union verbs (#1314)

cabal.project

@@ -25,15 +25,16 @@ packages:
   doc/cookbook/custom-errors
   doc/cookbook/basic-streaming
   doc/cookbook/db-postgres-pool
---  doc/cookbook/db-sqlite-simple
+  -- doc/cookbook/db-sqlite-simple
   doc/cookbook/file-upload
   doc/cookbook/generic
   -- doc/cookbook/hoist-server-with-context
---  doc/cookbook/https
+  -- doc/cookbook/https
   -- doc/cookbook/jwt-and-basic-auth/
   doc/cookbook/pagination
   -- doc/cookbook/sentry
   doc/cookbook/testing
+  doc/cookbook/uverb
   doc/cookbook/structuring-apis
   doc/cookbook/using-custom-monad
   doc/cookbook/using-free-client

doc/cookbook/uverb/UVerb.lhs

@@ -0,0 +1,217 @@
+# Listing alternative responses and exceptions in your API types
+
+Servant allows you to talk about the exceptions you throw in your API
+types.  This is not limited to actual exceptions, you can write
+handlers that respond with arbitrary open unions of types.
+
+## Preliminaries
+
+```haskell
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wall -Wno-orphans #-}
+
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async (async)
+import Control.Monad (when)
+import Control.Monad.Except (ExceptT (..), MonadError (..), MonadTrans (..), runExceptT)
+import Data.Aeson (FromJSON (..), ToJSON (..))
+import Data.Aeson.Encode.Pretty (encodePretty)
+import Data.String.Conversions (cs)
+import Data.Swagger (ToSchema)
+import Data.Typeable (Proxy (Proxy))
+import qualified GHC.Generics as GHC
+import qualified Network.HTTP.Client as Client
+import qualified Network.Wai.Handler.Warp as Warp
+import Servant.API
+import Servant.Client
+import Servant.Server
+import Servant.Swagger
+```
+
+## The API
+
+This looks like a `Verb`-based routing table, except that `UVerb` has
+no status, and carries a list of response types rather than a single
+one.  Each entry in the list carries its own response code.
+
+```haskell
+type API =
+         "fisx"  :> Capture "bool" Bool
+         :> UVerb 'GET '[JSON] '[FisxUser, WithStatus 303 String]
+    :<|> "arian"
+         :> UVerb 'GET '[JSON] '[WithStatus 201 ArianUser]
+```
+
+Here are the details:
+
+```haskell
+data FisxUser = FisxUser {name :: String}
+  deriving (Eq, Show, GHC.Generic)
+
+instance ToJSON FisxUser
+instance FromJSON FisxUser
+instance ToSchema FisxUser
+
+-- | 'HasStatus' allows us to can get around 'WithStatus' if we want
+-- to, and associate the status code with our resource types directly.
+--
+-- (To avoid orphan instances and make it more explicit what's in the
+-- API and what isn't, we could even introduce a newtype 'Resource'
+-- that wraps all the types we're using in our routing table, and then
+-- define lots of 'HasStatus' instances for @Resource This@ and
+-- @Resource That@.)
+instance HasStatus FisxUser where
+  type StatusOf FisxUser = 203
+
+data ArianUser = ArianUser
+  deriving (Eq, Show, GHC.Generic)
+
+instance ToJSON ArianUser
+instance FromJSON ArianUser
+instance ToSchema ArianUser
+```
+
+## Server, Client, Swagger
+
+You can just respond with any of the elements of the union in handlers.
+
+```haskell
+fisx :: Bool -> Handler (Union '[FisxUser, WithStatus 303 String])
+fisx True = respond (FisxUser "fisx")
+fisx False = respond (WithStatus @303 ("still fisx" :: String))
+
+arian :: Handler (Union '[WithStatus 201 ArianUser])
+arian = respond (WithStatus @201 ArianUser)
+```
+
+You can create client functions like you're used to:
+
+```
+fisxClient :: Bool -> ClientM (Union '[FisxUser, WithStatus 303 String])
+arianClient :: ClientM (Union '[WithStatus 201 ArianUser])
+(fisxClient :<|> arianClient) = client (Proxy @API)
+```
+
+...  and that's basically it!  Here are a few sample commands that
+show you how the swagger docs look like and how you can handle the
+result unions in clients:
+
+```
+main :: IO ()
+main = do
+  putStrLn . cs . encodePretty $ toSwagger (Proxy @API)
+  _ <- async . Warp.run 8080 $ serve (Proxy @API) (fisx :<|> arian)
+  threadDelay 50000
+  mgr <- Client.newManager Client.defaultManagerSettings
+  let cenv = mkClientEnv mgr (BaseUrl Http "localhost" 8080 "")
+  result <- runClientM (fisxClient True) cenv
+  print $ foldMapUnion (Proxy @Show) show <$> result
+  print $ matchUnion @FisxUser <$> result
+  print $ matchUnion @(WithStatus 303 String) <$> result
+  pure ()
+```
+
+## Idiomatic exceptions
+
+Since `UVerb` (probably) will mostly be used for error-like responses, it may be desirable to be able to early abort handler, like with current servant one would use `throwError` with `ServerError`.
+
+```haskell
+newtype UVerbT xs m a = UVerbT { unUVerbT :: ExceptT (Union xs) m a }
+  deriving newtype (Functor, Applicative, Monad, MonadTrans)
+
+-- | Deliberately hide 'ExceptT's 'MonadError' instance to be able to use
+-- underlying monad's instance.
+instance MonadError e m => MonadError e (UVerbT xs m) where
+  throwError = lift . throwError
+  catchError (UVerbT act) h = UVerbT $ ExceptT $
+    runExceptT act `catchError` (runExceptT . unUVerbT . h)
+
+-- | This combinator runs 'UVerbT'. It applies 'respond' internally, so the handler
+-- may use the usual 'return'.
+runUVerbT :: (Monad m, HasStatus x, IsMember x xs) => UVerbT xs m x -> m (Union xs)
+runUVerbT (UVerbT act) = either id id <$> runExceptT (act >>= respond)
+
+-- | Short-circuit 'UVerbT' computation returning one of the response types.
+throwUVerb :: (Monad m, HasStatus x, IsMember x xs) => x -> UVerbT xs m a
+throwUVerb = UVerbT . ExceptT . fmap Left . respond
+```
+
+Example usage:
+
+```haskell
+data Foo = Foo Int Int Int
+  deriving (Show, Eq, GHC.Generic, ToJSON)
+  deriving HasStatus via WithStatus 200 Foo
+
+data Bar = Bar
+  deriving (Show, Eq, GHC.Generic, ToJSON)
+
+h :: Handler (Union '[Foo, WithStatus 400 Bar])
+h = runUVerbT $ do
+  when ({- something bad -} True) $
+    throwUVerb $ WithStatus @400 Bar
+
+  when ({- really bad -} False) $
+    throwError $ err500
+
+  -- a lot of code here...
+
+  return $ Foo 1 2 3
+```
+
+## Related Work
+
+There is the [issue from
+2017](https://github.com/haskell-servant/servant/issues/841) that was
+resolved by the introduction of `UVerb`, with a long discussion on
+alternative designs.
+
+[servant-checked-exceptions](https://hackage.haskell.org/package/servant-checked-exceptions)
+is a good solution to the problem, but it restricts the user to JSON
+and a very specific envelop encoding for the union type, which is
+often not acceptable.  (One good reason for this design choice is that
+it makes writing clients easier, where you need to get to the union
+type from one representative, and you don't want to run several
+parsers in the hope that the ones that should will always error out so
+you can try until the right one returns a value.)
+
+[servant-exceptions](https://github.com/ch1bo/servant-exceptions) is
+another shot at at the problem.  It is inspired by
+servant-checked-exceptions, so it may be worth taking a closer look.
+The README claims that
+[cardano-sl](https://github.com/input-output-hk/cardano-sl) also has
+some code for generalized error handling.
+
+In an earier version of the `UVerb` implementation, we have used some
+code from
+[world-peace](https://hackage.haskell.org/package/world-peace), but
+that package itself wasn't flexible enough, and we had to use
+[sop-core](https://hackage.haskell.org/package/sop-core) to implement
+the `HasServer` instance.
+
+Here is a blog post we found on the subject:
+https://lukwagoallan.com/posts/unifying-servant-server-error-responses
+
+(If you have anything else, please add it here or let us know.)
+
+```haskell
+main :: IO ()
+main = return ()
+```

doc/cookbook/uverb/uverb.cabal

@@ -0,0 +1,33 @@
+name:                cookbook-uverb
+version:             0.0.1
+synopsis:            How to use the 'UVerb' type.
+description:         Listing alternative responses and exceptions in your API types.
+homepage:            http://docs.servant.dev/
+license:             BSD3
+license-file:        ../../../servant/LICENSE
+author:              Servant Contributors
+maintainer:          haskell-servant-maintainers@googlegroups.com
+category:            Servant
+build-type:          Simple
+cabal-version:       >=1.10
+tested-with:         GHC==8.4.4, GHC==8.6.5, GHC==8.8.2
+
+executable cookbook-uverb
+  main-is:             UVerb.lhs
+  build-depends:       base == 4.*
+                     , aeson >= 1.2
+                     , aeson-pretty >= 0.8.8
+                     , async
+                     , http-client
+                     , mtl
+                     , servant
+                     , servant-client
+                     , servant-server
+                     , servant-swagger
+                     , string-conversions
+                     , swagger2
+                     , wai
+                     , warp
+  default-language:    Haskell2010
+  ghc-options:         -Wall -pgmL markdown-unlit
+  build-tool-depends:  markdown-unlit:markdown-unlit

servant-client-core/servant-client-core.cabal

@@ -78,6 +78,7 @@ library
     , http-types            >= 0.12.2   && < 0.13
     , network-uri           >= 2.6.1.0  && < 2.7
     , safe                  >= 0.3.17   && < 0.4
+    , sop-core              >= 0.4.0.0  && < 0.6
 
   hs-source-dirs:      src
   default-language:    Haskell2010

servant-client-core/src/Servant/Client/Core.hs

@@ -18,6 +18,8 @@ module Servant.Client.Core
   -- * Client generation
     clientIn
   , HasClient(..)
+  , foldMapUnion
+  , matchUnion
 
   -- * Request
   , Request

servant-client-core/src/Servant/Client/Core/HasClient.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds       #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
@@ -7,6 +8,7 @@
 {-# LANGUAGE PolyKinds             #-}
 {-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE TypeOperators         #-}
 {-# LANGUAGE UndecidableInstances  #-}
@@ -15,31 +17,48 @@ module Servant.Client.Core.HasClient (
     clientIn,
     HasClient (..),
     EmptyClient (..),
+    foldMapUnion,
+    matchUnion,
     ) where
 
 import           Prelude ()
 import           Prelude.Compat
 
+import           Control.Arrow
+                 (left, (+++))
 import           Control.Monad
                  (unless)
 import qualified Data.ByteString.Lazy                     as BL
+import           Data.Either
+                 (partitionEithers)
 import           Data.Foldable
                  (toList)
 import           Data.List
                  (foldl')
-import           Data.Proxy
-                 (Proxy (Proxy))
 import           Data.Sequence
                  (fromList)
 import qualified Data.Text                       as T
 import           Network.HTTP.Media
                  (MediaType, matches, parseAccept, (//))
+import qualified Data.Sequence as Seq
+import           Data.SOP.BasicFunctors
+                 (I (I), (:.:) (Comp))
+import           Data.SOP.Constraint
+                 (All)
+import           Data.SOP.NP
+                 (NP (..), cpure_NP)
+import           Data.SOP.NS
+                 (NS (S))
 import           Data.String
                  (fromString)
 import           Data.Text
                  (Text, pack)
+import           Data.Proxy
+                 (Proxy (Proxy))
 import           GHC.TypeLits
                  (KnownSymbol, symbolVal)
+import           Network.HTTP.Types
+                 (Status)
 import qualified Network.HTTP.Types                       as H
 import           Servant.API
                  ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
@@ -54,9 +73,11 @@ import           Servant.API
                  contentType, getHeadersHList, getResponse, toQueryParam,
                  toUrlPiece)
 import           Servant.API.ContentTypes
-                 (contentTypes)
+                 (contentTypes, AllMime (allMime), AllMimeUnrender (allMimeUnrender))
 import           Servant.API.Modifiers
                  (FoldRequired, RequiredArgument, foldRequiredArgument)
+import           Servant.API.UVerb
+                 (HasStatus, HasStatuses (Statuses, statuses), UVerb, Union, Unique, inject, statusOf, foldMapUnion, matchUnion)
 
 import           Servant.Client.Core.Auth
 import           Servant.Client.Core.BasicAuth
@@ -288,6 +309,71 @@ instance {-# OVERLAPPING #-}
 
   hoistClientMonad _ _ f ma = f ma
 
+data ClientParseError = ClientParseError MediaType String | ClientStatusMismatch | ClientNoMatchingStatus
+  deriving (Eq, Show)
+
+instance {-# OVERLAPPING #-}
+  ( RunClient m,
+    contentTypes ~ (contentType ': otherContentTypes),
+    -- ('otherContentTypes' should be '_', but even -XPartialTypeSignatures does not seem
+    -- allow this in instance types as of 8.8.3.)
+    as ~ (a ': as'),
+    AllMime contentTypes,
+    ReflectMethod method,
+    All (AllMimeUnrender contentTypes) as,
+    All HasStatus as, HasStatuses as',
+    Unique (Statuses as)
+  ) =>
+  HasClient m (UVerb method contentTypes as)
+  where
+  type Client m (UVerb method contentTypes as) = m (Union as)
+
+  clientWithRoute _ _ request = do
+    let accept = Seq.fromList . allMime $ Proxy @contentTypes
+        -- offering to accept all mime types listed in the api gives best compatibility.  eg.,
+        -- we might not own the server implementation, and the server may choose to support
+        -- only part of the api.
+
+        method = reflectMethod $ Proxy @method
+        acceptStatus = statuses (Proxy @as)
+    response <- runRequestAcceptStatus (Just acceptStatus) request {requestMethod = method, requestAccept = accept}
+    responseContentType <- checkContentTypeHeader response
+    unless (any (matches responseContentType) accept) $ do
+      throwClientError $ UnsupportedContentType responseContentType response
+
+    let status = responseStatusCode response
+        body = responseBody response
+        res = tryParsers status $ mimeUnrenders (Proxy @contentTypes) body
+    case res of
+      Left errors -> throwClientError $ DecodeFailure (T.pack (show errors)) response
+      Right x -> return x
+    where
+      -- | Given a list of parsers of 'mkres', returns the first one that succeeds and all the
+      -- failures it encountered along the way
+      -- TODO; better name, rewrite haddocs.
+      tryParsers :: forall xs. All HasStatus xs => Status -> NP ([] :.: Either (MediaType, String)) xs -> Either [ClientParseError] (Union xs)
+      tryParsers _ Nil = Left [ClientNoMatchingStatus]
+      tryParsers status (Comp x :* xs)
+        | status == statusOf (Comp x) =
+          case partitionEithers x of
+            (err', []) -> (map (uncurry ClientParseError) err' ++) +++ S $ tryParsers status xs
+            (_, (res : _)) -> Right . inject . I $ res
+        | otherwise = -- no reason to parse in the first place. This ain't the one we're looking for
+          (ClientStatusMismatch :) +++ S $ tryParsers status xs
+
+      -- | Given a list of types, parses the given response body as each type
+      mimeUnrenders ::
+        forall cts xs.
+        All (AllMimeUnrender cts) xs =>
+        Proxy cts ->
+        BL.ByteString ->
+        NP ([] :.: Either (MediaType, String)) xs
+      mimeUnrenders ctp body = cpure_NP
+        (Proxy @(AllMimeUnrender cts))
+        (Comp . map (\(mediaType, parser) -> left ((,) mediaType) (parser body)) . allMimeUnrender $ ctp)
+
+  hoistClientMonad _ _ nt s = nt s
+
 instance {-# OVERLAPPABLE #-}
   ( RunStreamingClient m, MimeUnrender ct chunk, ReflectMethod method,
     FramingUnrender framing, FromSourceIO chunk a
@@ -710,4 +796,4 @@ decodedAs response ct = do
     Left err -> throwClientError $ DecodeFailure (T.pack err) response
     Right val -> return val
   where
-    accept = toList $ contentTypes ct 
+    accept = toList $ contentTypes ct

servant-client-core/src/Servant/Client/Core/Reexport.hs

@@ -5,6 +5,8 @@ module Servant.Client.Core.Reexport
   (
     -- * HasClient
     HasClient(..)
+  , foldMapUnion
+  , matchUnion
 
     -- * Response (for @Raw@)
   , Response

servant-client-core/src/Servant/Client/Core/RunClient.hs

@@ -7,6 +7,7 @@
 -- | Types for possible backends to run client-side `Request` queries
 module Servant.Client.Core.RunClient (
     RunClient (..),
+    runRequest,
     RunStreamingClient (..),
     ClientF (..),
     ) where
@@ -14,6 +15,8 @@ module Servant.Client.Core.RunClient (
 import           Prelude ()
 import           Prelude.Compat
 
+import           Network.HTTP.Types.Status
+                 (Status)
 import           Control.Monad.Free
                  (Free (..), liftF)
 
@@ -22,10 +25,15 @@ import           Servant.Client.Core.Request
 import           Servant.Client.Core.Response
 
 class Monad m => RunClient m where
-  -- | How to make a request.
+  -- | How to make a request, with an optional list of status codes to not throw exceptions
-  runRequest :: Request -> m Response
+  -- for (default: [200..299]).
+  runRequestAcceptStatus :: Maybe [Status] -> Request -> m Response
   throwClientError :: ClientError -> m a
 
+-- | How to make a request.
+runRequest :: RunClient m => Request -> m Response
+runRequest = runRequestAcceptStatus Nothing
+
 class RunClient m =>  RunStreamingClient m where
     withStreamingRequest :: Request -> (StreamingResponse -> IO a) ->  m a
 
@@ -41,6 +49,7 @@ data ClientF a
     | Throw ClientError
   deriving (Functor)
 
+-- TODO: honour the accept-status argument.
 instance ClientF ~ f => RunClient (Free f) where
-    runRequest req  = liftF (RunRequest req id)
+    runRequestAcceptStatus _ req  = liftF (RunRequest req id)
     throwClientError = liftF . Throw

servant-client/servant-client.cabal

@@ -108,6 +108,7 @@ test-suite spec
     , kan-extensions
     , servant-client
     , servant-client-core
+    , sop-core
     , stm
     , text
     , transformers

servant-client/src/Servant/Client/Internal/HttpClient.hs

@@ -65,7 +65,7 @@ import           GHC.Generics
 import           Network.HTTP.Media
                  (renderHeader)
 import           Network.HTTP.Types
-                 (hContentType, renderQuery, statusCode)
+                 (hContentType, renderQuery, statusCode, Status)
 import           Servant.Client.Core
 
 import qualified Network.HTTP.Client         as Client
@@ -155,14 +155,14 @@ instance Alt ClientM where
   a <!> b = a `catchError` \_ -> b
 
 instance RunClient ClientM where
-  runRequest = performRequest
+  runRequestAcceptStatus = performRequest
   throwClientError = throwError
 
 runClientM :: ClientM a -> ClientEnv -> IO (Either ClientError a)
 runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm
 
-performRequest :: Request -> ClientM Response
+performRequest :: Maybe [Status] -> Request -> ClientM Response
-performRequest req = do
+performRequest acceptStatus req = do
   ClientEnv m burl cookieJar' createClientRequest <- ask
   let clientRequest = createClientRequest burl req
   request <- case cookieJar' of
@@ -183,8 +183,11 @@ performRequest req = do
   let status = Client.responseStatus response
       status_code = statusCode status
       ourResponse = clientResponseToResponse id response
-  unless (status_code >= 200 && status_code < 300) $
+      goodStatus = case acceptStatus of
-      throwError $ mkFailureResponse burl req ourResponse
+        Nothing -> status_code >= 200 && status_code < 300
+        Just good -> status `elem` good
+  unless goodStatus $ do
+    throwError $ mkFailureResponse burl req ourResponse
   return ourResponse
   where
     requestWithoutCookieJar :: Client.Manager -> Client.Request -> ClientM (Client.Response BSL.ByteString)

servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs

@@ -47,7 +47,7 @@ import           Data.Time.Clock
                  (getCurrentTime)
 import           GHC.Generics
 import           Network.HTTP.Types
-                 (statusCode)
+                 (Status, statusCode)
 
 import qualified Network.HTTP.Client                as Client
 
@@ -112,7 +112,7 @@ instance Alt ClientM where
   a <!> b = a `catchError` \_ -> b
 
 instance RunClient ClientM where
-  runRequest = performRequest
+  runRequestAcceptStatus = performRequest
   throwClientError = throwError
 
 instance RunStreamingClient ClientM where
@@ -136,8 +136,8 @@ withClientM cm env k =
 runClientM :: NFData a => ClientM a -> ClientEnv -> IO (Either ClientError a)
 runClientM cm env = withClientM cm env (evaluate . force)
 
-performRequest :: Request -> ClientM Response
+performRequest :: Maybe [Status] -> Request -> ClientM Response
-performRequest req = do
+performRequest acceptStatus req = do
     -- TODO: should use Client.withResponse here too
   ClientEnv m burl cookieJar' createClientRequest <- ask
   let clientRequest = createClientRequest burl req
@@ -165,10 +165,14 @@ performRequest req = do
       let status = Client.responseStatus response
           status_code = statusCode status
           ourResponse = clientResponseToResponse id response
-      unless (status_code >= 200 && status_code < 300) $
+          goodStatus = case acceptStatus of
+            Nothing -> status_code >= 200 && status_code < 300
+            Just good -> status `elem` good
+      unless goodStatus $ do
         throwError $ mkFailureResponse burl req ourResponse
       return ourResponse
 
+-- | TODO: support UVerb ('acceptStatus' argument, like in 'performRequest' above).
 performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM a
 performWithStreamingRequest req k = do
   m <- asks manager

servant-client/test/Servant/ClientTestUtils.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE OverloadedStrings      #-}
 {-# LANGUAGE PolyKinds              #-}
 {-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE TypeApplications       #-}
 {-# LANGUAGE TypeFamilies           #-}
 {-# LANGUAGE TypeOperators          #-}
 {-# LANGUAGE UndecidableInstances   #-}
@@ -26,10 +27,14 @@ import           Control.Concurrent
 import           Control.Monad.Error.Class
                  (throwError)
 import           Data.Aeson
+import qualified Data.ByteString.Lazy as LazyByteString
 import           Data.Char
                  (chr, isPrint)
 import           Data.Monoid ()
 import           Data.Proxy
+import           Data.Text (Text)
+import qualified Data.Text as Text
+import           Data.Text.Encoding (encodeUtf8, decodeUtf8)
 import           GHC.Generics
                  (Generic)
 import qualified Network.HTTP.Client                  as C
@@ -47,8 +52,11 @@ import           Servant.API
                  ((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,
                  BasicAuthData (..), Capture, CaptureAll,
                  DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
-                 Headers, JSON, NoContent (NoContent), Post, QueryFlag,
+                 Headers, JSON, MimeRender(mimeRender),
-                 QueryParam, QueryParams, Raw, ReqBody, addHeader)
+                 MimeUnrender(mimeUnrender), NoContent (NoContent), PlainText,
+                 Post, QueryFlag, QueryParam, QueryParams, Raw, ReqBody,
+                 StdMethod(GET), Union, UVerb, WithStatus(WithStatus),
+                 addHeader)
 import           Servant.Client
 import qualified Servant.Client.Core.Auth    as Auth
 import           Servant.Server
@@ -63,7 +71,7 @@ _ = client comprehensiveAPIWithoutStreaming
 data Person = Person
   { _name :: String
   , _age  :: Integer
-  } deriving (Eq, Show, Generic)
+  } deriving (Eq, Show, Read, Generic)
 
 instance ToJSON Person
 instance FromJSON Person
@@ -74,6 +82,15 @@ instance FromForm Person
 instance Arbitrary Person where
   arbitrary = Person <$> arbitrary <*> arbitrary
 
+instance MimeRender PlainText Person where
+  mimeRender _ = LazyByteString.fromStrict . encodeUtf8 . Text.pack . show
+
+instance MimeUnrender PlainText Person where
+  mimeUnrender _ =
+    -- This does not handle any errors, but it should be fine for tests
+    Right . read . Text.unpack . decodeUtf8 . LazyByteString.toStrict
+
+
 alice :: Person
 alice = Person "Alice" 42
 
@@ -105,6 +122,12 @@ type Api =
   :<|> "deleteContentType" :> DeleteNoContent
   :<|> "redirectWithCookie" :> Raw
   :<|> "empty" :> EmptyAPI
+  :<|> "uverb-success-or-redirect" :>
+            Capture "bool" Bool :>
+            UVerb 'GET '[PlainText] '[WithStatus 200 Person,
+                                      WithStatus 301 Text]
+  :<|> "uverb-get-created" :> UVerb 'GET '[PlainText] '[WithStatus 201 Person]
+
 
 api :: Proxy Api
 api = Proxy
@@ -126,6 +149,10 @@ getMultiple     :: String -> Maybe Int -> Bool -> [(String, [Rational])]
 getRespHeaders  :: ClientM (Headers TestHeaders Bool)
 getDeleteContentType :: ClientM NoContent
 getRedirectWithCookie :: HTTP.Method -> ClientM Response
+uverbGetSuccessOrRedirect :: Bool
+                          -> ClientM (Union '[WithStatus 200 Person,
+                                              WithStatus 301 Text])
+uverbGetCreated :: ClientM (Union '[WithStatus 201 Person])
 
 getRoot
   :<|> getGet
@@ -143,7 +170,9 @@ getRoot
   :<|> getRespHeaders
   :<|> getDeleteContentType
   :<|> getRedirectWithCookie
-  :<|> EmptyClient = client api
+  :<|> EmptyClient
+  :<|> uverbGetSuccessOrRedirect
+  :<|> uverbGetCreated = client api
 
 server :: Application
 server = serve api (
@@ -166,7 +195,12 @@ server = serve api (
   :<|> (return $ addHeader 1729 $ addHeader "eg2" True)
   :<|> return NoContent
   :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.found302 [("Location", "testlocation"), ("Set-Cookie", "testcookie=test")] "")
-  :<|> emptyServer)
+  :<|> emptyServer
+  :<|> (\shouldRedirect -> if shouldRedirect
+                              then respond (WithStatus @301 ("redirecting" :: Text))
+                              else respond (WithStatus @200 alice ))
+  :<|> respond (WithStatus @201 carol)
+  )
 
 type FailApi =
        "get" :> Raw

servant-client/test/Servant/SuccessSpec.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE OverloadedStrings      #-}
 {-# LANGUAGE PolyKinds              #-}
 {-# LANGUAGE ScopedTypeVariables    #-}
+{-# LANGUAGE TypeApplications       #-}
 {-# LANGUAGE TypeFamilies           #-}
 {-# LANGUAGE TypeOperators          #-}
 {-# LANGUAGE UndecidableInstances   #-}
@@ -31,6 +32,8 @@ import           Data.Foldable
 import           Data.Maybe
                  (listToMaybe)
 import           Data.Monoid ()
+import           Data.Text
+                 (Text)
 import qualified Network.HTTP.Client                  as C
 import qualified Network.HTTP.Types                   as HTTP
 import           Test.Hspec
@@ -39,7 +42,7 @@ import           Test.HUnit
 import           Test.QuickCheck
 
 import           Servant.API
-                 (NoContent (NoContent), getHeaders)
+                 (NoContent (NoContent), WithStatus(WithStatus), getHeaders)
 import           Servant.Client
 import qualified Servant.Client.Core.Request as Req
 import           Servant.Client.Internal.HttpClient (defaultMakeClientRequest)
@@ -151,3 +154,23 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
             result <- left show <$> runClient (getMultiple cap num flag body) baseUrl
             return $
               result === Right (cap, num, flag, body)
+
+    context "With a route that can either return success or redirect" $ do
+      it "Redirects when appropriate" $ \(_, baseUrl) -> do
+        eitherResponse <- runClient (uverbGetSuccessOrRedirect True) baseUrl
+        case eitherResponse of
+          Left clientError -> fail $ show clientError
+          Right response -> matchUnion response `shouldBe` Just (WithStatus @301 @Text "redirecting")
+
+      it "Returns a proper response when appropriate" $ \(_, baseUrl) -> do
+        eitherResponse <- runClient (uverbGetSuccessOrRedirect False) baseUrl
+        case eitherResponse of
+          Left clientError -> fail $ show clientError
+          Right response -> matchUnion response `shouldBe` Just (WithStatus @200 alice)
+
+    context "with a route that uses uverb but only has a single response" $
+      it "returns the expected response" $ \(_, baseUrl) -> do
+        eitherResponse <- runClient (uverbGetCreated) baseUrl
+        case eitherResponse of
+          Left clientError -> fail $ show clientError
+          Right response -> matchUnion response `shouldBe` Just (WithStatus @201 carol)

servant-http-streams/src/Servant/HttpStreams/Internal.hs

@@ -141,7 +141,7 @@ instance Alt ClientM where
     a <!> b = a `catchError` \_ -> b
 
 instance RunClient ClientM where
-    runRequest = performRequest
+    runRequestAcceptStatus = performRequest
     throwClientError = throwError
 
 instance RunStreamingClient ClientM where
@@ -155,8 +155,8 @@ withClientM cm env k =
     let Codensity f = runExceptT $ flip runReaderT env $ unClientM cm
     in f k
 
-performRequest :: Request -> ClientM Response
+performRequest :: Maybe [Status] -> Request -> ClientM Response
-performRequest req = do
+performRequest acceptStatus req = do
     ClientEnv burl conn <- ask
     let (req', body) = requestToClientRequest burl req
     x <- ClientM $ lift $ lift $ Codensity $ \k -> do
@@ -165,7 +165,10 @@ performRequest req = do
             let sc = Client.getStatusCode res'
             lbs <- BSL.fromChunks <$> Streams.toList body'
             let res'' = clientResponseToResponse res' lbs
-            if sc >= 200 && sc < 300
+                goodStatus = case acceptStatus of
+                  Nothing -> sc >= 200 && sc < 300
+                  Just good -> sc `elem` (statusCode <$> good)
+            if goodStatus
             then k (Right res'')
             else k (Left (mkFailureResponse burl req res''))
 

servant-server/servant-server.cabal

@@ -51,6 +51,7 @@ library
     Servant.Server.Internal.RoutingApplication
     Servant.Server.Internal.ServerError
     Servant.Server.StaticFiles
+    Servant.Server.UVerb
 
   -- deprecated
   exposed-modules:
@@ -84,6 +85,7 @@ library
     , network-uri         >= 2.6.1.0  && < 2.8
     , monad-control       >= 1.0.2.3  && < 1.1
     , network             >= 2.8      && < 3.2
+    , sop-core            >= 0.4.0.0  && < 0.6
     , string-conversions  >= 0.4.0.1  && < 0.5
     , resourcet           >= 1.2.2    && < 1.3
     , tagged              >= 0.8.6    && < 0.9
@@ -94,6 +96,7 @@ library
 
   hs-source-dirs: src
   default-language: Haskell2010
+
   ghc-options: -Wall -Wno-redundant-constraints
 
 executable greet

servant-server/src/Servant/Server.hs

@@ -110,6 +110,7 @@ module Servant.Server
   -- * Re-exports
   , Application
   , Tagged (..)
+  , module Servant.Server.UVerb
 
   ) where
 
@@ -122,6 +123,7 @@ import           Data.Text
 import           Network.Wai
                  (Application)
 import           Servant.Server.Internal
+import           Servant.Server.UVerb
 
 
 -- * Implementing Servers

servant-server/src/Servant/Server/Internal.hs

@@ -65,7 +65,7 @@ import           Network.Socket
                  (SockAddr)
 import           Network.Wai
                  (Application, Request, httpVersion, isSecure, lazyRequestBody,
-                 queryString, remoteHost, requestBody, requestHeaders,
+                 queryString, remoteHost, getRequestBodyChunk, requestHeaders,
                  requestMethod, responseLBS, responseStream, vault)
 import           Prelude ()
 import           Prelude.Compat
@@ -681,7 +681,7 @@ instance
         bodyCheck fromRS = withRequest $ \req -> do
             let mimeUnrender'    = mimeUnrender (Proxy :: Proxy ctype) :: BL.ByteString -> Either String chunk
             let framingUnrender' = framingUnrender (Proxy :: Proxy framing) mimeUnrender' :: SourceIO B.ByteString ->  SourceIO chunk
-            let body = requestBody req
+            let body = getRequestBodyChunk req
             let rs = S.fromAction B.null body
             let rs' = fromRS $ framingUnrender' rs
             return rs'

servant-server/src/Servant/Server/UVerb.hs

@@ -0,0 +1,96 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-redundant-constraints #-}
+
+module Servant.Server.UVerb
+  ( respond,
+    IsServerResource,
+  )
+where
+
+import Data.Proxy (Proxy (Proxy))
+import Data.SOP (I (I))
+import Data.SOP.Constraint (All, And)
+import Data.String.Conversions (LBS, cs)
+import Network.HTTP.Types (Status, hContentType)
+import Network.Wai (responseLBS)
+import Servant.API (ReflectMethod, reflectMethod)
+import Servant.API.ContentTypes (AllCTRender (handleAcceptH), AllMime)
+import Servant.API.UVerb (HasStatus, IsMember, Statuses, UVerb, Union, Unique, foldMapUnion, inject, statusOf)
+import Servant.Server.Internal (Context, Delayed, Handler, HasServer (..), RouteResult (FailFatal, Route), Router, Server, ServerT, acceptCheck, addAcceptCheck, addMethodCheck, allowedMethodHead, err406, getAcceptHeader, leafRouter, methodCheck, runAction)
+
+
+-- | 'return' for 'UVerb' handlers.  Takes a value of any of the members of the open union,
+-- and will construct a union value in an 'Applicative' (eg. 'Server').
+respond ::
+  forall (x :: *) (xs :: [*]) (f :: * -> *).
+  (Applicative f, HasStatus x, IsMember x xs) =>
+  x ->
+  f (Union xs)
+respond = pure . inject . I
+
+-- | Helper constraint used in @instance 'HasServer' 'UVerb'@.
+type IsServerResource contentTypes = AllCTRender contentTypes `And` HasStatus
+
+instance
+  ( ReflectMethod method,
+    AllMime contentTypes,
+    All (IsServerResource contentTypes) as,
+    Unique (Statuses as) -- for consistency with servant-swagger (server would work fine
+        -- wihtout; client is a bit of a corner case, because it dispatches
+        -- the parser based on the status code.  with this uniqueness
+        -- constraint it won't have to run more than one parser in weird
+        -- corner cases.
+  ) =>
+  HasServer (UVerb method contentTypes as) context
+  where
+  type ServerT (UVerb method contentTypes as) m = m (Union as)
+
+  hoistServerWithContext _ _ nt s = nt s
+
+  route ::
+    forall env.
+    Proxy (UVerb method contentTypes as) ->
+    Context context ->
+    Delayed env (Server (UVerb method contentTypes as)) ->
+    Router env
+  route _proxy _ctx action = leafRouter route'
+    where
+      method = reflectMethod (Proxy @method)
+      route' env request cont = do
+        let action' :: Delayed env (Handler (Union as))
+            action' =
+              action
+                `addMethodCheck` methodCheck method request
+                `addAcceptCheck` acceptCheck (Proxy @contentTypes) (getAcceptHeader request)
+            mkProxy :: a -> Proxy a
+            mkProxy _ = Proxy
+
+        runAction action' env request cont $ \(output :: Union as) -> do
+          let encodeResource :: (AllCTRender contentTypes a, HasStatus a) => a -> (Status, Maybe (LBS, LBS))
+              encodeResource res =
+                ( statusOf $ mkProxy res,
+                  handleAcceptH (Proxy @contentTypes) (getAcceptHeader request) res
+                )
+              pickResource :: Union as -> (Status, Maybe (LBS, LBS))
+              pickResource = foldMapUnion (Proxy @(IsServerResource contentTypes)) encodeResource
+
+          case pickResource output of
+            (_, Nothing) -> FailFatal err406 -- this should not happen (checked before), so we make it fatal if it does
+            (status, Just (contentT, body)) ->
+              let bdy = if allowedMethodHead method request then "" else body
+               in Route $ responseLBS status ((hContentType, cs contentT) : []) bdy

servant-server/test/Servant/ServerSpec.hs

@@ -7,7 +7,6 @@
 {-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE TypeOperators        #-}
-{-# LANGUAGE TypeSynonymInstances #-}
 {-# OPTIONS_GHC -freduction-depth=100 #-}
 
 module Servant.ServerSpec where
@@ -49,14 +48,16 @@ import           Network.Wai.Test
 import           Servant.API
                  ((:<|>) (..), (:>), AuthProtect, BasicAuth,
                  BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,
-                 Delete, EmptyAPI, Get, Header, Headers, HttpVersion,
+                 Delete, EmptyAPI, Get, HasStatus(StatusOf), Header, Headers,
-                 IsSecure (..), JSON, Lenient, NoContent (..), NoContentVerb,
+                 HttpVersion, IsSecure (..), JSON, Lenient, NoContent (..),
-                 NoFraming, OctetStream, Patch, PlainText, Post, Put,
+                 NoContentVerb, NoFraming, OctetStream, Patch, PlainText, Post,
-                 QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody,
+                 Put, QueryFlag, QueryParam, QueryParams, Raw, RemoteHost,
-                 SourceIO, StdMethod (..), Stream, Strict, Verb, addHeader)
+                 ReqBody, SourceIO, StdMethod (..), Stream, Strict, Union,
+                 UVerb, Verb, addHeader)
 import           Servant.Server
                  (Context ((:.), EmptyContext), Handler, Server, Tagged (..),
-                 emptyServer, err401, err403, err404, serve, serveWithContext)
+                 emptyServer, err401, err403, err404, respond, serve,
+                 serveWithContext)
 import           Servant.Test.ComprehensiveAPI
 import qualified Servant.Types.SourceT             as S
 import           Test.Hspec
@@ -87,6 +88,7 @@ comprehensiveApiContext = NamedContext EmptyContext :. EmptyContext
 spec :: Spec
 spec = do
   verbSpec
+  uverbSpec
   captureSpec
   captureAllSpec
   queryParamSpec
@@ -253,8 +255,8 @@ captureSpec = do
 
     with (return (serve
         (Proxy :: Proxy (Capture "captured" String :> Raw))
-        (\ "captured" -> Tagged $ \request_ respond ->
+        (\ "captured" -> Tagged $ \request_ sendResponse ->
-            respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
+            sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
       it "strips the captured path snippet from pathInfo" $ do
         get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String]))
 
@@ -305,8 +307,8 @@ captureAllSpec = do
 
     with (return (serve
         (Proxy :: Proxy (CaptureAll "segments" String :> Raw))
-        (\ _captured -> Tagged $ \request_ respond ->
+        (\ _captured -> Tagged $ \request_ sendResponse ->
-            respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
+            sendResponse $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do
       it "consumes everything from pathInfo" $ do
         get "/captured/foo/bar/baz" `shouldRespondWith` (fromString (show ([] :: [Int])))
 
@@ -544,8 +546,8 @@ rawApi :: Proxy RawApi
 rawApi = Proxy
 
 rawApplication :: Show a => (Request -> a) -> Tagged m Application
-rawApplication f = Tagged $ \request_ respond ->
+rawApplication f = Tagged $ \request_ sendResponse ->
-    respond $ responseLBS ok200 []
+    sendResponse $ responseLBS ok200 []
         (cs $ show $ f request_)
 
 rawSpec :: Spec
@@ -706,7 +708,7 @@ basicAuthApi = Proxy
 basicAuthServer :: Server BasicAuthAPI
 basicAuthServer =
   const (return jerry) :<|>
-  (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "")
+  (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "")
 
 basicAuthContext :: Context '[ BasicAuthCheck () ]
 basicAuthContext =
@@ -751,7 +753,7 @@ genAuthApi = Proxy
 
 genAuthServer :: Server GenAuthAPI
 genAuthServer = const (return tweety)
-           :<|> (Tagged $ \ _ respond -> respond $ responseLBS imATeapot418 [] "")
+           :<|> (Tagged $ \ _ sendResponse -> sendResponse $ responseLBS imATeapot418 [] "")
 
 type instance AuthServerData (AuthProtect "auth") = ()
 
@@ -781,6 +783,73 @@ genAuthSpec = do
         it "plays nice with subsequent Raw endpoints" $ do
           get "/foo" `shouldRespondWith` 418
 
+-- }}}
+------------------------------------------------------------------------------
+-- * UVerb {{{
+------------------------------------------------------------------------------
+
+newtype PersonResponse = PersonResponse Person
+  deriving Generic
+instance ToJSON PersonResponse
+instance HasStatus PersonResponse where
+  type StatusOf PersonResponse = 200
+
+newtype RedirectResponse = RedirectResponse String
+  deriving Generic
+instance ToJSON RedirectResponse
+instance HasStatus RedirectResponse where
+  type StatusOf RedirectResponse = 301
+
+newtype AnimalResponse = AnimalResponse Animal
+  deriving Generic
+instance ToJSON AnimalResponse
+instance HasStatus AnimalResponse where
+  type StatusOf AnimalResponse = 203
+
+
+type UVerbApi
+  = "person" :> Capture "shouldRedirect" Bool :> UVerb 'GET '[JSON] '[PersonResponse, RedirectResponse]
+  :<|> "animal" :> UVerb 'GET '[JSON] '[AnimalResponse]
+
+uverbSpec :: Spec
+uverbSpec = describe "Servant.API.UVerb " $ do
+  let
+      joe = Person "joe" 42
+      mouse = Animal "Mouse" 7
+
+      personHandler
+        :: Bool
+        -> Handler (Union '[PersonResponse
+                           ,RedirectResponse])
+      personHandler True = respond $ RedirectResponse "over there!"
+      personHandler False = respond $ PersonResponse joe
+
+      animalHandler = respond $ AnimalResponse mouse
+
+      server :: Server UVerbApi
+      server = personHandler :<|> animalHandler
+
+  with (pure $ serve (Proxy :: Proxy UVerbApi) server) $ do
+    context "A route returning either 301/String or 200/Person" $ do
+      context "when requesting the person" $ do
+        let theRequest = THW.get "/person/false"
+        it "returns status 200" $
+            theRequest `shouldRespondWith` 200
+        it "returns a person" $ do
+            response <- theRequest
+            liftIO $ decode' (simpleBody response) `shouldBe` Just joe
+      context "requesting the redirect" $
+        it "returns a message and status 301" $
+          THW.get "/person/true"
+            `shouldRespondWith` "\"over there!\"" {matchStatus = 301}
+    context "a route with a single response type" $ do
+      let theRequest = THW.get "/animal"
+      it "should return the defined status code" $
+         theRequest `shouldRespondWith` 203
+      it "should return the expected response" $ do
+        response <- theRequest
+        liftIO $ decode' (simpleBody response) `shouldBe` Just mouse
+
 -- }}}
 ------------------------------------------------------------------------------
 -- * Test data types {{{

servant/servant.cabal

@@ -54,6 +54,8 @@ library
     Servant.API.Stream
     Servant.API.Sub
     Servant.API.TypeLevel
+    Servant.API.UVerb
+    Servant.API.UVerb.Union
     Servant.API.Vault
     Servant.API.Verbs
     Servant.API.WithNamedContext
@@ -78,6 +80,7 @@ library
       base                   >= 4.9      && < 4.15
     , bytestring             >= 0.10.8.1 && < 0.11
     , mtl                    >= 2.2.2    && < 2.3
+    , sop-core               >= 0.4.0.0  && < 0.6
     , transformers           >= 0.5.2.0  && < 0.6
     , text                   >= 1.2.3.0  && < 1.3
 
@@ -108,11 +111,13 @@ library
 
   hs-source-dirs: src
   default-language: Haskell2010
-  other-extensions: CPP
+  other-extensions: AllowAmbiguousTypes
+                  , CPP
                   , ConstraintKinds
                   , DataKinds
                   , DeriveDataTypeable
                   , DeriveGeneric
+                  , ExplicitNamespaces
                   , FlexibleContexts
                   , FlexibleInstances
                   , FunctionalDependencies
@@ -121,11 +126,13 @@ library
                   , MultiParamTypeClasses
                   , OverloadedStrings
                   , PolyKinds
+                  , RankNTypes
                   , ScopedTypeVariables
                   , TupleSections
                   , TypeFamilies
                   , TypeOperators
                   , UndecidableInstances
+
   ghc-options: -Wall -Wno-redundant-constraints
 
 test-suite spec

servant/src/Servant/API.hs

@@ -32,6 +32,7 @@ module Servant.API (
 
   -- * Actual endpoints, distinguished by HTTP method
   module Servant.API.Verbs,
+  module Servant.API.UVerb,
 
   -- * Streaming endpoints, distinguished by HTTP method
   module Servant.API.Stream,
@@ -132,6 +133,9 @@ import           Servant.API.Verbs
                  PutCreated, PutNoContent, PutNonAuthoritative,
                  ReflectMethod (reflectMethod), StdMethod (..),
                  Verb, NoContentVerb)
+import           Servant.API.UVerb
+                 (UVerb, Union, HasStatus, StatusOf, statusOf, Statuses,
+                 WithStatus (..), IsMember, Unique, inject)
 import           Servant.API.WithNamedContext
                  (WithNamedContext)
 import           Servant.Links

servant/src/Servant/API/ContentTypes.hs

@@ -419,7 +419,6 @@ instance MimeUnrender OctetStream BS.ByteString where
     mimeUnrender _ = Right . toStrict
 
 
-
 -- $setup
 -- >>> :set -XFlexibleInstances
 -- >>> :set -XMultiParamTypeClasses

servant/src/Servant/API/UVerb.hs

@@ -0,0 +1,97 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | An alternative to 'Verb' for end-points that respond with a resource value of any of an
+-- open union of types, and specific status codes for each type in this union.  (`UVerb` is
+-- short for `UnionVerb`)
+--
+-- This can be used for returning (rather than throwing) exceptions in a server as in, say
+-- @'[Report, WaiError]@; or responding with either a 303 forward with a location header, or
+-- 201 created with a different body type, depending on the circumstances.  (All of this can
+-- be done with vanilla servant-server by throwing exceptions, but it can't be represented in
+-- the API types without something like `UVerb`.)
+--
+-- See <https://docs.servant.dev/en/stable/cookbook/uverb/UVerb.html> for a working example.
+module Servant.API.UVerb
+  ( UVerb,
+    HasStatus (StatusOf),
+    statusOf,
+    HasStatuses (Statuses, statuses),
+    WithStatus (..),
+    module Servant.API.UVerb.Union,
+  )
+where
+
+import Data.Aeson (FromJSON, ToJSON)
+import Data.Proxy (Proxy (Proxy))
+import qualified GHC.Generics as GHC
+import GHC.TypeLits (Nat)
+import Network.HTTP.Types (Status, StdMethod)
+import Servant.API.ContentTypes (MimeRender (mimeRender), MimeUnrender (mimeUnrender), NoContent)
+import Servant.API.Status (KnownStatus, statusVal)
+import Servant.API.UVerb.Union
+
+class KnownStatus (StatusOf a) => HasStatus (a :: *) where
+  type StatusOf (a :: *) :: Nat
+
+statusOf :: forall a proxy. HasStatus a => proxy a -> Status
+statusOf = const (statusVal (Proxy :: Proxy (StatusOf a)))
+
+instance KnownStatus n => HasStatus (WithStatus n a) where
+  type StatusOf (WithStatus n a) = n
+
+-- | If an API can respond with 'NoContent' we assume that this will happen
+-- with the status code 204 No Content. If this needs to be overridden,
+-- 'WithStatus' can be used.
+instance HasStatus NoContent where
+  type StatusOf NoContent = 204
+
+class HasStatuses (as :: [*]) where
+  type Statuses (as :: [*]) :: [Nat]
+  statuses :: Proxy as -> [Status]
+
+instance HasStatuses '[] where
+  type Statuses '[] = '[]
+  statuses _ = []
+
+instance (HasStatus a, HasStatuses as) => HasStatuses (a ': as) where
+  type Statuses (a ': as) = StatusOf a ': Statuses as
+  statuses _ = statusOf (Proxy :: Proxy a) : statuses (Proxy :: Proxy as)
+
+newtype WithStatus (k :: Nat) a = WithStatus a
+  deriving (Eq, Show, GHC.Generic)
+
+instance (GHC.Generic (WithStatus n a), ToJSON a) => ToJSON (WithStatus n a)
+
+instance (GHC.Generic (WithStatus n a), FromJSON a) => FromJSON (WithStatus n a)
+
+instance MimeRender ctype a => MimeRender ctype (WithStatus _status a) where
+  mimeRender contentTypeProxy (WithStatus a) = mimeRender contentTypeProxy a
+
+instance MimeUnrender ctype a => MimeUnrender ctype (WithStatus _status a) where
+  mimeUnrender contentTypeProxy input =
+    WithStatus <$> mimeUnrender contentTypeProxy input
+
+-- | A variant of 'Verb' that can have any of a number of response values and status codes.
+--
+-- FUTUREWORK: it would be nice to make 'Verb' a special case of 'UVerb', and only write
+-- instances for 'HasServer' etc. for the latter, getting them for the former for free.
+-- Something like:
+--
+-- @type Verb method statusCode contentTypes a = UVerb method contentTypes [WithStatus statusCode a]@
+--
+-- Backwards compatibility is tricky, though: this type alias would mean people would have to
+-- use 'respond' instead of 'pure' or 'return', so all old handlers would have to be rewritten.
+data UVerb (method :: StdMethod) (contentTypes :: [*]) (as :: [*])

servant/src/Servant/API/UVerb/Union.hs

@@ -0,0 +1,147 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-
+
+Copyright Dennis Gosnell (c) 2017-2018
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Author name here nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+-}
+
+-- | Type-level code for implementing and using 'UVerb'.  Heavily inspired by
+-- [world-piece](https://github.com/cdepillabout/world-peace).
+module Servant.API.UVerb.Union
+( IsMember
+, Unique
+, Union
+, inject
+, eject
+, foldMapUnion
+, matchUnion
+)
+where
+
+import Data.Proxy (Proxy)
+import Data.SOP.BasicFunctors (I, unI)
+import Data.SOP.Constraint
+import Data.SOP.NS
+import Data.Type.Bool (If)
+import Data.Type.Equality (type (==))
+import GHC.TypeLits
+
+type Union = NS I
+
+-- | Convenience function to apply a function to an unknown union element using a type class.
+-- All elements of the union must have instances in the type class, and the function is
+-- applied unconditionally.
+--
+-- See also: 'matchUnion'.
+foldMapUnion ::
+  forall (c :: * -> Constraint) (a :: *) (as :: [*]).
+  All c as =>
+  Proxy c ->
+  (forall x. c x => x -> a) ->
+  Union as ->
+  a
+foldMapUnion proxy go = cfoldMap_NS proxy (go . unI)
+
+-- | Convenience function to extract a union element using 'cast', ie. return the value if the
+-- selected type happens to be the actual type of the union in this value, or 'Nothing'
+-- otherwise.
+--
+-- See also: 'foldMapUnion'.
+matchUnion :: forall (a :: *) (as :: [*]). (IsMember a as) => Union as -> Maybe a
+matchUnion = fmap unI . eject
+
+-- * Stuff stolen from 'Data.WorldPeace" but for generics-sop
+
+-- (this could to go sop-core, except it's probably too specialized to the servant use-case.)
+
+type IsMember (a :: u) (as :: [u]) = (Unique as, CheckElemIsMember a as, UElem a as)
+
+class UElem x xs where
+  inject :: f x -> NS f xs
+  eject :: NS f xs -> Maybe (f x)
+
+instance {-# OVERLAPPING #-} UElem x (x ': xs) where
+  inject = Z
+  eject (Z x) = Just x
+  eject _ = Nothing
+
+instance {-# OVERLAPPING #-} UElem x xs => UElem x (x' ': xs) where
+  inject = S . inject
+  eject (Z _) = Nothing
+  eject (S ns) = eject ns
+
+-- | Check whether @a@ is in list.  This will throw nice errors if the element is not in the
+-- list, or if there is a duplicate in the list.
+type family CheckElemIsMember (a :: k) (as :: [k]) :: Constraint where
+    CheckElemIsMember a as =
+      If (Elem a as) (() :: Constraint) (TypeError (NoElementError a as))
+
+type NoElementError (r :: k) (rs :: [k]) =
+          'Text "Expected one of:"
+    ':$$: 'Text "    " ':<>: 'ShowType rs
+    ':$$: 'Text "But got:"
+    ':$$: 'Text "    " ':<>: 'ShowType r
+
+type DuplicateElementError (rs :: [k]) =
+          'Text "Duplicate element in list:"
+    ':$$: 'Text "    " ':<>: 'ShowType rs
+
+type family Elem (x :: k) (xs :: [k]) :: Bool where
+  Elem _ '[] = 'False
+  Elem x (x' ': xs) =
+    If (x == x') 'True (Elem x xs)
+
+type family Unique xs :: Constraint where
+  Unique xs = If (Nubbed xs == 'True) (() :: Constraint) (TypeError (DuplicateElementError xs))
+
+type family Nubbed xs :: Bool where
+  Nubbed '[] = 'True
+  Nubbed (x ': xs) = If (Elem x xs) 'False (Nubbed xs)
+
+_testNubbed :: ( ( Nubbed '[Bool, Int, Int] ~ 'False
+                 , Nubbed '[Int, Int, Bool] ~ 'False
+                 , Nubbed '[Int, Bool] ~ 'True
+                 )
+               => a) -> a
+_testNubbed = id