uniworx/oauth2-mock-server
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

updated yaml parser

Browse Source
This commit is contained in:
David Mosbach 2024-01-28 23:57:11 +00:00
parent a8b7ee68da
commit 02510301ff
1 changed files with 21 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
app/UniWorX.hs
View File

@ -10,7 +10,6 @@
TemplateHaskell, TemplateHaskell,
TypeFamilies, TypeFamilies,
TypeApplications, TypeApplications,
DeriveGeneric,
DerivingStrategies, DerivingStrategies,
StandaloneDeriving, StandaloneDeriving,
UndecidableInstances, UndecidableInstances,
@ -34,7 +33,7 @@ import Conduit (ResourceT)
import Data.Map (Map(..)) import Data.Map (Map(..))
import Data.String (IsString(..)) import Data.String (IsString(..))
import Data.Text (Text(..)) import Data.Text (Text(..))
import Data.Yaml (decodeFileThrow, FromJSON(..), Value(..), (.:)) import Data.Yaml (decodeFileThrow, FromJSON(..), Value(..), (.:), (.:?))
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Text as T import qualified Data.Text as T
@ -42,8 +41,6 @@ import Database.Persist
import Database.Persist.TH import Database.Persist.TH
import Database.Persist.Postgresql import Database.Persist.Postgresql
import GHC.Generics
import System.Environment (lookupEnv) import System.Environment (lookupEnv)
@ -61,14 +58,28 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
compPersNumber Text Maybe compPersNumber Text Maybe
compDepartment Text Maybe compDepartment Text Maybe
postAddress Text Maybe postAddress Text Maybe
deriving Eq Show Generic deriving Eq Show
|] |]
instance FromJSON User instance FromJSON User where
parseJSON (Object o) = User
<$> o .: "userFirstName"
<*> o .: "userSurname"
<*> o .: "userEmail"
<*> o .:? "userMatrikelnummer"
<*> o .:? "userTitle"
<*> o .:? "userSex"
<*> o .:? "userBirthday"
<*> o .:? "userTelephone"
<*> o .:? "userMobile"
<*> o .:? "userCompanyPersonalNumber"
<*> o .:? "userCompanyDepartment"
<*> o .:? "userPostAddress"
parseJSON _ = error "Oauth2 Mock Server: invalid test user format"
data TestUserSpec = TestUsers data TestUserSpec = TestUsers
{ specialUsers :: [User] { specialUsers :: [Map Text User]
, randomUsers :: Map Text [Text] , randomUsers :: Map Text [Maybe Text]
} deriving (Show) } deriving (Show)
instance FromJSON TestUserSpec where instance FromJSON TestUserSpec where
@ -91,7 +102,8 @@ initDB = do
runMigration migrateAll runMigration migrateAll
testUsers <- decodeFileThrow @DB @TestUserSpec testUserFile testUsers <- decodeFileThrow @DB @TestUserSpec testUserFile
liftIO . putStrLn $ "the test users:\n" ++ show testUsers liftIO . putStrLn $ "the test users:\n" ++ show testUsers
forM_ (specialUsers testUsers) $ void . insert let users = M.elems . mconcat $ specialUsers testUsers
forM_ users $ void . insert
instance UserData (Entity User) (Map Text Text) where instance UserData (Entity User) (Map Text Text) where