eeva/servant
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Merge branch 'servant-docs-curl' of github.com:dfithian/servant into servant-docs-curl

Browse Source
This commit is contained in:
Dan Fithian 2021-07-29 08:33:35 -04:00
commit bc157062f1
12 changed files with 234 additions and 108 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -30,6 +30,7 @@ doc/_build
doc/venv
doc/tutorial/static/api.js
doc/tutorial/static/jq.js
shell.nix
# nix
result*

6
README.md
View File

@ -63,3 +63,9 @@ To compare with `reitit` (Clojure framework)
```
You can see the visualised results at https://www.techempower.com/benchmarks/#section=test
## Nix
A developer shell.nix file is provided in the `nix` directory
See [nix/README.md](nix/README.md)

3
cabal.project
View File

@ -3,8 +3,7 @@ packages:
servant-client/
servant-client-core/
servant-http-streams/
-- Tests failing with Cabal (TODO: investigate)
-- servant-docs/
servant-docs/
servant-foreign/
servant-server/
doc/tutorial/

15
doc/cookbook/uverb/UVerb.lhs
View File

@ -4,12 +4,19 @@ 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.
## Compatibility
:warning: This cookbook is compatible with GHC 8.6.1 or higher :warning:
## Preliminaries
```haskell
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
@ -154,12 +161,8 @@ Example usage:
```haskell
data Foo = Foo Int Int Int
deriving (Show, Eq, GHC.Generic)
instance ToJSON Foo
instance HasStatus Foo where
type StatusOf Foo = 200
deriving (Show, Eq, GHC.Generic, ToJSON)
deriving HasStatus via WithStatus 200 Foo
data Bar = Bar
deriving (Show, Eq, GHC.Generic)

4
doc/cookbook/uverb/uverb.cabal
View File

@ -28,6 +28,8 @@ executable cookbook-uverb
, swagger2
, wai
, warp
default-language: Haskell2010
if impl(ghc < 8.6.1)
buildable: False
default-language: Haskell2010
ghc-options: -Wall -pgmL markdown-unlit
build-tool-depends: markdown-unlit:markdown-unlit

6
nix/README.md
View File

@ -21,3 +21,9 @@ a particular ghc version, e.g:
``` sh
$ nix-shell nix/shell.nix --argstr compiler ghcHEAD
```
**Possible GHC versions**
- `ghc822Binary`
- `ghc865`
- `ghc884`
- `ghc8102` - default

40
nix/shell.nix
View File

@ -1,21 +1,25 @@
{ pkgs ? import <nixpkgs> {}
, compiler ? "ghc822"
let nixos = fetchTarball {
url = "https://releases.nixos.org/nixos/20.09/nixos-20.09.3505.12d9950bf47/nixexprs.tar.xz";
sha256 = "0fsl8bsdb8i536pfs4wrp0826h5l84xqlwx32sbz66jg4ykqp9lr";
}; in
{ compiler ? "ghc8102"
, tutorial ? false
, pkgs ? import nixos { config = {}; }
}:
with pkgs;
with pkgs;
let
ghc = haskell.packages.${compiler}.ghcWithPackages (_: []);
docstuffs = python3.withPackages (ps: with ps; [ recommonmark sphinx sphinx_rtd_theme ]);
in
stdenv.mkDerivation {
name = "servant-dev";
buildInputs = [ ghc zlib python3 wget ]
++ (if tutorial then [docstuffs postgresql] else []);
shellHook = ''
eval $(grep export ${ghc}/bin/ghc)
export LD_LIBRARY_PATH="${zlib}/lib";
'';
}
let
ghc = haskell.packages.${compiler}.ghcWithPackages (_: []);
docstuffs = python3.withPackages (ps: with ps; [ recommonmark sphinx sphinx_rtd_theme ]);
in
stdenv.mkDerivation {
name = "servant-dev";
buildInputs = [ ghc zlib python3 wget cabal-install postgresql openssl ]
++ (if tutorial then [docstuffs postgresql] else []);
shellHook = ''
eval $(grep export ${ghc}/bin/ghc)
export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:"${zlib}/lib";
'';
}

39
servant-docs/src/Servant/Docs/Internal.hs
View File

@ -846,21 +846,30 @@ markdownWith RenderingOptions{..} api = unlines $
formatBodies _responseExamples xs
curlStr :: Endpoint -> [HTTP.Header] -> [(Text, M.MediaType, ByteString)] -> String -> [String]
curlStr endpoint hdrs bds basePath =
let firstBodyMay = NE.head <$> NE.nonEmpty bds
in catMaybes $
( (Just "### Sample Request:") :
(Just "") :
(Just "```bash") :
(Just $ "curl -X" ++ BSC.unpack (endpoint ^. method) ++ " \\") :
((\(_, media_type, _) -> " -H 'Content-Type: " ++ show media_type ++ " '\\") <$> firstBodyMay) :
[] ) ++
((\(hdrName, hdrVal) -> Just $ " -H '" ++ cs (CI.original hdrName) ++ ": " ++ cs hdrVal ++ "' \\") <$> hdrs) ++
( ((\(_, _, body) -> " -d " ++ cs body ++ " \\") <$> firstBodyMay) :
(Just $ " " ++ basePath ++ showPath (endpoint ^. path)) :
(Just "```") :
(Just "") :
[] )
curlStr endpoint hdrs reqBodies basePath =
[ "### Sample Request:"
, ""
, "```bash"
, "curl -X" ++ BSC.unpack (endpoint ^. method) ++ " \\"
] <>
maybe [] pure mbMediaTypeStr <>
headersStrs <>
maybe [] pure mbReqBodyStr <>
[ " " ++ basePath ++ showPath (endpoint ^. path)
, "```"
, ""
]
where mbReqBody = listToMaybe reqBodies
mbMediaTypeStr = mkMediaTypeStr <$> mbReqBody
headersStrs = mkHeaderStr <$> hdrs
mbReqBodyStr = mkReqBodyStr <$> mbReqBody
mkMediaTypeStr (_, media_type, _) =
" -H 'Content-Type: " ++ show media_type ++ " '\\"
mkHeaderStr (hdrName, hdrVal) =
" -H '" ++ cs (CI.original hdrName) ++ ": " ++
cs hdrVal ++ "' \\"
mkReqBodyStr (_, _, body) = " -d " ++ cs body ++ " \\"
-- * Instances

