{-# 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@(Just cookie) mDestination = do let mAuthUser = lookup "x-auth-user" (parseCookieText cookie) let mToken = lookup "x-token" (parseCookieText cookie) case (mAuthUser, mToken) of (Just authUser, Just _) -> do 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 $ snd $ unzip eAuthInfos } (Nothing, _) -> error $ "Error handling not yet implemented properly, but here's your user: " <> (fromString $ T.unpack $ fromMaybe "" $ lookup "x-auth-user" (parseCookieText cookie) ) where digestAuthInfo :: [(MT.AuthMethod, MT.AuthInfo)] -> UserHandler (Headers '[ Header "Set-Cookie" T.Text , Header "Set-Cookie" T.Text ] AuthPage) digestAuthInfo tupAuthInfos = do (ReadState l10n _ _) <- 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 (ticketHeaders !! 0) $ addHeader (ticketHeaders !! 1) $ authPage l10n loc mDestination authControl Nothing _ = throwError $ err400 { errBody = "No cookie present." } authPostControl :: Maybe T.Text -> Maybe T.Text -> AuthReturn -> UserHandler UserSelectPage authPostControl (Just cookies) mDestination (AuthReturn pass method) = do let mticket = lookup ("x-ticket-" <> fromString (show method)) $ parseCookieText cookies 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 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 $ err401 { errBody = "Authentication failed!" } Left err -> throwError $ err500 { errBody = fromString $ show err } Nothing -> throwError $ err400 { errBody = "No ticket cookie present." } 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 _ -> throwError $ redirect303 userSelectLink Left err -> throwError $ err500 { errBody = fromString (show err) }