Polymorphic envelope

servant-checked-exceptions-core/servant-checked-exceptions-core.cabal

@@ -26,6 +26,7 @@ library
                      , Servant.Checked.Exceptions.Internal
                      , Servant.Checked.Exceptions.Internal.Envelope
                      , Servant.Checked.Exceptions.Internal.EnvelopeT
+                     , Servant.Checked.Exceptions.Internal.FlatEnvelope
                      , Servant.Checked.Exceptions.Internal.Prism
                      , Servant.Checked.Exceptions.Internal.Servant
                      , Servant.Checked.Exceptions.Internal.Servant.API

servant-checked-exceptions-core/src/Servant/Checked/Exceptions.hs

@@ -101,13 +101,16 @@ module Servant.Checked.Exceptions
   -- * Servant Types
   -- ** 'Throws' API parameter
     Throws
+  , Throws'
   -- ** 'NoThrow' API parameter
   , NoThrow
+  , NoThrow'
   -- ** HTTP Error Status Code
   , ErrStatus(toErrStatus)
   , Status
   -- ** Verbs
   , VerbWithErr
+  , VerbWithErr'
   -- *** Specialized Verbs
   -- **** HTTP 200
   , GetWithErr
@@ -145,6 +148,7 @@ module Servant.Checked.Exceptions
   , GetPartialContentWithErr
   -- * 'Envelope' response wrapper
   , Envelope(..)
+  , FlatEnvelope(..)
   -- ** 'Envelope' helper functions
   -- *** 'Envelope' constructors
   , toSuccEnvelope

servant-checked-exceptions-core/src/Servant/Checked/Exceptions/Internal.hs

@@ -1,13 +1,15 @@
 module Servant.Checked.Exceptions.Internal
   ( module Servant.Checked.Exceptions.Internal.Envelope
   , module Servant.Checked.Exceptions.Internal.EnvelopeT
+  , module Servant.Checked.Exceptions.Internal.FlatEnvelope
   , module Servant.Checked.Exceptions.Internal.Verbs
   , module Servant.Checked.Exceptions.Internal.Servant
   , module Servant.Checked.Exceptions.Internal.Util
   ) where
 
 import Servant.Checked.Exceptions.Internal.Envelope
 import Servant.Checked.Exceptions.Internal.EnvelopeT
+import Servant.Checked.Exceptions.Internal.FlatEnvelope
 import Servant.Checked.Exceptions.Internal.Verbs
 import Servant.Checked.Exceptions.Internal.Servant
 import Servant.Checked.Exceptions.Internal.Util

servant-checked-exceptions-core/src/Servant/Checked/Exceptions/Internal/FlatEnvelope.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{- |
+Module      :  Servant.Checked.Exceptions.Internal.Servant.API
+
+This module defines the 'FlatEnvelope' type.
+-}
+
+module Servant.Checked.Exceptions.Internal.FlatEnvelope
+  ( FlatEnvelope(..))
+  where
+
+import Control.Applicative ((<|>))
+import Data.Aeson (ToJSON(..), FromJSON(..))
+import Data.WorldPeace (OpenUnion)
+
+import Servant.Checked.Exceptions.Internal.Servant.API (EnvelopeStatus(..), AllErrStatus, MkEnvelope(..))
+import Servant.Checked.Exceptions.Internal.Envelope (Envelope(..), envelope, toErrEnvelope, toSuccEnvelope)
+
+-- | Wrapper around @Envelope@ that has a flat JSON representation.
+-- While with @Envelope@ the data and errors are contained in "err" and "data"
+-- fields, with @FlatEnvelope@ they are both contained in the root dictionary.
+data FlatEnvelope (es :: [*]) (succ :: *) =
+  FlatEnvelope
+    { unFlatEnvelope :: Envelope es succ
+    }
+
+instance (Show (OpenUnion es), Show a) => Show (FlatEnvelope es a) where
+  show = envelope show show . unFlatEnvelope
+
+-- | Both the error and success values are in the top level of the json.
+instance (ToJSON (OpenUnion es), ToJSON a) => ToJSON (FlatEnvelope es a) where
+  toJSON = envelope toJSON toJSON . unFlatEnvelope
+
+-- | Both the error and success values are in the top level of the json.
+-- Success values are tried first, then errors.
+instance (FromJSON (OpenUnion es), FromJSON a) => FromJSON (FlatEnvelope es a) where
+  parseJSON v = FlatEnvelope <$>
+    (  SuccEnvelope <$> parseJSON v
+   <|> ErrEnvelope  <$> parseJSON v
+    )
+
+instance AllErrStatus es => EnvelopeStatus es FlatEnvelope where
+  getEnvelopeStatus (FlatEnvelope envel) = getEnvelopeStatus envel
+
+instance MkEnvelope FlatEnvelope where
+  mkSuccEnvelope = FlatEnvelope . toSuccEnvelope
+  mkErrEnvelope = FlatEnvelope . toErrEnvelope

servant-checked-exceptions-core/src/Servant/Checked/Exceptions/Internal/Servant/API.hs

@@ -1,9 +1,12 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 {- |
 Module      :  Servant.Checked.Exceptions.Internal.Servant.API
@@ -15,16 +18,20 @@ Maintainer  :  Dennis Gosnell ([email protected])
 Stability   :  experimental
 Portability :  unknown
 
-This module defines the 'Throws' and 'Throwing' types.
+This module defines the 'Throws' and 'Throwing' types, and their
+envelope-polymorphic variants 'Throws\'' and 'Throwing\''
 -}
 
 module Servant.Checked.Exceptions.Internal.Servant.API where
 
 import GHC.Exts (Constraint)
 import Network.HTTP.Types (Status)
 import Servant.API ((:>))
+import Data.Functor.Identity (Identity (Identity))
+import Data.WorldPeace (OpenUnion, Union (That, This))
 
 import Servant.Checked.Exceptions.Internal.Util (Snoc)
+import Servant.Checked.Exceptions.Internal.Envelope (Envelope, envelope, toSuccEnvelope, toErrEnvelope)
 
 -- | 'Throws' is used in Servant API definitions and signifies that an API will
 -- throw the given error.
@@ -34,7 +41,13 @@ import Servant.Checked.Exceptions.Internal.Util (Snoc)
 --
 -- >>> import Servant.API (Get, JSON, (:>))
 -- >>> type API = Throws String :> Get '[JSON] Int
-data Throws (e :: *)
+--
+-- @Throws@ is a specialized case for @Throws'@, that accepts an additional
+-- envelope parameter @envel@. For @Throws@ this is @Envelope@.
+-- All combinators with a prime are polymorphic in the envelope.
+-- For an example of a custom envelope, take a look at 'Servant.Checked.Exceptions.Internal.FlatEnvelope'
+type Throws (e :: *) = Throws' Envelope e
+data Throws' (env :: [*] -> * -> *) (e :: *)
 
 -- | 'NoThrow' is used to indicate that an API will not throw an error, but
 -- that it will still return a response wrapped in a