1
servant-docs/test/Servant/DocsSpec.hs
View File

@ -130,7 +130,6 @@ spec = describe "Servant.Docs" $ do
md `shouldContain` "\"dt1field1\":\"field 1\""
it "contains response samples - dt1field2" $
md `shouldContain` "\"dt1field2\":13"
it "contains request body samples" $
md `shouldContain` "17"

41
servant-foreign/src/Servant/Foreign.hs
View File

@ -1,20 +1,32 @@
-- | Generalizes all the data needed to make code generation work with
-- arbitrary programming languages.
--
-- See documentation of 'HasForeignType' for a simple example. 'listFromAPI' returns a list of all your endpoints and their foreign types, given a mapping from Haskell types to foreign types (conventionally called `ftypes` below).
module Servant.Foreign
( ArgType(..)
, HeaderArg(..)
, QueryArg(..)
(
-- * Main API
listFromAPI
, Req(..)
, ReqBodyContentType(..)
, defReq
, HasForeignType(..)
, GenerateList(..)
, HasForeign(..)
, NoTypes
-- * Subtypes of 'Req'
, Url(..)
, Path
, Segment(..)
, SegmentType(..)
, Url(..)
-- aliases
, Path
, isCapture
, captureArg
, QueryArg(..)
, ArgType(..)
, HeaderArg(..)
, Arg(..)
, FunctionName(..)
, ReqBodyContentType(..)
, PathSegment(..)
-- lenses
-- * Lenses
, argName
, argType
, argPath
@ -30,7 +42,7 @@ module Servant.Foreign
, queryArgName
, queryArgType
, headerArg
-- prisms
-- * Prisms
, _PathSegment
, _HeaderArg
, _ReplaceHeaderArg
@ -39,16 +51,7 @@ module Servant.Foreign
, _Normal
, _Flag
, _List
-- rest of it
, HasForeign(..)
, HasForeignType(..)
, GenerateList(..)
, NoTypes
, captureArg
, isCapture
, defReq
, listFromAPI
-- re-exports
-- * Re-exports
, module Servant.API
, module Servant.Foreign.Inflections
) where

30
servant-foreign/src/Servant/Foreign/Inflections.hs
View File

@ -20,20 +20,31 @@ import Prelude hiding
(head, tail)
import Servant.Foreign.Internal
-- | Simply concat each part of the FunctionName together.
--
-- @[ "get", "documents", "by", "id" ] → "getdocumentsbyid"@
concatCase :: FunctionName -> Text
concatCase = view concatCaseL
concatCaseL :: Getter FunctionName Text
concatCaseL = _FunctionName . to mconcat
-- | Function name builder that simply concat each part together
concatCase :: FunctionName -> Text
concatCase = view concatCaseL
-- | Use the snake_case convention.
-- Each part is separated by a single underscore character.
--
-- @[ "get", "documents", "by", "id" ] → "get_documents_by_id"@
snakeCase :: FunctionName -> Text
snakeCase = view snakeCaseL
snakeCaseL :: Getter FunctionName Text
snakeCaseL = _FunctionName . to (intercalate "_")
-- | Function name builder using the snake_case convention.
-- each part is separated by a single underscore character.
snakeCase :: FunctionName -> Text
snakeCase = view snakeCaseL
-- | Use the camelCase convention.
-- The first part is lower case, every other part starts with an upper case character.
--
-- @[ "get", "documents", "by", "id" ] → "getDocumentsById"@
camelCase :: FunctionName -> Text
camelCase = view camelCaseL
camelCaseL :: Getter FunctionName Text
camelCaseL = _FunctionName . to convert
@ -42,8 +53,3 @@ camelCaseL = _FunctionName . to convert
convert (p:ps) = mconcat $ p : map capitalize ps
capitalize "" = ""
capitalize name = C.toUpper (head name) `cons` tail name
-- | Function name builder using the CamelCase convention.
-- each part begins with an upper case character.
camelCase :: FunctionName -> Text
camelCase = view camelCaseL

156
servant-foreign/src/Servant/Foreign/Internal.hs
View File

@ -13,8 +13,6 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Generalizes all the data needed to make code generation work with
-- arbitrary programming languages.
module Servant.Foreign.Internal where
import Prelude ()
@ -40,55 +38,75 @@ import Servant.API.Modifiers
(RequiredArgument)
import Servant.API.TypeLevel
-- | Canonical name of the endpoint, can be used to generate a function name.
--
-- You can use the functions in "Servant.Foreign.Inflections", like 'Servant.Foreign.Inflections.camelCase' to transform to `Text`.
newtype FunctionName = FunctionName { unFunctionName :: [Text] }
deriving (Data, Show, Eq, Semigroup, Monoid, Typeable)
makePrisms ''FunctionName
-- | See documentation of 'Arg'
newtype PathSegment = PathSegment { unPathSegment :: Text }
deriving (Data, Show, Eq, IsString, Semigroup, Monoid, Typeable)
makePrisms ''PathSegment
data Arg f = Arg
-- | Maps a name to the foreign type that belongs to the annotated value.
--
-- Used for header args, query args, and capture args.
data Arg ftype = Arg
{ _argName :: PathSegment
, _argType :: f }
-- ^ The name to be captured.
--
-- Only for capture args it really denotes a path segment.
, _argType :: ftype
-- ^ Foreign type the associated value will have
}
deriving (Data, Eq, Show, Typeable)
makeLenses ''Arg
argPath :: Getter (Arg f) Text
argPath :: Getter (Arg ftype) Text
argPath = argName . _PathSegment
data SegmentType f
data SegmentType ftype
= Static PathSegment
-- ^ a static path segment. like "/foo"
| Cap (Arg f)
-- ^ a capture. like "/:userid"
-- ^ Static path segment.
--
-- @"foo\/bar\/baz"@
--
-- contains the static segments @"foo"@, @"bar"@ and @"baz"@.
| Cap (Arg ftype)
-- ^ A capture.
--
-- @"user\/{userid}\/name"@
--
-- would capture the arg @userid@ with type @ftype@.
deriving (Data, Eq, Show, Typeable)
makePrisms ''SegmentType
newtype Segment f = Segment { unSegment :: SegmentType f }
-- | A part of the Url’s path.
newtype Segment ftype = Segment { unSegment :: SegmentType ftype }
deriving (Data, Eq, Show, Typeable)
makePrisms ''Segment
isCapture :: Segment f -> Bool
-- | Whether a segment is a 'Cap'.
isCapture :: Segment ftype -> Bool
isCapture (Segment (Cap _)) = True
isCapture _ = False
captureArg :: Segment f -> Arg f
-- | Crashing Arg extraction from segment, TODO: remove
captureArg :: Segment ftype -> Arg ftype
captureArg (Segment (Cap s)) = s
captureArg _ = error "captureArg called on non capture"
type Path f = [Segment f]
newtype Frag f = Frag { unFragment :: Arg f }
deriving (Data, Eq, Show, Typeable)
makePrisms ''Frag
-- TODO: remove, unnecessary indirection
type Path ftype = [Segment ftype]
-- | Type of a 'QueryArg'.
data ArgType
= Normal
| Flag
@ -97,18 +115,41 @@ data ArgType
makePrisms ''ArgType
data QueryArg f = QueryArg
{ _queryArgName :: Arg f
-- | Url Query argument.
--
-- Urls can contain query arguments, which is a list of key-value pairs.
-- In a typical url, query arguments look like this:
--
-- @?foo=bar&alist[]=el1&alist[]=el2&aflag@
--
-- Each pair can be
--
-- * @?foo=bar@: a plain key-val pair, either optional or required ('QueryParam')
-- * @?aflag@: a flag (no value, implicitly Bool with default `false` if it’s missing) ('QueryFlag')
-- * @?alist[]=el1&alist[]=el2@: list of values ('QueryParams')
--
-- @_queryArgType@ will be set accordingly.
--
-- For the plain key-val pairs ('QueryParam'), @_queryArgName@’s @ftype@ will be wrapped in a @Maybe@ if the argument is optional.
data QueryArg ftype = QueryArg
{ _queryArgName :: Arg ftype
-- ^ Name and foreign type of the argument. Will be wrapped in `Maybe` if the query is optional and in a `[]` if the query is a list
, _queryArgType :: ArgType
-- ^ one of normal/plain, list or flag
}
deriving (Data, Eq, Show, Typeable)
makeLenses ''QueryArg
data HeaderArg f = HeaderArg
{ _headerArg :: Arg f }
data HeaderArg ftype =
-- | The name of the header and the foreign type of its value.
HeaderArg
{ _headerArg :: Arg ftype }
-- | Unused, will never be set.
--
-- TODO: remove
| ReplaceHeaderArg
{ _headerArg :: Arg f
{ _headerArg :: Arg ftype
, _headerPattern :: Text
}
deriving (Data, Eq, Show, Typeable)
@ -117,29 +158,71 @@ makeLenses ''HeaderArg
makePrisms ''HeaderArg
data Url f = Url
{ _path :: Path f
, _queryStr :: [QueryArg f]
, _frag :: Maybe f
-- | Full endpoint url, with all captures and parameters
data Url ftype = Url
{ _path :: Path ftype
-- ^ Url path, list of either static segments or captures
--
-- @"foo\/{id}\/bar"@
, _queryStr :: [QueryArg ftype]
-- ^ List of query args
--
-- @"?foo=bar&a=b"@
, _frag :: Maybe ftype
-- ^ Url fragment.
--
-- Not sent to the HTTP server, so only useful for frontend matters (e.g. inter-page linking).
--
-- @#fragmentText@
}
deriving (Data, Eq, Show, Typeable)
defUrl :: Url f
defUrl :: Url ftype
defUrl = Url [] [] Nothing
makeLenses ''Url
-- | See documentation of '_reqBodyContentType'
data ReqBodyContentType = ReqBodyJSON | ReqBodyMultipart
deriving (Data, Eq, Show, Read)
data Req f = Req
{ _reqUrl :: Url f
-- | Full description of an endpoint in your API, generated by 'listFromAPI'. It should give you all the information needed to generate foreign language bindings.
--
-- Every field containing @ftype@ will use the foreign type mapping specified via 'HasForeignType' (see its docstring on how to set that up).
--
-- See https://docs.servant.dev/en/stable/tutorial/ApiType.html for accessible documentation of the possible content of an endpoint.
data Req ftype = Req
{ _reqUrl :: Url ftype
-- ^ Full list of URL segments, including captures
, _reqMethod :: HTTP.Method
, _reqHeaders :: [HeaderArg f]
, _reqBody :: Maybe f
, _reqReturnType :: Maybe f
-- ^ @\"GET\"@\/@\"POST\"@\/@\"PUT\"@\/…
, _reqHeaders :: [HeaderArg ftype]
-- ^ Headers required by this endpoint, with their type
, _reqBody :: Maybe ftype
-- ^ Foreign type of the expected request body ('ReqBody'), if any
, _reqReturnType :: Maybe ftype
-- ^ The foreign type of the response, if any
, _reqFuncName :: FunctionName
-- ^ The URL segments rendered in a way that they can be easily concatenated into a canonical function name
, _reqBodyContentType :: ReqBodyContentType
-- ^ The content type the request body is transferred as.
--
-- This is a severe limitation of @servant-foreign@ currently,
-- as we only allow the content type to be `JSON`
-- no user-defined content types. ('ReqBodyMultipart' is not
-- actually implemented.)
--
-- Thus, any routes looking like this will work:
--
-- @"foo" :> Get '[JSON] Foo@
--
-- while routes like
--
-- @"foo" :> Get '[MyFancyContentType] Foo@
--
-- will fail with an error like
--
-- @• JSON expected in list '[MyFancyContentType]@
}
deriving (Data, Eq, Show, Typeable)
@ -183,11 +266,16 @@ defReq = Req defUrl "GET" [] Nothing Nothing (FunctionName []) ReqBodyJSON
class HasForeignType lang ftype a where
typeFor :: Proxy lang -> Proxy ftype -> Proxy a -> ftype
-- | The language definition without any foreign types. It can be used for dynamic languages which do not /do/ type annotations.
data NoTypes
instance HasForeignType NoTypes NoContent ftype where
-- | Use if the foreign language does not have any types.
instance HasForeignType NoTypes NoContent a where
typeFor _ _ _ = NoContent
-- | Implementation of the Servant framework types.
--
-- Relevant instances: Everything containing 'HasForeignType'.
class HasForeign lang ftype (api :: *) where
type Foreign ftype api :: *
foreignFor :: Proxy lang -> Proxy ftype -> Proxy api -> Req ftype -> Foreign ftype api