matebeamter/src/Control/Auth.hs

148 lines
4.3 KiB
Haskell

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Control.Auth where
import Servant
import Servant.Client
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 (foldM)
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 API
import Hash
authControl
:: Maybe T.Text
-> UserHandler
(Headers
'[ Header "Set-Cookie" T.Text
, Header "Set-Cookie" T.Text
, Header "Set-Cookie" T.Text
]
AuthPage)
authControl mcookie@(Just cookie) = do
let mauthUser = lookup "x-auth-user" (parseCookieText cookie)
case mauthUser of
Just authUser -> 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
, 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
"x-auth-user=; Path=/; Expires=Thu, 01 Jan 1970 00:00:00 GMT" $
addHeader (ticketHeaders !! 0) $
addHeader (ticketHeaders !! 1) $
authPage l10n loc
authControl Nothing =
throwError $ err400
{ errBody = "No cookie present."
}
authPostControl
:: Maybe T.Text
-> AuthReturn
-> UserHandler UserSelectPage
authPostControl (Just cookies) (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 headers = errHeaders $ redirect303 userSelectLink -- FIXME: redirect to product select
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=/")
]
}
Right MT.Denied -> throwError $ err401
{ errBody = "Authentication failed! " <> fromString (T.unpack hashedPass)
}
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."
}