{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} module Control.Auth where import Servant import Servant.Client import Servant.Client.Core.Auth (mkAuthenticatedRequest) import qualified Data.Text as T import Data.Text.I18n import Data.String (fromString) import Data.Maybe (fromMaybe) import Data.Either (isRight, rights, lefts) import Control.Monad.Reader (ask) import Control.Monad.IO.Class (liftIO) -- imports from "mateamt" import qualified "mateamt" Types as MT -- internal imports import Types import View import Util import Client import ClientAuth import API import Hash authControl :: Maybe T.Text -> Maybe T.Text -> UserHandler (Headers '[ Header "Set-Cookie" T.Text , Header "Set-Cookie" T.Text ] AuthPage) authControl mcookie mDestination = do let mParsedCookie = fmap parseCookieText mcookie mAuthUser = lookup "x-auth-user" =<< mParsedCookie mToken = lookup "x-token" =<< mParsedCookie case (mAuthUser, mToken) of (Just authUser, Just _) -> throwError $ case mDestination of Just destination -> err303 { errHeaders = [ ("Location", fromString (T.unpack destination)) ] } Nothing -> redirect303 (userOverviewLink (read $ T.unpack authUser) Nothing ) (Just authUser, Nothing) -> do (ReadState _ backend _ _ _) <- ask let trs = map (MT.TicketRequest (read (T.unpack authUser) :: Int)) passes passes = [ MT.PrimaryPass , MT.SecondaryPass ] eAuthInfos <- zip passes <$> liftIO (mapM (\req -> runClientM (authGet req) backend ) trs ) if any (isRight . snd) eAuthInfos then digestAuthInfo (uncurry zip $ (\(as, bs) -> (as, rights bs)) $ unzip eAuthInfos) else throwError $ err400 { errBody = fromString $ show $ lefts $ map snd eAuthInfos } (Nothing, _) -> error "Error handling not yet implemented properly." where digestAuthInfo :: [(MT.AuthMethod, MT.AuthInfo)] -> UserHandler (Headers '[ Header "Set-Cookie" T.Text , Header "Set-Cookie" T.Text ] AuthPage) digestAuthInfo tupAuthInfos = do (ReadState l10n _ _ _ version) <- ask let loc = Locale (fromMaybe "en" $ lookup "locale" =<< fmap parseCookieText mcookie) ticketHeaders = map (\(method, MT.AuthInfo _ (MT.AuthTicket ticket)) -> "x-ticket-"<> fromString (show $ fromEnum method) <>"=" <> fromString (T.unpack ticket) <> ";Path=/") tupAuthInfos return $ addHeader (head ticketHeaders) $ addHeader (ticketHeaders !! 1) $ authPage l10n loc mDestination version mcookie authPostControl :: Maybe T.Text -> Maybe T.Text -> AuthReturn -> UserHandler UserSelectPage authPostControl mcookies@(Just cookies) mDestination (AuthReturn pass method) = do let mticket = lookup ("x-ticket-" <> fromString (show method)) $ parseCookieText cookies (_, _, loc, l10n, _, _, _) <- controlInit mcookies case mticket of Just ticket -> do (ReadState _ backend _ _ _) <- ask hashedPass <- hashPassword pass etoken <- liftIO $ runClientM (authSend (MT.AuthRequest (MT.AuthTicket ticket) (MT.AuthResponse hashedPass) ) ) backend case etoken of Right (MT.Granted (MT.AuthToken token)) -> do let mUser = lookup "x-auth-user" $ parseCookieText cookies headers = case (mDestination, mUser) of (Just destination, _) -> [ ("Location", fromString (T.unpack destination)) ] (Nothing, Just user) -> errHeaders $ redirect303 (userOverviewLink (read $ T.unpack user) Nothing ) _ -> errHeaders $ redirect303 (userSelectLink Nothing) throwError $ err303 { errHeaders = headers ++ [ ( "Set-Cookie" , "x-ticket-0=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT") , ( "Set-Cookie" , "x-ticket-1=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT") , ( "Set-Cookie" , "x-token=" <> fromString (T.unpack token) <>";Path=/") , ( "Set-Cookie" , "x-method=" <> fromString (show $ fromEnum method) <>";Path=/") ] } Right MT.Denied -> throwError ( addMessage (translate l10n loc "Authentication failed!") $ redirect303 (userSelectLink Nothing) ) Left err -> throwError $ err500 { errBody = fromString $ show err } Nothing -> throwError $ err400 { errBody = "No ticket cookie present." } where translate l10n locale = localize l10n locale . gettext authPostControl Nothing _ _ = throwError $ err400 { errBody = "No ticket cookie present." } authLogoutControl :: Maybe T.Text -> UserHandler UserOverviewPage authLogoutControl mcookie = do (ReadState _ backend _ _ _) <- ask let mParsedCookie = fmap parseCookieText mcookie token = T.unpack $ fromMaybe "secret" (lookup "x-token" =<< mParsedCookie) eReturn <- liftIO $ runClientM (authLogout (mkAuthenticatedRequest token authenticateReq)) backend case eReturn of Right _ -> do let redirectHeaders = errHeaders (redirect303 $ userSelectLink Nothing) unsetCookiesHeaders = map (\c -> ( "Set-Cookie" , c <> "=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT") ) ["x-auth-user", "x-method", "x-token"] throwError $ err303 { errHeaders = redirectHeaders ++ unsetCookiesHeaders } Left err -> throwError $ err500 { errBody = fromString (show err) }