diff --git a/src/AuthCode.hs b/src/AuthCode.hs index 101b232..da21caf 100644 --- a/src/AuthCode.hs +++ b/src/AuthCode.hs @@ -164,18 +164,17 @@ decodeToken token state = do prKey <- atomically $ readTVar state >>= return . privateKey jwkDecode prKey $ encodeUtf8 token -renewToken :: JWTWrapper -> AuthState user -> IO (Maybe JWTWrapper) -renewToken (JWTW _ _ rt) state = case rt >>= stripPrefix "Bearer " . pack of - Just t -> decodeToken t state >>= \case - Right (Jwe (header, body)) -> do - let jwt = fromJust . decode @JWT $ fromStrict body - now <- getCurrentTime - if now <= expiration jwt then return Nothing else do - mUser <- atomically . stateTVar state $ \s -> - 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 - Nothing -> return Nothing - Left _ -> return Nothing - Nothing -> return Nothing +renewToken :: Text -> AuthState user -> IO (Maybe JWTWrapper) +renewToken t state = decodeToken t state >>= \case + Right (Jwe (header, body)) -> do + let jwt = fromJust . decode @JWT $ fromStrict body + now <- getCurrentTime + if now >= expiration jwt then return Nothing else do + mUser <- atomically . stateTVar state $ \s -> + 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 + Nothing -> return Nothing + Left _ -> return Nothing + diff --git a/src/Server.hs b/src/Server.hs index 922d66a..6942e9b 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -3,7 +3,16 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# LANGUAGE DataKinds, TypeOperators, OverloadedStrings, ScopedTypeVariables, TypeApplications, RecordWildCards, AllowAmbiguousTypes #-} +{-# LANGUAGE + DataKinds + , TypeOperators + , OverloadedStrings + , ScopedTypeVariables + , TypeApplications + , RecordWildCards + , AllowAmbiguousTypes + , LambdaCase +#-} module Server {-( insecureOAuthMock' @@ -53,7 +62,7 @@ import Text.ParserCombinators.ReadPrec (look, pfail) import qualified Text.Read.Lex as Lex -import Web.Internal.FormUrlEncoded (FromForm(..), parseUnique, parseMaybe) +import Web.Internal.FormUrlEncoded (FromForm(..), parseUnique, parseMaybe, Form(..)) @@ -159,7 +168,7 @@ codeServer = handleCreds scopes' = map (readScope @user @userData) $ words scopes [userName, password] = splitOn ":" $ decodeBase64Lenient creds liftIO $ print userName - mUser <- liftIO $ lookupUser @user @userData userName password + 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 @@ -185,9 +194,11 @@ codeServer = handleCreds ---------------------- newtype ACode = ACode String deriving (Show) +newtype RToken = RToken Text deriving (Show) data ClientData = ClientData --TODO support other flows - { authID :: Either ACode JWTWrapper + { authID :: Either ACode RToken + , grantType :: Text , clientID :: Maybe String , clientSecret :: Maybe String , redirect :: Maybe String @@ -198,10 +209,11 @@ instance FromHttpApiData AuthFlow where parseQueryParam "authorization_code" = Right AuthFlow parseQueryParam x = Left x + instance FromForm ClientData where fromForm f = ClientData - <$> ((parseUnique @AuthFlow "grant_type" f) *> ((Left . ACode <$> parseUnique "code" f) - <|> (Right <$> parseUnique "refresh_token" f))) + <$> ((Left . ACode <$> parseUnique "code" f) <|> (parseMaybe @String "scope" f *> (Right . RToken <$> parseUnique "refresh_token" f))) + <*> parseUnique "grant_type" f <*> parseMaybe "client_id" f <*> parseMaybe "client_secret" f <*> parseMaybe "redirect_uri" f @@ -220,11 +232,13 @@ tokenEndpoint = provideToken where provideToken :: ClientData -> AuthHandler user JWTWrapper provideToken client = do + liftIO . putStrLn $ "Mock Server: received client data @ /token: " ++ show client unless (isNothing (clientID client >> clientSecret client) || Client (pack . fromJust $ clientID client) (pack . fromJust $ clientSecret client) `elem` trustedClients) . throwError $ err500 { errBody = "Invalid 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} @@ -232,7 +246,9 @@ tokenEndpoint = provideToken token <- asks (mkToken @user user scopes) >>= liftIO liftIO . putStrLn $ "token: " ++ show token return token - Right jwtw -> do + Right (RToken jwtw) -> do + unless (grantType client == "refresh_token") . throwError $ err500 { errBody = "Invalid grant_type" } + liftIO $ putStrLn "... checking refresh token" mToken <- asks (renewToken @user jwtw) >>= liftIO case mToken of Just token -> liftIO (putStrLn $ "refreshed token: " ++ show token) >> return token @@ -250,41 +266,58 @@ type HeaderR = Header' [Strict, Required] type Me userData = Users :> "me" :> HeaderR "Authorization" Text - :> Get '[JSON] (Maybe userData) + :> Get '[JSON] (QueryResult userData) type UserList userData = Users :> "query" :> HeaderR "Authorization" Text - :> Get '[JSON] [userData] -- TODO support query params + :> QParam "id" Text + :> Get '[JSON] (QueryResult [userData]) + +data QueryResult result = QLeft QueryError | QRight result +newtype QueryError = QError Text + +instance ToJSON QueryError where + toJSON (QError code) = object ["error" .= object ["code" .= code]] + +instance ToJSON result => ToJSON (QueryResult result) where + toJSON (QLeft x) = toJSON x + toJSON (QRight x) = toJSON x + + +verifyToken :: forall user userData . UserData user userData => Text -> AuthHandler user (Maybe (user, [Scope user])) +verifyToken jwtw = do + let mToken = stripPrefix "Bearer " jwtw + unless (isJust mToken) . throwError $ err500 { errBody = "Invalid token format" } + token <- asks (decodeToken @user (fromJust mToken)) >>= liftIO + liftIO $ putStrLn "decoded token:" >> print token + case token of + Left e -> throwError $ err500 { errBody = fromString $ show e } + Right (Jwe (header, body)) -> do + let jwt = fromJust . decode @JWT $ fromStrict body + -- TODO check if token grants access, then read logged in user from cookie + liftIO $ print jwt + ask >>= liftIO . (atomically . readTVar >=> return . Map.lookup (jti jwt) . activeTokens) userEndpoint :: forall user userData . UserData user userData => AuthServer user (Me userData) userEndpoint = handleUserData where - handleUserData :: Text -> AuthHandler user (Maybe userData) - handleUserData jwtw = do - let mToken = stripPrefix "Bearer " jwtw - unless (isJust mToken) . throwError $ err500 { errBody = "Invalid token format" } - token <- asks (decodeToken @user (fromJust mToken)) >>= liftIO - liftIO $ putStrLn "decoded token:" >> print token - case token of - Left e -> throwError $ err500 { errBody = fromString $ show e } - Right (Jwe (header, body)) -> do - let jwt = fromJust . decode @JWT $ fromStrict body - -- TODO check if token grants access, then read logged in user from cookie - liftIO $ print jwt - mUser <- ask >>= liftIO . (atomically . readTVar >=> return . Map.lookup (jti jwt) . activeTokens) - case mUser of - Just (u, scopes) -> return . Just . mconcat $ map (userScope @user @userData u) scopes - Nothing -> throwError $ err500 { errBody = "Unknown token" } + 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 + Nothing -> return . QLeft $ QError "UnknownToken" userListEndpoint :: forall user userData . UserData user userData => AuthServer user (UserList userData) userListEndpoint = handleUserData where - handleUserData :: Text -> AuthHandler user [userData] - handleUserData jwtw = do - undefined + 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 + Nothing -> return . QLeft $ QError "UserDoesNotExist" ------------------- @@ -296,7 +329,6 @@ type Routing user userData = Auth :<|> Token :<|> Me userData :<|> UserList userData - -- :<|> "qauth" :> Get '[HTML] Html routing :: forall user userData . UserData user userData => AuthServer user (Routing user userData) routing = loginServer @user @userData @@ -304,7 +336,6 @@ routing = loginServer @user @userData :<|> tokenEndpoint @user @userData :<|> userEndpoint @user @userData :<|> userListEndpoint @user @userData - -- :<|> return (loginPage "/foobar") diff --git a/src/User.hs b/src/User.hs index c49eccd..b1d0aea 100644 --- a/src/User.hs +++ b/src/User.hs @@ -20,4 +20,4 @@ class (Eq u, Show u, ToJSON a, Monoid a) => UserData u a where -- TODO Show mayb readScope :: String -> Scope u showScope :: Scope u -> String userScope :: u -> Scope u -> a - lookupUser :: UserName -> Password -> IO (Maybe u) + lookupUser :: UserName -> Maybe Password -> IO (Maybe u)