{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module Ouroboros.Consensus.Storage.LeiosDB.Exception
  ( LeiosDbException (..)
  , LeiosDbFailure (..)
  , LeiosDbWriteFailure (..)
  , throwLeiosDbException
  ) where

import Control.Monad.Class.MonadThrow (Exception (..), MonadThrow, SomeException, throwIO)
import Data.Aeson (KeyValue, ToJSON (..), Value (..), pairs, (.=))
import GHC.Stack (HasCallStack)
import qualified GHC.Stack

-- | Every way the Leios DB fails.
data LeiosDbException
  = LeiosDbException LeiosDbFailure
  | LeiosDbWriteException LeiosDbWriteFailure
  deriving Int -> LeiosDbException -> ShowS
[LeiosDbException] -> ShowS
LeiosDbException -> String
(Int -> LeiosDbException -> ShowS)
-> (LeiosDbException -> String)
-> ([LeiosDbException] -> ShowS)
-> Show LeiosDbException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LeiosDbException -> ShowS
showsPrec :: Int -> LeiosDbException -> ShowS
$cshow :: LeiosDbException -> String
show :: LeiosDbException -> String
$cshowList :: [LeiosDbException] -> ShowS
showList :: [LeiosDbException] -> ShowS
Show

-- | A database operation failed where it ran.
data LeiosDbFailure = LeiosDbFailure
  { LeiosDbFailure -> String
ldfErrorMessage :: String
  , LeiosDbFailure -> String
ldfCallStack :: String
  }
  deriving Int -> LeiosDbFailure -> ShowS
[LeiosDbFailure] -> ShowS
LeiosDbFailure -> String
(Int -> LeiosDbFailure -> ShowS)
-> (LeiosDbFailure -> String)
-> ([LeiosDbFailure] -> ShowS)
-> Show LeiosDbFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LeiosDbFailure -> ShowS
showsPrec :: Int -> LeiosDbFailure -> ShowS
$cshow :: LeiosDbFailure -> String
show :: LeiosDbFailure -> String
$cshowList :: [LeiosDbFailure] -> ShowS
showList :: [LeiosDbFailure] -> ShowS
Show

-- | A submitted write failed, as whoever awaits it sees it. A write runs
-- on the writer rather than at its call site, so it knows what a read
-- never can: which write it was, and where it was submitted from.
data LeiosDbWriteFailure = LeiosDbWriteFailure
  { LeiosDbWriteFailure -> String
ldwfWriteJob :: String
  , LeiosDbWriteFailure -> String
ldwfSubmittedFrom :: String
  , LeiosDbWriteFailure -> SomeException
ldwfWriteFailure :: SomeException
  }
  deriving Int -> LeiosDbWriteFailure -> ShowS
[LeiosDbWriteFailure] -> ShowS
LeiosDbWriteFailure -> String
(Int -> LeiosDbWriteFailure -> ShowS)
-> (LeiosDbWriteFailure -> String)
-> ([LeiosDbWriteFailure] -> ShowS)
-> Show LeiosDbWriteFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LeiosDbWriteFailure -> ShowS
showsPrec :: Int -> LeiosDbWriteFailure -> ShowS
$cshow :: LeiosDbWriteFailure -> String
show :: LeiosDbWriteFailure -> String
$cshowList :: [LeiosDbWriteFailure] -> ShowS
showList :: [LeiosDbWriteFailure] -> ShowS
Show

instance Exception LeiosDbException where
  displayException :: LeiosDbException -> String
displayException = \case
    LeiosDbException LeiosDbFailure{String
ldfErrorMessage :: LeiosDbFailure -> String
ldfErrorMessage :: String
ldfErrorMessage, String
ldfCallStack :: LeiosDbFailure -> String
ldfCallStack :: String
ldfCallStack} ->
      String
ldfErrorMessage String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
ldfCallStack
    LeiosDbWriteException LeiosDbWriteFailure{String
ldwfWriteJob :: LeiosDbWriteFailure -> String
ldwfWriteJob :: String
ldwfWriteJob, String
ldwfSubmittedFrom :: LeiosDbWriteFailure -> String
ldwfSubmittedFrom :: String
ldwfSubmittedFrom, SomeException
ldwfWriteFailure :: LeiosDbWriteFailure -> SomeException
ldwfWriteFailure :: SomeException
ldwfWriteFailure} ->
      String
ldwfWriteJob
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" failed: "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
ldwfWriteFailure
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\nsubmitted from:\n"
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
ldwfSubmittedFrom

-- | Fail with a 'LeiosDbException' carrying the call stack. Preferred over
-- 'error': an invariant the database broke is still a database failure, and
-- callers catch it as one.
throwLeiosDbException :: (HasCallStack, MonadThrow m) => String -> m a
throwLeiosDbException :: forall (m :: * -> *) a.
(HasCallStack, MonadThrow m) =>
String -> m a
throwLeiosDbException String
msg =
  LeiosDbException -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (LeiosDbException -> m a) -> LeiosDbException -> m a
forall a b. (a -> b) -> a -> b
$
    LeiosDbFailure -> LeiosDbException
LeiosDbException
      LeiosDbFailure
        { ldfErrorMessage :: String
ldfErrorMessage = String
msg
        , ldfCallStack :: String
ldfCallStack = CallStack -> String
GHC.Stack.prettyCallStack CallStack
HasCallStack => CallStack
GHC.Stack.callStack
        }

instance ToJSON LeiosDbException where
  toJSON :: LeiosDbException -> Value
toJSON = KeyMap Value -> Value
Object (KeyMap Value -> Value)
-> (LeiosDbException -> KeyMap Value) -> LeiosDbException -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LeiosDbException -> KeyMap Value
forall a kv. (KeyValue a kv, Monoid kv) => LeiosDbException -> kv
jsonLeiosDbException
  toEncoding :: LeiosDbException -> Encoding
toEncoding = Series -> Encoding
pairs (Series -> Encoding)
-> (LeiosDbException -> Series) -> LeiosDbException -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LeiosDbException -> Series
forall a kv. (KeyValue a kv, Monoid kv) => LeiosDbException -> kv
jsonLeiosDbException

jsonLeiosDbException :: (KeyValue a kv, Monoid kv) => LeiosDbException -> kv
jsonLeiosDbException :: forall a kv. (KeyValue a kv, Monoid kv) => LeiosDbException -> kv
jsonLeiosDbException = \case
  LeiosDbException LeiosDbFailure{String
ldfErrorMessage :: LeiosDbFailure -> String
ldfErrorMessage :: String
ldfErrorMessage, String
ldfCallStack :: LeiosDbFailure -> String
ldfCallStack :: String
ldfCallStack} ->
    [kv] -> kv
forall a. Monoid a => [a] -> a
mconcat
      [ Key
"kind" Key -> Value -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"LeiosDbException"
      , Key
"errorMessage" Key -> String -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
ldfErrorMessage
      , Key
"callStack" Key -> String -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
ldfCallStack
      ]
  LeiosDbWriteException LeiosDbWriteFailure{String
ldwfWriteJob :: LeiosDbWriteFailure -> String
ldwfWriteJob :: String
ldwfWriteJob, String
ldwfSubmittedFrom :: LeiosDbWriteFailure -> String
ldwfSubmittedFrom :: String
ldwfSubmittedFrom, SomeException
ldwfWriteFailure :: LeiosDbWriteFailure -> SomeException
ldwfWriteFailure :: SomeException
ldwfWriteFailure} ->
    [kv] -> kv
forall a. Monoid a => [a] -> a
mconcat
      [ Key
"kind" Key -> Value -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"LeiosDbWriteException"
      , Key
"writeJob" Key -> String -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
ldwfWriteJob
      , Key
"errorMessage" Key -> String -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
ldwfWriteFailure
      , Key
"callStack" Key -> String -> kv
forall v. ToJSON v => Key -> v -> kv
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
ldwfSubmittedFrom
      ]