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
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
userId <- runDB $ insert $ tokenUser (entityVal x)
liftIO $ createDirectoryIfMissing True $ "static" </> "data" </> (unpack $ extractKey userId)
runDB $ delete (entityKey x)
setMessage $ "User activated"
redirect $ HomeR
Just (Entity activatorKey activator) -> do
uSalt <- return $ userSalt $ activatorUser activator
mToken <- runDB $ selectFirst [TokenToken ==. (encodeUtf8 token), TokenKind ==. "activate"] []
case mToken of
Just (Entity uTokenId uToken) -> do
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
import Import
import Data.Text
import Import hiding (returnJson)
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
case result of
FormSuccess cred -> do
tuser <- runDB $ selectFirst [UserName ==. credentialsName cred] []
case tuser of
Just user -> do
case credentialsPasswd cred == userPassword (entityVal user) of
True -> do
setSession "userId" $ extractKey $ entityKey user
setMessage "Successfully logged in"
redirect $ HomeR
False -> do
setMessage $ "Login error"
redirect $ LoginR
Nothing -> do
setMessage "User does not exist"
redirect $ LoginR
mUserName <- lookupPostParam "username"
mHexToken <- lookupPostParam "token"
mHexResponse <- lookupPostParam "response"
case (mUserName, mHexToken, mHexResponse) of
(Just userName, Nothing, Nothing) -> do
tempUser <- runDB $ selectFirst [UserName ==. userName] []
case tempUser of
Just (Entity userId user) -> do
salt <- return $ userSalt user
token <- liftIO makeRandomToken
tokenId <- runDB $ insert $ Token (encodeUtf8 token) "login" (Just userId)
returnJson ["salt" .= (toHex salt), "token" .= (toHex $ encodeUtf8 token)]
Nothing ->
returnJsonError ("No such user" :: T.Text)
(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

View file

@ -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
case result of
FormSuccess user -> do
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
mUserName <- lookupPostParam "username"
newUserName <- case validateLen (fromJust mUserName) of
True -> return $ fromJust $ mUserName
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
signupForm = renderDivs $ User
<$> areq textField "Username" Nothing
<*> areq emailField "Email" Nothing
<*> areq passwordField "Password" Nothing
<*> pure []
-- create user
namesakes <- runDB $ selectList [UserName ==. newUserName] []
case namesakes of
[] -> do
salt <- liftIO generateSalt
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 = (T.pack . I.take 16 . randoms) <$> newStdGen
generateString :: IO T.Text
generateString = (toHex . B.pack . I.take 16 . randoms) <$> newStdGen
sendMail :: MonadIO m => Text -> Text -> Html -> m ()
sendMail toEmail subject body =

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -1,6 +1,18 @@
<h3>Login
$newline always
<form method=post enctype=#{enctype}>
^{loginWidget}
<div>
<input type=submit value="Login">
<section class="col">
<noscript>Please enable Javascript
<form class="login r">
<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 @@
$newline always
<div class="content">
<noscript>You need to have Javscript enabled</noscript>
<form class="signup" method="POST" action="/signup">
<h3>Signup
<form method=post enctype=#{enctype}>
^{signupWidget}
<div>
<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">