123 lines
3.7 KiB
Haskell
123 lines
3.7 KiB
Haskell
-- SPDX-FileCopyrightText: 2024 UniWorX Systems
|
|
-- SPDX-FileContributor: David Mosbach <david.mosbach@uniworx.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# Language GADTs,
|
|
GeneralizedNewtypeDeriving,
|
|
OverloadedStrings,
|
|
QuasiQuotes,
|
|
TemplateHaskell,
|
|
TypeFamilies,
|
|
TypeApplications,
|
|
DeriveGeneric,
|
|
DerivingStrategies,
|
|
StandaloneDeriving,
|
|
UndecidableInstances,
|
|
DataKinds,
|
|
FlexibleInstances,
|
|
MultiParamTypeClasses,
|
|
RecordWildCards #-}
|
|
|
|
module UniWorX (User(..), initDB) 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 Data.Yaml (decodeFileThrow, FromJSON(..), Value(..), (.:))
|
|
import qualified Data.Map as M
|
|
import qualified Data.Text as T
|
|
|
|
import Database.Persist
|
|
import Database.Persist.TH
|
|
import Database.Persist.Postgresql
|
|
|
|
import GHC.Generics
|
|
|
|
import System.Environment (lookupEnv)
|
|
|
|
|
|
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
|
|
User
|
|
firstName Text
|
|
surname Text
|
|
email Text
|
|
matricNumber Text Maybe
|
|
title Text Maybe
|
|
sex Text Maybe
|
|
birthday Text Maybe
|
|
telephone Text Maybe
|
|
mobile Text Maybe
|
|
compPersNumber Text Maybe
|
|
compDepartment Text Maybe
|
|
postAddress Text Maybe
|
|
deriving Eq Show Generic
|
|
|]
|
|
|
|
instance FromJSON User
|
|
|
|
data TestUserSpec = TestUsers
|
|
{ specialUsers :: [User]
|
|
, randomUsers :: Map Text [Text]
|
|
} deriving (Show)
|
|
|
|
instance FromJSON TestUserSpec where
|
|
parseJSON (Object o) = TestUsers <$> o .: "special-users" <*> o .: "random-users"
|
|
parseJSON _ = error "Oauth2 Mock Server: invalid test user format"
|
|
|
|
type DB = ReaderT SqlBackend (NoLoggingT (ResourceT IO))
|
|
|
|
runDB :: DB a -> IO a
|
|
runDB action = do
|
|
Just port <- lookupEnv "OAUTH2_DB_PORT" -- >>= \p -> return $ p <|> Just "9444"
|
|
Just host <- lookupEnv "OAUTH2_PGHOST"
|
|
let connStr = fromString @ConnectionString $ "host=" ++ host ++ " dbname=test_users user=oauth2mock password=0000 port=" ++ port
|
|
runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ flip runSqlPersistMPool pool action
|
|
|
|
initDB :: IO ()
|
|
initDB = do
|
|
Just testUserFile <- lookupEnv "OAUTH2_TEST_USERS"
|
|
runDB $ do
|
|
runMigration migrateAll
|
|
testUsers <- decodeFileThrow @DB @TestUserSpec testUserFile
|
|
liftIO . putStrLn $ "the test users:\n" ++ show testUsers
|
|
forM_ (specialUsers testUsers) $ void . insert
|
|
|
|
|
|
instance UserData (Entity User) (Map Text Text) where
|
|
data Scope (Entity User) = ID | Profile deriving (Show, Read, Eq)
|
|
readScope = read
|
|
showScope = show
|
|
userScope (Entity _ User{..}) ID = M.singleton "id" userEmail
|
|
userScope (Entity _ User{..}) Profile = M.fromList [(key, val) | (key, Just val) <-
|
|
[ ("firstName", Just userFirstName)
|
|
, ("surname", Just userSurname)
|
|
, ("email", Just userEmail)
|
|
, ("matriculationNumber", userMatricNumber)
|
|
, ("title", userTitle)
|
|
, ("sex", userSex)
|
|
, ("birthday", userBirthday)
|
|
, ("telephone", userTelephone)
|
|
, ("mobile", userMobile)
|
|
, ("companyPersonalNumber", userCompPersNumber)
|
|
, ("companyDepartment", userCompDepartment)
|
|
, ("postAddress", userPostAddress)
|
|
]]
|
|
lookupUser email _ = runDB $ do
|
|
user <- selectList [UserEmail ==. email] []
|
|
case user of
|
|
[entity] -> return $ Just entity
|
|
[] -> return Nothing
|
|
_ -> error "Oauth2 Mock Server: Ambiguous User."
|
|
|