Merge branch 'master' into 309-handle-application-exceptions-with-500-errors
This commit is contained in:
Sasa Bogicevic
commit
5b13ff4ba3
89 changed files with 2404 additions and 1495 deletions
61
.travis.yml
61
.travis.yml
|
|
@ -13,7 +13,6 @@ git:
|
|||
branches:
|
||||
only:
|
||||
- master
|
||||
- release-0.12
|
||||
|
||||
cache:
|
||||
directories:
|
||||
|
|
@ -35,19 +34,19 @@ matrix:
|
|||
include:
|
||||
- compiler: "ghc-8.4.3"
|
||||
# env: TEST=--disable-tests BENCH=--disable-benchmarks
|
||||
addons: {apt: {packages: [ghc-ppa-tools,ghc-8.4.3], sources: [hvr-ghc]}}
|
||||
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}
|
||||
- compiler: "ghc-8.2.2"
|
||||
# env: TEST=--disable-tests BENCH=--disable-benchmarks
|
||||
addons: {apt: {packages: [ghc-ppa-tools,ghc-8.2.2], sources: [hvr-ghc]}}
|
||||
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.2.2], sources: [hvr-ghc]}}
|
||||
- compiler: "ghc-8.0.2"
|
||||
# env: TEST=--disable-tests BENCH=--disable-benchmarks
|
||||
addons: {apt: {packages: [ghc-ppa-tools,ghc-8.0.2], sources: [hvr-ghc]}}
|
||||
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-8.0.2], sources: [hvr-ghc]}}
|
||||
- compiler: "ghc-7.10.3"
|
||||
# env: TEST=--disable-tests BENCH=--disable-benchmarks
|
||||
addons: {apt: {packages: [ghc-ppa-tools,ghc-7.10.3], sources: [hvr-ghc]}}
|
||||
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.10.3], sources: [hvr-ghc]}}
|
||||
- compiler: "ghc-7.8.4"
|
||||
# env: TEST=--disable-tests BENCH=--disable-benchmarks
|
||||
addons: {apt: {packages: [ghc-ppa-tools,ghc-7.8.4], sources: [hvr-ghc]}}
|
||||
addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.2,ghc-7.8.4], sources: [hvr-ghc]}}
|
||||
|
||||
before_install:
|
||||
- HC=${CC}
|
||||
|
|
@ -59,34 +58,27 @@ before_install:
|
|||
- HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') ))
|
||||
- echo $HCNUMVER
|
||||
|
||||
# Let's download "better" cabal
|
||||
- "curl -L http://oleg.fi/cabal-grayjay-buildable-fix.xz | xz -d > $HOME/.local/bin/cabal"
|
||||
- |
|
||||
if [ "$(cd $HOME/.local/bin && sha256sum cabal)" != "e281e9466b8eef30ac0d1371e8ea83c9d2e856bda4714a728ac474138b09b20f cabal" ]; then
|
||||
rm -f $HOME/.local/bin/cabal;
|
||||
sha256sum $HOME/.local/bin/cabal;
|
||||
false;
|
||||
else
|
||||
chmod a+x $HOME/.local/bin/cabal;
|
||||
fi
|
||||
|
||||
install:
|
||||
- cabal --version
|
||||
- echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]"
|
||||
- BENCH=${BENCH---enable-benchmarks}
|
||||
- TEST=${TEST---enable-tests}
|
||||
- HADDOCK=${HADDOCK-true}
|
||||
- INSTALLED=${INSTALLED-true}
|
||||
- UNCONSTRAINED=${UNCONSTRAINED-true}
|
||||
- NOINSTALLEDCONSTRAINTS=${NOINSTALLEDCONSTRAINTS-false}
|
||||
- GHCHEAD=${GHCHEAD-false}
|
||||
- travis_retry cabal update -v
|
||||
- "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config"
|
||||
- rm -fv cabal.project cabal.project.local
|
||||
- "if [ $HCNUMVER -ge 70800 ]; then sed -i.bak 's/-- ghc-options:.*/ghc-options: -j2/' ${HOME}/.cabal/config; fi"
|
||||
- grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$'
|
||||
- "printf 'packages: \"servant\" \"servant-client\" \"servant-client-core\" \"servant-docs\" \"servant-foreign\" \"servant-server\" \"doc/tutorial\" \"doc/cookbook/basic-auth\" \"doc/cookbook/db-postgres-pool\" \"doc/cookbook/db-sqlite-simple\" \"doc/cookbook/https\" \"doc/cookbook/pagination\" \"doc/cookbook/structuring-apis\" \"doc/cookbook/using-custom-monad\"\\n' > cabal.project"
|
||||
- "printf 'packages: \"servant\" \"servant-client\" \"servant-client-core\" \"servant-docs\" \"servant-foreign\" \"servant-server\" \"doc/tutorial\" \"doc/cookbook/basic-auth\" \"doc/cookbook/db-postgres-pool\" \"doc/cookbook/db-sqlite-simple\" \"doc/cookbook/file-upload\" \"doc/cookbook/https\" \"doc/cookbook/jwt-and-basic-auth\" \"doc/cookbook/pagination\" \"doc/cookbook/structuring-apis\" \"doc/cookbook/using-custom-monad\"\\n' > cabal.project"
|
||||
- "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project"
|
||||
- "echo 'allow-newer: servant-auth-server:http-types,servant-auth-server:servant-server, http-media:base' >> cabal.project"
|
||||
- cat cabal.project
|
||||
- "echo 'allow-newer: servant-auth-server:http-types,servant-auth-server:servant-server, servant-pagination:servant,servant-pagination:servant-server' >> cabal.project"
|
||||
- touch cabal.project.local
|
||||
- "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"
|
||||
- cat cabal.project || true
|
||||
- cat cabal.project.local || true
|
||||
- if [ -f "servant/configure.ac" ]; then
|
||||
(cd "servant" && autoreconf -i);
|
||||
fi
|
||||
|
|
@ -117,9 +109,15 @@ install:
|
|||
- if [ -f "doc/cookbook/db-sqlite-simple/configure.ac" ]; then
|
||||
(cd "doc/cookbook/db-sqlite-simple" && autoreconf -i);
|
||||
fi
|
||||
- if [ -f "doc/cookbook/file-upload/configure.ac" ]; then
|
||||
(cd "doc/cookbook/file-upload" && autoreconf -i);
|
||||
fi
|
||||
- if [ -f "doc/cookbook/https/configure.ac" ]; then
|
||||
(cd "doc/cookbook/https" && autoreconf -i);
|
||||
fi
|
||||
- if [ -f "doc/cookbook/jwt-and-basic-auth/configure.ac" ]; then
|
||||
(cd "doc/cookbook/jwt-and-basic-auth" && autoreconf -i);
|
||||
fi
|
||||
- if [ -f "doc/cookbook/pagination/configure.ac" ]; then
|
||||
(cd "doc/cookbook/pagination" && autoreconf -i);
|
||||
fi
|
||||
|
|
@ -130,7 +128,7 @@ install:
|
|||
(cd "doc/cookbook/using-custom-monad" && autoreconf -i);
|
||||
fi
|
||||
- rm -f cabal.project.freeze
|
||||
- rm -rf .ghc.environment.* "servant"/dist "servant-client"/dist "servant-client-core"/dist "servant-docs"/dist "servant-foreign"/dist "servant-server"/dist "doc/tutorial"/dist "doc/cookbook/basic-auth"/dist "doc/cookbook/db-postgres-pool"/dist "doc/cookbook/db-sqlite-simple"/dist "doc/cookbook/https"/dist "doc/cookbook/pagination"/dist "doc/cookbook/structuring-apis"/dist "doc/cookbook/using-custom-monad"/dist
|
||||
- rm -rf .ghc.environment.* "servant"/dist "servant-client"/dist "servant-client-core"/dist "servant-docs"/dist "servant-foreign"/dist "servant-server"/dist "doc/tutorial"/dist "doc/cookbook/basic-auth"/dist "doc/cookbook/db-postgres-pool"/dist "doc/cookbook/db-sqlite-simple"/dist "doc/cookbook/file-upload"/dist "doc/cookbook/https"/dist "doc/cookbook/jwt-and-basic-auth"/dist "doc/cookbook/pagination"/dist "doc/cookbook/structuring-apis"/dist "doc/cookbook/using-custom-monad"/dist
|
||||
- DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
|
||||
|
||||
# Here starts the actual work to be performed for the package under test;
|
||||
|
|
@ -148,22 +146,26 @@ script:
|
|||
- (cd "doc/cookbook/basic-auth" && cabal sdist)
|
||||
- (cd "doc/cookbook/db-postgres-pool" && cabal sdist)
|
||||
- (cd "doc/cookbook/db-sqlite-simple" && cabal sdist)
|
||||
- (cd "doc/cookbook/file-upload" && cabal sdist)
|
||||
- (cd "doc/cookbook/https" && cabal sdist)
|
||||
- (cd "doc/cookbook/jwt-and-basic-auth" && cabal sdist)
|
||||
- (cd "doc/cookbook/pagination" && cabal sdist)
|
||||
- (cd "doc/cookbook/structuring-apis" && cabal sdist)
|
||||
- (cd "doc/cookbook/using-custom-monad" && cabal sdist)
|
||||
- echo -en 'travis_fold:end:sdist\\r'
|
||||
- echo Unpacking... && echo -en 'travis_fold:start:unpack\\r'
|
||||
- mv "servant"/dist/servant-*.tar.gz "servant-client"/dist/servant-client-*.tar.gz "servant-client-core"/dist/servant-client-core-*.tar.gz "servant-docs"/dist/servant-docs-*.tar.gz "servant-foreign"/dist/servant-foreign-*.tar.gz "servant-server"/dist/servant-server-*.tar.gz "doc/tutorial"/dist/tutorial-*.tar.gz "doc/cookbook/basic-auth"/dist/cookbook-basic-auth-*.tar.gz "doc/cookbook/db-postgres-pool"/dist/cookbook-db-postgres-pool-*.tar.gz "doc/cookbook/db-sqlite-simple"/dist/cookbook-db-sqlite-simple-*.tar.gz "doc/cookbook/https"/dist/cookbook-https-*.tar.gz "doc/cookbook/pagination"/dist/cookbook-pagination-*.tar.gz "doc/cookbook/structuring-apis"/dist/cookbook-structuring-apis-*.tar.gz "doc/cookbook/using-custom-monad"/dist/cookbook-using-custom-monad-*.tar.gz ${DISTDIR}/
|
||||
- mv "servant"/dist/servant-*.tar.gz "servant-client"/dist/servant-client-*.tar.gz "servant-client-core"/dist/servant-client-core-*.tar.gz "servant-docs"/dist/servant-docs-*.tar.gz "servant-foreign"/dist/servant-foreign-*.tar.gz "servant-server"/dist/servant-server-*.tar.gz "doc/tutorial"/dist/tutorial-*.tar.gz "doc/cookbook/basic-auth"/dist/cookbook-basic-auth-*.tar.gz "doc/cookbook/db-postgres-pool"/dist/cookbook-db-postgres-pool-*.tar.gz "doc/cookbook/db-sqlite-simple"/dist/cookbook-db-sqlite-simple-*.tar.gz "doc/cookbook/file-upload"/dist/cookbook-file-upload-*.tar.gz "doc/cookbook/https"/dist/cookbook-https-*.tar.gz "doc/cookbook/jwt-and-basic-auth"/dist/cookbook-jwt-and-basic-auth-*.tar.gz "doc/cookbook/pagination"/dist/cookbook-pagination-*.tar.gz "doc/cookbook/structuring-apis"/dist/cookbook-structuring-apis-*.tar.gz "doc/cookbook/using-custom-monad"/dist/cookbook-using-custom-monad-*.tar.gz ${DISTDIR}/
|
||||
- cd ${DISTDIR} || false
|
||||
- find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \;
|
||||
- "printf 'packages: servant-*/*.cabal servant-client-*/*.cabal servant-client-core-*/*.cabal servant-docs-*/*.cabal servant-foreign-*/*.cabal servant-server-*/*.cabal tutorial-*/*.cabal cookbook-basic-auth-*/*.cabal cookbook-db-postgres-pool-*/*.cabal cookbook-db-sqlite-simple-*/*.cabal cookbook-https-*/*.cabal cookbook-pagination-*/*.cabal cookbook-structuring-apis-*/*.cabal cookbook-using-custom-monad-*/*.cabal\\n' > cabal.project"
|
||||
- "printf 'packages: servant-*/*.cabal servant-client-*/*.cabal servant-client-core-*/*.cabal servant-docs-*/*.cabal servant-foreign-*/*.cabal servant-server-*/*.cabal tutorial-*/*.cabal cookbook-basic-auth-*/*.cabal cookbook-db-postgres-pool-*/*.cabal cookbook-db-sqlite-simple-*/*.cabal cookbook-file-upload-*/*.cabal cookbook-https-*/*.cabal cookbook-jwt-and-basic-auth-*/*.cabal cookbook-pagination-*/*.cabal cookbook-structuring-apis-*/*.cabal cookbook-using-custom-monad-*/*.cabal\\n' > cabal.project"
|
||||
- "echo 'constraints: foundation >=0.0.14,memory <0.14.12 || >0.14.12' >> cabal.project"
|
||||
- "echo 'allow-newer: servant-auth-server:http-types,servant-auth-server:servant-server, http-media:base' >> cabal.project"
|
||||
- cat cabal.project
|
||||
- "echo 'allow-newer: servant-auth-server:http-types,servant-auth-server:servant-server, servant-pagination:servant,servant-pagination:servant-server' >> cabal.project"
|
||||
- touch cabal.project.local
|
||||
- "if ! $NOINSTALLEDCONSTRAINTS; then for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/^/constraints: /' | sed 's/-[^-]*$/ installed/' >> cabal.project.local; done; fi"
|
||||
- cat cabal.project || true
|
||||
- cat cabal.project.local || true
|
||||
- echo -en 'travis_fold:end:unpack\\r'
|
||||
|
||||
|
||||
- echo Building with tests and benchmarks... && echo -en 'travis_fold:start:build-everything\\r'
|
||||
# build & run tests, build benchmarks
|
||||
- cabal new-build -w ${HC} ${TEST} ${BENCH} all
|
||||
|
|
@ -176,5 +178,10 @@ script:
|
|||
- if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi
|
||||
|
||||
- echo -en 'travis_fold:end:haddock\\r'
|
||||
- echo Building without installed constraints for packages in global-db... && echo -en 'travis_fold:start:build-installed\\r'
|
||||
# Build without installed constraints for packages in global-db
|
||||
- if $UNCONSTRAINED; then rm -f cabal.project.local; echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks all; else echo "Not building without installed constraints"; fi
|
||||
|
||||
- echo -en 'travis_fold:end:build-installed\\r'
|
||||
# REGENDATA ["--config=cabal.make-travis-yml","--output=.travis.yml","cabal.project"]
|
||||
# EOF
|
||||
|
|
|
|||
|
|
@ -1,12 +1,11 @@
|
|||
folds: all-but-test
|
||||
branches: master release-0.12
|
||||
branches: master
|
||||
|
||||
-- We have inplace packages (servant-js) so we skip installing dependencies in a separate step
|
||||
install-dependencies-step: False
|
||||
|
||||
-- this speed-ups the build a little, but we have to check these for release
|
||||
no-tests-no-benchmarks: False
|
||||
build-with-installed-step: False
|
||||
|
||||
-- Don't run cabal check, as cookbook examples won't pass it
|
||||
cabal-check: False
|
||||
|
|
|
|||
|
|
@ -11,11 +11,10 @@ packages: servant/
|
|||
doc/cookbook/basic-auth
|
||||
doc/cookbook/db-postgres-pool
|
||||
doc/cookbook/db-sqlite-simple
|
||||
-- MkLink changed
|
||||
-- doc/cookbook/file-upload
|
||||
doc/cookbook/file-upload
|
||||
doc/cookbook/generic
|
||||
doc/cookbook/https
|
||||
-- servant-auth-* doesn't support GHC-8.4
|
||||
-- doc/cookbook/jwt-and-basic-auth
|
||||
doc/cookbook/jwt-and-basic-auth
|
||||
doc/cookbook/pagination
|
||||
doc/cookbook/structuring-apis
|
||||
doc/cookbook/using-custom-monad
|
||||
|
|
@ -30,4 +29,5 @@ constraints:
|
|||
memory <0.14.12 || >0.14.12
|
||||
|
||||
allow-newer:
|
||||
http-media:base
|
||||
servant-pagination:servant,
|
||||
servant-pagination:servant-server
|
||||
|
|
|
|||
106
doc/cookbook/generic/Generic.lhs
Normal file
106
doc/cookbook/generic/Generic.lhs
Normal file
|
|
@ -0,0 +1,106 @@
|
|||
# Using generics
|
||||
|
||||
```haskell
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
module Main (main, api, getLink, routesLinks, cliGet) where
|
||||
|
||||
import Control.Exception (throwIO)
|
||||
import Data.Proxy (Proxy (..))
|
||||
import Network.Wai.Handler.Warp (run)
|
||||
import System.Environment (getArgs)
|
||||
|
||||
import Servant
|
||||
import Servant.Client
|
||||
|
||||
import Servant.API.Generic
|
||||
import Servant.Client.Generic
|
||||
import Servant.Server.Generic
|
||||
```
|
||||
|
||||
The usage is simple, if you only need a collection of routes.
|
||||
First you define a record with field types prefixed by a parameter `route`:
|
||||
|
||||
```haskell
|
||||
data Routes route = Routes
|
||||
{ _get :: route :- Capture "id" Int :> Get '[JSON] String
|
||||
, _put :: route :- ReqBody '[JSON] Int :> Put '[JSON] Bool
|
||||
}
|
||||
deriving (Generic)
|
||||
```
|
||||
|
||||
Then we'll use this data type to define API, links, server and client.
|
||||
|
||||
## API
|
||||
|
||||
You can get a `Proxy` of the API using `genericApi`:
|
||||
|
||||
```haskell
|
||||
api :: Proxy (ToServantApi Routes)
|
||||
api = genericApi (Proxy :: Proxy Routes)
|
||||
```
|
||||
|
||||
It's recommented to use `genericApi` function, as then you'll get
|
||||
better error message, for example if you forget to `derive Generic`.
|
||||
|
||||
## Links
|
||||
|
||||
The clear advantage of record-based generics approach, is that
|
||||
we can get safe links very conviently. We don't need to define endpoint types,
|
||||
as field accessors work as proxies:
|
||||
|
||||
```haskell
|
||||
getLink :: Int -> Link
|
||||
getLink = fieldLink _get
|
||||
```
|
||||
|
||||
We can also get all links at once, as a record:
|
||||
|
||||
```haskell
|
||||
routesLinks :: Routes (AsLink Link)
|
||||
routesLinks = allFieldLinks
|
||||
```
|
||||
|
||||
## Client
|
||||
|
||||
Even more power starts to show when we generate a record of client functions.
|
||||
Here we use `genericClientHoist` function, which let us simultaneously
|
||||
hoist the monad, in this case from `ClientM` to `IO`.
|
||||
|
||||
```haskell
|
||||
cliRoutes :: Routes (AsClientT IO)
|
||||
cliRoutes = genericClientHoist
|
||||
(\x -> runClientM x env >>= either throwIO return)
|
||||
where
|
||||
env = error "undefined environment"
|
||||
|
||||
cliGet :: Int -> IO String
|
||||
cliGet = _get cliRoutes
|
||||
```
|
||||
|
||||
## Server
|
||||
|
||||
Finally, probably the most handy usage: we can convert record of handlers into
|
||||
the server implementation:
|
||||
|
||||
```haskell
|
||||
record :: Routes AsServer
|
||||
record = Routes
|
||||
{ _get = return . show
|
||||
, _put = return . odd
|
||||
}
|
||||
|
||||
app :: Application
|
||||
app = genericServe record
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
args <- getArgs
|
||||
case args of
|
||||
("run":_) -> do
|
||||
putStrLn "Starting cookbook-generic at http://localhost:8000"
|
||||
run 8000 app
|
||||
_ -> putStrLn "To run, pass 'run' argument: cabal new-run cookbook-generic run"
|
||||
```
|
||||
25
doc/cookbook/generic/generic.cabal
Normal file
25
doc/cookbook/generic/generic.cabal
Normal file
|
|
@ -0,0 +1,25 @@
|
|||
name: cookbook-generic
|
||||
version: 0.1
|
||||
synopsis: Using custom monad to pass a state between handlers
|
||||
homepage: http://haskell-servant.readthedocs.org/
|
||||
license: BSD3
|
||||
license-file: ../../../servant/LICENSE
|
||||
author: Servant Contributors
|
||||
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||
build-type: Simple
|
||||
cabal-version: >=1.10
|
||||
tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3
|
||||
|
||||
executable cookbook-using-custom-monad
|
||||
main-is: Generic.lhs
|
||||
build-depends: base == 4.*
|
||||
, servant
|
||||
, servant-client
|
||||
, servant-client-core
|
||||
, servant-server
|
||||
, base-compat
|
||||
, warp >= 3.2
|
||||
, transformers >= 0.3
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -pgmL markdown-unlit
|
||||
build-tool-depends: markdown-unlit:markdown-unlit >= 0.4
|
||||
|
|
@ -18,6 +18,7 @@ you name it!
|
|||
:maxdepth: 1
|
||||
|
||||
structuring-apis/StructuringApis.lhs
|
||||
generic/Generic.lhs
|
||||
https/Https.lhs
|
||||
db-sqlite-simple/DBConnection.lhs
|
||||
db-postgres-pool/PostgresPool.lhs
|
||||
|
|
|
|||
|
|
@ -3,22 +3,24 @@ servant – A Type-Level Web DSL
|
|||
|
||||
.. image:: https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png
|
||||
|
||||
**servant** is a set of packages for declaring web APIs at the type-level and
|
||||
then using those API specifications to:
|
||||
**servant** is a set of Haskell libraries for writing *type-safe* web
|
||||
applications but also *deriving* clients (in Haskell and other languages) or
|
||||
generating documentation for them, and more.
|
||||
|
||||
- write servers (this part of **servant** can be considered a web framework),
|
||||
- obtain client functions (in haskell),
|
||||
- generate client functions for other programming languages,
|
||||
- generate documentation for your web applications
|
||||
- and more...
|
||||
This is achieved by taking as input a description of the web API
|
||||
as a Haskell type. Servant is then able to check that your server-side request
|
||||
handlers indeed implement your web API faithfully, or to automatically derive
|
||||
Haskell functions that can hit a web application that implements this API,
|
||||
generate a Swagger description or code for client functions in some other
|
||||
languages directly.
|
||||
|
||||
All in a type-safe manner.
|
||||
If you would like to learn more, click the tutorial link below.
|
||||
|
||||
.. toctree::
|
||||
:maxdepth: 2
|
||||
|
||||
introduction.rst
|
||||
tutorial/index.rst
|
||||
cookbook/index.rst
|
||||
examples.md
|
||||
links.rst
|
||||
principles.rst
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
Introduction
|
||||
------------
|
||||
Principles
|
||||
----------
|
||||
|
||||
**servant** has the following guiding principles:
|
||||
|
||||
|
|
@ -477,7 +477,7 @@ data AngularOptions = AngularOptions
|
|||
}
|
||||
```
|
||||
|
||||
# Custom function name builder
|
||||
## Custom function name builder
|
||||
|
||||
Servant comes with three name builders included:
|
||||
|
||||
|
|
@ -518,4 +518,3 @@ var get_books = function(q, onSuccess, onError)
|
|||
}
|
||||
|
||||
```
|
||||
|
||||
|
|
|
|||
|
|
@ -3,9 +3,28 @@ Tutorial
|
|||
|
||||
This is an introductory tutorial to **servant**. Whilst browsing is fine, it makes more sense if you read the sections in order, or at least read the first section before anything else.
|
||||
|
||||
(Any comments, issues or feedback about the tutorial can be submitted
|
||||
to `servant's issue tracker <http://github.com/haskell-servant/servant/issues>`_.)
|
||||
Any comments, issues or feedback about the tutorial can be submitted
|
||||
to `servant's issue tracker <http://github.com/haskell-servant/servant/issues>`_.
|
||||
|
||||
In fact, the whole tutorial is a `cabal <https://cabal.readthedocs.io/en/latest/>`_
|
||||
project and can be built and played with locally as follows:
|
||||
|
||||
.. code-block:: bash
|
||||
|
||||
$ git clone https://github.com/haskell-servant/servant.git
|
||||
$ cd servant
|
||||
# build
|
||||
$ cabal new-build tutorial
|
||||
# load in ghci to play with it
|
||||
$ cabal new-repl tutorial
|
||||
|
||||
The code can be found in the `*.lhs` files under `doc/tutorial/` in the
|
||||
repository. Feel free to edit it while you're reading this documentation and
|
||||
see the effect of your changes.
|
||||
|
||||
`Nix <https://nixos.org/nix/>`_ users should feel free to take a look at
|
||||
the `nix/shell.nix` file in the repository and use it to provision a suitable
|
||||
environment to build and run the examples.
|
||||
|
||||
.. toctree::
|
||||
:maxdepth: 1
|
||||
|
|
|
|||
|
|
@ -75,8 +75,8 @@ library
|
|||
, time >= 1.4.2 && < 1.9
|
||||
|
||||
-- For legacy tools, we need to specify build-depends too
|
||||
build-depends: markdown-unlit >= 0.4.1 && <0.5
|
||||
build-tool-depends: markdown-unlit:markdown-unlit >= 0.4.1 && <0.5
|
||||
build-depends: markdown-unlit >= 0.5.0 && <0.6
|
||||
build-tool-depends: markdown-unlit:markdown-unlit >= 0.5.0 && <0.6
|
||||
|
||||
test-suite spec
|
||||
type: exitcode-stdio-1.0
|
||||
|
|
|
|||
|
|
@ -1,13 +1,61 @@
|
|||
[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client-core/CHANGELOG.md)
|
||||
[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
|
||||
|
||||
0.14.1
|
||||
------
|
||||
|
||||
- Merge in `servant-generic` (by [Patrick Chilton](https://github.com/chpatrick))
|
||||
into `servant` (`Servant.API.Generic`),
|
||||
`servant-client-code` (`Servant.Client.Generic`)
|
||||
and `servant-server` (`Servant.Server.Generic`).
|
||||
|
||||
0.14
|
||||
----
|
||||
|
||||
- Add a `hoistClientMonad` method to the `HasClient` typeclass, for
|
||||
changing the monad in which client functions run.
|
||||
- `Stream` takes a status code argument
|
||||
|
||||
```diff
|
||||
-Stream method framing ctype a
|
||||
+Stream method status framing ctype a
|
||||
```
|
||||
|
||||
([#966](https://github.com/haskell-servant/servant/pull/966)
|
||||
[#972](https://github.com/haskell-servant/servant/pull/972))
|
||||
|
||||
- `ToStreamGenerator` definition changed, so it's possible to write an instance
|
||||
for conduits.
|
||||
|
||||
```diff
|
||||
-class ToStreamGenerator f a where
|
||||
- toStreamGenerator :: f a -> StreamGenerator a
|
||||
+class ToStreamGenerator a b | a -> b where
|
||||
+ toStreamGenerator :: a -> StreamGenerator b
|
||||
```
|
||||
|
||||
([#959](https://github.com/haskell-servant/servant/pull/959))
|
||||
|
||||
- Added `NoFraming` streaming strategy
|
||||
([#959](https://github.com/haskell-servant/servant/pull/959))
|
||||
|
||||
- *servant-client-core* Free `Client` implementation.
|
||||
Useful for testing `HasClient` instances.
|
||||
([#920](https://github.com/haskell-servant/servant/pull/920))
|
||||
|
||||
- *servant-client-core* Add `hoistClient` to `HasClient`.
|
||||
Just like `hoistServer` allows us to change the monad in which request handlers
|
||||
of a web application live in, we also have `hoistClient` for changing the monad
|
||||
in which *client functions* live.
|
||||
Read [tutorial section for more information](https://haskell-servant.readthedocs.io/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in).
|
||||
([#936](https://github.com/haskell-servant/servant/pull/936))
|
||||
|
||||
iF you have own combinators, you'll need to define a new method of
|
||||
`HasClient` class, for example:
|
||||
|
||||
```haskell
|
||||
type Client m (MyCombinator :> api) = MyValue :> Client m api
|
||||
hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy api) nt . cl
|
||||
```
|
||||
|
||||
0.13.0.1
|
||||
--------
|
||||
|
||||
|
|
|
|||
|
|
@ -1,2 +1,2 @@
|
|||
import Distribution.Simple
|
||||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
name: servant-client-core
|
||||
version: 0.13
|
||||
version: 0.14.1
|
||||
synopsis: Core functionality and class for client function generation for servant APIs
|
||||
description:
|
||||
This library provides backend-agnostic generation of client functions. For
|
||||
|
|
@ -33,6 +33,7 @@ library
|
|||
exposed-modules:
|
||||
Servant.Client.Core
|
||||
Servant.Client.Free
|
||||
Servant.Client.Generic
|
||||
Servant.Client.Core.Reexport
|
||||
Servant.Client.Core.Internal.Auth
|
||||
Servant.Client.Core.Internal.BaseUrl
|
||||
|
|
@ -51,30 +52,30 @@ library
|
|||
base >= 4.7 && < 4.12
|
||||
, bytestring >= 0.10.4.0 && < 0.11
|
||||
, containers >= 0.5.5.1 && < 0.6
|
||||
, mtl >= 2.1 && < 2.3
|
||||
, text >= 1.2.3.0 && < 1.3
|
||||
, transformers >= 0.3.0.0 && < 0.6
|
||||
|
||||
if !impl(ghc >= 8.0)
|
||||
build-depends:
|
||||
semigroups >=0.18.3 && <0.19
|
||||
semigroups >=0.18.4 && <0.19
|
||||
|
||||
-- Servant dependencies
|
||||
build-depends:
|
||||
servant == 0.13.*
|
||||
servant >= 0.14.1 && <0.15
|
||||
|
||||
-- Other dependencies: Lower bound around what is in the latest Stackage LTS.
|
||||
-- Here can be exceptions if we really need features from the newer versions.
|
||||
build-depends:
|
||||
base-compat >= 0.9.3 && < 0.11
|
||||
base-compat >= 0.10.1 && < 0.11
|
||||
, base64-bytestring >= 1.0.0.1 && < 1.1
|
||||
, exceptions >= 0.8.3 && < 0.11
|
||||
, free >= 5.0.1 && < 5.1
|
||||
, generics-sop >= 0.3.1.0 && < 0.4
|
||||
, http-api-data >= 0.3.7.1 && < 0.4
|
||||
, http-media >= 0.7.1.1 && < 0.8
|
||||
, http-types >= 0.12 && < 0.13
|
||||
, exceptions >= 0.10.0 && < 0.11
|
||||
, free >= 5.0.2 && < 5.2
|
||||
, generics-sop >= 0.3.2.0 && < 0.4
|
||||
, http-api-data >= 0.3.8.1 && < 0.4
|
||||
, http-media >= 0.7.1.2 && < 0.8
|
||||
, http-types >= 0.12.1 && < 0.13
|
||||
, network-uri >= 2.6.1.0 && < 2.7
|
||||
, safe >= 0.3.15 && < 0.4
|
||||
, safe >= 0.3.17 && < 0.4
|
||||
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
|
|
@ -99,8 +100,8 @@ test-suite spec
|
|||
-- Additonal dependencies
|
||||
build-depends:
|
||||
deepseq >= 1.3.0.2 && <1.5
|
||||
, hspec >= 2.4.4 && <2.6
|
||||
, QuickCheck >= 2.10.1 && < 2.12
|
||||
, hspec >= 2.4.1 && <2.6
|
||||
, QuickCheck >= 2.11.3 && < 2.12
|
||||
|
||||
build-tool-depends:
|
||||
hspec-discover:hspec-discover >= 2.4.4 && <2.6
|
||||
hspec-discover:hspec-discover >= 2.5.1 && <2.6
|
||||
|
|
|
|||
|
|
@ -55,13 +55,11 @@ module Servant.Client.Core
|
|||
, setRequestBody
|
||||
) where
|
||||
import Servant.Client.Core.Internal.Auth
|
||||
import Servant.Client.Core.Internal.BaseUrl (BaseUrl (..),
|
||||
InvalidBaseUrlException,
|
||||
Scheme (..),
|
||||
parseBaseUrl,
|
||||
showBaseUrl)
|
||||
import Servant.Client.Core.Internal.BaseUrl
|
||||
(BaseUrl (..), InvalidBaseUrlException, Scheme (..),
|
||||
parseBaseUrl, showBaseUrl)
|
||||
import Servant.Client.Core.Internal.BasicAuth
|
||||
import Servant.Client.Core.Internal.HasClient
|
||||
import Servant.Client.Core.Internal.Generic
|
||||
import Servant.Client.Core.Internal.HasClient
|
||||
import Servant.Client.Core.Internal.Request
|
||||
import Servant.Client.Core.Internal.RunClient
|
||||
|
|
|
|||
|
|
@ -6,7 +6,8 @@
|
|||
|
||||
module Servant.Client.Core.Internal.Auth where
|
||||
|
||||
import Servant.Client.Core.Internal.Request (Request)
|
||||
import Servant.Client.Core.Internal.Request
|
||||
(Request)
|
||||
|
||||
-- | For a resource protected by authentication (e.g. AuthProtect), we need
|
||||
-- to provide the client with some data used to add authentication data
|
||||
|
|
|
|||
|
|
@ -3,11 +3,13 @@
|
|||
{-# LANGUAGE ViewPatterns #-}
|
||||
module Servant.Client.Core.Internal.BaseUrl where
|
||||
|
||||
import Control.Monad.Catch (Exception, MonadThrow, throwM)
|
||||
import Control.Monad.Catch
|
||||
(Exception, MonadThrow, throwM)
|
||||
import Data.List
|
||||
import Data.Typeable
|
||||
import GHC.Generics
|
||||
import Network.URI hiding (path)
|
||||
import Network.URI hiding
|
||||
(path)
|
||||
import Safe
|
||||
import Text.Read
|
||||
|
||||
|
|
|
|||
|
|
@ -6,11 +6,16 @@
|
|||
|
||||
module Servant.Client.Core.Internal.BasicAuth where
|
||||
|
||||
import Data.ByteString.Base64 (encode)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
import Servant.API.BasicAuth (BasicAuthData (BasicAuthData))
|
||||
import Servant.Client.Core.Internal.Request (Request, addHeader)
|
||||
import Data.ByteString.Base64
|
||||
(encode)
|
||||
import Data.Monoid
|
||||
((<>))
|
||||
import Data.Text.Encoding
|
||||
(decodeUtf8)
|
||||
import Servant.API.BasicAuth
|
||||
(BasicAuthData (BasicAuthData))
|
||||
import Servant.Client.Core.Internal.Request
|
||||
(Request, addHeader)
|
||||
|
||||
-- | Authenticate a request using Basic Authentication
|
||||
basicAuthReq :: BasicAuthData -> Request -> Request
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
{-# LANGUAGE DeriveFunctor #-}
|
||||
module Servant.Client.Core.Internal.ClientF where
|
||||
|
||||
import Servant.Client.Core.Internal.Request
|
||||
import Servant.Client.Core.Internal.Request
|
||||
|
||||
data ClientF a
|
||||
= RunRequest Request (Response -> a)
|
||||
|
|
|
|||
|
|
@ -1,19 +1,21 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DefaultSignatures #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DefaultSignatures #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
#include "overlapping-compat.h"
|
||||
|
||||
module Servant.Client.Core.Internal.Generic where
|
||||
|
||||
import Generics.SOP (Code, Generic, I(..), NP(..), NS(Z), SOP(..), to)
|
||||
import Servant.API ((:<|>)(..))
|
||||
import Generics.SOP
|
||||
(Code, Generic, I (..), NP (..), NS (Z), SOP (..), to)
|
||||
import Servant.API
|
||||
((:<|>) (..))
|
||||
|
||||
-- | This class allows us to match client structure with client functions
|
||||
-- produced with 'client' without explicit pattern-matching.
|
||||
|
|
|
|||
|
|
@ -15,53 +15,46 @@
|
|||
#include "overlapping-compat.h"
|
||||
module Servant.Client.Core.Internal.HasClient where
|
||||
|
||||
import Prelude ()
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Concurrent (newMVar, modifyMVar)
|
||||
import Data.Foldable (toList)
|
||||
import Control.Concurrent
|
||||
(modifyMVar, newMVar)
|
||||
import Control.Monad.IO.Class
|
||||
(MonadIO (..))
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.List (foldl')
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import Data.Semigroup ((<>))
|
||||
import Data.Sequence (fromList)
|
||||
import Data.String (fromString)
|
||||
import Data.Text (Text, pack)
|
||||
import GHC.TypeLits (KnownSymbol, symbolVal)
|
||||
import Data.Foldable
|
||||
(toList)
|
||||
import Data.List
|
||||
(foldl')
|
||||
import Data.Proxy
|
||||
(Proxy (Proxy))
|
||||
import Data.Semigroup
|
||||
((<>))
|
||||
import Data.Sequence
|
||||
(fromList)
|
||||
import Data.String
|
||||
(fromString)
|
||||
import Data.Text
|
||||
(Text, pack)
|
||||
import GHC.TypeLits
|
||||
(KnownSymbol, symbolVal)
|
||||
import qualified Network.HTTP.Types as H
|
||||
import Servant.API ((:<|>) ((:<|>)), (:>),
|
||||
AuthProtect, BasicAuth,
|
||||
BasicAuthData,
|
||||
BuildHeadersTo (..),
|
||||
BuildFromStream (..),
|
||||
ByteStringParser (..),
|
||||
Capture', CaptureAll,
|
||||
Description, EmptyAPI,
|
||||
FramingUnrender (..),
|
||||
Header', Headers (..),
|
||||
HttpVersion, IsSecure,
|
||||
MimeRender (mimeRender),
|
||||
MimeUnrender (mimeUnrender),
|
||||
NoContent (NoContent),
|
||||
QueryFlag, QueryParam',
|
||||
QueryParams, Raw,
|
||||
ReflectMethod (..),
|
||||
RemoteHost, ReqBody',
|
||||
ResultStream(..),
|
||||
SBoolI,
|
||||
Stream,
|
||||
Summary, ToHttpApiData,
|
||||
Vault, Verb,
|
||||
WithNamedContext,
|
||||
contentType,
|
||||
getHeadersHList,
|
||||
getResponse,
|
||||
toQueryParam,
|
||||
toUrlPiece)
|
||||
import Servant.API.ContentTypes (contentTypes)
|
||||
import Servant.API.Modifiers (FoldRequired,
|
||||
RequiredArgument,
|
||||
foldRequiredArgument)
|
||||
import Servant.API
|
||||
((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth, BasicAuthData,
|
||||
BuildHeadersTo (..), ByteStringParser (..), Capture',
|
||||
CaptureAll, Description, EmptyAPI, FramingUnrender (..),
|
||||
FromResultStream (..), Header', Headers (..), HttpVersion,
|
||||
IsSecure, MimeRender (mimeRender),
|
||||
MimeUnrender (mimeUnrender), NoContent (NoContent), QueryFlag,
|
||||
QueryParam', QueryParams, Raw, ReflectMethod (..), RemoteHost,
|
||||
ReqBody', ResultStream (..), SBoolI, Stream, Summary,
|
||||
ToHttpApiData, Vault, Verb, WithNamedContext, contentType,
|
||||
getHeadersHList, getResponse, toQueryParam, toUrlPiece)
|
||||
import Servant.API.ContentTypes
|
||||
(contentTypes)
|
||||
import Servant.API.Modifiers
|
||||
(FoldRequired, RequiredArgument, foldRequiredArgument)
|
||||
|
||||
import Servant.Client.Core.Internal.Auth
|
||||
import Servant.Client.Core.Internal.BasicAuth
|
||||
|
|
@ -283,18 +276,18 @@ instance OVERLAPPING_
|
|||
hoistClientMonad _ _ f ma = f ma
|
||||
|
||||
instance OVERLAPPABLE_
|
||||
( RunClient m, MimeUnrender ct a, ReflectMethod method,
|
||||
FramingUnrender framing a, BuildFromStream a (f a)
|
||||
) => HasClient m (Stream method status framing ct (f a)) where
|
||||
( RunClient m, MonadIO m, MimeUnrender ct a, ReflectMethod method,
|
||||
FramingUnrender framing a, FromResultStream a b
|
||||
) => HasClient m (Stream method status framing ct b) where
|
||||
|
||||
type Client m (Stream method status framing ct (f a)) = m (f a)
|
||||
type Client m (Stream method status framing ct b) = m b
|
||||
|
||||
clientWithRoute _pm Proxy req = do
|
||||
sresp <- streamingRequest req
|
||||
{ requestAccept = fromList [contentType (Proxy :: Proxy ct)]
|
||||
, requestMethod = reflectMethod (Proxy :: Proxy method)
|
||||
}
|
||||
return . buildFromStream $ ResultStream $ \k ->
|
||||
liftIO $ fromResultStream $ ResultStream $ \k ->
|
||||
runStreamingResponse sresp $ \gres -> do
|
||||
let reader = responseBody gres
|
||||
let unrender = unrenderFrames (Proxy :: Proxy framing) (Proxy :: Proxy a)
|
||||
|
|
|
|||
|
|
@ -12,26 +12,34 @@
|
|||
|
||||
module Servant.Client.Core.Internal.Request where
|
||||
|
||||
import Prelude ()
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Monad.Catch (Exception)
|
||||
import Control.Monad.Catch
|
||||
(Exception)
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Builder as Builder
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.Int (Int64)
|
||||
import Data.Semigroup ((<>))
|
||||
import Data.Int
|
||||
(Int64)
|
||||
import Data.Semigroup
|
||||
((<>))
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (encodeUtf8)
|
||||
import Data.Typeable (Typeable)
|
||||
import GHC.Generics (Generic)
|
||||
import Network.HTTP.Media (MediaType)
|
||||
import Network.HTTP.Types (Header, HeaderName, HttpVersion,
|
||||
Method, QueryItem, Status, http11,
|
||||
methodGet)
|
||||
import Web.HttpApiData (ToHttpApiData, toEncodedUrlPiece,
|
||||
toHeader)
|
||||
import Data.Text
|
||||
(Text)
|
||||
import Data.Text.Encoding
|
||||
(encodeUtf8)
|
||||
import Data.Typeable
|
||||
(Typeable)
|
||||
import GHC.Generics
|
||||
(Generic)
|
||||
import Network.HTTP.Media
|
||||
(MediaType)
|
||||
import Network.HTTP.Types
|
||||
(Header, HeaderName, HttpVersion, Method, QueryItem, Status,
|
||||
http11, methodGet)
|
||||
import Web.HttpApiData
|
||||
(ToHttpApiData, toEncodedUrlPiece, toHeader)
|
||||
|
||||
-- | A type representing possible errors in a request
|
||||
--
|
||||
|
|
|
|||
|
|
@ -6,24 +6,27 @@
|
|||
-- | Types for possible backends to run client-side `Request` queries
|
||||
module Servant.Client.Core.Internal.RunClient where
|
||||
|
||||
import Prelude ()
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Monad (unless)
|
||||
import Control.Monad.Free (Free (..), liftF)
|
||||
import Data.Foldable (toList)
|
||||
import Data.Proxy (Proxy)
|
||||
import Control.Monad
|
||||
(unless)
|
||||
import Control.Monad.Free
|
||||
(Free (..), liftF)
|
||||
import Data.Foldable
|
||||
(toList)
|
||||
import Data.Proxy
|
||||
(Proxy)
|
||||
import qualified Data.Text as T
|
||||
import Network.HTTP.Media (MediaType, matches,
|
||||
parseAccept, (//))
|
||||
import Servant.API (MimeUnrender,
|
||||
contentTypes,
|
||||
mimeUnrender)
|
||||
import Network.HTTP.Media
|
||||
(MediaType, matches, parseAccept, (//))
|
||||
import Servant.API
|
||||
(MimeUnrender, contentTypes, mimeUnrender)
|
||||
|
||||
import Servant.Client.Core.Internal.Request (Request, Response, GenResponse (..),
|
||||
StreamingResponse (..),
|
||||
ServantError (..))
|
||||
import Servant.Client.Core.Internal.ClientF
|
||||
import Servant.Client.Core.Internal.Request
|
||||
(GenResponse (..), Request, Response, ServantError (..),
|
||||
StreamingResponse (..))
|
||||
|
||||
class Monad m => RunClient m where
|
||||
-- | How to make a request.
|
||||
|
|
|
|||
|
|
@ -28,6 +28,6 @@ module Servant.Client.Core.Reexport
|
|||
|
||||
|
||||
import Servant.Client.Core.Internal.BaseUrl
|
||||
import Servant.Client.Core.Internal.HasClient
|
||||
import Servant.Client.Core.Internal.Generic
|
||||
import Servant.Client.Core.Internal.HasClient
|
||||
import Servant.Client.Core.Internal.Request
|
||||
|
|
|
|||
|
|
@ -1,15 +1,18 @@
|
|||
{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, GADTs #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
module Servant.Client.Free (
|
||||
client,
|
||||
ClientF (..),
|
||||
module Servant.Client.Core.Reexport,
|
||||
) where
|
||||
|
||||
import Data.Proxy (Proxy (..))
|
||||
import Control.Monad.Free
|
||||
import Servant.Client.Core
|
||||
import Servant.Client.Core.Reexport
|
||||
import Servant.Client.Core.Internal.ClientF
|
||||
import Control.Monad.Free
|
||||
import Data.Proxy
|
||||
(Proxy (..))
|
||||
import Servant.Client.Core
|
||||
import Servant.Client.Core.Internal.ClientF
|
||||
import Servant.Client.Core.Reexport
|
||||
|
||||
client :: HasClient (Free ClientF) api => Proxy api -> Client (Free ClientF) api
|
||||
client api = api `clientIn` (Proxy :: Proxy (Free ClientF))
|
||||
|
|
|
|||
51
servant-client-core/src/Servant/Client/Generic.hs
Normal file
51
servant-client-core/src/Servant/Client/Generic.hs
Normal file
|
|
@ -0,0 +1,51 @@
|
|||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
module Servant.Client.Generic (
|
||||
AsClientT,
|
||||
genericClient,
|
||||
genericClientHoist,
|
||||
) where
|
||||
|
||||
import Data.Proxy
|
||||
(Proxy (..))
|
||||
|
||||
import Servant.API.Generic
|
||||
import Servant.Client.Core
|
||||
|
||||
-- | A type that specifies that an API reocrd contains a client implementation.
|
||||
data AsClientT (m :: * -> *)
|
||||
instance GenericMode (AsClientT m) where
|
||||
type AsClientT m :- api = Client m api
|
||||
|
||||
-- | Generate a record of client functions.
|
||||
genericClient
|
||||
:: forall routes m.
|
||||
( HasClient m (ToServantApi routes)
|
||||
, GenericServant routes (AsClientT m)
|
||||
, Client m (ToServantApi routes) ~ ToServant routes (AsClientT m)
|
||||
)
|
||||
=> routes (AsClientT m)
|
||||
genericClient
|
||||
= fromServant
|
||||
$ clientIn (Proxy :: Proxy (ToServantApi routes)) (Proxy :: Proxy m)
|
||||
|
||||
-- | 'genericClient' but with 'hoistClientMonad' in between.
|
||||
genericClientHoist
|
||||
:: forall routes m n.
|
||||
( HasClient m (ToServantApi routes)
|
||||
, GenericServant routes (AsClientT n)
|
||||
, Client n (ToServantApi routes) ~ ToServant routes (AsClientT n)
|
||||
)
|
||||
=> (forall x. m x -> n x) -- ^ natural transformation
|
||||
-> routes (AsClientT n)
|
||||
genericClientHoist nt
|
||||
= fromServant
|
||||
$ hoistClientMonad m api nt
|
||||
$ clientIn api m
|
||||
where
|
||||
m = Proxy :: Proxy m
|
||||
api = Proxy :: Proxy (ToServantApi routes)
|
||||
|
|
@ -1,5 +1,5 @@
|
|||
name: servant-client-ghcjs
|
||||
version: 0.13
|
||||
version: 0.14
|
||||
synopsis: automatical derivation of querying functions for servant webservices for ghcjs
|
||||
description:
|
||||
This library lets you automatically derive Haskell functions that
|
||||
|
|
@ -43,7 +43,7 @@ library
|
|||
, monad-control >= 1.0.0.4 && < 1.1
|
||||
, mtl >= 2.1 && < 2.3
|
||||
, semigroupoids >= 4.3 && < 5.3
|
||||
, servant-client-core == 0.13.*
|
||||
, servant-client-core == 0.14.*
|
||||
, string-conversions >= 0.3 && < 0.5
|
||||
, transformers >= 0.3 && < 0.6
|
||||
, transformers-base >= 0.4.4 && < 0.5
|
||||
|
|
|
|||
|
|
@ -26,6 +26,7 @@ import Control.Monad.Trans.Control (MonadBaseControl (..))
|
|||
import Control.Monad.Trans.Except
|
||||
import Data.ByteString.Builder (toLazyByteString)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.CaseInsensitive
|
||||
import Data.Char
|
||||
import Data.Foldable (toList)
|
||||
|
|
@ -34,11 +35,14 @@ import Data.IORef (modifyIORef, newIORef, readIORef)
|
|||
import Data.Proxy (Proxy (..))
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.String.Conversions
|
||||
import Data.Typeable (Typeable)
|
||||
import Foreign.StablePtr
|
||||
import GHC.Generics
|
||||
import qualified GHCJS.Buffer as Buffer
|
||||
import GHCJS.Foreign.Callback
|
||||
import GHCJS.Prim
|
||||
import GHCJS.Types
|
||||
import JavaScript.TypedArray.ArrayBuffer ( ArrayBuffer )
|
||||
import JavaScript.Web.Location
|
||||
import Network.HTTP.Media (renderHeader)
|
||||
import Network.HTTP.Types
|
||||
|
|
@ -48,14 +52,34 @@ newtype JSXMLHttpRequest = JSXMLHttpRequest JSVal
|
|||
|
||||
newtype JSXMLHttpRequestClass = JSXMLHttpRequestClass JSVal
|
||||
|
||||
-- | The environment in which a request is run.
|
||||
newtype ClientEnv
|
||||
= ClientEnv
|
||||
{ baseUrl :: BaseUrl }
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Generates a set of client functions for an API.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- > type API = Capture "no" Int :> Get '[JSON] Int
|
||||
-- > :<|> Get '[JSON] [Bool]
|
||||
-- >
|
||||
-- > api :: Proxy API
|
||||
-- > api = Proxy
|
||||
-- >
|
||||
-- > getInt :: Int -> ClientM Int
|
||||
-- > getBools :: ClientM [Bool]
|
||||
-- > getInt :<|> getBools = client api
|
||||
--
|
||||
-- NOTE: Does not support constant space streaming of the request body!
|
||||
client :: HasClient ClientM api => Proxy api -> Client ClientM api
|
||||
client api = api `clientIn` (Proxy :: Proxy ClientM)
|
||||
|
||||
-- | @ClientM@ is the monad in which client functions run. Contains the
|
||||
-- 'BaseUrl' used for requests in the reader environment.
|
||||
--
|
||||
-- NOTE: Does not support constant space streaming of the request body!
|
||||
newtype ClientM a = ClientM
|
||||
{ runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }
|
||||
deriving ( Functor, Applicative, Monad, MonadIO, Generic
|
||||
|
|
@ -76,8 +100,15 @@ instance MonadBaseControl IO ClientM where
|
|||
instance Alt ClientM where
|
||||
a <!> b = a `catchError` const b
|
||||
|
||||
data StreamingNotSupportedException = StreamingNotSupportedException
|
||||
deriving ( Typeable, Show )
|
||||
|
||||
instance Exception StreamingNotSupportedException where
|
||||
displayException _ = "streamingRequest: streaming is not supported!"
|
||||
|
||||
instance RunClient ClientM where
|
||||
runRequest = performRequest
|
||||
streamingRequest _ = liftIO $ throwIO StreamingNotSupportedException
|
||||
throwServantError = throwError
|
||||
|
||||
instance ClientLike (ClientM a) (ClientM a) where
|
||||
|
|
@ -153,6 +184,7 @@ performXhr xhr burl request = do
|
|||
|
||||
openXhr xhr (cs $ requestMethod request) (toUrl burl request) True
|
||||
setHeaders xhr request
|
||||
js_setResponseType xhr "arraybuffer"
|
||||
body <- toBody request
|
||||
sendXhr xhr body
|
||||
takeMVar waiter
|
||||
|
|
@ -187,6 +219,9 @@ openXhr xhr method url =
|
|||
foreign import javascript unsafe "$1.open($2, $3, $4)"
|
||||
js_openXhr :: JSXMLHttpRequest -> JSVal -> JSVal -> Bool -> IO ()
|
||||
|
||||
foreign import javascript unsafe "$1.responseType = $2;"
|
||||
js_setResponseType :: JSXMLHttpRequest -> JSString -> IO ()
|
||||
|
||||
toUrl :: BaseUrl -> Request -> String
|
||||
toUrl burl request =
|
||||
let pathS = cs $ toLazyByteString $ requestPath request
|
||||
|
|
@ -217,35 +252,38 @@ setHeaders xhr request = do
|
|||
foreign import javascript unsafe "$1.setRequestHeader($2, $3)"
|
||||
js_setRequestHeader :: JSXMLHttpRequest -> JSVal -> JSVal -> IO ()
|
||||
|
||||
sendXhr :: JSXMLHttpRequest -> Maybe String -> IO ()
|
||||
sendXhr :: JSXMLHttpRequest -> Maybe ArrayBuffer -> IO ()
|
||||
sendXhr xhr Nothing = js_sendXhr xhr
|
||||
sendXhr xhr (Just body) =
|
||||
js_sendXhrWithBody xhr (toJSString body)
|
||||
js_sendXhrWithBody xhr body
|
||||
|
||||
foreign import javascript unsafe "$1.send()"
|
||||
js_sendXhr :: JSXMLHttpRequest -> IO ()
|
||||
|
||||
foreign import javascript unsafe "$1.send($2)"
|
||||
js_sendXhrWithBody :: JSXMLHttpRequest -> JSVal -> IO ()
|
||||
js_sendXhrWithBody :: JSXMLHttpRequest -> ArrayBuffer -> IO ()
|
||||
|
||||
toBody :: Request -> IO (Maybe String)
|
||||
toBody :: Request -> IO (Maybe ArrayBuffer)
|
||||
toBody request = case requestBody request of
|
||||
Nothing -> return Nothing
|
||||
Just (a, _) -> go a
|
||||
Just (a, _) -> Just <$> go a
|
||||
|
||||
where
|
||||
go :: RequestBody -> IO (Maybe String)
|
||||
go :: RequestBody -> IO ArrayBuffer
|
||||
go x = case x of
|
||||
RequestBodyLBS x -> return $ mBody x
|
||||
RequestBodyLBS x -> return $ mBody $ BL.toStrict x
|
||||
RequestBodyBS x -> return $ mBody x
|
||||
RequestBodyBuilder _ x -> return $ mBody $ toLazyByteString x
|
||||
RequestBodyBuilder _ x -> return $ mBody $ BL.toStrict $ toLazyByteString x
|
||||
RequestBodyStream _ x -> mBody <$> readBody x
|
||||
RequestBodyStreamChunked x -> mBody <$> readBody x
|
||||
RequestBodyIO x -> x >>= go
|
||||
|
||||
mBody :: ConvertibleStrings a String => a -> Maybe String
|
||||
mBody x = let y = cs x in if y == "" then Nothing else Just y
|
||||
mBody :: BS.ByteString -> ArrayBuffer
|
||||
mBody bs = js_bufferSlice offset len $ Buffer.getArrayBuffer buffer
|
||||
where
|
||||
(buffer, offset, len) = Buffer.fromByteString bs
|
||||
|
||||
readBody :: ((IO BS.ByteString -> IO ()) -> IO a) -> IO BS.ByteString
|
||||
readBody writer = do
|
||||
m <- newIORef mempty
|
||||
_ <- writer (\bsAct -> do
|
||||
|
|
@ -253,6 +291,8 @@ toBody request = case requestBody request of
|
|||
modifyIORef m (<> bs))
|
||||
readIORef m
|
||||
|
||||
foreign import javascript unsafe "$3.slice($1, $1 + $2)"
|
||||
js_bufferSlice :: Int -> Int -> ArrayBuffer -> ArrayBuffer
|
||||
|
||||
-- * inspecting the xhr response
|
||||
|
||||
|
|
@ -266,10 +306,10 @@ toResponse xhr = do
|
|||
_ -> liftIO $ do
|
||||
statusText <- cs <$> getStatusText xhr
|
||||
headers <- parseHeaders <$> getAllResponseHeaders xhr
|
||||
responseText <- cs <$> getResponseText xhr
|
||||
response <- getResponse xhr
|
||||
pure Response
|
||||
{ responseStatusCode = mkStatus status statusText
|
||||
, responseBody = responseText
|
||||
, responseBody = response
|
||||
, responseHeaders = Seq.fromList headers
|
||||
, responseHttpVersion = http11 -- this is made up
|
||||
}
|
||||
|
|
@ -288,14 +328,19 @@ getAllResponseHeaders xhr =
|
|||
foreign import javascript unsafe "$1.getAllResponseHeaders()"
|
||||
js_getAllResponseHeaders :: JSXMLHttpRequest -> IO JSVal
|
||||
|
||||
getResponseText :: JSXMLHttpRequest -> IO String
|
||||
getResponseText xhr = fromJSString <$> js_responseText xhr
|
||||
foreign import javascript unsafe "$1.responseText"
|
||||
js_responseText :: JSXMLHttpRequest -> IO JSVal
|
||||
getResponse :: JSXMLHttpRequest -> IO BL.ByteString
|
||||
getResponse xhr =
|
||||
BL.fromStrict
|
||||
. Buffer.toByteString 0 Nothing
|
||||
. Buffer.createFromArrayBuffer
|
||||
<$> js_response xhr
|
||||
|
||||
foreign import javascript unsafe "$1.response"
|
||||
js_response :: JSXMLHttpRequest -> IO ArrayBuffer
|
||||
|
||||
parseHeaders :: String -> ResponseHeaders
|
||||
parseHeaders s =
|
||||
(first mk . first strip . second strip . parseHeader) <$>
|
||||
first mk . first strip . second strip . parseHeader <$>
|
||||
splitOn "\r\n" (cs s)
|
||||
where
|
||||
parseHeader :: BS.ByteString -> (BS.ByteString, BS.ByteString)
|
||||
|
|
|
|||
|
|
@ -4,10 +4,45 @@
|
|||
0.14
|
||||
----
|
||||
|
||||
- Add `hoistClient` for changing the monad in which
|
||||
client functions run.
|
||||
- `Stream` takes a status code argument
|
||||
|
||||
```diff
|
||||
-Stream method framing ctype a
|
||||
+Stream method status framing ctype a
|
||||
```
|
||||
|
||||
([#966](https://github.com/haskell-servant/servant/pull/966)
|
||||
[#972](https://github.com/haskell-servant/servant/pull/972))
|
||||
|
||||
- `ToStreamGenerator` definition changed, so it's possible to write an instance
|
||||
for conduits.
|
||||
|
||||
```diff
|
||||
-class ToStreamGenerator f a where
|
||||
- toStreamGenerator :: f a -> StreamGenerator a
|
||||
+class ToStreamGenerator a b | a -> b where
|
||||
+ toStreamGenerator :: a -> StreamGenerator b
|
||||
```
|
||||
|
||||
([#959](https://github.com/haskell-servant/servant/pull/959))
|
||||
|
||||
- Added `NoFraming` streaming strategy
|
||||
([#959](https://github.com/haskell-servant/servant/pull/959))
|
||||
|
||||
- *servant-client-core* Add `hoistClient` to `HasClient`.
|
||||
Just like `hoistServer` allows us to change the monad in which request handlers
|
||||
of a web application live in, we also have `hoistClient` for changing the monad
|
||||
in which *client functions* live.
|
||||
Read [tutorial section for more information](https://haskell-servant.readthedocs.io/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in).
|
||||
([#936](https://github.com/haskell-servant/servant/pull/936))
|
||||
|
||||
- *servant-client* Add more constructors to `RequestBody`, including
|
||||
`RequestBodyStream`.
|
||||
*Note:* we are looking for http-library agnostic API,
|
||||
so the might change again soon.
|
||||
Tell us which constructors are useful for you!
|
||||
([#913](https://github.com/haskell-servant/servant/pull/913))
|
||||
|
||||
0.13.0.1
|
||||
--------
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
name: servant-client
|
||||
version: 0.13.0.1
|
||||
version: 0.14
|
||||
synopsis: automatical derivation of querying functions for servant webservices
|
||||
description:
|
||||
This library lets you derive automatically Haskell functions that
|
||||
|
|
@ -51,28 +51,25 @@ library
|
|||
, transformers >= 0.3.0.0 && < 0.6
|
||||
|
||||
if !impl(ghc >= 8.0)
|
||||
build-depends: semigroups >=0.18.3 && <0.19
|
||||
build-depends: semigroups >=0.18.4 && <0.19
|
||||
|
||||
-- Servant dependencies
|
||||
build-depends:
|
||||
servant-client-core == 0.13.*
|
||||
servant-client-core == 0.14.*
|
||||
|
||||
-- Other dependencies: Lower bound around what is in the latest Stackage LTS.
|
||||
-- Here can be exceptions if we really need features from the newer versions.
|
||||
build-depends:
|
||||
aeson >= 1.2.3.0 && < 1.4
|
||||
, base-compat >= 0.9.3 && < 0.11
|
||||
, attoparsec >= 0.13.2.0 && < 0.14
|
||||
, http-client >= 0.5.7.1 && < 0.6
|
||||
, http-client-tls >= 0.3.5.1 && < 0.4
|
||||
, http-media >= 0.7.1.1 && < 0.8
|
||||
, http-types >= 0.12 && < 0.13
|
||||
, exceptions >= 0.8.3 && < 0.11
|
||||
, monad-control >= 1.0.0.4 && < 1.1
|
||||
, semigroupoids >= 5.2.1 && < 5.3
|
||||
, stm >= 2.4.4.1 && < 2.5
|
||||
, transformers-base >= 0.4.4 && < 0.5
|
||||
, transformers-compat >= 0.5.1 && < 0.7
|
||||
base-compat >= 0.10.1 && < 0.11
|
||||
, http-client >= 0.5.12 && < 0.6
|
||||
, http-media >= 0.7.1.2 && < 0.8
|
||||
, http-types >= 0.12.1 && < 0.13
|
||||
, exceptions >= 0.10.0 && < 0.11
|
||||
, monad-control >= 1.0.2.3 && < 1.1
|
||||
, semigroupoids >= 5.2.2 && < 5.3
|
||||
, stm >= 2.4.5.0 && < 2.5
|
||||
, transformers-base >= 0.4.5.2 && < 0.5
|
||||
, transformers-compat >= 0.6.2 && < 0.7
|
||||
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
|
|
@ -97,10 +94,8 @@ test-suite spec
|
|||
, aeson
|
||||
, base-compat
|
||||
, bytestring
|
||||
, containers
|
||||
, http-api-data
|
||||
, http-client
|
||||
, http-media
|
||||
, http-types
|
||||
, mtl
|
||||
, servant-client
|
||||
|
|
@ -117,18 +112,16 @@ test-suite spec
|
|||
|
||||
-- Additonal dependencies
|
||||
build-depends:
|
||||
deepseq >= 1.3.0.2 && < 1.5
|
||||
, generics-sop >= 0.3.1.0 && < 0.4
|
||||
, hspec >= 2.4.4 && < 2.6
|
||||
generics-sop >= 0.3.2.0 && < 0.4
|
||||
, hspec >= 2.5.1 && < 2.6
|
||||
, HUnit >= 1.6 && < 1.7
|
||||
, random-bytestring >= 0.1 && < 0.2
|
||||
, network >= 2.6.3.2 && < 2.8
|
||||
, QuickCheck >= 2.10.1 && < 2.12
|
||||
, servant == 0.13.*
|
||||
, servant-server == 0.13.*
|
||||
, servant == 0.14.*
|
||||
, servant-server == 0.14.*
|
||||
|
||||
build-tool-depends:
|
||||
hspec-discover:hspec-discover >= 2.4.4 && < 2.6
|
||||
hspec-discover:hspec-discover >= 2.5.1 && < 2.6
|
||||
|
||||
test-suite readme
|
||||
type: exitcode-stdio-1.0
|
||||
|
|
@ -136,3 +129,4 @@ test-suite readme
|
|||
build-depends: base, servant, http-client, text, servant-client, markdown-unlit
|
||||
build-tool-depends: markdown-unlit:markdown-unlit
|
||||
ghc-options: -pgmL markdown-unlit
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
|
|
@ -13,5 +13,5 @@ module Servant.Client
|
|||
, module Servant.Client.Core.Reexport
|
||||
) where
|
||||
|
||||
import Servant.Client.Core.Reexport
|
||||
import Servant.Client.Internal.HttpClient
|
||||
import Servant.Client.Core.Reexport
|
||||
import Servant.Client.Internal.HttpClient
|
||||
|
|
|
|||
|
|
@ -11,34 +11,49 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
module Servant.Client.Internal.HttpClient where
|
||||
|
||||
import Prelude ()
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Concurrent.STM.TVar
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Control.Monad.Base (MonadBase (..))
|
||||
import Control.Monad.Catch (MonadCatch, MonadThrow)
|
||||
import Control.Monad.Error.Class (MonadError (..))
|
||||
import Control.Monad.Base
|
||||
(MonadBase (..))
|
||||
import Control.Monad.Catch
|
||||
(MonadCatch, MonadThrow)
|
||||
import Control.Monad.Error.Class
|
||||
(MonadError (..))
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.STM (atomically)
|
||||
import Control.Monad.Trans.Control (MonadBaseControl (..))
|
||||
import Control.Monad.STM
|
||||
(atomically)
|
||||
import Control.Monad.Trans.Control
|
||||
(MonadBaseControl (..))
|
||||
import Control.Monad.Trans.Except
|
||||
import Data.ByteString.Builder (toLazyByteString)
|
||||
import Data.ByteString.Builder
|
||||
(toLazyByteString)
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import Data.Foldable (toList, for_)
|
||||
import Data.Functor.Alt (Alt (..))
|
||||
import Data.Maybe (maybeToList)
|
||||
import Data.Semigroup ((<>))
|
||||
import Data.Proxy (Proxy (..))
|
||||
import Data.Sequence (fromList)
|
||||
import Data.String (fromString)
|
||||
import Data.Foldable
|
||||
(for_, toList)
|
||||
import Data.Functor.Alt
|
||||
(Alt (..))
|
||||
import Data.Maybe
|
||||
(maybeToList)
|
||||
import Data.Proxy
|
||||
(Proxy (..))
|
||||
import Data.Semigroup
|
||||
((<>))
|
||||
import Data.Sequence
|
||||
(fromList)
|
||||
import Data.String
|
||||
(fromString)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Data.Time.Clock
|
||||
(getCurrentTime)
|
||||
import GHC.Generics
|
||||
import Network.HTTP.Media (renderHeader)
|
||||
import Network.HTTP.Types (hContentType, renderQuery,
|
||||
statusCode)
|
||||
import Network.HTTP.Media
|
||||
(renderHeader)
|
||||
import Network.HTTP.Types
|
||||
(hContentType, renderQuery, statusCode)
|
||||
import Servant.Client.Core
|
||||
|
||||
import qualified Network.HTTP.Client as Client
|
||||
|
|
|
|||
|
|
@ -26,56 +26,53 @@
|
|||
#include "overlapping-compat.h"
|
||||
module Servant.ClientSpec (spec, Person(..), startWaiApp, endWaiApp) where
|
||||
|
||||
import Prelude ()
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Arrow (left)
|
||||
import Control.Concurrent (ThreadId, forkIO,
|
||||
killThread)
|
||||
import Control.Exception (bracket)
|
||||
import Control.Monad.Error.Class (throwError)
|
||||
import Control.Arrow
|
||||
(left)
|
||||
import Control.Concurrent
|
||||
(ThreadId, forkIO, killThread)
|
||||
import Control.Exception
|
||||
(bracket)
|
||||
import Control.Monad.Error.Class
|
||||
(throwError)
|
||||
import Data.Aeson
|
||||
import Data.Char (chr, isPrint)
|
||||
import Data.Foldable (forM_)
|
||||
import Data.Semigroup ((<>))
|
||||
import Data.Monoid ()
|
||||
import Data.Char
|
||||
(chr, isPrint)
|
||||
import Data.Foldable
|
||||
(forM_)
|
||||
import Data.Monoid ()
|
||||
import Data.Proxy
|
||||
import Data.Semigroup
|
||||
((<>))
|
||||
import qualified Generics.SOP as SOP
|
||||
import GHC.Generics (Generic)
|
||||
import GHC.Generics
|
||||
(Generic)
|
||||
import qualified Network.HTTP.Client as C
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import Network.Socket
|
||||
import qualified Network.Wai as Wai
|
||||
import Network.Wai.Handler.Warp
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import System.IO.Unsafe
|
||||
(unsafePerformIO)
|
||||
import Test.Hspec
|
||||
import Test.Hspec.QuickCheck
|
||||
import Test.HUnit
|
||||
import Test.QuickCheck
|
||||
import Web.FormUrlEncoded (FromForm, ToForm)
|
||||
import Web.FormUrlEncoded
|
||||
(FromForm, ToForm)
|
||||
|
||||
import Servant.API ((:<|>) ((:<|>)),
|
||||
(:>), AuthProtect,
|
||||
BasicAuth,
|
||||
BasicAuthData (..),
|
||||
Capture,
|
||||
CaptureAll, Delete,
|
||||
DeleteNoContent,
|
||||
EmptyAPI, addHeader,
|
||||
FormUrlEncoded,
|
||||
Get, Header,
|
||||
Headers, JSON,
|
||||
NoContent (NoContent),
|
||||
Post, Put, Raw,
|
||||
QueryFlag,
|
||||
QueryParam,
|
||||
QueryParams,
|
||||
ReqBody,
|
||||
getHeaders)
|
||||
import Servant.API
|
||||
((:<|>) ((:<|>)), (:>), AuthProtect, BasicAuth,
|
||||
BasicAuthData (..), Capture, CaptureAll, Delete,
|
||||
DeleteNoContent, EmptyAPI, FormUrlEncoded, Get, Header,
|
||||
Headers, JSON, NoContent (NoContent), Post, Put, QueryFlag,
|
||||
QueryParam, QueryParams, Raw, ReqBody, addHeader, getHeaders)
|
||||
import Servant.API.Internal.Test.ComprehensiveAPI
|
||||
import Servant.Client
|
||||
import qualified Servant.Client.Core.Internal.Request as Req
|
||||
import qualified Servant.Client.Core.Internal.Auth as Auth
|
||||
import qualified Servant.Client.Core.Internal.Auth as Auth
|
||||
import qualified Servant.Client.Core.Internal.Request as Req
|
||||
import Servant.Server
|
||||
import Servant.Server.Experimental.Auth
|
||||
|
||||
|
|
|
|||
|
|
@ -26,31 +26,36 @@
|
|||
#include "overlapping-compat.h"
|
||||
module Servant.StreamSpec (spec) where
|
||||
|
||||
import Control.Monad (replicateM_, void)
|
||||
import Control.Monad
|
||||
(replicateM_, void)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Proxy
|
||||
import qualified Network.HTTP.Client as C
|
||||
import Prelude ()
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
import System.IO (IOMode (ReadMode), withFile)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import System.IO
|
||||
(IOMode (ReadMode), withFile)
|
||||
import System.IO.Unsafe
|
||||
(unsafePerformIO)
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
|
||||
import Servant.API ((:<|>) ((:<|>)), (:>), JSON,
|
||||
NetstringFraming, NewlineFraming,
|
||||
OctetStream, ResultStream (..),
|
||||
StreamGenerator (..), StreamGet,
|
||||
NoFraming)
|
||||
import Servant.API
|
||||
((:<|>) ((:<|>)), (:>), JSON, NetstringFraming,
|
||||
NewlineFraming, NoFraming, OctetStream, ResultStream (..),
|
||||
StreamGenerator (..), StreamGet)
|
||||
import Servant.Client
|
||||
import Servant.ClientSpec (Person (..))
|
||||
import Servant.ClientSpec
|
||||
(Person (..))
|
||||
import qualified Servant.ClientSpec as CS
|
||||
import Servant.Server
|
||||
|
||||
#if MIN_VERSION_base(4,10,0)
|
||||
import GHC.Stats (gcdetails_mem_in_use_bytes, gc, getRTSStats)
|
||||
import GHC.Stats
|
||||
(gc, gcdetails_mem_in_use_bytes, getRTSStats)
|
||||
#else
|
||||
import GHC.Stats (currentBytesUsed, getGCStats)
|
||||
import GHC.Stats
|
||||
(currentBytesUsed, getGCStats)
|
||||
#endif
|
||||
|
||||
spec :: Spec
|
||||
|
|
@ -107,12 +112,12 @@ manager' = unsafePerformIO $ C.newManager C.defaultManagerSettings
|
|||
runClient :: ClientM a -> BaseUrl -> IO (Either ServantError a)
|
||||
runClient x baseUrl' = runClientM x (mkClientEnv manager' baseUrl')
|
||||
|
||||
runResultStream :: ResultStream a
|
||||
testRunResultStream :: ResultStream a
|
||||
-> IO ( Maybe (Either String a)
|
||||
, Maybe (Either String a)
|
||||
, Maybe (Either String a)
|
||||
, Maybe (Either String a))
|
||||
runResultStream (ResultStream k)
|
||||
testRunResultStream (ResultStream k)
|
||||
= k $ \act -> (,,,) <$> act <*> act <*> act <*> act
|
||||
|
||||
streamSpec :: Spec
|
||||
|
|
@ -122,14 +127,15 @@ streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do
|
|||
Right res <- runClient getGetNL baseUrl
|
||||
let jra = Just (Right alice)
|
||||
jrb = Just (Right bob)
|
||||
runResultStream res `shouldReturn` (jra, jrb, jra, Nothing)
|
||||
testRunResultStream res `shouldReturn` (jra, jrb, jra, Nothing)
|
||||
|
||||
it "works with Servant.API.StreamGet.Netstring" $ \(_, baseUrl) -> do
|
||||
Right res <- runClient getGetNS baseUrl
|
||||
let jra = Just (Right alice)
|
||||
jrb = Just (Right bob)
|
||||
runResultStream res `shouldReturn` (jra, jrb, jra, Nothing)
|
||||
testRunResultStream res `shouldReturn` (jra, jrb, jra, Nothing)
|
||||
|
||||
{-
|
||||
it "streams in constant memory" $ \(_, baseUrl) -> do
|
||||
Right (ResultStream res) <- runClient getGetALot baseUrl
|
||||
let consumeNChunks n = replicateM_ n (res void)
|
||||
|
|
@ -140,6 +146,7 @@ streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do
|
|||
memUsed <- currentBytesUsed <$> getGCStats
|
||||
#endif
|
||||
memUsed `shouldSatisfy` (< megabytes 22)
|
||||
-}
|
||||
|
||||
megabytes :: Num a => a -> a
|
||||
megabytes n = n * (1000 ^ (2 :: Int))
|
||||
|
|
|
|||
|
|
@ -5,14 +5,15 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
import Control.Lens
|
||||
import Data.Aeson
|
||||
import Data.Proxy
|
||||
import Data.String.Conversions
|
||||
import Data.Text (Text)
|
||||
import GHC.Generics
|
||||
import Servant.API
|
||||
import Servant.Docs
|
||||
import Control.Lens
|
||||
import Data.Aeson
|
||||
import Data.Proxy
|
||||
import Data.String.Conversions
|
||||
import Data.Text
|
||||
(Text)
|
||||
import GHC.Generics
|
||||
import Servant.API
|
||||
import Servant.Docs
|
||||
|
||||
-- * Example
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
name: servant-docs
|
||||
version: 0.11.2
|
||||
x-revision: 2
|
||||
x-revision: 5
|
||||
synopsis: generate API docs for your servant webservice
|
||||
description:
|
||||
Library for generating API docs from a servant API definition.
|
||||
|
|
@ -53,20 +53,20 @@ library
|
|||
|
||||
-- Servant dependencies
|
||||
build-depends:
|
||||
servant == 0.13.*
|
||||
servant == 0.13.* || ==0.14.*
|
||||
|
||||
-- Other dependencies: Lower bound around what is in the latest Stackage LTS.
|
||||
-- Here can be exceptions if we really need features from the newer versions.
|
||||
build-depends:
|
||||
aeson >= 1.2.3.0 && < 1.4
|
||||
aeson >= 1.2.3.0 && < 1.5
|
||||
, aeson-pretty >= 0.8.5 && < 0.9
|
||||
, base-compat >= 0.9.3 && < 0.11
|
||||
, case-insensitive >= 1.2.0.10 && < 1.3
|
||||
, control-monad-omega >= 0.3.1 && < 0.4
|
||||
, hashable >= 1.2.6.1 && < 1.3
|
||||
, http-media >= 0.7.1.1 && < 0.8
|
||||
, http-media >= 0.7.0 && < 0.8
|
||||
, http-types >= 0.12 && < 0.13
|
||||
, lens >= 4.15.4 && < 4.17
|
||||
, lens >= 4.15.4 && < 4.18
|
||||
, string-conversions >= 0.4.0.1 && < 0.5
|
||||
, unordered-containers >= 0.2.8.0 && < 0.3
|
||||
|
||||
|
|
|
|||
|
|
@ -56,5 +56,5 @@ module Servant.Docs
|
|||
, single
|
||||
) where
|
||||
|
||||
import Servant.Docs.Internal
|
||||
import Servant.Docs.Internal.Pretty
|
||||
import Servant.Docs.Internal
|
||||
import Servant.Docs.Internal.Pretty
|
||||
|
|
|
|||
|
|
@ -20,33 +20,45 @@
|
|||
#include "overlapping-compat.h"
|
||||
module Servant.Docs.Internal where
|
||||
|
||||
import Prelude ()
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Arrow (second)
|
||||
import Control.Lens (makeLenses, mapped, over,
|
||||
traversed, view, (%~), (&), (.~),
|
||||
(<>~), (^.), (|>))
|
||||
import Control.Arrow
|
||||
(second)
|
||||
import Control.Lens
|
||||
(makeLenses, mapped, over, traversed, view, (%~), (&), (.~),
|
||||
(<>~), (^.), (|>))
|
||||
import qualified Control.Monad.Omega as Omega
|
||||
import qualified Data.ByteString.Char8 as BSC
|
||||
import Data.ByteString.Lazy.Char8 (ByteString)
|
||||
import Data.ByteString.Lazy.Char8
|
||||
(ByteString)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Data.Foldable (fold)
|
||||
import Data.Hashable (Hashable)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.List.Compat (intercalate, intersperse, sort)
|
||||
import Data.List.NonEmpty (NonEmpty ((:|)), groupWith)
|
||||
import Data.Foldable
|
||||
(fold)
|
||||
import Data.Hashable
|
||||
(Hashable)
|
||||
import Data.HashMap.Strict
|
||||
(HashMap)
|
||||
import Data.List.Compat
|
||||
(intercalate, intersperse, sort)
|
||||
import Data.List.NonEmpty
|
||||
(NonEmpty ((:|)), groupWith)
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import Data.Maybe
|
||||
import Data.Monoid (All (..), Any (..), Dual (..),
|
||||
First (..), Last (..),
|
||||
Product (..), Sum (..))
|
||||
import Data.Ord (comparing)
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import Data.Semigroup (Semigroup (..))
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Text (Text, unpack)
|
||||
import Data.Monoid
|
||||
(All (..), Any (..), Dual (..), First (..), Last (..),
|
||||
Product (..), Sum (..))
|
||||
import Data.Ord
|
||||
(comparing)
|
||||
import Data.Proxy
|
||||
(Proxy (Proxy))
|
||||
import Data.Semigroup
|
||||
(Semigroup (..))
|
||||
import Data.String.Conversions
|
||||
(cs)
|
||||
import Data.Text
|
||||
(Text, unpack)
|
||||
import GHC.Generics
|
||||
import GHC.TypeLits
|
||||
import Servant.API
|
||||
|
|
@ -840,6 +852,24 @@ instance OVERLAPPABLE_
|
|||
status = fromInteger $ natVal (Proxy :: Proxy status)
|
||||
p = Proxy :: Proxy a
|
||||
|
||||
-- | TODO: mention the endpoint is streaming, its framing strategy
|
||||
--
|
||||
-- Also there are no samples.
|
||||
instance OVERLAPPABLE_
|
||||
(MimeRender ct a, KnownNat status
|
||||
, ReflectMethod method)
|
||||
=> HasDocs (Stream method status framing ct a) where
|
||||
docsFor Proxy (endpoint, action) DocOptions{..} =
|
||||
single endpoint' action'
|
||||
|
||||
where endpoint' = endpoint & method .~ method'
|
||||
action' = action & response.respTypes .~ allMime t
|
||||
& response.respStatus .~ status
|
||||
t = Proxy :: Proxy '[ct]
|
||||
method' = reflectMethod (Proxy :: Proxy method)
|
||||
status = fromInteger $ natVal (Proxy :: Proxy status)
|
||||
p = Proxy :: Proxy a
|
||||
|
||||
instance OVERLAPPING_
|
||||
(ToSample a, AllMimeRender (ct ': cts) a, KnownNat status
|
||||
, ReflectMethod method, AllHeaderSamples ls, GetHeaders (HList ls))
|
||||
|
|
|
|||
|
|
@ -4,16 +4,20 @@
|
|||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Servant.Docs.Internal.Pretty where
|
||||
|
||||
import Data.Aeson (ToJSON(..))
|
||||
import Data.Aeson.Encode.Pretty (encodePretty)
|
||||
import Data.Proxy (Proxy(Proxy))
|
||||
import Network.HTTP.Media ((//))
|
||||
import Servant.API
|
||||
import Data.Aeson
|
||||
(ToJSON (..))
|
||||
import Data.Aeson.Encode.Pretty
|
||||
(encodePretty)
|
||||
import Data.Proxy
|
||||
(Proxy (Proxy))
|
||||
import Network.HTTP.Media
|
||||
((//))
|
||||
import Servant.API
|
||||
|
||||
-- | PrettyJSON content type.
|
||||
data PrettyJSON
|
||||
|
|
|
|||
|
|
@ -20,7 +20,8 @@ import Control.Lens
|
|||
import Data.Aeson
|
||||
import Data.Monoid
|
||||
import Data.Proxy
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.String.Conversions
|
||||
(cs)
|
||||
import GHC.Generics
|
||||
import Test.Hspec
|
||||
|
||||
|
|
|
|||
|
|
@ -1,2 +1,2 @@
|
|||
import Distribution.Simple
|
||||
import Distribution.Simple
|
||||
main = defaultMain
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
name: servant-foreign
|
||||
version: 0.11.1
|
||||
x-revision: 3
|
||||
synopsis: Helpers for generating clients for servant APIs in any programming language
|
||||
description:
|
||||
Helper types and functions for generating client functions for servant APIs in any programming language
|
||||
|
|
@ -52,13 +53,13 @@ library
|
|||
|
||||
-- Servant dependencies
|
||||
build-depends:
|
||||
servant == 0.13.*
|
||||
servant == 0.13.* || ==0.14.*
|
||||
|
||||
-- Other dependencies: Lower bound around what is in the latest Stackage LTS.
|
||||
-- Here can be exceptions if we really need features from the newer versions.
|
||||
build-depends:
|
||||
base-compat >= 0.9.3 && <0.11
|
||||
, lens >= 4.15.4 && <4.17
|
||||
, lens >= 4.15.4 && <4.18
|
||||
, http-types >= 0.12 && < 0.13
|
||||
|
||||
hs-source-dirs: src
|
||||
|
|
|
|||
|
|
@ -51,6 +51,6 @@ module Servant.Foreign
|
|||
, module Servant.Foreign.Inflections
|
||||
) where
|
||||
|
||||
import Servant.API
|
||||
import Servant.Foreign.Internal
|
||||
import Servant.Foreign.Inflections
|
||||
import Servant.API
|
||||
import Servant.Foreign.Inflections
|
||||
import Servant.Foreign.Internal
|
||||
|
|
|
|||
|
|
@ -10,11 +10,14 @@ module Servant.Foreign.Inflections
|
|||
) where
|
||||
|
||||
|
||||
import Control.Lens hiding (cons)
|
||||
import qualified Data.Char as C
|
||||
import Control.Lens hiding
|
||||
(cons)
|
||||
import qualified Data.Char as C
|
||||
import Data.Monoid
|
||||
import Data.Text hiding (map)
|
||||
import Prelude hiding (head, tail)
|
||||
import Data.Text hiding
|
||||
(map)
|
||||
import Prelude hiding
|
||||
(head, tail)
|
||||
import Servant.Foreign.Internal
|
||||
|
||||
concatCaseL :: Getter FunctionName Text
|
||||
|
|
|
|||
|
|
@ -1,42 +1,47 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
#if !MIN_VERSION_base(4,8,0)
|
||||
{-# LANGUAGE NullaryTypeClasses #-}
|
||||
{-# LANGUAGE NullaryTypeClasses #-}
|
||||
#endif
|
||||
|
||||
-- | Generalizes all the data needed to make code generation work with
|
||||
-- arbitrary programming languages.
|
||||
module Servant.Foreign.Internal where
|
||||
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Lens (makePrisms, makeLenses, Getter, (&), (<>~), (%~),
|
||||
(.~))
|
||||
import Data.Data (Data)
|
||||
import Control.Lens
|
||||
(Getter, makeLenses, makePrisms, (%~), (&), (.~), (<>~))
|
||||
import Data.Data
|
||||
(Data)
|
||||
import Data.Proxy
|
||||
import Data.Semigroup (Semigroup)
|
||||
import Data.Semigroup
|
||||
(Semigroup)
|
||||
import Data.String
|
||||
import Data.Text
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Text.Encoding (decodeUtf8)
|
||||
import Data.Text.Encoding
|
||||
(decodeUtf8)
|
||||
import Data.Typeable
|
||||
(Typeable)
|
||||
import GHC.TypeLits
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import Servant.API
|
||||
import Servant.API.Modifiers
|
||||
(RequiredArgument)
|
||||
import Servant.API.TypeLevel
|
||||
import Servant.API.Modifiers (RequiredArgument)
|
||||
|
||||
newtype FunctionName = FunctionName { unFunctionName :: [Text] }
|
||||
deriving (Data, Show, Eq, Semigroup, Monoid, Typeable)
|
||||
|
|
@ -238,6 +243,20 @@ instance (Elem JSON list, HasForeignType lang ftype a, ReflectMethod method)
|
|||
method = reflectMethod (Proxy :: Proxy method)
|
||||
methodLC = toLower $ decodeUtf8 method
|
||||
|
||||
-- | TODO: doesn't taking framing into account.
|
||||
instance (ct ~ JSON, HasForeignType lang ftype a, ReflectMethod method)
|
||||
=> HasForeign lang ftype (Stream method status framing ct a) where
|
||||
type Foreign ftype (Stream method status framing ct a) = Req ftype
|
||||
|
||||
foreignFor lang Proxy Proxy req =
|
||||
req & reqFuncName . _FunctionName %~ (methodLC :)
|
||||
& reqMethod .~ method
|
||||
& reqReturnType .~ Just retType
|
||||
where
|
||||
retType = typeFor lang (Proxy :: Proxy ftype) (Proxy :: Proxy a)
|
||||
method = reflectMethod (Proxy :: Proxy method)
|
||||
methodLC = toLower $ decodeUtf8 method
|
||||
|
||||
instance (KnownSymbol sym, HasForeignType lang ftype (RequiredArgument mods a), HasForeign lang ftype api)
|
||||
=> HasForeign lang ftype (Header' mods sym a :> api) where
|
||||
type Foreign ftype (Header' mods sym a :> api) = Foreign ftype api
|
||||
|
|
|
|||
|
|
@ -1,14 +1,14 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
#if __GLASGOW_HASKELL__ < 709
|
||||
{-# OPTIONS_GHC -fcontext-stack=41 #-}
|
||||
#endif
|
||||
|
|
@ -16,12 +16,13 @@
|
|||
|
||||
module Servant.ForeignSpec where
|
||||
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Proxy
|
||||
import Servant.Foreign
|
||||
import Servant.API.Internal.Test.ComprehensiveAPI
|
||||
import Data.Monoid
|
||||
((<>))
|
||||
import Data.Proxy
|
||||
import Servant.API.Internal.Test.ComprehensiveAPI
|
||||
import Servant.Foreign
|
||||
|
||||
import Test.Hspec
|
||||
import Test.Hspec
|
||||
|
||||
|
||||
spec :: Spec
|
||||
|
|
|
|||
|
|
@ -1,6 +1,62 @@
|
|||
[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-server/CHANGELOG.md)
|
||||
[Changelog for `servant` package contains significant entries for all core packages.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
|
||||
|
||||
0.14.1
|
||||
------
|
||||
|
||||
- Merge in `servant-generic` (by [Patrick Chilton](https://github.com/chpatrick))
|
||||
into `servant` (`Servant.API.Generic`),
|
||||
`servant-client-code` (`Servant.Client.Generic`)
|
||||
and `servant-server` (`Servant.Server.Generic`).
|
||||
|
||||
- *servant-server* Deprecate `Servant.Utils.StaticUtils`, use `Servant.Server.StaticUtils`.
|
||||
|
||||
0.14
|
||||
----
|
||||
|
||||
- `Stream` takes a status code argument
|
||||
|
||||
```diff
|
||||
-Stream method framing ctype a
|
||||
+Stream method status framing ctype a
|
||||
```
|
||||
|
||||
([#966](https://github.com/haskell-servant/servant/pull/966)
|
||||
[#972](https://github.com/haskell-servant/servant/pull/972))
|
||||
|
||||
- `ToStreamGenerator` definition changed, so it's possible to write an instance
|
||||
for conduits.
|
||||
|
||||
```diff
|
||||
-class ToStreamGenerator f a where
|
||||
- toStreamGenerator :: f a -> StreamGenerator a
|
||||
+class ToStreamGenerator a b | a -> b where
|
||||
+ toStreamGenerator :: a -> StreamGenerator b
|
||||
```
|
||||
|
||||
([#959](https://github.com/haskell-servant/servant/pull/959))
|
||||
|
||||
- Added `NoFraming` streaming strategy
|
||||
([#959](https://github.com/haskell-servant/servant/pull/959))
|
||||
|
||||
- *servant-server* File serving in polymorphic monad.
|
||||
i.e. Generalised types of `serveDirectoryFileServer` etc functions in
|
||||
`Servant.Utils.StaticFiles`
|
||||
([#953](https://github.com/haskell-servant/servant/pull/953))
|
||||
|
||||
- *servant-server* `ReqBody` content type check is recoverable.
|
||||
This allows writing APIs like:
|
||||
|
||||
```haskell
|
||||
ReqBody '[JSON] Int :> Post '[PlainText] Int
|
||||
:<|> ReqBody '[PlainText] Int :> Post '[PlainText] Int
|
||||
```
|
||||
|
||||
which is useful when handlers are subtly different,
|
||||
for example may do less work.
|
||||
([#937](https://github.com/haskell-servant/servant/pull/937))
|
||||
|
||||
|
||||
0.13.0.1
|
||||
--------
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
name: servant-server
|
||||
version: 0.13.0.1
|
||||
version: 0.14.1
|
||||
synopsis: A family of combinators for defining webservices APIs and serving them
|
||||
description:
|
||||
A family of combinators for defining webservices APIs and serving them
|
||||
|
|
@ -40,13 +40,14 @@ custom-setup
|
|||
setup-depends:
|
||||
base >= 4 && <5,
|
||||
Cabal,
|
||||
cabal-doctest >= 1.0.1 && <1.1
|
||||
cabal-doctest >= 1.0.6 && <1.1
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Servant
|
||||
Servant.Server
|
||||
Servant.Server.Experimental.Auth
|
||||
Servant.Server.Generic
|
||||
Servant.Server.Internal
|
||||
Servant.Server.Internal.BasicAuth
|
||||
Servant.Server.Internal.Context
|
||||
|
|
@ -54,6 +55,10 @@ library
|
|||
Servant.Server.Internal.Router
|
||||
Servant.Server.Internal.RoutingApplication
|
||||
Servant.Server.Internal.ServantErr
|
||||
Servant.Server.StaticFiles
|
||||
|
||||
-- deprecated
|
||||
exposed-modules:
|
||||
Servant.Utils.StaticFiles
|
||||
|
||||
-- Bundled with GHC: Lower bound to not force re-installs
|
||||
|
|
@ -71,38 +76,32 @@ library
|
|||
|
||||
if !impl(ghc >= 8.0)
|
||||
build-depends:
|
||||
semigroups >= 0.18.3 && < 0.19
|
||||
semigroups >= 0.18.4 && < 0.19
|
||||
|
||||
-- Servant dependencies
|
||||
build-depends:
|
||||
servant == 0.13.*
|
||||
servant >= 0.14.1 && <0.15
|
||||
|
||||
-- Other dependencies: Lower bound around what is in the latest Stackage LTS.
|
||||
-- Here can be exceptions if we really need features from the newer versions.
|
||||
build-depends:
|
||||
aeson >= 1.2.3.0 && < 1.4
|
||||
, base-compat >= 0.9.3 && < 0.11
|
||||
, attoparsec >= 0.13.2.0 && < 0.14
|
||||
base-compat >= 0.10.1 && < 0.11
|
||||
, base64-bytestring >= 1.0.0.1 && < 1.1
|
||||
, deepseq >= 1.4.3.0 && < 1.5
|
||||
, exceptions >= 0.8.3 && < 0.11
|
||||
, http-api-data >= 0.3.7.1 && < 0.4
|
||||
, http-media >= 0.7.1.1 && < 0.8
|
||||
, http-types >= 0.12 && < 0.13
|
||||
, exceptions >= 0.10.0 && < 0.11
|
||||
, http-api-data >= 0.3.8.1 && < 0.4
|
||||
, http-media >= 0.7.1.2 && < 0.8
|
||||
, http-types >= 0.12.1 && < 0.13
|
||||
, network-uri >= 2.6.1.0 && < 2.7
|
||||
, monad-control >= 1.0.0.4 && < 1.1
|
||||
, network >= 2.6.3.2 && < 2.8
|
||||
, safe >= 0.3.15 && < 0.4
|
||||
, split >= 0.2.3.2 && < 0.3
|
||||
, monad-control >= 1.0.2.3 && < 1.1
|
||||
, network >= 2.6.3.5 && < 2.8
|
||||
, string-conversions >= 0.4.0.1 && < 0.5
|
||||
, system-filepath >= 0.4 && < 0.5
|
||||
, resourcet >= 1.1.9 && < 1.3
|
||||
, resourcet >= 1.1.11 && < 1.3
|
||||
, tagged >= 0.8.5 && < 0.9
|
||||
, transformers-base >= 0.4.4 && < 0.5
|
||||
, transformers-compat >= 0.5.1 && < 0.7
|
||||
, transformers-compat >= 0.6.2 && < 0.7
|
||||
, wai >= 3.2.1.1 && < 3.3
|
||||
, wai-app-static >= 3.1.6.1 && < 3.2
|
||||
, warp >= 3.2.13 && < 3.3
|
||||
, word8 >= 0.1.3 && < 0.2
|
||||
|
||||
hs-source-dirs: src
|
||||
|
|
@ -121,11 +120,13 @@ executable greet
|
|||
base
|
||||
, servant
|
||||
, servant-server
|
||||
, aeson
|
||||
, warp
|
||||
, wai
|
||||
, text
|
||||
|
||||
build-depends:
|
||||
aeson >= 1.3.1.1 && < 1.5
|
||||
, warp >= 3.2.13 && < 3.3
|
||||
|
||||
test-suite spec
|
||||
type: exitcode-stdio-1.0
|
||||
ghc-options: -Wall
|
||||
|
|
@ -138,24 +139,21 @@ test-suite spec
|
|||
Servant.Server.Internal.ContextSpec
|
||||
Servant.Server.Internal.RoutingApplicationSpec
|
||||
Servant.Server.RouterSpec
|
||||
Servant.Server.StaticFilesSpec
|
||||
Servant.Server.StreamingSpec
|
||||
Servant.Server.UsingContextSpec
|
||||
Servant.Server.UsingContextSpec.TestCombinators
|
||||
Servant.HoistSpec
|
||||
Servant.ServerSpec
|
||||
Servant.Utils.StaticFilesSpec
|
||||
|
||||
-- Dependencies inherited from the library. No need to specify bounds.
|
||||
build-depends:
|
||||
base
|
||||
, base-compat
|
||||
, aeson
|
||||
, base64-bytestring
|
||||
, bytestring
|
||||
, exceptions
|
||||
, http-types
|
||||
, mtl
|
||||
, network
|
||||
, resourcet
|
||||
, safe
|
||||
, servant
|
||||
|
|
@ -165,27 +163,26 @@ test-suite spec
|
|||
, transformers
|
||||
, transformers-compat
|
||||
, wai
|
||||
, warp
|
||||
|
||||
-- Additonal dependencies
|
||||
build-depends:
|
||||
directory >= 1.2.1.0 && < 1.4
|
||||
, hspec >= 2.4.4 && < 2.6
|
||||
, hspec-wai >= 0.9 && < 0.10
|
||||
aeson >= 1.3.1.1 && < 1.5
|
||||
, directory >= 1.2.1.0 && < 1.4
|
||||
, hspec >= 2.5.1 && < 2.6
|
||||
, hspec-wai >= 0.9.0 && < 0.10
|
||||
, QuickCheck >= 2.11.3 && < 2.12
|
||||
, should-not-typecheck >= 2.1.0 && < 2.2
|
||||
, parsec >= 3.1.11 && < 3.2
|
||||
, QuickCheck >= 2.10.1 && < 2.12
|
||||
, temporary >= 1.3 && < 1.4
|
||||
, wai-extra >= 3.0.21.0 && < 3.1
|
||||
, temporary >= 1.2.0.3 && < 1.4
|
||||
|
||||
build-tool-depends:
|
||||
hspec-discover:hspec-discover >=2.4.4 && <2.6
|
||||
hspec-discover:hspec-discover >= 2.5.1 && <2.6
|
||||
|
||||
test-suite doctests
|
||||
build-depends:
|
||||
base
|
||||
, servant-server
|
||||
, doctest >= 0.13.0 && <0.16
|
||||
, doctest >= 0.15.0 && <0.16
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: test/doctests.hs
|
||||
buildable: True
|
||||
|
|
|
|||
|
|
@ -6,16 +6,17 @@ module Servant (
|
|||
-- | For implementing servers for servant APIs.
|
||||
module Servant.Server,
|
||||
-- | Utilities on top of the servant core
|
||||
module Servant.Utils.Links,
|
||||
module Servant.Utils.StaticFiles,
|
||||
module Servant.Links,
|
||||
module Servant.Server.StaticFiles,
|
||||
-- | Useful re-exports
|
||||
Proxy(..),
|
||||
throwError
|
||||
) where
|
||||
|
||||
import Control.Monad.Error.Class (throwError)
|
||||
import Control.Monad.Error.Class
|
||||
(throwError)
|
||||
import Data.Proxy
|
||||
import Servant.API
|
||||
import Servant.Links
|
||||
import Servant.Server
|
||||
import Servant.Utils.Links
|
||||
import Servant.Utils.StaticFiles
|
||||
import Servant.Server.StaticFiles
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
-- | This module lets you implement 'Server's for defined APIs. You'll
|
||||
-- most likely just need 'serve'.
|
||||
|
|
@ -94,10 +94,14 @@ module Servant.Server
|
|||
|
||||
) where
|
||||
|
||||
import Data.Proxy (Proxy (..))
|
||||
import Data.Tagged (Tagged (..))
|
||||
import Data.Text (Text)
|
||||
import Network.Wai (Application)
|
||||
import Data.Proxy
|
||||
(Proxy (..))
|
||||
import Data.Tagged
|
||||
(Tagged (..))
|
||||
import Data.Text
|
||||
(Text)
|
||||
import Network.Wai
|
||||
(Application)
|
||||
import Servant.Server.Internal
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,33 +1,37 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Servant.Server.Experimental.Auth where
|
||||
|
||||
import Control.Monad.Trans (liftIO)
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import Data.Typeable (Typeable)
|
||||
import GHC.Generics (Generic)
|
||||
import Network.Wai (Request)
|
||||
import Control.Monad.Trans
|
||||
(liftIO)
|
||||
import Data.Proxy
|
||||
(Proxy (Proxy))
|
||||
import Data.Typeable
|
||||
(Typeable)
|
||||
import GHC.Generics
|
||||
(Generic)
|
||||
import Network.Wai
|
||||
(Request)
|
||||
|
||||
import Servant ((:>))
|
||||
import Servant
|
||||
((:>))
|
||||
import Servant.API.Experimental.Auth
|
||||
import Servant.Server.Internal (HasContextEntry,
|
||||
HasServer (..),
|
||||
getContextEntry)
|
||||
import Servant.Server.Internal.RoutingApplication (addAuthCheck,
|
||||
delayedFailFatal,
|
||||
DelayedIO,
|
||||
withRequest)
|
||||
import Servant.Server.Internal.Handler (Handler, runHandler)
|
||||
import Servant.Server.Internal
|
||||
(HasContextEntry, HasServer (..), getContextEntry)
|
||||
import Servant.Server.Internal.Handler
|
||||
(Handler, runHandler)
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
(DelayedIO, addAuthCheck, delayedFailFatal, withRequest)
|
||||
|
||||
-- * General Auth
|
||||
|
||||
|
|
|
|||
52
servant-server/src/Servant/Server/Generic.hs
Normal file
52
servant-server/src/Servant/Server/Generic.hs
Normal file
|
|
@ -0,0 +1,52 @@
|
|||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
-- | @since 0.14.1
|
||||
module Servant.Server.Generic (
|
||||
AsServerT,
|
||||
AsServer,
|
||||
genericServe,
|
||||
genericServer,
|
||||
genericServerT,
|
||||
) where
|
||||
|
||||
import Data.Proxy
|
||||
(Proxy (..))
|
||||
|
||||
import Servant.API.Generic
|
||||
import Servant.Server
|
||||
|
||||
-- | A type that specifies that an API record contains a server implementation.
|
||||
data AsServerT (m :: * -> *)
|
||||
instance GenericMode (AsServerT m) where
|
||||
type AsServerT m :- api = ServerT api m
|
||||
|
||||
type AsServer = AsServerT Handler
|
||||
|
||||
-- | Transform record of routes into a WAI 'Application'.
|
||||
genericServe
|
||||
:: forall routes.
|
||||
( HasServer (ToServantApi routes) '[]
|
||||
, GenericServant routes AsServer
|
||||
, Server (ToServantApi routes) ~ ToServant routes AsServer
|
||||
)
|
||||
=> routes AsServer -> Application
|
||||
genericServe = serve (Proxy :: Proxy (ToServantApi routes)) . genericServer
|
||||
|
||||
-- | Transform record of endpoints into a 'Server'.
|
||||
genericServer
|
||||
:: GenericServant routes AsServer
|
||||
=> routes AsServer
|
||||
-> ToServant routes AsServer
|
||||
genericServer = toServant
|
||||
|
||||
genericServerT
|
||||
:: GenericServant routes (AsServerT m)
|
||||
=> routes (AsServerT m)
|
||||
-> ToServant routes (AsServerT m)
|
||||
genericServerT = toServant
|
||||
|
|
@ -1,27 +1,23 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
#if MIN_VERSION_base(4,9,0) && __GLASGOW_HASKELL__ >= 802
|
||||
#define HAS_TYPE_ERROR
|
||||
#endif
|
||||
|
||||
#ifdef HAS_TYPE_ERROR
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
#endif
|
||||
|
||||
#include "overlapping-compat.h"
|
||||
|
||||
module Servant.Server.Internal
|
||||
|
|
@ -34,72 +30,74 @@ module Servant.Server.Internal
|
|||
, module Servant.Server.Internal.ServantErr
|
||||
) where
|
||||
|
||||
import Control.Monad (join, when)
|
||||
import Control.Monad.Trans (liftIO)
|
||||
import Control.Monad.Trans.Resource (runResourceT)
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Builder as BB
|
||||
import qualified Data.ByteString.Char8 as BC8
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Maybe (fromMaybe, mapMaybe,
|
||||
isNothing, maybeToList)
|
||||
import Data.Either (partitionEithers)
|
||||
import Data.Semigroup ((<>))
|
||||
import Data.String (IsString (..))
|
||||
import Data.String.Conversions (cs)
|
||||
import Data.Tagged (Tagged(..), retag, untag)
|
||||
import qualified Data.Text as T
|
||||
import Control.Monad
|
||||
(join, when)
|
||||
import Control.Monad.Trans
|
||||
(liftIO)
|
||||
import Control.Monad.Trans.Resource
|
||||
(runResourceT)
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Builder as BB
|
||||
import qualified Data.ByteString.Char8 as BC8
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Either
|
||||
(partitionEithers)
|
||||
import Data.Maybe
|
||||
(fromMaybe, isNothing, mapMaybe, maybeToList)
|
||||
import Data.Semigroup
|
||||
((<>))
|
||||
import Data.String
|
||||
(IsString (..))
|
||||
import Data.String.Conversions
|
||||
(cs)
|
||||
import Data.Tagged
|
||||
(Tagged (..), retag, untag)
|
||||
import qualified Data.Text as T
|
||||
import Data.Typeable
|
||||
import GHC.TypeLits (KnownNat, KnownSymbol, natVal,
|
||||
symbolVal)
|
||||
import Network.HTTP.Types hiding (Header, ResponseHeaders)
|
||||
import qualified Network.HTTP.Media as NHM
|
||||
import Network.Socket (SockAddr)
|
||||
import Network.Wai (Application, Request,
|
||||
httpVersion, isSecure,
|
||||
lazyRequestBody,
|
||||
rawQueryString, remoteHost,
|
||||
requestHeaders, requestMethod,
|
||||
responseLBS, responseStream,
|
||||
vault)
|
||||
import Prelude ()
|
||||
import GHC.TypeLits
|
||||
(KnownNat, KnownSymbol, natVal, symbolVal)
|
||||
import qualified Network.HTTP.Media as NHM
|
||||
import Network.HTTP.Types hiding
|
||||
(Header, ResponseHeaders)
|
||||
import Network.Socket
|
||||
(SockAddr)
|
||||
import Network.Wai
|
||||
(Application, Request, httpVersion, isSecure, lazyRequestBody,
|
||||
rawQueryString, remoteHost, requestHeaders, requestMethod,
|
||||
responseLBS, responseStream, vault)
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
import Web.HttpApiData (FromHttpApiData, parseHeader,
|
||||
parseQueryParam,
|
||||
parseUrlPieceMaybe,
|
||||
parseUrlPieces)
|
||||
import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture',
|
||||
CaptureAll, Verb, EmptyAPI,
|
||||
ReflectMethod(reflectMethod),
|
||||
IsSecure(..), Header', QueryFlag,
|
||||
QueryParam', QueryParams, Raw,
|
||||
RemoteHost, ReqBody', Vault,
|
||||
WithNamedContext,
|
||||
Description, Summary,
|
||||
Accept(..),
|
||||
FramingRender(..), Stream,
|
||||
StreamGenerator(..), ToStreamGenerator(..),
|
||||
BoundaryStrategy(..),
|
||||
If, SBool (..), SBoolI (..))
|
||||
import Servant.API.Modifiers (unfoldRequestArgument, RequestArgument, FoldRequired, FoldLenient)
|
||||
import Servant.API.ContentTypes (AcceptHeader (..),
|
||||
AllCTRender (..),
|
||||
AllCTUnrender (..),
|
||||
AllMime,
|
||||
MimeRender(..),
|
||||
canHandleAcceptH)
|
||||
import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
|
||||
getResponse)
|
||||
import Servant.API
|
||||
((:<|>) (..), (:>), Accept (..), BasicAuth,
|
||||
BoundaryStrategy (..), Capture', CaptureAll, Description,
|
||||
EmptyAPI, FramingRender (..), Header', If, IsSecure (..),
|
||||
QueryFlag, QueryParam', QueryParams, Raw,
|
||||
ReflectMethod (reflectMethod), RemoteHost, ReqBody',
|
||||
SBool (..), SBoolI (..), Stream, StreamGenerator (..),
|
||||
Summary, ToStreamGenerator (..), Vault, Verb,
|
||||
WithNamedContext)
|
||||
import Servant.API.ContentTypes
|
||||
(AcceptHeader (..), AllCTRender (..), AllCTUnrender (..),
|
||||
AllMime, MimeRender (..), canHandleAcceptH)
|
||||
import Servant.API.Modifiers
|
||||
(FoldLenient, FoldRequired, RequestArgument,
|
||||
unfoldRequestArgument)
|
||||
import Servant.API.ResponseHeaders
|
||||
(GetHeaders, Headers, getHeaders, getResponse)
|
||||
import Web.HttpApiData
|
||||
(FromHttpApiData, parseHeader, parseQueryParam,
|
||||
parseUrlPieceMaybe, parseUrlPieces)
|
||||
|
||||
import Servant.Server.Internal.Context
|
||||
import Servant.Server.Internal.BasicAuth
|
||||
import Servant.Server.Internal.Context
|
||||
import Servant.Server.Internal.Handler
|
||||
import Servant.Server.Internal.Router
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
import Servant.Server.Internal.ServantErr
|
||||
|
||||
#ifdef HAS_TYPE_ERROR
|
||||
import GHC.TypeLits (TypeError, ErrorMessage (..))
|
||||
import GHC.TypeLits
|
||||
(ErrorMessage (..), TypeError)
|
||||
#endif
|
||||
|
||||
class HasServer api context where
|
||||
|
|
@ -762,7 +760,7 @@ instance (HasContextEntry context (NamedContext name subContext), HasServer subA
|
|||
-- ...Maybe you haven't applied enough arguments to
|
||||
-- ...Capture' '[] "foo"
|
||||
-- ...
|
||||
--
|
||||
--
|
||||
instance TypeError (HasServerArrowKindError arr) => HasServer ((arr :: k -> l) :> api) context
|
||||
where
|
||||
type ServerT (arr :> api) m = TypeError (HasServerArrowKindError arr)
|
||||
|
|
|
|||
|
|
@ -1,22 +1,31 @@
|
|||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Servant.Server.Internal.BasicAuth where
|
||||
|
||||
import Control.Monad (guard)
|
||||
import Control.Monad.Trans (liftIO)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.ByteString.Base64 (decodeLenient)
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Typeable (Typeable)
|
||||
import Data.Word8 (isSpace, toLower, _colon)
|
||||
import Control.Monad
|
||||
(guard)
|
||||
import Control.Monad.Trans
|
||||
(liftIO)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.ByteString.Base64
|
||||
(decodeLenient)
|
||||
import Data.Monoid
|
||||
((<>))
|
||||
import Data.Typeable
|
||||
(Typeable)
|
||||
import Data.Word8
|
||||
(isSpace, toLower, _colon)
|
||||
import GHC.Generics
|
||||
import Network.HTTP.Types (Header)
|
||||
import Network.Wai (Request, requestHeaders)
|
||||
import Network.HTTP.Types
|
||||
(Header)
|
||||
import Network.Wai
|
||||
(Request, requestHeaders)
|
||||
|
||||
import Servant.API.BasicAuth (BasicAuthData(BasicAuthData))
|
||||
import Servant.API.BasicAuth
|
||||
(BasicAuthData (BasicAuthData))
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
import Servant.Server.Internal.ServantErr
|
||||
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ import GHC.TypeLits
|
|||
-- | 'Context's are used to pass values to combinators. (They are __not__ meant
|
||||
-- to be used to pass parameters to your handlers, i.e. they should not replace
|
||||
-- any custom 'Control.Monad.Trans.Reader.ReaderT'-monad-stack that you're using
|
||||
-- with 'Servant.Utils.Enter'.) If you don't use combinators that
|
||||
-- with 'hoistServer'.) If you don't use combinators that
|
||||
-- require any context entries, you can just use 'Servant.Server.serve' as always.
|
||||
--
|
||||
-- If you are using combinators that require a non-empty 'Context' you have to
|
||||
|
|
|
|||
|
|
@ -5,17 +5,25 @@
|
|||
{-# LANGUAGE TypeFamilies #-}
|
||||
module Servant.Server.Internal.Handler where
|
||||
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Monad.Base (MonadBase (..))
|
||||
import Control.Monad.Catch (MonadCatch, MonadThrow)
|
||||
import Control.Monad.Error.Class (MonadError)
|
||||
import Control.Monad.IO.Class (MonadIO)
|
||||
import Control.Monad.Trans.Control (MonadBaseControl (..))
|
||||
import Control.Monad.Trans.Except (ExceptT, runExceptT)
|
||||
import GHC.Generics (Generic)
|
||||
import Servant.Server.Internal.ServantErr (ServantErr)
|
||||
import Control.Monad.Base
|
||||
(MonadBase (..))
|
||||
import Control.Monad.Catch
|
||||
(MonadCatch, MonadThrow)
|
||||
import Control.Monad.Error.Class
|
||||
(MonadError)
|
||||
import Control.Monad.IO.Class
|
||||
(MonadIO)
|
||||
import Control.Monad.Trans.Control
|
||||
(MonadBaseControl (..))
|
||||
import Control.Monad.Trans.Except
|
||||
(ExceptT, runExceptT)
|
||||
import GHC.Generics
|
||||
(Generic)
|
||||
import Servant.Server.Internal.ServantErr
|
||||
(ServantErr)
|
||||
|
||||
newtype Handler a = Handler { runHandler' :: ExceptT ServantErr IO a }
|
||||
deriving
|
||||
|
|
|
|||
|
|
@ -1,15 +1,18 @@
|
|||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Servant.Server.Internal.Router where
|
||||
|
||||
import Data.Map (Map)
|
||||
import Data.Map
|
||||
(Map)
|
||||
import qualified Data.Map as M
|
||||
import Data.Monoid
|
||||
import Data.Text (Text)
|
||||
import Data.Text
|
||||
(Text)
|
||||
import qualified Data.Text as T
|
||||
import Network.Wai (Response, pathInfo)
|
||||
import Network.Wai
|
||||
(Response, pathInfo)
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
import Servant.Server.Internal.ServantErr
|
||||
|
||||
|
|
|
|||
|
|
@ -10,17 +10,27 @@
|
|||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Servant.Server.Internal.RoutingApplication where
|
||||
|
||||
import Control.DeepSeq (force)
|
||||
import Control.Monad (ap, liftM)
|
||||
import Control.Monad.Base (MonadBase (..))
|
||||
import Control.Monad.Catch (MonadThrow (..))
|
||||
import Control.Monad.Reader (MonadReader (..), ReaderT (..), runReaderT)
|
||||
import Control.Monad.Trans (MonadIO (..), MonadTrans (..))
|
||||
import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), MonadTransControl (..),
|
||||
defaultLiftBaseWith, defaultRestoreM)
|
||||
import Control.Monad.Trans.Resource (MonadResource (..), ResourceT, runResourceT, transResourceT, withInternalState, runInternalState)
|
||||
import Network.Wai (Application, Request, Response, ResponseReceived)
|
||||
import Prelude ()
|
||||
import Control.DeepSeq
|
||||
(force)
|
||||
import Control.Monad
|
||||
(ap, liftM)
|
||||
import Control.Monad.Base
|
||||
(MonadBase (..))
|
||||
import Control.Monad.Catch
|
||||
(MonadThrow (..))
|
||||
import Control.Monad.Reader
|
||||
(MonadReader (..), ReaderT (..), runReaderT)
|
||||
import Control.Monad.Trans
|
||||
(MonadIO (..), MonadTrans (..))
|
||||
import Control.Monad.Trans.Control
|
||||
(ComposeSt, MonadBaseControl (..), MonadTransControl (..),
|
||||
defaultLiftBaseWith, defaultRestoreM)
|
||||
import Control.Monad.Trans.Resource
|
||||
(MonadResource (..), ResourceT, runInternalState,
|
||||
runResourceT, transResourceT, withInternalState)
|
||||
import Network.Wai
|
||||
(Application, Request, Response, ResponseReceived)
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
import Servant.Server.Internal.Handler
|
||||
import Servant.Server.Internal.ServantErr
|
||||
|
|
@ -94,7 +104,7 @@ toApplication fullyEvaluate ra request respond =
|
|||
maybeEval resp =
|
||||
if fullyEvaluate
|
||||
then force resp
|
||||
else resp
|
||||
else resp
|
||||
routingRespond :: RouteResult Response -> IO ResponseReceived
|
||||
routingRespond (Fail err) = respond $ responseServantErr err
|
||||
routingRespond (FailFatal err) = respond $ responseServantErr err
|
||||
|
|
|
|||
|
|
@ -1,18 +1,21 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Servant.Server.Internal.ServantErr where
|
||||
|
||||
import Control.Exception
|
||||
(Exception)
|
||||
import Control.DeepSeq (NFData)
|
||||
import Control.Exception (Exception)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import Data.Typeable (Typeable)
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import Network.Wai (Response, responseLBS)
|
||||
import Data.Typeable
|
||||
(Typeable)
|
||||
import GHC.Generics (Generic)
|
||||
import qualified Network.HTTP.Types as HTTP
|
||||
import Network.Wai
|
||||
(Response, responseLBS)
|
||||
|
||||
data ServantErr = ServantErr { errHTTPCode :: Int
|
||||
, errReasonPhrase :: String
|
||||
|
|
|
|||
92
servant-server/src/Servant/Server/StaticFiles.hs
Normal file
92
servant-server/src/Servant/Server/StaticFiles.hs
Normal file
|
|
@ -0,0 +1,92 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
-- | This module defines server-side handlers that lets you serve static files.
|
||||
--
|
||||
-- The most common needs for a web application are covered by
|
||||
-- 'serveDirectoryWebApp`, but the other variants allow you to use
|
||||
-- different `StaticSettings` and 'serveDirectoryWith' even allows you
|
||||
-- to specify arbitrary 'StaticSettings' to be used for serving static files.
|
||||
module Servant.Server.StaticFiles
|
||||
( serveDirectoryWebApp
|
||||
, serveDirectoryWebAppLookup
|
||||
, serveDirectoryFileServer
|
||||
, serveDirectoryEmbedded
|
||||
, serveDirectoryWith
|
||||
, -- * Deprecated
|
||||
serveDirectory
|
||||
) where
|
||||
|
||||
import Data.ByteString
|
||||
(ByteString)
|
||||
import Network.Wai.Application.Static
|
||||
import Servant.API.Raw
|
||||
(Raw)
|
||||
import Servant.Server
|
||||
(ServerT, Tagged (..))
|
||||
import System.FilePath
|
||||
(addTrailingPathSeparator)
|
||||
#if !MIN_VERSION_wai_app_static(3,1,0)
|
||||
import Filesystem.Path.CurrentOS
|
||||
(decodeString)
|
||||
#endif
|
||||
import WaiAppStatic.Storage.Filesystem
|
||||
(ETagLookup)
|
||||
|
||||
-- | Serve anything under the specified directory as a 'Raw' endpoint.
|
||||
--
|
||||
-- @
|
||||
-- type MyApi = "static" :> Raw
|
||||
--
|
||||
-- server :: Server MyApi
|
||||
-- server = serveDirectoryWebApp "\/var\/www"
|
||||
-- @
|
||||
--
|
||||
-- would capture any request to @\/static\/\<something>@ and look for
|
||||
-- @\<something>@ under @\/var\/www@.
|
||||
--
|
||||
-- It will do its best to guess the MIME type for that file, based on the extension,
|
||||
-- and send an appropriate /Content-Type/ header if possible.
|
||||
--
|
||||
-- If your goal is to serve HTML, CSS and Javascript files that use the rest of the API
|
||||
-- as a webapp backend, you will most likely not want the static files to be hidden
|
||||
-- behind a /\/static\// prefix. In that case, remember to put the 'serveDirectoryWebApp'
|
||||
-- handler in the last position, because /servant/ will try to match the handlers
|
||||
-- in order.
|
||||
--
|
||||
-- Corresponds to the `defaultWebAppSettings` `StaticSettings` value.
|
||||
serveDirectoryWebApp :: FilePath -> ServerT Raw m
|
||||
serveDirectoryWebApp = serveDirectoryWith . defaultWebAppSettings . fixPath
|
||||
|
||||
-- | Same as 'serveDirectoryWebApp', but uses `defaultFileServerSettings`.
|
||||
serveDirectoryFileServer :: FilePath -> ServerT Raw m
|
||||
serveDirectoryFileServer = serveDirectoryWith . defaultFileServerSettings . fixPath
|
||||
|
||||
-- | Same as 'serveDirectoryWebApp', but uses 'webAppSettingsWithLookup'.
|
||||
serveDirectoryWebAppLookup :: ETagLookup -> FilePath -> ServerT Raw m
|
||||
serveDirectoryWebAppLookup etag =
|
||||
serveDirectoryWith . flip webAppSettingsWithLookup etag . fixPath
|
||||
|
||||
-- | Uses 'embeddedSettings'.
|
||||
serveDirectoryEmbedded :: [(FilePath, ByteString)] -> ServerT Raw m
|
||||
serveDirectoryEmbedded files = serveDirectoryWith (embeddedSettings files)
|
||||
|
||||
-- | Alias for 'staticApp'. Lets you serve a directory
|
||||
-- with arbitrary 'StaticSettings'. Useful when you want
|
||||
-- particular settings not covered by the four other
|
||||
-- variants. This is the most flexible method.
|
||||
serveDirectoryWith :: StaticSettings -> ServerT Raw m
|
||||
serveDirectoryWith = Tagged . staticApp
|
||||
|
||||
-- | Same as 'serveDirectoryFileServer'. It used to be the only
|
||||
-- file serving function in servant pre-0.10 and will be kept
|
||||
-- around for a few versions, but is deprecated.
|
||||
serveDirectory :: FilePath -> ServerT Raw m
|
||||
serveDirectory = serveDirectoryFileServer
|
||||
{-# DEPRECATED serveDirectory "Use serveDirectoryFileServer instead" #-}
|
||||
|
||||
fixPath :: FilePath -> FilePath
|
||||
fixPath =
|
||||
#if MIN_VERSION_wai_app_static(3,1,0)
|
||||
addTrailingPathSeparator
|
||||
#else
|
||||
decodeString . addTrailingPathSeparator
|
||||
#endif
|
||||
|
|
@ -1,86 +1,6 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
-- | This module defines server-side handlers that lets you serve static files.
|
||||
--
|
||||
-- The most common needs for a web application are covered by
|
||||
-- 'serveDirectoryWebApp`, but the other variants allow you to use
|
||||
-- different `StaticSettings` and 'serveDirectoryWith' even allows you
|
||||
-- to specify arbitrary 'StaticSettings' to be used for serving static files.
|
||||
module Servant.Utils.StaticFiles
|
||||
( serveDirectoryWebApp
|
||||
, serveDirectoryWebAppLookup
|
||||
, serveDirectoryFileServer
|
||||
, serveDirectoryEmbedded
|
||||
, serveDirectoryWith
|
||||
, -- * Deprecated
|
||||
serveDirectory
|
||||
) where
|
||||
{-# DEPRECATED "Use Servant.ServerStaticFiles." #-}
|
||||
( module Servant.Server.StaticFiles )
|
||||
where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Network.Wai.Application.Static
|
||||
import Servant.API.Raw (Raw)
|
||||
import Servant.Server (ServerT, Tagged (..))
|
||||
import System.FilePath (addTrailingPathSeparator)
|
||||
#if !MIN_VERSION_wai_app_static(3,1,0)
|
||||
import Filesystem.Path.CurrentOS (decodeString)
|
||||
#endif
|
||||
import WaiAppStatic.Storage.Filesystem (ETagLookup)
|
||||
|
||||
-- | Serve anything under the specified directory as a 'Raw' endpoint.
|
||||
--
|
||||
-- @
|
||||
-- type MyApi = "static" :> Raw
|
||||
--
|
||||
-- server :: Server MyApi
|
||||
-- server = serveDirectoryWebApp "\/var\/www"
|
||||
-- @
|
||||
--
|
||||
-- would capture any request to @\/static\/\<something>@ and look for
|
||||
-- @\<something>@ under @\/var\/www@.
|
||||
--
|
||||
-- It will do its best to guess the MIME type for that file, based on the extension,
|
||||
-- and send an appropriate /Content-Type/ header if possible.
|
||||
--
|
||||
-- If your goal is to serve HTML, CSS and Javascript files that use the rest of the API
|
||||
-- as a webapp backend, you will most likely not want the static files to be hidden
|
||||
-- behind a /\/static\// prefix. In that case, remember to put the 'serveDirectoryWebApp'
|
||||
-- handler in the last position, because /servant/ will try to match the handlers
|
||||
-- in order.
|
||||
--
|
||||
-- Corresponds to the `defaultWebAppSettings` `StaticSettings` value.
|
||||
serveDirectoryWebApp :: FilePath -> ServerT Raw m
|
||||
serveDirectoryWebApp = serveDirectoryWith . defaultWebAppSettings . fixPath
|
||||
|
||||
-- | Same as 'serveDirectoryWebApp', but uses `defaultFileServerSettings`.
|
||||
serveDirectoryFileServer :: FilePath -> ServerT Raw m
|
||||
serveDirectoryFileServer = serveDirectoryWith . defaultFileServerSettings . fixPath
|
||||
|
||||
-- | Same as 'serveDirectoryWebApp', but uses 'webAppSettingsWithLookup'.
|
||||
serveDirectoryWebAppLookup :: ETagLookup -> FilePath -> ServerT Raw m
|
||||
serveDirectoryWebAppLookup etag =
|
||||
serveDirectoryWith . flip webAppSettingsWithLookup etag . fixPath
|
||||
|
||||
-- | Uses 'embeddedSettings'.
|
||||
serveDirectoryEmbedded :: [(FilePath, ByteString)] -> ServerT Raw m
|
||||
serveDirectoryEmbedded files = serveDirectoryWith (embeddedSettings files)
|
||||
|
||||
-- | Alias for 'staticApp'. Lets you serve a directory
|
||||
-- with arbitrary 'StaticSettings'. Useful when you want
|
||||
-- particular settings not covered by the four other
|
||||
-- variants. This is the most flexible method.
|
||||
serveDirectoryWith :: StaticSettings -> ServerT Raw m
|
||||
serveDirectoryWith = Tagged . staticApp
|
||||
|
||||
-- | Same as 'serveDirectoryFileServer'. It used to be the only
|
||||
-- file serving function in servant pre-0.10 and will be kept
|
||||
-- around for a few versions, but is deprecated.
|
||||
serveDirectory :: FilePath -> ServerT Raw m
|
||||
serveDirectory = serveDirectoryFileServer
|
||||
{-# DEPRECATED serveDirectory "Use serveDirectoryFileServer instead" #-}
|
||||
|
||||
fixPath :: FilePath -> FilePath
|
||||
fixPath =
|
||||
#if MIN_VERSION_wai_app_static(3,1,0)
|
||||
addTrailingPathSeparator
|
||||
#else
|
||||
decodeString . addTrailingPathSeparator
|
||||
#endif
|
||||
import Servant.Server.StaticFiles
|
||||
|
|
|
|||
|
|
@ -9,9 +9,10 @@ import Data.Proxy
|
|||
import Servant.API
|
||||
import Servant.Server
|
||||
|
||||
import Test.Hspec (Spec, describe, it)
|
||||
import Test.Hspec.Wai (get, matchStatus, post,
|
||||
shouldRespondWith, with)
|
||||
import Test.Hspec
|
||||
(Spec, describe, it)
|
||||
import Test.Hspec.Wai
|
||||
(get, matchStatus, post, shouldRespondWith, with)
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "Arbitrary monad server" $ do
|
||||
|
|
|
|||
|
|
@ -1,10 +1,11 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
module Servant.HoistSpec where
|
||||
|
||||
import Test.Hspec (Spec)
|
||||
import Test.Hspec
|
||||
(Spec)
|
||||
|
||||
import Servant
|
||||
import Servant
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- https://github.com/haskell-servant/servant/issues/734
|
||||
|
|
|
|||
|
|
@ -6,16 +6,20 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Servant.Server.ErrorSpec (spec) where
|
||||
|
||||
import Control.Monad (when)
|
||||
import Data.Aeson (encode)
|
||||
import Control.Monad
|
||||
(when)
|
||||
import Data.Aeson
|
||||
(encode)
|
||||
import qualified Data.ByteString.Char8 as BC
|
||||
import qualified Data.ByteString.Lazy.Char8 as BCL
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Monoid
|
||||
((<>))
|
||||
import Data.Proxy
|
||||
import Network.HTTP.Types (hAccept, hAuthorization,
|
||||
hContentType, methodGet,
|
||||
methodPost, methodPut)
|
||||
import Safe (readMay)
|
||||
import Network.HTTP.Types
|
||||
(hAccept, hAuthorization, hContentType, methodGet, methodPost,
|
||||
methodPut)
|
||||
import Safe
|
||||
(readMay)
|
||||
import Test.Hspec
|
||||
import Test.Hspec.Wai
|
||||
|
||||
|
|
|
|||
|
|
@ -2,9 +2,12 @@
|
|||
{-# OPTIONS_GHC -fdefer-type-errors -Wwarn #-}
|
||||
module Servant.Server.Internal.ContextSpec (spec) where
|
||||
|
||||
import Data.Proxy (Proxy (..))
|
||||
import Test.Hspec (Spec, describe, it, shouldBe, context)
|
||||
import Test.ShouldNotTypecheck (shouldNotTypecheck)
|
||||
import Data.Proxy
|
||||
(Proxy (..))
|
||||
import Test.Hspec
|
||||
(Spec, context, describe, it, shouldBe)
|
||||
import Test.ShouldNotTypecheck
|
||||
(shouldNotTypecheck)
|
||||
|
||||
import Servant.API
|
||||
import Servant.Server.Internal.Context
|
||||
|
|
|
|||
|
|
@ -1,31 +1,37 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
module Servant.Server.Internal.RoutingApplicationSpec (spec) where
|
||||
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Control.Exception hiding (Handler)
|
||||
import Control.Monad.Trans.Resource (register)
|
||||
import Control.Monad.IO.Class
|
||||
import Data.IORef
|
||||
import Data.Proxy
|
||||
import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
|
||||
import Servant
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
import Network.Wai (defaultRequest)
|
||||
import Test.Hspec
|
||||
import Test.Hspec.Wai (request, shouldRespondWith, with)
|
||||
import Control.Exception hiding
|
||||
(Handler)
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Trans.Resource
|
||||
(register)
|
||||
import Data.IORef
|
||||
import Data.Proxy
|
||||
import GHC.TypeLits
|
||||
(KnownSymbol, Symbol, symbolVal)
|
||||
import Network.Wai
|
||||
(defaultRequest)
|
||||
import Servant
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
import Test.Hspec
|
||||
import Test.Hspec.Wai
|
||||
(request, shouldRespondWith, with)
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text as T
|
||||
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import System.IO.Unsafe
|
||||
(unsafePerformIO)
|
||||
|
||||
data TestResource x
|
||||
= TestResourceNone
|
||||
|
|
|
|||
|
|
@ -1,20 +1,27 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
module Servant.Server.RouterSpec (spec) where
|
||||
|
||||
import Control.Monad (unless)
|
||||
import Data.Proxy (Proxy(..))
|
||||
import Data.Text (unpack)
|
||||
import Network.HTTP.Types (Status (..))
|
||||
import Network.Wai (responseBuilder)
|
||||
import Network.Wai.Internal (Response (ResponseBuilder))
|
||||
import Test.Hspec
|
||||
import Test.Hspec.Wai (get, shouldRespondWith, with)
|
||||
import Control.Monad
|
||||
(unless)
|
||||
import Data.Proxy
|
||||
(Proxy (..))
|
||||
import Data.Text
|
||||
(unpack)
|
||||
import Network.HTTP.Types
|
||||
(Status (..))
|
||||
import Network.Wai
|
||||
(responseBuilder)
|
||||
import Network.Wai.Internal
|
||||
(Response (ResponseBuilder))
|
||||
import Servant.API
|
||||
import Servant.Server
|
||||
import Servant.Server.Internal
|
||||
import Test.Hspec
|
||||
import Test.Hspec.Wai
|
||||
(get, shouldRespondWith, with)
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "Servant.Server.Internal.Router" $ do
|
||||
|
|
|
|||
|
|
@ -3,22 +3,31 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Servant.Utils.StaticFilesSpec where
|
||||
module Servant.Server.StaticFilesSpec where
|
||||
|
||||
import Control.Exception (bracket)
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import Network.Wai (Application)
|
||||
import System.Directory (createDirectory,
|
||||
getCurrentDirectory,
|
||||
setCurrentDirectory)
|
||||
import System.IO.Temp (withSystemTempDirectory)
|
||||
import Test.Hspec (Spec, around_, describe, it)
|
||||
import Test.Hspec.Wai (get, shouldRespondWith, with)
|
||||
import Control.Exception
|
||||
(bracket)
|
||||
import Data.Proxy
|
||||
(Proxy (Proxy))
|
||||
import Network.Wai
|
||||
(Application)
|
||||
import System.Directory
|
||||
(createDirectory, getCurrentDirectory, setCurrentDirectory)
|
||||
import System.IO.Temp
|
||||
(withSystemTempDirectory)
|
||||
import Test.Hspec
|
||||
(Spec, around_, describe, it)
|
||||
import Test.Hspec.Wai
|
||||
(get, shouldRespondWith, with)
|
||||
|
||||
import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON)
|
||||
import Servant.Server (Server, serve)
|
||||
import Servant.ServerSpec (Person (Person))
|
||||
import Servant.Utils.StaticFiles (serveDirectoryFileServer)
|
||||
import Servant.API
|
||||
((:<|>) ((:<|>)), (:>), Capture, Get, JSON, Raw)
|
||||
import Servant.Server
|
||||
(Server, serve)
|
||||
import Servant.Server.StaticFiles
|
||||
(serveDirectoryFileServer)
|
||||
import Servant.ServerSpec
|
||||
(Person (Person))
|
||||
|
||||
type Api =
|
||||
"dummy_api" :> Capture "person_name" String :> Get '[JSON] Person
|
||||
|
|
@ -1,18 +1,19 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
-- | This module tests whether streaming works from client to server
|
||||
-- with a server implemented with servant-server.
|
||||
module Servant.Server.StreamingSpec where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Exception hiding (Handler)
|
||||
import Control.Exception hiding
|
||||
(Handler)
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Data.ByteString as Strict
|
||||
import qualified Data.ByteString.Lazy as Lazy
|
||||
import qualified Data.ByteString as Strict
|
||||
import qualified Data.ByteString.Lazy as Lazy
|
||||
import Network.HTTP.Types
|
||||
import Network.Wai
|
||||
import Network.Wai.Internal
|
||||
|
|
|
|||
|
|
@ -1,12 +1,13 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
module Servant.Server.UsingContextSpec where
|
||||
|
||||
import Network.Wai
|
||||
import Test.Hspec (Spec, describe, it)
|
||||
import Test.Hspec
|
||||
(Spec, describe, it)
|
||||
import Test.Hspec.Wai
|
||||
|
||||
import Servant
|
||||
|
|
|
|||
|
|
@ -1,13 +1,13 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
-- | These are custom combinators for Servant.Server.UsingContextSpec.
|
||||
--
|
||||
|
|
|
|||
|
|
@ -88,6 +88,7 @@ spec :: Spec
|
|||
spec = do
|
||||
verbSpec
|
||||
captureSpec
|
||||
captureAllSpec
|
||||
queryParamSpec
|
||||
reqBodySpec
|
||||
headerSpec
|
||||
|
|
|
|||
|
|
@ -13,9 +13,11 @@
|
|||
-----------------------------------------------------------------------------
|
||||
module Main where
|
||||
|
||||
import Build_doctests (flags, pkgs, module_sources)
|
||||
import Data.Foldable (traverse_)
|
||||
import Test.DocTest
|
||||
import Build_doctests
|
||||
(flags, module_sources, pkgs)
|
||||
import Data.Foldable
|
||||
(traverse_)
|
||||
import Test.DocTest
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
|
|
|
|||
|
|
@ -1,5 +1,138 @@
|
|||
[The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant/CHANGELOG.md)
|
||||
|
||||
0.14.1
|
||||
------
|
||||
|
||||
- Merge in (and slightly refactor) `servant-generic`
|
||||
(by [Patrick Chilton](https://github.com/chpatrick))
|
||||
into `servant` (`Servant.API.Generic`),
|
||||
`servant-client-code` (`Servant.Client.Generic`)
|
||||
and `servant-server` (`Servant.Server.Generic`).
|
||||
|
||||
- Deprecate `Servant.Utils.Links`, use `Servant.Links`.
|
||||
|
||||
- *servant-server* Deprecate `Servant.Utils.StaticUtils`, use `Servant.Server.StaticUtils`.
|
||||
|
||||
0.14
|
||||
----
|
||||
|
||||
### Signifacant changes
|
||||
|
||||
- `Stream` takes a status code argument
|
||||
|
||||
```diff
|
||||
-Stream method framing ctype a
|
||||
+Stream method status framing ctype a
|
||||
```
|
||||
|
||||
([#966](https://github.com/haskell-servant/servant/pull/966)
|
||||
[#972](https://github.com/haskell-servant/servant/pull/972))
|
||||
|
||||
- `ToStreamGenerator` definition changed, so it's possible to write an instance
|
||||
for conduits.
|
||||
|
||||
```diff
|
||||
-class ToStreamGenerator f a where
|
||||
- toStreamGenerator :: f a -> StreamGenerator a
|
||||
+class ToStreamGenerator a b | a -> b where
|
||||
+ toStreamGenerator :: a -> StreamGenerator b
|
||||
```
|
||||
|
||||
([#959](https://github.com/haskell-servant/servant/pull/959))
|
||||
|
||||
- Added `NoFraming` streaming strategy
|
||||
([#959](https://github.com/haskell-servant/servant/pull/959))
|
||||
|
||||
- *servant-client-core* Free `Client` implementation.
|
||||
Useful for testing `HasClient` instances.
|
||||
([#920](https://github.com/haskell-servant/servant/pull/920))
|
||||
|
||||
- *servant-client-core* Add `hoistClient` to `HasClient`.
|
||||
Just like `hoistServer` allows us to change the monad in which request handlers
|
||||
of a web application live in, we also have `hoistClient` for changing the monad
|
||||
in which *client functions* live.
|
||||
Read [tutorial section for more information](https://haskell-servant.readthedocs.io/en/release-0.14/tutorial/Client.html#changing-the-monad-the-client-functions-live-in).
|
||||
([#936](https://github.com/haskell-servant/servant/pull/936))
|
||||
|
||||
iF you have own combinators, you'll need to define a new method of
|
||||
`HasClient` class, for example:
|
||||
|
||||
```haskell
|
||||
type Client m (MyCombinator :> api) = MyValue :> Client m api
|
||||
hoistClientMonad pm _ nt cl = hoistClientMonad pm (Proxy :: Proxy api) nt . cl
|
||||
```
|
||||
|
||||
- *servant* Add `safeLink' :: (Link -> a) -> ... -> MkLink endpoint a`,
|
||||
which allows to create helpers returning something else than `Link`.
|
||||
([#968](https://github.com/haskell-servant/servant/pull/968))
|
||||
|
||||
- *servant-server* File serving in polymorphic monad.
|
||||
i.e. Generalised types of `serveDirectoryFileServer` etc functions in
|
||||
`Servant.Utils.StaticFiles`
|
||||
([#953](https://github.com/haskell-servant/servant/pull/953))
|
||||
|
||||
- *servant-server* `ReqBody` content type check is recoverable.
|
||||
This allows writing APIs like:
|
||||
|
||||
```haskell
|
||||
ReqBody '[JSON] Int :> Post '[PlainText] Int
|
||||
:<|> ReqBody '[PlainText] Int :> Post '[PlainText] Int
|
||||
```
|
||||
|
||||
which is useful when handlers are subtly different,
|
||||
for example may do less work.
|
||||
([#937](https://github.com/haskell-servant/servant/pull/937))
|
||||
|
||||
- *servant-client* Add more constructors to `RequestBody`, including
|
||||
`RequestBodyStream`.
|
||||
*Note:* we are looking for http-library agnostic API,
|
||||
so the might change again soon.
|
||||
Tell us which constructors are useful for you!
|
||||
([#913](https://github.com/haskell-servant/servant/pull/913))
|
||||
|
||||
### Other changes
|
||||
|
||||
- `GetHeaders` instances implemented without `OverlappingInstances`
|
||||
([#971](https://github.com/haskell-servant/servant/pull/971))
|
||||
|
||||
- Added tests or enabled tests
|
||||
([#975](https://github.com/haskell-servant/servant/pull/975))
|
||||
|
||||
- Add [pagination cookbook recipe](https://haskell-servant.readthedocs.io/en/release-0.14/cookbook/pagination/Pagination.html)
|
||||
([#946](https://github.com/haskell-servant/servant/pull/946))
|
||||
|
||||
- Add [`servant-flatten` "spice" to the structuring api recipe](https://haskell-servant.readthedocs.io/en/release-0.14/cookbook/structuring-apis/StructuringApis.html)
|
||||
([#929](https://github.com/haskell-servant/servant/pull/929))
|
||||
|
||||
- Dependency updates
|
||||
([#900](https://github.com/haskell-servant/servant/pull/900)
|
||||
[#919](https://github.com/haskell-servant/servant/pull/919)
|
||||
[#924](https://github.com/haskell-servant/servant/pull/924)
|
||||
[#943](https://github.com/haskell-servant/servant/pull/943)
|
||||
[#964](https://github.com/haskell-servant/servant/pull/964)
|
||||
[#967](https://github.com/haskell-servant/servant/pull/967)
|
||||
[#976](https://github.com/haskell-servant/servant/pull/976))
|
||||
|
||||
- Documentation updates
|
||||
[#963](https://github.com/haskell-servant/servant/pull/963)
|
||||
[#960](https://github.com/haskell-servant/servant/pull/960)
|
||||
[#908](https://github.com/haskell-servant/servant/pull/908)
|
||||
[#958](https://github.com/haskell-servant/servant/pull/958)
|
||||
[#948](https://github.com/haskell-servant/servant/pull/948)
|
||||
[#928](https://github.com/haskell-servant/servant/pull/928)
|
||||
[#921](https://github.com/haskell-servant/servant/pull/921))
|
||||
|
||||
- Development process improvements
|
||||
([#680](https://github.com/haskell-servant/servant/pull/680)
|
||||
[#917](https://github.com/haskell-servant/servant/pull/917)
|
||||
[#923](https://github.com/haskell-servant/servant/pull/923)
|
||||
[#961](https://github.com/haskell-servant/servant/pull/961)
|
||||
[#973](https://github.com/haskell-servant/servant/pull/973))
|
||||
|
||||
### Note
|
||||
|
||||
(VIM) Regular-expression to link PR numbers: `s/\v#(\d+)/[#\1](https:\/\/github.com\/haskell-servant\/servant/pull\/\1)/`
|
||||
|
||||
0.13.0.1
|
||||
--------
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
name: servant
|
||||
version: 0.13.0.1
|
||||
version: 0.14.1
|
||||
synopsis: A family of combinators for defining webservices APIs
|
||||
description:
|
||||
A family of combinators for defining webservices APIs and serving them
|
||||
|
|
@ -34,7 +34,7 @@ custom-setup
|
|||
setup-depends:
|
||||
base >= 4 && <5,
|
||||
Cabal,
|
||||
cabal-doctest >= 1.0.2 && <1.1
|
||||
cabal-doctest >= 1.0.6 && <1.1
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
|
|
@ -46,6 +46,7 @@ library
|
|||
Servant.API.Description
|
||||
Servant.API.Empty
|
||||
Servant.API.Experimental.Auth
|
||||
Servant.API.Generic
|
||||
Servant.API.Header
|
||||
Servant.API.HttpVersion
|
||||
Servant.API.Internal.Test.ComprehensiveAPI
|
||||
|
|
@ -62,8 +63,11 @@ library
|
|||
Servant.API.Vault
|
||||
Servant.API.Verbs
|
||||
Servant.API.WithNamedContext
|
||||
Servant.Links
|
||||
|
||||
-- Deprecated modules, to be removed in late 2019
|
||||
exposed-modules:
|
||||
Servant.Utils.Links
|
||||
Servant.Utils.Enter
|
||||
|
||||
-- Bundled with GHC: Lower bound to not force re-installs
|
||||
-- text and mtl are bundled starting with GHC-8.4
|
||||
|
|
@ -77,25 +81,24 @@ library
|
|||
|
||||
if !impl(ghc >= 8.0)
|
||||
build-depends:
|
||||
semigroups >= 0.18.3 && < 0.19
|
||||
semigroups >= 0.18.4 && < 0.19
|
||||
|
||||
-- Other dependencies: Lower bound around what is in the latest Stackage LTS.
|
||||
-- Here can be exceptions if we really need features from the newer versions.
|
||||
build-depends:
|
||||
base-compat >= 0.9.3 && < 0.11
|
||||
, aeson >= 1.2.3.0 && < 1.4
|
||||
, attoparsec >= 0.13.2.0 && < 0.14
|
||||
base-compat >= 0.10.1 && < 0.11
|
||||
, aeson >= 1.3.1.1 && < 1.5
|
||||
, attoparsec >= 0.13.2.2 && < 0.14
|
||||
, case-insensitive >= 1.2.0.10 && < 1.3
|
||||
, http-api-data >= 0.3.7.1 && < 0.4
|
||||
, http-media >= 0.7.1.1 && < 0.8
|
||||
, http-types >= 0.12 && < 0.13
|
||||
, natural-transformation >= 0.4 && < 0.5
|
||||
, mmorph >= 1.1.0 && < 1.2
|
||||
, http-api-data >= 0.3.8.1 && < 0.4
|
||||
, http-media >= 0.7.1.2 && < 0.8
|
||||
, http-types >= 0.12.1 && < 0.13
|
||||
, mmorph >= 1.1.2 && < 1.2
|
||||
, tagged >= 0.8.5 && < 0.9
|
||||
, singleton-bool >= 0.1.2.0 && < 0.2
|
||||
, singleton-bool >= 0.1.4 && < 0.2
|
||||
, string-conversions >= 0.4.0.1 && < 0.5
|
||||
, network-uri >= 2.6.1.0 && < 2.7
|
||||
, vault >= 0.3.0.7 && < 0.4
|
||||
, vault >= 0.3.1.1 && < 0.4
|
||||
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
|
|
@ -133,15 +136,13 @@ test-suite spec
|
|||
other-modules:
|
||||
Servant.API.ContentTypesSpec
|
||||
Servant.API.ResponseHeadersSpec
|
||||
Servant.Utils.LinksSpec
|
||||
Servant.Utils.EnterSpec
|
||||
Servant.LinksSpec
|
||||
|
||||
-- Dependencies inherited from the library. No need to specify bounds.
|
||||
build-depends:
|
||||
base
|
||||
, base-compat
|
||||
, aeson
|
||||
, attoparsec
|
||||
, bytestring
|
||||
, servant
|
||||
, string-conversions
|
||||
|
|
@ -153,23 +154,23 @@ test-suite spec
|
|||
|
||||
-- Additonal dependencies
|
||||
build-depends:
|
||||
aeson-compat >= 0.3.3 && < 0.4
|
||||
, hspec >= 2.4.4 && < 2.6
|
||||
, QuickCheck >= 2.10.1 && < 2.12
|
||||
, quickcheck-instances >= 0.3.16 && < 0.4
|
||||
aeson-compat >= 0.3.7.1 && < 0.4
|
||||
, hspec >= 2.5.1 && < 2.6
|
||||
, QuickCheck >= 2.11.3 && < 2.12
|
||||
, quickcheck-instances >= 0.3.18 && < 0.4
|
||||
|
||||
build-tool-depends:
|
||||
hspec-discover:hspec-discover >= 2.4.4 && < 2.6
|
||||
hspec-discover:hspec-discover >= 2.5.1 && < 2.6
|
||||
|
||||
test-suite doctests
|
||||
build-depends:
|
||||
base
|
||||
, servant
|
||||
, doctest >= 0.13.0 && <0.16
|
||||
, doctest >= 0.15.0 && <0.16
|
||||
|
||||
-- We test Links failure with doctest, so we need extra dependencies
|
||||
build-depends:
|
||||
hspec >= 2.4.4 && < 2.6
|
||||
hspec >= 2.5.1 && < 2.6
|
||||
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: test/doctests.hs
|
||||
|
|
@ -180,4 +181,4 @@ test-suite doctests
|
|||
x-doctest-options: -fdiagnostics-color=never
|
||||
include-dirs: include
|
||||
x-doctest-source-dirs: test
|
||||
x-doctest-modules: Servant.Utils.LinksSpec
|
||||
x-doctest-modules: Servant.LinksSpec
|
||||
|
|
|
|||
|
|
@ -63,8 +63,8 @@ module Servant.API (
|
|||
module Servant.API.Experimental.Auth,
|
||||
-- | General Authentication
|
||||
|
||||
-- * Utilities
|
||||
module Servant.Utils.Links,
|
||||
-- * Links
|
||||
module Servant.Links,
|
||||
-- | Type-safe internal URIs
|
||||
|
||||
-- * Re-exports
|
||||
|
|
@ -114,9 +114,9 @@ import Servant.API.ResponseHeaders
|
|||
ResponseHeader (..), addHeader, getHeadersHList, getResponse,
|
||||
noHeader)
|
||||
import Servant.API.Stream
|
||||
(BoundaryStrategy (..), BuildFromStream (..),
|
||||
ByteStringParser (..), FramingRender (..),
|
||||
FramingUnrender (..), NetstringFraming, NewlineFraming,
|
||||
(BoundaryStrategy (..), ByteStringParser (..),
|
||||
FramingRender (..), FramingUnrender (..),
|
||||
FromResultStream (..), NetstringFraming, NewlineFraming,
|
||||
NoFraming, ResultStream (..), Stream, StreamGenerator (..),
|
||||
StreamGet, StreamPost, ToStreamGenerator (..))
|
||||
import Servant.API.Sub
|
||||
|
|
@ -134,7 +134,7 @@ import Servant.API.Verbs
|
|||
ReflectMethod (reflectMethod), StdMethod (..), Verb)
|
||||
import Servant.API.WithNamedContext
|
||||
(WithNamedContext)
|
||||
import Servant.Utils.Links
|
||||
import Servant.Links
|
||||
(HasLink (..), IsElem, IsElem', Link, URI (..), safeLink)
|
||||
import Web.HttpApiData
|
||||
(FromHttpApiData (..), ToHttpApiData (..))
|
||||
|
|
|
|||
146
servant/src/Servant/API/Generic.hs
Normal file
146
servant/src/Servant/API/Generic.hs
Normal file
|
|
@ -0,0 +1,146 @@
|
|||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
-- | Define servant servers from record types. Generics for the win.
|
||||
--
|
||||
-- The usage is simple, if you only need a collection of routes. First you
|
||||
-- define a record with field types prefixed by a parameter `route`:
|
||||
--
|
||||
-- @
|
||||
-- data Routes route = Routes
|
||||
-- { _get :: route :- Capture "id" Int :> Get '[JSON] String
|
||||
-- , _put :: route :- ReqBody '[JSON] Int :> Put '[JSON] Bool
|
||||
-- }
|
||||
-- deriving ('Generic')
|
||||
-- @
|
||||
--
|
||||
-- You can get a 'Proxy' of the server using
|
||||
--
|
||||
-- @
|
||||
-- api :: Proxy (ToServantApi Routes)
|
||||
-- api = genericApi (Proxy :: Proxy Routes)
|
||||
-- @
|
||||
--
|
||||
-- Using 'genericApi' is better as it checks that instances exists,
|
||||
-- i.e. you get better error messages than simply using 'Proxy' value.
|
||||
--
|
||||
-- __Note:__ in 0.14 series this module isn't re-exported from 'Servant.API'.
|
||||
--
|
||||
-- "Servant.API.Generic" is based on @servant-generic@ package by
|
||||
-- [Patrick Chilton](https://github.com/chpatrick)
|
||||
--
|
||||
-- @since 0.14.1
|
||||
module Servant.API.Generic (
|
||||
GenericMode (..),
|
||||
GenericServant,
|
||||
ToServant,
|
||||
toServant,
|
||||
fromServant,
|
||||
-- * AsApi
|
||||
AsApi,
|
||||
ToServantApi,
|
||||
genericApi,
|
||||
-- * Utility
|
||||
GServantProduct,
|
||||
-- * re-exports
|
||||
Generic (Rep),
|
||||
) where
|
||||
|
||||
-- Based on servant-generic licensed under MIT License
|
||||
--
|
||||
-- Copyright (c) 2017 Patrick Chilton
|
||||
--
|
||||
-- Permission is hereby granted, free of charge, to any person obtaining a copy
|
||||
-- of this software and associated documentation files (the "Software"), to deal
|
||||
-- in the Software without restriction, including without limitation the rights
|
||||
-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
|
||||
-- copies of the Software, and to permit persons to whom the Software is
|
||||
-- furnished to do so, subject to the following conditions:
|
||||
--
|
||||
-- The above copyright notice and this permission notice shall be included in all
|
||||
-- copies or substantial portions of the Software.
|
||||
--
|
||||
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||||
-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||||
-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
|
||||
-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||||
-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
|
||||
-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
||||
-- SOFTWARE.
|
||||
|
||||
import Data.Proxy
|
||||
(Proxy (..))
|
||||
import GHC.Generics
|
||||
((:*:) (..), Generic (..), K1 (..), M1 (..))
|
||||
|
||||
import Servant.API.Alternative
|
||||
|
||||
-- | A constraint alias, for work with 'mode' and 'routes'.
|
||||
type GenericServant routes mode = (GenericMode mode, Generic (routes mode), GServantProduct (Rep (routes mode)))
|
||||
|
||||
-- | A class with a type family that applies an appropriate type family to the @api@
|
||||
-- parameter. For example, 'AsApi' will leave @api@ untouched, while
|
||||
-- @'AsServerT' m@ will produce @'ServerT' api m@.
|
||||
class GenericMode mode where
|
||||
type mode :- api :: *
|
||||
|
||||
infixl 0 :-
|
||||
|
||||
-- | Turns a generic product type into a tree of `:<|>` combinators.
|
||||
type ToServant routes mode = GToServant (Rep (routes mode))
|
||||
|
||||
type ToServantApi routes = ToServant routes AsApi
|
||||
|
||||
-- | See `ToServant`, but at value-level.
|
||||
toServant
|
||||
:: GenericServant routes mode
|
||||
=> routes mode -> ToServant routes mode
|
||||
toServant = gtoServant . from
|
||||
|
||||
-- | Inverse of `toServant`.
|
||||
--
|
||||
-- This can be used to turn 'generated' values such as client functions into records.
|
||||
--
|
||||
-- You may need to provide a type signature for the /output/ type (your record type).
|
||||
fromServant
|
||||
:: GenericServant routes mode
|
||||
=> ToServant routes mode -> routes mode
|
||||
fromServant = to . gfromServant
|
||||
|
||||
-- | A type that specifies that an API record contains an API definition. Only useful at type-level.
|
||||
data AsApi
|
||||
instance GenericMode AsApi where
|
||||
type AsApi :- api = api
|
||||
|
||||
-- | Get a 'Proxy' of an API type.
|
||||
genericApi
|
||||
:: GenericServant routes AsApi
|
||||
=> Proxy routes
|
||||
-> Proxy (ToServantApi routes)
|
||||
genericApi _ = Proxy
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Class
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
|
||||
class GServantProduct f where
|
||||
type GToServant f
|
||||
gtoServant :: f p -> GToServant f
|
||||
gfromServant :: GToServant f -> f p
|
||||
|
||||
instance GServantProduct f => GServantProduct (M1 i c f) where
|
||||
type GToServant (M1 i c f) = GToServant f
|
||||
gtoServant = gtoServant . unM1
|
||||
gfromServant = M1 . gfromServant
|
||||
|
||||
instance (GServantProduct l, GServantProduct r) => GServantProduct (l :*: r) where
|
||||
type GToServant (l :*: r) = GToServant l :<|> GToServant r
|
||||
gtoServant (l :*: r) = gtoServant l :<|> gtoServant r
|
||||
gfromServant (l :<|> r) = gfromServant l :*: gfromServant r
|
||||
|
||||
instance GServantProduct (K1 i c) where
|
||||
type GToServant (K1 i c) = c
|
||||
gtoServant = unK1
|
||||
gfromServant = K1
|
||||
|
|
@ -7,6 +7,7 @@
|
|||
module Servant.API.Internal.Test.ComprehensiveAPI where
|
||||
|
||||
import Data.Proxy
|
||||
(Proxy (..))
|
||||
import Servant.API
|
||||
|
||||
type GET = Get '[JSON] NoContent
|
||||
|
|
@ -38,6 +39,7 @@ type ComprehensiveAPIWithoutRaw =
|
|||
Vault :> GET :<|>
|
||||
Verb 'POST 204 '[JSON] NoContent :<|>
|
||||
Verb 'POST 204 '[JSON] Int :<|>
|
||||
Stream 'GET 200 NetstringFraming JSON [Int] :<|>
|
||||
WithNamedContext "foo" '[] GET :<|>
|
||||
CaptureAll "foo" Int :> GET :<|>
|
||||
Summary "foo" :> GET :<|>
|
||||
|
|
|
|||
|
|
@ -1,23 +1,48 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# OPTIONS_HADDOCK not-home #-}
|
||||
|
||||
module Servant.API.Stream where
|
||||
module Servant.API.Stream (
|
||||
Stream,
|
||||
StreamGet,
|
||||
StreamPost,
|
||||
-- * Sources
|
||||
--
|
||||
-- | Both 'StreamGenerator' and 'ResultStream' are equivalent
|
||||
-- to some *source* in streaming libraries.
|
||||
StreamGenerator (..),
|
||||
ToStreamGenerator (..),
|
||||
ResultStream (..),
|
||||
FromResultStream (..),
|
||||
-- * Framing
|
||||
FramingRender (..),
|
||||
FramingUnrender (..),
|
||||
BoundaryStrategy (..),
|
||||
ByteStringParser (..),
|
||||
-- ** Strategies
|
||||
NoFraming,
|
||||
NewlineFraming,
|
||||
NetstringFraming,
|
||||
) where
|
||||
|
||||
import Control.Arrow
|
||||
(first)
|
||||
import Data.ByteString.Lazy
|
||||
(ByteString, empty)
|
||||
import qualified Data.ByteString.Lazy.Char8 as LB
|
||||
import Data.Foldable
|
||||
(traverse_)
|
||||
import Data.List.NonEmpty
|
||||
(NonEmpty (..))
|
||||
import Data.Monoid
|
||||
((<>))
|
||||
import Data.Proxy
|
||||
|
|
@ -30,35 +55,82 @@ import GHC.TypeLits
|
|||
(Nat)
|
||||
import Network.HTTP.Types.Method
|
||||
(StdMethod (..))
|
||||
import System.IO.Unsafe
|
||||
(unsafeInterleaveIO)
|
||||
import Text.Read
|
||||
(readMaybe)
|
||||
|
||||
-- | A Stream endpoint for a given method emits a stream of encoded values at a given Content-Type, delimited by a framing strategy. Stream endpoints always return response code 200 on success. Type synonyms are provided for standard methods.
|
||||
-- | A Stream endpoint for a given method emits a stream of encoded values at a
|
||||
-- given Content-Type, delimited by a framing strategy. Stream endpoints always
|
||||
-- return response code 200 on success. Type synonyms are provided for standard
|
||||
-- methods.
|
||||
data Stream (method :: k1) (status :: Nat) (framing :: *) (contentType :: *) (a :: *)
|
||||
deriving (Typeable, Generic)
|
||||
|
||||
type StreamGet = Stream 'GET 200
|
||||
type StreamPost = Stream 'POST 200
|
||||
|
||||
-- | Stream endpoints may be implemented as producing a @StreamGenerator@ -- a function that itself takes two emit functions -- the first to be used on the first value the stream emits, and the second to be used on all subsequent values (to allow interspersed framing strategies such as comma separation).
|
||||
newtype StreamGenerator a = StreamGenerator {getStreamGenerator :: (a -> IO ()) -> (a -> IO ()) -> IO ()}
|
||||
-- | Stream endpoints may be implemented as producing a @StreamGenerator@ a
|
||||
-- function that itself takes two emit functions the first to be used on the
|
||||
-- first value the stream emits, and the second to be used on all subsequent
|
||||
-- values (to allow interspersed framing strategies such as comma separation).
|
||||
newtype StreamGenerator a = StreamGenerator { getStreamGenerator :: (a -> IO ()) -> (a -> IO ()) -> IO () }
|
||||
|
||||
-- | ToStreamGenerator is intended to be implemented for types such as Conduit, Pipe, etc. By implementing this class, all such streaming abstractions can be used directly as endpoints.
|
||||
class ToStreamGenerator a b | a -> b where
|
||||
toStreamGenerator :: a -> StreamGenerator b
|
||||
toStreamGenerator :: a -> StreamGenerator b
|
||||
|
||||
instance ToStreamGenerator (StreamGenerator a) a
|
||||
where toStreamGenerator x = x
|
||||
instance ToStreamGenerator (StreamGenerator a) a where
|
||||
toStreamGenerator x = x
|
||||
|
||||
-- | Clients reading from streaming endpoints can be implemented as producing a @ResultStream@ that captures the setup, takedown, and incremental logic for a read, being an IO continuation that takes a producer of Just either values or errors that terminates with a Nothing.
|
||||
newtype ResultStream a = ResultStream (forall b. (IO (Maybe (Either String a)) -> IO b) -> IO b)
|
||||
instance ToStreamGenerator (NonEmpty a) a where
|
||||
toStreamGenerator (x :| xs) = StreamGenerator $ \f g -> f x >> traverse_ g xs
|
||||
|
||||
-- | BuildFromStream is intended to be implemented for types such as Conduit, Pipe, etc. By implementing this class, all such streaming abstractions can be used directly on the client side for talking to streaming endpoints.
|
||||
class BuildFromStream a b where
|
||||
buildFromStream :: ResultStream a -> b
|
||||
instance ToStreamGenerator [a] a where
|
||||
toStreamGenerator [] = StreamGenerator $ \_ _ -> return ()
|
||||
toStreamGenerator (x : xs) = StreamGenerator $ \f g -> f x >> traverse_ g xs
|
||||
|
||||
instance BuildFromStream a (ResultStream a)
|
||||
where buildFromStream x = x
|
||||
-- | Clients reading from streaming endpoints can be implemented as producing a
|
||||
-- @ResultStream@ that captures the setup, takedown, and incremental logic for
|
||||
-- a read, being an IO continuation that takes a producer of Just either values
|
||||
-- or errors that terminates with a Nothing.
|
||||
newtype ResultStream a = ResultStream { runResultStream :: forall b. (IO (Maybe (Either String a)) -> IO b) -> IO b }
|
||||
|
||||
-- | FromResultStream is intended to be implemented for types such as Conduit, Pipe, etc. By implementing this class, all such streaming abstractions can be used directly on the client side for talking to streaming endpoints.
|
||||
class FromResultStream a b | b -> a where
|
||||
fromResultStream :: ResultStream a -> IO b
|
||||
|
||||
instance FromResultStream a (ResultStream a) where
|
||||
fromResultStream = return
|
||||
|
||||
-- | Uses 'unsafeInterleaveIO'
|
||||
instance FromResultStream a [a] where
|
||||
fromResultStream x = runResultStream x lazyRead
|
||||
|
||||
-- | Uses 'unsafeInterleaveIO'
|
||||
instance FromResultStream a (NonEmpty a) where
|
||||
fromResultStream x = runResultStream x $ \r -> do
|
||||
e <- r
|
||||
case e of
|
||||
Nothing -> fail "Empty stream"
|
||||
Just (Left er) -> fail er
|
||||
Just (Right y) -> do
|
||||
ys <- lazyRead r
|
||||
return (y :| ys)
|
||||
|
||||
lazyRead :: IO (Maybe (Either String a)) -> IO [a]
|
||||
lazyRead r = go
|
||||
where
|
||||
go = unsafeInterleaveIO loop
|
||||
|
||||
loop = do
|
||||
e <- r
|
||||
case e of
|
||||
Nothing -> return []
|
||||
Just (Left er) -> fail er
|
||||
Just (Right y) -> do
|
||||
ys <- go
|
||||
return (y : ys)
|
||||
|
||||
-- | The FramingRender class provides the logic for emitting a framing strategy. The strategy emits a header, followed by boundary-delimited data, and finally a termination character. For many strategies, some of these will just be empty bytestrings.
|
||||
class FramingRender strategy a where
|
||||
|
|
@ -74,10 +146,10 @@ data BoundaryStrategy = BoundaryStrategyBracket (ByteString -> (ByteString,ByteS
|
|||
| BoundaryStrategyGeneral (ByteString -> ByteString)
|
||||
|
||||
-- | A type of parser that can never fail, and has different parsing strategies (incremental, or EOF) depending if more input can be sent. The incremental parser should return `Nothing` if it would like to be sent a longer ByteString. If it returns a value, it also returns the remainder following that value.
|
||||
data ByteStringParser a = ByteStringParser {
|
||||
parseIncremental :: ByteString -> Maybe (a, ByteString),
|
||||
parseEOF :: ByteString -> (a, ByteString)
|
||||
}
|
||||
data ByteStringParser a = ByteStringParser
|
||||
{ parseIncremental :: ByteString -> Maybe (a, ByteString)
|
||||
, parseEOF :: ByteString -> (a, ByteString)
|
||||
}
|
||||
|
||||
-- | The FramingUnrender class provides the logic for parsing a framing strategy. The outer @ByteStringParser@ strips the header from a stream of bytes, and yields a parser that can handle the remainder, stepwise. Each frame may be a ByteString, or a String indicating the error state for that frame. Such states are per-frame, so that protocols that can resume after errors are able to do so. Eventually this returns an empty ByteString to indicate termination.
|
||||
class FramingUnrender strategy a where
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@ type Patch = Verb 'PATCH 200
|
|||
--
|
||||
-- If the resource cannot be created immediately, use 'PostAccepted'.
|
||||
--
|
||||
-- Consider using 'Servant.Utils.Links.safeLink' for the @Location@ header
|
||||
-- Consider using 'Servant.Links.safeLink' for the @Location@ header
|
||||
-- field.
|
||||
|
||||
-- | 'POST' with 201 status code.
|
||||
|
|
|
|||
573
servant/src/Servant/Links.hs
Normal file
573
servant/src/Servant/Links.hs
Normal file
|
|
@ -0,0 +1,573 @@
|
|||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_HADDOCK not-home #-}
|
||||
|
||||
-- | Type safe generation of internal links.
|
||||
--
|
||||
-- Given an API with a few endpoints:
|
||||
--
|
||||
-- >>> :set -XDataKinds -XTypeFamilies -XTypeOperators
|
||||
-- >>> import Servant.API
|
||||
-- >>> import Servant.Links
|
||||
-- >>> import Data.Proxy
|
||||
-- >>>
|
||||
-- >>> type Hello = "hello" :> Get '[JSON] Int
|
||||
-- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent
|
||||
-- >>> type API = Hello :<|> Bye
|
||||
-- >>> let api = Proxy :: Proxy API
|
||||
--
|
||||
-- It is possible to generate links that are guaranteed to be within 'API' with
|
||||
-- 'safeLink'. The first argument to 'safeLink' is a type representing the API
|
||||
-- you would like to restrict links to. The second argument is the destination
|
||||
-- endpoint you would like the link to point to, this will need to end with a
|
||||
-- verb like GET or POST. Further arguments may be required depending on the
|
||||
-- type of the endpoint. If everything lines up you will get a 'Link' out the
|
||||
-- other end.
|
||||
--
|
||||
-- You may omit 'QueryParam's and the like should you not want to provide them,
|
||||
-- but types which form part of the URL path like 'Capture' must be included.
|
||||
-- The reason you may want to omit 'QueryParam's is that safeLink is a bit
|
||||
-- magical: if parameters are included that could take input it will return a
|
||||
-- function that accepts that input and generates a link. This is best shown
|
||||
-- with an example. Here, a link is generated with no parameters:
|
||||
--
|
||||
-- >>> let hello = Proxy :: Proxy ("hello" :> Get '[JSON] Int)
|
||||
-- >>> toUrlPiece (safeLink api hello :: Link)
|
||||
-- "hello"
|
||||
--
|
||||
-- If the API has an endpoint with parameters then we can generate links with
|
||||
-- or without those:
|
||||
--
|
||||
-- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] NoContent)
|
||||
-- >>> toUrlPiece $ safeLink api with (Just "Hubert")
|
||||
-- "bye?name=Hubert"
|
||||
--
|
||||
-- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] NoContent)
|
||||
-- >>> toUrlPiece $ safeLink api without
|
||||
-- "bye"
|
||||
--
|
||||
-- If you would like create a helper for generating links only within that API,
|
||||
-- you can partially apply safeLink if you specify a correct type signature
|
||||
-- like so:
|
||||
--
|
||||
-- >>> :set -XConstraintKinds
|
||||
-- >>> :{
|
||||
-- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint)
|
||||
-- >>> => Proxy endpoint -> MkLink endpoint Link
|
||||
-- >>> apiLink = safeLink api
|
||||
-- >>> :}
|
||||
--
|
||||
-- `safeLink'` allows to make specialise the output:
|
||||
--
|
||||
-- >>> safeLink' toUrlPiece api without
|
||||
-- "bye"
|
||||
--
|
||||
-- >>> :{
|
||||
-- >>> let apiTextLink :: (IsElem endpoint API, HasLink endpoint)
|
||||
-- >>> => Proxy endpoint -> MkLink endpoint Text
|
||||
-- >>> apiTextLink = safeLink' toUrlPiece api
|
||||
-- >>> :}
|
||||
--
|
||||
-- >>> apiTextLink without
|
||||
-- "bye"
|
||||
--
|
||||
-- Attempting to construct a link to an endpoint that does not exist in api
|
||||
-- will result in a type error like this:
|
||||
--
|
||||
-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent)
|
||||
-- >>> safeLink api bad_link
|
||||
-- ...
|
||||
-- ...Could not deduce...
|
||||
-- ...
|
||||
--
|
||||
-- This error is essentially saying that the type family couldn't find
|
||||
-- bad_link under api after trying the open (but empty) type family
|
||||
-- `IsElem'` as a last resort.
|
||||
--
|
||||
-- @since 0.14.1
|
||||
module Servant.Links (
|
||||
module Servant.API.TypeLevel,
|
||||
|
||||
-- * Building and using safe links
|
||||
--
|
||||
-- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package.
|
||||
safeLink
|
||||
, safeLink'
|
||||
, allLinks
|
||||
, allLinks'
|
||||
, URI(..)
|
||||
-- * Generics
|
||||
, AsLink
|
||||
, fieldLink
|
||||
, fieldLink'
|
||||
, allFieldLinks
|
||||
, allFieldLinks'
|
||||
-- * Adding custom types
|
||||
, HasLink(..)
|
||||
, Link
|
||||
, linkURI
|
||||
, linkURI'
|
||||
, LinkArrayElementStyle (..)
|
||||
-- ** Link accessors
|
||||
, Param (..)
|
||||
, linkSegments
|
||||
, linkQueryParams
|
||||
) where
|
||||
|
||||
import Data.List
|
||||
import Data.Proxy
|
||||
(Proxy (..))
|
||||
import Data.Semigroup
|
||||
((<>))
|
||||
import Data.Singletons.Bool
|
||||
(SBool (..), SBoolI (..))
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import Data.Type.Bool
|
||||
(If)
|
||||
import GHC.TypeLits
|
||||
(KnownSymbol, symbolVal)
|
||||
import Network.URI
|
||||
(URI (..), escapeURIString, isUnreserved)
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Servant.API.Alternative
|
||||
((:<|>) ((:<|>)))
|
||||
import Servant.API.BasicAuth
|
||||
(BasicAuth)
|
||||
import Servant.API.Capture
|
||||
(Capture', CaptureAll)
|
||||
import Servant.API.Description
|
||||
(Description, Summary)
|
||||
import Servant.API.Empty
|
||||
(EmptyAPI (..))
|
||||
import Servant.API.Experimental.Auth
|
||||
(AuthProtect)
|
||||
import Servant.API.Generic
|
||||
import Servant.API.Header
|
||||
(Header')
|
||||
import Servant.API.HttpVersion
|
||||
(HttpVersion)
|
||||
import Servant.API.IsSecure
|
||||
(IsSecure)
|
||||
import Servant.API.Modifiers
|
||||
(FoldRequired)
|
||||
import Servant.API.QueryParam
|
||||
(QueryFlag, QueryParam', QueryParams)
|
||||
import Servant.API.Raw
|
||||
(Raw)
|
||||
import Servant.API.RemoteHost
|
||||
(RemoteHost)
|
||||
import Servant.API.ReqBody
|
||||
(ReqBody')
|
||||
import Servant.API.Stream
|
||||
(Stream)
|
||||
import Servant.API.Sub
|
||||
(type (:>))
|
||||
import Servant.API.TypeLevel
|
||||
import Servant.API.Vault
|
||||
(Vault)
|
||||
import Servant.API.Verbs
|
||||
(Verb)
|
||||
import Servant.API.WithNamedContext
|
||||
(WithNamedContext)
|
||||
import Web.HttpApiData
|
||||
|
||||
-- | A safe link datatype.
|
||||
-- The only way of constructing a 'Link' is using 'safeLink', which means any
|
||||
-- 'Link' is guaranteed to be part of the mentioned API.
|
||||
data Link = Link
|
||||
{ _segments :: [Escaped]
|
||||
, _queryParams :: [Param]
|
||||
} deriving Show
|
||||
|
||||
newtype Escaped = Escaped String
|
||||
|
||||
escaped :: String -> Escaped
|
||||
escaped = Escaped . escapeURIString isUnreserved
|
||||
|
||||
getEscaped :: Escaped -> String
|
||||
getEscaped (Escaped s) = s
|
||||
|
||||
instance Show Escaped where
|
||||
showsPrec d (Escaped s) = showsPrec d s
|
||||
show (Escaped s) = show s
|
||||
|
||||
linkSegments :: Link -> [String]
|
||||
linkSegments = map getEscaped . _segments
|
||||
|
||||
linkQueryParams :: Link -> [Param]
|
||||
linkQueryParams = _queryParams
|
||||
|
||||
instance ToHttpApiData Link where
|
||||
toHeader = TE.encodeUtf8 . toUrlPiece
|
||||
toUrlPiece l =
|
||||
let uri = linkURI l
|
||||
in Text.pack $ uriPath uri ++ uriQuery uri
|
||||
|
||||
-- | Query parameter.
|
||||
data Param
|
||||
= SingleParam String Text.Text
|
||||
| ArrayElemParam String Text.Text
|
||||
| FlagParam String
|
||||
deriving Show
|
||||
|
||||
addSegment :: Escaped -> Link -> Link
|
||||
addSegment seg l = l { _segments = _segments l <> [seg] }
|
||||
|
||||
addQueryParam :: Param -> Link -> Link
|
||||
addQueryParam qp l =
|
||||
l { _queryParams = _queryParams l <> [qp] }
|
||||
|
||||
-- | Transform 'Link' into 'URI'.
|
||||
--
|
||||
-- >>> type API = "something" :> Get '[JSON] Int
|
||||
-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)
|
||||
-- something
|
||||
--
|
||||
-- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int
|
||||
-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
|
||||
-- sum?x[]=1&x[]=2&x[]=3
|
||||
--
|
||||
-- >>> type API = "foo/bar" :> Get '[JSON] Int
|
||||
-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)
|
||||
-- foo%2Fbar
|
||||
--
|
||||
-- >>> type SomeRoute = "abc" :> Capture "email" String :> Put '[JSON] ()
|
||||
-- >>> let someRoute = Proxy :: Proxy SomeRoute
|
||||
-- >>> safeLink someRoute someRoute "test@example.com"
|
||||
-- Link {_segments = ["abc","test%40example.com"], _queryParams = []}
|
||||
--
|
||||
-- >>> linkURI $ safeLink someRoute someRoute "test@example.com"
|
||||
-- abc/test%40example.com
|
||||
--
|
||||
linkURI :: Link -> URI
|
||||
linkURI = linkURI' LinkArrayElementBracket
|
||||
|
||||
-- | How to encode array query elements.
|
||||
data LinkArrayElementStyle
|
||||
= LinkArrayElementBracket -- ^ @foo[]=1&foo[]=2@
|
||||
| LinkArrayElementPlain -- ^ @foo=1&foo=2@
|
||||
deriving (Eq, Ord, Show, Enum, Bounded)
|
||||
|
||||
-- | Configurable 'linkURI'.
|
||||
--
|
||||
-- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int
|
||||
-- >>> linkURI' LinkArrayElementBracket $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
|
||||
-- sum?x[]=1&x[]=2&x[]=3
|
||||
--
|
||||
-- >>> linkURI' LinkArrayElementPlain $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
|
||||
-- sum?x=1&x=2&x=3
|
||||
--
|
||||
linkURI' :: LinkArrayElementStyle -> Link -> URI
|
||||
linkURI' addBrackets (Link segments q_params) =
|
||||
URI mempty -- No scheme (relative)
|
||||
Nothing -- Or authority (relative)
|
||||
(intercalate "/" $ map getEscaped segments)
|
||||
(makeQueries q_params) mempty
|
||||
where
|
||||
makeQueries :: [Param] -> String
|
||||
makeQueries [] = ""
|
||||
makeQueries xs =
|
||||
"?" <> intercalate "&" (fmap makeQuery xs)
|
||||
|
||||
makeQuery :: Param -> String
|
||||
makeQuery (ArrayElemParam k v) = escape k <> style <> escape (Text.unpack v)
|
||||
makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v)
|
||||
makeQuery (FlagParam k) = escape k
|
||||
|
||||
style = case addBrackets of
|
||||
LinkArrayElementBracket -> "[]="
|
||||
LinkArrayElementPlain -> "="
|
||||
|
||||
escape :: String -> String
|
||||
escape = escapeURIString isUnreserved
|
||||
|
||||
-- | Create a valid (by construction) relative URI with query params.
|
||||
--
|
||||
-- This function will only typecheck if `endpoint` is part of the API `api`
|
||||
safeLink
|
||||
:: forall endpoint api. (IsElem endpoint api, HasLink endpoint)
|
||||
=> Proxy api -- ^ The whole API that this endpoint is a part of
|
||||
-> Proxy endpoint -- ^ The API endpoint you would like to point to
|
||||
-> MkLink endpoint Link
|
||||
safeLink = safeLink' id
|
||||
|
||||
-- | More general 'safeLink'.
|
||||
--
|
||||
safeLink'
|
||||
:: forall endpoint api a. (IsElem endpoint api, HasLink endpoint)
|
||||
=> (Link -> a)
|
||||
-> Proxy api -- ^ The whole API that this endpoint is a part of
|
||||
-> Proxy endpoint -- ^ The API endpoint you would like to point to
|
||||
-> MkLink endpoint a
|
||||
safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty)
|
||||
|
||||
-- | Create all links in an API.
|
||||
--
|
||||
-- Note that the @api@ type must be restricted to the endpoints that have
|
||||
-- valid links to them.
|
||||
--
|
||||
-- >>> type API = "foo" :> Capture "name" Text :> Get '[JSON] Text :<|> "bar" :> Capture "name" Int :> Get '[JSON] Double
|
||||
-- >>> let fooLink :<|> barLink = allLinks (Proxy :: Proxy API)
|
||||
-- >>> :t fooLink
|
||||
-- fooLink :: Text -> Link
|
||||
-- >>> :t barLink
|
||||
-- barLink :: Int -> Link
|
||||
--
|
||||
-- Note: nested APIs don't work well with this approach
|
||||
--
|
||||
-- >>> :kind! MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link
|
||||
-- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link :: *
|
||||
-- = Char -> (Int -> Link) :<|> (Double -> Link)
|
||||
allLinks
|
||||
:: forall api. HasLink api
|
||||
=> Proxy api
|
||||
-> MkLink api Link
|
||||
allLinks = allLinks' id
|
||||
|
||||
-- | More general 'allLinks'. See `safeLink'`.
|
||||
allLinks'
|
||||
:: forall api a. HasLink api
|
||||
=> (Link -> a)
|
||||
-> Proxy api
|
||||
-> MkLink api a
|
||||
allLinks' toA api = toLink toA api (Link mempty mempty)
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Generics
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
-- | Given an API record field, create a link for that route. Only the field's
|
||||
-- type is used.
|
||||
--
|
||||
-- @
|
||||
-- data Record route = Record
|
||||
-- { _get :: route :- Capture "id" Int :> Get '[JSON] String
|
||||
-- , _put :: route :- ReqBody '[JSON] Int :> Put '[JSON] Bool
|
||||
-- }
|
||||
-- deriving ('Generic')
|
||||
--
|
||||
-- getLink :: Int -> Link
|
||||
-- getLink = 'fieldLink' _get
|
||||
-- @
|
||||
--
|
||||
-- @since 0.14.1
|
||||
fieldLink
|
||||
:: ( IsElem endpoint (ToServantApi routes), HasLink endpoint
|
||||
, GenericServant routes AsApi
|
||||
)
|
||||
=> (routes AsApi -> endpoint)
|
||||
-> MkLink endpoint Link
|
||||
fieldLink = fieldLink' id
|
||||
|
||||
-- | More general version of 'fieldLink'
|
||||
--
|
||||
-- @since 0.14.1
|
||||
fieldLink'
|
||||
:: forall routes endpoint a.
|
||||
( IsElem endpoint (ToServantApi routes), HasLink endpoint
|
||||
, GenericServant routes AsApi
|
||||
)
|
||||
=> (Link -> a)
|
||||
-> (routes AsApi -> endpoint)
|
||||
-> MkLink endpoint a
|
||||
fieldLink' toA _ = safeLink' toA (genericApi (Proxy :: Proxy routes)) (Proxy :: Proxy endpoint)
|
||||
|
||||
-- | A type that specifies that an API record contains a set of links.
|
||||
--
|
||||
-- @since 0.14.1
|
||||
data AsLink (a :: *)
|
||||
instance GenericMode (AsLink a) where
|
||||
type (AsLink a) :- api = MkLink api a
|
||||
|
||||
-- | Get all links as a record.
|
||||
--
|
||||
-- @since 0.14.1
|
||||
allFieldLinks
|
||||
:: ( HasLink (ToServantApi routes)
|
||||
, GenericServant routes (AsLink Link)
|
||||
, ToServant routes (AsLink Link) ~ MkLink (ToServantApi routes) Link
|
||||
)
|
||||
=> routes (AsLink Link)
|
||||
allFieldLinks = allFieldLinks' id
|
||||
|
||||
-- | More general version of 'allFieldLinks'.
|
||||
--
|
||||
-- @since 0.14.1
|
||||
allFieldLinks'
|
||||
:: forall routes a.
|
||||
( HasLink (ToServantApi routes)
|
||||
, GenericServant routes (AsLink a)
|
||||
, ToServant routes (AsLink a) ~ MkLink (ToServantApi routes) a
|
||||
)
|
||||
=> (Link -> a)
|
||||
-> routes (AsLink a)
|
||||
allFieldLinks' toA
|
||||
= fromServant
|
||||
$ allLinks' toA (Proxy :: Proxy (ToServantApi routes))
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- HasLink
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
-- | Construct a toLink for an endpoint.
|
||||
class HasLink endpoint where
|
||||
type MkLink endpoint (a :: *)
|
||||
toLink
|
||||
:: (Link -> a)
|
||||
-> Proxy endpoint -- ^ The API endpoint you would like to point to
|
||||
-> Link
|
||||
-> MkLink endpoint a
|
||||
|
||||
-- Naked symbol instance
|
||||
instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where
|
||||
type MkLink (sym :> sub) a = MkLink sub a
|
||||
toLink toA _ =
|
||||
toLink toA (Proxy :: Proxy sub) . addSegment (escaped seg)
|
||||
where
|
||||
seg = symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
-- QueryParam instances
|
||||
instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods))
|
||||
=> HasLink (QueryParam' mods sym v :> sub)
|
||||
where
|
||||
type MkLink (QueryParam' mods sym v :> sub) a = If (FoldRequired mods) v (Maybe v) -> MkLink sub a
|
||||
toLink toA _ l mv =
|
||||
toLink toA (Proxy :: Proxy sub) $
|
||||
case sbool :: SBool (FoldRequired mods) of
|
||||
STrue -> (addQueryParam . SingleParam k . toQueryParam) mv l
|
||||
SFalse -> maybe id (addQueryParam . SingleParam k . toQueryParam) mv l
|
||||
where
|
||||
k :: String
|
||||
k = symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
instance (KnownSymbol sym, ToHttpApiData v, HasLink sub)
|
||||
=> HasLink (QueryParams sym v :> sub)
|
||||
where
|
||||
type MkLink (QueryParams sym v :> sub) a = [v] -> MkLink sub a
|
||||
toLink toA _ l =
|
||||
toLink toA (Proxy :: Proxy sub) .
|
||||
foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l
|
||||
where
|
||||
k = symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
instance (KnownSymbol sym, HasLink sub)
|
||||
=> HasLink (QueryFlag sym :> sub)
|
||||
where
|
||||
type MkLink (QueryFlag sym :> sub) a = Bool -> MkLink sub a
|
||||
toLink toA _ l False =
|
||||
toLink toA (Proxy :: Proxy sub) l
|
||||
toLink toA _ l True =
|
||||
toLink toA (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l
|
||||
where
|
||||
k = symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
-- :<|> instance - Generate all links at once
|
||||
instance (HasLink a, HasLink b) => HasLink (a :<|> b) where
|
||||
type MkLink (a :<|> b) r = MkLink a r :<|> MkLink b r
|
||||
toLink toA _ l = toLink toA (Proxy :: Proxy a) l :<|> toLink toA (Proxy :: Proxy b) l
|
||||
|
||||
-- Misc instances
|
||||
instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where
|
||||
type MkLink (ReqBody' mods ct a :> sub) r = MkLink sub r
|
||||
toLink toA _ = toLink toA (Proxy :: Proxy sub)
|
||||
|
||||
instance (ToHttpApiData v, HasLink sub)
|
||||
=> HasLink (Capture' mods sym v :> sub)
|
||||
where
|
||||
type MkLink (Capture' mods sym v :> sub) a = v -> MkLink sub a
|
||||
toLink toA _ l v =
|
||||
toLink toA (Proxy :: Proxy sub) $
|
||||
addSegment (escaped . Text.unpack $ toUrlPiece v) l
|
||||
|
||||
instance (ToHttpApiData v, HasLink sub)
|
||||
=> HasLink (CaptureAll sym v :> sub)
|
||||
where
|
||||
type MkLink (CaptureAll sym v :> sub) a = [v] -> MkLink sub a
|
||||
toLink toA _ l vs = toLink toA (Proxy :: Proxy sub) $
|
||||
foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs
|
||||
|
||||
instance HasLink sub => HasLink (Header' mods sym (a :: *) :> sub) where
|
||||
type MkLink (Header' mods sym a :> sub) r = MkLink sub r
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (Vault :> sub) where
|
||||
type MkLink (Vault :> sub) a = MkLink sub a
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (Description s :> sub) where
|
||||
type MkLink (Description s :> sub) a = MkLink sub a
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (Summary s :> sub) where
|
||||
type MkLink (Summary s :> sub) a = MkLink sub a
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (HttpVersion :> sub) where
|
||||
type MkLink (HttpVersion:> sub) a = MkLink sub a
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (IsSecure :> sub) where
|
||||
type MkLink (IsSecure :> sub) a = MkLink sub a
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (WithNamedContext name context sub) where
|
||||
type MkLink (WithNamedContext name context sub) a = MkLink sub a
|
||||
toLink toA _ = toLink toA (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (RemoteHost :> sub) where
|
||||
type MkLink (RemoteHost :> sub) a = MkLink sub a
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (BasicAuth realm a :> sub) where
|
||||
type MkLink (BasicAuth realm a :> sub) r = MkLink sub r
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink EmptyAPI where
|
||||
type MkLink EmptyAPI a = EmptyAPI
|
||||
toLink _ _ _ = EmptyAPI
|
||||
|
||||
-- Verb (terminal) instances
|
||||
instance HasLink (Verb m s ct a) where
|
||||
type MkLink (Verb m s ct a) r = r
|
||||
toLink toA _ = toA
|
||||
|
||||
instance HasLink Raw where
|
||||
type MkLink Raw a = a
|
||||
toLink toA _ = toA
|
||||
|
||||
instance HasLink (Stream m status fr ct a) where
|
||||
type MkLink (Stream m status fr ct a) r = r
|
||||
toLink toA _ = toA
|
||||
|
||||
-- AuthProtext instances
|
||||
instance HasLink sub => HasLink (AuthProtect tag :> sub) where
|
||||
type MkLink (AuthProtect tag :> sub) a = MkLink sub a
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
-- | Helper for implemneting 'toLink' for combinators not affecting link
|
||||
-- structure.
|
||||
simpleToLink
|
||||
:: forall sub a combinator.
|
||||
(HasLink sub, MkLink sub a ~ MkLink (combinator :> sub) a)
|
||||
=> Proxy sub
|
||||
-> (Link -> a)
|
||||
-> Proxy (combinator :> sub)
|
||||
-> Link
|
||||
-> MkLink (combinator :> sub) a
|
||||
simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)
|
||||
|
||||
|
||||
-- $setup
|
||||
-- >>> import Servant.API
|
||||
-- >>> import Data.Text (Text)
|
||||
|
|
@ -1,122 +0,0 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
module Servant.Utils.Enter {-# DEPRECATED "Use hoistServer or hoistServerWithContext from servant-server" #-} (
|
||||
module Servant.Utils.Enter,
|
||||
-- * natural-transformation re-exports
|
||||
(:~>)(..),
|
||||
) where
|
||||
|
||||
import Control.Monad.Identity
|
||||
import Control.Monad.Morph
|
||||
import Control.Monad.Reader
|
||||
import qualified Control.Monad.State.Lazy as LState
|
||||
import qualified Control.Monad.State.Strict as SState
|
||||
import qualified Control.Monad.Writer.Lazy as LWriter
|
||||
import qualified Control.Monad.Writer.Strict as SWriter
|
||||
import Control.Natural
|
||||
import Data.Tagged
|
||||
(Tagged, retag)
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
import Servant.API
|
||||
|
||||
-- | Helper type family to state the 'Enter' symmetry.
|
||||
type family Entered m n api where
|
||||
Entered m n (a -> api) = a -> Entered m n api
|
||||
Entered m n (m a) = n a
|
||||
Entered m n (api1 :<|> api2) = Entered m n api1 :<|> Entered m n api2
|
||||
Entered m n (Tagged m a) = Tagged n a
|
||||
|
||||
class
|
||||
( Entered m n typ ~ ret
|
||||
, Entered n m ret ~ typ
|
||||
) => Enter typ m n ret | typ m n -> ret, ret m n -> typ, ret typ m -> n, ret typ n -> m
|
||||
where
|
||||
-- | Map the leafs of an API type.
|
||||
enter :: (m :~> n) -> typ -> ret
|
||||
|
||||
-- ** Servant combinators
|
||||
|
||||
instance
|
||||
( Enter typ1 m1 n1 ret1, Enter typ2 m2 n2 ret2
|
||||
, m1 ~ m2, n1 ~ n2
|
||||
, Entered m1 n1 (typ1 :<|> typ2) ~ (ret1 :<|> ret2)
|
||||
, Entered n1 m1 (ret1 :<|> ret2) ~ (typ1 :<|> typ2)
|
||||
) => Enter (typ1 :<|> typ2) m1 n1 (ret1 :<|> ret2)
|
||||
where
|
||||
enter e (a :<|> b) = enter e a :<|> enter e b
|
||||
|
||||
instance
|
||||
( Enter typ m n ret
|
||||
, Entered m n (a -> typ) ~ (a -> ret)
|
||||
, Entered n m (a -> ret) ~ (a -> typ)
|
||||
) => Enter (a -> typ) m n (a -> ret)
|
||||
where
|
||||
enter arg f a = enter arg (f a)
|
||||
|
||||
-- ** Leaf instances
|
||||
|
||||
instance
|
||||
( Entered m n (Tagged m a) ~ Tagged n a
|
||||
, Entered n m (Tagged n a) ~ Tagged m a
|
||||
) => Enter (Tagged m a) m n (Tagged n a)
|
||||
where
|
||||
enter _ = retag
|
||||
|
||||
instance
|
||||
( Entered m n (m a) ~ n a
|
||||
, Entered n m (n a) ~ m a
|
||||
) => Enter (m a) m n (n a)
|
||||
where
|
||||
enter (NT f) = f
|
||||
|
||||
-- | Like `lift`.
|
||||
liftNat :: (Control.Monad.Morph.MonadTrans t, Monad m) => m :~> t m
|
||||
liftNat = NT Control.Monad.Morph.lift
|
||||
|
||||
runReaderTNat :: r -> (ReaderT r m :~> m)
|
||||
runReaderTNat a = NT (`runReaderT` a)
|
||||
|
||||
evalStateTLNat :: Monad m => s -> (LState.StateT s m :~> m)
|
||||
evalStateTLNat a = NT (`LState.evalStateT` a)
|
||||
|
||||
evalStateTSNat :: Monad m => s -> (SState.StateT s m :~> m)
|
||||
evalStateTSNat a = NT (`SState.evalStateT` a)
|
||||
|
||||
-- | Log the contents of `SWriter.WriterT` with the function provided as the
|
||||
-- first argument, and return the value of the @WriterT@ computation
|
||||
logWriterTSNat :: MonadIO m => (w -> IO ()) -> (SWriter.WriterT w m :~> m)
|
||||
logWriterTSNat logger = NT $ \x -> do
|
||||
(a, w) <- SWriter.runWriterT x
|
||||
liftIO $ logger w
|
||||
return a
|
||||
|
||||
-- | Like `logWriterTSNat`, but for lazy @WriterT@.
|
||||
logWriterTLNat :: MonadIO m => (w -> IO ()) -> (LWriter.WriterT w m :~> m)
|
||||
logWriterTLNat logger = NT $ \x -> do
|
||||
(a, w) <- LWriter.runWriterT x
|
||||
liftIO $ logger w
|
||||
return a
|
||||
|
||||
-- | Like @mmorph@'s `hoist`.
|
||||
hoistNat :: (MFunctor t, Monad m) => (m :~> n) -> (t m :~> t n)
|
||||
hoistNat (NT n) = NT $ hoist n
|
||||
|
||||
-- | Like @mmorph@'s `embed`.
|
||||
embedNat :: (MMonad t, Monad n) => (m :~> t n) -> (t m :~> t n)
|
||||
embedNat (NT n) = NT $ embed n
|
||||
|
||||
-- | Like @mmorph@'s `squash`.
|
||||
squashNat :: (Monad m, MMonad t) => t (t m) :~> t m
|
||||
squashNat = NT squash
|
||||
|
||||
-- | Like @mmorph@'s `generalize`.
|
||||
generalizeNat :: Applicative m => Identity :~> m
|
||||
generalizeNat = NT (pure . runIdentity)
|
||||
|
|
@ -1,487 +1,6 @@
|
|||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_HADDOCK not-home #-}
|
||||
|
||||
-- | Type safe generation of internal links.
|
||||
--
|
||||
-- Given an API with a few endpoints:
|
||||
--
|
||||
-- >>> :set -XDataKinds -XTypeFamilies -XTypeOperators
|
||||
-- >>> import Servant.API
|
||||
-- >>> import Servant.Utils.Links
|
||||
-- >>> import Data.Proxy
|
||||
-- >>>
|
||||
-- >>> type Hello = "hello" :> Get '[JSON] Int
|
||||
-- >>> type Bye = "bye" :> QueryParam "name" String :> Delete '[JSON] NoContent
|
||||
-- >>> type API = Hello :<|> Bye
|
||||
-- >>> let api = Proxy :: Proxy API
|
||||
--
|
||||
-- It is possible to generate links that are guaranteed to be within 'API' with
|
||||
-- 'safeLink'. The first argument to 'safeLink' is a type representing the API
|
||||
-- you would like to restrict links to. The second argument is the destination
|
||||
-- endpoint you would like the link to point to, this will need to end with a
|
||||
-- verb like GET or POST. Further arguments may be required depending on the
|
||||
-- type of the endpoint. If everything lines up you will get a 'Link' out the
|
||||
-- other end.
|
||||
--
|
||||
-- You may omit 'QueryParam's and the like should you not want to provide them,
|
||||
-- but types which form part of the URL path like 'Capture' must be included.
|
||||
-- The reason you may want to omit 'QueryParam's is that safeLink is a bit
|
||||
-- magical: if parameters are included that could take input it will return a
|
||||
-- function that accepts that input and generates a link. This is best shown
|
||||
-- with an example. Here, a link is generated with no parameters:
|
||||
--
|
||||
-- >>> let hello = Proxy :: Proxy ("hello" :> Get '[JSON] Int)
|
||||
-- >>> toUrlPiece (safeLink api hello :: Link)
|
||||
-- "hello"
|
||||
--
|
||||
-- If the API has an endpoint with parameters then we can generate links with
|
||||
-- or without those:
|
||||
--
|
||||
-- >>> let with = Proxy :: Proxy ("bye" :> QueryParam "name" String :> Delete '[JSON] NoContent)
|
||||
-- >>> toUrlPiece $ safeLink api with (Just "Hubert")
|
||||
-- "bye?name=Hubert"
|
||||
--
|
||||
-- >>> let without = Proxy :: Proxy ("bye" :> Delete '[JSON] NoContent)
|
||||
-- >>> toUrlPiece $ safeLink api without
|
||||
-- "bye"
|
||||
--
|
||||
-- If you would like create a helper for generating links only within that API,
|
||||
-- you can partially apply safeLink if you specify a correct type signature
|
||||
-- like so:
|
||||
--
|
||||
-- >>> :set -XConstraintKinds
|
||||
-- >>> :{
|
||||
-- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint)
|
||||
-- >>> => Proxy endpoint -> MkLink endpoint Link
|
||||
-- >>> apiLink = safeLink api
|
||||
-- >>> :}
|
||||
--
|
||||
-- `safeLink'` allows to make specialise the output:
|
||||
--
|
||||
-- >>> safeLink' toUrlPiece api without
|
||||
-- "bye"
|
||||
--
|
||||
-- >>> :{
|
||||
-- >>> let apiTextLink :: (IsElem endpoint API, HasLink endpoint)
|
||||
-- >>> => Proxy endpoint -> MkLink endpoint Text
|
||||
-- >>> apiTextLink = safeLink' toUrlPiece api
|
||||
-- >>> :}
|
||||
--
|
||||
-- >>> apiTextLink without
|
||||
-- "bye"
|
||||
--
|
||||
-- Attempting to construct a link to an endpoint that does not exist in api
|
||||
-- will result in a type error like this:
|
||||
--
|
||||
-- >>> let bad_link = Proxy :: Proxy ("hello" :> Delete '[JSON] NoContent)
|
||||
-- >>> safeLink api bad_link
|
||||
-- ...
|
||||
-- ...Could not deduce...
|
||||
-- ...
|
||||
--
|
||||
-- This error is essentially saying that the type family couldn't find
|
||||
-- bad_link under api after trying the open (but empty) type family
|
||||
-- `IsElem'` as a last resort.
|
||||
module Servant.Utils.Links (
|
||||
module Servant.API.TypeLevel,
|
||||
|
||||
-- * Building and using safe links
|
||||
--
|
||||
-- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package.
|
||||
safeLink
|
||||
, safeLink'
|
||||
, allLinks
|
||||
, allLinks'
|
||||
, URI(..)
|
||||
-- * Adding custom types
|
||||
, HasLink(..)
|
||||
, Link
|
||||
, linkURI
|
||||
, linkURI'
|
||||
, LinkArrayElementStyle (..)
|
||||
-- ** Link accessors
|
||||
, Param (..)
|
||||
, linkSegments
|
||||
, linkQueryParams
|
||||
) where
|
||||
|
||||
import Data.List
|
||||
import Data.Proxy
|
||||
(Proxy (..))
|
||||
import Data.Semigroup
|
||||
((<>))
|
||||
import Data.Singletons.Bool
|
||||
(SBool (..), SBoolI (..))
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import Data.Type.Bool
|
||||
(If)
|
||||
import GHC.TypeLits
|
||||
(KnownSymbol, symbolVal)
|
||||
import Network.URI
|
||||
(URI (..), escapeURIString, isUnreserved)
|
||||
import Prelude ()
|
||||
import Prelude.Compat
|
||||
|
||||
import Servant.API.Alternative
|
||||
((:<|>) ((:<|>)))
|
||||
import Servant.API.BasicAuth
|
||||
(BasicAuth)
|
||||
import Servant.API.Capture
|
||||
(Capture', CaptureAll)
|
||||
import Servant.API.Description
|
||||
(Description, Summary)
|
||||
import Servant.API.Empty
|
||||
(EmptyAPI (..))
|
||||
import Servant.API.Experimental.Auth
|
||||
(AuthProtect)
|
||||
import Servant.API.Header
|
||||
(Header')
|
||||
import Servant.API.HttpVersion
|
||||
(HttpVersion)
|
||||
import Servant.API.IsSecure
|
||||
(IsSecure)
|
||||
import Servant.API.Modifiers
|
||||
(FoldRequired)
|
||||
import Servant.API.QueryParam
|
||||
(QueryFlag, QueryParam', QueryParams)
|
||||
import Servant.API.Raw
|
||||
(Raw)
|
||||
import Servant.API.RemoteHost
|
||||
(RemoteHost)
|
||||
import Servant.API.ReqBody
|
||||
(ReqBody')
|
||||
import Servant.API.Stream
|
||||
(Stream)
|
||||
import Servant.API.Sub
|
||||
(type (:>))
|
||||
import Servant.API.TypeLevel
|
||||
import Servant.API.Vault
|
||||
(Vault)
|
||||
import Servant.API.Verbs
|
||||
(Verb)
|
||||
import Servant.API.WithNamedContext
|
||||
(WithNamedContext)
|
||||
import Web.HttpApiData
|
||||
|
||||
-- | A safe link datatype.
|
||||
-- The only way of constructing a 'Link' is using 'safeLink', which means any
|
||||
-- 'Link' is guaranteed to be part of the mentioned API.
|
||||
data Link = Link
|
||||
{ _segments :: [Escaped]
|
||||
, _queryParams :: [Param]
|
||||
} deriving Show
|
||||
|
||||
newtype Escaped = Escaped String
|
||||
|
||||
escaped :: String -> Escaped
|
||||
escaped = Escaped . escapeURIString isUnreserved
|
||||
|
||||
getEscaped :: Escaped -> String
|
||||
getEscaped (Escaped s) = s
|
||||
|
||||
instance Show Escaped where
|
||||
showsPrec d (Escaped s) = showsPrec d s
|
||||
show (Escaped s) = show s
|
||||
|
||||
linkSegments :: Link -> [String]
|
||||
linkSegments = map getEscaped . _segments
|
||||
|
||||
linkQueryParams :: Link -> [Param]
|
||||
linkQueryParams = _queryParams
|
||||
|
||||
instance ToHttpApiData Link where
|
||||
toHeader = TE.encodeUtf8 . toUrlPiece
|
||||
toUrlPiece l =
|
||||
let uri = linkURI l
|
||||
in Text.pack $ uriPath uri ++ uriQuery uri
|
||||
|
||||
-- | Query parameter.
|
||||
data Param
|
||||
= SingleParam String Text.Text
|
||||
| ArrayElemParam String Text.Text
|
||||
| FlagParam String
|
||||
deriving Show
|
||||
|
||||
addSegment :: Escaped -> Link -> Link
|
||||
addSegment seg l = l { _segments = _segments l <> [seg] }
|
||||
|
||||
addQueryParam :: Param -> Link -> Link
|
||||
addQueryParam qp l =
|
||||
l { _queryParams = _queryParams l <> [qp] }
|
||||
|
||||
-- | Transform 'Link' into 'URI'.
|
||||
--
|
||||
-- >>> type API = "something" :> Get '[JSON] Int
|
||||
-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)
|
||||
-- something
|
||||
--
|
||||
-- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int
|
||||
-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
|
||||
-- sum?x[]=1&x[]=2&x[]=3
|
||||
--
|
||||
-- >>> type API = "foo/bar" :> Get '[JSON] Int
|
||||
-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)
|
||||
-- foo%2Fbar
|
||||
--
|
||||
-- >>> type SomeRoute = "abc" :> Capture "email" String :> Put '[JSON] ()
|
||||
-- >>> let someRoute = Proxy :: Proxy SomeRoute
|
||||
-- >>> safeLink someRoute someRoute "test@example.com"
|
||||
-- Link {_segments = ["abc","test%40example.com"], _queryParams = []}
|
||||
--
|
||||
-- >>> linkURI $ safeLink someRoute someRoute "test@example.com"
|
||||
-- abc/test%40example.com
|
||||
--
|
||||
linkURI :: Link -> URI
|
||||
linkURI = linkURI' LinkArrayElementBracket
|
||||
|
||||
-- | How to encode array query elements.
|
||||
data LinkArrayElementStyle
|
||||
= LinkArrayElementBracket -- ^ @foo[]=1&foo[]=2@
|
||||
| LinkArrayElementPlain -- ^ @foo=1&foo=2@
|
||||
deriving (Eq, Ord, Show, Enum, Bounded)
|
||||
|
||||
-- | Configurable 'linkURI'.
|
||||
--
|
||||
-- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int
|
||||
-- >>> linkURI' LinkArrayElementBracket $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
|
||||
-- sum?x[]=1&x[]=2&x[]=3
|
||||
--
|
||||
-- >>> linkURI' LinkArrayElementPlain $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]
|
||||
-- sum?x=1&x=2&x=3
|
||||
--
|
||||
linkURI' :: LinkArrayElementStyle -> Link -> URI
|
||||
linkURI' addBrackets (Link segments q_params) =
|
||||
URI mempty -- No scheme (relative)
|
||||
Nothing -- Or authority (relative)
|
||||
(intercalate "/" $ map getEscaped segments)
|
||||
(makeQueries q_params) mempty
|
||||
module Servant.Utils.Links
|
||||
{-# DEPRECATED "Use Servant.Links." #-}
|
||||
( module Servant.Links )
|
||||
where
|
||||
makeQueries :: [Param] -> String
|
||||
makeQueries [] = ""
|
||||
makeQueries xs =
|
||||
"?" <> intercalate "&" (fmap makeQuery xs)
|
||||
|
||||
makeQuery :: Param -> String
|
||||
makeQuery (ArrayElemParam k v) = escape k <> style <> escape (Text.unpack v)
|
||||
makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v)
|
||||
makeQuery (FlagParam k) = escape k
|
||||
|
||||
style = case addBrackets of
|
||||
LinkArrayElementBracket -> "[]="
|
||||
LinkArrayElementPlain -> "="
|
||||
|
||||
escape :: String -> String
|
||||
escape = escapeURIString isUnreserved
|
||||
|
||||
-- | Create a valid (by construction) relative URI with query params.
|
||||
--
|
||||
-- This function will only typecheck if `endpoint` is part of the API `api`
|
||||
safeLink
|
||||
:: forall endpoint api. (IsElem endpoint api, HasLink endpoint)
|
||||
=> Proxy api -- ^ The whole API that this endpoint is a part of
|
||||
-> Proxy endpoint -- ^ The API endpoint you would like to point to
|
||||
-> MkLink endpoint Link
|
||||
safeLink = safeLink' id
|
||||
|
||||
-- | More general 'safeLink'.
|
||||
--
|
||||
safeLink'
|
||||
:: forall endpoint api a. (IsElem endpoint api, HasLink endpoint)
|
||||
=> (Link -> a)
|
||||
-> Proxy api -- ^ The whole API that this endpoint is a part of
|
||||
-> Proxy endpoint -- ^ The API endpoint you would like to point to
|
||||
-> MkLink endpoint a
|
||||
safeLink' toA _ endpoint = toLink toA endpoint (Link mempty mempty)
|
||||
|
||||
-- | Create all links in an API.
|
||||
--
|
||||
-- Note that the @api@ type must be restricted to the endpoints that have
|
||||
-- valid links to them.
|
||||
--
|
||||
-- >>> type API = "foo" :> Capture "name" Text :> Get '[JSON] Text :<|> "bar" :> Capture "name" Int :> Get '[JSON] Double
|
||||
-- >>> let fooLink :<|> barLink = allLinks (Proxy :: Proxy API)
|
||||
-- >>> :t fooLink
|
||||
-- fooLink :: Text -> Link
|
||||
-- >>> :t barLink
|
||||
-- barLink :: Int -> Link
|
||||
--
|
||||
-- Note: nested APIs don't work well with this approach
|
||||
--
|
||||
-- >>> :kind! MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link
|
||||
-- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) Link :: *
|
||||
-- = Char -> (Int -> Link) :<|> (Double -> Link)
|
||||
allLinks
|
||||
:: forall api. HasLink api
|
||||
=> Proxy api
|
||||
-> MkLink api Link
|
||||
allLinks = allLinks' id
|
||||
|
||||
-- | More general 'allLinks'. See `safeLink'`.
|
||||
allLinks'
|
||||
:: forall api a. HasLink api
|
||||
=> (Link -> a)
|
||||
-> Proxy api
|
||||
-> MkLink api a
|
||||
allLinks' toA api = toLink toA api (Link mempty mempty)
|
||||
|
||||
-- | Construct a toLink for an endpoint.
|
||||
class HasLink endpoint where
|
||||
type MkLink endpoint (a :: *)
|
||||
toLink
|
||||
:: (Link -> a)
|
||||
-> Proxy endpoint -- ^ The API endpoint you would like to point to
|
||||
-> Link
|
||||
-> MkLink endpoint a
|
||||
|
||||
-- Naked symbol instance
|
||||
instance (KnownSymbol sym, HasLink sub) => HasLink (sym :> sub) where
|
||||
type MkLink (sym :> sub) a = MkLink sub a
|
||||
toLink toA _ =
|
||||
toLink toA (Proxy :: Proxy sub) . addSegment (escaped seg)
|
||||
where
|
||||
seg = symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
-- QueryParam instances
|
||||
instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mods))
|
||||
=> HasLink (QueryParam' mods sym v :> sub)
|
||||
where
|
||||
type MkLink (QueryParam' mods sym v :> sub) a = If (FoldRequired mods) v (Maybe v) -> MkLink sub a
|
||||
toLink toA _ l mv =
|
||||
toLink toA (Proxy :: Proxy sub) $
|
||||
case sbool :: SBool (FoldRequired mods) of
|
||||
STrue -> (addQueryParam . SingleParam k . toQueryParam) mv l
|
||||
SFalse -> maybe id (addQueryParam . SingleParam k . toQueryParam) mv l
|
||||
where
|
||||
k :: String
|
||||
k = symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
instance (KnownSymbol sym, ToHttpApiData v, HasLink sub)
|
||||
=> HasLink (QueryParams sym v :> sub)
|
||||
where
|
||||
type MkLink (QueryParams sym v :> sub) a = [v] -> MkLink sub a
|
||||
toLink toA _ l =
|
||||
toLink toA (Proxy :: Proxy sub) .
|
||||
foldl' (\l' v -> addQueryParam (ArrayElemParam k (toQueryParam v)) l') l
|
||||
where
|
||||
k = symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
instance (KnownSymbol sym, HasLink sub)
|
||||
=> HasLink (QueryFlag sym :> sub)
|
||||
where
|
||||
type MkLink (QueryFlag sym :> sub) a = Bool -> MkLink sub a
|
||||
toLink toA _ l False =
|
||||
toLink toA (Proxy :: Proxy sub) l
|
||||
toLink toA _ l True =
|
||||
toLink toA (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l
|
||||
where
|
||||
k = symbolVal (Proxy :: Proxy sym)
|
||||
|
||||
-- :<|> instance - Generate all links at once
|
||||
instance (HasLink a, HasLink b) => HasLink (a :<|> b) where
|
||||
type MkLink (a :<|> b) r = MkLink a r :<|> MkLink b r
|
||||
toLink toA _ l = toLink toA (Proxy :: Proxy a) l :<|> toLink toA (Proxy :: Proxy b) l
|
||||
|
||||
-- Misc instances
|
||||
instance HasLink sub => HasLink (ReqBody' mods ct a :> sub) where
|
||||
type MkLink (ReqBody' mods ct a :> sub) r = MkLink sub r
|
||||
toLink toA _ = toLink toA (Proxy :: Proxy sub)
|
||||
|
||||
instance (ToHttpApiData v, HasLink sub)
|
||||
=> HasLink (Capture' mods sym v :> sub)
|
||||
where
|
||||
type MkLink (Capture' mods sym v :> sub) a = v -> MkLink sub a
|
||||
toLink toA _ l v =
|
||||
toLink toA (Proxy :: Proxy sub) $
|
||||
addSegment (escaped . Text.unpack $ toUrlPiece v) l
|
||||
|
||||
instance (ToHttpApiData v, HasLink sub)
|
||||
=> HasLink (CaptureAll sym v :> sub)
|
||||
where
|
||||
type MkLink (CaptureAll sym v :> sub) a = [v] -> MkLink sub a
|
||||
toLink toA _ l vs = toLink toA (Proxy :: Proxy sub) $
|
||||
foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs
|
||||
|
||||
instance HasLink sub => HasLink (Header' mods sym (a :: *) :> sub) where
|
||||
type MkLink (Header' mods sym a :> sub) r = MkLink sub r
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (Vault :> sub) where
|
||||
type MkLink (Vault :> sub) a = MkLink sub a
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (Description s :> sub) where
|
||||
type MkLink (Description s :> sub) a = MkLink sub a
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (Summary s :> sub) where
|
||||
type MkLink (Summary s :> sub) a = MkLink sub a
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (HttpVersion :> sub) where
|
||||
type MkLink (HttpVersion:> sub) a = MkLink sub a
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (IsSecure :> sub) where
|
||||
type MkLink (IsSecure :> sub) a = MkLink sub a
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (WithNamedContext name context sub) where
|
||||
type MkLink (WithNamedContext name context sub) a = MkLink sub a
|
||||
toLink toA _ = toLink toA (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (RemoteHost :> sub) where
|
||||
type MkLink (RemoteHost :> sub) a = MkLink sub a
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink sub => HasLink (BasicAuth realm a :> sub) where
|
||||
type MkLink (BasicAuth realm a :> sub) r = MkLink sub r
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
instance HasLink EmptyAPI where
|
||||
type MkLink EmptyAPI a = EmptyAPI
|
||||
toLink _ _ _ = EmptyAPI
|
||||
|
||||
-- Verb (terminal) instances
|
||||
instance HasLink (Verb m s ct a) where
|
||||
type MkLink (Verb m s ct a) r = r
|
||||
toLink toA _ = toA
|
||||
|
||||
instance HasLink Raw where
|
||||
type MkLink Raw a = a
|
||||
toLink toA _ = toA
|
||||
|
||||
instance HasLink (Stream m fr ct a) where
|
||||
type MkLink (Stream m fr ct a) r = r
|
||||
toLink toA _ = toA
|
||||
|
||||
-- AuthProtext instances
|
||||
instance HasLink sub => HasLink (AuthProtect tag :> sub) where
|
||||
type MkLink (AuthProtect tag :> sub) a = MkLink sub a
|
||||
toLink = simpleToLink (Proxy :: Proxy sub)
|
||||
|
||||
-- | Helper for implemneting 'toLink' for combinators not affecting link
|
||||
-- structure.
|
||||
simpleToLink
|
||||
:: forall sub a combinator.
|
||||
(HasLink sub, MkLink sub a ~ MkLink (combinator :> sub) a)
|
||||
=> Proxy sub
|
||||
-> (Link -> a)
|
||||
-> Proxy (combinator :> sub)
|
||||
-> Link
|
||||
-> MkLink (combinator :> sub) a
|
||||
simpleToLink _ toA _ = toLink toA (Proxy :: Proxy sub)
|
||||
|
||||
|
||||
-- $setup
|
||||
-- >>> import Servant.API
|
||||
-- >>> import Data.Text (Text)
|
||||
import Servant.Links
|
||||
|
|
|
|||
|
|
@ -12,25 +12,32 @@ import Prelude ()
|
|||
import Prelude.Compat
|
||||
|
||||
import Data.Aeson.Compat
|
||||
import Data.ByteString.Char8 (ByteString, append, pack)
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import qualified Data.ByteString.Lazy.Char8 as BSL8
|
||||
import Data.ByteString.Char8
|
||||
(ByteString, append, pack)
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import qualified Data.ByteString.Lazy.Char8 as BSL8
|
||||
import Data.Either
|
||||
import Data.Function (on)
|
||||
import Data.List (maximumBy)
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import Data.Maybe (fromJust, isJust, isNothing)
|
||||
import Data.Function
|
||||
(on)
|
||||
import Data.List
|
||||
(maximumBy)
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import Data.Maybe
|
||||
(fromJust, isJust, isNothing)
|
||||
import Data.Proxy
|
||||
import Data.String (IsString (..))
|
||||
import Data.String.Conversions (cs)
|
||||
import qualified Data.Text as TextS
|
||||
import qualified Data.Text.Encoding as TextSE
|
||||
import qualified Data.Text.Lazy as TextL
|
||||
import Data.String
|
||||
(IsString (..))
|
||||
import Data.String.Conversions
|
||||
(cs)
|
||||
import qualified Data.Text as TextS
|
||||
import qualified Data.Text.Encoding as TextSE
|
||||
import qualified Data.Text.Lazy as TextL
|
||||
import GHC.Generics
|
||||
import Test.Hspec
|
||||
import Test.QuickCheck
|
||||
import Text.Read (readMaybe)
|
||||
import "quickcheck-instances" Test.QuickCheck.Instances ()
|
||||
import "quickcheck-instances" Test.QuickCheck.Instances ()
|
||||
import Text.Read
|
||||
(readMaybe)
|
||||
|
||||
import Servant.API.ContentTypes
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Servant.API.ResponseHeadersSpec where
|
||||
|
||||
import Test.Hspec
|
||||
import Test.Hspec
|
||||
|
||||
import Servant.API.Header
|
||||
import Servant.API.ResponseHeaders
|
||||
import Servant.API.Header
|
||||
import Servant.API.ResponseHeaders
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "Servant.API.ResponseHeaders" $ do
|
||||
|
|
|
|||
|
|
@ -1,22 +1,25 @@
|
|||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
#if __GLASGOW_HASKELL__ < 709
|
||||
{-# OPTIONS_GHC -fcontext-stack=41 #-}
|
||||
#endif
|
||||
module Servant.Utils.LinksSpec where
|
||||
module Servant.LinksSpec where
|
||||
|
||||
import Data.Proxy (Proxy (..))
|
||||
import Test.Hspec (Expectation, Spec, describe, it,
|
||||
shouldBe)
|
||||
import Data.String (fromString)
|
||||
import Data.Proxy
|
||||
(Proxy (..))
|
||||
import Data.String
|
||||
(fromString)
|
||||
import Test.Hspec
|
||||
(Expectation, Spec, describe, it, shouldBe)
|
||||
|
||||
import Servant.API
|
||||
import Servant.Utils.Links
|
||||
import Servant.API.Internal.Test.ComprehensiveAPI (comprehensiveAPIWithoutRaw)
|
||||
import Servant.API.Internal.Test.ComprehensiveAPI
|
||||
(comprehensiveAPIWithoutRaw)
|
||||
import Servant.Links
|
||||
|
||||
type TestApi =
|
||||
-- Capture and query params
|
||||
|
|
@ -51,7 +54,7 @@ shouldBeLink link expected =
|
|||
toUrlPiece link `shouldBe` fromString expected
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "Servant.Utils.Links" $ do
|
||||
spec = describe "Servant.Links" $ do
|
||||
it "generates correct links for capture query params" $ do
|
||||
let l1 = Proxy :: Proxy ("hello" :> Capture "name" String :> Delete '[JSON] NoContent)
|
||||
apiLink l1 "hi" `shouldBeLink` "hello/hi"
|
||||
|
|
@ -1,33 +0,0 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# OPTIONS_GHC -fno-warn-deprecations #-}
|
||||
module Servant.Utils.EnterSpec where
|
||||
|
||||
import Test.Hspec (Spec)
|
||||
|
||||
import Servant.API
|
||||
import Servant.Utils.Enter
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- https://github.com/haskell-servant/servant/issues/734
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
-- This didn't fail if executed in GHCi; cannot have as a doctest.
|
||||
|
||||
data App a
|
||||
|
||||
f :: App :~> App
|
||||
f = NT id
|
||||
|
||||
server :: App Int :<|> (String -> App Bool)
|
||||
server = undefined
|
||||
|
||||
server' :: App Int :<|> (String -> App Bool)
|
||||
server' = enter f server
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Spec
|
||||
-------------------------------------------------------------------------------
|
||||
|
||||
spec :: Spec
|
||||
spec = return ()
|
||||
|
|
@ -13,9 +13,11 @@
|
|||
-----------------------------------------------------------------------------
|
||||
module Main where
|
||||
|
||||
import Build_doctests (flags, pkgs, module_sources)
|
||||
import Data.Foldable (traverse_)
|
||||
import Test.DocTest
|
||||
import Build_doctests
|
||||
(flags, module_sources, pkgs)
|
||||
import Data.Foldable
|
||||
(traverse_)
|
||||
import Test.DocTest
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
|
|
|
|||
15
stack.yaml
15
stack.yaml
|
|
@ -1,5 +1,5 @@
|
|||
# Let's try to keep resolver at the first day of the month
|
||||
resolver: nightly-2018-03-01
|
||||
resolver: nightly-2018-06-01
|
||||
packages:
|
||||
- servant-client/
|
||||
- servant-client-core/
|
||||
|
|
@ -8,18 +8,5 @@ packages:
|
|||
- servant-server/
|
||||
- servant/
|
||||
|
||||
extra-deps:
|
||||
- cabal-doctest-1.0.6
|
||||
- http-api-data-0.3.7.2
|
||||
- http-types-0.12
|
||||
- text-1.2.3.0
|
||||
- aeson-1.3.0.0
|
||||
- exceptions-0.10.0
|
||||
- aeson-compat-0.3.7.1
|
||||
- free-5.0.1
|
||||
- lens-4.16
|
||||
- random-bytestring-0.1.3
|
||||
- pcg-random-0.1.3.5
|
||||
|
||||
# allow-newer: true # ignores all bounds, that's a sledgehammer
|
||||
# - doc/tutorial/
|
||||
|
|
|
|||
Loading…
Reference in a new issue