changed token endpoint mimetype

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

package.yaml

@@ -35,6 +35,7 @@ dependencies:
 - bytestring
 - jose-jwt
 - base64
+- http-api-data
 
 ghc-options:
 - -Wall

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

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