mirror of
https://github.com/Start9Labs/registry.git
synced 2026-03-26 10:21:51 +00:00
80 lines
2.2 KiB
Haskell
80 lines
2.2 KiB
Haskell
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
|
|
module Lib.Error where
|
|
|
|
import Startlude
|
|
|
|
import Data.String.Interpolate.IsString
|
|
import Network.HTTP.Types
|
|
import Yesod.Core
|
|
|
|
type S9ErrT m = ExceptT S9Error m
|
|
|
|
data S9Error =
|
|
PersistentE Text
|
|
| AppMgrE Text ExitCode
|
|
| NotFoundE Text
|
|
| InvalidParamsE Text 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
|
|
AppMgrE cmd code -> Error APPMGR_ERROR [i|"appmgr #{cmd}" exited with #{code}|]
|
|
NotFoundE e -> Error NOT_FOUND [i|#{e}|]
|
|
InvalidParamsE e m -> Error INVALID_PARAMS [i|Could not parse request parameters #{e}: #{m}|]
|
|
|
|
data ErrorCode =
|
|
DATABASE_ERROR
|
|
| APPMGR_ERROR
|
|
| NOT_FOUND
|
|
| INVALID_PARAMS
|
|
|
|
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
|
|
AppMgrE _ _ -> status500
|
|
NotFoundE _ -> status404
|
|
InvalidParamsE _ _ -> status400
|
|
|
|
|
|
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
|
|
|
|
errOnNothing :: MonadHandler m => Status -> Text -> Maybe a -> m a
|
|
errOnNothing status res entity = case entity of
|
|
Nothing -> sendResponseStatus status res
|
|
Just a -> pure a
|