From 4ccd17d357ce663b3297233235959a39b39d18a3 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Tue, 16 Jan 2024 03:06:13 +0100 Subject: [PATCH] removed specific user types from library --- README.md | 4 ++++ app/Main.hs | 7 +++--- app/UniWorX.hs | 50 +++++++++++++++++++++++++++++----------- oauth2-mock-server.cabal | 9 ++++++++ package.yaml | 3 +++ src/AuthCode.hs | 8 ++++--- src/Server.hs | 47 ++++++++++++++++--------------------- src/User.hs | 2 +- 8 files changed, 83 insertions(+), 47 deletions(-) diff --git a/README.md b/README.md index e9d1f06..701105a 100644 --- a/README.md +++ b/README.md @@ -1 +1,5 @@ # oauth2-mock-server + Windows: + ``` + ghcup run --mingw-path -- stack run + ``` \ No newline at end of file diff --git a/app/Main.hs b/app/Main.hs index 14e2dd9..d970085 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -7,14 +7,15 @@ import Server import Control.Applicative ((<|>)) import System.Environment (lookupEnv) import qualified Data.Map as M +import qualified Data.Text as T main :: IO () main = do port <- determinePort putStrLn $ "Try: http://localhost:" ++ show port ++ "/auth?scope=ID%20Profile&client_id=42&response_type=code&redirect_uri=http:%2F%2Flocalhost:0000%2F" - runMockServer port testUsers + runMockServer @User @(M.Map T.Text T.Text) port where determinePort :: IO Int determinePort = do - Just port <- (read @Int <$> lookupEnv "OAUTH2_SERVER_PORT") <|> Just 9443 - return port + Just port <- lookupEnv "OAUTH2_SERVER_PORT" >>= \p -> return $ p <|> Just "9443" + return $ read @Int port diff --git a/app/UniWorX.hs b/app/UniWorX.hs index 4fe8dd2..06f45d5 100644 --- a/app/UniWorX.hs +++ b/app/UniWorX.hs @@ -1,4 +1,17 @@ -{-# Language GADTs, GeneralizedNewtypeDeriving, OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies #-} +{-# Language GADTs, + GeneralizedNewtypeDeriving, + OverloadedStrings, + QuasiQuotes, + TemplateHaskell, + TypeFamilies, + TypeApplications, + DerivingStrategies, + StandaloneDeriving, + UndecidableInstances, + DataKinds, + FlexibleInstances, + MultiParamTypeClasses, + RecordWildCards #-} module UniWorX (User(..), initDB, testUsers) where @@ -6,6 +19,17 @@ import User import Control.Applicative ((<|>)) import Control.Monad (void, forM_) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Logger (runStderrLoggingT, NoLoggingT) +import Control.Monad.Reader (ReaderT) + +import Conduit (ResourceT) + +import Data.Map (Map(..)) +import Data.String (IsString(..)) +import Data.Text (Text(..)) +import qualified Data.Map as M +import qualified Data.Text as T import Database.Persist import Database.Persist.TH @@ -23,15 +47,15 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| testUsers :: [User] -- TODO move to db testUsers = - [ User {name = "Fallback User", email = "foo@bar.com"} - , User {name = "Tina Tester", email = "t@t.tt"} - , User {name = "Max Muster", email = "m@m.mm"}] + [ User "Fallback User" "foo@bar.com" + , User "Tina Tester" "t@t.tt" + , User "Max Muster" "m@m.mm"] -runDB :: IO a -> IO a +runDB :: ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> IO a runDB action = do - Just port <- lookupEnv "OAUTH2_DB_PORT" <|> Just "9444" - let connStr = "host=localhost dbname=test_users user=oauth2mock password=0000 port=" ++ port - withPostgresqlPool connStr 10 $ \pool -> flip runSqlPersistMPool pool action + Just port <- lookupEnv "OAUTH2_DB_PORT" >>= \p -> return $ p <|> Just "9444" + let connStr = fromString @ConnectionString $ "host=localhost dbname=test_users user=oauth2mock password=0000 port=" ++ port + runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ flip runSqlPersistMPool pool action initDB :: IO () initDB = runDB $ do @@ -42,11 +66,11 @@ instance UserData User (Map Text Text) where data Scope User = ID | Profile deriving (Show, Read, Eq) readScope = read showScope = show - userScope (Entity uID _) ID = singleton "id" uID - userScope (Entity _ User{..}) Profile = fromList [("name", name), ("email", email)] + userScope (Entity uID _) ID = M.singleton "id" . T.pack $ show uID + userScope (Entity _ User{..}) Profile = M.fromList [("name", userName), ("email", userEmail)] lookupUser email _ = runDB $ do - user <- selectList [UserEmail ==. e] [] + user <- selectList [UserEmail ==. email] [] case user of - [Entity _ u] -> return $ Just u - [] -> Nothing + [entity] -> return $ Just entity + [] -> return Nothing _ -> error "Ambiguous User." diff --git a/oauth2-mock-server.cabal b/oauth2-mock-server.cabal index dc55627..de2efa7 100644 --- a/oauth2-mock-server.cabal +++ b/oauth2-mock-server.cabal @@ -37,11 +37,14 @@ library , base64 , blaze-html , bytestring + , conduit , containers , http-api-data , http-client , http-media , jose-jwt + , monad-logger + , mtl , persistent , persistent-postgresql , persistent-template @@ -73,11 +76,14 @@ executable oauth2-mock-server-exe , base64 , blaze-html , bytestring + , conduit , containers , http-api-data , http-client , http-media , jose-jwt + , monad-logger + , mtl , oauth2-mock-server , persistent , persistent-postgresql @@ -110,11 +116,14 @@ test-suite oauth2-mock-server-test , base64 , blaze-html , bytestring + , conduit , containers , http-api-data , http-client , http-media , jose-jwt + , monad-logger + , mtl , oauth2-mock-server , persistent , persistent-postgresql diff --git a/package.yaml b/package.yaml index 60460b0..456f35a 100644 --- a/package.yaml +++ b/package.yaml @@ -43,6 +43,9 @@ dependencies: - persistent - persistent-postgresql - persistent-template +- monad-logger +- conduit +- mtl ghc-options: - -Wall diff --git a/src/AuthCode.hs b/src/AuthCode.hs index 1d23864..30f8930 100644 --- a/src/AuthCode.hs +++ b/src/AuthCode.hs @@ -21,6 +21,8 @@ import Data.UUID import qualified Data.Map.Strict as M +import Database.Persist (Entity(..)) + import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.STM.TVar import Control.Monad (void, (>=>)) @@ -45,7 +47,7 @@ instance FromJSON JWT where data AuthRequest user = AuthRequest { client :: String , codeExpiration :: NominalDiffTime - , user :: user + , user :: Entity user , scopes :: [Scope user] } @@ -53,7 +55,7 @@ data AuthRequest user = AuthRequest data State user = State { activeCodes :: Map Text (AuthRequest user) - , activeTokens :: Map UUID (user, [Scope user]) + , activeTokens :: Map UUID (Entity user, [Scope user]) , publicKey :: Jwk , privateKey :: Jwk } @@ -84,7 +86,7 @@ expire code time state = void . forkIO $ do atomically . modifyTVar state $ \s -> s{ activeCodes = M.delete code s.activeCodes } -verify :: Text -> Maybe String -> AuthState user -> IO (Maybe (user, [Scope user])) +verify :: Text -> Maybe String -> AuthState user -> IO (Maybe (Entity user, [Scope user])) verify code mClientID state = do now <- getCurrentTime mData <- atomically $ do diff --git a/src/Server.hs b/src/Server.hs index 45bed97..7089d23 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -34,6 +34,8 @@ import Data.UUID.V4 import qualified Data.ByteString.Char8 as BS import qualified Data.Map.Strict as Map +import Database.Persist (Entity(..)) + import GHC.Read (readPrec, lexP) import Jose.Jwa @@ -99,7 +101,6 @@ type QParam = QueryParam' [Required, Strict] -- type ProtectedAuth user = BasicAuth "login" user :> "auth" :> Auth -- Prompts for username & password -- type QuickAuth = "qauth" :> Auth -- Prompts for username only -type Foo user userData = BasicAuth "login" user :> "foo" :> Get '[JSON] userData type Auth = "auth" :> QParam "scope" QScope :> QParam "client_id" QClient @@ -246,7 +247,7 @@ tokenEndpoint = provideToken mkToken :: forall user userData . UserData user userData - => user -> [Scope user] -> AuthState user -> IO JWTWrapper + => Entity user -> [Scope user] -> AuthState user -> IO JWTWrapper mkToken u scopes state = do pubKey <- atomically $ readTVar state >>= return . publicKey now <- getCurrentTime @@ -273,7 +274,7 @@ type HeaderR = Header' [Strict, Required] type Me userData = Users :> "me" :> HeaderR "Authorization" Text - :> Get '[JSON] userData + :> Get '[JSON] (Maybe userData) type UserList userData = Users :> "query" @@ -284,7 +285,7 @@ type UserList userData = Users userEndpoint :: forall user userData . UserData user userData => AuthServer user (Me userData) userEndpoint = handleUserData where - handleUserData :: Text -> AuthHandler user userData + handleUserData :: Text -> AuthHandler user (Maybe userData) handleUserData jwtw = do let mToken = stripPrefix "Bearer " jwtw unless (isJust mToken) . throwError $ err500 { errBody = "Invalid token format"} @@ -298,7 +299,7 @@ userEndpoint = handleUserData liftIO $ print jwt mUser <- ask >>= liftIO . (atomically . readTVar >=> return . Map.lookup (jti jwt) . activeTokens) case mUser of - Just (u, scopes) -> return . mconcat $ map (userScope @user @userData u) scopes + Just (u, scopes) -> return . Just . mconcat $ map (userScope @user @userData u) scopes Nothing -> throwError $ err500 { errBody = "Unknown token" } @@ -324,7 +325,6 @@ type Routing user userData = Auth :<|> Token :<|> Me userData :<|> UserList userData - :<|> Foo user userData -- :<|> "qauth" :> Get '[HTML] Html routing :: forall user userData . UserData user userData => AuthServer user (Routing user userData) @@ -333,40 +333,33 @@ routing = loginServer @user @userData :<|> tokenEndpoint @user @userData :<|> userEndpoint @user @userData :<|> userListEndpoint @user @userData - :<|> undefined -- :<|> return (loginPage "/foobar") -exampleAuthServer :: AuthServer User (Routing User (Map.Map Text Text)) -exampleAuthServer = routing -authAPI :: Proxy (Routing User (Map.Map Text Text)) -authAPI = Proxy - -- insecureOAuthMock :: Application -- insecureOAuthMock = authAPI `serve` exampleAuthServer -insecureOAuthMock' :: [User] -> AuthState User -> Application -insecureOAuthMock' testUsers s = serveWithContext authAPI c $ hoistServerWithContext authAPI p (toHandler @User @(Map.Map Text Text) s) exampleAuthServer +insecureOAuthMock' :: forall user userData . UserData user userData => AuthState user -> Application +insecureOAuthMock' s = serve authAPI $ hoistServer authAPI (toHandler @user @userData s) (routing @user @userData) where - c = authenticate testUsers :. EmptyContext - p = Proxy :: Proxy '[BasicAuthCheck User] + authAPI = Proxy @(Routing user userData) -authenticate :: [User] -> BasicAuthCheck User -authenticate users = BasicAuthCheck $ \authData -> do - let - (uEmail, uPass) = (,) <$> (decodeUtf8 . basicAuthUsername) <*> (decodeUtf8 . basicAuthPassword) $ authData - case (find (\u -> email u == uEmail) users) of - Nothing -> return NoSuchUser - Just u -> return $ if uPass == password u then Authorized u else BadPassword +-- authenticate :: [User] -> BasicAuthCheck User +-- authenticate users = BasicAuthCheck $ \authData -> do +-- let +-- (uEmail, uPass) = (,) <$> (decodeUtf8 . basicAuthUsername) <*> (decodeUtf8 . basicAuthPassword) $ authData +-- case (find (\u -> email u == uEmail) users) of +-- Nothing -> return NoSuchUser +-- Just u -> return $ if uPass == password u then Authorized u else BadPassword -- frontend :: BasicAuthData -> ClientM (Map.Map Text Text) -- frontend ba = client authAPI ba "[ID]" "42" "code" "" -runMockServer :: Int -> [User] -> IO () -runMockServer port testUsers = do - state <- mkState @User @(Map.Map Text Text) - run port $ insecureOAuthMock' testUsers state +runMockServer :: forall user userData . UserData user userData => Int -> IO () +runMockServer port = do + state <- mkState @user @userData + run port $ insecureOAuthMock' @user @userData state -- runMockServer' :: Int -> IO () -- runMockServer' port = do diff --git a/src/User.hs b/src/User.hs index dafaa5e..f1080e5 100644 --- a/src/User.hs +++ b/src/User.hs @@ -24,7 +24,7 @@ class (PersistEntity u, Show u, ToJSON a, Monoid a) => UserData u a where -- TOD readScope :: String -> Scope u showScope :: Scope u -> String userScope :: Entity u -> Scope u -> a - lookupUser :: UserName -> Password -> IO (Maybe u) + lookupUser :: UserName -> Password -> IO (Maybe (Entity u)) -- data User = User