added raw login and activation without javascript.

This commit is contained in:
nek0 2017-01-07 21:57:28 +01:00
parent 4dde6edfb1
commit 48bfe94ef7
5 changed files with 157 additions and 21 deletions

View file

@ -22,9 +22,15 @@ import Data.Maybe
import System.Directory import System.Directory
import System.FilePath import System.FilePath
import qualified Data.ByteString.Char8 as BC
import Handler.Login
getActivateR :: Text -> Handler Html getActivateR :: Text -> Handler Html
getActivateR token = do getActivateR token = do
t <- runDB $ selectFirst [ActivatorToken ==. token] [] t <- runDB $ selectFirst [ActivatorToken ==. token] []
(activateRawWidget, _) <- generateFormPost $
renderBootstrap3 BootstrapBasicForm activateForm
case t of case t of
Nothing -> do Nothing -> do
mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] [] mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] []
@ -32,6 +38,8 @@ getActivateR token = do
Just (Entity _ uToken) -> do Just (Entity _ uToken) -> do
user <- runDB $ getJust (fromJust $ tokenUser uToken) user <- runDB $ getJust (fromJust $ tokenUser uToken)
let hexSalt = toHex $ userSalt user let hexSalt = toHex $ userSalt user
master <- getYesod
let addWarn = "http://" `isPrefixOf` appRoot (appSettings master)
defaultLayout $ do defaultLayout $ do
setTitle "Activate your account" setTitle "Activate your account"
$(widgetFile "activate") $(widgetFile "activate")
@ -44,6 +52,8 @@ getActivateR token = do
case mToken of case mToken of
Just (Entity _ _) -> do Just (Entity _ _) -> do
let hexSalt = toHex uSalt let hexSalt = toHex uSalt
master <- getYesod
let addWarn = "http://" `isPrefixOf` appRoot (appSettings master)
defaultLayout $ defaultLayout $
$(widgetFile "activate") $(widgetFile "activate")
_ -> do _ -> do
@ -84,9 +94,9 @@ postActivateR token = do
-- cleanup -- cleanup
runDB $ delete aId runDB $ delete aId
runDB $ delete uTokenId runDB $ delete uTokenId
returnJsonError "Somebody already activated your username. Your token has been deleted" returnJsonError ("Somebody already activated your username. Your token has been deleted" :: String)
Nothing -> Nothing ->
returnJsonError "Invalid token" returnJsonError ("Invalid token" :: String)
else do else do
runDB $ update (fromJust $ tokenUser uToken) [UserSalted =. salted] runDB $ update (fromJust $ tokenUser uToken) [UserSalted =. salted]
-- cleanup -- cleanup
@ -95,11 +105,85 @@ postActivateR token = do
welcomeLink <- ($ ProfileR (fromJust $ tokenUser uToken)) <$> getUrlRender welcomeLink <- ($ ProfileR (fromJust $ tokenUser uToken)) <$> getUrlRender
returnJson ["welcome" .= welcomeLink] returnJson ["welcome" .= welcomeLink]
_ -> _ ->
returnJsonError "Invalid activation token!" returnJsonError ("Invalid activation token!" :: String)
returnJson :: (Monad m, a ~ Value) => data ActivateFormRes = ActivateFormRes
[(Text, a)] -> m RepJson { pass1 :: Text
returnJson = return . repJson . object , pass2 :: Text
}
returnJsonError :: Text -> Handler RepJson activateForm :: AForm Handler ActivateFormRes
returnJsonError = returnJson . (:[]) . ("error" .=) activateForm = ActivateFormRes
<$> areq passwordField (bfs ("Password" :: Text)) Nothing
<*> areq passwordField (bfs ("Repeat Password" :: Text)) Nothing
<* bootstrapSubmit ("Activate" :: BootstrapSubmit Text)
postActivateRawR :: Text -> Handler Html
postActivateRawR token = do
((res, _), _) <- runFormPost $
renderBootstrap3 BootstrapBasicForm activateForm
case res of
FormSuccess pwd -> do
if pass1 pwd == pass2 pwd
then do
mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] []
case mToken of
Just (Entity uTokenId uToken) ->
if
isNothing (tokenUser uToken)
then do
newUser <- runDB $ selectFirst [ActivatorToken ==. token] []
case newUser of
Just (Entity aId activ) -> do
namesakes <- runDB $ selectList [UserName ==. userName (activatorUser activ)] []
if
I.null namesakes
then do
let salted = fromHex' $ BC.unpack $ hmacKeccak (userSalt $ activatorUser activ) (encodeUtf8 $ pass1 pwd)
-- putting user in active state
uId <- runDB $ insert $ activatorUser activ
runDB $ update uId [UserSalted =. salted]
-- create user directory
liftIO $ createDirectoryIfMissing True $
"static" </> "data" </> unpack (extractKey uId)
-- cleanup
runDB $ delete aId
runDB $ delete uTokenId
-- login and redirect
setSession "userId" (extractKey uId)
setMessage "Successfully activated"
redirect $ ProfileR uId
else do
-- cleanup
runDB $ delete aId
runDB $ delete uTokenId
setMessage "Somebody already activated your username. Your token has been deleted"
redirect HomeR
Nothing -> do
setMessage "Invalid token"
redirect HomeR
else do
uuser <- runDB $ getJust $ fromJust $ tokenUser uToken
let salted = fromHex' $ BC.unpack $ hmacKeccak (userSalt uuser) (encodeUtf8 $ pass1 pwd)
runDB $ update (fromJust $ tokenUser uToken) [UserSalted =. salted]
-- cleanup
runDB $ delete uTokenId
setSession "userId" (extractKey $ fromJust $ tokenUser uToken)
setMessage "Successfully activated"
redirect $ ProfileR (fromJust $ tokenUser uToken)
Nothing -> do
setMessage "Invalid activation token!"
redirect HomeR
else do
setMessage "Passwords must match!"
redirect $ ActivateR token
_ -> do
setMessage "Activation error"
redirect HomeR
-- returnJson :: (Monad m, a ~ Value) =>
-- [(Text, a)] -> m RepJson
-- returnJson = return . repJson . object
-- returnJsonError :: Text -> Handler RepJson
-- returnJsonError = returnJson . (:[]) . ("error" .=)

