eidolon/Handler/Login.hs

114 lines
3.9 KiB
Haskell
Executable File

-- eidolon -- A simple gallery in Haskell and Yesod
-- Copyright (C) 2015 Amedeo Molnár
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published
-- by the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
module Handler.Login where
import Import hiding (returnJson)
import qualified Data.Text as T
import Crypto.HMAC
import Crypto.Hash.CryptoAPI (SHA1)
import Data.Text.Encoding (encodeUtf8)
import Data.Serialize (encode)
import Data.Maybe
import qualified Data.ByteString as B
import Data.Aeson.Types
data Credentials = Credentials
{ credentialsName :: Text
, credentialsPasswd :: Text
}
deriving Show
getLoginR :: Handler Html
getLoginR =
formLayout $ do
setTitle "Eidolon :: Login"
$(widgetFile "login")
postLoginR :: Handler RepJson
postLoginR = do
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
let salt = userSalt user
token <- liftIO makeRandomToken
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
let tempToken = fromHex' $ T.unpack hexToken
savedToken <- runDB $ selectFirst [TokenKind ==. "login", TokenToken ==. tempToken] []
case savedToken of
Just (Entity tokenId token) -> do
let savedUserId = tokenUser token
queriedUser <- runDB $ getJust (fromJust savedUserId)
let salted = userSalted queriedUser
let hexSalted = toHex salted
let expected = hmacSHA1 (tokenToken token) (encodeUtf8 hexSalted)
if
fromHex' (T.unpack hexResponse) == expected
then do
-- Success!!
runDB $ delete tokenId
return $ Right savedUserId
else
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)
setMessage "Succesfully logged in"
welcomeLink <- ($ProfileR (fromJust userId)) <$> getUrlRender
returnJson ["welcome" .= welcomeLink]
_ ->
returnJsonError ("Protocol error" :: T.Text)
loginForm :: Form Credentials
loginForm = renderDivs $ Credentials
<$> areq textField "Username" Nothing
<*> areq passwordField "Password" Nothing
getLogoutR :: Handler Html
getLogoutR = do
deleteSession "userId"
setMessage "Succesfully logged out"
redirect HomeR
returnJson :: Monad m => [Pair] -> m RepJson
returnJson = return . repJson . object
returnJsonError :: (ToJSON a, Monad m) => a -> m RepJson
returnJsonError = returnJson . (:[]) . ("error" .=)
hmacSHA1 :: B.ByteString -> B.ByteString -> B.ByteString
hmacSHA1 keyData msgData =
let key = MacKey keyData
sha1 :: SHA1
sha1 = hmac' key msgData
in encode sha1