matebeamter/src/Control/Auth.hs

204 lines
6.2 KiB
Haskell

{-# 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)
}