From 23a5a93509759c7bbd3ceb67b87547dd7b8f42dd Mon Sep 17 00:00:00 2001
From: David Mosbach <david.mosbach@live.de>
Date: Tue, 9 Jan 2024 02:23:40 +0100
Subject: [PATCH] auth code & client secret verification

---
 src/AuthCode.hs | 14 ++++++++++-
 src/Server.hs   | 65 +++++++++++++++++++++++++++++++++++--------------
 2 files changed, 60 insertions(+), 19 deletions(-)

diff --git a/src/AuthCode.hs b/src/AuthCode.hs
index 4324e36..708ba4b 100644
--- a/src/AuthCode.hs
+++ b/src/AuthCode.hs
@@ -4,6 +4,7 @@ module AuthCode
 ( State (..)
 , AuthState
 , genUnencryptedCode
+, verify
 ) where
 
 import Data.Map.Strict (Map)
@@ -14,7 +15,7 @@ import qualified Data.Map.Strict as M
 
 import Control.Concurrent (forkIO, threadDelay)
 import Control.Concurrent.STM.TVar
-import Control.Monad (void)
+import Control.Monad (void, (>=>))
 import Control.Monad.STM
 
 
@@ -48,3 +49,14 @@ expire code time state = void . forkIO $ do
   threadDelay $ fromEnum time
   atomically . modifyTVar state $ \s -> s{ activeCodes = M.delete code s.activeCodes }
 
+
+verify :: String -> String -> AuthState -> IO Bool
+verify code clientID 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'
+    _ -> False
diff --git a/src/Server.hs b/src/Server.hs
index 8daf341..4a8ecf4 100644
--- a/src/Server.hs
+++ b/src/Server.hs
@@ -9,6 +9,7 @@ module Server
 import AuthCode
 import User
 
+import Control.Applicative ((<|>))
 import Control.Concurrent
 import Control.Concurrent.STM.TVar (newTVarIO)
 import Control.Exception (bracket)
@@ -19,7 +20,7 @@ import Control.Monad.Trans.Reader
 import Data.Aeson
 import Data.ByteString (ByteString (..))
 import Data.List (find, elemIndex)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isJust)
 import Data.String (IsString (..))
 import Data.Text hiding (elem, find, head, length, map, null, splitAt, tail, words)
 import Data.Text.Encoding (decodeUtf8)
@@ -44,8 +45,13 @@ testUsers =
   , User {name = "Tina Tester", email = "t@t.tt", password = "1111", uID = "1"}
   , User {name = "Max Muster", email = "m@m.mm", password = "2222", uID = "2"}]
 
-trustedClients :: [Text] -- TODO move to db
-trustedClients = ["42"]
+data AuthClient = Client
+  { ident :: Text
+  , secret :: Text
+  } deriving (Show, Eq)
+
+trustedClients :: [AuthClient] -- TODO move to db
+trustedClients = [Client "42" "shhh"]
 
 data ResponseType = Code -- ^ authorisation code grant
                   | Token -- ^ implicit grant via access token
@@ -91,7 +97,7 @@ authServer = handleAuth
                -> QRedirect
                -> AuthHandler userData
     handleAuth u scopes client responseType url = do
-      unless (pack client `elem` trustedClients) . -- TODO fetch trusted clients from db | TODO also check if the redirect url really belongs to the client
+      unless (isJust $ find (\c -> ident c == pack client) trustedClients) . -- TODO fetch trusted clients from db | TODO also check if the redirect url really belongs to the client
         throwError $ err404 { errBody = "Not a trusted client."}
       let
         scopes' = map (readScope @user @userData) $ words scopes
@@ -160,20 +166,38 @@ runMockServer' port = do
 
 
 data ClientData = ClientData
-  { grantType :: Text
-  , grant :: Text
-  , clientID :: Text
-  , clientSecret :: Text
-  , redirect :: Text
+  { grantType :: GrantType
+  , grant :: String
+  , userName :: Maybe String
+  , clientID :: String
+  , clientSecret :: String
+  , redirect :: String
   } deriving Show
 
 instance FromJSON ClientData where
   parseJSON (Object o) = ClientData
-    <$> o .: "grant_type"
-    <*> o .: "authorization_code" --TODO add alternatives
-    <*> o .: "client_id"
-    <*> o .: "client_secret"
-    <*> o .: "redirect_url"
+    <$> 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_url"
+      where ps = fromString @Key . show
+
+data GrantType = PassCreds | AuthCode | Implicit | ClientCreds deriving (Eq)
+
+instance Show GrantType where
+  show PassCreds = "password"
+  show AuthCode  = "authorization_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"
 
 data JWT = JWT
   { token :: Text -- TODO should be JWT
@@ -189,8 +213,13 @@ tokenEndpoint :: AuthServer Token
 tokenEndpoint = provideToken
   where
     provideToken :: ClientData -> AuthHandler JWT
-    provideToken client = do
-      --TODO validate everything
-      return JWT {token = "", tokenType = "JWT", expiration = 0.25 * nominalDay}
+    provideToken client = case (grantType client) of
+      AuthCode -> do
+        --TODO validate everything
+        unless (Client (pack $ clientID client) (pack $ clientSecret client) `elem` trustedClients) .
+          throwError $ err500 { errBody = "Invalid client" }
+        valid <- asks (verify (grant client) (clientID client)) >>= liftIO
+        unless valid . throwError $ err500 { errBody = "Invalid authorisation code" }
+        return JWT {token = "", tokenType = "JWT", expiration = 0.25 * nominalDay}
+      x -> error $ show x ++ " not supported yet"
 
-      
\ No newline at end of file