eidolon/Handler/Login.hs

100 lines
3.2 KiB
Haskell
Raw Normal View History

2014-08-12 12:42:25 +00:00
module Handler.Login where
2014-08-24 19:42:42 +00:00
import Import hiding (returnJson)
import qualified Data.Text as T
import Crypto.HMAC
import Crypto.Hash.CryptoAPI (SHA1)
2014-12-28 06:12:25 +00:00
import Data.Text.Encoding (encodeUtf8)
2014-08-24 19:42:42 +00:00
import Data.Serialize (encode)
import Data.Maybe
2014-12-28 06:12:25 +00:00
import qualified Data.ByteString as B
import Data.Aeson.Types
2014-08-12 12:42:25 +00:00
2014-08-12 16:14:59 +00:00
data Credentials = Credentials
{ credentialsName :: Text
, credentialsPasswd :: Text
}
deriving Show
2014-08-12 12:42:25 +00:00
getLoginR :: Handler Html
2014-08-12 16:14:59 +00:00
getLoginR = do
2014-08-24 19:42:42 +00:00
-- (loginWidget, enctype) <- generateFormPost loginForm
formLayout $ do
2014-09-24 21:03:18 +00:00
setTitle "Eidolon :: Login"
2014-08-12 16:14:59 +00:00
$(widgetFile "login")
2014-08-12 12:42:25 +00:00
2014-08-24 19:42:42 +00:00
postLoginR :: Handler RepJson
2014-08-12 16:14:59 +00:00
postLoginR = do
2014-08-24 19:42:42 +00:00
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
2014-12-28 06:12:25 +00:00
_ <- runDB $ insert $ Token (encodeUtf8 token) "login" (Just userId)
2014-08-24 19:42:42 +00:00
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
2014-08-26 02:37:56 +00:00
hexSalted <- return $ toHex salted
2014-08-24 19:42:42 +00:00
expected <- return $ hmacSHA1 (tokenToken token) (encodeUtf8 hexSalted)
case (fromHex' $ T.unpack hexResponse) == expected of
2014-09-05 18:40:47 +00:00
True -> do
2014-08-24 19:42:42 +00:00
-- Success!!
2014-09-05 18:40:47 +00:00
runDB $ delete tokenId
2014-08-24 19:42:42 +00:00
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)
2014-08-12 16:14:59 +00:00
loginForm :: Form Credentials
loginForm = renderDivs $ Credentials
<$> areq textField "Username" Nothing
<*> areq passwordField "Password" Nothing
getLogoutR :: Handler Html
getLogoutR = do
2014-08-13 20:30:48 +00:00
deleteSession "userId"
2014-08-15 13:47:16 +00:00
setMessage "Succesfully logged out"
2014-08-12 16:14:59 +00:00
redirect $ HomeR
2014-08-24 19:42:42 +00:00
2014-12-28 06:12:25 +00:00
returnJson :: Monad m => [Pair] -> m RepJson
2014-08-24 19:42:42 +00:00
returnJson = return . repJson . object
2014-12-28 06:12:25 +00:00
returnJsonError :: (ToJSON a, Monad m) => a -> m RepJson
2014-08-24 19:42:42 +00:00
returnJsonError = returnJson . (:[]) . ("error" .=)
2014-12-28 06:12:25 +00:00
hmacSHA1 :: B.ByteString -> B.ByteString -> B.ByteString
2014-08-24 19:42:42 +00:00
hmacSHA1 keyData msgData =
let key = MacKey keyData
sha1 :: SHA1
sha1 = hmac' key msgData
in encode sha1