diff --git a/src/AuthCode.hs b/src/AuthCode.hs index 6f366be..f836724 100644 --- a/src/AuthCode.hs +++ b/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 - , 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 diff --git a/src/Server.hs b/src/Server.hs index 877ff45..dd6f619 100644 --- a/src/Server.hs +++ b/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 - | 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