oauth2-mock-server/app/UniWorX.hs

-- 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,
             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.Maybe (fromJust)
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 System.Environment (lookupEnv)


share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
  User
    firstName       Text
    surname         Text
    email           Text
    matricNumber    Text Maybe
    title           Text Maybe
    gender          Text Maybe
    birthday        Text Maybe
    telephone       Text Maybe
    mobile          Text Maybe
    compPersNumber  Text Maybe
    compDepartment  Text Maybe
    postAddress     Text Maybe
    deriving Eq Show
|]

instance FromJSON User where
  parseJSON (Object o) = User
    <$> o .:  "userFirstName"
    <*> o .:  "userSurname"
    <*> o .:  "userEmail"
    <*> o .:? "userMatrikelnummer"
    <*> o .:? "userTitle"
    <*> o .:? "userGender"
    <*> o .:? "userBirthday"
    <*> o .:? "userTelephone"
    <*> o .:? "userMobile"
    <*> o .:? "userCompanyPersonalNumber"
    <*> o .:? "userCompanyDepartment"
    <*> o .:? "userPostAddress"
  parseJSON _ = error "Oauth2 Mock Server: invalid test user format"

data TestUserSpec = TestUsers
  { specialUsers :: [Map Text User]
  , randomUsers  :: Map Text [Maybe 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
    let users = M.elems . mconcat $ specialUsers testUsers
    forM_ users $ void . insert


instance UserData (Entity User) (Map Text Text) where
  type UserID (Entity User) = Key User
  data CustomScope (Entity User) = UWX deriving (Read, Show, Eq)
  userScope (Entity _ User{..}) (Left OpenID) = M.singleton "id" userEmail
  userScope (Entity _ User{..}) (Left Profile) = M.fromList $ catM
    [ ("name", Just $ userFirstName <> " " <> userSurname)
    , ("given_name", Just userFirstName)
    , ("family_name", Just userSurname)
    , ("middle_name", Nothing)
    , ("nickname", Nothing)
    , ("preferred_username", Nothing)
    , ("profile", Nothing)
    , ("picture", Nothing)
    , ("website", Nothing)
    , ("gender", userGender)
    , ("birthdate", userBirthday)
    , ("zoneinfo", Nothing)
    , ("locale", Nothing)
    , ("updated_at", Nothing)
    ]
  userScope (Entity _ User{..}) (Left Email) = M.fromList [("email", userEmail), ("email_verified", userEmail)]
  userScope (Entity _ User{..}) (Left Address) = case userPostAddress of
    Just address -> M.singleton "address" address
    Nothing -> M.empty
  userScope (Entity _ User{..}) (Left Phone) = M.fromList $ catM [("phone_number", userMobile), ("phone_number_verified", userTelephone)]
  userScope (Entity _ User{..}) (Right UWX) = M.fromList $ catM
    [ ("matriculationNumber", userMatricNumber)
    , ("title", userTitle)
    , ("companyPersonalNumber", userCompPersNumber)
    , ("companyDepartment", userCompDepartment)
    ]
  userScope (Entity _ User{..}) _ = M.empty
  lookupUser UserQuery{..} = runDB $ do
    let filters = map fst $ catM [(UserEmail ==. fromJust email, email)]
        keyFilter = case key of
          Just k -> \(Entity x _) -> (T.pack $ show x) == k
          Nothing -> \_ -> True
    user <- filter keyFilter <$> selectList filters []
    case user of
      [entity] -> return $ Just entity
      [] -> return Nothing
      _ -> error "Oauth2 Mock Server: Ambiguous User."
  userID (Entity x _) = x

catM :: [(a, Maybe b)] -> [(a, b)]
catM l = [ (x,y) | (x, Just y) <- l ]