@@ -53,19 +66,22 @@ data Throws (e :: *)
 --   apiHandler :: 'Servant.Handler' ('Servant.Checked.Exceptions.Internal.Envelope.Envelope' \'[] Int)
 --   apiHandler = 'Servant.Checked.Exceptions.Internal.Envelope.pureSuccEnvelope' 3
 -- @
-data NoThrow
+data NoThrow' (env :: [*] -> * -> *)
+type NoThrow = NoThrow' Envelope
 
 -- | This is used internally and should not be used by end-users.
-data Throwing (e :: [*])
+data Throwing' (env :: [*] -> * -> *) (e :: [*])
+type Throwing (e :: [*]) = Throwing' Envelope e
+
 
 -- | Used by the 'HasServer' and 'HasClient' instances for
 -- @'Throwing' es ':>' api ':>' apis@ to detect @'Throwing' es@ followed
 -- immediately by @'Throws' e@.
 type family ThrowingNonterminal api where
-  ThrowingNonterminal (Throwing es :> Throws e :> api) =
-    Throwing (Snoc es e) :> api
-  ThrowingNonterminal (Throwing es :> c :> api) =
-    c :> Throwing es :> api
+  ThrowingNonterminal (Throwing' env es :> Throws' env e :> api) =
+    Throwing' env (Snoc es e) :> api
+  ThrowingNonterminal (Throwing' env es :> c :> api) =
+    c :> Throwing' env es :> api
 
 
 -- | Note that clients generated by @servant-client@ currently don't handle
@@ -78,6 +94,27 @@ type family AllErrStatus (es :: [k]) :: Constraint where
   AllErrStatus '[] = ()
   AllErrStatus (a ': as) = (ErrStatus a, AllErrStatus as)
 
+-- | Get the HTTP status from an @envelope@.
+class EnvelopeStatus es (envel :: [*] -> * -> *) where
+  getEnvelopeStatus :: envel es a -> Status -> Status
+
+instance AllErrStatus es => EnvelopeStatus es Envelope where
+  getEnvelopeStatus envel successStatus = envelope getErrStatus (const successStatus) envel
+
+-- | Get the HTTP status from an @OpenUnion es@, used by @Envelope@.
+getErrStatus :: AllErrStatus es => OpenUnion es -> Status
+getErrStatus (This (Identity e)) = toErrStatus e
+getErrStatus (That es)           = getErrStatus es
+
+-- | Create an envelope from success or error values.
+class MkEnvelope (envel :: [*] -> * -> *) where
+  mkSuccEnvelope :: a -> envel es a
+  mkErrEnvelope :: e -> envel '[e] a
+
+instance MkEnvelope Envelope where
+  mkSuccEnvelope = toSuccEnvelope
+  mkErrEnvelope = toErrEnvelope
+
 -- $setup
 -- >>> :set -XDataKinds
 -- >>> :set -XTypeOperators

servant-checked-exceptions-core/src/Servant/Checked/Exceptions/Internal/Servant/Docs.hs

@@ -41,123 +41,125 @@ import Servant.Docs
         ToSample(toSamples))
 import Servant.Docs.Internal (apiEndpoints, respBody, response)
 
-import Servant.Checked.Exceptions.Internal.Envelope
-       (Envelope, toErrEnvelope, toSuccEnvelope)
 import Servant.Checked.Exceptions.Internal.Prism ((<>~))
 import Servant.Checked.Exceptions.Internal.Servant.API
-       (NoThrow, Throws, Throwing)
+       (NoThrow', Throws', Throwing', MkEnvelope(..))
 import Servant.Checked.Exceptions.Internal.Util (Snoc)
 
 -- TODO: Make sure to also account for when headers are being used.
 
 -- | Change a 'Throws' into 'Throwing'.
-instance (HasDocs (Throwing '[e] :> api)) => HasDocs (Throws e :> api) where
+instance (HasDocs (Throwing' envel '[e] :> api)) => HasDocs (Throws' envel e :> api) where
   docsFor
-    :: Proxy (Throws e :> api)
+    :: Proxy (Throws' envel e :> api)
     -> (Endpoint, Action)
     -> DocOptions
     -> API
-  docsFor Proxy = docsFor (Proxy :: Proxy (Throwing '[e] :> api))
+  docsFor Proxy = docsFor (Proxy :: Proxy (Throwing' envel '[e] :> api))
 
 -- | When @'Throwing' es@ comes before a 'Verb', generate the documentation for
 -- the same 'Verb', but returning an @'Envelope' es@.  Also add documentation
 -- for the potential @es@.
 instance
-       ( CreateRespBodiesFor es ctypes
-       , HasDocs (Verb method status ctypes (Envelope es a))
+       ( CreateRespBodiesFor envel es ctypes
+       , HasDocs (Verb method status ctypes (envel es a))
        )
-    => HasDocs (Throwing es :> Verb method status ctypes a) where
+    => HasDocs (Throwing' envel es :> Verb method status ctypes a) where
   docsFor
-    :: Proxy (Throwing es :> Verb method status ctypes a)
+    :: Proxy (Throwing' envel es :> Verb method status ctypes a)
     -> (Endpoint, Action)
     -> DocOptions
     -> API
   docsFor Proxy (endpoint, action) docOpts =
     let api =
           docsFor
-            (Proxy :: Proxy (Verb method status ctypes (Envelope es a)))
+            (Proxy :: Proxy (Verb method status ctypes (envel es a)))
             (endpoint, action)
             docOpts
     in api & apiEndpoints . traverse . response . respBody <>~
-        createRespBodiesFor (Proxy :: Proxy es) (Proxy :: Proxy ctypes)
+        createRespBodiesFor (Proxy :: Proxy envel) (Proxy :: Proxy es) (Proxy :: Proxy ctypes)
 
 -- | When 'NoThrow' comes before a 'Verb', generate the documentation for
 -- the same 'Verb', but returning an @'Envelope' \'[]@.
-instance (HasDocs (Verb method status ctypes (Envelope '[] a)))
-    => HasDocs (NoThrow :> Verb method status ctypes a) where
+instance (HasDocs (Verb method status ctypes (envel '[] a)))
+    => HasDocs (NoThrow' envel :> Verb method status ctypes a) where
   docsFor
-    :: Proxy (NoThrow :> Verb method status ctypes a)
+    :: Proxy (NoThrow' envel :> Verb method status ctypes a)
     -> (Endpoint, Action)
     -> DocOptions
     -> API
   docsFor Proxy (endpoint, action) docOpts =
     docsFor
-      (Proxy :: Proxy (Verb method status ctypes (Envelope '[] a)))
+      (Proxy :: Proxy (Verb method status ctypes (envel '[] a)))
       (endpoint, action)
       docOpts
 
--- | Create samples for a given @list@ of types, under given @ctypes@.
+-- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the
+-- @e@ onto the @es@.
+instance (HasDocs (Throwing' envel (Snoc es e) :> api)) =>
+    HasDocs (Throwing' envel es :> Throws' envel e :> api) where
+  docsFor
+    :: Proxy (Throwing' envel es :> Throws' envel e :> api)
+    -> (Endpoint, Action)
+    -> DocOptions
+    -> API
+  docsFor Proxy =
+    docsFor (Proxy :: Proxy (Throwing' envel (Snoc es e) :> api))
+
+-- | Create samples for an envelope with a @list@ of types, under given @ctypes@.
 --
--- Additional instances of this class should not need to be created.
-class CreateRespBodiesFor list ctypes where
+-- Instances of this class are only necessary when using a custom @envel@.
+class CreateRespBodiesFor (envel :: [*] -> * -> *) list ctypes where
   createRespBodiesFor
-    :: Proxy list
+    :: Proxy envel
+    -> Proxy list
     -> Proxy ctypes
     -> [(Text, MediaType, ByteString)]
 
 -- | An empty list of types has no samples.
-instance CreateRespBodiesFor '[] ctypes where
+instance CreateRespBodiesFor (envel :: [*] -> * -> *) '[] ctypes where
   createRespBodiesFor
-    :: Proxy '[]
+    :: Proxy envel
+    -> Proxy '[]
     -> Proxy ctypes
     -> [(Text, MediaType, ByteString)]
-  createRespBodiesFor Proxy Proxy = []
+  createRespBodiesFor Proxy Proxy Proxy = []
 
 -- | Create a response body for each of the error types.
 instance
-       ( AllMimeRender ctypes (Envelope '[e] ())
-       , CreateRespBodiesFor es ctypes
+       ( AllMimeRender ctypes (envel '[e] ())
+       , CreateRespBodiesFor envel es ctypes
        , ToSample e
+       , MkEnvelope envel
        )
-    => CreateRespBodiesFor (e ': es) ctypes where
+    => CreateRespBodiesFor (envel :: [*] -> * -> *) (e ': es) ctypes where
   createRespBodiesFor
-    :: Proxy (e ': es)
+    :: Proxy envel
+    -> Proxy (e ': es)
     -> Proxy ctypes
     -> [(Text, MediaType, ByteString)]
-  createRespBodiesFor Proxy ctypes =
-    createRespBodyFor (Proxy :: Proxy e) ctypes <>
-    createRespBodiesFor (Proxy :: Proxy es) ctypes
+  createRespBodiesFor Proxy Proxy ctypes =
+    createRespBodyFor (Proxy :: Proxy envel) (Proxy :: Proxy e) ctypes <>
+    createRespBodiesFor (Proxy :: Proxy envel) (Proxy :: Proxy es) ctypes
 
 -- | Create a sample for a given @e@ under given @ctypes@.
 createRespBodyFor
-  :: forall e ctypes.
-     (AllMimeRender ctypes (Envelope '[e] ()), ToSample e)
-  => Proxy e -> Proxy ctypes -> [(Text, MediaType, ByteString)]
-createRespBodyFor Proxy ctypes = concatMap enc samples
+  :: forall (envel :: [*] -> * -> *) e ctypes.
+     (AllMimeRender ctypes (envel '[e] ()), ToSample e, MkEnvelope envel)
+  => Proxy envel -> Proxy e -> Proxy ctypes -> [(Text, MediaType, ByteString)]
+createRespBodyFor Proxy Proxy ctypes = concatMap enc samples
     where
-      samples :: [(Text, Envelope '[e] ())]
-      samples = fmap toErrEnvelope <$> toSamples (Proxy :: Proxy e)
+      samples :: [(Text, envel '[e] ())]
+      samples = fmap mkErrEnvelope <$> toSamples (Proxy :: Proxy e)
 
-      enc :: (Text, Envelope '[e] ()) -> [(Text, MediaType, ByteString)]
+      enc :: (Text, envel '[e] ()) -> [(Text, MediaType, ByteString)]
       enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s
 
--- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the
--- @e@ onto the @es@.
-instance (HasDocs (Throwing (Snoc es e) :> api)) =>
-    HasDocs (Throwing es :> Throws e :> api) where
-  docsFor
-    :: Proxy (Throwing es :> Throws e :> api)
-    -> (Endpoint, Action)
-    -> DocOptions
-    -> API
-  docsFor Proxy =
-    docsFor (Proxy :: Proxy (Throwing (Snoc es e) :> api))
-
 -- | We can generate a sample of an @'Envelope' es a@ as long as there is a way
 -- to generate a sample of the @a@.
 --
 -- This doesn't need to worry about generating a sample of @es@, because that is
 -- taken care of in the 'HasDocs' instance for @'Throwing' es@.
-instance ToSample a => ToSample (Envelope es a) where
-  toSamples :: Proxy (Envelope es a) -> [(Text, Envelope es a)]
-  toSamples Proxy = fmap toSuccEnvelope <$> toSamples (Proxy :: Proxy a)
+instance (ToSample a, MkEnvelope envel) => ToSample ((envel :: [*] -> * -> *) es a) where
+  toSamples :: Proxy (envel es a) -> [(Text, envel es a)]
+  toSamples Proxy = fmap mkSuccEnvelope <$> toSamples (Proxy :: Proxy a)