113 lines
3.9 KiB
Haskell
113 lines
3.9 KiB
Haskell
-- 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
|