issuing of id tokens
This commit is contained in:
David Mosbach
parent
45debf40cd
commit
ba9bc7f784
@ -31,6 +31,7 @@ import Control.Monad.Reader (ReaderT)
|
||||
import Conduit (ResourceT)
|
||||
|
||||
import Data.Map (Map(..))
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.String (IsString(..))
|
||||
import Data.Text (Text(..))
|
||||
import Data.Yaml (decodeFileThrow, FromJSON(..), Value(..), (.:), (.:?))
|
||||
@ -51,7 +52,7 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
|
||||
email Text
|
||||
matricNumber Text Maybe
|
||||
title Text Maybe
|
||||
sex Text Maybe
|
||||
gender Text Maybe
|
||||
birthday Text Maybe
|
||||
telephone Text Maybe
|
||||
mobile Text Maybe
|
||||
@ -68,7 +69,7 @@ instance FromJSON User where
|
||||
<*> o .: "userEmail"
|
||||
<*> o .:? "userMatrikelnummer"
|
||||
<*> o .:? "userTitle"
|
||||
<*> o .:? "userSex"
|
||||
<*> o .:? "userGender"
|
||||
<*> o .:? "userBirthday"
|
||||
<*> o .:? "userTelephone"
|
||||
<*> o .:? "userMobile"
|
||||
@ -107,28 +108,49 @@ initDB = do
|
||||
|
||||
|
||||
instance UserData (Entity User) (Map Text Text) where
|
||||
data Scope (Entity User) = ID | Profile deriving (Show, Read, Eq)
|
||||
readScope = read
|
||||
showScope = show
|
||||
userScope (Entity _ User{..}) ID = M.singleton "id" userEmail
|
||||
userScope (Entity _ User{..}) Profile = M.fromList [(key, val) | (key, Just val) <-
|
||||
[ ("firstName", Just userFirstName)
|
||||
, ("surname", Just userSurname)
|
||||
, ("email", Just userEmail)
|
||||
, ("matriculationNumber", userMatricNumber)
|
||||
type UserID (Entity User) = Key User
|
||||
data CustomScope (Entity User) = UWX deriving (Read, Show, Eq)
|
||||
userScope (Entity _ User{..}) (Left OpenID) = M.singleton "id" userEmail
|
||||
userScope (Entity _ User{..}) (Left Profile) = M.fromList $ catM
|
||||
[ ("name", Just $ userFirstName <> " " <> userSurname)
|
||||
, ("given_name", Just userFirstName)
|
||||
, ("family_name", Just userSurname)
|
||||
, ("middle_name", Nothing)
|
||||
, ("nickname", Nothing)
|
||||
, ("preferred_username", Nothing)
|
||||
, ("profile", Nothing)
|
||||
, ("picture", Nothing)
|
||||
, ("website", Nothing)
|
||||
, ("gender", userGender)
|
||||
, ("birthdate", userBirthday)
|
||||
, ("zoneinfo", Nothing)
|
||||
, ("locale", Nothing)
|
||||
, ("updated_at", Nothing)
|
||||
]
|
||||
userScope (Entity _ User{..}) (Left Email) = M.fromList [("email", userEmail), ("email_verified", userEmail)]
|
||||
userScope (Entity _ User{..}) (Left Address) = case userPostAddress of
|
||||
Just address -> M.singleton "address" address
|
||||
Nothing -> M.empty
|
||||
userScope (Entity _ User{..}) (Left Phone) = M.fromList $ catM [("phone_number", userMobile), ("phone_number_verified", userTelephone)]
|
||||
userScope (Entity _ User{..}) (Right UWX) = M.fromList $ catM
|
||||
[ ("matriculationNumber", userMatricNumber)
|
||||
, ("title", userTitle)
|
||||
, ("sex", userSex)
|
||||
, ("birthday", userBirthday)
|
||||
, ("telephone", userTelephone)
|
||||
, ("mobile", userMobile)
|
||||
, ("companyPersonalNumber", userCompPersNumber)
|
||||
, ("companyDepartment", userCompDepartment)
|
||||
, ("postAddress", userPostAddress)
|
||||
]]
|
||||
lookupUser email _ = runDB $ do
|
||||
user <- selectList [UserEmail ==. email] []
|
||||
]
|
||||
userScope (Entity _ User{..}) _ = M.empty
|
||||
lookupUser UserQuery{..} = runDB $ do
|
||||
let filters = map fst $ catM [(UserEmail ==. fromJust email, email)]
|
||||
keyFilter = case key of
|
||||
Just k -> \(Entity x _) -> (T.pack $ show x) == k
|
||||
Nothing -> \_ -> True
|
||||
user <- filter keyFilter <$> selectList filters []
|
||||
case user of
|
||||
[entity] -> return $ Just entity
|
||||
[] -> return Nothing
|
||||
_ -> error "Oauth2 Mock Server: Ambiguous User."
|
||||
userID (Entity x _) = x
|
||||
|
||||
catM :: [(a, Maybe b)] -> [(a, b)]
|
||||
catM l = [ (x,y) | (x, Just y) <- l ]
|
||||
|
||||
|
||||
@ -37,6 +37,7 @@ library
|
||||
, blaze-html
|
||||
, bytestring
|
||||
, containers
|
||||
, cookie
|
||||
, http-api-data
|
||||
, http-client
|
||||
, http-media
|
||||
@ -72,6 +73,7 @@ executable oauth2-mock-server-exe
|
||||
, bytestring
|
||||
, conduit
|
||||
, containers
|
||||
, cookie
|
||||
, http-api-data
|
||||
, http-client
|
||||
, http-media
|
||||
@ -112,6 +114,7 @@ test-suite oauth2-mock-server-test
|
||||
, blaze-html
|
||||
, bytestring
|
||||
, containers
|
||||
, cookie
|
||||
, http-api-data
|
||||
, http-client
|
||||
, http-media
|
||||
|
||||
@ -44,6 +44,7 @@ dependencies:
|
||||
- blaze-html
|
||||
- http-media
|
||||
- string-interpolate
|
||||
- cookie
|
||||
|
||||
ghc-options:
|
||||
- -Wall
|
||||
|
||||
104
src/AuthCode.hs
104
src/AuthCode.hs
@ -3,12 +3,13 @@
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# LANGUAGE OverloadedRecordDot, OverloadedStrings, ScopedTypeVariables, TypeApplications, LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedRecordDot, OverloadedStrings, ScopedTypeVariables, TypeApplications, LambdaCase, DeriveGeneric, AllowAmbiguousTypes #-}
|
||||
|
||||
module AuthCode
|
||||
( State(..)
|
||||
, AuthState
|
||||
, AuthRequest(..)
|
||||
, TokenParams(..)
|
||||
, JWT(..)
|
||||
, JWTWrapper(..)
|
||||
, genUnencryptedCode
|
||||
@ -18,18 +19,23 @@ module AuthCode
|
||||
, renewToken
|
||||
) where
|
||||
|
||||
import Prelude hiding (exp)
|
||||
|
||||
import User
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Bool (bool)
|
||||
import Data.ByteString (ByteString (..), fromStrict, toStrict)
|
||||
import Data.Either (fromRight)
|
||||
import Data.List ((\\))
|
||||
import Data.Map.Strict (Map)
|
||||
import Data.Maybe (isJust, fromMaybe, fromJust)
|
||||
import Data.Maybe (isJust, fromMaybe, fromJust, catMaybes)
|
||||
import Data.Time.Calendar
|
||||
import Data.Time.Clock
|
||||
import Data.Text (pack, replace, Text, stripPrefix)
|
||||
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
||||
import Data.Text.Encoding.Base64
|
||||
import Data.UUID
|
||||
import Data.UUID hiding (null)
|
||||
import Data.UUID.V4
|
||||
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
@ -40,13 +46,22 @@ import Control.Concurrent.STM.TVar
|
||||
import Control.Monad (void, (>=>))
|
||||
import Control.Monad.STM
|
||||
|
||||
import GHC.Generics
|
||||
|
||||
import Jose.Jwa
|
||||
import Jose.Jwe
|
||||
import Jose.Jwk (Jwk(..))
|
||||
import Jose.Jwt hiding (decode, encode)
|
||||
import qualified Jose.Jws as Jws
|
||||
|
||||
import Servant.API (FromHttpApiData(..))
|
||||
|
||||
import System.Environment (getEnv)
|
||||
|
||||
|
||||
--------------
|
||||
---- Tokens ----
|
||||
--------------
|
||||
|
||||
data JWT = JWT
|
||||
{ issuer :: Text
|
||||
@ -60,25 +75,41 @@ instance ToJSON JWT where
|
||||
instance FromJSON JWT where
|
||||
parseJSON (Object o) = JWT <$> o .: "iss" <*> o .: "exp" <*> o .: "jti"
|
||||
|
||||
data IDToken = IDT
|
||||
{ iss :: Text
|
||||
, sub :: Text
|
||||
, aud :: [Text]
|
||||
, exp :: NominalDiffTime
|
||||
, iat :: NominalDiffTime
|
||||
, auth_time :: Maybe NominalDiffTime
|
||||
, nonce :: Maybe Text
|
||||
} deriving (Generic, Show)
|
||||
|
||||
instance ToJSON IDToken
|
||||
instance FromJSON IDToken
|
||||
|
||||
|
||||
data JWTWrapper = JWTW
|
||||
{ acessToken :: String
|
||||
, expiresIn :: NominalDiffTime
|
||||
, refreshToken :: Maybe String
|
||||
, idToken :: Maybe String
|
||||
} deriving (Show)
|
||||
|
||||
instance ToJSON JWTWrapper where
|
||||
toJSON (JWTW a e r) = object
|
||||
toJSON (JWTW a e r i) = object
|
||||
[ "access_token" .= a
|
||||
, "token_type" .= ("JWT" :: Text)
|
||||
, "expires_in" .= fromEnum e
|
||||
, "refresh_token" .= r ]
|
||||
, "refresh_token" .= r
|
||||
, "id_token" .= i ]
|
||||
|
||||
instance FromJSON JWTWrapper where
|
||||
parseJSON (Object o) = JWTW
|
||||
<$> o .: "access_token"
|
||||
<*> o .: "expires_in"
|
||||
<*> o .:? "refresh_token"
|
||||
<*> o .:? "id_token"
|
||||
|
||||
instance FromHttpApiData JWTWrapper where
|
||||
parseHeader bs = case decode (fromStrict bs) of
|
||||
@ -86,24 +117,33 @@ instance FromHttpApiData JWTWrapper where
|
||||
Nothing -> Left "Invalid JWT wrapper"
|
||||
|
||||
|
||||
-------------
|
||||
---- State ----
|
||||
-------------
|
||||
|
||||
data AuthRequest user = AuthRequest
|
||||
{ client :: String
|
||||
, codeExpiration :: NominalDiffTime
|
||||
, user :: user
|
||||
, scopes :: [Scope user]
|
||||
, scopes :: [Scope' user]
|
||||
, rNonce :: Maybe Text
|
||||
}
|
||||
|
||||
|
||||
type TokenParams user = (user, [Scope' user], Maybe Text)
|
||||
|
||||
data State user = State
|
||||
{ activeCodes :: Map Text (AuthRequest user)
|
||||
, activeTokens :: Map UUID (user, [Scope user])
|
||||
, activeTokens :: Map UUID (TokenParams user)
|
||||
, publicKey :: Jwk
|
||||
, privateKey :: Jwk
|
||||
}
|
||||
|
||||
type AuthState user = TVar (State user)
|
||||
|
||||
-----------------
|
||||
---- Functions ----
|
||||
-----------------
|
||||
|
||||
genUnencryptedCode :: AuthRequest user
|
||||
-> String
|
||||
-> AuthState user
|
||||
@ -127,7 +167,10 @@ genUnencryptedCode req url state = do
|
||||
atomically . modifyTVar state $ \s -> s{ activeCodes = M.delete code s.activeCodes }
|
||||
|
||||
|
||||
verify :: Text -> Maybe String -> AuthState user -> IO (Maybe (user, [Scope user]))
|
||||
verify :: Text
|
||||
-> Maybe String
|
||||
-> AuthState user
|
||||
-> IO (Maybe (TokenParams user))
|
||||
verify code mClientID state = do
|
||||
now <- getCurrentTime
|
||||
mData <- atomically $ do
|
||||
@ -135,28 +178,48 @@ verify code mClientID state = do
|
||||
modifyTVar state $ \s -> s{ activeCodes = M.delete code s.activeCodes }
|
||||
return result
|
||||
return $ case mData of
|
||||
Just (AuthRequest clientID' _ u s) -> if (fromMaybe clientID' mClientID) == clientID' then Just (u, s) else Nothing
|
||||
Just (AuthRequest clientID' _ u s n) -> if (fromMaybe clientID' mClientID) == clientID'
|
||||
then Just (u, s, n)
|
||||
else Nothing
|
||||
_ -> Nothing
|
||||
|
||||
|
||||
mkToken :: user -> [Scope user] -> AuthState user -> IO JWTWrapper
|
||||
mkToken u scopes state = do
|
||||
mkToken :: forall user userData . UserData user userData
|
||||
=> TokenParams user
|
||||
-> Maybe Text -- client_id
|
||||
-> AuthState user
|
||||
-> IO JWTWrapper
|
||||
mkToken (u, scopes, nonce) clientID state = do
|
||||
pubKey <- atomically $ readTVar state >>= return . publicKey
|
||||
now <- getCurrentTime
|
||||
uuid <- nextRandom
|
||||
port <- pack <$> getEnv "OAUTH2_SERVER_PORT"
|
||||
let
|
||||
lifetimeAT = 3600 :: NominalDiffTime -- TODO make configurable
|
||||
lifetimeRT = nominalDay -- TODO make configurable
|
||||
lifetimeIT = 3600 :: NominalDiffTime -- TODO make configurable
|
||||
itRefDate = UTCTime (fromGregorian 1970 1 1) 0
|
||||
at = JWT "Oauth2MockServer" (lifetimeAT `addUTCTime` now) uuid
|
||||
rt = JWT "Oauth2MockServer" (lifetimeRT `addUTCTime` now) uuid
|
||||
it = IDT
|
||||
{ iss = "http://localhost:" <> port -- TODO maybe make configurable
|
||||
, sub = pack . show $ userID @user @userData u
|
||||
, aud = catMaybes [clientID]
|
||||
, exp = (lifetimeIT `addUTCTime` now) `diffUTCTime` itRefDate
|
||||
, iat = now `diffUTCTime` itRefDate
|
||||
, auth_time = Just $ now `diffUTCTime` itRefDate
|
||||
, nonce = nonce
|
||||
}
|
||||
encodedAT <- jwkEncode RSA_OAEP_256 A128GCM pubKey (Nested . Jwt . toStrict $ encode at)
|
||||
encodedRT <- jwkEncode RSA_OAEP_256 A128GCM pubKey (Nested . Jwt . toStrict $ encode rt)
|
||||
case encodedAT >> encodedRT of
|
||||
encodedIT <- Jws.jwkEncode RS256 pubKey (Nested . Jwt . toStrict $ encode it)
|
||||
case encodedAT >> encodedRT >> encodedIT of
|
||||
Right _ -> do
|
||||
let Jwt aToken = fromRight undefined encodedAT
|
||||
Jwt rToken = fromRight undefined encodedRT
|
||||
atomically . modifyTVar state $ \s -> s { activeTokens = M.insert uuid (u, scopes) (activeTokens s) }
|
||||
return $ JWTW (BS.unpack aToken) lifetimeAT (Just $ BS.unpack rToken)
|
||||
Jwt iToken = fromRight undefined encodedIT
|
||||
atomically . modifyTVar state $ \s -> s { activeTokens = M.insert uuid (u, scopes, nonce) (activeTokens s) }
|
||||
return $ JWTW (BS.unpack aToken) lifetimeAT (Just $ BS.unpack rToken) (Just $ BS.unpack iToken)
|
||||
Left e -> error $ show e
|
||||
|
||||
decodeToken :: Text -> AuthState user -> IO (Either JwtError JwtContent)
|
||||
@ -164,8 +227,13 @@ decodeToken token state = do
|
||||
prKey <- atomically $ readTVar state >>= return . privateKey
|
||||
jwkDecode prKey $ encodeUtf8 token
|
||||
|
||||
renewToken :: Text -> AuthState user -> IO (Maybe JWTWrapper)
|
||||
renewToken t state = decodeToken t state >>= \case
|
||||
renewToken :: forall user userData . UserData user userData
|
||||
=> Text -- ^ token
|
||||
-> [Scope' user]
|
||||
-> Maybe Text -- ^ client_id
|
||||
-> AuthState user
|
||||
-> IO (Maybe JWTWrapper) -- TODO more descriptive failures
|
||||
renewToken t scopes clientID state = decodeToken t state >>= \case
|
||||
Right (Jwe (header, body)) -> do
|
||||
let jwt = fromJust . decode @JWT $ fromStrict body
|
||||
now <- getCurrentTime
|
||||
@ -174,7 +242,7 @@ renewToken t state = decodeToken t state >>= \case
|
||||
let (key, tokens) = M.updateLookupWithKey (\_ _ -> Nothing) (jti jwt) s.activeTokens
|
||||
in (key, s { activeTokens = tokens })
|
||||
case mUser of
|
||||
Just (u, scopes) -> Just <$> mkToken u scopes state
|
||||
Just (u, scopes', nonce) -> bool (pure Nothing) (Just <$> mkToken @user @userData (u, scopes, nonce) clientID state) (null $ scopes \\ scopes')
|
||||
Nothing -> return Nothing
|
||||
Left _ -> return Nothing
|
||||
|
||||
|
||||
148
src/Server.hs
148
src/Server.hs
@ -40,12 +40,13 @@ import Control.Monad.Trans.Error (Error(..))
|
||||
import Control.Monad.Trans.Reader
|
||||
|
||||
import Data.Aeson
|
||||
import Data.ByteString (fromStrict)
|
||||
import Data.ByteString (fromStrict, ByteString)
|
||||
import Data.List (find, elemIndex)
|
||||
import Data.Maybe (fromMaybe, fromJust, isJust, isNothing)
|
||||
import Data.String (IsString (..))
|
||||
import Data.Text hiding (elem, find, head, length, map, null, splitAt, tail, words)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Text.Encoding.Base64
|
||||
import Data.Time.Clock (NominalDiffTime (..), nominalDay, UTCTime(..), getCurrentTime, addUTCTime)
|
||||
|
||||
@ -60,13 +61,14 @@ import Network.HTTP.Client (newManager, defaultManagerSettings)
|
||||
import Network.Wai.Handler.Warp
|
||||
|
||||
import Servant
|
||||
import Servant.Client
|
||||
import Servant.Client hiding (client)
|
||||
import Servant.API
|
||||
|
||||
import Text.ParserCombinators.ReadPrec (look, pfail)
|
||||
|
||||
import qualified Text.Read.Lex as Lex
|
||||
|
||||
import Web.Cookie (parseCookiesText)
|
||||
import Web.Internal.FormUrlEncoded (FromForm(..), parseUnique, parseMaybe, Form(..))
|
||||
|
||||
|
||||
@ -102,7 +104,9 @@ type QClient = String
|
||||
type QResType = String
|
||||
type QRedirect = Text
|
||||
type QState = Text
|
||||
type QNonce = Text
|
||||
type QAuth = Text
|
||||
type QCookie = Text
|
||||
|
||||
type QParam = QueryParam' [Required, Strict]
|
||||
|
||||
@ -112,15 +116,17 @@ type Auth = "auth"
|
||||
:> QParam "response_type" QResType
|
||||
:> QParam "redirect_uri" QRedirect
|
||||
:> QueryParam "state" QState
|
||||
:> Get '[HTML] Html -- login
|
||||
:> QueryParam "nonce" QNonce
|
||||
:> Header "Cookie" QCookie
|
||||
:> Get '[HTML] Html -- ^ login
|
||||
|
||||
type AuthCode = "code"
|
||||
:> HeaderR "Authorization" QAuth
|
||||
:> HeaderR "OA2_Scope" QScope
|
||||
:> HeaderR "OA2_Client_ID" QClient
|
||||
:> HeaderR "OA2_Redirect_URI" QRedirect
|
||||
:> Header "OA2_State" QState
|
||||
:> Get '[JSON] Text -- returns auth code
|
||||
:> Header "OA2_State" QState
|
||||
:> Get '[JSON] (Headers '[Header "Set-Cookie" Text] Text) -- ^ returns auth code
|
||||
|
||||
|
||||
type AuthHandler user = ReaderT (AuthState user) Handler
|
||||
@ -130,59 +136,76 @@ toHandler :: forall user userData a . UserData user userData => AuthState user -
|
||||
toHandler s h = runReaderT h s
|
||||
|
||||
loginServer :: forall user userData . UserData user userData => AuthServer user Auth
|
||||
loginServer = handleAuth
|
||||
loginServer = decideLogin
|
||||
where
|
||||
handleAuth :: QScope
|
||||
-> QClient
|
||||
-> QResType
|
||||
-> QRedirect
|
||||
-> Maybe QState
|
||||
-> AuthHandler user Html
|
||||
handleAuth scopes client responseType url mState = do
|
||||
let
|
||||
responseType' = read @ResponseType responseType
|
||||
headers = Map.fromList @Text @Text
|
||||
[ ("OA2_Scope", pack scopes)
|
||||
, ("OA2_Client_ID", pack client)
|
||||
, ("OA2_Redirect_URI", url)]
|
||||
headers' = if isJust mState then Map.insert "OA2_State" (fromJust mState) headers else headers
|
||||
unless (responseType' == Code) $ throwError err500 { errBody = "Unsupported response type" }
|
||||
return $ loginPage headers'
|
||||
decideLogin scopes client responseType url mState mNonce mCookies
|
||||
| Just nonce <- mNonce, Just cookies <- mCookies = handleOIDC nonce cookies
|
||||
| Nothing <- (mNonce >> mCookies) = handleLogin
|
||||
| otherwise = throwError err500 { errBody = "Either cookie or nonce missing" }
|
||||
where
|
||||
-- | Retrieve user id from cookie
|
||||
handleOIDC :: QNonce
|
||||
-> QCookie
|
||||
-> AuthHandler user Html
|
||||
handleOIDC nonce cookies = case read @ResponseType responseType of -- TODO nonce can also occur if user is not logged in yet
|
||||
IDToken -> do
|
||||
let mCreds = lookup "oa2_auth_cookie" . parseCookiesText $ encodeUtf8 cookies
|
||||
unless (isJust mCreds) $ throwError err401 { errBody = "Missing auth cookie" }
|
||||
url' <- handleCreds @user @userData (fromJust mCreds) scopes client url mState (Just nonce)
|
||||
throwError err303 { errHeaders = [("Location", encodeUtf8 url')]}
|
||||
_ -> throwError err500 { errBody = "Unsupported response type" }
|
||||
|
||||
-- | Html login form
|
||||
handleLogin :: AuthHandler user Html
|
||||
handleLogin = do
|
||||
let
|
||||
responseType' = read @ResponseType responseType
|
||||
headers = Map.fromList @Text @Text $
|
||||
[ ("OA2_Scope", pack scopes)
|
||||
, ("OA2_Client_ID", pack client)
|
||||
, ("OA2_Redirect_URI", url)
|
||||
] ++ [(x,y) | (x, Just y) <- [("OA2_State", mState)]]
|
||||
case responseType' of
|
||||
Code -> return $ loginPage headers
|
||||
_ -> throwError err500 { errBody = "Unsupported response type" }
|
||||
|
||||
|
||||
codeServer :: forall user userData . UserData user userData => AuthServer user AuthCode
|
||||
codeServer = handleCreds
|
||||
where
|
||||
handleCreds :: QAuth
|
||||
-> QScope
|
||||
-> QClient
|
||||
-> QRedirect
|
||||
-> Maybe QState
|
||||
-> AuthHandler user Text
|
||||
handleCreds creds scopes client url mState = do
|
||||
unless (isJust $ find (\c -> ident c == pack client) trustedClients) . -- TODO fetch trusted clients from db | TODO also check if the redirect url really belongs to the client
|
||||
throwError $ err404 { errBody = "Not a trusted client."}
|
||||
let
|
||||
scopes' = map (readScope @user @userData) $ words scopes
|
||||
[userName, password] = splitOn ":" $ decodeBase64Lenient creds
|
||||
liftIO $ print userName
|
||||
mUser <- liftIO $ lookupUser @user @userData userName (Just password)
|
||||
unless (isJust mUser) $ throwError err500 { errBody = "Unknown user."}
|
||||
let u = fromJust mUser
|
||||
mAuthCode <- asks (genUnencryptedCode (AuthRequest client 600 u scopes') (unpack url)) >>= liftIO
|
||||
liftIO $ print mAuthCode
|
||||
liftIO . putStrLn $ "user: " ++ show u ++ " | scopes: " ++ show (map (showScope @user @userData) scopes')
|
||||
redirect $ addParams url mAuthCode mState
|
||||
redirect :: Maybe Text -> AuthHandler user Text
|
||||
redirect (Just url) = liftIO (print url) >> return url --throwError err303 { errHeaders = [("Location", url)]}
|
||||
redirect Nothing = throwError err500 { errBody = "Could not generate authorisation code."}
|
||||
addParams :: Text -> Maybe Text -> Maybe Text -> Maybe Text
|
||||
addParams url Nothing _ = Nothing
|
||||
addParams url (Just code) mState =
|
||||
let urlParts = splitOn "?" url
|
||||
(pre, post) = if length urlParts == 2 then (urlParts !! 0, urlParts !! 1) else (head urlParts, "")
|
||||
rState = case mState of {Just s -> "&state=" <> (replace "/" "%2F" $ replace "=" "%3D" s); Nothing -> ""}
|
||||
post' = if not (T.null post) then "&" <> T.tail post else post
|
||||
in Just $ pre <> "?code=" <> code <> post' <> rState
|
||||
codeServer creds scopes client url mState = addHeader ("oa2_auth_cookie=" <> creds) <$>
|
||||
handleCreds @user @userData creds scopes client url mState Nothing
|
||||
|
||||
handleCreds :: forall user userData . UserData user userData
|
||||
=> QAuth
|
||||
-> QScope
|
||||
-> QClient
|
||||
-> QRedirect
|
||||
-> Maybe QState
|
||||
-> Maybe QNonce
|
||||
-> AuthHandler user Text
|
||||
handleCreds creds scopes client url mState mNonce = do
|
||||
unless (isJust $ find (\c -> ident c == pack client) trustedClients) . -- TODO fetch trusted clients from db | TODO also check if the redirect url really belongs to the client
|
||||
throwError $ err404 { errBody = "Not a trusted client."}
|
||||
let scopes' = map (read @(Scope' user)) $ words scopes
|
||||
[userName, password] = splitOn ":" $ decodeBase64Lenient creds
|
||||
mUser <- liftIO $ lookupUser @user @userData (UserQuery (Just userName) (Just password) Nothing)
|
||||
unless (isJust mUser) $ throwError err500 { errBody = "Unknown user."}
|
||||
let u = fromJust mUser
|
||||
mAuthCode <- asks (genUnencryptedCode (AuthRequest client 600 u scopes' mNonce) (unpack url)) >>= liftIO
|
||||
liftIO $ print mAuthCode
|
||||
liftIO . putStrLn $ "user: " ++ show u ++ " | scopes: " ++ show (map show scopes')
|
||||
redirect $ addParams url mAuthCode mState
|
||||
where
|
||||
redirect :: Maybe Text -> AuthHandler user Text
|
||||
redirect (Just url) = liftIO (print url) >> return url --throwError err303 { errHeaders = [("Location", url)]}
|
||||
redirect Nothing = throwError err500 { errBody = "Could not generate authorisation code."}
|
||||
addParams :: Text -> Maybe Text -> Maybe Text -> Maybe Text
|
||||
addParams url Nothing _ = Nothing
|
||||
addParams url (Just code) mState =
|
||||
let urlParts = splitOn "?" url
|
||||
(pre, post) = if length urlParts == 2 then (urlParts !! 0, urlParts !! 1) else (head urlParts, "")
|
||||
rState = case mState of {Just s -> "&state=" <> (replace "/" "%2F" $ replace "=" "%3D" s); Nothing -> ""}
|
||||
post' = if not (T.null post) then "&" <> T.tail post else post
|
||||
in Just $ pre <> "?code=" <> code <> post' <> rState
|
||||
|
||||
|
||||
|
||||
@ -233,20 +256,21 @@ tokenEndpoint = provideToken
|
||||
unless (isNothing (clientID client >> clientSecret client)
|
||||
|| Client (pack . fromJust $ clientID client) (pack . fromJust $ clientSecret client) `elem` trustedClients) .
|
||||
throwError $ err500 { errBody = "Invalid client" }
|
||||
let cid = pack <$> clientID client
|
||||
case authID client of
|
||||
Left (ACode authCode) -> do
|
||||
unless (grantType client == "authorization_code") . throwError $ err500 { errBody = "Invalid grant_type" }
|
||||
mUser <- asks (verify (pack authCode) (clientID client)) >>= liftIO -- TODO verify redirect url here
|
||||
unless (isJust mUser) . throwError $ err500 { errBody = "Invalid authorisation code" }
|
||||
-- return JWT {token = "", tokenType = "JWT", expiration = 0.25 * nominalDay}
|
||||
let (user, scopes) = fromJust mUser
|
||||
token <- asks (mkToken @user user scopes) >>= liftIO
|
||||
token <- asks (mkToken @user @userData (fromJust mUser) cid) >>= liftIO
|
||||
liftIO . putStrLn $ "token: " ++ show token
|
||||
return token
|
||||
Right (RToken jwtw) -> do
|
||||
let scopes = [] -- TODO read query param for this
|
||||
unless (grantType client == "refresh_token") . throwError $ err500 { errBody = "Invalid grant_type" }
|
||||
liftIO $ putStrLn "... checking refresh token"
|
||||
mToken <- asks (renewToken @user jwtw) >>= liftIO
|
||||
mToken <- asks (renewToken @user @userData jwtw scopes cid) >>= liftIO
|
||||
case mToken of
|
||||
Just token -> liftIO (putStrLn $ "refreshed token: " ++ show token) >> return token
|
||||
Nothing -> throwError $ err500 { errBody = "Invalid refresh token" }
|
||||
@ -282,7 +306,7 @@ instance ToJSON result => ToJSON (QueryResult result) where
|
||||
toJSON (QRight x) = toJSON x
|
||||
|
||||
|
||||
verifyToken :: forall user userData . UserData user userData => Text -> AuthHandler user (Maybe (user, [Scope user]))
|
||||
verifyToken :: forall user userData . UserData user userData => Text -> AuthHandler user (Maybe (TokenParams user))
|
||||
verifyToken jwtw = do
|
||||
let mToken = stripPrefix "Bearer " jwtw
|
||||
unless (isJust mToken) . throwError $ err500 { errBody = "Invalid token format" }
|
||||
@ -302,7 +326,7 @@ userEndpoint = handleUserData
|
||||
where
|
||||
handleUserData :: Text -> AuthHandler user (QueryResult userData)
|
||||
handleUserData jwtw = verifyToken @user @userData jwtw >>= \case
|
||||
Just (u, scopes) -> return . QRight . mconcat $ map (userScope @user @userData u) scopes
|
||||
Just (u, scopes, _) -> return . QRight . mconcat $ map (userScope @user @userData u) scopes
|
||||
Nothing -> return . QLeft $ QError "UnknownToken"
|
||||
|
||||
|
||||
@ -312,8 +336,8 @@ userListEndpoint = handleUserData
|
||||
handleUserData :: Text -> Text -> AuthHandler user (QueryResult [userData])
|
||||
handleUserData jwtw userID = verifyToken @user @userData jwtw >>= \case -- TODO check if this user is allowed query other users
|
||||
Nothing -> return . QLeft $ QError "UnknownToken"
|
||||
Just admin -> liftIO $ lookupUser @user @userData userID Nothing >>= \case
|
||||
Just u -> return $ QRight [mconcat $ map (userScope @user @userData u) (snd admin)] -- TODO support queries that fit for multiple users
|
||||
Just (_, scopes, _) -> liftIO $ lookupUser @user @userData (UserQuery (Just userID) Nothing Nothing) >>= \case
|
||||
Just u -> return $ QRight [mconcat $ map (userScope @user @userData u) scopes] -- TODO support queries that fit for multiple users
|
||||
Nothing -> return . QLeft $ QError "UserDoesNotExist"
|
||||
|
||||
|
||||
|
||||
72
src/User.hs
72
src/User.hs
@ -3,21 +3,75 @@
|
||||
--
|
||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||
|
||||
{-# LANGUAGE OverloadedStrings, RecordWildCards, TypeFamilies, MultiParamTypeClasses, FlexibleInstances, AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE OverloadedStrings, RecordWildCards, TypeFamilies, TypeApplications, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, AllowAmbiguousTypes, RankNTypes, OverlappingInstances, ScopedTypeVariables #-}
|
||||
|
||||
module User ( UserData(..) ) where
|
||||
module User
|
||||
( UserData(..)
|
||||
, Scope(..)
|
||||
, Scope'(..)
|
||||
, UserQuery(..)
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Data.Aeson
|
||||
import Data.Char (toUpper, toLower)
|
||||
import Data.Map.Strict
|
||||
import Data.Maybe
|
||||
import Data.Text
|
||||
import Data.Text hiding (head, tail, toUpper, toLower)
|
||||
|
||||
import GHC.Read (readPrec, lexP)
|
||||
|
||||
import Text.ParserCombinators.ReadPrec (look, pfail)
|
||||
import qualified Text.Read.Lex as Lex
|
||||
|
||||
type UserName = Text
|
||||
type Password = Text
|
||||
|
||||
class (Eq u, Show u, ToJSON a, Monoid a) => UserData u a where -- TODO Show maybe not necessary
|
||||
data Scope u
|
||||
readScope :: String -> Scope u
|
||||
showScope :: Scope u -> String
|
||||
userScope :: u -> Scope u -> a
|
||||
lookupUser :: UserName -> Maybe Password -> IO (Maybe u)
|
||||
-- | OIDC scope
|
||||
data Scope = OpenID
|
||||
| Profile
|
||||
| Email
|
||||
| Address
|
||||
| Phone
|
||||
| OfflineAccess
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance Read Scope where
|
||||
readPrec = do
|
||||
Lex.Ident str <- lexP
|
||||
Lex.EOF <- lexP
|
||||
return $ case str of
|
||||
"openid" -> OpenID
|
||||
"profile" -> Profile
|
||||
"email" -> Email
|
||||
"address" -> Address
|
||||
"phone" -> Phone
|
||||
"offline_access" -> OfflineAccess
|
||||
|
||||
|
||||
type Scope' user = Either Scope (CustomScope user)
|
||||
|
||||
instance forall user . Read (CustomScope user) => Read (Scope' user) where
|
||||
readPrec = (Left <$> readPrec @Scope) <|> (Right <$> readPrec @(CustomScope user))
|
||||
|
||||
data UserQuery = UserQuery
|
||||
{ email :: Maybe Text
|
||||
, password :: Maybe Text
|
||||
, key :: Maybe Text
|
||||
} deriving (Show)
|
||||
|
||||
class ( Eq u
|
||||
, Show u -- TODO Show maybe not necessary
|
||||
, Show (UserID u)
|
||||
, Read (CustomScope u)
|
||||
, Show (CustomScope u)
|
||||
, Eq (CustomScope u)
|
||||
, ToJSON a
|
||||
, Monoid a
|
||||
) => UserData u a where
|
||||
type UserID u
|
||||
data CustomScope u
|
||||
userScope :: u -> Scope' u -> a
|
||||
lookupUser :: UserQuery -> IO (Maybe u)
|
||||
userID :: u -> UserID u
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user