fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

refactor(auth): add missing TODOs, remove debris

Browse Source
This commit is contained in:
Sarah Vaupel 2024-02-29 22:16:11 +01:00
parent d1e1f25162
commit 13502d704e
5 changed files with 34 additions and 322 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
config/settings.yml
View File

@ -66,7 +66,7 @@ keep-unreferenced-files: 86400
health-check-interval: health-check-interval:
matching-cluster-config: "_env:HEALTHCHECK_INTERVAL_MATCHING_CLUSTER_CONFIG:600" matching-cluster-config: "_env:HEALTHCHECK_INTERVAL_MATCHING_CLUSTER_CONFIG:600"
http-reachable: "_env:HEALTHCHECK_INTERVAL_HTTP_REACHABLE:600" http-reachable: "_env:HEALTHCHECK_INTERVAL_HTTP_REACHABLE:600"
ldap-admins: "_env:HEALTHCHECK_INTERVAL_LDAP_ADMINS:600" ldap-admins: "_env:HEALTHCHECK_INTERVAL_LDAP_ADMINS:600" # TODO: either generalize over every external auth sources, or otherwise reimplement for different semantics
smtp-connect: "_env:HEALTHCHECK_INTERVAL_SMTP_CONNECT:600" smtp-connect: "_env:HEALTHCHECK_INTERVAL_SMTP_CONNECT:600"
widget-memcached: "_env:HEALTHCHECK_INTERVAL_WIDGET_MEMCACHED:600" widget-memcached: "_env:HEALTHCHECK_INTERVAL_WIDGET_MEMCACHED:600"
active-job-executors: "_env:HEALTHCHECK_INTERVAL_ACTIVE_JOB_EXECUTORS:60" active-job-executors: "_env:HEALTHCHECK_INTERVAL_ACTIVE_JOB_EXECUTORS:60"
@ -77,7 +77,7 @@ health-check-http: "_env:HEALTHCHECK_HTTP:true" # Can we assume, that we can rea
health-check-active-job-executors-timeout: "_env:HEALTHCHECK_ACTIVE_JOB_EXECUTORS_TIMEOUT:5" health-check-active-job-executors-timeout: "_env:HEALTHCHECK_ACTIVE_JOB_EXECUTORS_TIMEOUT:5"
health-check-active-widget-memcached-timeout: "_env:HEALTHCHECK_ACTIVE_WIDGET_MEMCACHED_TIMEOUT:2" health-check-active-widget-memcached-timeout: "_env:HEALTHCHECK_ACTIVE_WIDGET_MEMCACHED_TIMEOUT:2"
health-check-smtp-connect-timeout: "_env:HEALTHCHECK_SMTP_CONNECT_TIMEOUT:5" health-check-smtp-connect-timeout: "_env:HEALTHCHECK_SMTP_CONNECT_TIMEOUT:5"
health-check-ldap-admins-timeout: "_env:HEALTHCHECK_LDAP_ADMINS_TIMEOUT:60" health-check-ldap-admins-timeout: "_env:HEALTHCHECK_LDAP_ADMINS_TIMEOUT:60" # TODO: either generalize over every external auth sources, or otherwise reimplement for different semantics
health-check-http-reachable-timeout: "_env:HEALTHCHECK_HTTP_REACHABLE_TIMEOUT:2" health-check-http-reachable-timeout: "_env:HEALTHCHECK_HTTP_REACHABLE_TIMEOUT:2"
health-check-matching-cluster-config-timeout: "_env:HEALTHCHECK_MATCHING_CLUSTER_CONFIG_TIMEOUT:2" health-check-matching-cluster-config-timeout: "_env:HEALTHCHECK_MATCHING_CLUSTER_CONFIG_TIMEOUT:2"
@ -129,10 +129,12 @@ database:
auto-db-migrate: '_env:AUTO_DB_MIGRATE:true' auto-db-migrate: '_env:AUTO_DB_MIGRATE:true'
# External sources used for user authentication and userdata lookups # External sources used for user authentication and userdata lookups
# TODO: add SSO option for user-auth config
user-auth: user-auth:
# mode: single-source # mode: single-source
protocol: azureadv2 protocol: azureadv2
config: config:
# TODO make default values obsolete?
client-id: "_env:AZURECLIENTID:00000000-0000-0000-0000-000000000000" client-id: "_env:AZURECLIENTID:00000000-0000-0000-0000-000000000000"
client-secret: "_env:AZURECLIENTSECRET:verysecret" client-secret: "_env:AZURECLIENTSECRET:verysecret"
tenant-id: "_env:AZURETENANTID:00000000-0000-0000-0000-000000000000" tenant-id: "_env:AZURETENANTID:00000000-0000-0000-0000-000000000000"
@ -149,14 +151,16 @@ user-auth:
# timeout: "_env:LDAPTIMEOUT:5" # timeout: "_env:LDAPTIMEOUT:5"
# search-timeout: "_env:LDAPSEARCHTIME:5" # search-timeout: "_env:LDAPSEARCHTIME:5"
# TODO: might move later # TODO: generalize for arbitrary auth protocols
# TODO: maybe use separate pools for external databases?
ldap-pool: ldap-pool:
stripes: "_env:LDAPSTRIPES:1" stripes: "_env:LDAPSTRIPES:1"
timeout: "_env:LDAPTIMEOUT:20" timeout: "_env:LDAPTIMEOUT:20"
limit: "_env:LDAPLIMIT:10" limit: "_env:LDAPLIMIT:10"
# TODO: might move later # TODO: reintroduce and move into failover settings once failover mode has been reimplemented
# user-retest-failover: 60 # user-retest-failover: 60
# TODO; maybe implement syncWithin and syncInterval per auth source
user-sync-within: "_env:USER_SYNC_WITHIN:1209600" # 14 Tage in Sekunden user-sync-within: "_env:USER_SYNC_WITHIN:1209600" # 14 Tage in Sekunden
user-sync-interval: "_env:USER_SYNC_INTERVAL:3600" # jede Stunde user-sync-interval: "_env:USER_SYNC_INTERVAL:3600" # jede Stunde

