From a0c5ed71de91af7b1d758e2d67d8790e99996152 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Mon, 15 Jan 2024 01:47:28 +0100 Subject: [PATCH] persistent db --- app/Main.hs | 30 ++++++++--------------- app/UniWorX.hs | 52 ++++++++++++++++++++++++++++++++++++++++ flake.nix | 2 +- oauth2-mock-server.cabal | 10 ++++++++ package.yaml | 3 +++ src/LoginForm.hs | 2 +- src/Server.hs | 4 ++-- src/User.hs | 46 ++++++++++++++++++----------------- 8 files changed, 103 insertions(+), 46 deletions(-) create mode 100644 app/UniWorX.hs diff --git a/app/Main.hs b/app/Main.hs index 28ffe38..14e2dd9 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,30 +1,20 @@ +{-# Language TypeApplications #-} + module Main (main) where +import UniWorX import Server - import Control.Applicative ((<|>)) - +import System.Environment (lookupEnv) import qualified Data.Map as M -import System.Environment (getArgs) - main :: IO () main = do - args <- getArgs >>= flip buildArgs M.empty - port <- determinePort args + 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 + runMockServer port testUsers where - buildArgs :: [String] -> M.Map String String -> IO (M.Map String String) - buildArgs [] m = return m - buildArgs (k:v:xs) m = return (M.insert k v m) >>= buildArgs xs - buildArgs _ _ = error "invalid command line args" - - determinePort :: M.Map String String -> IO Int - determinePort args = do - case M.lookup "-p" args <|> M.lookup "--port" args of - Just port -> return $ read port - Nothing -> return 9443 - - - + determinePort :: IO Int + determinePort = do + Just port <- (read @Int <$> lookupEnv "OAUTH2_SERVER_PORT") <|> Just 9443 + return port diff --git a/app/UniWorX.hs b/app/UniWorX.hs new file mode 100644 index 0000000..4fe8dd2 --- /dev/null +++ b/app/UniWorX.hs @@ -0,0 +1,52 @@ +{-# Language GADTs, GeneralizedNewtypeDeriving, OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies #-} + +module UniWorX (User(..), initDB, testUsers) where + +import User + +import Control.Applicative ((<|>)) +import Control.Monad (void, forM_) + +import Database.Persist +import Database.Persist.TH +import Database.Persist.Postgresql + +import System.Environment (lookupEnv) + + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| + User + name Text + email Text + deriving Eq Show +|] + +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"}] + +runDB :: 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 + +initDB :: IO () +initDB = runDB $ do + runMigration migrateAll + forM_ testUsers $ void . insert + +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)] + lookupUser email _ = runDB $ do + user <- selectList [UserEmail ==. e] [] + case user of + [Entity _ u] -> return $ Just u + [] -> Nothing + _ -> error "Ambiguous User." diff --git a/flake.nix b/flake.nix index cabde49..9d98e99 100644 --- a/flake.nix +++ b/flake.nix @@ -20,7 +20,7 @@ ''; }; buildInputs = [ stackWrapper ] ++ ( - with pkgs; [ reuse zlib ] ++ ( + with pkgs; [ reuse zlib postgresql_16 ] ++ ( with haskell.packages."ghc927"; [ ghc haskell-language-server ] ) ); diff --git a/oauth2-mock-server.cabal b/oauth2-mock-server.cabal index 240d473..dc55627 100644 --- a/oauth2-mock-server.cabal +++ b/oauth2-mock-server.cabal @@ -42,6 +42,9 @@ library , http-client , http-media , jose-jwt + , persistent + , persistent-postgresql + , persistent-template , servant , servant-client , servant-server @@ -57,6 +60,7 @@ library executable oauth2-mock-server-exe main-is: Main.hs other-modules: + UniWorX Paths_oauth2_mock_server autogen-modules: Paths_oauth2_mock_server @@ -75,6 +79,9 @@ executable oauth2-mock-server-exe , http-media , jose-jwt , oauth2-mock-server + , persistent + , persistent-postgresql + , persistent-template , servant , servant-client , servant-server @@ -109,6 +116,9 @@ test-suite oauth2-mock-server-test , http-media , jose-jwt , oauth2-mock-server + , persistent + , persistent-postgresql + , persistent-template , servant , servant-client , servant-server diff --git a/package.yaml b/package.yaml index 448b44a..60460b0 100644 --- a/package.yaml +++ b/package.yaml @@ -40,6 +40,9 @@ dependencies: - blaze-html - http-media - string-interpolate +- persistent +- persistent-postgresql +- persistent-template ghc-options: - -Wall diff --git a/src/LoginForm.hs b/src/LoginForm.hs index 18202fb..7adae98 100644 --- a/src/LoginForm.hs +++ b/src/LoginForm.hs @@ -51,7 +51,7 @@ loginPage headers = docTypeHtml $ head' >> body' const formData = new FormData(#{formID}); const creds = formData.get('#{emailID}') + ':' + ''; headers.append('Authorization', btoa(creds)); - alert(creds); + //alert(creds); e.preventDefault(); fetch('../code', { method: 'GET', diff --git a/src/Server.hs b/src/Server.hs index 7c252ac..45bed97 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -363,8 +363,8 @@ authenticate users = BasicAuthCheck $ \authData -> do -- frontend :: BasicAuthData -> ClientM (Map.Map Text Text) -- frontend ba = client authAPI ba "[ID]" "42" "code" "" -runMockServer :: Int -> IO () -runMockServer port = do +runMockServer :: Int -> [User] -> IO () +runMockServer port testUsers = do state <- mkState @User @(Map.Map Text Text) run port $ insecureOAuthMock' testUsers state diff --git a/src/User.hs b/src/User.hs index 8c48fa5..dafaa5e 100644 --- a/src/User.hs +++ b/src/User.hs @@ -2,8 +2,8 @@ module User ( UserData(..) -, User (..) -, testUsers +-- , User (..) +-- , testUsers ) where import Data.Aeson @@ -12,37 +12,39 @@ import Data.Map.Strict import Data.Maybe import Data.Text hiding (singleton, find) +import Database.Persist (PersistEntity(..), Entity(..)) + import GHC.Generics type UserName = Text type Password = Text -class (Show u, ToJSON a, Monoid a) => UserData u a where -- TODO Show maybe not necessary, but currently needed for TypeApplications +class (PersistEntity u, Show u, ToJSON a, Monoid a) => UserData u a where -- TODO Show maybe not necessary data Scope u readScope :: String -> Scope u showScope :: Scope u -> String - userScope :: u -> Scope u -> a + userScope :: Entity u -> Scope u -> a lookupUser :: UserName -> Password -> IO (Maybe u) -data User = User - { name :: Text - , email :: Text - , password :: Text - , uID :: Text - } deriving (Eq, Show) +-- data User = User +-- { name :: Text +-- , email :: Text +-- , password :: Text +-- , uID :: Text +-- } deriving (Eq, Show) -testUsers :: [User] -- TODO move to db -testUsers = - [ User {name = "Fallback User", email = "foo@bar.com", password = "0000", uID = "0"} - , User {name = "Tina Tester", email = "t@t.tt", password = "1111", uID = "1"} - , User {name = "Max Muster", email = "m@m.mm", password = "2222", uID = "2"}] +-- testUsers :: [User] -- TODO move to db +-- testUsers = +-- [ User {name = "Fallback User", email = "foo@bar.com", password = "0000", uID = "0"} +-- , User {name = "Tina Tester", email = "t@t.tt", password = "1111", uID = "1"} +-- , User {name = "Max Muster", email = "m@m.mm", password = "2222", uID = "2"}] -instance UserData User (Map Text Text) where - data Scope User = ID | Profile deriving (Show, Read, Eq) - readScope = read - showScope = show - userScope User{..} ID = singleton "id" uID - userScope User{..} Profile = fromList [("name", name), ("email", email)] - lookupUser e _ = return $ find (\User{..} -> email == e) testUsers \ No newline at end of file +-- instance UserData User (Map Text Text) where +-- data Scope User = ID | Profile deriving (Show, Read, Eq) +-- readScope = read +-- showScope = show +-- userScope User{..} ID = singleton "id" uID +-- userScope User{..} Profile = fromList [("name", name), ("email", email)] +-- lookupUser e _ = return $ find (\User{..} -> email == e) testUsers \ No newline at end of file