initial commit

src/Lib/Error.hs

@@ -0,0 +1,57 @@
+{-# 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
+
+respondStatusException :: MonadHandler m => S9ErrT m a -> m a
+respondStatusException 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