strofication complete. it works!

This commit is contained in:
nek0 2014-08-24 21:42:42 +02:00
parent d98ec229cc
commit 7fd35f4b02
10 changed files with 260 additions and 78 deletions

View file

@ -1,20 +1,60 @@
module Handler.Activate where module Handler.Activate where
import Import as I import Import as I hiding (returnJson)
import Data.Text import Data.Text
import Data.Text.Encoding
import Data.Maybe
import System.Directory import System.Directory
import System.FilePath import System.FilePath
getActivateR :: Text -> Handler Html getActivateR :: Text -> Handler Html
getActivateR token = do getActivateR token = do
t <- runDB $ selectFirst [TokenToken ==. token] [] t <- runDB $ selectFirst [ActivatorToken ==. token] []
case t of case t of
Nothing -> do Nothing -> do
setMessage "Invalid Token!" setMessage "Invalid Token!"
redirect $ HomeR 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" .=)

View file

@ -1,7 +1,14 @@
module Handler.Login where 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 data Credentials = Credentials
{ credentialsName :: Text { credentialsName :: Text
@ -11,29 +18,59 @@ data Credentials = Credentials
getLoginR :: Handler Html getLoginR :: Handler Html
getLoginR = do getLoginR = do
(loginWidget, enctype) <- generateFormPost loginForm -- (loginWidget, enctype) <- generateFormPost loginForm
defaultLayout $ do defaultLayout $ do
$(widgetFile "login") $(widgetFile "login")
postLoginR :: Handler Html
postLoginR :: Handler RepJson
postLoginR = do 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 :: Form Credentials
loginForm = renderDivs $ Credentials loginForm = renderDivs $ Credentials
@ -45,3 +82,13 @@ getLogoutR = do
deleteSession "userId" deleteSession "userId"
setMessage "Succesfully logged out" setMessage "Succesfully logged out"
redirect $ HomeR 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

View file

@ -4,54 +4,72 @@ module Handler.Signup where
import Import as I import Import as I
import System.Random import System.Random
import Data.Text as T import Data.Text as T
import Data.Text.Encoding
import Data.ByteString as B
import Data.Maybe
import Network.Mail.Mime import Network.Mail.Mime
import Text.Blaze.Html.Renderer.Utf8 import Text.Blaze.Html.Renderer.Utf8
getSignupR :: Handler Html getSignupR :: Handler Html
getSignupR = do getSignupR = do
(signupWidget, enctype) <- generateFormPost signupForm -- (signupWidget, enctype) <- generateFormPost signupForm
defaultLayout $ do defaultLayout $ do
$(widgetFile "signup") $(widgetFile "signup")
postSignupR :: Handler Html postSignupR :: Handler Html
postSignupR = do 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)] [] False -> do
case (validateLen (userName user)) && ((I.length namesakes) == 0) of setMessage "Invalid username"
True -> do redirect $ SignupR
tokenString <- liftIO generateString mEmail <- lookupPostParam "email"
uId <- runDB $ insert $ Token tokenString user mTos1 <- lookupPostParam "tos-1"
activateLink <- ($ ActivateR tokenString) <$> getUrlRender mTos2 <- lookupPostParam "tos-2"
sendMail (userEmail user) "Please activate your account!" $ case (mTos1, mTos2) of
[shamlet| (Just "tos-1", Just "tos-2") ->
<h1> Welcome to Eidolon! return ()
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"
redirect $ SignupR
_ -> do _ -> do
setMessage "Please try again" setMessage "You need to agree to our terms."
redirect $ SignupR 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 :: Text -> Bool
validateLen a = validateLen a =
(T.length a) > 3 (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 :: MonadIO m => Text -> Text -> Html -> m ()
sendMail toEmail subject body = sendMail toEmail subject body =

View file

@ -2,6 +2,11 @@ module Helper
( getUserIdFromText ( getUserIdFromText
, extractKey , extractKey
-- , getUserNameById -- , getUserNameById
, fromHex
, fromHex'
, toHex
, makeRandomToken
, generateSalt
) )
where where
@ -9,22 +14,27 @@ import Prelude
import Model import Model
import Control.Applicative import Control.Applicative
import Control.Monad.Trans.Class import Control.Monad.Trans.Class
import Data.Text
import Data.Maybe 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
import Database.Persist.Types import Database.Persist.Types
import System.FilePath import System.FilePath
import System.Random
import Yesod.Persist.Core import Yesod.Persist.Core
import Yesod.Core.Types import Yesod.Core.Types
import Numeric (readHex, showHex)
getUserIdFromText :: Text -> UserId getUserIdFromText :: T.Text -> UserId
getUserIdFromText tempUserId = 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 extractKey = extractKey' . unKey
where where
extractKey' (PersistInt64 k) = pack $ show k extractKey' (PersistInt64 k) = T.pack $ show k
extractKey' _ = "" extractKey' _ = ""
--getUserNameById :: UserId -> Text --getUserNameById :: UserId -> Text
@ -33,3 +43,33 @@ extractKey = extractKey' . unKey
-- user = runDB $ getJust $ userId -- user = runDB $ getJust $ userId
-- in -- in
-- userName user -- 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

View file

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

View file

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

View file

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

View file

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

View file

@ -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">

View file

@ -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">