eidolon/Handler/Login.hs

164 lines
5.8 KiB
Haskell
Raw Normal View History

2015-01-18 19:44:41 +00:00
-- 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
2015-01-21 09:00:18 +00:00
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
2015-01-18 19:44:41 +00:00
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
2016-11-19 09:42:56 +00:00
-- old hmac
import Crypto.HMAC as Old
2014-08-24 19:42:42 +00:00
import Crypto.Hash.CryptoAPI (SHA1)
2016-11-19 09:42:56 +00:00
-- new hmac
import Crypto.MAC.HMAC as New
2016-12-03 02:14:13 +00:00
import Crypto.Hash.Algorithms (Keccak_512)
2016-11-19 09:42:56 +00:00
2016-12-03 02:14:13 +00:00
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
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
2016-11-30 20:22:35 +00:00
import qualified Data.ByteString.Char8 as BC
2014-12-28 06:12:25 +00:00
import Data.Aeson.Types
2014-08-12 12:42:25 +00:00
2017-04-26 19:43:22 +00:00
-- getLoginR :: Handler Html
-- getLoginR = do
-- master <- getYesod
-- let addWarn = "http://" `T.isPrefixOf` appRoot (appSettings master)
-- (loginRawWidget, _) <- generateFormPost $
-- renderBootstrap3 BootstrapBasicForm loginForm
-- defaultLayout $ 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 $ getBy $ UniqueUser userName
-- case tempUser of
-- Just (Entity userId user) -> do
-- let salt = userSalt user
-- token <- liftIO makeRandomToken
-- runDB $ insert_ $ Token (encodeUtf8 token) "login" userName
-- 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 savedUserName = tokenUsername token
-- mqueriedUser <- runDB $ getBy $ UniqueUser savedUserName
-- let queriedUser = entityVal $ fromJust mqueriedUser
-- salted = userSalted queriedUser
-- hexSalted = toHex salted
-- expected = hmacKeccak (encodeUtf8 $ toHex $ tokenToken token) (encodeUtf8 hexSalted)
-- if encodeUtf8 hexResponse == expected
-- then do
-- -- Success!!
-- runDB $ delete tokenId
-- return $ Right $ (entityKey $ fromJust mqueriedUser)
-- 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 userId
-- setMessage "Succesfully logged in"
-- welcomeLink <- ($ProfileR userId) <$> getUrlRender
-- returnJson ["welcome" .= welcomeLink]
-- _ ->
-- returnJsonError ("Protocol error" :: T.Text)
getLoginRawR :: Handler Html
getLoginRawR = do
master <- getYesod
let addWarn = "http://" `T.isPrefixOf` appRoot (appSettings master)
(loginRawWidget, _) <- generateFormPost $
renderBootstrap3 BootstrapBasicForm loginForm
2016-08-30 12:22:00 +00:00
defaultLayout $ 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
postLoginRawR :: Handler Html
postLoginRawR = do
((res, _), _) <- runFormPost $
renderBootstrap3 BootstrapBasicForm loginForm
case res of
FormSuccess cred -> do
muser <- runDB $ getBy $ UniqueUser $ credentialsName cred
case muser of
Just (Entity uId user) -> do
let testSalted = BC.unpack $ hmacKeccak (userSalt user) (encodeUtf8 $ credentialsPasswd cred)
if fromHex' testSalted == userSalted user
then do
2017-04-26 19:43:22 +00:00
setCreds False $ Creds "raw" (userName user) []
setMessage "Successfully logged in"
redirect $ ProfileR uId
else do
setMessage "Wrong password"
2017-04-26 19:43:22 +00:00
redirect $ AuthR LoginR
Nothing -> do
setMessage "No such user"
2017-04-26 19:43:22 +00:00
redirect $ AuthR LoginR
_ -> do
setMessage "Login error"
2017-04-26 19:43:22 +00:00
redirect $ AuthR LoginR
data Credentials = Credentials
{ credentialsName :: Text
, credentialsPasswd :: Text
}
deriving Show
2014-08-12 16:14:59 +00:00
loginForm :: AForm Handler Credentials
loginForm = Credentials
<$> areq textField (bfs ("Username" :: T.Text)) Nothing
<*> areq passwordField (bfs ("Password" :: T.Text)) Nothing
<* bootstrapSubmit ("Login" :: BootstrapSubmit T.Text)
2014-08-12 16:14:59 +00:00
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"
2015-09-14 16:54:46 +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
2016-11-19 09:42:56 +00:00
2016-12-03 02:14:13 +00:00
hmacKeccak :: B.ByteString -> B.ByteString -> B.ByteString
hmacKeccak key msg = BC.pack $ show $ hmacGetDigest (New.hmac key msg :: HMAC Keccak_512)