53 lines
1.5 KiB
Haskell
53 lines
1.5 KiB
Haskell
{-# 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."
|