fixed signing of id tokens
This commit is contained in:
David Mosbach
parent
26d2255c25
commit
2530a2dad6
@ -132,10 +132,10 @@ data AuthRequest user = AuthRequest
|
||||
type TokenParams user = (user, [Scope' user], Maybe Text)
|
||||
|
||||
data State user = State
|
||||
{ activeCodes :: Map Text (AuthRequest user)
|
||||
{ activeCodes :: Map Text (AuthRequest user)
|
||||
, activeTokens :: Map UUID (TokenParams user)
|
||||
, publicKey :: Jwk
|
||||
, privateKey :: Jwk
|
||||
, publicKey :: Jwk
|
||||
, privateKey :: Jwk
|
||||
}
|
||||
|
||||
type AuthState user = TVar (State user)
|
||||
@ -190,7 +190,7 @@ mkToken :: forall user userData . UserData user userData
|
||||
-> AuthState user
|
||||
-> IO JWTWrapper
|
||||
mkToken (u, scopes, nonce) clientID state = do
|
||||
pubKey <- atomically $ readTVar state >>= return . publicKey
|
||||
(pubKey, privKey) <- atomically $ readTVar state >>= return . ((,) <$> publicKey <*> privateKey)
|
||||
now <- getCurrentTime
|
||||
uuid <- nextRandom
|
||||
port <- pack <$> getEnv "OAUTH2_SERVER_PORT"
|
||||
@ -212,20 +212,25 @@ mkToken (u, scopes, nonce) clientID state = do
|
||||
}
|
||||
encodedAT <- jwkEncode RSA_OAEP_256 A128GCM pubKey (Nested . Jwt . toStrict $ encode at)
|
||||
encodedRT <- jwkEncode RSA_OAEP_256 A128GCM pubKey (Nested . Jwt . toStrict $ encode rt)
|
||||
encodedIT <- Jws.jwkEncode RS256 pubKey (Nested . Jwt . toStrict $ encode it)
|
||||
encodedIT <- Jws.jwkEncode RS256 privKey (Nested . Jwt . toStrict $ encode it)
|
||||
case encodedAT >> encodedRT >> encodedIT of
|
||||
Right _ -> do
|
||||
let Jwt aToken = fromRight undefined encodedAT
|
||||
Jwt rToken = fromRight undefined encodedRT
|
||||
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)
|
||||
return $ JWTW
|
||||
{ acessToken = BS.unpack aToken
|
||||
, expiresIn = lifetimeAT
|
||||
, refreshToken = Just $ BS.unpack rToken
|
||||
, idToken = if Left OpenID `elem` scopes then Nothing else Just $ BS.unpack iToken
|
||||
}
|
||||
Left e -> error $ show e
|
||||
|
||||
decodeToken :: Text -> AuthState user -> IO (Either JwtError JwtContent)
|
||||
decodeToken token state = do
|
||||
prKey <- atomically $ readTVar state >>= return . privateKey
|
||||
jwkDecode prKey $ encodeUtf8 token
|
||||
key <- atomically $ readTVar state >>= return . privateKey
|
||||
jwkDecode key $ encodeUtf8 token
|
||||
|
||||
renewToken :: forall user userData . UserData user userData
|
||||
=> Text -- ^ token
|
||||
|
||||
@ -54,7 +54,7 @@ import qualified Data.Map.Strict as Map
|
||||
|
||||
import GHC.Read (readPrec, lexP)
|
||||
|
||||
import Jose.Jwk (generateRsaKeyPair, KeyUse(Enc), KeyId)
|
||||
import Jose.Jwk (generateRsaKeyPair, KeyUse(..), KeyId)
|
||||
import Jose.Jwt hiding (decode, encode)
|
||||
|
||||
import Network.HTTP.Client (newManager, defaultManagerSettings)
|
||||
@ -65,6 +65,7 @@ import Servant.Client hiding (client)
|
||||
import Servant.API
|
||||
|
||||
import Text.ParserCombinators.ReadPrec (look, pfail)
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
import qualified Text.Read.Lex as Lex
|
||||
|
||||
@ -81,10 +82,11 @@ data AuthClient = Client
|
||||
trustedClients :: [AuthClient] -- TODO move to db
|
||||
trustedClients = [Client "42" "shhh"]
|
||||
|
||||
data ResponseType = Code -- ^ authorisation code grant
|
||||
| Token -- ^ implicit grant via access token
|
||||
| IDToken -- ^ implicit grant via access token & ID token
|
||||
data ResponseType = Code -- ^ authorisation code flow
|
||||
| Token -- ^ implicit flow via access token
|
||||
| IDToken -- ^ implicit flow via access token & ID token
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Read ResponseType where
|
||||
readPrec = do
|
||||
Lex.Ident str <- lexP
|
||||
@ -107,6 +109,7 @@ type QState = Text
|
||||
type QNonce = Text
|
||||
type QAuth = Text
|
||||
type QCookie = Text
|
||||
type QPrompt = Text
|
||||
|
||||
type QParam = QueryParam' [Required, Strict]
|
||||
|
||||
@ -117,15 +120,17 @@ type Auth = "auth"
|
||||
:> QParam "redirect_uri" QRedirect
|
||||
:> QueryParam "state" QState
|
||||
:> QueryParam "nonce" QNonce
|
||||
:> QueryParam "prompt" QPrompt
|
||||
:> Header "Cookie" QCookie
|
||||
:> Get '[HTML] Html -- ^ login
|
||||
|
||||
type AuthCode = "code"
|
||||
:> HeaderR "Authorization" QAuth
|
||||
:> HeaderR "Authorization" QAuth --TODO store in cookie instead of passing as headers
|
||||
:> HeaderR "OA2_Scope" QScope
|
||||
:> HeaderR "OA2_Client_ID" QClient
|
||||
:> HeaderR "OA2_Redirect_URI" QRedirect
|
||||
:> Header "OA2_State" QState
|
||||
:> Header "OA2_Nonce" QNonce
|
||||
:> Get '[JSON] (Headers '[Header "Set-Cookie" Text] Text) -- ^ returns auth code
|
||||
|
||||
|
||||
@ -138,41 +143,47 @@ toHandler s h = runReaderT h s
|
||||
loginServer :: forall user userData . UserData user userData => AuthServer user Auth
|
||||
loginServer = decideLogin
|
||||
where
|
||||
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" }
|
||||
decideLogin scopes client responseType url mState mNonce mPrompt mCookies
|
||||
| Nothing <- responseType' = throwError err401 { errBody = "Unsupported response type" }
|
||||
| not validOIDC = throwError err401 { errBody = "For OIDC, the 'openid' scope and the 'id_token' response type must be given" }
|
||||
| Just "none" <- mPrompt = handleSSO
|
||||
| Just "login" <- mPrompt = handleLogin
|
||||
| Nothing <- mPrompt = handleLogin
|
||||
| otherwise = throwError err401 { errBody = "Prompt not supported" }
|
||||
where
|
||||
responseType' = readMaybe @ResponseType responseType
|
||||
validOIDC :: Bool
|
||||
validOIDC = let scopes' = map (read @(Scope' user)) $ words scopes
|
||||
in (Left OpenID `elem` scopes') == (responseType' == Just IDToken)
|
||||
-- | 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" }
|
||||
handleSSO :: AuthHandler user Html
|
||||
handleSSO = do -- TODO check openid scope
|
||||
liftIO $ putStrLn "login via SSO..."
|
||||
unless (read @ResponseType responseType == IDToken) $ throwError err500 { errBody = "Unsupported response type" }
|
||||
unless (isJust mCookies) $ throwError err500 { errBody = "Missing cookie" }
|
||||
let mCreds = lookup "oa2_auth_cookie" . parseCookiesText . encodeUtf8 $ fromJust mCookies
|
||||
unless (isJust mCreds) $ throwError err500 { errBody = "Missing oauth2 cookie" }
|
||||
url' <- handleCreds @user @userData (fromJust mCreds) scopes client url mState mNonce
|
||||
liftIO $ putStrLn "SSO successful"
|
||||
throwError err303 { errHeaders = [("Location", encodeUtf8 url')]}
|
||||
|
||||
-- | 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" }
|
||||
handleLogin =
|
||||
let 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)
|
||||
, ("OA2_Nonce", mNonce)
|
||||
]]
|
||||
in return $ loginPage headers
|
||||
|
||||
|
||||
codeServer :: forall user userData . UserData user userData => AuthServer user AuthCode
|
||||
codeServer creds scopes client url mState = addHeader ("oa2_auth_cookie=\"" <> creds <> "\"") <$>
|
||||
handleCreds @user @userData creds scopes client url mState Nothing
|
||||
codeServer creds scopes client url mState mNonce = addHeader ("oa2_auth_cookie=\"" <> creds <> "\"") <$>
|
||||
handleCreds @user @userData creds scopes client url mState mNonce
|
||||
|
||||
handleCreds :: forall user userData . UserData user userData
|
||||
=> QAuth
|
||||
@ -187,6 +198,7 @@ handleCreds creds scopes client url mState mNonce = do
|
||||
throwError $ err404 { errBody = "Not a trusted client."}
|
||||
let scopes' = map (read @(Scope' user)) $ words scopes
|
||||
[userName, password] = splitOn ":" $ decodeBase64Lenient creds
|
||||
liftIO . putStrLn $ "\acreds: " <> show userName
|
||||
mUser <- liftIO $ lookupUser @user @userData (UserQuery (Just userName) (Just password) Nothing)
|
||||
unless (isJust mUser) $ throwError err500 { errBody = "Unknown user."}
|
||||
let u = fromJust mUser
|
||||
@ -222,6 +234,7 @@ data ClientData = ClientData --TODO support other flows
|
||||
, clientID :: Maybe String
|
||||
, clientSecret :: Maybe String
|
||||
, redirect :: Maybe String
|
||||
, scopeSubset :: Maybe QScope
|
||||
} deriving Show
|
||||
|
||||
data AuthFlow = AuthFlow
|
||||
@ -232,11 +245,12 @@ instance FromHttpApiData AuthFlow where
|
||||
|
||||
instance FromForm ClientData where
|
||||
fromForm f = ClientData
|
||||
<$> ((Left . ACode <$> parseUnique "code" f) <|> (parseMaybe @String "scope" f *> (Right . RToken <$> parseUnique "refresh_token" f)))
|
||||
<$> ((Left . ACode <$> parseUnique "code" f) <|> (Right . RToken <$> parseUnique "refresh_token" f))
|
||||
<*> parseUnique "grant_type" f
|
||||
<*> parseMaybe "client_id" f
|
||||
<*> parseMaybe "client_secret" f
|
||||
<*> parseMaybe "redirect_uri" f
|
||||
<*> parseMaybe "scope" f
|
||||
|
||||
instance Error Text where
|
||||
strMsg = pack
|
||||
@ -267,10 +281,11 @@ tokenEndpoint = provideToken
|
||||
liftIO . putStrLn $ "token: " ++ show token
|
||||
return token
|
||||
Right (RToken jwtw) -> do
|
||||
let scopes = [] -- TODO read query param for this
|
||||
let scopes' = (map (read @(Scope' user)) . words) <$> scopeSubset client
|
||||
liftIO . putStrLn $ "\aSCOPES: " ++ show scopes'
|
||||
unless (grantType client == "refresh_token") . throwError $ err500 { errBody = "Invalid grant_type" }
|
||||
liftIO $ putStrLn "... checking refresh token"
|
||||
mToken <- asks (renewToken @user @userData jwtw scopes cid) >>= liftIO
|
||||
mToken <- asks (renewToken @user @userData jwtw (fromMaybe [] scopes') cid) >>= liftIO
|
||||
case mToken of
|
||||
Just token -> liftIO (putStrLn $ "refreshed token: " ++ show token) >> return token
|
||||
Nothing -> throwError $ err500 { errBody = "Invalid refresh token" }
|
||||
@ -334,7 +349,7 @@ userListEndpoint :: forall user userData . UserData user userData => AuthServer
|
||||
userListEndpoint = handleUserData
|
||||
where
|
||||
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
|
||||
handleUserData jwtw userID = verifyToken @user @userData jwtw >>= \case -- TODO check if this user is allowed to query other users
|
||||
Nothing -> return . QLeft $ QError "UnknownToken"
|
||||
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
|
||||
@ -373,6 +388,7 @@ type Routing user userData = Auth
|
||||
:<|> Token
|
||||
:<|> Me userData
|
||||
:<|> UserList userData
|
||||
:<|> Logout
|
||||
|
||||
routing :: forall user userData . UserData user userData => AuthServer user (Routing user userData)
|
||||
routing = loginServer @user @userData
|
||||
@ -380,6 +396,7 @@ routing = loginServer @user @userData
|
||||
:<|> tokenEndpoint @user @userData
|
||||
:<|> userEndpoint @user @userData
|
||||
:<|> userListEndpoint @user @userData
|
||||
:<|> logoutEndpoint @user @userData
|
||||
|
||||
|
||||
|
||||
@ -416,7 +433,7 @@ runMockServer port = runMockServerWithRoutes @user @userData @EmptyAPI port empt
|
||||
|
||||
mkState :: forall user userData . UserData user userData => IO (AuthState user)
|
||||
mkState = do
|
||||
(publicKey, privateKey) <- generateRsaKeyPair 256 (KeyId "Oauth2MockKey") Enc Nothing
|
||||
(publicKey, privateKey) <- generateRsaKeyPair 256 (KeyId "Oauth2MockJWT") Enc Nothing
|
||||
let
|
||||
activeCodes = Map.empty
|
||||
activeTokens = Map.empty
|
||||
|
||||
Loading…
Reference in New Issue
Block a user