├── .gitignore ├── test ├── Spec.hs └── Servant │ └── MockSpec.hs ├── Setup.hs ├── .ghci ├── README.md ├── include └── overlapping-compat.h ├── stack.yaml ├── stack-servant-0.8.yaml ├── stack-servant-0.8.1.yaml ├── example └── main.hs ├── CHANGELOG.md ├── LICENSE ├── servant-mock.cabal ├── .travis.yml └── src └── Servant └── Mock.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-newstyle/ 3 | .stack-work/ 4 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.ghci: -------------------------------------------------------------------------------- 1 | :set -Wall -itest -isrc -optP-include -optPdist/build/autogen/cabal_macros.h -Iinclude 2 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # servant-mock - Derive a mock server for free from your servant API types 2 | 3 | ![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png) 4 | -------------------------------------------------------------------------------- /include/overlapping-compat.h: -------------------------------------------------------------------------------- 1 | #if __GLASGOW_HASKELL__ >= 710 2 | #define OVERLAPPABLE_ {-# OVERLAPPABLE #-} 3 | #define OVERLAPPING_ {-# OVERLAPPING #-} 4 | #else 5 | {-# LANGUAGE OverlappingInstances #-} 6 | #define OVERLAPPABLE_ 7 | #define OVERLAPPING_ 8 | #endif 9 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2016-10-07 2 | packages: 3 | - '.' 4 | extra-deps: 5 | - hspec-wai-0.8.0 6 | - hspec-expectations-0.8.0 7 | - call-stack-0.1.0 8 | - hspec-2.3.1 9 | - hspec-discover-2.3.1 10 | - hspec-core-2.3.1 11 | flags: {} 12 | extra-package-dbs: [] 13 | -------------------------------------------------------------------------------- /stack-servant-0.8.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - '.' 4 | extra-deps: 5 | - aeson-0.11.2.1 6 | - servant-0.8 7 | - servant-server-0.8 8 | - hspec-wai-0.8.0 9 | - hspec-expectations-0.8.0 10 | - call-stack-0.1.0 11 | - hspec-2.3.1 12 | - hspec-discover-2.3.1 13 | - hspec-core-2.3.1 14 | resolver: nightly-2016-09-08 15 | -------------------------------------------------------------------------------- /stack-servant-0.8.1.yaml: -------------------------------------------------------------------------------- 1 | flags: {} 2 | packages: 3 | - '.' 4 | extra-deps: 5 | - aeson-1.0.0.0 6 | - servant-0.8.1 7 | - servant-server-0.8.1 8 | - hspec-wai-0.8.0 9 | - hspec-expectations-0.8.0 10 | - call-stack-0.1.0 11 | - hspec-2.3.1 12 | - hspec-discover-2.3.1 13 | - hspec-core-2.3.1 14 | resolver: nightly-2016-09-08 15 | -------------------------------------------------------------------------------- /example/main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | {-# OPTIONS_GHC -fno-warn-unused-binds #-} 7 | 8 | import Data.Aeson 9 | import GHC.Generics 10 | import Network.Wai.Handler.Warp 11 | import Servant 12 | import Servant.Mock 13 | import Test.QuickCheck.Arbitrary 14 | 15 | newtype User = User { username :: String } 16 | deriving (Eq, Show, Arbitrary, Generic) 17 | 18 | instance ToJSON User 19 | 20 | type API = "user" :> Get '[JSON] User 21 | 22 | api :: Proxy API 23 | api = Proxy 24 | 25 | main :: IO () 26 | main = run 8080 (serve api $ mock api (Proxy :: Proxy '[])) 27 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 0.8.7 2 | ----- 3 | 4 | - Support for servant-0.18 5 | - Hint for migration: if you get errors about `ambiguous type 6 | variable ‘context0’ arising from a use of ‘mock’`, try calling 7 | `mock` with explicit type information about the context: `mock 8 | api (Proxy @'[])`, not `mock api Proxy`. 9 | 10 | 0.8.6 11 | ----- 12 | 13 | - Support for servant-0.17 14 | 15 | 0.8.5 16 | ----- 17 | 18 | - Support for servant-0.15 19 | 20 | 0.8.4 21 | ----- 22 | 23 | - Support for servant-0.13 24 | 25 | 0.8.3 26 | ----- 27 | 28 | - Support for servant-0.12 29 | - Add `HasMock (Description d :> api)` and `HasMock (Summary d :> api)` 30 | instances 31 | 32 | 0.8.2 33 | ----- 34 | 35 | - Support for servant-0.11 36 | - Add `HasMock EmptyAPI` instance 37 | 38 | 0.8.1.2 39 | ------- 40 | 41 | - Support for servant-0.10 42 | - Fix test with hspec-wai-0.8 43 | 44 | 0.8.1.1 45 | ------- 46 | 47 | - Fix tests compiling with servant-0.9 48 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015-2016, Servant Contributors 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Alp Mestanogullari nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /servant-mock.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: servant-mock 3 | version: 0.8.7 4 | 5 | synopsis: Derive a mock server for free from your servant API types 6 | category: Servant, Web, Testing 7 | description: 8 | Derive a mock server for free from your servant API types 9 | . 10 | See the @Servant.Mock@ module for the documentation and an example. 11 | 12 | homepage: http://haskell-servant.readthedocs.org/ 13 | bug-reports: http://github.com/haskell-servant/servant-mock/issues 14 | license: BSD3 15 | license-file: LICENSE 16 | author: Servant Contributors 17 | maintainer: haskell-servant-maintainers@googlegroups.com 18 | copyright: 2015-2018 Servant Contributors 19 | build-type: Simple 20 | tested-with: 21 | GHC ==8.0.2 22 | || ==8.2.2 23 | || ==8.4.4 24 | || ==8.6.5 25 | || ==8.8.1 26 | 27 | extra-source-files: README.md CHANGELOG.md include/*.h 28 | 29 | source-repository head 30 | type: git 31 | location: http://github.com/haskell-servant/servant-mock.git 32 | 33 | flag example 34 | description: Build the example too 35 | default: True 36 | manual: True 37 | 38 | library 39 | exposed-modules: 40 | Servant.Mock 41 | build-depends: 42 | base >=4.9 && <4.14, 43 | base-compat >=0.10.5 && <0.12, 44 | bytestring >=0.10.8.1 && <0.11, 45 | http-types >=0.12.2 && <0.13, 46 | servant >=0.17 && <0.19, 47 | servant-server >=0.17 && <0.19, 48 | transformers >=0.5.2.0 && <0.6, 49 | QuickCheck >=2.12.6.1 && <2.14, 50 | wai >=3.2.1.2 && <3.3 51 | hs-source-dirs: src 52 | default-language: Haskell2010 53 | include-dirs: include 54 | ghc-options: -Wall 55 | 56 | executable mock-app 57 | main-is: main.hs 58 | hs-source-dirs: example 59 | default-language: Haskell2010 60 | build-depends: 61 | aeson, 62 | base, 63 | servant-mock, 64 | servant-server >= 0.10, 65 | QuickCheck, 66 | warp 67 | if flag(example) 68 | buildable: True 69 | else 70 | buildable: False 71 | ghc-options: -Wall 72 | 73 | test-suite spec 74 | type: exitcode-stdio-1.0 75 | ghc-options: -Wall 76 | default-language: Haskell2010 77 | hs-source-dirs: test 78 | main-is: Spec.hs 79 | other-modules: 80 | Servant.MockSpec 81 | build-tool-depends: 82 | hspec-discover:hspec-discover 83 | build-depends: 84 | bytestring-conversion, 85 | base, 86 | hspec, 87 | hspec-wai >=0.9.0 && <0.11, 88 | QuickCheck, 89 | servant, 90 | servant-server, 91 | servant-mock, 92 | aeson, 93 | wai 94 | -------------------------------------------------------------------------------- /test/Servant/MockSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ConstraintKinds #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | 9 | module Servant.MockSpec where 10 | 11 | import Data.Aeson as Aeson 12 | import Data.Proxy 13 | import GHC.Generics 14 | import Network.Wai 15 | import Servant.API 16 | import Test.Hspec hiding (pending) 17 | import Test.Hspec.Wai hiding (Body) 18 | import Test.QuickCheck 19 | 20 | import Servant 21 | import Servant.Test.ComprehensiveAPI 22 | import Servant.Mock 23 | 24 | import Data.ByteString.Conversion.To 25 | import Data.String 26 | 27 | -- This declaration simply checks that all instances are in place. 28 | _ = mock comprehensiveAPI (Proxy :: Proxy '[NamedContext "foo" '[]]) 29 | 30 | data Body 31 | = Body 32 | | ArbitraryBody 33 | deriving (Generic) 34 | 35 | instance ToJSON Body 36 | 37 | instance Arbitrary Body where 38 | arbitrary = return ArbitraryBody 39 | 40 | data TestHeader 41 | = TestHeader 42 | | ArbitraryHeader 43 | deriving (Show) 44 | 45 | -- Needed for servant-0.8.1 46 | instance ToByteString TestHeader where 47 | builder = fromString . show 48 | 49 | instance ToHttpApiData TestHeader where 50 | toHeader = toHeader . show 51 | toUrlPiece = toUrlPiece . show 52 | toQueryParam = toQueryParam . show 53 | 54 | 55 | instance Arbitrary TestHeader where 56 | arbitrary = return ArbitraryHeader 57 | 58 | spec :: Spec 59 | spec = do 60 | describe "mock" $ do 61 | context "Get" $ do 62 | let api :: Proxy (Get '[JSON] Body) 63 | api = Proxy 64 | app = serve api (mock api (Proxy :: Proxy '[])) 65 | with (return app) $ do 66 | it "serves arbitrary response bodies" $ do 67 | get "/" `shouldRespondWith` 200{ 68 | matchBody = MatchBody $ \ _ b -> 69 | if b == Aeson.encode ArbitraryBody 70 | then Nothing 71 | else Just ("body not correct\n") 72 | } 73 | 74 | context "response headers" $ do 75 | let withHeader :: Proxy (Get '[JSON] (Headers '[Header "foo" TestHeader] Body)) 76 | withHeader = Proxy 77 | withoutHeader :: Proxy (Get '[JSON] (Headers '[] Body)) 78 | withoutHeader = Proxy 79 | toApp :: (HasMock api '[]) => Proxy api -> IO Application 80 | toApp api = return $ serve api (mock api (Proxy :: Proxy '[])) 81 | with (toApp withHeader) $ do 82 | it "serves arbitrary response bodies" $ do 83 | get "/" `shouldRespondWith` 200{ 84 | matchHeaders = return $ MatchHeader $ \ h _ -> 85 | if h == [("Content-Type", "application/json;charset=utf-8"), ("foo", "ArbitraryHeader")] 86 | then Nothing 87 | else Just ("headers not correct\n") 88 | } 89 | 90 | with (toApp withoutHeader) $ do 91 | it "works for no additional headers" $ do 92 | get "/" `shouldRespondWith` 200{ 93 | matchHeaders = return $ MatchHeader $ \ h _ -> 94 | if h == [("Content-Type", "application/json;charset=utf-8")] 95 | then Nothing 96 | else Just ("headers not correct\n") 97 | } 98 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # haskell-ci '--branches' 'master' '-o' '.travis.yml' 'servant-mock.cabal' 4 | # 5 | # For more information, see https://github.com/haskell-CI/haskell-ci 6 | # 7 | # version: 0.9.20200121 8 | # 9 | version: ~> 1.0 10 | language: c 11 | os: linux 12 | dist: xenial 13 | git: 14 | # whether to recursively clone submodules 15 | submodules: false 16 | branches: 17 | only: 18 | - master 19 | cache: 20 | directories: 21 | - $HOME/.cabal/packages 22 | - $HOME/.cabal/store 23 | - $HOME/.hlint 24 | before_cache: 25 | - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log 26 | # remove files that are regenerated by 'cabal update' 27 | - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* 28 | - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json 29 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache 30 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar 31 | - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx 32 | - rm -rfv $CABALHOME/packages/head.hackage 33 | jobs: 34 | include: 35 | - compiler: ghc-8.8.1 36 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.1","cabal-install-3.0"]}} 37 | os: linux 38 | - compiler: ghc-8.6.5 39 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.0"]}} 40 | os: linux 41 | - compiler: ghc-8.4.4 42 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.0"]}} 43 | os: linux 44 | - compiler: ghc-8.2.2 45 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.0"]}} 46 | os: linux 47 | - compiler: ghc-8.0.2 48 | addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.0"]}} 49 | os: linux 50 | before_install: 51 | - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') 52 | - WITHCOMPILER="-w $HC" 53 | - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//') 54 | - HCPKG="$HC-pkg" 55 | - unset CC 56 | - CABAL=/opt/ghc/bin/cabal 57 | - CABALHOME=$HOME/.cabal 58 | - export PATH="$CABALHOME/bin:$PATH" 59 | - TOP=$(pwd) 60 | - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" 61 | - echo $HCNUMVER 62 | - CABAL="$CABAL -vnormal+nowrap" 63 | - set -o pipefail 64 | - TEST=--enable-tests 65 | - BENCH=--enable-benchmarks 66 | - HEADHACKAGE=false 67 | - rm -f $CABALHOME/config 68 | - | 69 | echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config 70 | echo "remote-build-reporting: anonymous" >> $CABALHOME/config 71 | echo "write-ghc-environment-files: always" >> $CABALHOME/config 72 | echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config 73 | echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config 74 | echo "world-file: $CABALHOME/world" >> $CABALHOME/config 75 | echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config 76 | echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config 77 | echo "installdir: $CABALHOME/bin" >> $CABALHOME/config 78 | echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config 79 | echo "store-dir: $CABALHOME/store" >> $CABALHOME/config 80 | echo "install-dirs user" >> $CABALHOME/config 81 | echo " prefix: $CABALHOME" >> $CABALHOME/config 82 | echo "repository hackage.haskell.org" >> $CABALHOME/config 83 | echo " url: http://hackage.haskell.org/" >> $CABALHOME/config 84 | install: 85 | - ${CABAL} --version 86 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 87 | - | 88 | echo "program-default-options" >> $CABALHOME/config 89 | echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config 90 | - cat $CABALHOME/config 91 | - rm -fv cabal.project cabal.project.local cabal.project.freeze 92 | - travis_retry ${CABAL} v2-update -v 93 | # Generate cabal.project 94 | - rm -rf cabal.project cabal.project.local cabal.project.freeze 95 | - touch cabal.project 96 | - | 97 | echo "packages: ." >> cabal.project 98 | - | 99 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(servant-mock)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 100 | - cat cabal.project || true 101 | - cat cabal.project.local || true 102 | - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi 103 | - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} 104 | - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" 105 | - rm cabal.project.freeze 106 | - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all 107 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all 108 | script: 109 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 110 | # Packaging... 111 | - ${CABAL} v2-sdist all 112 | # Unpacking... 113 | - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ 114 | - cd ${DISTDIR} || false 115 | - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; 116 | - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; 117 | - PKGDIR_servant_mock="$(find . -maxdepth 1 -type d -regex '.*/servant-mock-[0-9.]*')" 118 | # Generate cabal.project 119 | - rm -rf cabal.project cabal.project.local cabal.project.freeze 120 | - touch cabal.project 121 | - | 122 | echo "packages: ${PKGDIR_servant_mock}" >> cabal.project 123 | - | 124 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(servant-mock)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 125 | - cat cabal.project || true 126 | - cat cabal.project.local || true 127 | # Building... 128 | # this builds all libraries and executables (without tests/benchmarks) 129 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all 130 | # Building with tests and benchmarks... 131 | # build & run tests, build benchmarks 132 | - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all 133 | # Testing... 134 | - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all 135 | # cabal check... 136 | - (cd ${PKGDIR_servant_mock} && ${CABAL} -vnormal check) 137 | # haddock... 138 | - ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all 139 | # Building without installed constraints for packages in global-db... 140 | - rm -f cabal.project.local 141 | - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all 142 | 143 | # REGENDATA ("0.9.20200121",["--branches","master","-o",".travis.yml","servant-mock.cabal"]) 144 | # EOF 145 | -------------------------------------------------------------------------------- /src/Servant/Mock.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE PolyKinds #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | {-# OPTIONS_GHC -fno-warn-orphans #-} 12 | 13 | #include "overlapping-compat.h" 14 | 15 | -- | 16 | -- Module : Servant.Mock 17 | -- Copyright : 2015 Alp Mestanogullari 18 | -- License : BSD3 19 | -- 20 | -- Maintainer : Alp Mestanogullari 21 | -- Stability : experimental 22 | -- Portability : portable 23 | -- 24 | -- Automatically derive a mock webserver that implements some API type, 25 | -- just from the said API type's definition. 26 | -- 27 | -- Using this module couldn't be simpler. Given some API type, like: 28 | -- 29 | -- > type API = "user" :> Get '[JSON] User 30 | -- 31 | -- that describes your web application, all you have to do is define 32 | -- a 'Proxy' to it: 33 | -- 34 | -- > myAPI :: Proxy API 35 | -- > myAPI = Proxy 36 | -- 37 | -- and call 'mock', which has the following type: 38 | -- 39 | -- @ 40 | -- 'mock' :: 'HasMock' api context => 'Proxy' api -> 'Proxy' context -> 'Server' api 41 | -- @ 42 | -- 43 | -- What this says is, given some API type @api@ that it knows it can 44 | -- "mock", 'mock' hands you an implementation of the API type. It does so 45 | -- by having each request handler generate a random value of the 46 | -- appropriate type (@User@ in our case). All you need for this to work is 47 | -- to provide 'Arbitrary' instances for the data types returned as response 48 | -- bodies, hence appearing next to 'Delete', 'Get', 'Patch', 'Post' and 'Put'. 49 | -- 50 | -- To put this all to work and run the mock server, just call 'serve' on the 51 | -- result of 'mock' to get an 'Application' that you can then run with warp. 52 | -- 53 | -- @ 54 | -- main :: IO () 55 | -- main = Network.Wai.Handler.Warp.run 8080 $ 56 | -- 'serve' myAPI ('mock' myAPI Proxy) 57 | -- @ 58 | module Servant.Mock ( HasMock(..) ) where 59 | 60 | import Prelude () 61 | import Prelude.Compat 62 | 63 | import Control.Monad.IO.Class 64 | import Data.ByteString.Lazy.Char8 (pack) 65 | import Data.Proxy 66 | import GHC.TypeLits 67 | import Network.HTTP.Types.Status 68 | import Network.Wai 69 | import Servant 70 | import Servant.API.ContentTypes 71 | import Servant.API.Modifiers 72 | import Test.QuickCheck.Arbitrary (Arbitrary (..), vector) 73 | import Test.QuickCheck.Gen (Gen, generate) 74 | 75 | -- | 'HasMock' defines an interpretation of API types 76 | -- than turns them into random-response-generating 77 | -- request handlers, hence providing an instance for 78 | -- all the combinators of the core /servant/ library. 79 | class (HasServer api context 80 | #if MIN_VERSION_servant_server(0,18,0) 81 | , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters 82 | #endif 83 | ) => HasMock api context where 84 | -- | Calling this method creates request handlers of 85 | -- the right type to implement the API described by 86 | -- @api@ that just generate random response values of 87 | -- the right type. E.g: 88 | -- 89 | -- @ 90 | -- type API = "user" :> Get '[JSON] User 91 | -- :<|> "book" :> Get '[JSON] Book 92 | -- 93 | -- api :: Proxy API 94 | -- api = Proxy 95 | -- 96 | -- -- let's say we will start with the frontend, 97 | -- -- and hence need a placeholder server 98 | -- server :: Server API 99 | -- server = mock api Proxy 100 | -- @ 101 | -- 102 | -- What happens here is that @'Server' API@ 103 | -- actually "means" 2 request handlers, of the following types: 104 | -- 105 | -- @ 106 | -- getUser :: Handler User 107 | -- getBook :: Handler Book 108 | -- @ 109 | -- 110 | -- So under the hood, 'mock' uses the 'IO' bit to generate 111 | -- random values of type 'User' and 'Book' every time these 112 | -- endpoints are requested. 113 | mock :: Proxy api -> Proxy context -> Server api 114 | 115 | instance (HasMock a context, HasMock b context) => HasMock (a :<|> b) context where 116 | mock _ context = mock (Proxy :: Proxy a) context :<|> mock (Proxy :: Proxy b) context 117 | 118 | instance (KnownSymbol path, HasMock rest context) => HasMock (path :> rest) context where 119 | mock _ = mock (Proxy :: Proxy rest) 120 | 121 | instance (KnownSymbol s, FromHttpApiData a, HasMock rest context, SBoolI (FoldLenient mods)) => HasMock (Capture' mods s a :> rest) context where 122 | mock _ context = \_ -> mock (Proxy :: Proxy rest) context 123 | 124 | instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) => HasMock (CaptureAll s a :> rest) context where 125 | mock _ context = \_ -> mock (Proxy :: Proxy rest) context 126 | 127 | instance (AllCTUnrender ctypes a, HasMock rest context, SBoolI (FoldLenient mods)) 128 | => HasMock (ReqBody' mods ctypes a :> rest) context where 129 | mock _ context = \_ -> mock (Proxy :: Proxy rest) context 130 | 131 | -- | @since 0.8.5 132 | instance (MimeUnrender ctype chunk, FramingUnrender fr, FromSourceIO chunk a, HasMock rest context) 133 | => HasMock (StreamBody' mods fr ctype a :> rest) context where 134 | mock _ context = \_ -> mock (Proxy :: Proxy rest) context 135 | 136 | instance HasMock rest context => HasMock (RemoteHost :> rest) context where 137 | mock _ context = \_ -> mock (Proxy :: Proxy rest) context 138 | 139 | instance HasMock rest context => HasMock (IsSecure :> rest) context where 140 | mock _ context = \_ -> mock (Proxy :: Proxy rest) context 141 | 142 | instance HasMock rest context => HasMock (Vault :> rest) context where 143 | mock _ context = \_ -> mock (Proxy :: Proxy rest) context 144 | 145 | instance HasMock rest context => HasMock (HttpVersion :> rest) context where 146 | mock _ context = \_ -> mock (Proxy :: Proxy rest) context 147 | 148 | instance (KnownSymbol s, FromHttpApiData a, HasMock rest context, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)) 149 | => HasMock (QueryParam' mods s a :> rest) context where 150 | mock _ context = \_ -> mock (Proxy :: Proxy rest) context 151 | 152 | instance (KnownSymbol s, FromHttpApiData a, HasMock rest context) 153 | => HasMock (QueryParams s a :> rest) context where 154 | mock _ context = \_ -> mock (Proxy :: Proxy rest) context 155 | 156 | instance (KnownSymbol s, HasMock rest context) => HasMock (QueryFlag s :> rest) context where 157 | mock _ context = \_ -> mock (Proxy :: Proxy rest) context 158 | 159 | instance (KnownSymbol h, FromHttpApiData a, HasMock rest context, SBoolI (FoldRequired mods), SBoolI (FoldLenient mods)) 160 | => HasMock (Header' mods h a :> rest) context where 161 | mock _ context = \_ -> mock (Proxy :: Proxy rest) context 162 | 163 | instance (Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a 164 | #if MIN_VERSION_servant_server(0,18,0) 165 | , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters 166 | #endif 167 | ) 168 | => HasMock (Verb method status ctypes a) context where 169 | mock _ _ = mockArbitrary 170 | 171 | instance (ReflectMethod method 172 | #if MIN_VERSION_servant_server(0,18,0) 173 | , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters 174 | #endif 175 | ) => HasMock (NoContentVerb method) context where 176 | mock _ _ = mockArbitrary 177 | 178 | instance (Arbitrary a, KnownNat status, ReflectMethod method, MimeRender ctype chunk, FramingRender fr, ToSourceIO chunk a 179 | #if MIN_VERSION_servant_server(0,18,0) 180 | , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters 181 | #endif 182 | ) 183 | => HasMock (Stream method status fr ctype a) context where 184 | mock _ _ = mockArbitrary 185 | 186 | instance OVERLAPPING_ 187 | (GetHeaders (Headers headerTypes a), Arbitrary (HList headerTypes), 188 | Arbitrary a, KnownNat status, ReflectMethod method, AllCTRender ctypes a 189 | #if MIN_VERSION_servant_server(0,18,0) 190 | , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters 191 | #endif 192 | ) 193 | => HasMock (Verb method status ctypes (Headers headerTypes a)) context where 194 | mock _ _ = mockArbitrary 195 | 196 | instance 197 | #if MIN_VERSION_servant_server(0,18,0) 198 | HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters => 199 | #endif 200 | HasMock Raw context where 201 | mock _ _ = Tagged $ \_req respond -> do 202 | bdy <- genBody 203 | respond $ responseLBS status200 [] bdy 204 | 205 | where genBody = pack <$> generate (vector 100 :: Gen [Char]) 206 | 207 | instance 208 | #if MIN_VERSION_servant_server(0,18,0) 209 | HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters => 210 | #endif 211 | HasMock EmptyAPI context where 212 | mock _ _ = emptyServer 213 | 214 | instance HasMock api context => HasMock (Summary d :> api) context where 215 | mock _ context = mock (Proxy :: Proxy api) context 216 | 217 | instance HasMock api context => HasMock (Description d :> api) context where 218 | mock _ context = mock (Proxy :: Proxy api) context 219 | 220 | instance ( HasContextEntry context (NamedContext name subContext) 221 | #if MIN_VERSION_servant_server(0,18,0) 222 | , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters 223 | #endif 224 | , HasMock rest subContext) => 225 | HasMock (WithNamedContext name subContext rest) context where 226 | 227 | mock _ _ = mock (Proxy :: Proxy rest) (Proxy :: Proxy subContext) 228 | 229 | mockArbitrary :: (MonadIO m, Arbitrary a) => m a 230 | mockArbitrary = liftIO (generate arbitrary) 231 | 232 | -- utility instance 233 | instance (Arbitrary (HList ls), Arbitrary a) 234 | => Arbitrary (Headers ls a) where 235 | arbitrary = Headers <$> arbitrary <*> arbitrary 236 | 237 | instance Arbitrary (HList '[]) where 238 | arbitrary = pure HNil 239 | 240 | instance (Arbitrary a, Arbitrary (HList hs)) 241 | => Arbitrary (HList (Header h a ': hs)) where 242 | arbitrary = HCons <$> fmap Header arbitrary <*> arbitrary 243 | 244 | instance Arbitrary NoContent where 245 | arbitrary = pure NoContent 246 | --------------------------------------------------------------------------------