strofication complete. it works!

Handler/Activate.hs

@@ -1,20 +1,60 @@
 module Handler.Activate where
 
-import Import as I
+import Import as I hiding (returnJson)
 import Data.Text
+import Data.Text.Encoding
+import Data.Maybe
 import System.Directory
 import System.FilePath
 
 getActivateR :: Text -> Handler Html
 getActivateR token = do
-  t <- runDB $ selectFirst [TokenToken ==. token] []
+  t <- runDB $ selectFirst [ActivatorToken ==. token] []
   case t of
     Nothing -> do
       setMessage "Invalid Token!"
       redirect $ HomeR
-    Just x -> do
+    Just (Entity activatorKey activator) -> do
-      userId <- runDB $ insert $ tokenUser (entityVal x)
+      uSalt <- return $ userSalt $ activatorUser activator
-      liftIO $ createDirectoryIfMissing True $ "static" </> "data" </> (unpack $ extractKey userId)
+      mToken <- runDB $ selectFirst [TokenToken ==. (encodeUtf8 token), TokenKind ==. "activate"] []
-      runDB $ delete (entityKey x)
+      case mToken of
-      setMessage $ "User activated"
+        Just (Entity uTokenId uToken) -> do
-      redirect $ HomeR
+          hexSalt <- return $ toHex uSalt
+          defaultLayout $ do
+            $(widgetFile "activate")
+        _ -> do
+          returnJsonError "Invalid token!"
+          redirect $ ActivateR token
+
+postActivateR :: Text -> Handler RepJson
+postActivateR token = do
+  msalted <- fromJust <$> lookupPostParam "salted"
+  salted <- return $ fromHex' $ unpack msalted
+  mToken <- runDB $ selectFirst [TokenToken ==. (encodeUtf8 token), TokenKind ==. "activate"] []
+  case mToken of
+    Just (Entity uTokenId uToken) -> do
+      newUser <- runDB $ selectFirst [ActivatorToken ==. token] []
+      case newUser of
+        Just (Entity aId activ) -> do
+          -- putting user in active state
+          uId <- runDB $ insert $ activatorUser activ
+          runDB $ update uId [UserSalted =. (Just 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)
+          welcomeLink <- ($ ProfileR uId) <$> getUrlRender
+          returnJson ["welcome" .= welcomeLink]
+          -- redirect $ HomeR
+    _ -> do
+      returnJsonError "Invalid activation token!"
+
+returnJson :: (Monad m, ToJSON a, a ~ Value) =>
+              [(Text, a)] -> m RepJson
+returnJson = return . repJson . object
+
+returnJsonError :: Text -> Handler RepJson
+returnJsonError = returnJson . (:[]) . ("error" .=) 

Handler/Login.hs

@@ -1,7 +1,14 @@
 module Handler.Login where
 
-import Import
+import Import hiding (returnJson)
-import Data.Text
+import qualified Data.Text as T
+import Yesod hiding (returnJson)
+import Crypto.HMAC
+import Crypto.Hash.CryptoAPI (SHA1)
+import qualified Data.ByteString as B
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import Data.Serialize (encode)
+import Data.Maybe
 
 data Credentials = Credentials
   { credentialsName   :: Text
@@ -11,29 +18,59 @@ data Credentials = Credentials
 
 getLoginR :: Handler Html
 getLoginR = do
-  (loginWidget, enctype) <- generateFormPost loginForm
+--  (loginWidget, enctype) <- generateFormPost loginForm
   defaultLayout $ do
     $(widgetFile "login")
 
-postLoginR :: Handler Html
+
+postLoginR :: Handler RepJson
 postLoginR = do
-  ((result, loginWidget), enctype) <- runFormPost loginForm
+  mUserName <- lookupPostParam "username"
-  case result of
+  mHexToken <- lookupPostParam "token"
-    FormSuccess cred -> do
+  mHexResponse <- lookupPostParam "response"
-      tuser <- runDB $ selectFirst [UserName ==. credentialsName cred] []
+
-      case tuser of
+  case (mUserName, mHexToken, mHexResponse) of
-        Just user -> do
+    (Just userName, Nothing, Nothing) -> do
-          case credentialsPasswd cred == userPassword (entityVal user) of
+      tempUser <- runDB $ selectFirst [UserName ==. userName] []
-            True -> do
+      case tempUser of
-              setSession "userId" $ extractKey $ entityKey user
+        Just (Entity userId user) -> do
-              setMessage "Successfully logged in"
+          salt <- return $ userSalt user
-              redirect $ HomeR
+          token <- liftIO makeRandomToken
-            False -> do
+          tokenId <- runDB $ insert $ Token (encodeUtf8 token) "login" (Just userId)
-              setMessage $ "Login error"
+          returnJson ["salt" .= (toHex salt), "token" .= (toHex $ encodeUtf8 token)]
-              redirect $ LoginR
+        Nothing ->
-        Nothing -> do
+          returnJsonError ("No such user" :: T.Text)
-          setMessage "User does not exist"
+
-          redirect $ LoginR
+    (Nothing, Just hexToken, Just hexResponse) -> do
+      response <- do
+        tempToken <- return $ fromHex' $ T.unpack hexToken
+        savedToken <- runDB $ selectFirst [TokenKind ==. "login", TokenToken ==. tempToken] []
+        case savedToken of
+          Just (Entity tokenId token) -> do
+            savedUserId <- return $ tokenUser token
+            queriedUser <- runDB $ getJust (fromJust savedUserId)
+            salted <- return $ userSalted queriedUser
+            hexSalted <- return $ toHex $ fromJust salted
+            expected <- return $ hmacSHA1 (tokenToken token) (encodeUtf8 hexSalted)
+            case (fromHex' $ T.unpack hexResponse) == expected of
+              True ->
+                -- Success!!
+                return $ Right savedUserId
+              _    ->
+                return $ Left ("Wrong password" :: T.Text)
+          Nothing ->
+            return $ Left "Invalid token"
+      case response of
+        Left msg ->
+          returnJsonError msg
+        Right userId -> do
+          setSession "userId" $ extractKey (fromJust userId)
+          welcomeLink <- ($ProfileR (fromJust userId)) <$> getUrlRender
+          returnJson ["welcome" .= welcomeLink]
+
+    _ ->
+      returnJsonError ("Protocol error" :: T.Text)
+
 
 loginForm :: Form Credentials
 loginForm = renderDivs $ Credentials
@@ -45,3 +82,13 @@ getLogoutR = do
   deleteSession "userId"
   setMessage "Succesfully logged out"
   redirect $ HomeR
+
+returnJson = return . repJson . object
+
+returnJsonError = returnJson . (:[]) . ("error" .=)
+
+hmacSHA1 keyData msgData =
+  let key = MacKey keyData
+      sha1 :: SHA1
+      sha1 = hmac' key msgData
+  in encode sha1

Handler/Signup.hs

@@ -4,54 +4,72 @@ module Handler.Signup where
 import Import as I
 import System.Random
 import Data.Text as T
+import Data.Text.Encoding
+import Data.ByteString as B
+import Data.Maybe
 import Network.Mail.Mime
 import Text.Blaze.Html.Renderer.Utf8
 
 getSignupR :: Handler Html
 getSignupR = do
-  (signupWidget, enctype) <- generateFormPost signupForm
+--  (signupWidget, enctype) <- generateFormPost signupForm
   defaultLayout $ do
     $(widgetFile "signup")
 
 postSignupR :: Handler Html
 postSignupR = do
-  ((result, signupWidget), enctype) <- runFormPost signupForm
+  mUserName <- lookupPostParam "username"
-  case result of
+  newUserName <- case validateLen (fromJust mUserName) of
-    FormSuccess user -> do
+    True -> return $ fromJust $ mUserName
-      namesakes <- runDB $ selectList [UserName ==. (userName user)] []
-      case (validateLen (userName user)) && ((I.length namesakes) == 0) of
-        True -> do
-          tokenString <- liftIO generateString
-          uId <- runDB $ insert $ Token tokenString user
-          activateLink <- ($ ActivateR tokenString) <$> getUrlRender
-          sendMail (userEmail user) "Please activate your account!" $
-            [shamlet|
-              <h1> Welcome to Eidolon!
-              To complete your sgnup please activate your account by visiting the following link
-              <a href="#{activateLink}">#{activateLink}
-            |]
-          setMessage "User created"
-          redirect $ HomeR
     False -> do
-          setMessage "Username error"
+      setMessage "Invalid username"
       redirect $ SignupR
+  mEmail <- lookupPostParam "email"
+  mTos1 <- lookupPostParam "tos-1"
+  mTos2 <- lookupPostParam "tos-2"
+  case (mTos1, mTos2) of
+    (Just "tos-1", Just "tos-2") ->
+      return ()
     _ -> do
-      setMessage "Please try again"
+      setMessage "You need to agree to our terms."
       redirect $ SignupR
 
-signupForm :: Form User
+  -- create user
-signupForm = renderDivs $ User
+  namesakes <- runDB $ selectList [UserName ==. newUserName] []
-  <$> areq textField "Username" Nothing
+  case namesakes of
-  <*> areq emailField "Email" Nothing
+    [] -> do
-  <*> areq passwordField "Password" Nothing
+      salt <- liftIO generateSalt
-  <*> pure []
+      newUser <- return $ User newUserName (fromJust mEmail) "" salt Nothing []
+      activatorText <- liftIO generateString
+      aId <- runDB $ insert $ Activator activatorText newUser
+      tId <- runDB $ insert $ Token (encodeUtf8 activatorText) "activate" Nothing
+      activateLink <- ($ ActivateR activatorText) <$> getUrlRender
+      sendMail (userEmail newUser) "Please activate your account!" $
+        [shamlet|
+          <h1> Welcome to Eidolon!
+          To complete your sgnup please activate your account by visiting the following link:
+          <a href="#{activateLink}">#{activateLink}
+        |]
+      setMessage "User pending activation"
+      redirect $ HomeR
+    _ -> do
+      setMessage "This user already exists"
+      redirect $ SignupR
+
+--signupForm :: Form User
+--signupForm = renderDivs $ User
+--  <$> areq textField "Username" Nothing
+--  <*> areq emailField "Email" Nothing
+--  <*> areq passwordField "Password" Nothing
+--  <*> pure ("" :: ByteString)
+--  <*> pure []
 
 validateLen :: Text -> Bool
 validateLen a =
   (T.length a) > 3
 
-generateString :: IO Text
+generateString :: IO T.Text
-generateString = (T.pack . I.take 16 . randoms) <$> newStdGen
+generateString = (toHex . B.pack . I.take 16 . randoms) <$> newStdGen
 
 sendMail :: MonadIO m => Text -> Text -> Html -> m ()
 sendMail toEmail subject body =

Helper.hs

@@ -2,6 +2,11 @@ module Helper
   ( getUserIdFromText
   , extractKey
 --  , getUserNameById
+  , fromHex
+  , fromHex'
+  , toHex
+  , makeRandomToken
+  , generateSalt
   )
 where
 
@@ -9,22 +14,27 @@ import Prelude
 import Model
 import Control.Applicative
 import Control.Monad.Trans.Class
-import Data.Text
 import Data.Maybe
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.Text as T
 import Database.Persist
 import Database.Persist.Types
 import System.FilePath
+import System.Random
 import Yesod.Persist.Core
 import Yesod.Core.Types
+import Numeric (readHex, showHex)
 
-getUserIdFromText :: Text -> UserId
+getUserIdFromText :: T.Text -> UserId
 getUserIdFromText tempUserId =
-  Key $ PersistInt64 $ fromIntegral $ read $ unpack tempUserId
+  Key $ PersistInt64 $ fromIntegral $ read $ T.unpack tempUserId
 
-extractKey :: KeyBackend backend entity -> Text
+extractKey :: KeyBackend backend entity -> T.Text
 extractKey = extractKey' . unKey
   where
-    extractKey' (PersistInt64 k) = pack $ show k
+    extractKey' (PersistInt64 k) = T.pack $ show k
     extractKey' _ = ""
 
 --getUserNameById :: UserId -> Text
@@ -33,3 +43,33 @@ extractKey = extractKey' . unKey
 --    user = runDB $ getJust $ userId
 --  in
 --    userName user
+
+fromHex :: String -> BL.ByteString
+fromHex = BL.pack . hexToWords
+  where hexToWords (c:c':text) =
+          let hex = [c, c']
+              word = case readHex hex of
+                     (d,_):_ -> d
+                     []      -> error "empty list"
+                     _       -> error "fuckup"
+--              (word, _):_ = readHex hex
+          in word : hexToWords text
+        hexToWords _ = []
+
+-- strict variant
+
+fromHex' :: String -> B.ByteString
+fromHex' = B.concat . BL.toChunks . fromHex
+
+toHex :: B.ByteString -> T.Text
+toHex = T.pack . concatMap mapByte . B.unpack
+  where mapByte = pad 2 '0' . flip showHex ""
+        pad len padding s
+          | length s < len = pad len padding $ padding:s
+          | otherwise = s
+
+makeRandomToken :: IO T.Text
+makeRandomToken = (T.pack . take 16 . randoms) `fmap` newStdGen
+
+generateSalt :: IO B.ByteString
+generateSalt = (B.pack . take 8 . randoms) <$> getStdGen

Model.hs

@@ -5,6 +5,7 @@ import Data.Text (Text)
 import Database.Persist.Quasi
 import Data.Typeable (Typeable)
 import Data.Time (UTCTime)
+import Data.ByteString
 import System.FilePath (FilePath)
 
 -- You can define all of your database entities in the entities file.

config/models

@@ -2,12 +2,19 @@ User
     name Text
     email Text
     password Text
+    salt ByteString
+    salted ByteString Maybe
     albums [AlbumId]
     deriving Typeable
-Token
+Activator
     token Text
     user User
     deriving
+Token
+    token ByteString
+    kind Text
+    user UserId Maybe
+    deriving
 Album
     title Text
     owner UserId
@@ -20,7 +27,7 @@ Medium
     time UTCTime
     owner UserId
     description Textarea
-    tags [Text]
+    tags Texts
     album AlbumId
     deriving
 

config/routes

@@ -7,7 +7,7 @@
 /signup				SignupR		GET POST
 /login				LoginR		GET POST
 /logout				LogoutR		GET
-/activate/#Text			ActivateR	GET
+/activate/#Text			ActivateR	GET POST
 /profile/#UserId		ProfileR	GET
 /user/#Text			UserR		GET
 /upload				UploadR		GET POST

eidolon.cabal

@@ -85,6 +85,9 @@ library
                  , yesod-persistent
                  , transformers
                  , old-locale
+                 , cereal
+                 , cryptohash-cryptoapi
+                 , crypto-api
 
 executable         eidolon
     if flag(library-only)

templates/login.hamlet

@@ -1,6 +1,18 @@
-<h3>Login
+$newline always
 
-<form method=post enctype=#{enctype}>
+<section class="col">
-  ^{loginWidget}
+  <noscript>Please enable Javascript
-  <div>
+  <form class="login r">
-    <input type=submit value="Login">
+    <h3>Login
+    <p>
+      <label for="username">User:
+      <input id="username" type="text" required>
+    <p>
+      <label for="password">Password:
+      <input id="password" type="password" required>
+    <p id="progress">
+    <input id="login" type="submit" value="Login">
+
+  <script src="/static/js/jquery-1.7.1.min.js" type="text/javascript">
+  <script src="/static/js/jsSHA.js" type="text/javascript">
+  <script src="/static/js/login.js" type="text/javascript">

templates/signup.hamlet

@@ -1,6 +1,20 @@
-<h3>Signup
+$newline always
-
+<div class="content">
-<form method=post enctype=#{enctype}>
+  <noscript>You need to have Javscript enabled</noscript>
-  ^{signupWidget}
+  <form class="signup" method="POST" action="/signup">
-  <div>
+    <h3>Signup
-    <input type=submit value="Register">
+    <p>
+      <label for="username">Username:
+      <input id="username" name="username" type="text" required>
+    <p>
+      <label for="email">E-Mail:
+      <input id="email" name="email" type="email" required>
+    <p class="tos">
+      <input type="checkbox" id="tos-1" name="tos-1" value="tos-1" required>
+      <label for="tos-1">terms of service 1
+    <p class="tos">
+      <input type="checkbox" id="tos-2" name="tos-2" value="tos-2" required>
+      <label for="tos-2">terms of service 2
+    <input id="signup" type="submit" value="Signup">
+  <script src="/static/js/jquery-1.7.1.min.js" type="text/javascript">
+  <script src="/static/js/signup.js" type="text/javascript">