fixed signing of id tokens

src/AuthCode.hs

@@ -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
+  , publicKey    :: Jwk
-  , privateKey  :: 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
+  key <- atomically $ readTVar state >>= return . privateKey
-  jwkDecode prKey $ encodeUtf8 token
+  jwkDecode key $ encodeUtf8 token
 
 renewToken :: forall user userData . UserData user userData
            => Text -- ^ token

src/Server.hs

@@ -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
+data ResponseType = Code -- ^ authorisation code flow
-                  | Token -- ^ implicit grant via access token
+                  | Token -- ^ implicit flow via access token
-                  | IDToken -- ^ implicit grant via access token & ID 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
+    decideLogin scopes client responseType url mState mNonce mPrompt mCookies
-      | Just nonce <- mNonce, Just cookies <- mCookies = handleOIDC nonce cookies
+      | Nothing <- responseType' = throwError err401 { errBody = "Unsupported response type" }
-      | Nothing <- (mNonce >> mCookies) = handleLogin
+      | not validOIDC = throwError err401 { errBody = "For OIDC, the 'openid' scope and the 'id_token' response type must be given" }
-      | otherwise = throwError err500 { errBody = "Either cookie or nonce missing" }
+      | 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
+        handleSSO :: AuthHandler user Html
-                   -> QCookie
+        handleSSO = do -- TODO check openid scope
-                   -> AuthHandler user Html
+          liftIO $ putStrLn "login via SSO..."
-        handleOIDC nonce cookies = case read @ResponseType responseType of -- TODO nonce can also occur if user is not logged in yet
+          unless (read @ResponseType responseType == IDToken) $ throwError err500 { errBody = "Unsupported response type" }
-          IDToken -> do
+          unless (isJust mCookies) $ throwError err500 { errBody = "Missing cookie" }
-            let mCreds = lookup "oa2_auth_cookie" . parseCookiesText $ encodeUtf8 cookies
+          let mCreds = lookup "oa2_auth_cookie" . parseCookiesText . encodeUtf8 $ fromJust mCookies
-            unless (isJust mCreds) $ throwError err401 { errBody = "Missing auth cookie" }
+          unless (isJust mCreds) $ throwError err500 { errBody = "Missing oauth2 cookie" }
-            url' <- handleCreds @user @userData (fromJust mCreds) scopes client url mState (Just nonce)
+          url' <- handleCreds @user @userData (fromJust mCreds) scopes client url mState mNonce
-            throwError err303 { errHeaders = [("Location", encodeUtf8 url')]}
+          liftIO $ putStrLn "SSO successful"
-          _ -> throwError err500 { errBody = "Unsupported response type" }
+          throwError err303 { errHeaders = [("Location", encodeUtf8 url')]}
 
         -- | Html login form
         handleLogin :: AuthHandler user Html
-        handleLogin = do
+        handleLogin =
-          let
+          let headers = Map.fromList @Text @Text $
-            responseType' = read @ResponseType responseType
+                [ ("OA2_Scope", pack scopes)
-            headers = Map.fromList @Text @Text $
+                , ("OA2_Client_ID", pack client)
-              [ ("OA2_Scope", pack scopes)
+                , ("OA2_Redirect_URI", url)
-              , ("OA2_Client_ID", pack client)
+                ] ++ [(x,y) | (x, Just y) <-
-              , ("OA2_Redirect_URI", url)
+                      [ ("OA2_State", mState)
-              ] ++ [(x,y) | (x, Just y) <- [("OA2_State", mState)]]
+                      , ("OA2_Nonce", mNonce)
-          case responseType' of
+                      ]]
-            Code -> return $ loginPage headers
+          in return $ loginPage headers
-            _ -> throwError err500 { errBody = "Unsupported response type" }
       
 
 codeServer :: forall user userData . UserData user userData => AuthServer user AuthCode
-codeServer creds scopes client url mState = addHeader ("oa2_auth_cookie=\"" <> creds <> "\"") <$>
+codeServer creds scopes client url mState mNonce = addHeader ("oa2_auth_cookie=\"" <> creds <> "\"") <$>
-  handleCreds @user @userData creds scopes client url mState Nothing
+  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