feat(ldap): failover

config/settings.yml

@@ -92,19 +92,21 @@ database:
 auto-db-migrate: '_env:AUTO_DB_MIGRATE:true'
 
 ldap:
-  host:    "_env:LDAPHOST:"
+  - host:    "_env:LDAPHOST:"
-  tls:     "_env:LDAPTLS:"
+    tls:     "_env:LDAPTLS:"
-  port:    "_env:LDAPPORT:389"
+    port:    "_env:LDAPPORT:389"
-  user:    "_env:LDAPUSER:"
+    user:    "_env:LDAPUSER:"
-  pass:    "_env:LDAPPASS:"
+    pass:    "_env:LDAPPASS:"
-  baseDN:  "_env:LDAPBASE:"
+    baseDN:  "_env:LDAPBASE:"
-  scope:   "_env:LDAPSCOPE:WholeSubtree"
+    scope:   "_env:LDAPSCOPE:WholeSubtree"
-  timeout: "_env:LDAPTIMEOUT:5"
+    timeout: "_env:LDAPTIMEOUT:5"
-  search-timeout: "_env:LDAPSEARCHTIME:5"
+    search-timeout: "_env:LDAPSEARCHTIME:5"
-  pool:
+    pool:
-    stripes: "_env:LDAPSTRIPES:1"
+      stripes: "_env:LDAPSTRIPES:1"
-    timeout: "_env:LDAPTIMEOUT:20"
+      timeout: "_env:LDAPTIMEOUT:20"
-    limit:   "_env:LDAPLIMIT:10"
+      limit:   "_env:LDAPLIMIT:10"
+
+ldap-re-test-failover: 60
 
 smtp:
   host:    "_env:SMTPHOST:"

package.yaml

@@ -145,6 +145,8 @@ dependencies:
   - pandoc
   - token-bucket
   - async
+  - pointedlist
+  - clock
 
 other-extensions:
   - GeneralizedNewtypeDeriving

src/Application.hs

@@ -209,9 +209,9 @@ makeFoundation appSettings'@AppSettings{..} = do
         (pgConnStr  appDatabaseConf)
         (pgPoolSize appDatabaseConf)
 
-      ldapPool <- for appLdapConf $ \LdapConf{..} -> do
+      ldapPool <- traverse mkFailover <=< forOf (traverse . traverse) appLdapConf $ \conf@LdapConf{..} -> do
-        $logDebugS "setup" "LDAP-Pool"
+        $logDebugS "setup" $ "LDAP-Pool " <> tshow ldapHost
-        createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
+        (conf,) <$> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
 
       -- Perform database migration using our application's logging settings.
       if

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 [])
+campusUserWith :: MonadUnliftIO m
-campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
+               => (    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 []))
+campusUserReTest  :: MonadUnliftIO m => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
-campusUser' conf pool User{userIdent}
+campusUserReTest pool doTest = campusUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool
-  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser conf pool (Creds apLdap (CI.original userIdent) [])
+
+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 :: MonadUnliftIO m => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Ldap.AttrList [])
-campusUserMatr conf@LdapConf{..} pool userMatr = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< withLdap pool $ \ldap -> do
+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' :: (MonadCatch m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Maybe (Ldap.AttrList []))
-campusUserMatr' conf pool
+campusUserMatr' pool mode
-  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . campusUserMatr conf pool
+  = 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
+               ) => Failover (LdapConf, LdapPool) -> FailoverMode -> AuthPlugin site
-campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
+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

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
+      flip catches excHandlers $ case appLdapPool of
-        Just (ldapConf, ldapPool)
+        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
 
   

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)

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
+                Just pool <- getsYesod $ view _appLdapPool
-                void . lift . Auth.campusUser conf pool $ Creds Auth.apLdap (CI.original userIdent) []
+                void . lift . Auth.campusUser pool FailoverUnlimited $ Creds Auth.apLdap (CI.original userIdent) []
             case campusResult of
               Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup
               _other

src/Handler/Utils/Users.hs

@@ -100,10 +100,9 @@ guessUser (Set.toList -> criteria) = $cachedHereBinary criteria $ go False
             ]
 
           doLdap userMatr = do
-            app <- getYesod
+            ldapPool' <- getsYesod $ view _appLdapPool
-            let ldap = (,) <$> app ^. _appLdapConf <*> app ^. _appLdapPool
+            fmap (fmap entityKey . join) . for ldapPool' $ \ldapPool -> do
-            fmap (fmap entityKey . join) . for ldap $ \(ldapConf, ldapPool) -> do
+              ldapData <- campusUserMatr' ldapPool FailoverUnlimited userMatr
-              ldapData <- campusUserMatr' ldapConf ldapPool userMatr
               for ldapData $ upsertCampusUser UpsertCampusUser
 
       if

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

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 ()

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
+  case appLdapPool of
-    Just (ldapConf, ldapPool) -> 
+    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

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
+  reTestAfter <- getsYesod $ view _appLdapReTestFailover
-  ldapAdminUsers <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
+  case ldapPool' of
-    E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
+    Just ldapPool -> do
-    E.where_ $ user E.^. UserAuthentication E.==. E.val AuthLDAP
+      ldapAdminUsers' <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
-    return $ user E.^. UserIdent
+        E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
-  case (,) <$> ldapPool' <*> ldapConf' of
+        E.where_ $ user E.^. UserAuthentication E.==. E.val AuthLDAP
-    Just (ldapPool, ldapConf)
+        return $ user E.^. UserIdent
-      | not $ null ldapAdminUsers
+      for (assertM' (not . null) ldapAdminUsers') $ \ldapAdminUsers -> do
-        -> do
+        let numAdmins = genericLength ldapAdminUsers
-          let numAdmins = genericLength ldapAdminUsers
+            hCampusExc :: CampusUserException -> Handler (Sum Integer)
-              hCampusExc :: CampusUserException -> Handler (Sum Integer)
+            hCampusExc _ = return $ Sum 0
-              hCampusExc _ = return $ Sum 0
+        Sum numResolved <- fmap fold . forM ldapAdminUsers $
-          Sum numResolved <- fmap fold . forM ldapAdminUsers $
+          \(CI.original -> adminIdent) -> handle hCampusExc $ Sum 1 <$ campusUserReTest ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited (Creds "LDAP" adminIdent [])
-            \(CI.original -> adminIdent) -> handle hCampusExc $ Sum 1 <$ campusUser ldapConf ldapPool (Creds "LDAP" adminIdent [])
+        return $ numResolved % numAdmins
-          return . Just $ numResolved % numAdmins
     _other -> return Nothing
 
 

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 :: (MonadUnliftIO m, MonadCatch m, Typeable a) => LdapPool -> (Ldap -> m a) -> m (Either LdapPoolError a)
-withLdap pool act = withResource pool $ \LdapExecutor{..} -> ldapExec act
+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 )

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"
 

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

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)