diff --git a/oauth2-mock-server.cabal b/oauth2-mock-server.cabal index b7b9dc2..11a719a 100644 --- a/oauth2-mock-server.cabal +++ b/oauth2-mock-server.cabal @@ -35,6 +35,7 @@ library , base64 , bytestring , containers + , http-api-data , http-client , jose-jwt , servant @@ -62,6 +63,7 @@ executable oauth2-mock-server-exe , base64 , bytestring , containers + , http-api-data , http-client , jose-jwt , oauth2-mock-server @@ -91,6 +93,7 @@ test-suite oauth2-mock-server-test , base64 , bytestring , containers + , http-api-data , http-client , jose-jwt , oauth2-mock-server diff --git a/package.yaml b/package.yaml index 040fdf5..315b3f2 100644 --- a/package.yaml +++ b/package.yaml @@ -35,6 +35,7 @@ dependencies: - bytestring - jose-jwt - base64 +- http-api-data ghc-options: - -Wall diff --git a/src/AuthCode.hs b/src/AuthCode.hs index 6a42fe1..08ec313 100644 --- a/src/AuthCode.hs +++ b/src/AuthCode.hs @@ -8,7 +8,7 @@ module AuthCode ) where import Data.Map.Strict (Map) -import Data.Maybe (isJust) +import Data.Maybe (isJust, fromMaybe) import Data.Time.Clock import Data.Text (pack, replace, Text) import Data.Text.Encoding.Base64 @@ -58,13 +58,13 @@ expire code time state = void . forkIO $ do atomically . modifyTVar state $ \s -> s{ activeCodes = M.delete code s.activeCodes } -verify :: Text -> String -> AuthState -> IO Bool -verify code clientID state = do +verify :: Text -> Maybe String -> AuthState -> IO Bool +verify code mClientID state = do now <- getCurrentTime mData <- atomically $ do result <- (readTVar >=> return . M.lookup code . activeCodes) state modifyTVar state $ \s -> s{ activeCodes = M.delete code s.activeCodes } return result return $ case mData of - Just (clientID', _) -> clientID == clientID' + Just (clientID', _) -> (fromMaybe clientID' mClientID) == clientID' _ -> False diff --git a/src/Server.hs b/src/Server.hs index 5dfa22d..80537c3 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -21,7 +21,7 @@ import Control.Monad.Trans.Reader import Data.Aeson import Data.ByteString (ByteString (..), fromStrict, toStrict) import Data.List (find, elemIndex) -import Data.Maybe (fromMaybe, isJust) +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 Data.Text.Encoding (decodeUtf8) @@ -48,6 +48,8 @@ import Text.ParserCombinators.ReadPrec (look, pfail) import qualified Text.Read.Lex as Lex +import Web.Internal.FormUrlEncoded (FromForm(..), parseUnique, parseMaybe) + testUsers :: [User] -- TODO move to db testUsers = @@ -149,23 +151,24 @@ data ClientData = ClientData { grantType :: GrantType , grant :: String , userName :: Maybe String - , clientID :: String - , clientSecret :: String + , clientID :: Maybe String + , clientSecret :: Maybe String , redirect :: Maybe String } deriving Show -instance FromJSON ClientData where - parseJSON (Object o) = ClientData - <$> o .: "grant_type" - <*> (o .: ps PassCreds --TODO add alternatives - <|> o .: ps AuthCode - <|> o .: ps Implicit - <|> o .: ps ClientCreds) - <*> o .:? "username" - <*> o .: "client_id" - <*> o .: "client_secret" - <*> o .:? "redirect_uri" - where ps = fromString @Key . show + +instance FromForm ClientData where + fromForm f = ClientData + <$> parseUnique "grant_type" f + <*> (parseUnique @String (ps PassCreds) f --TODO add alternatives + >> parseUnique @String (ps AuthCode) f + >> parseUnique @String (ps Implicit) f + >> parseUnique @String (ps ClientCreds) f) + <*> parseMaybe "username" f + <*> parseMaybe "client_id" f + <*> parseMaybe "client_secret" f + <*> parseMaybe "redirect_uri" f + where ps = pack . show data GrantType = PassCreds | AuthCode | Implicit | ClientCreds deriving (Eq) @@ -174,10 +177,10 @@ instance Show GrantType where show AuthCode = "code" show _ = undefined --TODO support other flows -instance FromJSON GrantType where - parseJSON (String s) - | s == pack (show AuthCode) = pure AuthCode - | otherwise = error $ show s ++ " grant type not supported yet" +instance FromHttpApiData GrantType where + parseQueryParam s + | s == pack (show AuthCode) = Right AuthCode + | otherwise = Left $ s <> " grant type not supported yet" data JWT = JWT { issuer :: Text @@ -206,7 +209,7 @@ instance FromHttpApiData JWTWrapper where Nothing -> Left "Invalid JWT wrapper" type Token = "token" - :> ReqBody '[JSON] ClientData + :> ReqBody '[FormUrlEncoded] ClientData :> Post '[JSON] JWTWrapper tokenEndpoint :: AuthServer Token @@ -215,9 +218,10 @@ tokenEndpoint = provideToken provideToken :: ClientData -> AuthHandler JWTWrapper provideToken client = case (grantType client) of AuthCode -> do - unless (Client (pack $ clientID client) (pack $ clientSecret client) `elem` trustedClients) . - throwError $ err500 { errBody = "Invalid client" } - valid <- asks (verify (pack $ grant client) (clientID client)) >>= liftIO + unless (isNothing (clientID client >> clientSecret client) + || Client (pack . fromJust $ clientID client) (pack . fromJust $ clientSecret client) `elem` trustedClients) . + throwError $ err500 { errBody = "Invalid client" } + valid <- asks (verify (pack $ grant client) (clientID client)) >>= liftIO -- TODO verify redirect url here unless valid . throwError $ err500 { errBody = "Invalid authorisation code" } -- return JWT {token = "", tokenType = "JWT", expiration = 0.25 * nominalDay} token <- asks mkToken >>= liftIO