-- 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 -- old hmac import Crypto.HMAC as Old import Crypto.Hash.CryptoAPI (SHA1) -- new hmac import Crypto.MAC.HMAC as New import Crypto.Hash.Algorithms (Keccak_512) import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Serialize (encode) import Data.Maybe import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import Data.Aeson.Types -- 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 defaultLayout $ do setTitle "Eidolon :: Login" $(widgetFile "login") 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 setCreds False $ Creds "raw" (userName user) [] setMessage "Successfully logged in" redirect $ ProfileR uId else do setMessage "Wrong password" redirect $ AuthR LoginR Nothing -> do setMessage "No such user" redirect $ AuthR LoginR _ -> do setMessage "Login error" redirect $ AuthR LoginR data Credentials = Credentials { credentialsName :: Text , credentialsPasswd :: Text } deriving Show 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) 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 hmacKeccak :: B.ByteString -> B.ByteString -> B.ByteString hmacKeccak key msg = BC.pack $ show $ hmacGetDigest (New.hmac key msg :: HMAC Keccak_512)