diff --git a/config/settings.yml b/config/settings.yml index bb8047209..7746c254b 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -66,7 +66,7 @@ keep-unreferenced-files: 86400 health-check-interval: matching-cluster-config: "_env:HEALTHCHECK_INTERVAL_MATCHING_CLUSTER_CONFIG: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" widget-memcached: "_env:HEALTHCHECK_INTERVAL_WIDGET_MEMCACHED:600" 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-widget-memcached-timeout: "_env:HEALTHCHECK_ACTIVE_WIDGET_MEMCACHED_TIMEOUT:2" 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-matching-cluster-config-timeout: "_env:HEALTHCHECK_MATCHING_CLUSTER_CONFIG_TIMEOUT:2" @@ -129,10 +129,12 @@ database: auto-db-migrate: '_env:AUTO_DB_MIGRATE:true' # External sources used for user authentication and userdata lookups +# TODO: add SSO option for user-auth config user-auth: # mode: single-source protocol: azureadv2 config: + # TODO make default values obsolete? client-id: "_env:AZURECLIENTID:00000000-0000-0000-0000-000000000000" client-secret: "_env:AZURECLIENTSECRET:verysecret" tenant-id: "_env:AZURETENANTID:00000000-0000-0000-0000-000000000000" @@ -149,14 +151,16 @@ user-auth: # timeout: "_env:LDAPTIMEOUT: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: stripes: "_env:LDAPSTRIPES:1" timeout: "_env:LDAPTIMEOUT:20" 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 +# TODO; maybe implement syncWithin and syncInterval per auth source user-sync-within: "_env:USER_SYNC_WITHIN:1209600" # 14 Tage in Sekunden user-sync-interval: "_env:USER_SYNC_INTERVAL:3600" # jede Stunde diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 394f4aed4..bc5092881 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -32,7 +32,6 @@ import Yesod.Auth.OAuth2 (getAccessToken, getRefreshToken) import qualified Control.Monad.Catch as C (Handler(..)) --- import qualified Data.Aeson as Json (encode) import qualified Data.ByteString as ByteString import qualified Data.CaseInsensitive as CI import qualified Data.Map as Map @@ -254,65 +253,6 @@ upsertUser _upsertMode upsertData = do 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 ) @@ -445,245 +385,17 @@ decodeUser now UserDefaultConf{..} upsertData = do -- | otherwise = throwM err -- where -- 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 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,_) --- decodeAzureUser now UserDefaultConf{..} upsertMode azureData = do --- let --- userTelephone = decodeAzure azureUserTelephone --- userMobile = decodeAzure azureUserMobile --- userCompanyPersonalNumber = Nothing -- TODO decodeAzure azureUserFraportPersonalnummer --- userCompanyDepartment = Nothing --TODO decodeAzure ldapUserFraportAbteilung --- --- userAuthentication --- | is _UpsertUserLoginOther upsertMode --- = 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 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) +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 associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m () diff --git a/src/Settings.hs b/src/Settings.hs index 74a07929b..9aa46f6b1 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -47,8 +47,6 @@ import qualified Data.Scientific as Scientific 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.Socket as HaskellNet @@ -78,8 +76,6 @@ import qualified Web.ServerSession.Core as ServerSession import Text.Show (showParen, showString) --- import qualified Data.List.PointedList as P - import qualified Network.Minio as Minio import Data.Conduit.Algorithms.FastCDC @@ -451,12 +447,11 @@ data AppSettings = AppSettings , appDatabaseConf :: PostgresConf -- ^ Configuration settings for accessing the database. , appAutoDbMigrate :: Bool - , appUserAuthConf :: UserAuthConf - -- ^ Configuration settings for CSV export/import to LMS (= Learn Management System) + , appUserAuthConf :: UserAuthConf -- TODO: add SSO option for user-auth config , 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 - -- ^ 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 -- ^ Configuration settings for accessing a printer queue via lpr for letter mailing , appSmtpConf :: Maybe SmtpConf @@ -464,15 +459,13 @@ data AppSettings = AppSettings , appWidgetMemcachedConf :: Maybe WidgetMemcachedConf -- ^ Configuration settings for accessing a Memcached instance for use with `addStaticContent` , appRoot :: ApprootScope -> Maybe Text - -- ^ Base for all generated URLs. If @Nothing@, determined - -- from the request headers. + -- ^ Base for all generated URLs. If @Nothing@, determined from the request headers. , appHost :: HostPreference -- ^ Host/interface the server should bind to. , appPort :: Int -- ^ Port to listen on , appIpFromHeader :: Bool - -- ^ Get the IP address from the header when logging. Useful when sitting - -- behind a reverse proxy. + -- ^ Get the IP address from the header when logging. Useful when sitting behind a reverse proxy. , appServerSessionConfig :: ServerSessionSettings , appServerSessionAcidFallback :: Bool @@ -513,15 +506,17 @@ data AppSettings = AppSettings , appHealthCheckActiveJobExecutorsTimeout :: NominalDiffTime , appHealthCheckActiveWidgetMemcachedTimeout :: NominalDiffTime , appHealthCheckSMTPConnectTimeout :: NominalDiffTime - , appHealthCheckLDAPAdminsTimeout :: NominalDiffTime + , appHealthCheckLDAPAdminsTimeout :: NominalDiffTime -- TODO: either generalize over every external auth sources, or otherwise reimplement for different semantics , appHealthCheckHTTPReachableTimeout :: 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 , 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 , appSynchroniseAvsUsersInterval :: NominalDiffTime @@ -624,6 +619,7 @@ instance FromJSON AppSettings where appWebpackEntrypoints <- o .: "webpack-manifest" appDatabaseConf <- o .: "database" appAutoDbMigrate <- o .: "auto-db-migrate" + -- TODO: reintroduce non-emptyness check for ldap hosts -- let nonEmptyHost (UserDbLdap LdapConf{..}) = case ldapHost of -- Ldap.Tls host _ -> not $ null host -- Ldap.Plain host -> not $ null host diff --git a/src/Settings/Ldap.hs b/src/Settings/Ldap.hs index ae821f155..915f4ebce 100644 --- a/src/Settings/Ldap.hs +++ b/src/Settings/Ldap.hs @@ -2,11 +2,9 @@ -- -- SPDX-License-Identifier: AGPL-3.0-or-later -{-# OPTIONS_GHC -fno-warn-orphans #-} - module Settings.Ldap ( LdapConf(..) - , _ldapConfHost, _ldapConfDn, _ldapConfBase, _ldapConfScope, _ldapConfTimeout, _ldapConfSearchTimeout + , _ldapConfHost, _ldapConfPort, _ldapConfSourceId, _ldapConfDn, _ldapConfPassword, _ldapConfBase, _ldapConfScope, _ldapConfTimeout, _ldapConfSearchTimeout ) where import ClassyPrelude @@ -26,7 +24,8 @@ import Ldap.Client.Instances () data LdapConf = LdapConf { ldapConfHost :: Ldap.Host , 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 , ldapConfPassword :: Ldap.Password , ldapConfBase :: Ldap.Dn diff --git a/src/Settings/OAuth2.hs b/src/Settings/OAuth2.hs index 5242a776a..ba1980178 100644 --- a/src/Settings/OAuth2.hs +++ b/src/Settings/OAuth2.hs @@ -22,7 +22,8 @@ data AzureConf = AzureConf , azureConfClientSecret :: Text , azureConfTenantId :: UUID , azureConfScopes :: Set Text -- TODO: use AzureScopes type? - } deriving (Show) + } + deriving (Show) makeLenses_ ''AzureConf