diff --git a/config/settings.yml b/config/settings.yml index 85cd909e6..47c517a15 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -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:" diff --git a/package.yaml b/package.yaml index 48e099fc9..11a03591f 100644 --- a/package.yaml +++ b/package.yaml @@ -145,6 +145,8 @@ dependencies: - pandoc - token-bucket - async + - pointedlist + - clock other-extensions: - GeneralizedNewtypeDeriving diff --git a/src/Application.hs b/src/Application.hs index fa6992621..51bef9a21 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index feaa31c44..8f0a40f98 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 77f0828d8..7aee3ddff 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 235b46c20..6dd5305f6 100644 --- a/src/Foundation/Type.hs +++ b/src/Foundation/Type.hs @@ -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) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index ee0d67d85..bcc916a16 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -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 diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index bd95b8be3..be010ee94 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -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 diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 7212ff285..1e3925395 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -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 diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 65bd3603d..3a5365c57 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -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 () diff --git a/src/Jobs/Handler/SynchroniseLdap.hs b/src/Jobs/Handler/SynchroniseLdap.hs index 1c82569ed..42c40db87 100644 --- a/src/Jobs/Handler/SynchroniseLdap.hs +++ b/src/Jobs/Handler/SynchroniseLdap.hs @@ -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 diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs index 90ddf8966..fb8e67ae1 100644 --- a/src/Jobs/HealthReport.hs +++ b/src/Jobs/HealthReport.hs @@ -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 diff --git a/src/Ldap/Client/Pool.hs b/src/Ldap/Client/Pool.hs index 9a33e9e0f..d85028187 100644 --- a/src/Ldap/Client/Pool.hs +++ b/src/Ldap/Client/Pool.hs @@ -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 ) diff --git a/src/Settings.hs b/src/Settings.hs index ce756983e..22454a0df 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -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" diff --git a/src/Utils/Failover.hs b/src/Utils/Failover.hs new file mode 100644 index 000000000..112ceab53 --- /dev/null +++ b/src/Utils/Failover.hs @@ -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 diff --git a/src/Yesod/Core/Types/Instances.hs b/src/Yesod/Core/Types/Instances.hs index 042255544..62ffbdb4c 100644 --- a/src/Yesod/Core/Types/Instances.hs +++ b/src/Yesod/Core/Types/Instances.hs @@ -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)