registry/src/Lib/Error.hs

{-# LANGUAGE RecordWildCards #-}
module Lib.Error where

import           Startlude

import           Network.HTTP.Types
import           Yesod.Core

type S9ErrT m = ExceptT S9Error m

data S9Error = PersistentE Text deriving (Show, Eq)

instance Exception S9Error

-- | Redact any sensitive data in this function
toError :: S9Error -> Error
toError = \case
    PersistentE t -> Error DATABASE_ERROR t

data ErrorCode =
      DATABASE_ERROR
    deriving (Eq, Show)
instance ToJSON ErrorCode where
    toJSON = String . show

data Error = Error
    { errorCode    :: ErrorCode
    , errorMessage :: Text
    } deriving (Eq, Show)
instance ToJSON Error where
    toJSON Error{..} = object
        [ "code" .= errorCode
        , "message" .= errorMessage
        ]
instance ToContent Error where
    toContent = toContent . toJSON
instance ToTypedContent Error where
    toTypedContent = toTypedContent . toJSON

instance ToTypedContent S9Error where
    toTypedContent = toTypedContent . toJSON . toError
instance ToContent S9Error where
    toContent = toContent . toJSON . toError

toStatus :: S9Error -> Status
toStatus = \case
    PersistentE _ -> status500

handleS9ErrT :: MonadHandler m => S9ErrT m a -> m a
handleS9ErrT action = runExceptT action >>= \case
    Left e -> toStatus >>= sendResponseStatus $ e
    Right a -> pure a

handleS9ErrNuclear :: MonadIO m => S9ErrT m a -> m a
handleS9ErrNuclear action = runExceptT action >>= \case
    Left e -> throwIO e
    Right a -> pure a