added raw login and activation without javascript.

2017-01-07 21:57:28 +01:00 · 2017-01-07 21:57:28 +01:00 · 48bfe94ef7
commit 48bfe94ef7
parent 4dde6edfb1
5 changed files with 157 additions and 21 deletions
--- 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" .=) 
--- 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
--- 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
--- a/templates/activate.hamlet
+++ b/templates/activate.hamlet
@ -1,7 +1,18 @@
 $newline always
 <div .medium>
  <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>
    <div .form-group .required>
      <label for="password1">Password:
--- a/templates/login.hamlet
+++ b/templates/login.hamlet
@ -1,7 +1,17 @@
 $newline always
 <div .medium>
  <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>
    <div .form-group .required>
      <label for="username">User: