Skip to content

Commit ff05138

Browse files
jorisdraljorisdral
committed
QLS: refactor error handlers
1 parent 0f8e54d commit ff05138

File tree

3 files changed

+79
-41
lines changed

3 files changed

+79
-41
lines changed

‎test/Database/LSMTree/Model/Session.hs

Lines changed: 13 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -233,7 +233,10 @@ runModelMWithInjectedErrors ::
233233
runModelMWithInjectedErrors Nothing onNoErrors _ st =
234234
runModelM onNoErrors st
235235
runModelMWithInjectedErrors (Just _) _ onErrors st =
236-
runModelM (onErrors >> throwError (ErrDiskFault "modelled FsError")) st
236+
runModelM (onErrors >> throwError modelErrDiskFault) st
237+
238+
modelErrDiskFault :: Err
239+
modelErrDiskFault = ErrDiskFault "modelled disk fault"
237240

238241
--
239242
-- Errors
@@ -249,6 +252,7 @@ data Err =
249252
-- | A catch-all error for cases where /something/ went wrong with the file
250253
-- system.
251254
| ErrDiskFault String
255+
| ErrOther String
252256

253257
instance Show Err where
254258
showsPrec d = \case
@@ -268,6 +272,10 @@ instance Show Err where
268272
showParen (d > appPrec) $
269273
showString "ErrDiskFault " .
270274
showParen True (showString s)
275+
ErrOther s ->
276+
showParen (d > appPrec) $
277+
showString "ErrOther " .
278+
showParen True (showString s)
271279

272280
-- Approximate equality for errors.
273281
--
@@ -291,6 +299,9 @@ instance Eq Err where
291299
(==) ErrSnapshotWrongType ErrSnapshotWrongType = True
292300
(==) ErrBlobRefInvalidated ErrBlobRefInvalidated = True
293301
(==) ErrCursorClosed ErrCursorClosed = True
302+
(==) (ErrOther s1) (ErrOther s2) = s1 == s2
303+
(==) _ (ErrOther _) = False
304+
(==) (ErrOther _) _ = False
294305
(==) _ (ErrDiskFault _) = True
295306
(==) (ErrDiskFault _) _ = True
296307
(==) _ _ = False
@@ -303,6 +314,7 @@ instance Eq Err where
303314
ErrBlobRefInvalidated{} -> ()
304315
ErrCursorClosed{} -> ()
305316
ErrDiskFault{} -> ()
317+
ErrOther{} -> ()
306318

307319
{-------------------------------------------------------------------------------
308320
Tables

‎test/Test/Database/LSMTree/Model/Session.hs

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -30,6 +30,7 @@ instance Arbitrary Err where
3030
, pure ErrBlobRefInvalidated
3131
, pure ErrCursorClosed
3232
, ErrDiskFault <$> arbitrary
33+
, ErrOther <$> arbitrary
3334
]
3435
where
3536
_coveredAllCases x = case x of
@@ -40,8 +41,10 @@ instance Arbitrary Err where
4041
ErrBlobRefInvalidated{} -> ()
4142
ErrCursorClosed{} -> ()
4243
ErrDiskFault{} -> ()
44+
ErrOther{} -> ()
4345

4446
shrink (ErrDiskFault s) = ErrDiskFault <$> shrink s
47+
shrink (ErrOther s) = ErrOther <$> shrink s
4548
shrink _ = []
4649

4750
deriving stock instance Generic Err

‎test/Test/Database/LSMTree/StateMachine.hs

Lines changed: 63 additions & 40 deletions
Original file line numberDiff line numberDiff line change
@@ -190,11 +190,7 @@ propLockstep_ModelIOImpl =
190190
env :: RealEnv ModelIO.Table IO
191191
env = RealEnv {
192192
envSession = session
193-
, envHandlers = [
194-
handler
195-
, fileFormatErrorHandler
196-
, diskFaultErrorHandler
197-
]
193+
, envHandlers = [handler]
198194
, envErrors = errsVar
199195
, envInjectFaultResults = faultsVar
200196
}
@@ -295,11 +291,7 @@ propLockstep_RealImpl_RealFS_IO tr =
295291
env :: RealEnv R.Table IO
296292
env = RealEnv {
297293
envSession = session
298-
, envHandlers = [
299-
realHandler @IO
300-
, fileFormatErrorHandler
301-
, diskFaultErrorHandler
302-
]
294+
, envHandlers = realErrorHandlers @IO
303295
, envErrors = errsVar
304296
, envInjectFaultResults = faultsVar
305297
}
@@ -338,11 +330,7 @@ propLockstep_RealImpl_MockFS_IO tr =
338330
env :: RealEnv R.Table IO
339331
env = RealEnv {
340332
envSession = session
341-
, envHandlers = [
342-
realHandler @IO
343-
, fileFormatErrorHandler
344-
, diskFaultErrorHandler
345-
]
333+
, envHandlers = realErrorHandlers @IO
346334
, envErrors = errsVar
347335
, envInjectFaultResults = faultsVar
348336
}
@@ -375,11 +363,7 @@ propLockstep_RealImpl_MockFS_IOSim tr actions =
375363
env :: RealEnv R.Table (IOSim s)
376364
env = RealEnv {
377365
envSession = session
378-
, envHandlers = [
379-
realHandler @(IOSim s)
380-
, fileFormatErrorHandler
381-
, diskFaultErrorHandler
382-
]
366+
, envHandlers = realErrorHandlers @(IOSim s)
383367
, envErrors = errsVar
384368
, envInjectFaultResults = faultsVar
385369
}
@@ -439,8 +423,30 @@ getAllSessionCursors (R.Internal.Session' s) =
439423
cs <- readMVar (R.Internal.sessionOpenCursors seshEnv)
440424
pure ((\x -> SomeCursor (R.Internal.Cursor' x)) <$> Map.elems cs)
441425

442-
realHandler :: Monad m => Handler m (Maybe Model.Err)
443-
realHandler = Handler $ pure . handler'
426+
createSystemTempDirectory :: [Char] -> IO (FilePath, HasFS IO HandleIO, HasBlockIO IO HandleIO)
427+
createSystemTempDirectory prefix = do
428+
systemTempDir <- getCanonicalTemporaryDirectory
429+
tempDir <- createTempDirectory systemTempDir prefix
430+
let hasFS = ioHasFS (MountPoint tempDir)
431+
hasBlockIO <- ioHasBlockIO hasFS defaultIOCtxParams
432+
pure (tempDir, hasFS, hasBlockIO)
433+
434+
{-------------------------------------------------------------------------------
435+
Error handlers
436+
-------------------------------------------------------------------------------}
437+
438+
realErrorHandlers :: Monad m => [Handler m (Maybe Model.Err)]
439+
realErrorHandlers = [
440+
lsmTreeErrorHandler
441+
, commitActionRegistryErrorHandler
442+
, abortActionRegistryErrorHandler
443+
, fsErrorHandler
444+
, fileFormatErrorHandler
445+
, catchAllErrorHandler
446+
]
447+
448+
lsmTreeErrorHandler :: Monad m => Handler m (Maybe Model.Err)
449+
lsmTreeErrorHandler = Handler $ pure . handler'
444450
where
445451
handler' :: LSMTreeError -> Maybe Model.Err
446452
handler' ErrTableClosed = Just Model.ErrTableClosed
@@ -449,48 +455,65 @@ realHandler = Handler $ pure . handler'
449455
handler' (ErrSnapshotExists _snap) = Just Model.ErrSnapshotExists
450456
handler' ErrSnapshotWrongTableType{} = Just Model.ErrSnapshotWrongType
451457
handler' (ErrBlobRefInvalid _) = Just Model.ErrBlobRefInvalidated
452-
handler' _ = Nothing
458+
handler' e = Just (Model.ErrOther (displayException e))
453459

454-
-- | When combined with other handlers, 'diskFaultErrorHandler' has to go last
455-
-- because it matches on 'SomeException', an no other handlers are run after
456-
-- that. See the use of 'catches' in 'catchErr'.
457-
diskFaultErrorHandler :: Monad m => Handler m (Maybe Model.Err)
458-
diskFaultErrorHandler = Handler $ \e -> pure $
459-
if isDiskFault e
460-
then Just (Model.ErrDiskFault (displayException e))
461-
else Nothing
460+
commitActionRegistryErrorHandler :: Monad m => Handler m (Maybe Model.Err)
461+
commitActionRegistryErrorHandler = Handler $ pure . handler'
462+
where
463+
handler' :: CommitActionRegistryError -> Maybe Model.Err
464+
handler' e
465+
| isDiskFault (toException e) = Just (Model.ErrDiskFault (displayException e))
466+
| otherwise = Just (Model.ErrOther (displayException e))
462467

468+
abortActionRegistryErrorHandler :: Monad m => Handler m (Maybe Model.Err)
469+
abortActionRegistryErrorHandler = Handler $ pure . handler'
470+
where
471+
handler' :: AbortActionRegistryError -> Maybe Model.Err
472+
handler' e
473+
| isDiskFault (toException e) = Just (Model.ErrDiskFault (displayException e))
474+
| otherwise = Just (Model.ErrOther (displayException e))
475+
476+
-- | Some exceptions contain other exceptions. We check recursively if there is
477+
-- *any* exception that must have occurred because of a disk fault, and if so we
478+
-- consider the whole structure of exceptions a disk fault exception.
463479
isDiskFault :: SomeException -> Bool
464480
isDiskFault e
465481
| Just (CommitActionRegistryError es) <- fromException e
466-
= all isDiskFault' es
482+
= any isDiskFault' es
467483
| Just (AbortActionRegistryError reason es) <- fromException e
468484
= case reason of
469-
ReasonExitCaseException e' -> isDiskFault e' && all isDiskFault' es
485+
ReasonExitCaseException e' -> isDiskFault e' || any isDiskFault' es
470486
ReasonExitCaseAbort -> False
471487
| Just (e' :: ActionError) <- fromException e
472488
= isDiskFault' (getActionError e')
473489
| Just FsError{} <- fromException e
474490
= True
491+
| Just FileFormatError{} <- fromException e
492+
= True
475493
| otherwise
476494
= False
477495
where
478496
isDiskFault' :: forall e. Exception e => e -> Bool
479497
isDiskFault' = isDiskFault . toException
480498

499+
fsErrorHandler :: Monad m => Handler m (Maybe Model.Err)
500+
fsErrorHandler = Handler $ pure . handler'
501+
where
502+
handler' :: FsError -> Maybe Model.Err
503+
handler' e = Just (Model.ErrDiskFault (displayException e))
504+
481505
fileFormatErrorHandler :: Monad m => Handler m (Maybe Model.Err)
482506
fileFormatErrorHandler = Handler $ pure . handler'
483507
where
484508
handler' :: FileFormatError -> Maybe Model.Err
485509
handler' e = Just (Model.ErrDiskFault (displayException e))
486510

487-
createSystemTempDirectory :: [Char] -> IO (FilePath, HasFS IO HandleIO, HasBlockIO IO HandleIO)
488-
createSystemTempDirectory prefix = do
489-
systemTempDir <- getCanonicalTemporaryDirectory
490-
tempDir <- createTempDirectory systemTempDir prefix
491-
let hasFS = ioHasFS (MountPoint tempDir)
492-
hasBlockIO <- ioHasBlockIO hasFS defaultIOCtxParams
493-
pure (tempDir, hasFS, hasBlockIO)
511+
-- | When combined with other handlers, 'catchAllErrorHandler' has to go last
512+
-- because it matches on 'SomeException', an no other handlers are run after
513+
-- that. See the use of 'catches' in 'catchErr'.
514+
catchAllErrorHandler :: Monad m => Handler m (Maybe Model.Err)
515+
catchAllErrorHandler = Handler $ \(e :: SomeException) ->
516+
pure $ Just (Model.ErrOther (displayException e))
494517

495518
{-------------------------------------------------------------------------------
496519
Key and value types

0 commit comments

Comments
 (0)