2019-10-04 07:04:23 +00:00
|
|
|
{-# LANGUAGE DataKinds #-}
|
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE PackageImports #-}
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
2019-09-08 10:48:57 +00:00
|
|
|
module Control.Auth where
|
|
|
|
|
2019-10-04 07:04:23 +00:00
|
|
|
import Servant
|
|
|
|
import Servant.Client
|
2019-10-14 18:10:30 +00:00
|
|
|
import Servant.Client.Core.Auth (mkAuthenticatedRequest)
|
2019-10-04 07:04:23 +00:00
|
|
|
|
|
|
|
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
|
2019-09-08 10:48:57 +00:00
|
|
|
|
|
|
|
-- internal imports
|
|
|
|
|
|
|
|
import Types
|
|
|
|
import View
|
2019-10-04 07:04:23 +00:00
|
|
|
import Util
|
|
|
|
import Client
|
2019-10-14 18:10:30 +00:00
|
|
|
import ClientAuth
|
2019-10-04 07:04:23 +00:00
|
|
|
import API
|
|
|
|
import Hash
|
|
|
|
|
|
|
|
authControl
|
|
|
|
:: Maybe T.Text
|
2019-10-14 04:38:16 +00:00
|
|
|
-> Maybe T.Text
|
2019-10-04 07:04:23 +00:00
|
|
|
-> UserHandler
|
|
|
|
(Headers
|
|
|
|
'[ Header "Set-Cookie" T.Text
|
|
|
|
, Header "Set-Cookie" T.Text
|
|
|
|
]
|
|
|
|
AuthPage)
|
2019-10-15 05:22:04 +00:00
|
|
|
authControl mcookie mDestination = do
|
|
|
|
let mParsedCookie = fmap parseCookieText mcookie
|
|
|
|
mAuthUser = lookup "x-auth-user" =<< mParsedCookie
|
|
|
|
mToken = lookup "x-token" =<< mParsedCookie
|
2019-10-14 04:38:16 +00:00
|
|
|
case (mAuthUser, mToken) of
|
2019-10-16 16:07:12 +00:00
|
|
|
(Just authUser, Just _) ->
|
2019-10-14 04:38:16 +00:00
|
|
|
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
|
2019-10-04 07:04:23 +00:00
|
|
|
(ReadState _ backend _) <- ask
|
|
|
|
let trs = map
|
|
|
|
(MT.TicketRequest
|
|
|
|
(read (T.unpack authUser) :: Int))
|
|
|
|
passes
|
|
|
|
passes =
|
|
|
|
[ MT.PrimaryPass
|
|
|
|
, MT.SecondaryPass
|
|
|
|
]
|
|
|
|
eAuthInfos <- zip passes <$>
|
2019-10-16 16:07:12 +00:00
|
|
|
liftIO (mapM
|
2019-10-04 07:04:23 +00:00
|
|
|
(\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
|
2019-10-16 16:07:12 +00:00
|
|
|
{ errBody = fromString $ show $ lefts $ map snd eAuthInfos
|
2019-10-04 07:04:23 +00:00
|
|
|
}
|
2019-10-14 04:38:16 +00:00
|
|
|
(Nothing, _) ->
|
2019-10-15 05:22:04 +00:00
|
|
|
error "Error handling not yet implemented properly."
|
2019-10-04 07:04:23 +00:00
|
|
|
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) <>"=" <>
|
2019-10-16 16:07:12 +00:00
|
|
|
fromString (T.unpack ticket) <> ";Path=/")
|
2019-10-04 07:04:23 +00:00
|
|
|
tupAuthInfos
|
2019-10-14 04:38:16 +00:00
|
|
|
return $
|
2019-10-16 16:07:12 +00:00
|
|
|
addHeader (head ticketHeaders) $
|
2019-10-14 04:38:16 +00:00
|
|
|
addHeader (ticketHeaders !! 1) $
|
2019-10-24 16:05:22 +00:00
|
|
|
authPage l10n loc mDestination mcookie
|
2019-09-08 10:48:57 +00:00
|
|
|
|
2019-10-04 07:04:23 +00:00
|
|
|
authPostControl
|
|
|
|
:: Maybe T.Text
|
2019-10-14 04:38:16 +00:00
|
|
|
-> Maybe T.Text
|
2019-10-04 07:04:23 +00:00
|
|
|
-> AuthReturn
|
|
|
|
-> UserHandler UserSelectPage
|
2019-10-14 04:38:16 +00:00
|
|
|
authPostControl (Just cookies) mDestination (AuthReturn pass method) = do
|
2019-10-04 07:04:23 +00:00
|
|
|
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
|
2019-10-14 04:38:16 +00:00
|
|
|
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)
|
2019-10-14 13:07:17 +00:00
|
|
|
Nothing
|
2019-10-14 04:38:16 +00:00
|
|
|
)
|
|
|
|
_ -> errHeaders $ redirect303 userSelectLink
|
2019-10-04 07:04:23 +00:00
|
|
|
throwError $ err303
|
|
|
|
{ errHeaders = headers ++
|
2019-10-14 13:07:17 +00:00
|
|
|
[ ( "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=/")
|
2019-10-04 07:04:23 +00:00
|
|
|
]
|
|
|
|
}
|
|
|
|
Right MT.Denied -> throwError $ err401
|
2019-10-14 18:44:19 +00:00
|
|
|
{ errBody = "Authentication failed!"
|
2019-10-04 07:04:23 +00:00
|
|
|
}
|
|
|
|
Left err -> throwError $ err500
|
|
|
|
{ errBody = fromString $ show err
|
|
|
|
}
|
|
|
|
Nothing -> throwError $ err400
|
|
|
|
{ errBody = "No ticket cookie present."
|
|
|
|
}
|
2019-10-14 04:38:16 +00:00
|
|
|
authPostControl Nothing _ _ = throwError $ err400
|
2019-10-04 07:04:23 +00:00
|
|
|
{ errBody = "No ticket cookie present."
|
|
|
|
}
|
2019-10-14 18:10:30 +00:00
|
|
|
|
|
|
|
authLogoutControl
|
|
|
|
:: Maybe T.Text
|
|
|
|
-> UserHandler UserOverviewPage
|
|
|
|
authLogoutControl mcookie = do
|
|
|
|
(ReadState _ backend _) <- ask
|
|
|
|
let mParsedCookie = fmap parseCookieText mcookie
|
2019-10-16 16:07:12 +00:00
|
|
|
token = T.unpack $ fromMaybe "secret"
|
|
|
|
(lookup "x-token" =<< mParsedCookie)
|
2019-10-14 18:10:30 +00:00
|
|
|
eReturn <- liftIO $ runClientM
|
|
|
|
(authLogout (mkAuthenticatedRequest token authenticateReq))
|
|
|
|
backend
|
|
|
|
case eReturn of
|
2019-10-15 05:22:04 +00:00
|
|
|
Right _ -> do
|
|
|
|
let redirectHeaders = errHeaders (redirect303 userSelectLink)
|
|
|
|
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
|
|
|
|
}
|
2019-10-14 18:10:30 +00:00
|
|
|
Left err -> throwError $ err500
|
|
|
|
{ errBody = fromString (show err)
|
|
|
|
}
|