View file

@ -34,14 +34,12 @@ import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Char8 as BC
import Data.Aeson.Types import Data.Aeson.Types
data Credentials = Credentials
{ credentialsName :: Text
, credentialsPasswd :: Text
}
deriving Show
getLoginR :: Handler Html getLoginR :: Handler Html
getLoginR = getLoginR = do
master <- getYesod
let addWarn = "http://" `T.isPrefixOf` appRoot (appSettings master)
(loginRawWidget, _) <- generateFormPost $
renderBootstrap3 BootstrapBasicForm loginForm
defaultLayout $ do defaultLayout $ do
setTitle "Eidolon :: Login" setTitle "Eidolon :: Login"
$(widgetFile "login") $(widgetFile "login")
@ -94,11 +92,42 @@ postLoginR = do
_ -> _ ->
returnJsonError ("Protocol error" :: T.Text) returnJsonError ("Protocol error" :: T.Text)
postLoginRawR :: Handler Html
postLoginRawR = do
((res, _), _) <- runFormPost $
renderBootstrap3 BootstrapBasicForm loginForm
case res of
FormSuccess cred -> do
muser <- runDB $ getBy $ UniqueUser $ credentialsName cred
case muser of
Just (Entity uId user) -> do
let testSalted = BC.unpack $ hmacKeccak (userSalt user) (encodeUtf8 $ credentialsPasswd cred)
if fromHex' testSalted == userSalted user
then do
setSession "userId" $ extractKey uId
setMessage "Successfully logged in"
redirect $ ProfileR uId
else do
setMessage "Wrong password"
redirect LoginR
Nothing -> do
setMessage "No such user"
redirect LoginR
_ -> do
setMessage "Login error"
redirect LoginR
loginForm :: Form Credentials data Credentials = Credentials
loginForm = renderDivs $ Credentials { credentialsName :: Text
<$> areq textField "Username" Nothing , credentialsPasswd :: Text
<*> areq passwordField "Password" Nothing }
deriving Show
loginForm :: AForm Handler Credentials
loginForm = Credentials
<$> areq textField (bfs ("Username" :: T.Text)) Nothing
<*> areq passwordField (bfs ("Password" :: T.Text)) Nothing
<* bootstrapSubmit ("Login" :: BootstrapSubmit T.Text)
getLogoutR :: Handler Html getLogoutR :: Handler Html
getLogoutR = do getLogoutR = do

View file

@ -23,8 +23,10 @@
/page/#Int PageR GET /page/#Int PageR GET
/signup SignupR GET POST /signup SignupR GET POST
/login LoginR GET POST /login LoginR GET POST
/loginraw LoginRawR POST
/logout LogoutR GET /logout LogoutR GET
/activate/#T.Text ActivateR GET POST /activate/#T.Text ActivateR GET POST
/activateraw/#T.Text ActivateRawR POST
/profile/#UserId ProfileR GET /profile/#UserId ProfileR GET
/user/#T.Text UserR GET /user/#T.Text UserR GET
/user/#T.Text/album/#T.Text BeautyAlbumR GET /user/#T.Text/album/#T.Text BeautyAlbumR GET

View file

@ -1,7 +1,18 @@
$newline always $newline always
<div .medium> <div .medium>
<h3>Activate your account <h3>Activate your account
<div .noscript .redbox>You need to have Javascript enabled<br/> <div .noscript>
<div .redbox>
You are activating without JavaScript!
$if addWarn
Your password will be sent completely unencrypted! There is no TLS to
wrap your connection in!
$else
Your password will be sent unencrypted within a TLS connection. Check
your connection for leaks before proceeding.
<form method="post" action=@{ActivateRawR token}>
^{activateRawWidget}
<form .js-hidden> <form .js-hidden>
<div .form-group .required> <div .form-group .required>
<label for="password1">Password: <label for="password1">Password:

View file

@ -1,7 +1,17 @@
$newline always $newline always
<div .medium> <div .medium>
<h3>Login <h3>Login
<div .noscript .redbox>Please enable Javascript to log in<br/> <div .noscript>
<div .redbox>
You are logging in without JavaScript!
$if addWarn
Your password will be sent completely unencrypted! There is no TLS to
wrap your connection in!
$else
Your password will be sent unencrypted within a TLS connection. Check
your connection for leaks before proceeding.
<form method="post" action=@{LoginRawR}>
^{loginRawWidget}
<form .js-hidden> <form .js-hidden>
<div .form-group .required> <div .form-group .required>
<label for="username">User: <label for="username">User: