servant-typed-error (empty) → 0.1.2.0

raw patch · 5 files changed

+251/−0 lines, 5 filesdep +aesondep +basedep +mtl

Dependencies added: aeson, base, mtl, servant, servant-client, servant-server, sop-core

Files

ChangeLog.md +11/−0
LICENSE +21/−0
README.md +51/−0
servant-typed-error.cabal +37/−0
src/Servant/Typed/Error.hs +131/−0

+ ChangeLog.md view

@@ -0,0 +1,11 @@+# Changelog for servant-resumable++## 0.1.2.0+* Prep for OSS release++## 0.1.1.0+* Add typed error for DELETE++## 0.1.0.0+* Initial version+

+ LICENSE view

@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2022 Plow Technologies++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

+ README.md view

@@ -0,0 +1,51 @@+# servant-typed-error++This is a small wrapper for the exception approach detailed here: https://docs.servant.dev/en/stable/cookbook/uverb/UVerb.html?highlight=exceptions++This library allows sending and receiving Typed errors via servant. For example, we can define the following API:++```haskell+data APIError = Whoops | Bad Int+  deriving (Generic, ToJSON, FromJSON)++type API =+  "foo" :> Capture "number" Int :> GetTypedError '[JSON] Bool APIError+    :<|> "whoops" :> GetTypedError '[JSON] Int APIError+```++Here we use `GetTypedError` instead of the usual `Get` to indicate the API can return an `ApiError`, which must have a `ToJSON`/`FromJSON` instance.++There are two ways of writing a server for this API. We can either use the `TypedHandler` monad, which has `throwTypedError` and `throwServantError` functions allowing us to either throw our custom typed error or a generic `ServantError`. Another approach using a generic `mtl` style definition of a monad with a `MonadError e m` constraint; we can then use `liftTypedError` to lift it into servant's `Handler` monad:+++```haskell+alwaysWhoops :: MonadError APIError m => m Int+alwaysWhoops = throwError Whoops++server :: Server API+server =+  ( \i ->+      runTypedHandler $ case i of+        42 -> throwTypedError $ Bad i+        -1 -> throwServantError err500+        x -> pure $ x `mod` 2 == 0+  )+    :<|> liftTypedError alwaysWhoops+```++Finally, we can recover the errors on the client side via a special `TypedClientM e a` monad. We use the `typedClient` to convert the servant-client API to use our `TypedClientM`:++```haskell+foo :: Int -> TypedClientM APIError Bool+whoops :: TypedClientM APIError Int+foo :<|> whoops = typedClient $ client $ Proxy @API+```++Then, using `runTypedClientM` we can obtain an `Either (Either ClientError APIError) a` and pattern match on both the generic servant-client error or the user defined `APIError`.+++## Differences with other servant typed error/exception libs++- [servant-checked-exceptions](https://hackage.haskell.org/package/servant-checked-exceptions) This library wraps the response in a custom type, so it would be a bit awkward to use with the frontend. The approach here sends the same 200 response as vanilla servant would++- [servant-exceptions](https://github.com/ch1bo/servant-exceptions) Not investigated much since it's missing the client implementation

+ servant-typed-error.cabal view

@@ -0,0 +1,37 @@+cabal-version: 1.12+name:           servant-typed-error+version:        0.1.2.0+synopsis:       Typed error wrapper for Servant+description:    Typed error wrapper using UVerb for Servant+category:       Web, Servant+homepage:       https://github.com/plow-technologies/servant-typed-error.git#readme+bug-reports:    https://github.com/plow-technologies/servant-typed-error.git/issues+author:         Sam Balco+maintainer:     info@plowtech.net+copyright:      2021 Plow Technologies LLC+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+  type: git+  location: https://github.com/plow-technologies/servant-typed-error.git++library+  exposed-modules:+      Servant.Typed.Error+  hs-source-dirs:+      src+  build-depends:+      aeson >= 2.1.1 && < 2.2+    , base >= 4.13 && < 4.18+    , mtl >= 2.2.2 && < 2.3+    , servant >= 0.19 && < 0.20+    , servant-server >= 0.19.1 && < 0.20+    , servant-client >= 0.19 && < 0.20+    , sop-core >= 0.5.0.2 && < 0.6+  default-language: Haskell2010+

+ src/Servant/Typed/Error.hs view

@@ -0,0 +1,131 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Servant.Typed.Error+  ( GetTypedError,+    PostTypedError,+    DeleteTypedError,+    PutTypedError,+    WithError,+    TypedHandler (..),+    throwTypedError,+    throwServantError,+    runTypedHandler,+    liftTypedError,+    TypedClientM,+    typedClient,+    runTypedClientM,+  )+where++import Control.Monad.Except (ExceptT (..), MonadError (..), runExceptT)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Reader (ReaderT (..))+import Data.Aeson (FromJSON (..), ToJSON (..))+import Data.Bifunctor (Bifunctor (..))+import Data.SOP (I (I))+import Data.SOP.BasicFunctors (unI)+import Servant (Union, WithStatus (..), (:<|>) (..))+import Servant.API (Capture, HasStatus (..), JSON, ReqBody, StdMethod (DELETE, GET, POST, PUT), UVerb, Union, WithStatus (..), (:<|>) (..), (:>))+import Servant.API.UVerb (eject, inject)+import Servant.Client (ClientEnv, ClientError, runClientM)+import Servant.Client.Internal.HttpClient (ClientM (..))+import Servant.Server (Handler (..), ServerError, respond)++-- These are needed due to overlapping instances. See: https://github.com/haskell-servant/servant/issues/1431+newtype WithStatus200 a = WithStatus200 (WithStatus 200 a)++newtype WithStatus500 a = WithStatus500 (WithStatus 500 a)++instance ToJSON a => ToJSON (WithStatus200 a) where+  toJSON (WithStatus200 (WithStatus a)) = toJSON a++instance FromJSON a => FromJSON (WithStatus200 a) where+  parseJSON o = (WithStatus200 . WithStatus) <$> parseJSON o++instance ToJSON a => ToJSON (WithStatus500 a) where+  toJSON (WithStatus500 (WithStatus a)) = toJSON a++instance FromJSON a => FromJSON (WithStatus500 a) where+  parseJSON o = (WithStatus500 . WithStatus) <$> parseJSON o++instance HasStatus (WithStatus200 a) where+  type StatusOf (WithStatus200 a) = 200++instance HasStatus (WithStatus500 a) where+  type StatusOf (WithStatus500 a) = 500++type WithError err ty = '[WithStatus200 ty, WithStatus500 err]++type GetTypedError resp ty err = UVerb 'GET resp '[WithStatus200 ty, WithStatus500 err]++type PostTypedError resp ty err = UVerb 'POST resp '[WithStatus200 ty, WithStatus500 err]++type DeleteTypedError resp ty err = UVerb 'DELETE resp '[WithStatus200 ty, WithStatus500 err]++type PutTypedError resp ty err = UVerb 'PUT resp '[WithStatus200 ty, WithStatus500 err]++newtype TypedHandler e a = TypedHandler {unTypedHandler :: ExceptT (Either ServerError e) IO a}+  deriving newtype (Functor, Applicative, Monad, MonadError (Either ServerError e))++throwTypedError :: e -> TypedHandler e a+throwTypedError = throwError . Right++throwServantError :: ServerError -> TypedHandler e a+throwServantError = throwError . Left++-- | Inside `TypedHandler` we can throw two different kinds of errors:+-- Either a ServerError, via `throwServantError` or a custom error via `throwTyped`+runTypedHandler :: TypedHandler e a -> Handler (Union '[WithStatus200 a, WithStatus500 e])+runTypedHandler (TypedHandler m) =+  Handler $+    either+      (either throwError (pure . inject . I . WithStatus500 . WithStatus))+      (pure . inject . I . WithStatus200 . WithStatus)+      =<< liftIO (runExceptT m)++-- | This function is subtly different to `runTypedHandler` in that it can be used to+-- instantiate a function `f :: MonadError e m => m a` to `Handler (Union '[WithStatus200 a, WithStatus500 e])`.+-- Any calls to `throwError` in `f` will get turned to `throwTyped` in `liftTypedError f`.+-- In case you also want to throw a `ServantError`, use `runTypedHandler` instead.+liftTypedError :: Functor m => ExceptT e m a -> m (Union '[WithStatus200 a, WithStatus500 e])+liftTypedError m =+  either (inject . I . WithStatus500 . WithStatus) (inject . I . WithStatus200 . WithStatus)+    <$> runExceptT m++newtype TypedClientM e a = TypedClientM {unTypedClientM :: ReaderT ClientEnv (ExceptT (Either ClientError e) IO) a}++class TypedClient a b where+  typedClient :: a -> b++instance (TypedClient a b, TypedClient a' b') => TypedClient (a :<|> a') (b :<|> b') where+  typedClient = bimap typedClient typedClient++instance (TypedClient a' b', TypedClient b a) => TypedClient (a -> a') (b -> b') where+  typedClient f = typedClient . f . typedClient++instance TypedClient a a where+  typedClient = id++instance TypedClient (ClientM (Union '[WithStatus200 a, WithStatus500 e])) (TypedClientM e a) where+  typedClient (ClientM (ReaderT m)) = TypedClientM $+    ReaderT $ \env ->+      ExceptT $+        runExceptT (m env)+          >>= pure . \case+            Left servantErr -> Left $ Left servantErr+            Right u ->+              case unI <$> eject u of+                Just (WithStatus500 (WithStatus err)) -> Left $ Right err+                _ -> case unI <$> eject u of+                  Just (WithStatus200 (WithStatus a)) -> Right a+                  _ -> error "Didn't match on either response"++runTypedClientM :: TypedClientM e a -> ClientEnv -> IO (Either (Either ClientError e) a)+runTypedClientM cm env = runExceptT $ flip runReaderT env $ unTypedClientM cm