refactor(auth): add missing TODOs, remove debris
This commit is contained in:
parent
d1e1f25162
commit
13502d704e
@ -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
|
||||
|
||||
|
||||
@ -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<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,_)
|
||||
-- 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<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)
|
||||
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 ()
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -22,7 +22,8 @@ data AzureConf = AzureConf
|
||||
, azureConfClientSecret :: Text
|
||||
, azureConfTenantId :: UUID
|
||||
, azureConfScopes :: Set Text -- TODO: use AzureScopes type?
|
||||
} deriving (Show)
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
makeLenses_ ''AzureConf
|
||||
|
||||
|
||||
Reference in New Issue
Block a user