persistent db

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
-  port <- determinePort args
   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)
+      determinePort :: IO Int
-      buildArgs [] m = return m
+      determinePort = do
-      buildArgs (k:v:xs) m = return (M.insert k v m) >>= buildArgs xs
+        Just port <- (read @Int <$> lookupEnv "OAUTH2_SERVER_PORT") <|> Just 9443
-      buildArgs _ _ = error "invalid command line args"
+        return port
-
-      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
-
-
-

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."

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 ]
         )
       );

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

package.yaml

@@ -40,6 +40,9 @@ dependencies:
 - blaze-html
 - http-media
 - string-interpolate
+- persistent
+- persistent-postgresql
+- persistent-template
 
 ghc-options:
 - -Wall

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',

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 :: Int -> [User] -> IO ()
-runMockServer port = do
+runMockServer port testUsers = do
   state <- mkState @User @(Map.Map Text Text)
   run port $ insecureOAuthMock' testUsers state
 

src/User.hs

@@ -2,8 +2,8 @@
 
 module User
 ( UserData(..)
-, User (..)
+-- , User (..)
-, testUsers
+-- , 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
+-- data User = User
-  { name     :: Text
+--   { name     :: Text
-  , email    :: Text
+--   , email    :: Text
-  , password :: Text
+--   , password :: Text
-  , uID      :: Text
+--   , uID      :: Text
-  } deriving (Eq, Show)
+--   } deriving (Eq, Show)
 
-testUsers :: [User] -- TODO move to db
+-- testUsers :: [User] -- TODO move to db
-testUsers =
+-- testUsers =
-  [ User {name = "Fallback User", email = "foo@bar.com", password = "0000", uID = "0"}
+--   [ 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 = "Tina Tester", email = "t@t.tt", password = "1111", uID = "1"}
-  , User {name = "Max Muster", email = "m@m.mm", password = "2222", uID = "2"}]
+--   , User {name = "Max Muster", email = "m@m.mm", password = "2222", uID = "2"}]
 
 
-instance UserData User (Map Text Text) where
+-- instance UserData User (Map Text Text) where
-  data Scope User = ID | Profile deriving (Show, Read, Eq)
+--   data Scope User = ID | Profile deriving (Show, Read, Eq)
-  readScope = read
+--   readScope = read
-  showScope = show
+--   showScope = show
-  userScope User{..} ID = singleton "id" uID
+--   userScope User{..} ID = singleton "id" uID
-  userScope User{..} Profile = fromList [("name", name), ("email", email)]
+--   userScope User{..} Profile = fromList [("name", name), ("email", email)]
-  lookupUser e _ = return $ find (\User{..} -> email == e) testUsers
+--   lookupUser e _ = return $ find (\User{..} -> email == e) testUsers