diff --git a/.travis.yml b/.travis.yml index 8d84b97a..12a23576 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,6 +1,6 @@ # This Travis job script has been generated by a script via # -# runghc make_travis_yml_2.hs '--config=cabal.make-travis-yml' '--output=.travis.yml' '--max-backjumps=10000' 'cabal.project' +# runghc make_travis_yml_2.hs '--config=cabal.make-travis-yml' '--output=.travis.yml' 'cabal.project' # # For more information, see https://github.com/hvr/multi-ghc-travis # @@ -33,18 +33,21 @@ before_cache: matrix: include: - - compiler: "ghc-7.8.4" + - compiler: "ghc-8.4.3" # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.8.4], sources: [hvr-ghc]}} - - compiler: "ghc-7.10.3" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-7.10.3], sources: [hvr-ghc]}} - - compiler: "ghc-8.0.2" - # env: TEST=--disable-tests BENCH=--disable-benchmarks - addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}} + addons: {apt: {packages: [ghc-ppa-tools,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,cabal-install-head,ghc-8.2.2], sources: [hvr-ghc]}} + addons: {apt: {packages: [ghc-ppa-tools,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]}} + - 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]}} + - 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]}} before_install: - HC=${CC} @@ -56,6 +59,17 @@ 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 '?')]" @@ -64,15 +78,14 @@ install: - HADDOCK=${HADDOCK-true} - INSTALLED=${INSTALLED-true} - GHCHEAD=${GHCHEAD-false} - - CABALNEWBUILDOPTS=--max-backjumps=10000 - 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/db-postgres-pool\" \"doc/cookbook/jwt-and-basic-auth\" \"doc/cookbook/db-sqlite-simple\" \"doc/cookbook/basic-auth\" \"doc/cookbook/https\" \"doc/cookbook/structuring-apis\" \"doc/cookbook/using-custom-monad\" \"doc/cookbook/file-upload\"\\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/https\" \"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-js:servant,servant-js:servant-foreign,servant-auth-server:http-types,servant-multipart:lens,servant-multipart:resourcet,servant-multipart:servant,servant-multipart:servant-server,servant-auth-server:servant-server' >> cabal.project" + - "echo 'allow-newer: servant-auth-server:http-types,servant-auth-server:servant-server, http-media:base' >> cabal.project" - cat cabal.project - if [ -f "servant/configure.ac" ]; then (cd "servant" && autoreconf -i); @@ -95,32 +108,29 @@ install: - if [ -f "doc/tutorial/configure.ac" ]; then (cd "doc/tutorial" && autoreconf -i); fi + - if [ -f "doc/cookbook/basic-auth/configure.ac" ]; then + (cd "doc/cookbook/basic-auth" && autoreconf -i); + fi - if [ -f "doc/cookbook/db-postgres-pool/configure.ac" ]; then (cd "doc/cookbook/db-postgres-pool" && 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/db-sqlite-simple/configure.ac" ]; then (cd "doc/cookbook/db-sqlite-simple" && autoreconf -i); fi - - if [ -f "doc/cookbook/basic-auth/configure.ac" ]; then - (cd "doc/cookbook/basic-auth" && autoreconf -i); - fi - if [ -f "doc/cookbook/https/configure.ac" ]; then (cd "doc/cookbook/https" && autoreconf -i); fi + - if [ -f "doc/cookbook/pagination/configure.ac" ]; then + (cd "doc/cookbook/pagination" && autoreconf -i); + fi - if [ -f "doc/cookbook/structuring-apis/configure.ac" ]; then (cd "doc/cookbook/structuring-apis" && autoreconf -i); fi - if [ -f "doc/cookbook/using-custom-monad/configure.ac" ]; then (cd "doc/cookbook/using-custom-monad" && autoreconf -i); fi - - if [ -f "doc/cookbook/file-upload/configure.ac" ]; then - (cd "doc/cookbook/file-upload" && 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/db-postgres-pool"/dist "doc/cookbook/jwt-and-basic-auth"/dist "doc/cookbook/db-sqlite-simple"/dist "doc/cookbook/basic-auth"/dist "doc/cookbook/https"/dist "doc/cookbook/structuring-apis"/dist "doc/cookbook/using-custom-monad"/dist "doc/cookbook/file-upload"/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/https"/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; @@ -135,37 +145,36 @@ script: - (cd "servant-foreign" && cabal sdist) - (cd "servant-server" && cabal sdist) - (cd "doc/tutorial" && cabal sdist) - - (cd "doc/cookbook/db-postgres-pool" && cabal sdist) - - (cd "doc/cookbook/jwt-and-basic-auth" && cabal sdist) - - (cd "doc/cookbook/db-sqlite-simple" && cabal sdist) - (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/https" && cabal sdist) + - (cd "doc/cookbook/pagination" && cabal sdist) - (cd "doc/cookbook/structuring-apis" && cabal sdist) - (cd "doc/cookbook/using-custom-monad" && cabal sdist) - - (cd "doc/cookbook/file-upload" && 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/db-postgres-pool"/dist/cookbook-db-postgres-pool-*.tar.gz "doc/cookbook/jwt-and-basic-auth"/dist/cookbook-jwt-and-basic-auth-*.tar.gz "doc/cookbook/db-sqlite-simple"/dist/cookbook-db-sqlite-simple-*.tar.gz "doc/cookbook/basic-auth"/dist/cookbook-basic-auth-*.tar.gz "doc/cookbook/https"/dist/cookbook-https-*.tar.gz "doc/cookbook/structuring-apis"/dist/cookbook-structuring-apis-*.tar.gz "doc/cookbook/using-custom-monad"/dist/cookbook-using-custom-monad-*.tar.gz "doc/cookbook/file-upload"/dist/cookbook-file-upload-*.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/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}/ - 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-db-postgres-pool-*/*.cabal cookbook-jwt-and-basic-auth-*/*.cabal cookbook-db-sqlite-simple-*/*.cabal cookbook-basic-auth-*/*.cabal cookbook-https-*/*.cabal cookbook-structuring-apis-*/*.cabal cookbook-using-custom-monad-*/*.cabal cookbook-file-upload-*/*.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-https-*/*.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-js:servant,servant-js:servant-foreign,servant-auth-server:http-types,servant-multipart:lens,servant-multipart:resourcet,servant-multipart:servant,servant-multipart:servant-server,servant-auth-server:servant-server' >> cabal.project" + - "echo 'allow-newer: servant-auth-server:http-types,servant-auth-server:servant-server, http-media:base' >> cabal.project" - cat cabal.project - 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} ${CABALNEWBUILDOPTS} all + - cabal new-build -w ${HC} ${TEST} ${BENCH} all - echo -en 'travis_fold:end:build-everything\\r' - - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} ${CABALNEWBUILDOPTS} all; fi + - if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi - echo Haddock... && echo -en 'travis_fold:start:haddock\\r' # haddock - rm -rf ./dist-newstyle - - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} ${CABALNEWBUILDOPTS} all; else echo "Skipping haddock generation";fi + - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi - echo -en 'travis_fold:end:haddock\\r' -# REGENDATA ["--config=cabal.make-travis-yml","--output=.travis.yml","--max-backjumps=10000","cabal.project"] +# REGENDATA ["--config=cabal.make-travis-yml","--output=.travis.yml","cabal.project"] # EOF diff --git a/cabal.project b/cabal.project index a1d01559..9a6c9e1c 100644 --- a/cabal.project +++ b/cabal.project @@ -5,19 +5,29 @@ packages: servant/ servant-foreign/ servant-server/ doc/tutorial/ - doc/cookbook/*/*.cabal + + -- doc/cookbook/*/*.cabal + + doc/cookbook/basic-auth + doc/cookbook/db-postgres-pool + doc/cookbook/db-sqlite-simple + -- MkLink changed + -- doc/cookbook/file-upload + doc/cookbook/https + -- servant-auth-* doesn't support GHC-8.4 + -- doc/cookbook/jwt-and-basic-auth + doc/cookbook/pagination + doc/cookbook/structuring-apis + doc/cookbook/using-custom-monad allow-newer: - servant-js:servant, - servant-js:servant-foreign, servant-auth-server:http-types, - servant-multipart:lens, - servant-multipart:resourcet, - servant-multipart:servant, - servant-multipart:servant-server, servant-auth-server:servant-server constraints: -- see https://github.com/haskell-infra/hackage-trustees/issues/119 foundation >=0.0.14, memory <0.14.12 || >0.14.12 + +allow-newer: + http-media:base diff --git a/doc/cookbook/basic-auth/basic-auth.cabal b/doc/cookbook/basic-auth/basic-auth.cabal index 5997b598..ea9bfb09 100644 --- a/doc/cookbook/basic-auth/basic-auth.cabal +++ b/doc/cookbook/basic-auth/basic-auth.cabal @@ -8,7 +8,7 @@ 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 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 executable cookbook-basic-auth main-is: BasicAuth.lhs diff --git a/doc/cookbook/db-postgres-pool/db-postgres-pool.cabal b/doc/cookbook/db-postgres-pool/db-postgres-pool.cabal index a2236e40..6e2da06b 100644 --- a/doc/cookbook/db-postgres-pool/db-postgres-pool.cabal +++ b/doc/cookbook/db-postgres-pool/db-postgres-pool.cabal @@ -8,7 +8,7 @@ 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 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 executable cookbook-db-postgres-pool main-is: PostgresPool.lhs diff --git a/doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal b/doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal index 6115cf2f..a6736adc 100644 --- a/doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal +++ b/doc/cookbook/db-sqlite-simple/db-sqlite-simple.cabal @@ -8,7 +8,7 @@ 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 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 executable cookbook-db-sqlite-simple main-is: DBConnection.lhs diff --git a/doc/cookbook/file-upload/file-upload.cabal b/doc/cookbook/file-upload/file-upload.cabal index 66b346a4..f422e59e 100644 --- a/doc/cookbook/file-upload/file-upload.cabal +++ b/doc/cookbook/file-upload/file-upload.cabal @@ -8,7 +8,7 @@ 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 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 executable cookbook-file-upload main-is: FileUpload.lhs diff --git a/doc/cookbook/https/https.cabal b/doc/cookbook/https/https.cabal index bec9273c..790acaef 100644 --- a/doc/cookbook/https/https.cabal +++ b/doc/cookbook/https/https.cabal @@ -8,7 +8,7 @@ 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 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 executable cookbook-https main-is: Https.lhs diff --git a/doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal b/doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal index b5f751b0..4ff5e6f1 100644 --- a/doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal +++ b/doc/cookbook/jwt-and-basic-auth/jwt-and-basic-auth.cabal @@ -11,7 +11,7 @@ maintainer: haskell-servant-maintainers@googlegroups.com category: Servant 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 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 executable cookbook-jwt-and-basic-auth if !impl(ghc >= 7.10) diff --git a/doc/cookbook/pagination/dummy/Pagination.lhs b/doc/cookbook/pagination/dummy/Pagination.lhs new file mode 100644 index 00000000..ab900f27 --- /dev/null +++ b/doc/cookbook/pagination/dummy/Pagination.lhs @@ -0,0 +1,5 @@ +```haskell +module Main (main) where +main :: IO () +main = return () +``` diff --git a/doc/cookbook/pagination/pagination.cabal b/doc/cookbook/pagination/pagination.cabal index e05d7401..91382df4 100644 --- a/doc/cookbook/pagination/pagination.cabal +++ b/doc/cookbook/pagination/pagination.cabal @@ -8,17 +8,25 @@ author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com build-type: Simple cabal-version: >=1.10 +extra-source-files: + Pagination.lhs + dummy/Pagination.lhs +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 executable cookbook-pagination - if impl(ghc < 7.10.1) - buildable: False main-is: Pagination.lhs - build-depends: base == 4.* - , aeson - , servant - , servant-server - , servant-pagination >= 2.1.0 && < 3.0.0 - , warp + build-tool-depends: markdown-unlit:markdown-unlit default-language: Haskell2010 ghc-options: -Wall -pgmL markdown-unlit - build-tool-depends: markdown-unlit:markdown-unlit + + if impl(ghc >= 8.0) + hs-source-dirs: . + build-depends: base >= 4.8 && <4.12 + , aeson + , servant + , servant-server + , servant-pagination >= 2.1.0 && < 3.0.0 + , warp + else + hs-source-dirs: dummy + build-depends: base diff --git a/doc/cookbook/structuring-apis/structuring-apis.cabal b/doc/cookbook/structuring-apis/structuring-apis.cabal index b2a9985c..de50bf43 100644 --- a/doc/cookbook/structuring-apis/structuring-apis.cabal +++ b/doc/cookbook/structuring-apis/structuring-apis.cabal @@ -8,7 +8,7 @@ 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 +tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.3 executable cookbook-structuring-apis main-is: StructuringApis.lhs diff --git a/doc/cookbook/using-custom-monad/using-custom-monad.cabal b/doc/cookbook/using-custom-monad/using-custom-monad.cabal index 216f1cf6..d5945b01 100644 --- a/doc/cookbook/using-custom-monad/using-custom-monad.cabal +++ b/doc/cookbook/using-custom-monad/using-custom-monad.cabal @@ -8,7 +8,7 @@ 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 +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: UsingCustomMonad.lhs diff --git a/doc/examples.md b/doc/examples.md index faff6993..3cba5ecf 100644 --- a/doc/examples.md +++ b/doc/examples.md @@ -6,6 +6,11 @@ including a test-suite using [**hspec**](http://hspec.github.io/) and **servant-client**. +- **[servant-examples](https://github.com/sras/servant-examples)**: + + Similar to [the cookbook](https://haskell-servant.readthedocs.io/en/latest/cookbook/index.html) but + with no explanations, for developers who just want to look at code examples to find out how to do X or Y + with servant. - **[stack-templates](https://github.com/commercialhaskell/stack-templates)** diff --git a/doc/tutorial/ApiType.lhs b/doc/tutorial/ApiType.lhs index cc85be50..71bfc0bc 100644 --- a/doc/tutorial/ApiType.lhs +++ b/doc/tutorial/ApiType.lhs @@ -137,7 +137,7 @@ type StreamGet = Stream 'GET type StreamPost = Stream 'POST ``` -These describe endpoints that return a stream of values rather than just a single value. They not only take a single content type as a parameter, but also a framing strategy -- this specifies how the individual results are delineated from one another in the stream. The two standard strategies given with Servant are `NewlineFraming` and `NetstringFraming`, but others can be written to match other protocols. +These describe endpoints that return a stream of values rather than just a single value. They not only take a single content type as a parameter, but also a framing strategy -- this specifies how the individual results are delineated from one another in the stream. The three standard strategies given with Servant are `NewlineFraming`, `NetstringFraming` and `NoFraming`, but others can be written to match other protocols. ### `Capture` diff --git a/doc/tutorial/Server.lhs b/doc/tutorial/Server.lhs index 327ab29c..39aa1b61 100644 --- a/doc/tutorial/Server.lhs +++ b/doc/tutorial/Server.lhs @@ -95,12 +95,6 @@ users1 = ] ``` -Let's also write our API type. - -``` haskell ignore -type UserAPI1 = "users" :> Get '[JSON] [User] -``` - We can now take care of writing the actual webservice that will handle requests to such an API. This one will be very simple, being reduced to just a single endpoint. The type of the web application is determined by the API type, diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index 18f86738..9c928c11 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -17,6 +17,7 @@ tested-with: GHC==7.10.3 GHC==8.0.2 GHC==8.2.2 + GHC==8.4.3 extra-source-files: static/index.html static/ui.js @@ -34,7 +35,7 @@ library -- Packages `servant` depends on. -- We don't need to specify bounds here as this package is never released. build-depends: - base >= 4.7 && <4.11 + base >= 4.7 && <4.12 , aeson , aeson-compat , attoparsec diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 56c46dff..7888f008 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -23,6 +23,7 @@ tested-with: GHC==7.10.3 GHC==8.0.2 GHC==8.2.2 + GHC==8.4.3 source-repository head type: git @@ -47,7 +48,7 @@ library -- -- note: mtl lower bound is so low because of GHC-7.8 build-depends: - base >= 4.7 && < 4.11 + base >= 4.7 && < 4.12 , bytestring >= 0.10.4.0 && < 0.11 , containers >= 0.5.5.1 && < 0.6 , mtl >= 2.1 && < 2.3 diff --git a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs index 2458ae65..59b34bfd 100644 --- a/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs +++ b/servant-client-core/src/Servant/Client/Core/Internal/HasClient.hs @@ -285,9 +285,9 @@ instance OVERLAPPING_ instance OVERLAPPABLE_ ( RunClient m, MimeUnrender ct a, ReflectMethod method, FramingUnrender framing a, BuildFromStream a (f a) - ) => HasClient m (Stream method framing ct (f a)) where + ) => HasClient m (Stream method status framing ct (f a)) where - type Client m (Stream method framing ct (f a)) = m (f a) + type Client m (Stream method status framing ct (f a)) = m (f a) clientWithRoute _pm Proxy req = do sresp <- streamingRequest req diff --git a/servant-client-ghcjs/servant-client-ghcjs.cabal b/servant-client-ghcjs/servant-client-ghcjs.cabal index f832a2ff..f65c5aff 100644 --- a/servant-client-ghcjs/servant-client-ghcjs.cabal +++ b/servant-client-ghcjs/servant-client-ghcjs.cabal @@ -31,7 +31,7 @@ library Servant.Client.Ghcjs Servant.Client.Internal.XhrClient build-depends: - base >= 4.7 && < 4.11 + base >= 4.7 && < 4.12 , bytestring >= 0.10 && < 0.11 , case-insensitive >= 1.2.0.0 && < 1.3.0.0 , containers >= 0.5 && < 0.6 diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index dbf96c28..394ba3f2 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -21,6 +21,7 @@ tested-with: GHC==7.10.3 GHC==8.0.2 GHC==8.2.2 + GHC==8.4.3 homepage: http://haskell-servant.readthedocs.org/ Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files: @@ -41,7 +42,7 @@ library -- -- note: mtl lower bound is so low because of GHC-7.8 build-depends: - base >= 4.7 && < 4.11 + base >= 4.7 && < 4.12 , bytestring >= 0.10.4.0 && < 0.11 , containers >= 0.5.5.1 && < 0.6 , mtl >= 2.1 && < 2.3 @@ -121,7 +122,7 @@ test-suite spec , hspec >= 2.4.4 && < 2.6 , HUnit >= 1.6 && < 1.7 , random-bytestring >= 0.1 && < 0.2 - , network >= 2.6.3.2 && < 2.7 + , network >= 2.6.3.2 && < 2.8 , QuickCheck >= 2.10.1 && < 2.12 , servant == 0.13.* , servant-server == 0.13.* diff --git a/servant-client/test/Servant/StreamSpec.hs b/servant-client/test/Servant/StreamSpec.hs index ad4a2664..f1abedc9 100644 --- a/servant-client/test/Servant/StreamSpec.hs +++ b/servant-client/test/Servant/StreamSpec.hs @@ -29,7 +29,6 @@ module Servant.StreamSpec (spec) where import Control.Monad (replicateM_, void) import qualified Data.ByteString as BS import Data.Proxy -import GHC.Stats (currentBytesUsed, getGCStats) import qualified Network.HTTP.Client as C import Prelude () import Prelude.Compat @@ -41,12 +40,18 @@ import Test.QuickCheck import Servant.API ((:<|>) ((:<|>)), (:>), JSON, NetstringFraming, NewlineFraming, OctetStream, ResultStream (..), - StreamGenerator (..), StreamGet) + StreamGenerator (..), StreamGet, + NoFraming) import Servant.Client 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) +#else +import GHC.Stats (currentBytesUsed, getGCStats) +#endif spec :: Spec spec = describe "Servant.Stream" $ do @@ -55,7 +60,7 @@ spec = describe "Servant.Stream" $ do type StreamApi f = "streamGetNewline" :> StreamGet NewlineFraming JSON (f Person) :<|> "streamGetNetstring" :> StreamGet NetstringFraming JSON (f Person) - :<|> "streamALot" :> StreamGet NewlineFraming OctetStream (f BS.ByteString) + :<|> "streamALot" :> StreamGet NoFraming OctetStream (f BS.ByteString) capi :: Proxy (StreamApi ResultStream) @@ -81,16 +86,16 @@ server = serve sapi :<|> return (StreamGenerator lotsGenerator) where lotsGenerator f r = do - f "" - withFile "/dev/urandom" ReadMode $ + void $ f "" + void $ withFile "/dev/urandom" ReadMode $ \handle -> streamFiveMBNTimes handle 1000 r return () streamFiveMBNTimes handle left sink - | left <= 0 = return "" + | left <= (0 :: Int) = return () | otherwise = do msg <- BS.hGet handle (megabytes 5) - sink msg + _ <- sink msg streamFiveMBNTimes handle (left - 1) sink @@ -129,8 +134,12 @@ streamSpec = beforeAll (CS.startWaiApp server) $ afterAll CS.endWaiApp $ do Right (ResultStream res) <- runClient getGetALot baseUrl let consumeNChunks n = replicateM_ n (res void) consumeNChunks 900 +#if MIN_VERSION_base(4,10,0) + memUsed <- gcdetails_mem_in_use_bytes . gc <$> getRTSStats +#else memUsed <- currentBytesUsed <$> getGCStats - memUsed `shouldSatisfy` (< (megabytes 20)) +#endif + memUsed `shouldSatisfy` (< megabytes 22) megabytes :: Num a => a -> a -megabytes n = n * (1000 ^ 2) +megabytes n = n * (1000 ^ (2 :: Int)) diff --git a/servant-docs/servant-docs.cabal b/servant-docs/servant-docs.cabal index b8f6069f..fc3624c9 100644 --- a/servant-docs/servant-docs.cabal +++ b/servant-docs/servant-docs.cabal @@ -21,6 +21,7 @@ tested-with: GHC==7.10.3 GHC==8.0.2 GHC==8.2.2 + GHC==8.4.3 homepage: http://haskell-servant.readthedocs.org/ Bug-reports: http://github.com/haskell-servant/servant/issues extra-source-files: @@ -42,7 +43,7 @@ library -- -- note: mtl lower bound is so low because of GHC-7.8 build-depends: - base >= 4.7 && < 4.11 + base >= 4.7 && < 4.12 , bytestring >= 0.10.4.0 && < 0.11 , text >= 1.2.3.0 && < 1.3 diff --git a/servant-foreign/CHANGELOG.md b/servant-foreign/CHANGELOG.md index 73846801..796f9017 100644 --- a/servant-foreign/CHANGELOG.md +++ b/servant-foreign/CHANGELOG.md @@ -1,6 +1,11 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-foreign/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.11.1 +------ + +- Add missing `Semigroup` instances + 0.11 ---- diff --git a/servant-foreign/servant-foreign.cabal b/servant-foreign/servant-foreign.cabal index 0b46e87a..a8af2ec1 100644 --- a/servant-foreign/servant-foreign.cabal +++ b/servant-foreign/servant-foreign.cabal @@ -27,6 +27,7 @@ tested-with: GHC==7.10.3 GHC==8.0.2 GHC==8.2.2 + GHC==8.4.3 source-repository head type: git @@ -42,9 +43,13 @@ library -- -- note: mtl lower bound is so low because of GHC-7.8 build-depends: - base >= 4.7 && <4.11 + base >= 4.7 && <4.12 , text >= 1.2.3.0 && < 1.3 + if !impl(ghc >= 8.0) + build-depends: + semigroups >=0.18.3 && <0.19 + -- Servant dependencies build-depends: servant == 0.13.* diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index 69a21481..b79cbf70 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -27,6 +27,7 @@ import Control.Lens (makePrisms, makeLenses, Getter, (&), (<>~), (%~), (.~)) import Data.Data (Data) import Data.Proxy +import Data.Semigroup (Semigroup) import Data.String import Data.Text import Data.Typeable (Typeable) @@ -38,12 +39,12 @@ import Servant.API.TypeLevel import Servant.API.Modifiers (RequiredArgument) newtype FunctionName = FunctionName { unFunctionName :: [Text] } - deriving (Data, Show, Eq, Monoid, Typeable) + deriving (Data, Show, Eq, Semigroup, Monoid, Typeable) makePrisms ''FunctionName newtype PathSegment = PathSegment { unPathSegment :: Text } - deriving (Data, Show, Eq, IsString, Monoid, Typeable) + deriving (Data, Show, Eq, IsString, Semigroup, Monoid, Typeable) makePrisms ''PathSegment diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index ca8d14d2..e5cbca9a 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -26,6 +26,7 @@ tested-with: GHC==7.10.3 GHC==8.0.2 GHC==8.2.2 + GHC==8.4.3 extra-source-files: include/*.h CHANGELOG.md @@ -60,7 +61,7 @@ library -- -- note: mtl lower bound is so low because of GHC-7.8 build-depends: - base >= 4.7 && < 4.11 + base >= 4.7 && < 4.12 , bytestring >= 0.10.4.0 && < 0.11 , containers >= 0.5.5.1 && < 0.6 , mtl >= 2.1 && < 2.3 @@ -90,7 +91,7 @@ library , http-types >= 0.12 && < 0.13 , network-uri >= 2.6.1.0 && < 2.7 , monad-control >= 1.0.0.4 && < 1.1 - , network >= 2.6.3.2 && < 2.7 + , network >= 2.6.3.2 && < 2.8 , safe >= 0.3.15 && < 0.4 , split >= 0.2.3.2 && < 0.3 , string-conversions >= 0.4.0.1 && < 0.5 diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 451337e1..a8058e3b 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -283,37 +283,40 @@ instance OVERLAPPING_ instance OVERLAPPABLE_ - ( MimeRender ctype a, ReflectMethod method, - FramingRender framing ctype, ToStreamGenerator f a - ) => HasServer (Stream method framing ctype (f a)) context where + ( MimeRender ctype a, ReflectMethod method, KnownNat status, + FramingRender framing ctype, ToStreamGenerator b a + ) => HasServer (Stream method status framing ctype b) context where - type ServerT (Stream method framing ctype (f a)) m = m (f a) + type ServerT (Stream method status framing ctype b) m = m b hoistServerWithContext _ _ nt s = nt s - route Proxy _ = streamRouter ([],) method (Proxy :: Proxy framing) (Proxy :: Proxy ctype) + route Proxy _ = streamRouter ([],) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) where method = reflectMethod (Proxy :: Proxy method) + status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) instance OVERLAPPING_ - ( MimeRender ctype a, ReflectMethod method, - FramingRender framing ctype, ToStreamGenerator f a, - GetHeaders (Headers h (f a)) - ) => HasServer (Stream method framing ctype (Headers h (f a))) context where + ( MimeRender ctype a, ReflectMethod method, KnownNat status, + FramingRender framing ctype, ToStreamGenerator b a, + GetHeaders (Headers h b) + ) => HasServer (Stream method status framing ctype (Headers h b)) context where - type ServerT (Stream method framing ctype (Headers h (f a))) m = m (Headers h (f a)) + type ServerT (Stream method status framing ctype (Headers h b)) m = m (Headers h b) hoistServerWithContext _ _ nt s = nt s - route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method (Proxy :: Proxy framing) (Proxy :: Proxy ctype) + route Proxy _ = streamRouter (\x -> (getHeaders x, getResponse x)) method status (Proxy :: Proxy framing) (Proxy :: Proxy ctype) where method = reflectMethod (Proxy :: Proxy method) + status = toEnum . fromInteger $ natVal (Proxy :: Proxy status) -streamRouter :: (MimeRender ctype a, FramingRender framing ctype, ToStreamGenerator f a) => - (b -> ([(HeaderName, B.ByteString)], f a)) +streamRouter :: (MimeRender ctype a, FramingRender framing ctype, ToStreamGenerator b a) => + (c -> ([(HeaderName, B.ByteString)], b)) -> Method + -> Status -> Proxy framing -> Proxy ctype - -> Delayed env (Handler b) + -> Delayed env (Handler c) -> Router env -streamRouter splitHeaders method framingproxy ctypeproxy action = leafRouter $ \env request respond -> +streamRouter splitHeaders method status framingproxy ctypeproxy action = leafRouter $ \env request respond -> let accH = fromMaybe ct_wildcard $ lookup hAccept $ requestHeaders request cmediatype = NHM.matchAccept [contentType ctypeproxy] accH accCheck = when (isNothing cmediatype) $ delayedFail err406 @@ -323,7 +326,7 @@ streamRouter splitHeaders method framingproxy ctypeproxy action = leafRouter $ \ ) env request respond $ \ output -> let (headers, fa) = splitHeaders output k = getStreamGenerator . toStreamGenerator $ fa in - Route $ responseStream status200 (contentHeader : headers) $ \write flush -> do + Route $ responseStream status (contentHeader : headers) $ \write flush -> do write . BB.lazyByteString $ header framingproxy ctypeproxy case boundary framingproxy ctypeproxy of BoundaryStrategyBracket f -> diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 8674e682..64e3590e 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -17,57 +17,62 @@ module Servant.ServerSpec where -import Control.Monad (forM_, when, unless) -import Control.Monad.Error.Class (MonadError (..)) -import Data.Aeson (FromJSON, ToJSON, decode', encode) -import qualified Data.ByteString.Base64 as Base64 -import Data.Char (toUpper) +import Control.Monad + (forM_, unless, when) +import Control.Monad.Error.Class + (MonadError (..)) +import Data.Aeson + (FromJSON, ToJSON, decode', encode) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as Base64 +import Data.Char + (toUpper) import Data.Monoid -import Data.Proxy (Proxy (Proxy)) -import Data.String (fromString) -import Data.String.Conversions (cs) -import qualified Data.Text as T -import GHC.Generics (Generic) -import Network.HTTP.Types (Status (..), hAccept, hContentType, - methodDelete, methodGet, - methodHead, methodPatch, - methodPost, methodPut, ok200, - imATeapot418, - parseQuery) -import Network.Wai (Application, Request, requestHeaders, pathInfo, - queryString, rawQueryString, - responseLBS) -import Network.Wai.Test (defaultRequest, request, - runSession, simpleBody, - simpleHeaders, simpleStatus) -import Servant.API ((:<|>) (..), (:>), AuthProtect, - BasicAuth, BasicAuthData(BasicAuthData), - Capture, CaptureAll, Delete, Get, Header, - Headers, HttpVersion, - IsSecure (..), JSON, - NoContent (..), Patch, PlainText, - Post, Put, EmptyAPI, - QueryFlag, QueryParam, QueryParams, - Raw, RemoteHost, ReqBody, - StdMethod (..), Verb, addHeader) +import Data.Proxy + (Proxy (Proxy)) +import Data.String + (fromString) +import Data.String.Conversions + (cs) +import qualified Data.Text as T +import GHC.Generics + (Generic) +import Network.HTTP.Types + (Status (..), hAccept, hContentType, imATeapot418, + methodDelete, methodGet, methodHead, methodPatch, methodPost, + methodPut, ok200, parseQuery) +import Network.Wai + (Application, Request, pathInfo, queryString, rawQueryString, + requestHeaders, responseLBS) +import Network.Wai.Test + (defaultRequest, request, runSession, simpleBody, + simpleHeaders, simpleStatus) +import Servant.API + ((:<|>) (..), (:>), AuthProtect, BasicAuth, + BasicAuthData (BasicAuthData), Capture, CaptureAll, Delete, + EmptyAPI, Get, Header, Headers, HttpVersion, IsSecure (..), + JSON, NoContent (..), NoFraming, OctetStream, Patch, + PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, + RemoteHost, ReqBody, StdMethod (..), Stream, + StreamGenerator (..), Verb, addHeader) import Servant.API.Internal.Test.ComprehensiveAPI -import Servant.Server (Server, Handler, Tagged (..), err401, err403, - err404, serve, serveWithContext, - Context((:.), EmptyContext), emptyServer) -import Test.Hspec (Spec, context, describe, it, - shouldBe, shouldContain) -import qualified Test.Hspec.Wai as THW -import Test.Hspec.Wai (get, liftIO, matchHeaders, - matchStatus, shouldRespondWith, - with, (<:>)) +import Servant.Server + (Context ((:.), EmptyContext), Handler, Server, Tagged (..), + emptyServer, err401, err403, err404, serve, serveWithContext) +import Test.Hspec + (Spec, context, describe, it, shouldBe, shouldContain) +import Test.Hspec.Wai + (get, liftIO, matchHeaders, matchStatus, shouldRespondWith, + with, (<:>)) +import qualified Test.Hspec.Wai as THW -import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck), - BasicAuthResult(Authorized,Unauthorized)) import Servant.Server.Experimental.Auth - (AuthHandler, AuthServerData, - mkAuthHandler) + (AuthHandler, AuthServerData, mkAuthHandler) +import Servant.Server.Internal.BasicAuth + (BasicAuthCheck (BasicAuthCheck), + BasicAuthResult (Authorized, Unauthorized)) import Servant.Server.Internal.Context - (NamedContext(..)) + (NamedContext (..)) -- * comprehensive api test @@ -105,6 +110,7 @@ type VerbApi method status :<|> "accept" :> ( Verb method status '[JSON] Person :<|> Verb method status '[PlainText] String ) + :<|> "stream" :> Stream method status NoFraming OctetStream (StreamGenerator BS.ByteString) verbSpec :: Spec verbSpec = describe "Servant.API.Verb" $ do @@ -114,6 +120,8 @@ verbSpec = describe "Servant.API.Verb" $ do :<|> return (addHeader 5 alice) :<|> return (addHeader 10 NoContent) :<|> (return alice :<|> return "B") + :<|> return (StreamGenerator $ \f _ -> f "bytestring") + get200 = Proxy :: Proxy (VerbApi 'GET 200) post210 = Proxy :: Proxy (VerbApi 'POST 210) put203 = Proxy :: Proxy (VerbApi 'PUT 203) @@ -179,6 +187,11 @@ verbSpec = describe "Servant.API.Verb" $ do liftIO $ simpleHeaders response `shouldContain` [("Content-Type", "application/json;charset=utf-8")] + it "works for Stream as for Result" $ do + response <- THW.request method "/stream" [] "" + liftIO $ statusCode (simpleStatus response) `shouldBe` status + liftIO $ simpleBody response `shouldBe` "bytestring" + test "GET 200" get200 methodGet 200 test "POST 210" post210 methodPost 210 test "PUT 203" put203 methodPut 203 diff --git a/servant/servant.cabal b/servant/servant.cabal index 7e8cc0da..8a9589ed 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -22,6 +22,7 @@ tested-with: GHC==7.10.3 GHC==8.0.2 GHC==8.2.2 + GHC==8.4.3 extra-source-files: include/*.h CHANGELOG.md @@ -69,7 +70,7 @@ library -- -- note: mtl lower bound is so low because of GHC-7.8 build-depends: - base >= 4.7 && < 4.11 + base >= 4.7 && < 4.12 , bytestring >= 0.10.4.0 && < 0.11 , mtl >= 2.1 && < 2.3 , text >= 1.2.3.0 && < 1.3 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index d236b0da..4ae2b8ef 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -117,8 +117,8 @@ import Servant.API.Stream (BoundaryStrategy (..), BuildFromStream (..), ByteStringParser (..), FramingRender (..), FramingUnrender (..), NetstringFraming, NewlineFraming, - ResultStream (..), Stream, StreamGenerator (..), StreamGet, - StreamPost, ToStreamGenerator (..)) + NoFraming, ResultStream (..), Stream, StreamGenerator (..), + StreamGet, StreamPost, ToStreamGenerator (..)) import Servant.API.Sub ((:>)) import Servant.API.Vault diff --git a/servant/src/Servant/API/ResponseHeaders.hs b/servant/src/Servant/API/ResponseHeaders.hs index cd6f1ad6..a0036c93 100644 --- a/servant/src/Servant/API/ResponseHeaders.hs +++ b/servant/src/Servant/API/ResponseHeaders.hs @@ -100,23 +100,41 @@ instance OVERLAPPABLE_ ( FromHttpApiData v, BuildHeadersTo xs, KnownSymbol h ) class GetHeaders ls where getHeaders :: ls -> [HTTP.Header] -instance OVERLAPPING_ GetHeaders (HList '[]) where - getHeaders _ = [] +-- | Auxiliary class for @'GetHeaders' ('HList' hs)@ instance +class GetHeadersFromHList hs where + getHeadersFromHList :: HList hs -> [HTTP.Header] -instance OVERLAPPABLE_ ( KnownSymbol h, ToHttpApiData x, GetHeaders (HList xs) ) - => GetHeaders (HList (Header h x ': xs)) where - getHeaders hdrs = case hdrs of - Header val `HCons` rest -> (headerName , toHeader val):getHeaders rest - UndecodableHeader h `HCons` rest -> (headerName, h) :getHeaders rest - MissingHeader `HCons` rest -> getHeaders rest - where headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) +instance GetHeadersFromHList hs => GetHeaders (HList hs) where + getHeaders = getHeadersFromHList -instance OVERLAPPING_ GetHeaders (Headers '[] a) where - getHeaders _ = [] +instance GetHeadersFromHList '[] where + getHeadersFromHList _ = [] -instance OVERLAPPABLE_ ( KnownSymbol h, GetHeaders (HList rest), ToHttpApiData v ) - => GetHeaders (Headers (Header h v ': rest) a) where - getHeaders hs = getHeaders $ getHeadersHList hs +instance (KnownSymbol h, ToHttpApiData x, GetHeadersFromHList xs) + => GetHeadersFromHList (Header h x ': xs) + where + getHeadersFromHList hdrs = case hdrs of + Header val `HCons` rest -> (headerName , toHeader val) : getHeadersFromHList rest + UndecodableHeader h `HCons` rest -> (headerName, h) : getHeadersFromHList rest + MissingHeader `HCons` rest -> getHeadersFromHList rest + where + headerName = CI.mk . pack $ symbolVal (Proxy :: Proxy h) + +-- | Auxiliary class for @'GetHeaders' ('Headers' hs a)@ instance +class GetHeaders' hs where + getHeaders' :: Headers hs a -> [HTTP.Header] + +instance GetHeaders' hs => GetHeaders (Headers hs a) where + getHeaders = getHeaders' + +-- | This instance is an optimisation +instance GetHeaders' '[] where + getHeaders' _ = [] + +instance (KnownSymbol h, GetHeadersFromHList rest, ToHttpApiData v) + => GetHeaders' (Header h v ': rest) + where + getHeaders' hs = getHeadersFromHList $ getHeadersHList hs -- * Adding diff --git a/servant/src/Servant/API/Stream.hs b/servant/src/Servant/API/Stream.hs index 369955b8..6a44eae9 100644 --- a/servant/src/Servant/API/Stream.hs +++ b/servant/src/Servant/API/Stream.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -25,26 +26,28 @@ import Data.Typeable (Typeable) import GHC.Generics (Generic) +import GHC.TypeLits + (Nat) import Network.HTTP.Types.Method (StdMethod (..)) 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. Steam endpoints always return response code 200 on success. Type synonyms are provided for standard methods. -data Stream (method :: k1) (framing :: *) (contentType :: *) (a :: *) +-- | 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 -type StreamPost = Stream 'POST +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 ()} +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 f a where - toStreamGenerator :: f a -> StreamGenerator a +class ToStreamGenerator a b | a -> b where + toStreamGenerator :: a -> StreamGenerator b -instance ToStreamGenerator StreamGenerator a +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. @@ -80,6 +83,18 @@ data ByteStringParser a = ByteStringParser { class FramingUnrender strategy a where unrenderFrames :: Proxy strategy -> Proxy a -> ByteStringParser (ByteStringParser (Either String ByteString)) +-- | A framing strategy that does not do any framing at all, it just passes the input data +-- This will be used most of the time with binary data, such as files +data NoFraming + +instance FramingRender NoFraming a where + header _ _ = empty + boundary _ _ = BoundaryStrategyGeneral id + trailer _ _ = empty + +instance FramingUnrender NoFraming a where + unrenderFrames _ _ = ByteStringParser (Just . (go,)) (go,) + where go = ByteStringParser (Just . (, empty) . Right) ((, empty) . Right) -- | A simple framing strategy that has no header or termination, and inserts a newline character between each frame. -- This assumes that it is used with a Content-Type that encodes without newlines (e.g. JSON). diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index a5071253..5002bcca 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -19,8 +19,6 @@ -- >>> 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 @@ -63,10 +61,24 @@ -- >>> :set -XConstraintKinds -- >>> :{ -- >>> let apiLink :: (IsElem endpoint API, HasLink endpoint) --- >>> => Proxy endpoint -> MkLink 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: -- @@ -86,7 +98,9 @@ module Servant.Utils.Links ( -- -- | Note that 'URI' is from the "Network.URI" module in the @network-uri@ package. safeLink + , safeLink' , allLinks + , allLinks' , URI(..) -- * Adding custom types , HasLink(..) @@ -276,8 +290,18 @@ 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 -safeLink _ endpoint = toLink endpoint (Link mempty mempty) + -> 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. -- @@ -293,37 +317,47 @@ safeLink _ endpoint = toLink endpoint (Link mempty mempty) -- -- 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)) --- MkLink (Capture "nest" Char :> (Capture "x" Int :> Get '[JSON] Int :<|> Capture "y" Double :> Get '[JSON] Double)) :: * +-- >>> :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 -allLinks api = toLink api (Link mempty mempty) + -> 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 - toLink :: Proxy endpoint -- ^ The API endpoint you would like to point to - -> Link - -> MkLink endpoint + 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) = MkLink sub - toLink _ = - toLink (Proxy :: Proxy sub) . addSegment (escaped seg) + 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) = If (FoldRequired mods) v (Maybe v) -> MkLink sub - toLink _ l mv = - toLink (Proxy :: Proxy sub) $ + => 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 @@ -332,105 +366,121 @@ instance (KnownSymbol sym, ToHttpApiData v, HasLink sub, SBoolI (FoldRequired mo k = symbolVal (Proxy :: Proxy sym) instance (KnownSymbol sym, ToHttpApiData v, HasLink sub) - => HasLink (QueryParams sym v :> sub) where - type MkLink (QueryParams sym v :> sub) = [v] -> MkLink sub - toLink _ l = - toLink (Proxy :: Proxy 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) = Bool -> MkLink sub - toLink _ l False = - toLink (Proxy :: Proxy sub) l - toLink _ l True = - toLink (Proxy :: Proxy sub) $ addQueryParam (FlagParam k) l + => 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) = MkLink a :<|> MkLink b - toLink _ l = toLink (Proxy :: Proxy a) l :<|> toLink (Proxy :: Proxy b) l + 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) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) + 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) = v -> MkLink sub - toLink _ l v = - toLink (Proxy :: Proxy 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) = [v] -> MkLink sub - toLink _ l vs = - toLink (Proxy :: Proxy sub) $ - foldl' (flip $ addSegment . escaped . Text.unpack . toUrlPiece) l vs + => 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) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) +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) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) + 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) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) + 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) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) + 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) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) + type MkLink (HttpVersion:> sub) a = MkLink sub a + toLink = simpleToLink (Proxy :: Proxy sub) instance HasLink sub => HasLink (IsSecure :> sub) where - type MkLink (IsSecure :> sub) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) + 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) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) + 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) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) + 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) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) + type MkLink (BasicAuth realm a :> sub) r = MkLink sub r + toLink = simpleToLink (Proxy :: Proxy sub) instance HasLink EmptyAPI where - type MkLink EmptyAPI = EmptyAPI - toLink _ _ = EmptyAPI + 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) = Link - toLink _ = id + type MkLink (Verb m s ct a) r = r + toLink toA _ = toA instance HasLink Raw where - type MkLink Raw = Link - toLink _ = id + type MkLink Raw a = a + toLink toA _ = toA instance HasLink (Stream m fr ct a) where - type MkLink (Stream m fr ct a) = Link - toLink _ = id + 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) = MkLink sub - toLink _ = toLink (Proxy :: Proxy sub) + 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 diff --git a/servant/test/Servant/Utils/LinksSpec.hs b/servant/test/Servant/Utils/LinksSpec.hs index 1d30d578..1ebb0fc6 100644 --- a/servant/test/Servant/Utils/LinksSpec.hs +++ b/servant/test/Servant/Utils/LinksSpec.hs @@ -41,7 +41,7 @@ type LinkableApi = apiLink :: (IsElem endpoint TestApi, HasLink endpoint) - => Proxy endpoint -> MkLink endpoint + => Proxy endpoint -> MkLink endpoint Link apiLink = safeLink (Proxy :: Proxy TestApi) -- | Convert a link to a URI and ensure that this maps to the given string