feat(ldap): failover
This commit is contained in:
Gregor Kleen
parent
e0c05f39d4
commit
0e68b6cf53
@ -92,19 +92,21 @@ database:
|
||||
auto-db-migrate: '_env:AUTO_DB_MIGRATE:true'
|
||||
|
||||
ldap:
|
||||
host: "_env:LDAPHOST:"
|
||||
tls: "_env:LDAPTLS:"
|
||||
port: "_env:LDAPPORT:389"
|
||||
user: "_env:LDAPUSER:"
|
||||
pass: "_env:LDAPPASS:"
|
||||
baseDN: "_env:LDAPBASE:"
|
||||
scope: "_env:LDAPSCOPE:WholeSubtree"
|
||||
timeout: "_env:LDAPTIMEOUT:5"
|
||||
search-timeout: "_env:LDAPSEARCHTIME:5"
|
||||
pool:
|
||||
stripes: "_env:LDAPSTRIPES:1"
|
||||
timeout: "_env:LDAPTIMEOUT:20"
|
||||
limit: "_env:LDAPLIMIT:10"
|
||||
- host: "_env:LDAPHOST:"
|
||||
tls: "_env:LDAPTLS:"
|
||||
port: "_env:LDAPPORT:389"
|
||||
user: "_env:LDAPUSER:"
|
||||
pass: "_env:LDAPPASS:"
|
||||
baseDN: "_env:LDAPBASE:"
|
||||
scope: "_env:LDAPSCOPE:WholeSubtree"
|
||||
timeout: "_env:LDAPTIMEOUT:5"
|
||||
search-timeout: "_env:LDAPSEARCHTIME:5"
|
||||
pool:
|
||||
stripes: "_env:LDAPSTRIPES:1"
|
||||
timeout: "_env:LDAPTIMEOUT:20"
|
||||
limit: "_env:LDAPLIMIT:10"
|
||||
|
||||
ldap-re-test-failover: 60
|
||||
|
||||
smtp:
|
||||
host: "_env:SMTPHOST:"
|
||||
|
||||
@ -145,6 +145,8 @@ dependencies:
|
||||
- pandoc
|
||||
- token-bucket
|
||||
- async
|
||||
- pointedlist
|
||||
- clock
|
||||
|
||||
other-extensions:
|
||||
- GeneralizedNewtypeDeriving
|
||||
|
||||
@ -209,9 +209,9 @@ makeFoundation appSettings'@AppSettings{..} = do
|
||||
(pgConnStr appDatabaseConf)
|
||||
(pgPoolSize appDatabaseConf)
|
||||
|
||||
ldapPool <- for appLdapConf $ \LdapConf{..} -> do
|
||||
$logDebugS "setup" "LDAP-Pool"
|
||||
createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
|
||||
ldapPool <- traverse mkFailover <=< forOf (traverse . traverse) appLdapConf $ \conf@LdapConf{..} -> do
|
||||
$logDebugS "setup" $ "LDAP-Pool " <> tshow ldapHost
|
||||
(conf,) <$> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
|
||||
|
||||
-- Perform database migration using our application's logging settings.
|
||||
if
|
||||
|
||||
@ -3,6 +3,7 @@ module Auth.LDAP
|
||||
, campusLogin
|
||||
, CampusUserException(..)
|
||||
, campusUser, campusUser'
|
||||
, campusUserReTest, campusUserReTest'
|
||||
, campusUserMatr, campusUserMatr'
|
||||
, CampusMessage(..)
|
||||
, ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
|
||||
@ -102,8 +103,18 @@ instance Exception CampusUserException
|
||||
|
||||
makePrisms ''CampusUserException
|
||||
|
||||
campusUser :: MonadUnliftIO m => LdapConf -> LdapPool -> Creds site -> m (Ldap.AttrList [])
|
||||
campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
|
||||
campusUserWith :: MonadUnliftIO m
|
||||
=> ( Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap
|
||||
-> Failover (LdapConf, LdapPool)
|
||||
-> FailoverMode
|
||||
-> ((LdapConf, Ldap) -> IO (Ldap.AttrList []))
|
||||
-> IO (Either LdapPoolError (Ldap.AttrList []))
|
||||
)
|
||||
-> Failover (LdapConf, LdapPool)
|
||||
-> FailoverMode
|
||||
-> Creds site
|
||||
-> m (Ldap.AttrList [])
|
||||
campusUserWith withLdap' pool mode Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap' _2 pool mode $ \(conf@LdapConf{..}, ldap) -> do
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
results <- case lookup "DN" credsExtra of
|
||||
Just userDN -> do
|
||||
@ -121,13 +132,23 @@ campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $
|
||||
, Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
|
||||
]
|
||||
|
||||
campusUser' :: (MonadCatch m, MonadUnliftIO m) => LdapConf -> LdapPool -> User -> m (Maybe (Ldap.AttrList []))
|
||||
campusUser' conf pool User{userIdent}
|
||||
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser conf pool (Creds apLdap (CI.original userIdent) [])
|
||||
campusUserReTest :: MonadUnliftIO m => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
|
||||
campusUserReTest pool doTest = campusUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool
|
||||
|
||||
campusUserReTest' :: (MonadCatch m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
|
||||
campusUserReTest' pool doTest mode User{userIdent}
|
||||
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUserReTest pool doTest mode (Creds apLdap (CI.original userIdent) [])
|
||||
|
||||
campusUser :: MonadUnliftIO m => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
|
||||
campusUser = campusUserWith withLdapFailover
|
||||
|
||||
campusUser' :: (MonadCatch m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
|
||||
campusUser' pool mode User{userIdent}
|
||||
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser pool mode (Creds apLdap (CI.original userIdent) [])
|
||||
|
||||
|
||||
campusUserMatr :: MonadUnliftIO m => LdapConf -> LdapPool -> UserMatriculation -> m (Ldap.AttrList [])
|
||||
campusUserMatr conf@LdapConf{..} pool userMatr = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
|
||||
campusUserMatr :: MonadUnliftIO m => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Ldap.AttrList [])
|
||||
campusUserMatr pool mode userMatr = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> do
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
results <- findUserMatr conf ldap userMatr []
|
||||
case results of
|
||||
@ -140,9 +161,9 @@ campusUserMatr conf@LdapConf{..} pool userMatr = liftIO . (`catches` errHandlers
|
||||
, Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
|
||||
]
|
||||
|
||||
campusUserMatr' :: (MonadCatch m, MonadUnliftIO m) => LdapConf -> LdapPool -> UserMatriculation -> m (Maybe (Ldap.AttrList []))
|
||||
campusUserMatr' conf pool
|
||||
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . campusUserMatr conf pool
|
||||
campusUserMatr' :: (MonadCatch m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Maybe (Ldap.AttrList []))
|
||||
campusUserMatr' pool mode
|
||||
= runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . campusUserMatr pool mode
|
||||
|
||||
|
||||
|
||||
@ -168,8 +189,8 @@ campusLogin :: forall site.
|
||||
, RenderMessage site CampusMessage
|
||||
, RenderMessage site AFormMessage
|
||||
, Button site ButtonSubmit
|
||||
) => LdapConf -> LdapPool -> AuthPlugin site
|
||||
campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
|
||||
) => Failover (LdapConf, LdapPool) -> FailoverMode -> AuthPlugin site
|
||||
campusLogin pool mode = AuthPlugin{..}
|
||||
where
|
||||
apName :: Text
|
||||
apName = apLdap
|
||||
@ -184,7 +205,7 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
|
||||
redirect $ tp LoginR
|
||||
FormMissing -> redirect $ tp LoginR
|
||||
FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
|
||||
ldapResult <- withLdap pool $ \ldap -> liftIO $ do
|
||||
ldapResult <- withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do
|
||||
Ldap.bind ldap ldapDn ldapPassword
|
||||
searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName]
|
||||
case searchResults of
|
||||
|
||||
@ -4893,17 +4893,17 @@ instance YesodAuth UniWorX where
|
||||
$logDebugS "auth" $ tshow Creds{..}
|
||||
UniWorX{ appSettings' = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod
|
||||
|
||||
flip catches excHandlers $ case (,) <$> appLdapConf <*> appLdapPool of
|
||||
Just (ldapConf, ldapPool)
|
||||
flip catches excHandlers $ case appLdapPool of
|
||||
Just ldapPool
|
||||
| Just upsertMode' <- upsertMode -> do
|
||||
ldapData <- campusUser ldapConf ldapPool Creds{..}
|
||||
ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..}
|
||||
$logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
|
||||
Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData
|
||||
_other
|
||||
-> acceptExisting
|
||||
|
||||
authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes
|
||||
[ campusLogin <$> appLdapConf <*> appLdapPool
|
||||
[ flip campusLogin campusUserFailoverMode <$> appLdapPool
|
||||
, Just . hashLogin $ pwHashAlgorithm appAuthPWHash
|
||||
, dummyLogin <$ guard appAuthDummyLogin
|
||||
]
|
||||
@ -4926,6 +4926,9 @@ instance YesodAuth UniWorX where
|
||||
_other -> Auth.germanMessage
|
||||
where lang = Text.splitOn "-" $ selectLanguage' appLanguages ls
|
||||
|
||||
campusUserFailoverMode :: FailoverMode
|
||||
campusUserFailoverMode = FailoverUnlimited
|
||||
|
||||
instance YesodAuthPersist UniWorX
|
||||
|
||||
|
||||
|
||||
@ -37,7 +37,7 @@ data UniWorX = UniWorX
|
||||
, appStatic :: EmbeddedStatic -- ^ Settings for static file serving.
|
||||
, appConnPool :: ConnectionPool -- ^ Database connection pool.
|
||||
, appSmtpPool :: Maybe SMTPPool
|
||||
, appLdapPool :: Maybe LdapPool
|
||||
, appLdapPool :: Maybe (Failover (LdapConf, LdapPool))
|
||||
, appWidgetMemcached :: Maybe Memcached.Connection -- ^ Actually a proper pool
|
||||
, appHttpManager :: Manager
|
||||
, appLogger :: (ReleaseKey, TVar Logger)
|
||||
|
||||
@ -337,8 +337,8 @@ postAdminUserR uuid = do
|
||||
campusHandler :: MonadPlus m => Auth.CampusUserException -> m a
|
||||
campusHandler _ = mzero
|
||||
campusResult <- runMaybeT . handle campusHandler $ do
|
||||
(Just pool, Just conf) <- getsYesod $ (,) <$> view _appLdapPool <*> view _appLdapConf
|
||||
void . lift . Auth.campusUser conf pool $ Creds Auth.apLdap (CI.original userIdent) []
|
||||
Just pool <- getsYesod $ view _appLdapPool
|
||||
void . lift . Auth.campusUser pool FailoverUnlimited $ Creds Auth.apLdap (CI.original userIdent) []
|
||||
case campusResult of
|
||||
Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup
|
||||
_other
|
||||
|
||||
@ -100,10 +100,9 @@ guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False
|
||||
]
|
||||
|
||||
doLdap userMatr = do
|
||||
app <- getYesod
|
||||
let ldap = (,) <$> app ^. _appLdapConf <*> app ^. _appLdapPool
|
||||
fmap (fmap entityKey . join) . for ldap $ \(ldapConf, ldapPool) -> do
|
||||
ldapData <- campusUserMatr' ldapConf ldapPool userMatr
|
||||
ldapPool' <- getsYesod $ view _appLdapPool
|
||||
fmap (fmap entityKey . join) . for ldapPool' $ \ldapPool -> do
|
||||
ldapData <- campusUserMatr' ldapPool FailoverUnlimited userMatr
|
||||
for ldapData $ upsertCampusUser UpsertCampusUser
|
||||
|
||||
if
|
||||
|
||||
@ -12,6 +12,7 @@ import Utils.Tokens as Import
|
||||
import Utils.Frontend.Modal as Import
|
||||
import Utils.Frontend.Notification as Import
|
||||
import Utils.Lens as Import
|
||||
import Utils.Failover as Import
|
||||
|
||||
import Settings as Import
|
||||
import Settings.StaticFiles as Import
|
||||
|
||||
@ -118,6 +118,8 @@ import Algebra.Lattice as Import
|
||||
|
||||
import Data.Proxy as Import (Proxy(..))
|
||||
|
||||
import Data.List.PointedList as Import (PointedList)
|
||||
|
||||
import Language.Haskell.TH.Instances as Import ()
|
||||
import Data.NonNull.Instances as Import ()
|
||||
import Data.Monoid.Instances as Import ()
|
||||
|
||||
@ -39,14 +39,15 @@ dispatchJobSynchroniseLdap numIterations epoch iteration
|
||||
dispatchJobSynchroniseLdapUser :: UserId -> Handler ()
|
||||
dispatchJobSynchroniseLdapUser jUser = do
|
||||
UniWorX{ appSettings' = AppSettings{..}, .. } <- getYesod
|
||||
case (,) <$> appLdapConf <*> appLdapPool of
|
||||
Just (ldapConf, ldapPool) ->
|
||||
case appLdapPool of
|
||||
Just ldapPool ->
|
||||
runDB . void . runMaybeT . handleExc $ do
|
||||
user@User{userIdent} <- MaybeT $ get jUser
|
||||
|
||||
$logInfoS "SynchroniseLdap" [st|Synchronising #{userIdent}|]
|
||||
|
||||
ldapAttrs <- MaybeT $ campusUser' ldapConf ldapPool user
|
||||
reTestAfter <- getsYesod $ view _appLdapReTestFailover
|
||||
ldapAttrs <- MaybeT $ campusUserReTest' ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited user
|
||||
void . lift $ upsertCampusUser UpsertCampusUser ldapAttrs
|
||||
Nothing ->
|
||||
throwM SynchroniseLdapNoLdap
|
||||
|
||||
@ -93,21 +93,20 @@ dispatchHealthCheckHTTPReachable = fmap HealthHTTPReachable . yesodTimeout (^. _
|
||||
dispatchHealthCheckLDAPAdmins :: Handler HealthReport
|
||||
dispatchHealthCheckLDAPAdmins = fmap HealthLDAPAdmins . yesodTimeout (^. _appHealthCheckLDAPAdminsTimeout) (Just 0) $ do
|
||||
ldapPool' <- getsYesod appLdapPool
|
||||
ldapConf' <- getsYesod $ view _appLdapConf
|
||||
ldapAdminUsers <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
|
||||
E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
|
||||
E.where_ $ user E.^. UserAuthentication E.==. E.val AuthLDAP
|
||||
return $ user E.^. UserIdent
|
||||
case (,) <$> ldapPool' <*> ldapConf' of
|
||||
Just (ldapPool, ldapConf)
|
||||
| not $ null ldapAdminUsers
|
||||
-> do
|
||||
let numAdmins = genericLength ldapAdminUsers
|
||||
hCampusExc :: CampusUserException -> Handler (Sum Integer)
|
||||
hCampusExc _ = return $ Sum 0
|
||||
Sum numResolved <- fmap fold . forM ldapAdminUsers $
|
||||
\(CI.original -> adminIdent) -> handle hCampusExc $ Sum 1 <$ campusUser ldapConf ldapPool (Creds "LDAP" adminIdent [])
|
||||
return . Just $ numResolved % numAdmins
|
||||
reTestAfter <- getsYesod $ view _appLdapReTestFailover
|
||||
case ldapPool' of
|
||||
Just ldapPool -> do
|
||||
ldapAdminUsers' <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
|
||||
E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
|
||||
E.where_ $ user E.^. UserAuthentication E.==. E.val AuthLDAP
|
||||
return $ user E.^. UserIdent
|
||||
for (assertM' (not . null) ldapAdminUsers') $ \ldapAdminUsers -> do
|
||||
let numAdmins = genericLength ldapAdminUsers
|
||||
hCampusExc :: CampusUserException -> Handler (Sum Integer)
|
||||
hCampusExc _ = return $ Sum 0
|
||||
Sum numResolved <- fmap fold . forM ldapAdminUsers $
|
||||
\(CI.original -> adminIdent) -> handle hCampusExc $ Sum 1 <$ campusUserReTest ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited (Creds "LDAP" adminIdent [])
|
||||
return $ numResolved % numAdmins
|
||||
_other -> return Nothing
|
||||
|
||||
|
||||
|
||||
@ -4,12 +4,14 @@ module Ldap.Client.Pool
|
||||
( LdapPool
|
||||
, LdapExecutor, Ldap, LdapError
|
||||
, LdapPoolError(..)
|
||||
, withLdap
|
||||
, withLdap, withLdapFailover, withLdapFailoverReTest
|
||||
, createLdapPool
|
||||
) where
|
||||
|
||||
import ClassyPrelude hiding (Handler, catches, try)
|
||||
|
||||
import Utils.Failover
|
||||
|
||||
import Control.Lens
|
||||
|
||||
import Ldap.Client (Ldap, LdapError)
|
||||
@ -27,6 +29,9 @@ import Control.Monad.Trans.Resource (MonadResource)
|
||||
import qualified Control.Monad.Trans.Resource as Resource
|
||||
import Control.Monad.Catch
|
||||
|
||||
import Control.Monad.Trans.Except (throwE)
|
||||
import Data.Fixed (Nano)
|
||||
|
||||
|
||||
type LdapPool = Pool LdapExecutor
|
||||
data LdapExecutor = LdapExecutor
|
||||
@ -41,8 +46,14 @@ data LdapPoolError = LdapPoolTimeout | LdapError LdapError
|
||||
instance Exception LdapPoolError
|
||||
|
||||
|
||||
withLdap :: (MonadUnliftIO m, Typeable a) => LdapPool -> (Ldap -> m a) -> m (Either LdapPoolError a)
|
||||
withLdap pool act = withResource pool $ \LdapExecutor{..} -> ldapExec act
|
||||
withLdap :: (MonadUnliftIO m, MonadCatch m, Typeable a) => LdapPool -> (Ldap -> m a) -> m (Either LdapPoolError a)
|
||||
withLdap pool act = fmap join . try . withResource pool $ \LdapExecutor{..} -> ldapExec act
|
||||
|
||||
withLdapFailover :: (MonadUnliftIO m, MonadCatch m, Typeable a) => Lens p p' LdapPool Ldap -> Failover p -> FailoverMode -> (p' -> m a) -> m (Either LdapPoolError a)
|
||||
withLdapFailover l@(flip withLens const -> proj) pool' mode act = try . withFailover pool' mode (either throwE return) $ \x -> withLdap (proj x) (\c -> act $ x & l .~ c)
|
||||
|
||||
withLdapFailoverReTest :: (MonadUnliftIO m, MonadCatch m, Typeable a) => Lens p p' LdapPool Ldap -> Failover p -> (Nano -> Bool) -> FailoverMode -> (p' -> m a) -> m (Either LdapPoolError a)
|
||||
withLdapFailoverReTest l@(flip withLens const -> proj) pool' doTest mode act = try . withFailoverReTest pool' doTest mode (either throwE return) $ \x -> withLdap (proj x) (\c -> act $ x & l .~ c)
|
||||
|
||||
|
||||
createLdapPool :: ( MonadLoggerIO m, MonadResource m )
|
||||
|
||||
@ -65,6 +65,8 @@ import qualified Web.ServerSession.Core as ServerSession
|
||||
|
||||
import Text.Show (showParen, showString)
|
||||
|
||||
import qualified Data.List.PointedList as P
|
||||
|
||||
|
||||
-- | Runtime settings to configure this application. These settings can be
|
||||
-- loaded from various sources: defaults, environment variables, config files,
|
||||
@ -78,7 +80,7 @@ data AppSettings = AppSettings
|
||||
, appDatabaseConf :: PostgresConf
|
||||
-- ^ Configuration settings for accessing the database.
|
||||
, appAutoDbMigrate :: Bool
|
||||
, appLdapConf :: Maybe LdapConf
|
||||
, appLdapConf :: Maybe (PointedList LdapConf)
|
||||
-- ^ Configuration settings for accessing the LDAP-directory
|
||||
, appSmtpConf :: Maybe SmtpConf
|
||||
-- ^ Configuration settings for accessing a SMTP Mailserver
|
||||
@ -131,6 +133,8 @@ data AppSettings = AppSettings
|
||||
, appSynchroniseLdapUsersWithin :: Maybe NominalDiffTime
|
||||
, appSynchroniseLdapUsersInterval :: NominalDiffTime
|
||||
|
||||
, appLdapReTestFailover :: DiffTime
|
||||
|
||||
, appSessionFilesExpire :: NominalDiffTime
|
||||
, appPruneUnreferencedFiles :: Maybe NominalDiffTime
|
||||
|
||||
@ -412,7 +416,7 @@ instance FromJSON AppSettings where
|
||||
let nonEmptyHost LdapConf{..} = case ldapHost of
|
||||
Ldap.Tls host _ -> not $ null host
|
||||
Ldap.Plain host -> not $ null host
|
||||
appLdapConf <- assertM nonEmptyHost <$> o .:? "ldap"
|
||||
appLdapConf <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= []
|
||||
appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp"
|
||||
let validMemcachedConf MemcachedConf{memcachedConnectInfo = Memcached.ConnectInfo{..}, ..} = and
|
||||
[ not $ null connectHost
|
||||
@ -462,6 +466,8 @@ instance FromJSON AppSettings where
|
||||
appSynchroniseLdapUsersWithin <- o .:? "synchronise-ldap-users-within"
|
||||
appSynchroniseLdapUsersInterval <- o .: "synchronise-ldap-users-interval"
|
||||
|
||||
appLdapReTestFailover <- o .: "ldap-re-test-failover"
|
||||
|
||||
appSessionFilesExpire <- o .: "session-files-expire"
|
||||
appPruneUnreferencedFiles <- o .:? "prune-unreferenced-files"
|
||||
|
||||
|
||||
131
src/Utils/Failover.hs
Normal file
131
src/Utils/Failover.hs
Normal file
@ -0,0 +1,131 @@
|
||||
module Utils.Failover
|
||||
( Failover
|
||||
, mkFailover
|
||||
, FailoverMode(..)
|
||||
, withFailover, withFailoverReTest
|
||||
) where
|
||||
|
||||
import ClassyPrelude hiding (try)
|
||||
import Utils (foldMapM)
|
||||
|
||||
import Data.List.PointedList (PointedList)
|
||||
import qualified Data.List.PointedList as P
|
||||
|
||||
import Numeric.Natural
|
||||
|
||||
import System.Clock
|
||||
|
||||
import Control.Lens hiding (failover)
|
||||
import Utils.Lens.TH
|
||||
|
||||
import Data.List (unfoldr, genericTake)
|
||||
|
||||
import Control.Monad.Catch
|
||||
import Control.Monad.Trans.Except (ExceptT, runExceptT)
|
||||
import Control.Monad.Trans.Cont (runContT)
|
||||
import Control.Monad.Cont.Class (MonadCont(..))
|
||||
|
||||
import Control.Concurrent.STM.TVar (stateTVar)
|
||||
|
||||
import Data.Void (vacuous)
|
||||
|
||||
import Data.Fixed
|
||||
|
||||
|
||||
data FailoverItem a = FailoverItem
|
||||
{ failoverValue :: a
|
||||
, failoverLastTest :: Maybe TimeSpec
|
||||
}
|
||||
makeLenses_ ''FailoverItem
|
||||
|
||||
newtype Failover a = Failover { failover :: TVar (PointedList (FailoverItem a)) }
|
||||
deriving (Eq)
|
||||
|
||||
data FailoverMode
|
||||
= FailoverUnlimited
|
||||
| FailoverLimited Natural
|
||||
| FailoverNone
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
|
||||
mkFailover :: MonadIO m
|
||||
=> PointedList a
|
||||
-> m (Failover a)
|
||||
mkFailover opts = fmap Failover . liftIO $ newTVarIO opts'
|
||||
where opts' = opts <&> \failoverValue -> FailoverItem{ failoverLastTest = Nothing, .. }
|
||||
|
||||
|
||||
withFailover :: ( MonadIO m, MonadCatch m
|
||||
, Exception e
|
||||
)
|
||||
=> Failover a
|
||||
-> FailoverMode
|
||||
-> (b -> ExceptT e m c)
|
||||
-> (a -> m b)
|
||||
-> m c
|
||||
withFailover f@Failover{..} mode detAcceptable act = do
|
||||
now <- liftIO $ getTime Monotonic
|
||||
|
||||
FailoverItem{failoverValue} <- fmap (view P.focus) . liftIO $ readTVarIO failover
|
||||
|
||||
res <- act failoverValue
|
||||
res' <- runExceptT $ detAcceptable res
|
||||
|
||||
let
|
||||
recordFailure =
|
||||
atomically . stateTVar failover $ \failover' -> case P.next $ failover' & P.focus . _failoverLastTest ?~ now of
|
||||
Just failover'' -> (True, failover'')
|
||||
Nothing -> (False, failover')
|
||||
doRetry err = do
|
||||
didNext <- recordFailure
|
||||
let newMode = case mode of
|
||||
FailoverLimited n -> FailoverLimited $ pred n
|
||||
other -> other
|
||||
if | didNext -> withFailover f newMode detAcceptable act
|
||||
| otherwise -> throwM err
|
||||
|
||||
case (res', mode) of
|
||||
(Left err, FailoverUnlimited)
|
||||
-> doRetry err
|
||||
(Left err, FailoverLimited n)
|
||||
| n > 0
|
||||
-> doRetry err
|
||||
_other
|
||||
-> void recordFailure >> either throwM return res'
|
||||
|
||||
withFailoverReTest :: ( MonadIO m, MonadCatch m
|
||||
, Exception e
|
||||
)
|
||||
=> Failover a
|
||||
-> (Nano -> Bool)
|
||||
-> FailoverMode
|
||||
-> (b -> ExceptT e m c)
|
||||
-> (a -> m b)
|
||||
-> m c
|
||||
withFailoverReTest f@Failover{..} doTest mode detAcceptable act = do
|
||||
now <- liftIO $ getTime Monotonic
|
||||
|
||||
let filterFailover = filter $ \(view $ _2 . P.focus -> FailoverItem{failoverLastTest}) -> maybe True (\lT -> doTest . MkFixed . toNanoSecs $ now - lT) failoverLastTest
|
||||
|
||||
failover' <- fmap (reverse . filterFailover . unfoldr (\(i, l) -> ((i, ) &&& (succ i, )) <$> P.previous l) . (0,)) . liftIO $ readTVarIO failover
|
||||
|
||||
let failover'' = case mode of
|
||||
FailoverUnlimited -> failover'
|
||||
FailoverLimited n -> genericTake (succ n) failover'
|
||||
FailoverNone -> take 1 failover'
|
||||
|
||||
reTestRes <- flip runContT return . callCC $ \((. Just) -> retRes) -> fmap vacuous . flip foldMapM failover'' $ \failover'''@(over _2 (view P.focus) -> (i, FailoverItem{failoverValue})) -> do
|
||||
res <- lift $ act failoverValue
|
||||
res' <- lift . runExceptT $ detAcceptable res
|
||||
|
||||
case res' of
|
||||
Left _ -> do
|
||||
atomically . modifyTVar failover $ P.reversedPrefix . ix i . _failoverLastTest ?~ now
|
||||
return Nothing
|
||||
Right res'' -> do
|
||||
atomically . writeTVar failover $ view _2 failover''' & P.focus . _failoverLastTest ?~ now
|
||||
retRes res''
|
||||
|
||||
case reTestRes of
|
||||
Nothing -> withFailover f mode detAcceptable act
|
||||
Just r -> return r
|
||||
@ -31,18 +31,23 @@ import Control.Monad.Morph (MFunctor, MMonad)
|
||||
|
||||
|
||||
deriving via (ReaderT (HandlerData site site) IO) instance MonadFix (HandlerFor site)
|
||||
deriving via (ReaderT (HandlerData sub site) IO) instance MonadFix (SubHandlerFor sub site)
|
||||
deriving via (ReaderT (WidgetData site) IO) instance MonadFix (WidgetFor site)
|
||||
|
||||
deriving via (ReaderT (HandlerData site site) IO) instance MonadCatch (HandlerFor site)
|
||||
deriving via (ReaderT (HandlerData sub site) IO) instance MonadCatch (SubHandlerFor sub site)
|
||||
deriving via (ReaderT (WidgetData site) IO) instance MonadCatch (WidgetFor site)
|
||||
|
||||
deriving via (ReaderT (HandlerData site site) IO) instance MonadMask (HandlerFor site)
|
||||
deriving via (ReaderT (HandlerData sub site) IO) instance MonadMask (SubHandlerFor sub site)
|
||||
deriving via (ReaderT (WidgetData site) IO) instance MonadMask (WidgetFor site)
|
||||
|
||||
deriving via (ReaderT (HandlerData site site) IO) instance MonadBase IO (HandlerFor site)
|
||||
deriving via (ReaderT (HandlerData sub site) IO) instance MonadBase IO (SubHandlerFor sub site)
|
||||
deriving via (ReaderT (WidgetData site) IO) instance MonadBase IO (WidgetFor site)
|
||||
|
||||
deriving via (ReaderT (HandlerData site site) IO) instance MonadRandom (HandlerFor site)
|
||||
deriving via (ReaderT (HandlerData sub site) IO) instance MonadRandom (SubHandlerFor sub site)
|
||||
deriving via (ReaderT (WidgetData site) IO) instance MonadRandom (WidgetFor site)
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user