servant-checked-exceptions-core (empty) → 2.0.0.0

raw patch · 18 files changed

+1765/−0 lines, 18 filesdep +Globdep +aesondep +base

Dependencies added: Glob, aeson, base, bytestring, deepseq, doctest, http-api-data, http-media, http-types, profunctors, servant, servant-checked-exceptions-core, servant-docs, tagged, text, world-peace

Files

CHANGELOG.md +11/−0
LICENSE +30/−0
README.md +222/−0
example/Api.hs +141/−0
example/Docs.hs +63/−0
servant-checked-exceptions-core.cabal +84/−0
src/Servant/Checked/Exceptions.hs +177/−0
src/Servant/Checked/Exceptions/Envelope.hs +31/−0
src/Servant/Checked/Exceptions/Internal.hs +11/−0
src/Servant/Checked/Exceptions/Internal/Envelope.hs +466/−0
src/Servant/Checked/Exceptions/Internal/Prism.hs +75/−0
src/Servant/Checked/Exceptions/Internal/Servant.hs +19/−0
src/Servant/Checked/Exceptions/Internal/Servant/API.hs +80/−0
src/Servant/Checked/Exceptions/Internal/Servant/Docs.hs +163/−0
src/Servant/Checked/Exceptions/Internal/Util.hs +40/−0
src/Servant/Checked/Exceptions/Internal/Verbs.hs +69/−0
src/Servant/Checked/Exceptions/Verbs.hs +43/−0
test/DocTest.hs +40/−0

+ CHANGELOG.md view

@@ -0,0 +1,11 @@+## 2.0.0.0++*    Initial release of `servant-checked-exceptions-core` package, with+     core types factored out of `servant-checked-exceptions` for users+     who want access to them without incurring a dependency on `servant-server`+     and `servant-client`. See+    [issue 25](https://github.com/cdepillabout/servant-checked-exceptions/issues/25)++*    Compared to `servant-checked-exceptions`, `servant-checked-exceptions-core`+     breaks up the `Exceptions` module into `Verbs` and `Envelope`.+    [issue 18](https://github.com/cdepillabout/servant-checked-exceptions/issues/18)

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright Dennis Gosnell (c) 2017++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.

+ README.md view

@@ -0,0 +1,222 @@++Servant.Checked.Exceptions+==========================++[![Build Status](https://secure.travis-ci.org/cdepillabout/servant-checked-exceptions.svg)](http://travis-ci.org/cdepillabout/servant-checked-exceptions)+[![Hackage](https://img.shields.io/hackage/v/servant-checked-exceptions.svg)](https://hackage.haskell.org/package/servant-checked-exceptions)+[![Stackage LTS](http://stackage.org/package/servant-checked-exceptions/badge/lts)](http://stackage.org/lts/package/servant-checked-exceptions)+[![Stackage Nightly](http://stackage.org/package/servant-checked-exceptions/badge/nightly)](http://stackage.org/nightly/package/servant-checked-exceptions)+![BSD3 license](https://img.shields.io/badge/license-BSD3-blue.svg)++`servant-checked-exceptions` provides a way to specify errors thrown by a+Servant api on the type level.  It allows easy composition between different+error types.++`servant-checked-exceptions` provides the+[`Throws`](https://hackage.haskell.org/package/servant-checked-exceptions/docs/Servant-Checked-Exceptions.html#t:Throws)+data type to signify which errors can be thrown by an api.  For instance,+imagine a `getAuthor` api that returns an `Author` based on an `AuthorId`:++```haskell+-- This is a servant-compatible type describing our api.+type Api =+  "author" :>+  Capture "author-id" AuthorId :>+  Throws DatabaseError :>+  Throws AuthorNotFoundError :>+  Get '[JSON] Author++-- These are the two errors that can be thrown:+data DatabaseError = DatabaseError+data AuthorNotFoundError = AuthorNotFoundError+```++The corresponding handler function uses the+[`Envelope`](https://hackage.haskell.org/package/servant-checked-exceptions/docs/Servant-Checked-Exceptions.html#t:Envelope)+data type to model the possibility of returning an `Author` successfully, or+either `DatabaseError` or `AuthorNotFoundError` unsuccessfully.+Internally, `Envelope` is using an open sum-type to easily represent multiple+different errors:++```haskell+getAuthorHandler+  :: AuthorId+  -> Handler (Envelope '[DatabaseError, AuthorNotFoundError] Author)+getAuthorHandler authorId = ...+```++For more documentation and usage examples, see the+[documentation](https://hackage.haskell.org/package/servant-checked-exceptions) on Hackage.++## Why would I want to use this?++Using `Envelope` with its open sum-type to represent errors gives us an easy+way to reuse errors on multiple routes.++For instance, imagine that we had another api for updating an author's name,+given the author's ID.  Using `Throws` and `Envelope`, it might look like this:++```haskell+type Api =+  "update-author-name" :>+  Capture "author-id" AuthorId :>+  Capture "author-name" AuthorName :>+  Throws DatabaseError :>+  Throws AuthorNotFoundError :>+  Throws AuthorNameTooShort :>+  Post '[JSON] Author++data AuthorNameTooShort = AuthorNameTooShort++postChangeAuthorName+  :: AuthorId+  -> AuthorName+  -> Handler (Envelope '[DatabaseError, AuthorNotFoundError, AuthorNameTooShort] Author)+postChangeAuthorName authorId newAuthorName = ...+```++We are able to reuse the `DatabaseError` and `AuthorNotFoundError`.  If we try+to return an error that is not declared using `Throws`, GHC will give us an+error.  We get flexiblity and type-safety.++When using [servant-docs](https://hackage.haskell.org/package/servant-docs) to+create documentation, only one instance of `ToSample` needs to be created for+each error (`DatabaseError`, `AuthorNotFoundError`, and `AuthorNameTooShort`).+Multiple instances of `ToSample` do not need to be created for _every_+different `Envelope` used in a handler.++## Example++This repository contains an [example](example/) of using+`servant-checked-exceptions`.  This includes an [api](example/Api.hs),+[server](example/Server.hs), [client](example/Client.hs), and+[documentation](example/Docs.hs).++Below I show how to compile and run these examples.++### Compile++The examples can be compiled by using the `buildexample` flag:++```sh+$ stack build --flag servant-checked-exceptions:buildexample+```++This creates three executables.  A server, a client, and a documentaiton+generator.++### Run the server++The server is a small example that will take search queries and return results.+The server can be run with the following command:++```sh+$ stack exec -- servant-checked-exceptions-example-server+```++This runs the server on port 8201.  Here is an example of using `curl` to+access the server.  This will send the query `hello`:++```sh+$ curl \+    --request POST \+    --header 'Accept: application/json' \+    'http://localhost:8201/lax-search/hello'+{"data":"good"}+```++If you try to send a query that is not `hello`, the server will return an error:++```sh+$ curl \+    --request POST \+    --header 'Accept: application/json' \+    'http://localhost:8201/lax-search/goodbye'+{"err":"BadSearchTermErr"}+```++There is also a strict api, that requires `hello` to be capitalized like `Hello`:++```sh+$ curl \+    --request POST \+    --header 'Accept: application/json' \+    'http://localhost:8201/strict-search/hello'+{"err":"IncorrectCapitalization"}+$ curl \+    --request POST \+    --header 'Accept: application/json' \+    'http://localhost:8201/strict-search/Hello'+{"data":"good"}+```++### Run the client++The client provides a small command line application to query the server.  In+order to use the client, the server must be running.++Use the client to access the lax search api:++```sh+$ stack exec -- servant-checked-exceptions-example-client foobar+the search term was not "Hello"+$ stack exec -- servant-checked-exceptions-example-client hello+Success: good+```++Use the client to access the strict search api:++```sh+$ stack exec -- servant-checked-exceptions-example-client --strict hello+the search term was not capitalized correctly+$ stack exec -- servant-checked-exceptions-example-client --strict Hello+Success: good+```++### Run the documentation generator++The documentation generator will generate documentation for the api in Markdown:++```sh+$ stack exec -- servant-checked-exceptions-example-docs+```++Here is a small example of the documentation that will be generated for the lax+search api:++```markdown+## POST /lax-search/:query++#### Captures:++- *query*: a search string like "hello" or "bye"++#### Response:++- Status code 200+- Headers: []++- Supported content types are:++    - `application/json`++- This is a successful response.++{"data":"good"}++- a completely incorrect search term was used++{"err":"BadSearchTermErr"}+```++You can see that both the success and error responses are documented.++## Packaging the core types++[`servant-checked-exceptions-core`](https://hackage.haskell.org/package/servant-checked-exceptions-core)+exports the core types need for building an API with checked exceptions,+allowing you to avoid depending on server-side libraries like `warp`, `Glob`+and `servant-server`. This can be useful if you are writing an API meant to be+shared with ghcjs and run in a browser, where these dependencies aren't+available.+

+ example/Api.hs view

@@ -0,0 +1,141 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module Api where++import Data.Aeson+       (FromJSON(parseJSON), ToJSON(toJSON), Value, withText)+import Data.Aeson.Types (Parser)+import Data.String (IsString)+import Data.Text (unpack)+import Network.HTTP.Types (Status, status400, status404)+import Servant.API (Capture, JSON, Post, (:>), (:<|>))+import Text.Read (readMaybe)+import Web.HttpApiData (FromHttpApiData, ToHttpApiData)++import Servant.Checked.Exceptions (NoThrow, Throws)+import Servant.Checked.Exceptions.Internal.Servant.API (ErrStatus(toErrStatus))++---------+-- API --+---------++-- | This is our main 'Api' type.  We will create a server, a client, and+-- documentation for this api.+--+-- This api is composed of three routes, 'ApiStrictSearch', 'ApiLaxSearch', and+-- 'ApiNoErrSearch'.+type Api = ApiStrictSearch :<|> ApiLaxSearch :<|> ApiNoErrSearch++-- | This is a strict search api.  You pass it a @\"query\"@, and it returns a+-- 'SearchResponse'.  It potentially returns a 'BadSearchTermErr' if your query+-- is not the string @\"hello\"@.  It returns an 'IncorrectCapitialization'+-- error if your query is not capitalized like @\"Hello\"@.+--+-- Notice how we are using 'Throws' to indicate we will potentially throw an+-- error.  Also, notice how we can list multiple 'Throws'.+type ApiStrictSearch =+  "strict-search" :>+  Capture "query" SearchQuery :>+  Throws BadSearchTermErr :>+  Throws IncorrectCapitalization :>+  Post '[JSON] SearchResponse++-- | This is similar to 'ApiStrictSearch', but it doesn't force the query to be+-- capitalized correctly.  It only returns a 'BadSearchTermErr'.+type ApiLaxSearch =+  "lax-search" :>+  Capture "query" SearchQuery :>+  Throws BadSearchTermErr :>+  Post '[JSON] SearchResponse++-- | This is similar to 'ApiLaxSearch', but it doesn't force the query to use+-- correct terms.  It does not return an error.+type ApiNoErrSearch =+  "no-err-search" :>+  Capture "query" SearchQuery :>+  NoThrow :>+  Post '[JSON] SearchResponse++------------------------------+-- Parameters and Responses --+------------------------------++-- | This 'SearchQuery' type is just a newtype wrapper around a 'String'.+newtype SearchQuery = SearchQuery+  { unSearchQuery :: String+  } deriving ( Eq+             , FromHttpApiData+             , FromJSON+             , IsString+             , Ord+             , Read+             , Show+             , ToHttpApiData+             , ToJSON+             )++-- | This 'SearchResponse' type is just a newtype wrapper around a 'String'.+newtype SearchResponse = SearchResponse+  { unSearchResponse :: String+  } deriving ( Eq+             , FromHttpApiData+             , FromJSON+             , IsString+             , Ord+             , Read+             , Show+             , ToHttpApiData+             , ToJSON+             )++------------+-- Errors --+------------++-- | This error is returned when the search query is not the string @\"hello\"@.+data BadSearchTermErr = BadSearchTermErr deriving (Eq, Read, Show)++instance ToJSON BadSearchTermErr where+  toJSON :: BadSearchTermErr -> Value+  toJSON = toJSON . show++instance FromJSON BadSearchTermErr where+  parseJSON :: Value -> Parser BadSearchTermErr+  parseJSON = withText "BadSearchTermErr" $+    maybe (fail "could not parse as BadSearchTermErr") pure . readMaybe . unpack++instance ErrStatus BadSearchTermErr where+  toErrStatus :: BadSearchTermErr -> Status+  toErrStatus _ = status404++-- | This error is returned when the search query is @\"hello\"@, but it is not+-- capitalized correctly.  For example, the search query @\"hello\"@ will+-- return an 'IncorrectCapitialization' error.  However, the search query+-- @\"Hello\"@ will return a success.+data IncorrectCapitalization = IncorrectCapitalization deriving (Eq, Read, Show)++instance ToJSON IncorrectCapitalization where+  toJSON :: IncorrectCapitalization -> Value+  toJSON = toJSON . show++instance FromJSON IncorrectCapitalization where+  parseJSON :: Value -> Parser IncorrectCapitalization+  parseJSON = withText "IncorrectCapitalization" $+    maybe (fail "could not parse as IncorrectCapitalization") pure . readMaybe . unpack++instance ErrStatus IncorrectCapitalization where+  toErrStatus :: IncorrectCapitalization -> Status+  toErrStatus _ = status400++----------+-- Port --+----------++-- | The port to run the server on.+port :: Int+port = 8201

+ example/Docs.hs view

@@ -0,0 +1,63 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main where++import Data.Proxy (Proxy(Proxy))+import Data.Text (Text)+import Servant.API (Capture)+import Servant.Docs+       (DocCapture(DocCapture), ToCapture(toCapture), ToSample(toSamples),+        docs, markdown)++import Servant.Checked.Exceptions ()++import Api+       (Api, BadSearchTermErr(BadSearchTermErr),+        IncorrectCapitalization(IncorrectCapitalization), SearchQuery,+        SearchResponse)++-- This module prints out documentation for 'Api'.+--+-- Notice how we only need 'ToSample' instances for the two errors we are+-- throwing with 'Throws': 'BadSearchTermErr' and 'IncorrectCapitialization'.+-- We don't have to directly worry about writing instances for 'Envelope'.++instance ToSample SearchResponse where+  toSamples :: Proxy SearchResponse -> [(Text, SearchResponse)]+  toSamples Proxy = [("This is a successful response.", "good")]++instance ToCapture (Capture "query" SearchQuery) where+  toCapture :: Proxy (Capture "query" SearchQuery) -> DocCapture+  toCapture Proxy =+    DocCapture "query" "a search string like \"hello\" or \"bye\""++instance ToSample BadSearchTermErr where+  toSamples :: Proxy BadSearchTermErr -> [(Text, BadSearchTermErr)]+  toSamples Proxy =+    [("a completely incorrect search term was used", BadSearchTermErr)]++instance ToSample IncorrectCapitalization where+  toSamples :: Proxy IncorrectCapitalization -> [(Text, IncorrectCapitalization)]+  toSamples Proxy =+    [ ( "the search term \"Hello\" has not been capitalized correctly"+      , IncorrectCapitalization)+    ]++-- | Print the documentation rendered as markdown to stdout.+main :: IO ()+main = putStrLn . markdown $ docs (Proxy :: Proxy Api)

+ servant-checked-exceptions-core.cabal view

@@ -0,0 +1,84 @@+name:                servant-checked-exceptions-core+version:             2.0.0.0+synopsis:            Checked exceptions for Servant APIs.+description:         Please see <https://github.com/cdepillabout/servant-checked-exceptions#readme README.md>.+homepage:            https://github.com/cdepillabout/servant-checked-exceptions+license:             BSD3+license-file:        LICENSE+author:              Dennis Gosnell+maintainer:          cdep.illabout@gmail.com+copyright:           2017-2018 Dennis Gosnell+category:            Text+build-type:          Simple+extra-source-files:  CHANGELOG.md+                   , README.md+cabal-version:       >=1.10++flag buildexample+  description: Build a small example program+  default: False++library+  hs-source-dirs:      src+  exposed-modules:     Servant.Checked.Exceptions+                     , Servant.Checked.Exceptions.Envelope+                     , Servant.Checked.Exceptions.Verbs+                     , Servant.Checked.Exceptions.Internal+                     , Servant.Checked.Exceptions.Internal.Envelope+                     , Servant.Checked.Exceptions.Internal.Prism+                     , Servant.Checked.Exceptions.Internal.Servant+                     , Servant.Checked.Exceptions.Internal.Servant.API+                     , Servant.Checked.Exceptions.Internal.Servant.Docs+                     , Servant.Checked.Exceptions.Internal.Util+                     , Servant.Checked.Exceptions.Internal.Verbs+  build-depends:       base >= 4.9 && < 5+                     , aeson+                     , bytestring+                     , deepseq+                     , http-media+                     , http-types+                     , profunctors+                     , tagged+                     , servant >= 0.12+                     , servant-docs >= 0.10+                     , text+                     , world-peace+  default-language:    Haskell2010+  ghc-options:         -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction+  other-extensions:    QuasiQuotes+                     , TemplateHaskell++executable servant-checked-exceptions-example-docs+  main-is:             Docs.hs+  other-modules:       Api+  hs-source-dirs:      example+  build-depends:       base+                     , aeson+                     , http-api-data+                     , http-types+                     , servant+                     , servant-checked-exceptions-core+                     , servant-docs+                     , text+  default-language:    Haskell2010+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N++  if flag(buildexample)+    buildable:         True+  else+    buildable:         False++test-suite servant-checked-exceptions-doctest+  if impl(ghcjs)+    buildable: False+  type:                exitcode-stdio-1.0+  main-is:             DocTest.hs+  hs-source-dirs:      test+  build-depends:       base+                     , doctest+                     , Glob+  default-language:    Haskell2010+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N+source-repository head+  type:     git+  location: git@github.com:cdepillabout/servant-checked-exceptions.git

+ src/Servant/Checked/Exceptions.hs view

@@ -0,0 +1,177 @@+{- |+Module      :  Servant.Checked.Exceptions++Copyright   :  Dennis Gosnell 2017+License     :  BSD3++Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)+Stability   :  experimental+Portability :  unknown++This module gives you the ability to specify which errors are thrown by a+Servant api.  This is done with the 'Throws' data type.  Here is an example of+creating an api that uses 'Throws':++@+  type Api =+    \"author\" 'Servant.API.:>'+    'Servant.API.Capture' \"author-id\" AuthorId 'Servant.API.:>'+    'Throws' CouldNotConnectToDbError 'Servant.API.:>'+    'Throws' AuthorNotFoundError 'Servant.API.:>'+    'Servant.API.Get' \'['Servant.API.JSON'] Author+@++This api will return an @Author@ for a given @AuthorId@.  'Throws' is used+to indicate that this api will potentially return two different errors:+@CouldNotConnectToDbError@ and @AuthorNotFoundError@.++These two errors might be defined like this:++@+  data CouldNotConnectToDbError = CouldNotConnectToDbError+    deriving ('Eq', 'Read', 'Show')++  data AuthorNotFoundError = AuthorNotFoundError+    deriving ('Eq', 'Read', 'Show')+@++Writing the server handler for this api will look like the following.  Notice+how the 'Envelope' type is used:++@+  getAuthorHandler+    :: AuthorId+    -> 'Handler' ('Envelope' \'[DatabaseError, AuthorNotFoundError] Author)+  getAuthorHandler authorId = do+    eitherAuthor <- getAuthorFromDb authorId+    case eitherAuthor of+      Left NoDb -> pure $ 'toErrEnvelope' CouldNotConnectToDbError+      Left NoAuthor -> pure $ 'toErrEnvelope' AuthorNotFoundError+      Right author -> pure $ 'toSuccEnvelope' author++  getAuthorFromDb :: AuthorId -> Handler (Either DbErr Author)+  getAuthorFromDb = ...++  data DbErr = NoDb | NoAuthor+@++@'Envelope' \'[DatabaseError, AuthorNotFoundError] Author@ represents a+response that will contain an @Author@ on success, or contain either a+@DatabaseError@ or a @AuthorNotFoundError@ on error.++Under the hood, 'Envelope' is using an extensible sum-type ('OpenUnion') to+represent possible errors.  Working with an api that returns two possible+errors is just as easy as working with an api that returns three possible+errors.++Clients will also use the 'Envelope' type:++@+  getAuthor+    :: AuthorId+    -> 'Servant.Client.ClientM' ('Envelope' \'[DatabaseError, AuthorNotFoundError] Author)+  getAuthor = 'Servant.Client.client' ('Data.Proxy.Proxy' :: 'Data.Proxy.Proxy' Api)+@++It is easy to do case analysis (similar to pattern matching) on the 'Envelope'+type with the 'catchesEnvelope' function.++Checkout the+<https://github.com/cdepillabout/servant-checked-exceptions/tree/master/example example>+in the repository on Github.  It includes a fleshed-out example of an+<https://github.com/cdepillabout/servant-checked-exceptions/blob/master/example/Api.hs api>,+<https://github.com/cdepillabout/servant-checked-exceptions/blob/master/example/Server.hs server>,+<https://github.com/cdepillabout/servant-checked-exceptions/blob/master/example/Client.hs client>,+and+<https://github.com/cdepillabout/servant-checked-exceptions/blob/master/example/Docs.hs documentation>.+The <https://github.com/cdepillabout/servant-checked-exceptions README.md>+shows how to compile and run the examples.+-}++module Servant.Checked.Exceptions+  (+  -- * Servant Types+  -- ** 'Throws' API parameter+    Throws+  -- ** 'NoThrow' API parameter+  , NoThrow+  -- ** HTTP Error Status Code+  , ErrStatus(toErrStatus)+  , Status+  -- ** Verbs+  , VerbWithErr+  -- *** Specialized Verbs+  -- **** HTTP 200+  , GetWithErr+  , PostWithErr+  , PutWithErr+  , DeleteWithErr+  , PatchWithErr+  -- **** HTTP 201+  , PostCreatedWithErr+  -- **** HTTP 202+  , GetAcceptedWithErr+  , PostAcceptedWithErr+  , DeleteAcceptedWithErr+  , PatchAcceptedWithErr+  , PutAcceptedWithErr+  -- **** HTTP 203+  , GetNonAuthoritativeWithErr+  , PostNonAuthoritativeWithErr+  , DeleteNonAuthoritativeWithErr+  , PatchNonAuthoritativeWithErr+  , PutNonAuthoritativeWithErr+  -- **** HTTP 204+  , GetNoContentWithErr+  , PostNoContentWithErr+  , DeleteNoContentWithErr+  , PatchNoContentWithErr+  , PutNoContentWithErr+  -- **** HTTP 205+  , GetResetContentWithErr+  , PostResetContentWithErr+  , DeleteResetContentWithErr+  , PatchResetContentWithErr+  , PutResetContentWithErr+  -- **** HTTP 206+  , GetPartialContentWithErr+  -- * 'Envelope' response wrapper+  , Envelope(..)+  -- ** 'Envelope' helper functions+  -- *** 'Envelope' constructors+  , toSuccEnvelope+  , toErrEnvelope+  , pureSuccEnvelope+  , pureErrEnvelope+  -- *** 'Envelope' destructors+  , envelope+  , emptyEnvelope+  , fromEnvelope+  , fromEnvelopeOr+  , fromEnvelopeM+  , fromEnvelopeOrM+  , errEnvelopeMatch+  , catchesEnvelope+  -- *** 'Envelope' optics+  , _SuccEnvelope+  , _ErrEnvelope+  , _ErrEnvelopeErr+  -- *** 'Envelope' and 'Either'+  , envelopeToEither+  , eitherToEnvelope+  , isoEnvelopeEither+  -- * Re-exported modules+  -- | "Data.WorldPeace" exports the 'OpenUnion' type as well as other+  -- combinators.  It also exports the 'OpenProduct' type and 'ToProduct' type+  -- class used by some of the functions above.+  , module Data.WorldPeace+  , module Servant.Checked.Exceptions.Internal.Servant.Docs+  ) where++import Data.WorldPeace+import Network.HTTP.Types (Status)++import Servant.Checked.Exceptions.Internal.Envelope+import Servant.Checked.Exceptions.Internal.Servant.API+import Servant.Checked.Exceptions.Internal.Servant.Docs+import Servant.Checked.Exceptions.Internal.Verbs

+ src/Servant/Checked/Exceptions/Envelope.hs view

@@ -0,0 +1,31 @@+module Servant.Checked.Exceptions.Envelope (+  -- * Envelope+    Envelope(..)+  -- * Helper functions+  -- ** Envelope Constructors+  , toSuccEnvelope+  , toErrEnvelope+  , pureSuccEnvelope+  , pureErrEnvelope+  -- ** Envelope Destructors+  , envelope+  , emptyEnvelope+  , fromEnvelope+  , fromEnvelopeOr+  , fromEnvelopeM+  , fromEnvelopeOrM+  , errEnvelopeMatch+  , catchesEnvelope+  -- ** Optics+  , _SuccEnvelope+  , _ErrEnvelope+  , _ErrEnvelopeErr+  -- ** Either+  , envelopeToEither+  , eitherToEnvelope+  , isoEnvelopeEither+  -- * Setup code for doctests+  -- $setup+  ) where++import Servant.Checked.Exceptions.Internal.Envelope

+ src/Servant/Checked/Exceptions/Internal.hs view

@@ -0,0 +1,11 @@+module Servant.Checked.Exceptions.Internal+  ( module Servant.Checked.Exceptions.Internal.Envelope+  , 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.Verbs+import Servant.Checked.Exceptions.Internal.Servant+import Servant.Checked.Exceptions.Internal.Util

+ src/Servant/Checked/Exceptions/Internal/Envelope.hs view

@@ -0,0 +1,466 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++{- |+Module      :  Servant.Checked.Exceptions.Internal.Envelope++Copyright   :  Dennis Gosnell 2017+License     :  BSD3++Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)+Stability   :  experimental+Portability :  unknown++This module defines the 'Envelope' type as a wrapper around a success value, or+a set of possible errors.  The errors are an 'OpenUnion', which is an+extensible sumtype.++Other than the 'Envelope' type, the most important thing in this module is the+'ToJSON' instance for 'Envelope'.+-}++module Servant.Checked.Exceptions.Internal.Envelope where++import Control.Applicative ((<|>))+import Control.Monad.Fix (MonadFix(mfix))+import Data.Aeson+  ( FromJSON(parseJSON)+  , ToJSON(toJSON)+  , Value+  , (.:)+  , (.=)+  , object+  , withObject+  )+import Data.Aeson.Types (Parser)+import Data.Data (Data)+import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotent)+import Data.Typeable (Typeable)+import Data.WorldPeace+  ( IsMember+  , OpenUnion+  , ReturnX+  , ToOpenProduct+  , absurdUnion+  , catchesOpenUnion+  , openUnionLift+  , openUnionPrism+  )+import GHC.Generics (Generic)++import Servant.Checked.Exceptions.Internal.Prism+       (Iso, Prism, Prism', iso, preview, prism)++-- $setup+-- >>> :set -XDataKinds+-- >>> :set -XTypeOperators+-- >>> import Data.Aeson (encode)+-- >>> import Data.ByteString.Lazy.Char8 (hPutStrLn)+-- >>> import Data.Text (Text)+-- >>> import System.IO (stdout)+-- >>> import Text.Read (readMaybe)+-- >>> import Servant.Checked.Exceptions.Internal.Prism (review)+-- >>> let putByteStrLn = hPutStrLn stdout+++-- | This 'Envelope' type is a used as a wrapper around either an 'OpenUnion'+-- with an error or a successful value.  It is similar to an @'Either' e a@,+-- but where the @e@ is specialized to @'OpenUnion' es@.  The most important+-- difference from 'Either' is the the 'FromJSON' and 'ToJSON' instances.+--+-- Given an @'Envelope' \'['String', 'Double'] ()@, we know that the envelope+-- could be a 'SuccEnvelope' and contain @()@.  Or it could be a 'ErrEnvelope'+-- that contains /either/ a 'String' /or/ a 'Double'.  It might be simpler to+-- think of it as a type like @'Either' 'String' ('Either' 'Double' ())@.+--+-- An 'Envelope' can be created with the 'toErrEnvelope' and 'toSuccEnvelope'+-- functions.  The 'Prism's '_SuccEnvelope', '_ErrEnvelope', and+-- '_ErrEnvelopeErr' can be used to get values out of an 'Envelope'.+data Envelope es a = ErrEnvelope (OpenUnion es) | SuccEnvelope a+  deriving (Foldable, Functor, Generic, Traversable)++-- | Create an 'ErrEnvelope' from a member of the 'OpenUnion'.+--+-- For instance, here is how to create an 'ErrEnvelope' that contains a+-- 'Double':+--+-- >>> let double = 3.5 :: Double+-- >>> toErrEnvelope double :: Envelope '[String, Double, Int] ()+-- ErrEnvelope (Identity 3.5)+toErrEnvelope :: IsMember e es => e -> Envelope es a+toErrEnvelope = ErrEnvelope . openUnionLift++-- | This is a function to create a 'SuccEnvelope'.+--+-- >>> toSuccEnvelope "hello" :: Envelope '[Double] String+-- SuccEnvelope "hello"+toSuccEnvelope :: a -> Envelope es a+toSuccEnvelope = SuccEnvelope++-- | 'pureErrEnvelope' is 'toErrEnvelope' lifted up to an 'Applicative'.+pureErrEnvelope :: (Applicative m, IsMember e es) => e -> m (Envelope es a)+pureErrEnvelope = pure . toErrEnvelope++-- | 'pureSuccEnvelope' is 'toSuccEnvelope' lifted up to an 'Applicative'.+pureSuccEnvelope :: Applicative m => a -> m (Envelope es a)+pureSuccEnvelope = pure . toSuccEnvelope++-- | Case analysis for 'Envelope's.+--+-- ==== __Examples__+--+--  Here is an example of matching on a 'SuccEnvelope':+--+-- >>> let env = toSuccEnvelope "hello" :: Envelope '[Double, Int] String+-- >>> envelope (const "not a String") id env+-- "hello"+--+-- Here is an example of matching on a 'ErrEnvelope':+--+-- >>> let double = 3.5 :: Double+-- >>> let env' = toErrEnvelope double :: Envelope '[Double, Int] String+-- >>> envelope (const "not a String") id env'+-- "not a String"+envelope :: (OpenUnion es -> c) -> (a -> c) -> Envelope es a -> c+envelope f _ (ErrEnvelope es) = f es+envelope _ f (SuccEnvelope a) = f a++-- | Unwrap an 'Envelope' that cannot contain an error.+--+-- ==== __Examples__+--+-- >>> let env = toSuccEnvelope "hello" :: Envelope '[] String+-- >>> emptyEnvelope env+-- "hello"+emptyEnvelope :: Envelope '[] a -> a+emptyEnvelope (SuccEnvelope a) = a+emptyEnvelope (ErrEnvelope es) = absurdUnion es++-- | Just like 'Data.Either.fromEither' but for 'Envelope'.+--+-- ==== __Examples__+--+--  Here is an example of successfully matching:+--+-- >>> let env = toSuccEnvelope "hello" :: Envelope '[Double, Int] String+-- >>> fromEnvelope (const "not a String") env+-- "hello"+--+-- Here is an example of unsuccessfully matching:+--+-- >>> let double = 3.5 :: Double+-- >>> let env' = toErrEnvelope double :: Envelope '[Double, Int] String+-- >>> fromEnvelope (const "not a String") env'+-- "not a String"+fromEnvelope :: (OpenUnion es -> a) -> Envelope es a -> a+fromEnvelope f = envelope f id++-- | Lifted version of 'fromEnvelope'.+fromEnvelopeM+  :: Applicative m+  => (OpenUnion es -> m a) -> Envelope es a -> m a+fromEnvelopeM f = envelope f pure++-- | Flipped version of 'fromEnvelope'.+fromEnvelopeOr :: Envelope es a -> (OpenUnion es -> a) -> a+fromEnvelopeOr = flip fromEnvelope++-- | Flipped version of 'fromEnvelopeM'.+fromEnvelopeOrM+  :: Applicative m+  => Envelope es a -> (OpenUnion es -> m a) -> m a+fromEnvelopeOrM = flip fromEnvelopeM++-- | Convert an 'Envelope' to an 'Either'.+envelopeToEither :: Envelope es a -> Either (OpenUnion es) a+envelopeToEither (ErrEnvelope es) = Left es+envelopeToEither (SuccEnvelope a) = Right a++-- | Convert an 'Either' to an 'Envelope'.+eitherToEnvelope :: Either (OpenUnion es) a -> Envelope es a+eitherToEnvelope (Left es) = ErrEnvelope es+eitherToEnvelope (Right a) = SuccEnvelope a++-- | Lens-compatible 'Iso' from 'Envelope' to 'Either'.+isoEnvelopeEither :: Iso (Envelope es a) (Envelope fs b) (Either (OpenUnion es) a) (Either (OpenUnion fs) b)+isoEnvelopeEither = iso envelopeToEither eitherToEnvelope++-- | Lens-compatible 'Prism' to pull out an @a@ from a 'SuccEnvelope'.+--+-- ==== __Examples__+--+-- Use '_SuccEnvelope' to construct an 'Envelope':+--+-- >>> review _SuccEnvelope "hello" :: Envelope '[Double] String+-- SuccEnvelope "hello"+--+-- Use '_SuccEnvelope' to try to destruct an 'Envelope' into an @a@:+--+-- >>> let env = toSuccEnvelope "hello" :: Envelope '[Double] String+-- >>> preview _SuccEnvelope env :: Maybe String+-- Just "hello"+--+-- Use '_SuccEnvelope' to try to destruct a 'Envelope into an @a@+-- (unsuccessfully):+--+-- >>> let double = 3.5 :: Double+-- >>> let env' = toErrEnvelope double :: Envelope '[Double] String+-- >>> preview _SuccEnvelope env' :: Maybe String+-- Nothing+_SuccEnvelope :: Prism (Envelope es a) (Envelope es b) a b+_SuccEnvelope = prism SuccEnvelope $ envelope (Left . ErrEnvelope) Right++-- | Lens-compatible 'Prism' to pull out an @'OpenUnion' es@ from a+-- 'ErrEnvelope'.+--+-- Most users will not use '_ErrEnvelope', but instead '_ErrEnvelopeErr'.+--+-- ==== __Examples__+--+-- Use '_ErrEnvelope' to construct an 'Envelope':+--+-- >>> let string = "hello" :: String+-- >>> review _ErrEnvelope (openUnionLift string) :: Envelope '[String] Double+-- ErrEnvelope (Identity "hello")+--+-- Use '_ErrEnvelope' to try to destruct an 'Envelope' into an+-- @'OpenUnion' es@:+--+-- >>> let double = 3.5 :: Double+-- >>> let env = toErrEnvelope double :: Envelope '[Double] ()+-- >>> preview _ErrEnvelope env :: Maybe (OpenUnion '[Double])+-- Just (Identity 3.5)+--+-- Use '_ErrEnvelope' to try to destruct a 'Envelope into an+-- @'OpenUnion' es@ (unsuccessfully):+--+-- >>> let env' = toSuccEnvelope () :: Envelope '[Double] ()+-- >>> preview _ErrEnvelope env' :: Maybe (OpenUnion '[Double])+-- Nothing+_ErrEnvelope :: Prism (Envelope es a) (Envelope es' a) (OpenUnion es) (OpenUnion es')+_ErrEnvelope = prism ErrEnvelope $ envelope Right (Left . SuccEnvelope)++-- | Lens-compatible 'Prism' to pull out a specific @e@ from an 'ErrEnvelope'.+--+-- Most users will use '_ErrEnvelopeErr' instead of '_ErrEnvelope'.+--+-- ==== __Examples__+--+-- Use '_ErrEnvelopeErr' to construct an 'Envelope':+--+-- >>> let string = "hello" :: String+-- >>> review _ErrEnvelopeErr string :: Envelope '[String] Double+-- ErrEnvelope (Identity "hello")+--+-- Use '_ErrEnvelopeErr' to try to destruct an 'Envelope' into an @e@:+--+-- >>> let double = 3.5 :: Double+-- >>> let env = toErrEnvelope double :: Envelope '[Double] ()+-- >>> preview _ErrEnvelopeErr env :: Maybe Double+-- Just 3.5+--+-- Use '_ErrEnvelopeErr' to try to destruct a 'Envelope into an+-- @e@ (unsuccessfully):+--+-- >>> let env' = toSuccEnvelope () :: Envelope '[Double] ()+-- >>> preview _ErrEnvelopeErr env' :: Maybe Double+-- Nothing+-- >>> let env'' = toErrEnvelope 'c' :: Envelope '[Double, Char] ()+-- >>> preview _ErrEnvelopeErr env'' :: Maybe Double+-- Nothing+_ErrEnvelopeErr :: forall e es a. IsMember e es => Prism' (Envelope es a) e+_ErrEnvelopeErr = _ErrEnvelope . openUnionPrism++-- | Pull out a specific @e@ from an 'ErrEnvelope'.+--+-- ==== __Examples__+--+-- Successfully pull out an @e@:+--+-- >>> let double = 3.5 :: Double+-- >>> let env = toErrEnvelope double :: Envelope '[Double] ()+-- >>> errEnvelopeMatch env :: Maybe Double+-- Just 3.5+--+-- Unsuccessfully pull out an @e@:+--+-- >>> let env' = toSuccEnvelope () :: Envelope '[Double] ()+-- >>> errEnvelopeMatch env' :: Maybe Double+-- Nothing+-- >>> let env'' = toErrEnvelope 'c' :: Envelope '[Double, Char] ()+-- >>> errEnvelopeMatch env'' :: Maybe Double+-- Nothing+errEnvelopeMatch+  :: forall e es a.+     IsMember e es+  => Envelope es a -> Maybe e+errEnvelopeMatch = preview _ErrEnvelopeErr++-- | An alternate case anaylsis for an 'Envelope'.  This method uses a tuple+-- containing handlers for each potential value of the 'Envelope'.  This is+-- somewhat similar to the 'Control.Exception.catches' function.+--+-- When working with an 'Envelope' with a large number of possible error types,+-- it can be easier to use 'catchesEnvelope' than 'envelope'.+--+-- ==== __Examples__+--+-- Here is an example of handling an 'SuccEnvelope' with two possible error values.+-- Notice that a normal tuple is used:+--+-- >>> let env = toSuccEnvelope 2.0 :: Envelope '[Int, String] Double+-- >>> let intHandler = (\int -> show int) :: Int -> String+-- >>> let strHandler = (\str -> str) :: String -> String+-- >>> let succHandler = (\dbl -> "got a double") :: Double -> String+-- >>> catchesEnvelope (intHandler, strHandler) succHandler env :: String+-- "got a double"+--+-- Here is an example of handling an 'ErrEnvelope' with two possible error values.+-- Notice that a normal tuple is used to hold the handlers:+--+-- >>> let env = toErrEnvelope (3 :: Int) :: Envelope '[Int, String] Double+-- >>> let intHandler = (\int -> show int) :: Int -> String+-- >>> let strHandler = (\str -> str) :: String -> String+-- >>> let succHandler = (\dbl -> "got a double") :: Double -> String+-- >>> catchesEnvelope (intHandler, strHandler) succHandler env :: String+-- "3"+--+-- Given an 'Envelope' like @'Envelope' \'['Int', 'String'] 'Double'@, the type of+-- 'catchesEnvelope' becomes the following:+--+-- @+--   'catchesEnvelope'+--     :: ('Int' -> x, 'String' -> x)+--     -> ('Double' -> x)+--     -> 'Envelope' \'['Int', 'String'] 'Double'+--     -> x+-- @+--+-- Here is an example of handling an 'ErrEnvelope' with three possible values.+-- Notice how a 3-tuple is used to hold the handlers:+--+-- >>> let env = toErrEnvelope ("hi" :: String) :: Envelope '[Int, String, Char] Double+-- >>> let intHandler = (\int -> show int) :: Int -> String+-- >>> let strHandler = (\str -> str) :: String -> String+-- >>> let chrHandler = (\chr -> [chr]) :: Char -> String+-- >>> let succHandler = (\dbl -> "got a double") :: Double -> String+-- >>> catchesEnvelope (intHandler, strHandler, chrHandler) succHandler env :: String+-- "hi"+--+-- Given an 'Envelope' like @'Envelope' \'['Int', 'String', 'Char'] 'Double'@,+-- the type of 'catchesEnvelope' becomes the following:+--+-- @+--   'catchesEnvelope'+--     :: ('Int' -> x, 'String' -> x, 'Char' -> x)+--     -> ('Double' -> x)+--     -> 'Envelope' \'['Int', 'String', 'Char'] 'Double'+--     -> x+-- @+--+-- Here is an example of handling an 'ErrEnvelope' with only one possible error value.+-- Notice that a normal handler is used (not a tuple):+--+-- >>> let env = toErrEnvelope (3 :: Int) :: Envelope '[Int] Double+-- >>> let intHandler = (\int -> show int) :: Int -> String+-- >>> let succHandler = (\dbl -> "got a double") :: Double -> String+-- >>> catchesEnvelope intHandler succHandler env :: String+-- "3"+--+-- Given an 'Envelope' like @'Envelope' \'['Int'] 'Double'@, the type of+-- 'catchesEnvelope' becomes the following:+--+-- @+--   'catchesEnvelope'+--     :: ('Int' -> x)+--     -> ('Double' -> x)+--     -> 'Envelope' \'['Int'] 'Double'+--     -> x+-- @+catchesEnvelope+  :: forall tuple es a x.+     ToOpenProduct tuple (ReturnX x es)+  => tuple -> (a -> x) -> Envelope es a -> x+catchesEnvelope _ a2x (SuccEnvelope a) = a2x a+catchesEnvelope tuple _ (ErrEnvelope u) = catchesOpenUnion tuple u++-- | This 'ToJSON' instance encodes an 'Envelope' as an object with one of two+-- keys depending on whether it is a 'SuccEnvelope' or an 'ErrEnvelope'.+--+-- Here is an example of a 'SuccEnvelope':+--+-- >>> let string = "hello" :: String+-- >>> let env = toSuccEnvelope string :: Envelope '[Double] String+-- >>> putByteStrLn $ encode env+-- {"data":"hello"}+--+-- Here is an example of a 'ErrEnvelope':+--+-- >>> let double = 3.5 :: Double+-- >>> let env' = toErrEnvelope double :: Envelope '[Double] String+-- >>> putByteStrLn $ encode env'+-- {"err":3.5}+instance (ToJSON (OpenUnion es), ToJSON a) => ToJSON (Envelope es a) where+  toJSON :: Envelope es a -> Value+  toJSON (ErrEnvelope es) = object ["err" .= es]+  toJSON (SuccEnvelope a) = object ["data" .= a]++-- | This is only a valid instance when the 'FromJSON' instances for the @es@+-- don't overlap.+--+-- For an explanation, see the documentation on the 'FromJSON' instance for+-- 'Servant.Checked.Exceptions.Internal.Union.Union'.+instance (FromJSON (OpenUnion es), FromJSON a) => FromJSON (Envelope es a) where+  parseJSON :: Value -> Parser (Envelope es a)+  parseJSON = withObject "Envelope" $ \obj ->+    SuccEnvelope <$> obj .: "data" <|>+    ErrEnvelope <$> obj .: "err"++deriving instance (Data (OpenUnion es), Data a, Typeable es) => Data (Envelope es a)+deriving instance (Eq (OpenUnion es), Eq a) => Eq (Envelope es a)+deriving instance (Ord (OpenUnion es), Ord a) => Ord (Envelope es a)+deriving instance (Read (OpenUnion es), Read a) => Read (Envelope es a)+deriving instance (Show (OpenUnion es), Show a) => Show (Envelope es a)+deriving instance (Typeable (OpenUnion es), Typeable a) => Typeable (Envelope es a)++instance Applicative (Envelope es) where+  pure :: a -> Envelope es a+  pure = SuccEnvelope++  (<*>) :: Envelope es (a -> b) -> Envelope es a -> Envelope es b+  ErrEnvelope es <*> _ = ErrEnvelope es+  SuccEnvelope f <*> r = fmap f r++instance Monad (Envelope es) where+  (>>=) :: Envelope es a -> (a -> Envelope es b) -> Envelope es b+  ErrEnvelope es >>= _ = ErrEnvelope es+  SuccEnvelope a >>= k = k a++instance MonadFix (Envelope es) where+  mfix :: (a -> Envelope es a) -> Envelope es a+  mfix f =+    let a = f (unSucc a)+    in a+    where+      unSucc :: Envelope es a -> a+      unSucc (SuccEnvelope x) = x+      unSucc (ErrEnvelope _) = errorWithoutStackTrace "mfix Envelope: ErrEnvelope"++instance Semigroup (Envelope es a) where+  (<>) :: Envelope es a -> Envelope es a -> Envelope es a+  ErrEnvelope _ <> b = b+  a      <> _ = a++  stimes :: Integral b => b -> Envelope es a -> Envelope es a+  stimes = stimesIdempotent

+ src/Servant/Checked/Exceptions/Internal/Prism.hs view

@@ -0,0 +1,75 @@+{-# LANGUAGE RankNTypes #-}++{- |+Module      :  Servant.Checked.Exceptions.Internal.Envelope+License     :  BSD3+Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)+Stability   :  experimental+Portability :  unknown++These functions are for working with Optics popularized by the+<https://hackage.haskell.org/package/lens lens> package. Documentation can be+found in the lens package.  These functions are redefined here to remove the+dependency on the lens package.+-}++module Servant.Checked.Exceptions.Internal.Prism+  ( Prism+  , prism+  , Prism'+  , prism'+  , Iso+  , iso+  , review+  , preview+  , (<>~)+  ) where++import Data.Profunctor.Unsafe((#.))+import Control.Applicative+import Data.Coerce+import Data.Functor.Identity+import Data.Monoid+import Data.Profunctor+import Data.Tagged++type Iso s t a b+   = forall p f. (Profunctor p, Functor f) =>+                   p a (f b) -> p s (f t)++type Prism s t a b+   = forall p f. (Choice p, Applicative f) =>+                   p a (f b) -> p s (f t)++type Prism' s a = Prism s s a a++type ASetter s t a b = (a -> Identity b) -> s -> Identity t++iso :: (s -> a) -> (b -> t) -> Iso s t a b+iso sa bt = dimap sa (fmap bt)+{-# INLINE iso #-}++prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b+prism bt seta = dimap seta (either pure (fmap bt)) . right'+{-# INLINE prism #-}++prism' :: (a -> s) -> (s -> Maybe a) -> Prism' s a+prism' bs sma = prism bs (\s -> maybe (Left s) Right (sma s))+{-# INLINE prism' #-}++review :: Prism' t b -> b -> t+review p = coerce . p . Tagged . Identity+{-# INLINE review #-}++preview :: Prism' s a -> s -> Maybe a+preview l = coerce . l (Const . First . Just)+{-# INLINE preview #-}++over :: ASetter s t a b -> (a -> b) -> s -> t+over l f = runIdentity #. l (Identity #. f)+{-# INLINE over #-}++infixr 4 <>~+(<>~) :: Monoid a => ASetter s t a a -> a -> s -> t+l <>~ n = over l (`mappend` n)+{-# INLINE (<>~) #-}

+ src/Servant/Checked/Exceptions/Internal/Servant.hs view

@@ -0,0 +1,19 @@+{- |+Module      :  Servant.Checked.Exceptions.Internal.Servant++Copyright   :  Dennis Gosnell 2017+License     :  BSD3++Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)+Stability   :  experimental+Portability :  unknown++Export all of instances for the Client, Docs, and Server.+-}++module Servant.Checked.Exceptions.Internal.Servant+  ( module Servant.Checked.Exceptions.Internal.Servant.API+  ) where++import Servant.Checked.Exceptions.Internal.Servant.API+import Servant.Checked.Exceptions.Internal.Servant.Docs ()

+ src/Servant/Checked/Exceptions/Internal/Servant/API.hs view

@@ -0,0 +1,80 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{- |+Module      :  Servant.Checked.Exceptions.Internal.Servant.API++Copyright   :  Dennis Gosnell 2017+License     :  BSD3++Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)+Stability   :  experimental+Portability :  unknown++This module defines the 'Throws' and 'Throwing' types.+-}++module Servant.Checked.Exceptions.Internal.Servant.API where++import GHC.Exts (Constraint)+import Network.HTTP.Types (Status)+import Servant.API ((:>))++import Servant.Checked.Exceptions.Internal.Util (Snoc)++-- | 'Throws' is used in Servant API definitions and signifies that an API will+-- throw the given error.+--+-- Here is an example of how to create an API that potentially returns a+-- 'String' as an error, or an 'Int' on success:+--+-- >>> import Servant.API (Get, JSON, (:>))+-- >>> type API = Throws String :> Get '[JSON] Int+data Throws (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+-- 'Servant.Checked.Exceptions.Internal.Envelope.Envelope'.+--+-- ==== __Examples__+--+-- Create an API using 'NoThrow':+--+-- >>> import Servant.API (Get, JSON, (:>))+-- >>> type API = NoThrow :> Get '[JSON] Int+--+-- A servant-server handler for this type would look like the following:+--+-- @+--   apiHandler :: 'Servant.Handler' ('Servant.Checked.Exceptions.Internal.Envelope.Envelope' \'[] Int)+--   apiHandler = 'Servant.Checked.Exceptions.Internal.Envelope.pureSuccEnvelope' 3+-- @+data NoThrow++-- | This is used internally and should not be used by end-users.+data Throwing (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+++class ErrStatus e where+  toErrStatus :: e -> Status++type family AllErrStatus (es :: [k]) :: Constraint where+  AllErrStatus '[] = ()+  AllErrStatus (a ': as) = (ErrStatus a, AllErrStatus as)++-- $setup+-- >>> :set -XDataKinds+-- >>> :set -XTypeOperators

+ src/Servant/Checked/Exceptions/Internal/Servant/Docs.hs view

@@ -0,0 +1,163 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++{- |+Module      :  Servant.Checked.Exceptions.Internal.Servant.Docs++Copyright   :  Dennis Gosnell 2017+License     :  BSD3++Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)+Stability   :  experimental+Portability :  unknown++This module exports 'HasDocs' instances for 'Throws' and 'Throwing'.+-}++module Servant.Checked.Exceptions.Internal.Servant.Docs where++import Data.Proxy (Proxy(Proxy))+import Data.ByteString.Lazy (ByteString)+import Data.Function ((&))+import Data.Monoid ((<>))+import Data.Text (Text)+import Network.HTTP.Media (MediaType)+import Servant.API (Verb, (:>))+import Servant.API.ContentTypes (AllMimeRender(allMimeRender))+import Servant.Docs+       (Action, API, DocOptions, Endpoint, HasDocs(docsFor),+        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)+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+  docsFor+    :: Proxy (Throws e :> api)+    -> (Endpoint, Action)+    -> DocOptions+    -> API+  docsFor Proxy = docsFor (Proxy :: Proxy (Throwing '[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))+       )+    => HasDocs (Throwing es :> Verb method status ctypes a) where+  docsFor+    :: Proxy (Throwing 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)))+            (endpoint, action)+            docOpts+    in api & apiEndpoints . traverse . response . respBody <>~+        createRespBodiesFor (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+  docsFor+    :: Proxy (NoThrow :> Verb method status ctypes a)+    -> (Endpoint, Action)+    -> DocOptions+    -> API+  docsFor Proxy (endpoint, action) docOpts =+    docsFor+      (Proxy :: Proxy (Verb method status ctypes (Envelope '[] a)))+      (endpoint, action)+      docOpts++-- | Create samples for a given @list@ of types, under given @ctypes@.+--+-- Additional instances of this class should not need to be created.+class CreateRespBodiesFor list ctypes where+  createRespBodiesFor+    :: Proxy list+    -> Proxy ctypes+    -> [(Text, MediaType, ByteString)]++-- | An empty list of types has no samples.+instance CreateRespBodiesFor '[] ctypes where+  createRespBodiesFor+    :: Proxy '[]+    -> Proxy ctypes+    -> [(Text, MediaType, ByteString)]+  createRespBodiesFor Proxy Proxy = []++-- | Create a response body for each of the error types.+instance+       ( AllMimeRender ctypes (Envelope '[e] ())+       , CreateRespBodiesFor es ctypes+       , ToSample e+       )+    => CreateRespBodiesFor (e ': es) ctypes where+  createRespBodiesFor+    :: Proxy (e ': es)+    -> Proxy ctypes+    -> [(Text, MediaType, ByteString)]+  createRespBodiesFor Proxy ctypes =+    createRespBodyFor (Proxy :: Proxy e) ctypes <>+    createRespBodiesFor (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+    where+      samples :: [(Text, Envelope '[e] ())]+      samples = fmap toErrEnvelope <$> toSamples (Proxy :: Proxy e)++      enc :: (Text, Envelope '[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)

+ src/Servant/Checked/Exceptions/Internal/Util.hs view

@@ -0,0 +1,40 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{- |+Module      :  Servant.Checked.Exceptions.Internal.Util++Copyright   :  Dennis Gosnell 2017+License     :  BSD3++Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)+Stability   :  experimental+Portability :  unknown++Additional helpers.+-}++module Servant.Checked.Exceptions.Internal.Util where++-- | A type-level @snoc@.+--+-- Append to an empty list:+--+-- >>> Refl :: Snoc '[] Double :~: '[Double]+-- Refl+--+-- Append to a non-empty list:+--+-- >>> Refl :: Snoc '[Char] String :~: '[Char, String]+-- Refl+type family Snoc (as :: [k]) (b :: k) where+  Snoc '[] b = '[b]+  Snoc (a ': as) b = (a ': Snoc as b)++-- $setup+-- >>> :set -XDataKinds+-- >>> :set -XTypeOperators+-- >>> import Data.Type.Equality ((:~:)(Refl))+

+ src/Servant/Checked/Exceptions/Internal/Verbs.hs view

@@ -0,0 +1,69 @@+{- |+Module      :  Servant.Checked.Exceptions.Internal.Verbs++Copyright   :  Dennis Gosnell 2017+License     :  BSD3++Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)+Stability   :  experimental+Portability :  unknown++This module defines the 'Throws' and 'Throwing' types.+-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Servant.Checked.Exceptions.Internal.Verbs where+++import Data.Typeable (Typeable)+import GHC.Generics (Generic)+import GHC.TypeLits (Nat)+import Network.HTTP.Types (StdMethod(DELETE, GET, PATCH, POST, PUT))++data VerbWithErr+    (method :: k1)+    (successStatusCode :: Nat)+    (contentTypes :: [*])+    (es :: [*])+    a+  deriving (Generic, Typeable)++type GetWithErr    = VerbWithErr 'GET    200+type PostWithErr   = VerbWithErr 'POST   200+type PutWithErr    = VerbWithErr 'PUT    200+type DeleteWithErr = VerbWithErr 'DELETE 200+type PatchWithErr  = VerbWithErr 'PATCH  200++type PostCreatedWithErr = VerbWithErr 'POST 201++type GetAcceptedWithErr    = VerbWithErr 'GET 202+type PostAcceptedWithErr   = VerbWithErr 'POST 202+type DeleteAcceptedWithErr = VerbWithErr 'DELETE 202+type PatchAcceptedWithErr  = VerbWithErr 'PATCH 202+type PutAcceptedWithErr    = VerbWithErr 'PUT 202++type GetNonAuthoritativeWithErr    = VerbWithErr 'GET 203+type PostNonAuthoritativeWithErr   = VerbWithErr 'POST 203+type DeleteNonAuthoritativeWithErr = VerbWithErr 'DELETE 203+type PatchNonAuthoritativeWithErr  = VerbWithErr 'PATCH 203+type PutNonAuthoritativeWithErr    = VerbWithErr 'PUT 203++type GetNoContentWithErr    = VerbWithErr 'GET 204+type PostNoContentWithErr   = VerbWithErr 'POST 204+type DeleteNoContentWithErr = VerbWithErr 'DELETE 204+type PatchNoContentWithErr  = VerbWithErr 'PATCH 204+type PutNoContentWithErr    = VerbWithErr 'PUT 204++type GetResetContentWithErr    = VerbWithErr 'GET 205+type PostResetContentWithErr   = VerbWithErr 'POST 205+type DeleteResetContentWithErr = VerbWithErr 'DELETE 205+type PatchResetContentWithErr  = VerbWithErr 'PATCH 205+type PutResetContentWithErr    = VerbWithErr 'PUT 205++type GetPartialContentWithErr = VerbWithErr 'GET 206

+ src/Servant/Checked/Exceptions/Verbs.hs view

@@ -0,0 +1,43 @@+module Servant.Checked.Exceptions.Verbs (+  -- *** Specialized Verbs+  -- **** HTTP 200+    GetWithErr+  , PostWithErr+  , PutWithErr+  , DeleteWithErr+  , PatchWithErr+  , VerbWithErr+  -- **** HTTP 201+  , PostCreatedWithErr+  -- **** HTTP 202+  , GetAcceptedWithErr+  , PostAcceptedWithErr+  , DeleteAcceptedWithErr+  , PatchAcceptedWithErr+  , PutAcceptedWithErr+  -- **** HTTP 203+  , GetNonAuthoritativeWithErr+  , PostNonAuthoritativeWithErr+  , DeleteNonAuthoritativeWithErr+  , PatchNonAuthoritativeWithErr+  , PutNonAuthoritativeWithErr+  -- **** HTTP 204+  , GetNoContentWithErr+  , PostNoContentWithErr+  , DeleteNoContentWithErr+  , PatchNoContentWithErr+  , PutNoContentWithErr+  -- **** HTTP 205+  , GetResetContentWithErr+  , PostResetContentWithErr+  , DeleteResetContentWithErr+  , PatchResetContentWithErr+  , PutResetContentWithErr+  -- **** HTTP 206+  , GetPartialContentWithErr+  -- * 'Envelope' response wrapper+  , module Data.WorldPeace+  )where++import Data.WorldPeace+import Servant.Checked.Exceptions.Internal.Verbs

+ test/DocTest.hs view

@@ -0,0 +1,40 @@++module Main (main) where++import Prelude++import Data.Monoid ((<>))+import System.FilePath.Glob (glob)+import Test.DocTest (doctest)++main :: IO ()+main = glob "src/**/*.hs" >>= doDocTest++doDocTest :: [String] -> IO ()+doDocTest options = doctest $ options <> ghcExtensions++ghcExtensions :: [String]+ghcExtensions =+    [+    --   "-XConstraintKinds"+    -- , "-XDataKinds"+      "-XDeriveDataTypeable"+    , "-XDeriveGeneric"+    -- , "-XEmptyDataDecls"+    , "-XFlexibleContexts"+    -- , "-XFlexibleInstances"+    -- , "-XGADTs"+    -- , "-XGeneralizedNewtypeDeriving"+    -- , "-XInstanceSigs"+    -- , "-XMultiParamTypeClasses"+    -- , "-XNoImplicitPrelude"+    , "-XOverloadedStrings"+    -- , "-XPolyKinds"+    -- , "-XRankNTypes"+    -- , "-XRecordWildCards"+    , "-XScopedTypeVariables"+    -- , "-XStandaloneDeriving"+    -- , "-XTupleSections"+    -- , "-XTypeFamilies"+    -- , "-XTypeOperators"+    ]