added raw login and activation without javascript.

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) =>
+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" .=) 

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
+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 = do

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

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:

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: