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