77 lines
2.3 KiB
Haskell
77 lines
2.3 KiB
Haskell
{-# Language GADTs,
|
|
GeneralizedNewtypeDeriving,
|
|
OverloadedStrings,
|
|
QuasiQuotes,
|
|
TemplateHaskell,
|
|
TypeFamilies,
|
|
TypeApplications,
|
|
DerivingStrategies,
|
|
StandaloneDeriving,
|
|
UndecidableInstances,
|
|
DataKinds,
|
|
FlexibleInstances,
|
|
MultiParamTypeClasses,
|
|
RecordWildCards #-}
|
|
|
|
module UniWorX (User(..), initDB, testUsers) where
|
|
|
|
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
|
|
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 "Fallback User" "foo@bar.com"
|
|
, User "Tina Tester" "t@t.tt"
|
|
, User "Max Muster" "m@m.mm"]
|
|
|
|
runDB :: ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> IO a
|
|
runDB action = do
|
|
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
|
|
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 = M.singleton "id" . T.pack $ show uID
|
|
userScope (Entity _ User{..}) Profile = M.fromList [("name", userName), ("email", userEmail)]
|
|
lookupUser email _ = runDB $ do
|
|
user <- selectList [UserEmail ==. email] []
|
|
case user of
|
|
[entity] -> return $ Just entity
|
|
[] -> return Nothing
|
|
_ -> error "Ambiguous User."
|