308
src/Foundation/Yesod/Auth.hs
View File

@ -32,7 +32,6 @@ import Yesod.Auth.OAuth2 (getAccessToken, getRefreshToken)
import qualified Control.Monad.Catch as C (Handler(..)) import qualified Control.Monad.Catch as C (Handler(..))
-- import qualified Data.Aeson as Json (encode)
import qualified Data.ByteString as ByteString import qualified Data.ByteString as ByteString
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.Map as Map import qualified Data.Map as Map
@ -254,65 +253,6 @@ upsertUser _upsertMode upsertData = do
return user return user
-- | Upsert User DB according to given Azure data (does not query Azure itself)
-- upsertAzureUser :: forall m.
-- ( MonadHandler m, HandlerSite m ~ UniWorX
-- , MonadCatch m
-- )
-- => UpsertUserMode
-- -> [(Text, [ByteString])]
-- -> SqlPersistT m (Entity User)
-- upsertAzureUser upsertMode azureData = do
-- now <- liftIO getCurrentTime
-- userDefaultConf <- getsYesod $ view _appUserDefaults
--
-- (newUser,userUpdate) <- decodeAzureUser now userDefaultConf upsertMode azureData
-- --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict?
--
-- oldUsers <- for (userAzurePrimaryKey newUser) $ \pKey -> selectKeysList [ UserAzurePrimaryKey ==. Just pKey ] []
--
-- user@(Entity userId userRec) <- case oldUsers of
-- Just [oldUserId] -> updateGetEntity oldUserId userUpdate
-- _other -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
-- unless (validDisplayName (newUser ^. _userTitle)
-- (newUser ^. _userFirstName)
-- (newUser ^. _userSurname)
-- (userRec ^. _userDisplayName)) $
-- update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ]
-- when (validEmail' (userRec ^. _userEmail)) $ do
-- let emUps = [ UserDisplayEmail =. (newUser ^. _userEmail) | not (validEmail' (userRec ^. _userDisplayEmail)) ]
-- ++ [ UserAuthentication =. AuthAzure | is _AuthNoLogin (userRec ^. _userAuthentication) ]
-- unless (null emUps) $ update userId emUps
-- -- Attempt to update ident, too:
-- unless (validEmail' (userRec ^. _userIdent)) $
-- void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ()))
--
-- let
-- userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
-- userSystemFunctions' = do
-- (_k, v) <- azureData
-- -- guard $ k == azureAffiliation -- TODO: is affiliation stored in Azure DB in any way?
-- v' <- v
-- Right str <- return $ Text.decodeUtf8' v'
-- assertM' (not . Text.null) $ Text.strip str
--
-- iforM_ userSystemFunctions $ \func preset -> do
-- memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId)
-- if | preset -> void $ upsert (UserSystemFunction userId func False False) []
-- | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
--
-- return user
decodeUserTest :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadCatch m
)
=> UpsertUserData
-> m (Either UserConversionException (User, [Update User]))
decodeUserTest decodeData = do
now <- liftIO getCurrentTime
userDefaultConf <- getsYesod $ view _appUserDefaults
try $ decodeUser now userDefaultConf decodeData
decodeUser :: ( MonadThrow m decodeUser :: ( MonadThrow m
) )
@ -445,245 +385,17 @@ decodeUser now UserDefaultConf{..} upsertData = do
-- | otherwise = throwM err -- | otherwise = throwM err
-- where -- where
-- vs = Text.decodeUtf8' <$> (ldapMap !!! attr) -- vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
-- decodeLdapUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertUserMode -> Ldap.AttrList [] -> m (User,_)
-- decodeLdapUser now UserDefaultConf{..} upsertMode ldapData = do
-- let
-- userTelephone = decodeLdap ldapUserTelephone
-- userMobile = decodeLdap ldapUserMobile
-- userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer
-- userCompanyDepartment = decodeLdap ldapUserFraportAbteilung
--
-- userAuthentication
-- | is _UpsertUserLoginOther upsertMode
-- = AuthNoLogin -- AuthPWHash (error "Non-LDAP logins should only work for users that are already known")
-- | otherwise = AuthLDAP
-- userLastAuthentication = guardOn isLogin now
-- isLogin = has (_UpsertUserLoginLdap <> _UpsertUserLoginOther . united) upsertMode
--
-- userTitle = decodeLdap ldapUserTitle -- CampusUserInvalidTitle
-- userFirstName = decodeLdap' ldapUserFirstName -- CampusUserInvalidGivenName
-- userSurname = decodeLdap' ldapUserSurname -- CampusUserInvalidSurname
-- userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName <&> fixDisplayName -- do not check LDAP-given userDisplayName
--
-- --userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
-- -- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
--
-- userIdent <- if
-- | [bs] <- ldapMap !!! ldapUserPrincipalName
-- , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
-- , hasn't _upsertUserIdent upsertMode || has (_upsertUserIdent . only userIdent') upsertMode
-- -> return userIdent'
-- | Just userIdent' <- upsertMode ^? _upsertUserIdent
-- -> return userIdent'
-- | otherwise
-- -> throwM CampusUserInvalidIdent
--
-- userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E<number@fraport.de` here, too strong! Make Email-Field optional!
-- | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
-- -> return $ CI.mk userEmail
-- -- | userEmail : _ <- mapMaybe (assertM validEmail . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) -- TOO STRONG, see above!
-- -- -> return $ CI.mk userEmail
-- | otherwise
-- -> throwM CampusUserInvalidEmail
--
-- -- TODO: ExternalUser
-- userLdapPrimaryKey <- if
-- | [bs] <- ldapMap !!! ldapPrimaryKey
-- , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
-- , Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey''
-- -> return $ Just userLdapPrimaryKey'''
-- | otherwise
-- -> return Nothing
--
-- let
-- newUser = User
-- { userMaxFavourites = userDefaultMaxFavourites
-- , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
-- , userTheme = userDefaultTheme
-- , userDateTimeFormat = userDefaultDateTimeFormat
-- , userDateFormat = userDefaultDateFormat
-- , userTimeFormat = userDefaultTimeFormat
-- , userDownloadFiles = userDefaultDownloadFiles
-- , userWarningDays = userDefaultWarningDays
-- , userShowSex = userDefaultShowSex
-- , userSex = Nothing
-- , userBirthday = Nothing
-- , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
-- , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
-- , userNotificationSettings = def
-- , userLanguages = Nothing
-- , userCsvOptions = def
-- , userTokensIssuedAfter = Nothing
-- , userCreated = now
-- , userDisplayName = userDisplayName
-- , userDisplayEmail = userEmail
-- , userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
-- , userPostAddress = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
-- , userPostLastUpdate = Nothing
-- , userPinPassword = Nothing -- must be derived via AVS
-- , userPrefersPostal = userDefaultPrefersPostal
-- , ..
-- }
-- userUpdate =
-- [ UserLastAuthentication =. Just now | isLogin ] ++
-- [ UserEmail =. userEmail | validEmail' userEmail ] ++
-- [
-- -- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName
-- UserFirstName =. userFirstName
-- , UserSurname =. userSurname
-- , UserMobile =. userMobile
-- , UserTelephone =. userTelephone
-- , UserCompanyPersonalNumber =. userCompanyPersonalNumber
-- , UserCompanyDepartment =. userCompanyDepartment
-- ]
-- return (newUser, userUpdate)
--
-- where
-- ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
-- ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
--
-- -- just returns Nothing on error, pure
-- decodeLdap :: Ldap.Attr -> Maybe Text
-- decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr
--
-- decodeLdap' :: Ldap.Attr -> Text
-- decodeLdap' = fromMaybe "" . decodeLdap
-- -- accept the first successful decoding or empty; only throw an error if all decodings fail
-- -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m (Maybe Text)
-- -- decodeLdap' attr err
-- -- | [] <- vs = return Nothing
-- -- | (h:_) <- rights vs = return $ Just h
-- -- | otherwise = throwM err
-- -- where
-- -- vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
--
-- -- only accepts the first successful decoding, ignoring all others, but failing if there is none
-- -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
-- decodeLdap1 attr err
-- | (h:_) <- rights vs = return h
-- | otherwise = throwM err
-- where
-- vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
--
-- -- accept and merge one or more successful decodings, ignoring all others
-- -- decodeLdapN attr err
-- -- | t@(_:_) <- rights vs
-- -- = return $ Text.unwords t
-- -- | otherwise = throwM err
-- -- where
-- -- vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
-- decodeAzureUser :: (MonadThrow m) => UTCTime -> UserDefaultConf -> UpsertUserMode -> [(Text, [ByteString])] -> m (User,_) decodeUserTest :: ( MonadHandler m
-- decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do , HandlerSite m ~ UniWorX
-- let , MonadCatch m
-- userTelephone = decodeAzure azureUserTelephone )
-- userMobile = decodeAzure azureUserMobile => UpsertUserData
-- userCompanyPersonalNumber = Nothing -- TODO decodeAzure azureUserFraportPersonalnummer -> m (Either UserConversionException (User, [Update User]))
-- userCompanyDepartment = Nothing --TODO decodeAzure ldapUserFraportAbteilung decodeUserTest decodeData = do
-- now <- liftIO getCurrentTime
-- userAuthentication userDefaultConf <- getsYesod $ view _appUserDefaults
-- | is _UpsertUserLoginOther upsertMode try $ decodeUser now userDefaultConf decodeData
-- = AuthPWHash (error "Non-LDAP logins should only work for users that are already known") -- TODO throwM instead?
-- | otherwise = AuthAzure
-- userLastAuthentication = guardOn isLogin now
-- isLogin = has (_UpsertUserLoginAzure <> _UpsertUserLoginOther . united) upsertMode
--
-- userTitle = Nothing -- TODO decodeAzure ldapUserTitle -- CampusUserInvalidTitle
-- userFirstName = decodeAzure' azureUserGivenName -- CampusUserInvalidGivenName
-- userSurname = decodeAzure' azureUserSurname -- CampusUserInvalidSurname
-- userDisplayName <- decodeAzure1 azureUserDisplayName UserInvalidDisplayName <&> fixDisplayName -- do not check LDAP-given userDisplayName
--
-- --userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
-- -- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
--
-- userIdent <- if
-- | [bs] <- azureMap !!! azureUserPrincipalName
-- , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
-- , hasn't _upsertUserIdent upsertMode || has (_upsertUserIdent . only userIdent') upsertMode
-- -> return userIdent'
-- | Just userIdent' <- upsertMode ^? _upsertUserIdent
-- -> return userIdent'
-- | otherwise
-- -> throwM UserInvalidIdent
--
-- userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E<number@fraport.de` here, too strong! Make Email-Field optional!
-- | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome azureMap [azureUserMail])
-- -> return $ CI.mk userEmail
-- -- -> return $ CI.mk userEmail
-- | otherwise
-- -> throwM UserInvalidEmail
--
-- -- TODO: use fromASCIIBytes / fromByteString?
-- userAzurePrimaryKey <- if
-- | [bs] <- azureMap !!! azurePrimaryKey
-- , Right userAzurePrimaryKey'' <- Text.decodeUtf8' bs
-- , Just userAzurePrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userAzurePrimaryKey''
-- , Just userAzurePrimaryKey'''' <- UUID.fromText userAzurePrimaryKey'''
-- -> return $ Just userAzurePrimaryKey''''
-- | otherwise
-- -> return Nothing
--
-- let
-- newUser = User
-- { userMaxFavourites = userDefaultMaxFavourites
-- , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
-- , userTheme = userDefaultTheme
-- , userDateTimeFormat = userDefaultDateTimeFormat
-- , userDateFormat = userDefaultDateFormat
-- , userTimeFormat = userDefaultTimeFormat
-- , userDownloadFiles = userDefaultDownloadFiles
-- , userWarningDays = userDefaultWarningDays
-- , userShowSex = userDefaultShowSex
-- , userSex = Nothing
-- , userBirthday = Nothing
-- , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced
-- , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels
-- , userNotificationSettings = def
-- , userLanguages = Nothing -- TODO: decode and parse preferredLanguages
-- , userCsvOptions = def
-- , userTokensIssuedAfter = Nothing
-- , userCreated = now
-- , userDisplayName = userDisplayName
-- , userDisplayEmail = userEmail
-- , userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
-- , userPostAddress = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
-- , userPostLastUpdate = Nothing
-- , userPinPassword = Nothing -- must be derived via AVS
-- , userPrefersPostal = userDefaultPrefersPostal
-- , ..
-- }
-- userUpdate =
-- --- [ UserLastAuthentication =. Just now | isLogin ] ++
-- [ UserEmail =. userEmail | validEmail' userEmail ] ++
-- [
-- -- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
-- UserFirstName =. userFirstName
-- , UserSurname =. userSurname
-- , UserMobile =. userMobile
-- , UserTelephone =. userTelephone
-- , UserCompanyPersonalNumber =. userCompanyPersonalNumber
-- , UserCompanyDepartment =. userCompanyDepartment
-- ]
-- return (newUser, userUpdate)
--
-- where
-- azureMap :: Map.Map Text [ByteString]
-- azureMap = Map.fromListWith (++) $ azureData <&> second (filter (not . ByteString.null))
--
-- -- just returns Nothing on error, pure
-- decodeAzure :: Text -> Maybe Text
-- decodeAzure attr = listToMaybe . rights $ Text.decodeUtf8' <$> azureMap !!! attr
--
-- decodeAzure' :: Text -> Text
-- decodeAzure' = fromMaybe "" . decodeAzure
--
-- -- only accepts the first successful decoding, ignoring all others, but failing if there is none
-- -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
-- decodeAzure1 attr err
-- | (h:_) <- rights vs = return h
-- | otherwise = throwM err
-- where
-- vs = Text.decodeUtf8' <$> (azureMap !!! attr)
associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m () associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()

26
src/Settings.hs
View File

@ -47,8 +47,6 @@ import qualified Data.Scientific as Scientific
import qualified Data.Text as Text import qualified Data.Text as Text
-- import qualified Ldap.Client as Ldap
import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..)) import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..))
import qualified Network.Socket as HaskellNet import qualified Network.Socket as HaskellNet
@ -78,8 +76,6 @@ import qualified Web.ServerSession.Core as ServerSession
import Text.Show (showParen, showString) import Text.Show (showParen, showString)
-- import qualified Data.List.PointedList as P
import qualified Network.Minio as Minio import qualified Network.Minio as Minio
import Data.Conduit.Algorithms.FastCDC import Data.Conduit.Algorithms.FastCDC
@ -451,12 +447,11 @@ data AppSettings = AppSettings
, appDatabaseConf :: PostgresConf , appDatabaseConf :: PostgresConf
-- ^ Configuration settings for accessing the database. -- ^ Configuration settings for accessing the database.
, appAutoDbMigrate :: Bool , appAutoDbMigrate :: Bool
, appUserAuthConf :: UserAuthConf , appUserAuthConf :: UserAuthConf -- TODO: add SSO option for user-auth config
-- ^ Configuration settings for CSV export/import to LMS (= Learn Management System)
, appLmsConf :: LmsConf , appLmsConf :: LmsConf
-- ^ Configuration settings for accessing the LDAP-directory -- ^ Configuration settings for CSV export/import to LMS (= Learn Management System) -- TODO, TODISCUSS: reimplement as user-auth source?
, appAvsConf :: Maybe AvsConf , appAvsConf :: Maybe AvsConf
-- ^ Configuration settings for accessing AVS Server (= Ausweis Verwaltungs System) -- ^ Configuration settings for accessing AVS Server (= Ausweis Verwaltungs System) -- TODO, TODISCUSS: reimplement as user-auth source?
, appLprConf :: LprConf , appLprConf :: LprConf
-- ^ Configuration settings for accessing a printer queue via lpr for letter mailing -- ^ Configuration settings for accessing a printer queue via lpr for letter mailing
, appSmtpConf :: Maybe SmtpConf , appSmtpConf :: Maybe SmtpConf
@ -464,15 +459,13 @@ data AppSettings = AppSettings
, appWidgetMemcachedConf :: Maybe WidgetMemcachedConf , appWidgetMemcachedConf :: Maybe WidgetMemcachedConf
-- ^ Configuration settings for accessing a Memcached instance for use with `addStaticContent` -- ^ Configuration settings for accessing a Memcached instance for use with `addStaticContent`
, appRoot :: ApprootScope -> Maybe Text , appRoot :: ApprootScope -> Maybe Text
-- ^ Base for all generated URLs. If @Nothing@, determined -- ^ Base for all generated URLs. If @Nothing@, determined from the request headers.
-- from the request headers.
, appHost :: HostPreference , appHost :: HostPreference
-- ^ Host/interface the server should bind to. -- ^ Host/interface the server should bind to.
, appPort :: Int , appPort :: Int
-- ^ Port to listen on -- ^ Port to listen on
, appIpFromHeader :: Bool , appIpFromHeader :: Bool
-- ^ Get the IP address from the header when logging. Useful when sitting -- ^ Get the IP address from the header when logging. Useful when sitting behind a reverse proxy.
-- behind a reverse proxy.
, appServerSessionConfig :: ServerSessionSettings , appServerSessionConfig :: ServerSessionSettings
, appServerSessionAcidFallback :: Bool , appServerSessionAcidFallback :: Bool
@ -513,15 +506,17 @@ data AppSettings = AppSettings
, appHealthCheckActiveJobExecutorsTimeout :: NominalDiffTime , appHealthCheckActiveJobExecutorsTimeout :: NominalDiffTime
, appHealthCheckActiveWidgetMemcachedTimeout :: NominalDiffTime , appHealthCheckActiveWidgetMemcachedTimeout :: NominalDiffTime
, appHealthCheckSMTPConnectTimeout :: NominalDiffTime , appHealthCheckSMTPConnectTimeout :: NominalDiffTime
, appHealthCheckLDAPAdminsTimeout :: NominalDiffTime , appHealthCheckLDAPAdminsTimeout :: NominalDiffTime -- TODO: either generalize over every external auth sources, or otherwise reimplement for different semantics
, appHealthCheckHTTPReachableTimeout :: NominalDiffTime , appHealthCheckHTTPReachableTimeout :: NominalDiffTime
, appHealthCheckMatchingClusterConfigTimeout :: NominalDiffTime , appHealthCheckMatchingClusterConfigTimeout :: NominalDiffTime
-- , appUserRetestFailover :: DiffTime -- , appUserRetestFailover :: DiffTime -- TODO: reintroduce and move into failover settings once failover mode has been reimplemented
-- TODO; maybe implement syncWithin and syncInterval per auth source
, appUserSyncWithin :: Maybe NominalDiffTime , appUserSyncWithin :: Maybe NominalDiffTime
, appUserSyncInterval :: NominalDiffTime , appUserSyncInterval :: NominalDiffTime
, appLdapPoolConf :: Maybe ResourcePoolConf , appLdapPoolConf :: Maybe ResourcePoolConf -- TODO: generalize for arbitrary auth protocols
-- TODO: maybe use separate pools for external databases?
, appSynchroniseAvsUsersWithin :: Maybe NominalDiffTime , appSynchroniseAvsUsersWithin :: Maybe NominalDiffTime
, appSynchroniseAvsUsersInterval :: NominalDiffTime , appSynchroniseAvsUsersInterval :: NominalDiffTime
@ -624,6 +619,7 @@ instance FromJSON AppSettings where
appWebpackEntrypoints <- o .: "webpack-manifest" appWebpackEntrypoints <- o .: "webpack-manifest"
appDatabaseConf <- o .: "database" appDatabaseConf <- o .: "database"
appAutoDbMigrate <- o .: "auto-db-migrate" appAutoDbMigrate <- o .: "auto-db-migrate"
-- TODO: reintroduce non-emptyness check for ldap hosts
-- let nonEmptyHost (UserDbLdap LdapConf{..}) = case ldapHost of -- let nonEmptyHost (UserDbLdap LdapConf{..}) = case ldapHost of
-- Ldap.Tls host _ -> not $ null host -- Ldap.Tls host _ -> not $ null host
-- Ldap.Plain host -> not $ null host -- Ldap.Plain host -> not $ null host

7
src/Settings/Ldap.hs
View File

@ -2,11 +2,9 @@
-- --
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Settings.Ldap module Settings.Ldap
( LdapConf(..) ( LdapConf(..)
, _ldapConfHost, _ldapConfDn, _ldapConfBase, _ldapConfScope, _ldapConfTimeout, _ldapConfSearchTimeout , _ldapConfHost, _ldapConfPort, _ldapConfSourceId, _ldapConfDn, _ldapConfPassword, _ldapConfBase, _ldapConfScope, _ldapConfTimeout, _ldapConfSearchTimeout
) where ) where
import ClassyPrelude import ClassyPrelude
@ -26,7 +24,8 @@ import Ldap.Client.Instances ()
data LdapConf = LdapConf data LdapConf = LdapConf
{ ldapConfHost :: Ldap.Host { ldapConfHost :: Ldap.Host
, ldapConfPort :: Ldap.PortNumber , ldapConfPort :: Ldap.PortNumber
, ldapConfSourceId :: Text -- ^ Some unique identifier for this LDAP instance, e.g. hostname or hostname:port , ldapConfSourceId :: Text
-- ^ Some unique identifier for this LDAP instance, e.g. hostname or hostname:port
, ldapConfDn :: Ldap.Dn , ldapConfDn :: Ldap.Dn
, ldapConfPassword :: Ldap.Password , ldapConfPassword :: Ldap.Password
, ldapConfBase :: Ldap.Dn , ldapConfBase :: Ldap.Dn

3
src/Settings/OAuth2.hs
View File

@ -22,7 +22,8 @@ data AzureConf = AzureConf
, azureConfClientSecret :: Text , azureConfClientSecret :: Text
, azureConfTenantId :: UUID , azureConfTenantId :: UUID
, azureConfScopes :: Set Text -- TODO: use AzureScopes type? , azureConfScopes :: Set Text -- TODO: use AzureScopes type?
} deriving (Show) }
deriving (Show)
makeLenses_ ''AzureConf makeLenses_ ''AzureConf