diff --git a/Handler/Activate.hs b/Handler/Activate.hs index 97e89fb..3cde985 100755 --- a/Handler/Activate.hs +++ b/Handler/Activate.hs @@ -22,9 +22,15 @@ import Data.Maybe import System.Directory import System.FilePath +import qualified Data.ByteString.Char8 as BC + +import Handler.Login + getActivateR :: Text -> Handler Html getActivateR token = do t <- runDB $ selectFirst [ActivatorToken ==. token] [] + (activateRawWidget, _) <- generateFormPost $ + renderBootstrap3 BootstrapBasicForm activateForm case t of Nothing -> do mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] [] @@ -32,6 +38,8 @@ getActivateR token = do Just (Entity _ uToken) -> do user <- runDB $ getJust (fromJust $ tokenUser uToken) let hexSalt = toHex $ userSalt user + master <- getYesod + let addWarn = "http://" `isPrefixOf` appRoot (appSettings master) defaultLayout $ do setTitle "Activate your account" $(widgetFile "activate") @@ -44,6 +52,8 @@ getActivateR token = do case mToken of Just (Entity _ _) -> do let hexSalt = toHex uSalt + master <- getYesod + let addWarn = "http://" `isPrefixOf` appRoot (appSettings master) defaultLayout $ $(widgetFile "activate") _ -> do @@ -84,9 +94,9 @@ postActivateR token = do -- cleanup runDB $ delete aId 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 -> - returnJsonError "Invalid token" + returnJsonError ("Invalid token" :: String) else do runDB $ update (fromJust $ tokenUser uToken) [UserSalted =. salted] -- cleanup @@ -95,11 +105,85 @@ postActivateR token = do welcomeLink <- ($ ProfileR (fromJust $ tokenUser uToken)) <$> getUrlRender returnJson ["welcome" .= welcomeLink] _ -> - returnJsonError "Invalid activation token!" + returnJsonError ("Invalid activation token!" :: String) -returnJson :: (Monad m, a ~ Value) => - [(Text, a)] -> m RepJson -returnJson = return . repJson . object +data ActivateFormRes = ActivateFormRes + { pass1 :: Text + , pass2 :: Text + } -returnJsonError :: Text -> Handler RepJson -returnJsonError = returnJson . (:[]) . ("error" .=) +activateForm :: AForm Handler ActivateFormRes +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" .=) diff --git a/Handler/Login.hs b/Handler/Login.hs index 3ebdafe..94a2b67 100755 --- a/Handler/Login.hs +++ b/Handler/Login.hs @@ -34,14 +34,12 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Data.Aeson.Types -data Credentials = Credentials - { credentialsName :: Text - , credentialsPasswd :: Text - } - deriving Show - getLoginR :: Handler Html -getLoginR = +getLoginR = do + master <- getYesod + let addWarn = "http://" `T.isPrefixOf` appRoot (appSettings master) + (loginRawWidget, _) <- generateFormPost $ + renderBootstrap3 BootstrapBasicForm loginForm defaultLayout $ do setTitle "Eidolon :: Login" $(widgetFile "login") @@ -94,11 +92,42 @@ postLoginR = do _ -> 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 -loginForm = renderDivs $ Credentials - <$> areq textField "Username" Nothing - <*> areq passwordField "Password" Nothing +data Credentials = Credentials + { credentialsName :: Text + , credentialsPasswd :: Text + } + 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 = do diff --git a/config/routes b/config/routes index 41da5fc..08c586f 100755 --- a/config/routes +++ b/config/routes @@ -23,8 +23,10 @@ /page/#Int PageR GET /signup SignupR GET POST /login LoginR GET POST +/loginraw LoginRawR POST /logout LogoutR GET /activate/#T.Text ActivateR GET POST +/activateraw/#T.Text ActivateRawR POST /profile/#UserId ProfileR GET /user/#T.Text UserR GET /user/#T.Text/album/#T.Text BeautyAlbumR GET diff --git a/templates/activate.hamlet b/templates/activate.hamlet index 1f7cd9d..cbfcd32 100755 --- a/templates/activate.hamlet +++ b/templates/activate.hamlet @@ -1,7 +1,18 @@ $newline always

Activate your account -
You need to have Javascript enabled
+
+
+ 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. +
+ ^{activateRawWidget} +