From fa35b5bd700ff0252b10aa84b2d649eb78bd7eb5 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sun, 29 Sep 2019 23:55:08 +0300 Subject: [PATCH 01/31] Build jsaddle with GHC-8.8 Closes https://github.com/haskell-servant/servant/issues/1227 --- .travis.yml | 22 ++++++++++++++++++++-- cabal.project | 12 ++++++++++++ servant-jsaddle/servant-jsaddle.cabal | 8 ++++---- 3 files changed, 36 insertions(+), 6 deletions(-) diff --git a/.travis.yml b/.travis.yml index 6ae8bd58..337014b9 100644 --- a/.travis.yml +++ b/.travis.yml @@ -143,7 +143,7 @@ install: if ! $GHCJS ; then echo "packages: servant-machines" >> cabal.project ; fi if ! $GHCJS ; then echo "packages: servant-conduit" >> cabal.project ; fi if ! $GHCJS ; then echo "packages: servant-pipes" >> cabal.project ; fi - if $GHCJS || ! $GHCJS && [ $HCNUMVER -lt 80800 ] ; then echo "packages: servant-jsaddle" >> cabal.project ; fi + echo "packages: servant-jsaddle" >> cabal.project if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/basic-auth" >> cabal.project ; fi if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/curl-mock" >> cabal.project ; fi if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/basic-streaming" >> cabal.project ; fi @@ -159,6 +159,7 @@ install: echo "constraints: foundation >=0.0.14" >> cabal.project echo "constraints: memory <0.14.12 || >0.14.12" >> cabal.project echo "constraints: sqlite-simple < 0" >> cabal.project + echo "constraints: base-compat ^>=0.11" >> cabal.project echo "allow-newer: aeson-pretty-0.8.7:base-compat" >> cabal.project echo "allow-newer: vault-0.3.1.2:hashable" >> cabal.project echo "allow-newer: psqueues-0.2.7.1:hashable" >> cabal.project @@ -167,6 +168,14 @@ install: echo "allow-newer: io-streams-1.5.1.0:network" >> cabal.project echo "allow-newer: io-streams-1.5.1.0:primitive" >> cabal.project echo "allow-newer: openssl-streams-1.2.2.0:network" >> cabal.project + echo "allow-newer: jsaddle-0.9.6.0:lens" >> cabal.project + echo "allow-newer: jsaddle-0.9.6.0:primitive" >> cabal.project + echo "allow-newer: jsaddle-0.9.6.0:time" >> cabal.project + echo "allow-newer: jsaddle-dom-0.9.3.2:base" >> cabal.project + echo "allow-newer: jsaddle-dom-0.9.3.2:base-compat" >> cabal.project + echo "allow-newer: jsaddle-dom-0.9.3.2:Cabal" >> cabal.project + echo "allow-newer: jsaddle-dom-0.9.3.2:lens" >> cabal.project + echo "allow-newer: jsaddle-warp-0.9.6.0:time" >> cabal.project echo "optimization: False" >> cabal.project - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-file-upload|cookbook-generic|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-jsaddle|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true @@ -247,7 +256,7 @@ script: if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_machines}" >> cabal.project ; fi if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_conduit}" >> cabal.project ; fi if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_pipes}" >> cabal.project ; fi - if $GHCJS || ! $GHCJS && [ $HCNUMVER -lt 80800 ] ; then echo "packages: ${PKGDIR_servant_jsaddle}" >> cabal.project ; fi + echo "packages: ${PKGDIR_servant_jsaddle}" >> cabal.project if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_basic_auth}" >> cabal.project ; fi if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_curl_mock}" >> cabal.project ; fi if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_basic_streaming}" >> cabal.project ; fi @@ -263,6 +272,7 @@ script: echo "constraints: foundation >=0.0.14" >> cabal.project echo "constraints: memory <0.14.12 || >0.14.12" >> cabal.project echo "constraints: sqlite-simple < 0" >> cabal.project + echo "constraints: base-compat ^>=0.11" >> cabal.project echo "allow-newer: aeson-pretty-0.8.7:base-compat" >> cabal.project echo "allow-newer: vault-0.3.1.2:hashable" >> cabal.project echo "allow-newer: psqueues-0.2.7.1:hashable" >> cabal.project @@ -271,6 +281,14 @@ script: echo "allow-newer: io-streams-1.5.1.0:network" >> cabal.project echo "allow-newer: io-streams-1.5.1.0:primitive" >> cabal.project echo "allow-newer: openssl-streams-1.2.2.0:network" >> cabal.project + echo "allow-newer: jsaddle-0.9.6.0:lens" >> cabal.project + echo "allow-newer: jsaddle-0.9.6.0:primitive" >> cabal.project + echo "allow-newer: jsaddle-0.9.6.0:time" >> cabal.project + echo "allow-newer: jsaddle-dom-0.9.3.2:base" >> cabal.project + echo "allow-newer: jsaddle-dom-0.9.3.2:base-compat" >> cabal.project + echo "allow-newer: jsaddle-dom-0.9.3.2:Cabal" >> cabal.project + echo "allow-newer: jsaddle-dom-0.9.3.2:lens" >> cabal.project + echo "allow-newer: jsaddle-warp-0.9.6.0:time" >> cabal.project echo "optimization: False" >> cabal.project - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-file-upload|cookbook-generic|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-jsaddle|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true diff --git a/cabal.project b/cabal.project index 9d6e3fdd..c4329c9d 100644 --- a/cabal.project +++ b/cabal.project @@ -62,3 +62,15 @@ allow-newer: openssl-streams-1.2.2.0:network -- MonadFail -- https://github.com/nurpax/sqlite-simple/issues/74 constraints: sqlite-simple < 0 + +-- jsaddle +allow-newer: jsaddle-0.9.6.0:lens +allow-newer: jsaddle-0.9.6.0:primitive +allow-newer: jsaddle-0.9.6.0:time +allow-newer: jsaddle-dom-0.9.3.2:base +allow-newer: jsaddle-dom-0.9.3.2:base-compat +allow-newer: jsaddle-dom-0.9.3.2:Cabal +allow-newer: jsaddle-dom-0.9.3.2:lens +allow-newer: jsaddle-warp-0.9.6.0:time + +constraints: base-compat ^>=0.11 diff --git a/servant-jsaddle/servant-jsaddle.cabal b/servant-jsaddle/servant-jsaddle.cabal index c9904056..e12cf9e5 100644 --- a/servant-jsaddle/servant-jsaddle.cabal +++ b/servant-jsaddle/servant-jsaddle.cabal @@ -22,7 +22,7 @@ category: Servant, Web build-type: Simple cabal-version: >=1.10 tested-with: - GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 + GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1 , GHCJS ==8.4 homepage: http://haskell-servant.readthedocs.org/ @@ -46,7 +46,7 @@ library -- Bundled with GHC: Lower bound to not force re-installs -- text and mtl are bundled starting with GHC-8.4 build-depends: - base >=4.9 && <4.13 + base >=4.9 && <4.14 , bytestring >=0.10.8.1 && <0.11 , containers >=0.5.7.1 && <0.7 , mtl >=2.2.2 && <2.3 @@ -60,10 +60,10 @@ library -- Strict dependency on `servant-client-core` as we re-export things. build-depends: servant-client-core >=0.16 && <0.16.1 build-depends: - base-compat >=0.10.5 && <0.11 + base-compat >=0.10.5 && <0.12 , case-insensitive >=1.2.0.0 && <1.3 , exceptions >=0.10.0 && <0.11 - , ghcjs-dom + , ghcjs-dom >=0.9.4.0 && <0.10 , http-media >=0.7.1.3 && <0.9 , http-types >=0.12.2 && <0.13 , jsaddle >=0.9.6.0 && <0.10 From 52408fea16b530d394d8b3841ab2f448170f0af5 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sun, 15 Sep 2019 14:50:55 +0300 Subject: [PATCH 02/31] Fix servant-client with base-compat-0.11 --- cabal.project | 2 -- servant-client/CHANGELOG.md | 5 +++++ servant-client/servant-client.cabal | 2 +- .../src/Servant/Client/Internal/HttpClient.hs | 10 +++++++--- servant-http-streams/CHANGELOG.md | 5 +++++ .../src/Servant/HttpStreams/Internal.hs | 8 +++++++- 6 files changed, 25 insertions(+), 7 deletions(-) diff --git a/cabal.project b/cabal.project index c4329c9d..41093bdc 100644 --- a/cabal.project +++ b/cabal.project @@ -38,8 +38,6 @@ packages: doc/cookbook/using-free-client -- doc/cookbook/open-id-connect - - tests: True optimization: False -- reorder-goals: True diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index aa144cab..02f7bd85 100644 --- a/servant-client/CHANGELOG.md +++ b/servant-client/CHANGELOG.md @@ -1,6 +1,11 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-client/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.16.0.1 +-------- + +- Allow `base-compat-0.11` + 0.16 ---- diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 5c8268fc..dd7356f1 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: servant-client -version: 0.16 +version: 0.16.0.1 synopsis: Automatic derivation of querying functions for servant category: Servant, Web diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index 1feb56d6..ec8a63e5 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -16,10 +16,11 @@ import Prelude.Compat import Control.Concurrent.MVar (modifyMVar, newMVar) -import qualified Data.ByteString as BS import Control.Concurrent.STM.TVar import Control.Exception + (SomeException (..), catch) import Control.Monad + (unless) import Control.Monad.Base (MonadBase (..)) import Control.Monad.Catch @@ -27,15 +28,18 @@ import Control.Monad.Catch import Control.Monad.Error.Class (MonadError (..)) import Control.Monad.IO.Class - (liftIO) + (MonadIO (..)) import Control.Monad.Reader + (MonadReader, ReaderT, ask, runReaderT) import Control.Monad.STM (STM, atomically) import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.Except + (ExceptT, runExceptT) import Data.Bifunctor (bimap) +import qualified Data.ByteString as BS import Data.ByteString.Builder (toLazyByteString) import qualified Data.ByteString.Lazy as BSL @@ -64,8 +68,8 @@ import Network.HTTP.Types (hContentType, renderQuery, statusCode) import Servant.Client.Core -import qualified Servant.Types.SourceT as S import qualified Network.HTTP.Client as Client +import qualified Servant.Types.SourceT as S -- | The environment in which a request is run. data ClientEnv diff --git a/servant-http-streams/CHANGELOG.md b/servant-http-streams/CHANGELOG.md index 7bf14e4f..19b1f6b1 100644 --- a/servant-http-streams/CHANGELOG.md +++ b/servant-http-streams/CHANGELOG.md @@ -1,6 +1,11 @@ [The latest version of this document is on GitHub.](https://github.com/haskell-servant/servant/blob/master/servant-http-streams/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.16.0.1 +-------- + +- Allow `base-compat-0.11` + 0.16 ---- diff --git a/servant-http-streams/src/Servant/HttpStreams/Internal.hs b/servant-http-streams/src/Servant/HttpStreams/Internal.hs index 3c5fb7e4..54c920bc 100644 --- a/servant-http-streams/src/Servant/HttpStreams/Internal.hs +++ b/servant-http-streams/src/Servant/HttpStreams/Internal.hs @@ -18,6 +18,8 @@ import Control.DeepSeq (NFData, force) import Control.Exception (IOException, SomeException (..), catch, evaluate, throwIO) +import Control.Monad + (unless) import Control.Monad.Base (MonadBase (..)) import Control.Monad.Codensity @@ -25,9 +27,13 @@ import Control.Monad.Codensity import Control.Monad.Error.Class (MonadError (..)) import Control.Monad.IO.Class - (liftIO) + (MonadIO (..)) import Control.Monad.Reader + (MonadReader, ReaderT, ask, runReaderT) +import Control.Monad.Trans.Class + (lift) import Control.Monad.Trans.Except + (ExceptT, runExceptT) import Data.Bifunctor (bimap, first) import Data.ByteString.Builder From 71ca2a203c30df159d6040e938d732f7889e4eb6 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Mon, 30 Sep 2019 10:53:32 +0300 Subject: [PATCH 03/31] Allow jsaddle-dom-0.9.3.1 --- .travis.yml | 8 ++++++++ cabal.project | 4 ++++ 2 files changed, 12 insertions(+) diff --git a/.travis.yml b/.travis.yml index 337014b9..d6385fae 100644 --- a/.travis.yml +++ b/.travis.yml @@ -171,6 +171,10 @@ install: echo "allow-newer: jsaddle-0.9.6.0:lens" >> cabal.project echo "allow-newer: jsaddle-0.9.6.0:primitive" >> cabal.project echo "allow-newer: jsaddle-0.9.6.0:time" >> cabal.project + echo "allow-newer: jsaddle-dom-0.9.3.1:base" >> cabal.project + echo "allow-newer: jsaddle-dom-0.9.3.1:base-compat" >> cabal.project + echo "allow-newer: jsaddle-dom-0.9.3.1:Cabal" >> cabal.project + echo "allow-newer: jsaddle-dom-0.9.3.1:lens" >> cabal.project echo "allow-newer: jsaddle-dom-0.9.3.2:base" >> cabal.project echo "allow-newer: jsaddle-dom-0.9.3.2:base-compat" >> cabal.project echo "allow-newer: jsaddle-dom-0.9.3.2:Cabal" >> cabal.project @@ -284,6 +288,10 @@ script: echo "allow-newer: jsaddle-0.9.6.0:lens" >> cabal.project echo "allow-newer: jsaddle-0.9.6.0:primitive" >> cabal.project echo "allow-newer: jsaddle-0.9.6.0:time" >> cabal.project + echo "allow-newer: jsaddle-dom-0.9.3.1:base" >> cabal.project + echo "allow-newer: jsaddle-dom-0.9.3.1:base-compat" >> cabal.project + echo "allow-newer: jsaddle-dom-0.9.3.1:Cabal" >> cabal.project + echo "allow-newer: jsaddle-dom-0.9.3.1:lens" >> cabal.project echo "allow-newer: jsaddle-dom-0.9.3.2:base" >> cabal.project echo "allow-newer: jsaddle-dom-0.9.3.2:base-compat" >> cabal.project echo "allow-newer: jsaddle-dom-0.9.3.2:Cabal" >> cabal.project diff --git a/cabal.project b/cabal.project index 41093bdc..fc36d163 100644 --- a/cabal.project +++ b/cabal.project @@ -65,6 +65,10 @@ constraints: sqlite-simple < 0 allow-newer: jsaddle-0.9.6.0:lens allow-newer: jsaddle-0.9.6.0:primitive allow-newer: jsaddle-0.9.6.0:time +allow-newer: jsaddle-dom-0.9.3.1:base +allow-newer: jsaddle-dom-0.9.3.1:base-compat +allow-newer: jsaddle-dom-0.9.3.1:Cabal +allow-newer: jsaddle-dom-0.9.3.1:lens allow-newer: jsaddle-dom-0.9.3.2:base allow-newer: jsaddle-dom-0.9.3.2:base-compat allow-newer: jsaddle-dom-0.9.3.2:Cabal From 0cc1109c05c1871b225a033836b6e87e4378a5e4 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Mon, 30 Sep 2019 19:40:18 +0300 Subject: [PATCH 04/31] Add changelog.d directory, amend CONTRIBUTING.md --- CONTRIBUTING.md | 29 ++++++++++++++++++++++++++++- changelog.d/issue1028 | 10 ++++++++++ changelog.d/issue1200 | 10 ++++++++++ changelog.d/todo | 6 ++++++ 4 files changed, 54 insertions(+), 1 deletion(-) create mode 100644 changelog.d/issue1028 create mode 100644 changelog.d/issue1200 create mode 100644 changelog.d/todo diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 82e66a5d..46eb65f7 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -35,7 +35,34 @@ Some things we like: Though we aren't sticklers for style, the `.stylish-haskell.yaml` and `HLint.hs` files in the repository provide a good baseline for consistency. -**Important**: please do not modify the changelog files nor the versions of the servant packages you are sending patches for. We take care of this before every release and do it uniformly for all the servant packages, so there's no need to worry about this for your pull requests. +**Important**: please do not modify the versions of the servant packages you are sending patches for. + +## Changelog entries + +We experiment with using [changelog-d tool](https://github.com/phadej/changelog-d) to assemble changelogs. +You are not required to install it. + +In each PR please add a file to `changelog.d` directory named after issue you are solving or the pull request itself (in a separate commit after you know the pull request number). For example + +```cabal +synopsis: One sentence summary of the change. +prs: #1219 +issues: #1028 + +description: { + +A longer description. Small changes don't need this. +Bigger ones definitely do, for example we try to include migration hints +for breaking changes. + +However if you don't know what to write, that's ok too. + +By the way, the braces around are omitted when the file is parsed. +They can be used so the field doesn't need to be indented, which is handy +for prose. + +} +``` ## PR process diff --git a/changelog.d/issue1028 b/changelog.d/issue1028 new file mode 100644 index 00000000..aaa51e50 --- /dev/null +++ b/changelog.d/issue1028 @@ -0,0 +1,10 @@ +synopsis: Add NoContentVerb +prs: #1228 #1219 +issues: #1028 +significance: significant + +description: { + +TBW + +} diff --git a/changelog.d/issue1200 b/changelog.d/issue1200 new file mode 100644 index 00000000..ad664066 --- /dev/null +++ b/changelog.d/issue1200 @@ -0,0 +1,10 @@ +synopsis: Fix Verb with headers checking content type differently +prs: #1204 +issues: #1200 +packages: servant-client servant-client-core servant-http-streams + +description: { + +TBW + +} diff --git a/changelog.d/todo b/changelog.d/todo new file mode 100644 index 00000000..7ee059f6 --- /dev/null +++ b/changelog.d/todo @@ -0,0 +1,6 @@ +synopsis: unclassified pull requests +prs: #1229 #1224 #1226 #1216 #1214 #1194 +prs: #1194 #1201 #1198 #1197 #1190 #1188 +prs: #1183 #1181 #1182 #1175 #1175 #1174 +prs: #1173 #1171 #1154 #1162 #1157 #1159 +prs: #1156 From ed201224dc55a7c220cb05eb1cfaade3bde075a1 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Mon, 30 Sep 2019 21:17:13 +0300 Subject: [PATCH 05/31] Add changelog entry --- changelog.d/z-changelog-d | 8 ++++++++ 1 file changed, 8 insertions(+) create mode 100644 changelog.d/z-changelog-d diff --git a/changelog.d/z-changelog-d b/changelog.d/z-changelog-d new file mode 100644 index 00000000..c7e027ff --- /dev/null +++ b/changelog.d/z-changelog-d @@ -0,0 +1,8 @@ +synopsis: Try changelog-d for changelog management +prs: #1230 + +description: { + +Check the [CONTRIBUTING.md](https://github.com/haskell-servant/servant/blob/master/CONTRIBUTING.md) for details + +} From 6d0c415377d8b02aa8c55ee9a60b42f7927b3290 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Tue, 1 Oct 2019 13:49:25 +0300 Subject: [PATCH 06/31] Add few delays in servant-jsaddle tests Hopefully they will fail less on Travis with these --- changelog.d/todo | 1 + servant-jsaddle/test/Servant/Client/JSaddleSpec.hs | 4 +++- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/changelog.d/todo b/changelog.d/todo index 7ee059f6..a4b587c3 100644 --- a/changelog.d/todo +++ b/changelog.d/todo @@ -4,3 +4,4 @@ prs: #1194 #1201 #1198 #1197 #1190 #1188 prs: #1183 #1181 #1182 #1175 #1175 #1174 prs: #1173 #1171 #1154 #1162 #1157 #1159 prs: #1156 +prs: #1233 diff --git a/servant-jsaddle/test/Servant/Client/JSaddleSpec.hs b/servant-jsaddle/test/Servant/Client/JSaddleSpec.hs index 759fbebe..c5820d8e 100644 --- a/servant-jsaddle/test/Servant/Client/JSaddleSpec.hs +++ b/servant-jsaddle/test/Servant/Client/JSaddleSpec.hs @@ -105,16 +105,18 @@ spec = do serverApp = pure $ logRequest $ addCors $ serve testApi testServer Warp.testWithApplication serverApp $ \serverPort -> do + threadDelay $ 500 * 1000 let clientApp :: IO Application clientApp = WS.jsaddleOr defaultConnectionOptions (action serverPort >> Run.syncPoint) WS.jsaddleApp Warp.testWithApplication (simpleCors <$> clientApp) $ \clientPort -> do + threadDelay $ 500 * 1000 + putStrLn $ "server http://localhost:" ++ show serverPort putStrLn $ "client http://localhost:" ++ show clientPort putStrLn $ "google-chrome-stable --headless --disable-gpu --screenshot http://localhost:" ++ show clientPort - -- threadDelay $ 1000 * 1000 * 1000 -- Run headless chrome -- https://docs.travis-ci.com/user/gui-and-headless-browsers/#using-the-chrome-addon-in-the-headless-mode From 99aa09e65bc2e2a6d1653cf52558e0d008f64035 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Tue, 1 Oct 2019 16:28:28 +0300 Subject: [PATCH 07/31] Catch WS.ConnectionClosed --- servant-jsaddle/test/Servant/Client/JSaddleSpec.hs | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/servant-jsaddle/test/Servant/Client/JSaddleSpec.hs b/servant-jsaddle/test/Servant/Client/JSaddleSpec.hs index c5820d8e..55c29fbf 100644 --- a/servant-jsaddle/test/Servant/Client/JSaddleSpec.hs +++ b/servant-jsaddle/test/Servant/Client/JSaddleSpec.hs @@ -8,7 +8,10 @@ module Servant.Client.JSaddleSpec where import Control.Concurrent (threadDelay) -import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Concurrent.MVar + (newEmptyMVar, putMVar, takeMVar) +import Control.Exception + (handle, throwIO) import Control.Monad.Trans import Data.Aeson import Data.ByteString @@ -28,15 +31,16 @@ import qualified Language.Javascript.JSaddle.WebSockets as WS import qualified Network.HTTP.Types as Http import qualified Network.Wai as Wai import Network.Wai.Handler.Warp as Warp -import qualified System.Process as P import Network.Wai.Middleware.AddHeaders import Network.Wai.Middleware.Cors (simpleCors) import Network.WebSockets (defaultConnectionOptions) +import qualified Network.WebSockets as WS import Servant.API import Servant.Client.JSaddle import Servant.Server +import qualified System.Process as P import Test.Hspec type TestApi = ReqBody '[OctetStream] ByteString :> Post '[JSON] TestResponse @@ -104,7 +108,11 @@ spec = do let serverApp :: IO Application serverApp = pure $ logRequest $ addCors $ serve testApi testServer - Warp.testWithApplication serverApp $ \serverPort -> do + let handler :: WS.ConnectionException -> IO () + handler WS.ConnectionClosed = return () + handler e = throwIO e + + handle handler $ Warp.testWithApplication serverApp $ \serverPort -> do threadDelay $ 500 * 1000 let clientApp :: IO Application From ec80f251f333ca9510a1a28366799693b3c03707 Mon Sep 17 00:00:00 2001 From: Noah Snelson Date: Mon, 7 Oct 2019 11:23:30 -0700 Subject: [PATCH 08/31] Fixes issue #1206 by updating broken links in tutorial. --- changelog.d/issue1206 | 13 +++++++++++++ doc/tutorial/Authentication.lhs | 2 +- doc/tutorial/Client.lhs | 4 ++-- 3 files changed, 16 insertions(+), 3 deletions(-) create mode 100644 changelog.d/issue1206 diff --git a/changelog.d/issue1206 b/changelog.d/issue1206 new file mode 100644 index 00000000..e6e1f1ae --- /dev/null +++ b/changelog.d/issue1206 @@ -0,0 +1,13 @@ +synopsis: Fix broken links in Tutorial documentation. +issues: #1206 + +description: { + + In servant/doc/tutorial/Client.lhs, several links point to an .lhs file, + which show as broken in the live web documentation. Changing the suffix to + .html displays the correct documentation. + + In servant/doc/tutorial/Authentication.lhs, a link to GHC documentation for + Type Families pointed to a 404'd page. A link to existing GHC documentation + was substituted. +} diff --git a/doc/tutorial/Authentication.lhs b/doc/tutorial/Authentication.lhs index e1e9e58a..e358ac62 100644 --- a/doc/tutorial/Authentication.lhs +++ b/doc/tutorial/Authentication.lhs @@ -318,7 +318,7 @@ genAuthAPI = Proxy Now we need to bring everything together for the server. We have the `AuthHandler Request Account` value and an `AuthProtected` endpoint. To bind these -together, we need to provide a [Type Family](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/type-families.html) +together, we need to provide a [Type Family](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#type-families) instance that tells the `HasServer` instance that our `Context` will supply a `Account` (via `AuthHandler Request Account`) and that downstream combinators will have access to this `Account` value (or an error will be thrown if authentication diff --git a/doc/tutorial/Client.lhs b/doc/tutorial/Client.lhs index 00c2f26e..404ea027 100644 --- a/doc/tutorial/Client.lhs +++ b/doc/tutorial/Client.lhs @@ -1,9 +1,9 @@ # Querying an API -While defining handlers that [serve an API](Server.lhs) has a lot to it, querying an API is simpler: we do not care about what happens inside the webserver, we just need to know how to talk to it and get a response back. That said, we usually have to write the querying functions by hand because the structure of the API isn't a first class citizen and can't be inspected to generate the client-side functions. +While defining handlers that [serve an API](Server.html) has a lot to it, querying an API is simpler: we do not care about what happens inside the webserver, we just need to know how to talk to it and get a response back. That said, we usually have to write the querying functions by hand because the structure of the API isn't a first class citizen and can't be inspected to generate the client-side functions. **servant** however has a way to inspect APIs, because APIs are just Haskell types and (GHC) Haskell lets us do quite a few things with types. In the same way that we look at an API type to deduce the types the handlers should have, we can inspect the structure of the API to *derive* Haskell functions that take one argument for each occurrence of `Capture`, `ReqBody`, `QueryParam` -and friends (see [the tutorial introduction](ApiType.lhs) for an overview). By *derive*, we mean that there's no code generation involved - the functions are defined just by the structure of the API type. +and friends (see [the tutorial introduction](ApiType.html) for an overview). By *derive*, we mean that there's no code generation involved - the functions are defined just by the structure of the API type. The source for this tutorial section is a literate Haskell file, so first we need to have some language extensions and imports: From 56127724480422b8854d0aeb28ad906c9153c0bd Mon Sep 17 00:00:00 2001 From: Noah Snelson Date: Mon, 7 Oct 2019 18:55:47 -0700 Subject: [PATCH 09/31] Change Type Families user manual link to specify GHC 8.8.1 --- doc/tutorial/Authentication.lhs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/tutorial/Authentication.lhs b/doc/tutorial/Authentication.lhs index e358ac62..e602528e 100644 --- a/doc/tutorial/Authentication.lhs +++ b/doc/tutorial/Authentication.lhs @@ -318,7 +318,7 @@ genAuthAPI = Proxy Now we need to bring everything together for the server. We have the `AuthHandler Request Account` value and an `AuthProtected` endpoint. To bind these -together, we need to provide a [Type Family](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#type-families) +together, we need to provide a [Type Family](https://downloads.haskell.org/~ghc/8.8.1/docs/html/users_guide/glasgow_exts.html#type-families) instance that tells the `HasServer` instance that our `Context` will supply a `Account` (via `AuthHandler Request Account`) and that downstream combinators will have access to this `Account` value (or an error will be thrown if authentication From ce3c68f94bf96d6b5f5d409197bfbac362211faf Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Tue, 5 Nov 2019 16:31:06 +0100 Subject: [PATCH 10/31] servant-client-core: Redact Authorization header --- servant-client-core/servant-client-core.cabal | 1 + .../src/Servant/Client/Core/Request.hs | 26 ++++++++++++++++++- .../test/Servant/Client/Core/RequestSpec.hs | 19 ++++++++++++++ 3 files changed, 45 insertions(+), 1 deletion(-) create mode 100644 servant-client-core/test/Servant/Client/Core/RequestSpec.hs diff --git a/servant-client-core/servant-client-core.cabal b/servant-client-core/servant-client-core.cabal index 5789da60..3faf65bb 100644 --- a/servant-client-core/servant-client-core.cabal +++ b/servant-client-core/servant-client-core.cabal @@ -96,6 +96,7 @@ test-suite spec main-is: Spec.hs other-modules: Servant.Client.Core.Internal.BaseUrlSpec + Servant.Client.Core.RequestSpec -- Dependencies inherited from the library. No need to specify bounds. build-depends: diff --git a/servant-client-core/src/Servant/Client/Core/Request.hs b/servant-client-core/src/Servant/Client/Core/Request.hs index 73756e70..0276d46f 100644 --- a/servant-client-core/src/Servant/Client/Core/Request.hs +++ b/servant-client-core/src/Servant/Client/Core/Request.hs @@ -64,8 +64,32 @@ data RequestF body path = Request , requestHeaders :: Seq.Seq Header , requestHttpVersion :: HttpVersion , requestMethod :: Method - } deriving (Generic, Typeable, Eq, Show, Functor, Foldable, Traversable) + } deriving (Generic, Typeable, Eq, Functor, Foldable, Traversable) +instance (Show a, Show b) => + Show (Servant.Client.Core.Request.RequestF a b) where + showsPrec p req + = showParen + (p >= 11) + ( showString "Request {requestPath = " + . showsPrec 0 (requestPath req) + . showString ", requestQueryString = " + . showsPrec 0 (requestQueryString req) + . showString ", requestBody = " + . showsPrec 0 (requestBody req) + . showString ", requestAccept = " + . showsPrec 0 (requestAccept req) + . showString ", requestHeaders = " + . showsPrec 0 (redactSensitiveHeader <$> requestHeaders req)) + . showString ", requestHttpVersion = " + . showsPrec 0 (requestHttpVersion req) + . showString ", requestMethod = " + . showsPrec 0 (requestMethod req) + . showString "}" + where + redactSensitiveHeader :: Header -> Header + redactSensitiveHeader ("Authorization", _) = ("Authorization", "") + redactSensitiveHeader h = h instance Bifunctor RequestF where bimap = bimapDefault instance Bifoldable RequestF where bifoldMap = bifoldMapDefault instance Bitraversable RequestF where diff --git a/servant-client-core/test/Servant/Client/Core/RequestSpec.hs b/servant-client-core/test/Servant/Client/Core/RequestSpec.hs new file mode 100644 index 00000000..99a1db7d --- /dev/null +++ b/servant-client-core/test/Servant/Client/Core/RequestSpec.hs @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE OverloadedStrings #-} +module Servant.Client.Core.RequestSpec (spec) where + + +import Prelude () +import Prelude.Compat +import Control.Monad +import Data.List (isInfixOf) +import Servant.Client.Core.Request +import Test.Hspec + +spec :: Spec +spec = do + describe "Request" $ do + describe "show" $ do + it "redacts the authorization header" $ do + let request = void $ defaultRequest { requestHeaders = pure ("authorization", "secret") } + isInfixOf "secret" (show request) `shouldBe` False From 143091eb3f1a153d17b1bdae12fb70b768e07cf3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Thu, 7 Nov 2019 18:53:41 -0500 Subject: [PATCH 11/31] merge documentation from duplicate routes Servant supports defining the same route multiple times with different content-types and result-types, but servant-docs was only documenting the first of copy of such duplicated routes. It now combines the documentation from all the copies. Unfortunately, it is not yet possible for the documentation to specify multiple status codes. --- servant-docs/src/Servant/Docs/Internal.hs | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 4ba7c962..c102007e 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -20,6 +20,7 @@ #include "overlapping-compat.h" module Servant.Docs.Internal where +import Debug.Trace import Prelude () import Prelude.Compat @@ -116,7 +117,8 @@ instance Semigroup API where (<>) = mappend instance Monoid API where - API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2) (b1 `mappend` b2) + API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2) + (HM.unionWith combineAction b1 (traceShowId b2)) mempty = API mempty mempty -- | An empty 'API' @@ -223,6 +225,15 @@ data Response = Response , _respHeaders :: [HTTP.Header] } deriving (Eq, Ord, Show) +-- | Combine two Responses, we can't make a monoid because merging Status breaks +-- the laws. +-- +-- As such, we invent a non-commutative, left associative operation +-- 'combineResponse' to mush two together taking the status from the very left. +combineResponse :: Response -> Response -> Response +Response s ts bs hs `combineResponse` Response _ ts' bs' hs' + = Response s (ts <> ts') (bs <> bs') (hs <> hs') + -- | Default response: status code 200, no response body. -- -- Can be tweaked with two lenses. @@ -265,11 +276,10 @@ data Action = Action -- laws. -- -- As such, we invent a non-commutative, left associative operation --- 'combineAction' to mush two together taking the response, body and content --- types from the very left. +-- 'combineAction' to mush two together taking the response from the very left. combineAction :: Action -> Action -> Action -Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ = - Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp +Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' ts' body' resp' = + Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') (ts <> ts') (body <> body') (resp `combineResponse` resp') -- | Default 'Action'. Has no 'captures', no query 'params', expects -- no request body ('rqbody') and the typical response is 'defResponse'. From 1f6d7d7ea8aef0cb927e89e308dd99874bda9daa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Thu, 7 Nov 2019 19:01:56 -0500 Subject: [PATCH 12/31] remove leftover debug code --- servant-docs/src/Servant/Docs/Internal.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index c102007e..65394c4c 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -20,7 +20,6 @@ #include "overlapping-compat.h" module Servant.Docs.Internal where -import Debug.Trace import Prelude () import Prelude.Compat @@ -118,7 +117,7 @@ instance Semigroup API where instance Monoid API where API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2) - (HM.unionWith combineAction b1 (traceShowId b2)) + (HM.unionWith combineAction b1 b2) mempty = API mempty mempty -- | An empty 'API' From fdb1e030e6a7e3565db4ee2f2b1317295b0025fd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Thu, 7 Nov 2019 19:08:45 -0500 Subject: [PATCH 13/31] add changelog.d entry --- changelog.d/issue1240 | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 changelog.d/issue1240 diff --git a/changelog.d/issue1240 b/changelog.d/issue1240 new file mode 100644 index 00000000..95f6b05e --- /dev/null +++ b/changelog.d/issue1240 @@ -0,0 +1,15 @@ +synopsis: Merge documentation from duplicate routes +prs: #1241 +issues: #1240 + +description: { + +Servant supports defining the same route multiple times with different +content-types and result-types, but servant-docs was only documenting +the first of copy of such duplicated routes. It now combines the +documentation from all the copies. + +Unfortunately, it is not yet possible for the documentation to specify +multiple status codes. + +} From 0cfd9e6597a9a97e7e860a6a4468cda1da21eda7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Thu, 7 Nov 2019 19:31:29 -0500 Subject: [PATCH 14/31] test "merge documentation from duplicate routes" --- servant-docs/test/Servant/DocsSpec.hs | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index eedc18a9..c6f7a915 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -52,8 +52,10 @@ spec :: Spec spec = describe "Servant.Docs" $ do describe "markdown" $ do - let md = markdown (docs (Proxy :: Proxy TestApi1)) - tests md + let md1 = markdown (docs (Proxy :: Proxy TestApi1)) + tests1 md1 + let md2 = markdown (docs (Proxy :: Proxy TestApi2)) + tests2 md2 describe "markdown with extra info" $ do let @@ -65,7 +67,7 @@ spec = describe "Servant.Docs" $ do (Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1)) (defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]]) md = markdown (docsWith defaultDocOptions [] extra (Proxy :: Proxy TestApi1)) - tests md + tests1 md it "contains the extra info provided" $ do md `shouldContain` "Get an Integer" md `shouldContain` "Post data" @@ -93,7 +95,7 @@ spec = describe "Servant.Docs" $ do where - tests md = do + tests1 md = do it "mentions supported content-types" $ do md `shouldContain` "application/json" md `shouldContain` "text/plain;charset=utf-8" @@ -116,6 +118,11 @@ spec = describe "Servant.Docs" $ do it "does not generate any docs mentioning the 'empty-api' path" $ md `shouldNotContain` "empty-api" + tests2 md = do + it "mentions the content-types from both copies of the route" $ do + md `shouldContain` "application/json" + md `shouldContain` "text/plain;charset=utf-8" + -- * APIs @@ -142,6 +149,10 @@ type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int) :<|> Header "X-Test" Int :> Put '[JSON] Int :<|> "empty-api" :> EmptyAPI +type TestApi2 = "duplicate-endpoint" :> Get '[JSON] Datatype1 + :<|> "duplicate-endpoint" :> Get '[PlainText] Int + + data TT = TT1 | TT2 deriving (Show, Eq) data UT = UT1 | UT2 deriving (Show, Eq) From 8507cc509ba7bb17e2a970c0062d503c24147bd3 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Mon, 11 Nov 2019 10:11:34 +0200 Subject: [PATCH 15/31] Regenerate .travis.yml --- .travis.yml | 55 ++++++++++++++++++++++++++--------------------------- 1 file changed, 27 insertions(+), 28 deletions(-) diff --git a/.travis.yml b/.travis.yml index d6385fae..53d44e3d 100644 --- a/.travis.yml +++ b/.travis.yml @@ -4,7 +4,7 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.5.20190916 +# version: 0.7.20191106 # language: c dist: xenial @@ -20,6 +20,7 @@ cache: directories: - $HOME/.cabal/packages - $HOME/.cabal/store + - $HOME/.hlint before_cache: - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log # remove files that are regenerated by 'cabal update' @@ -32,7 +33,7 @@ before_cache: matrix: include: - compiler: ghcjs-8.4 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["cabal-install-3.0"]}} + addons: {"apt":{"sources":["hvr-ghc",{"sourceline":"deb http://ppa.launchpad.net/hvr/ghcjs/ubuntu xenial main"},{"sourceline":"deb https://deb.nodesource.com/node_8.x xenial main","key_url":"https://deb.nodesource.com/gpgkey/nodesource.gpg.key"}],"packages":["ghcjs-8.4","cabal-install-3.0","ghc-8.4.4","nodejs"]}} - compiler: ghc-8.8.1 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}} - compiler: ghc-8.6.5 @@ -50,21 +51,11 @@ before_install: else GHCJS=false; fi - - | - if [ "$TRAVIS_OS_NAME" = "linux" ]; then - if $GHCJS ; then sudo add-apt-repository -y ppa:hvr/ghcjs ; fi; - if $GHCJS ; then curl -s https://deb.nodesource.com/gpgkey/nodesource.gpg.key | sudo apt-key add - ; fi; - if $GHCJS ; then sudo apt-add-repository 'https://deb.nodesource.com/node_8.x xenial main' ; fi; - if $GHCJS ; then sudo apt-get update ; fi; - sudo apt-get install $CC; - if $GHCJS ; then sudo apt-get install -y nodejs cabal-install-3.0 ; fi; - fi - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - WITHCOMPILER="-w $HC" - if $GHCJS ; then HC=${HC}js ; fi - if $GHCJS ; then WITHCOMPILER="--ghcjs ${WITHCOMPILER}js" ; fi - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//') - - if $GHCJS ; then sudo apt-get install -y ghc-8.4.4 ; fi - if $GHCJS ; then PATH="/opt/ghc/8.4.4/bin:$PATH" ; fi - HCPKG="$HC-pkg" - unset CC @@ -104,21 +95,29 @@ install: - HEADHACKAGE=false - rm -f $CABALHOME/config - | - echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config - echo "remote-build-reporting: anonymous" >> $CABALHOME/config - echo "write-ghc-environment-files: always" >> $CABALHOME/config - echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config - echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config - echo "world-file: $CABALHOME/world" >> $CABALHOME/config - echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config - echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config - echo "installdir: $CABALHOME/bin" >> $CABALHOME/config - echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config - echo "store-dir: $CABALHOME/store" >> $CABALHOME/config - echo "install-dirs user" >> $CABALHOME/config - echo " prefix: $CABALHOME" >> $CABALHOME/config - echo "repository hackage.haskell.org" >> $CABALHOME/config - echo " url: http://hackage.haskell.org/" >> $CABALHOME/config + echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config + echo "remote-build-reporting: anonymous" >> $CABALHOME/config + echo "write-ghc-environment-files: always" >> $CABALHOME/config + echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config + echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config + echo "world-file: $CABALHOME/world" >> $CABALHOME/config + echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config + echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config + echo "installdir: $CABALHOME/bin" >> $CABALHOME/config + echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config + echo "store-dir: $CABALHOME/store" >> $CABALHOME/config + echo "install-dirs user" >> $CABALHOME/config + echo " prefix: $CABALHOME" >> $CABALHOME/config + echo "repository hackage.haskell.org" >> $CABALHOME/config + echo " url: http://hackage.haskell.org/" >> $CABALHOME/config + echo " secure: True" >> $CABALHOME/config + echo " key-threshold: 3" >> $CABALHOME/config + echo " root-keys:" >> $CABALHOME/config + echo " fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0" >> $CABALHOME/config + echo " 1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42" >> $CABALHOME/config + echo " 2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3" >> $CABALHOME/config + echo " 0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d" >> $CABALHOME/config + echo " 51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921" >> $CABALHOME/config - GHCJOBS=-j2 - | echo "program-default-options" >> $CABALHOME/config @@ -343,5 +342,5 @@ script: - if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output ; fi - echo -en 'travis_fold:end:haddock\\r' -# REGENDATA ["--config=cabal.haskell-ci","--output=.travis.yml","cabal.project"] +# REGENDATA ("0.7.20191106",["--config=cabal.haskell-ci","--output=.travis.yml","cabal.project"]) # EOF From da365b1e477282397857ab5ee36b3b15d2b7b3ab Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jan=20Hr=C4=8Dek?= Date: Tue, 12 Nov 2019 08:57:14 +0100 Subject: [PATCH 16/31] Various haddock fixes --- servant/src/Servant/API/Description.hs | 4 ++-- servant/src/Servant/API/Raw.hs | 5 +++-- servant/src/Servant/API/TypeLevel.hs | 2 +- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/servant/src/Servant/API/Description.hs b/servant/src/Servant/API/Description.hs index b7996650..18c54322 100644 --- a/servant/src/Servant/API/Description.hs +++ b/servant/src/Servant/API/Description.hs @@ -39,14 +39,14 @@ data Summary (sym :: Symbol) --type MyApi = Description -- "This comment is visible in multiple Servant interpretations \ -- \and can be really long if necessary. \ --- \Haskell multiline support is not perfect \ +-- \Haskell multiline String support is not perfect \ -- \but it's still very readable." -- :> Get '[JSON] Book -- :} data Description (sym :: Symbol) deriving (Typeable) --- | Fold modifier list to decide whether argument should be parsed strictly or leniently. +-- | Fold list of modifiers to extract description as a type-level String. -- -- >>> :kind! FoldDescription '[] -- FoldDescription '[] :: Symbol diff --git a/servant/src/Servant/API/Raw.hs b/servant/src/Servant/API/Raw.hs index 0624298c..4ece3845 100644 --- a/servant/src/Servant/API/Raw.hs +++ b/servant/src/Servant/API/Raw.hs @@ -11,6 +11,7 @@ import Data.Typeable -- a modified (stripped) 'pathInfo' if the 'Application' is being routed with 'Servant.API.Sub.:>'. -- -- In addition to just letting you plug in your existing WAI 'Application's, --- this can also be used with to serve --- static files stored in a particular directory on your filesystem +-- this can also be used with functions from +-- +-- to serve static files stored in a particular directory on your filesystem data Raw deriving Typeable diff --git a/servant/src/Servant/API/TypeLevel.hs b/servant/src/Servant/API/TypeLevel.hs index 188aa63d..79ff287a 100644 --- a/servant/src/Servant/API/TypeLevel.hs +++ b/servant/src/Servant/API/TypeLevel.hs @@ -178,7 +178,7 @@ type family IsStrictSubAPI sub api :: Constraint where -- | Check that every element of @xs@ is an endpoint of @api@ (using @'IsIn'@). -- --- ok (Proxy :: Proxy (AllIsIn (Endpoints SampleAPI) SampleAPI)) +-- >>> ok (Proxy :: Proxy (AllIsIn (Endpoints SampleAPI) SampleAPI)) -- OK type family AllIsIn xs api :: Constraint where AllIsIn '[] api = () From 13b21cbbf1160bdbc55088fc97168640c58dfe60 Mon Sep 17 00:00:00 2001 From: Robert Hensing Date: Tue, 12 Nov 2019 15:01:35 +0100 Subject: [PATCH 17/31] Add changelog entry --- changelog.d/pull1238 | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 changelog.d/pull1238 diff --git a/changelog.d/pull1238 b/changelog.d/pull1238 new file mode 100644 index 00000000..eeca9ddb --- /dev/null +++ b/changelog.d/pull1238 @@ -0,0 +1,2 @@ +synopsis: Redact the authorization header in Show and exceptions +prs: #1238 From 83336ae991c9f7a7a2dfd4a53ebd22a856dca8a1 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sun, 17 Nov 2019 19:39:44 +0200 Subject: [PATCH 18/31] Small updates - Allow newer js-jquery in tutorial - use bionic on Travis - allow newer hspec in servant-jsaddle --- .travis.yml | 14 +++++++------- cabal.haskell-ci | 1 + doc/tutorial/tutorial.cabal | 2 +- servant-jsaddle/servant-jsaddle.cabal | 2 +- 4 files changed, 10 insertions(+), 9 deletions(-) diff --git a/.travis.yml b/.travis.yml index 53d44e3d..97ea3717 100644 --- a/.travis.yml +++ b/.travis.yml @@ -7,7 +7,7 @@ # version: 0.7.20191106 # language: c -dist: xenial +dist: bionic git: # whether to recursively clone submodules submodules: false @@ -33,17 +33,17 @@ before_cache: matrix: include: - compiler: ghcjs-8.4 - addons: {"apt":{"sources":["hvr-ghc",{"sourceline":"deb http://ppa.launchpad.net/hvr/ghcjs/ubuntu xenial main"},{"sourceline":"deb https://deb.nodesource.com/node_8.x xenial main","key_url":"https://deb.nodesource.com/gpgkey/nodesource.gpg.key"}],"packages":["ghcjs-8.4","cabal-install-3.0","ghc-8.4.4","nodejs"]}} + addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"},{"sourceline":"deb http://ppa.launchpad.net/hvr/ghcjs/ubuntu bionic main"}],"packages":["ghcjs-8.4","cabal-install-3.0","ghc-8.4.4","nodejs"]}} - compiler: ghc-8.8.1 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}} + addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.1","cabal-install-3.0"]}} - compiler: ghc-8.6.5 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-3.0"]}} + addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.0"]}} - compiler: ghc-8.4.4 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-3.0"]}} + addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.0"]}} - compiler: ghc-8.2.2 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-3.0"]}} + addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.0"]}} - compiler: ghc-8.0.2 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-3.0"]}} + addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.0"]}} before_install: - | if echo $CC | grep -q ghcjs; then diff --git a/cabal.haskell-ci b/cabal.haskell-ci index 023c5323..85c02cf6 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -1,3 +1,4 @@ +distribution: bionic folds: all-but-test branches: master jobs-selection: any diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index d68dad30..296b6476 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -66,7 +66,7 @@ library blaze-html >= 0.9.0.1 && < 0.10 , blaze-markup >= 0.8.0.0 && < 0.9 , cookie >= 0.4.3 && < 0.5 - , js-jquery >= 3.2.1 && < 3.3 + , js-jquery >= 3.3.1 && < 3.4 , lucid >= 2.9.11 && < 2.10 , random >= 1.1 && < 1.2 , servant-js >= 0.9 && < 0.10 diff --git a/servant-jsaddle/servant-jsaddle.cabal b/servant-jsaddle/servant-jsaddle.cabal index e12cf9e5..4ff54b6d 100644 --- a/servant-jsaddle/servant-jsaddle.cabal +++ b/servant-jsaddle/servant-jsaddle.cabal @@ -122,4 +122,4 @@ test-suite spec , jsaddle-warp , QuickCheck - build-tool-depends: hspec-discover:hspec-discover >=2.4.4 && <2.5 + build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.8 From ce5939b837403f48482fde81e4873558f713ad9a Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Mon, 9 Dec 2019 14:31:10 +0200 Subject: [PATCH 19/31] Try to fix CI: remove servant-jssaddle, regenerate .travis.yml --- .travis.yml | 25 ++++++++++++++----------- cabal.project | 4 ++-- 2 files changed, 16 insertions(+), 13 deletions(-) diff --git a/.travis.yml b/.travis.yml index 97ea3717..0fafe196 100644 --- a/.travis.yml +++ b/.travis.yml @@ -4,9 +4,11 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.7.20191106 +# version: 0.9.20191209 # +version: ~> 1.0 language: c +os: linux dist: bionic git: # whether to recursively clone submodules @@ -30,20 +32,26 @@ before_cache: - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx - rm -rfv $CABALHOME/packages/head.hackage -matrix: +jobs: include: - compiler: ghcjs-8.4 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"},{"sourceline":"deb http://ppa.launchpad.net/hvr/ghcjs/ubuntu bionic main"}],"packages":["ghcjs-8.4","cabal-install-3.0","ghc-8.4.4","nodejs"]}} + addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"},{"sourceline":"deb http://ppa.launchpad.net/hvr/ghcjs/ubuntu bionic main"},{"sourceline":"deb https://deb.nodesource.com/node_10.x bionic main","key_url":"https://deb.nodesource.com/gpgkey/nodesource.gpg.key"}],"packages":["ghcjs-8.4","cabal-install-3.0","ghc-8.4.4","nodejs"]}} + os: linux - compiler: ghc-8.8.1 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.1","cabal-install-3.0"]}} + os: linux - compiler: ghc-8.6.5 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.0"]}} + os: linux - compiler: ghc-8.4.4 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.0"]}} + os: linux - compiler: ghc-8.2.2 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.0"]}} + os: linux - compiler: ghc-8.0.2 addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu bionic main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.0"]}} + os: linux before_install: - | if echo $CC | grep -q ghcjs; then @@ -142,7 +150,6 @@ install: if ! $GHCJS ; then echo "packages: servant-machines" >> cabal.project ; fi if ! $GHCJS ; then echo "packages: servant-conduit" >> cabal.project ; fi if ! $GHCJS ; then echo "packages: servant-pipes" >> cabal.project ; fi - echo "packages: servant-jsaddle" >> cabal.project if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/basic-auth" >> cabal.project ; fi if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/curl-mock" >> cabal.project ; fi if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: doc/cookbook/basic-streaming" >> cabal.project ; fi @@ -180,7 +187,7 @@ install: echo "allow-newer: jsaddle-dom-0.9.3.2:lens" >> cabal.project echo "allow-newer: jsaddle-warp-0.9.6.0:time" >> cabal.project echo "optimization: False" >> cabal.project - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-file-upload|cookbook-generic|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-jsaddle|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" + - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-file-upload|cookbook-generic|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true - if [ -f "servant/configure.ac" ]; then (cd "servant" && autoreconf -i); fi @@ -194,7 +201,6 @@ install: - if [ -f "servant-machines/configure.ac" ]; then (cd "servant-machines" && autoreconf -i); fi - if [ -f "servant-conduit/configure.ac" ]; then (cd "servant-conduit" && autoreconf -i); fi - if [ -f "servant-pipes/configure.ac" ]; then (cd "servant-pipes" && autoreconf -i); fi - - if [ -f "servant-jsaddle/configure.ac" ]; then (cd "servant-jsaddle" && autoreconf -i); fi - if [ -f "doc/cookbook/basic-auth/configure.ac" ]; then (cd "doc/cookbook/basic-auth" && autoreconf -i); fi - if [ -f "doc/cookbook/curl-mock/configure.ac" ]; then (cd "doc/cookbook/curl-mock" && autoreconf -i); fi - if [ -f "doc/cookbook/basic-streaming/configure.ac" ]; then (cd "doc/cookbook/basic-streaming" && autoreconf -i); fi @@ -232,7 +238,6 @@ script: - PKGDIR_servant_machines="$(find . -maxdepth 1 -type d -regex '.*/servant-machines-[0-9.]*')" - PKGDIR_servant_conduit="$(find . -maxdepth 1 -type d -regex '.*/servant-conduit-[0-9.]*')" - PKGDIR_servant_pipes="$(find . -maxdepth 1 -type d -regex '.*/servant-pipes-[0-9.]*')" - - PKGDIR_servant_jsaddle="$(find . -maxdepth 1 -type d -regex '.*/servant-jsaddle-[0-9.]*')" - PKGDIR_cookbook_basic_auth="$(find . -maxdepth 1 -type d -regex '.*/cookbook-basic-auth-[0-9.]*')" - PKGDIR_cookbook_curl_mock="$(find . -maxdepth 1 -type d -regex '.*/cookbook-curl-mock-[0-9.]*')" - PKGDIR_cookbook_basic_streaming="$(find . -maxdepth 1 -type d -regex '.*/cookbook-basic-streaming-[0-9.]*')" @@ -259,7 +264,6 @@ script: if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_machines}" >> cabal.project ; fi if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_conduit}" >> cabal.project ; fi if ! $GHCJS ; then echo "packages: ${PKGDIR_servant_pipes}" >> cabal.project ; fi - echo "packages: ${PKGDIR_servant_jsaddle}" >> cabal.project if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_basic_auth}" >> cabal.project ; fi if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_curl_mock}" >> cabal.project ; fi if ! $GHCJS && [ $HCNUMVER -ge 80400 ] ; then echo "packages: ${PKGDIR_cookbook_basic_streaming}" >> cabal.project ; fi @@ -297,7 +301,7 @@ script: echo "allow-newer: jsaddle-dom-0.9.3.2:lens" >> cabal.project echo "allow-newer: jsaddle-warp-0.9.6.0:time" >> cabal.project echo "optimization: False" >> cabal.project - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-file-upload|cookbook-generic|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-jsaddle|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" + - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-file-upload|cookbook-generic|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true - | @@ -314,7 +318,6 @@ script: servant-machines) echo ${PKGDIR_servant_machines} ;; servant-conduit) echo ${PKGDIR_servant_conduit} ;; servant-pipes) echo ${PKGDIR_servant_pipes} ;; - servant-jsaddle) echo ${PKGDIR_servant_jsaddle} ;; cookbook-basic-auth) echo ${PKGDIR_cookbook_basic_auth} ;; cookbook-curl-mock) echo ${PKGDIR_cookbook_curl_mock} ;; cookbook-basic-streaming) echo ${PKGDIR_cookbook_basic_streaming} ;; @@ -342,5 +345,5 @@ script: - if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output ; fi - echo -en 'travis_fold:end:haddock\\r' -# REGENDATA ("0.7.20191106",["--config=cabal.haskell-ci","--output=.travis.yml","cabal.project"]) +# REGENDATA ("0.9.20191209",["--config=cabal.haskell-ci","--output=.travis.yml","cabal.project"]) # EOF diff --git a/cabal.project b/cabal.project index fc36d163..d926827c 100644 --- a/cabal.project +++ b/cabal.project @@ -15,8 +15,8 @@ packages: servant-pipes/ -- servant GHCJS -packages: - servant-jsaddle/ +-- packages: +-- servant-jsaddle/ -- Cookbooks packages: From 2050ec86a2e906aa19f1354552cd3c9e1db288e0 Mon Sep 17 00:00:00 2001 From: natsuki14 Date: Sun, 15 Dec 2019 03:09:01 +0900 Subject: [PATCH 20/31] I guess some sample curl commans are wrong. --- doc/tutorial/Authentication.lhs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/tutorial/Authentication.lhs b/doc/tutorial/Authentication.lhs index e602528e..da18b7ee 100644 --- a/doc/tutorial/Authentication.lhs +++ b/doc/tutorial/Authentication.lhs @@ -368,10 +368,10 @@ genAuthMain = run 8080 (serveWithContext genAuthAPI genAuthServerContext genAuth $ curl -XGET localhost:8080/private Missing auth header -$ curl -XGET localhost:8080/private -H "servant-auth-cookie: key3" +$ curl -XGET localhost:8080/private -H "Cookie: servant-auth-cookie=key3" [{"ssshhh":"this is a secret: Ghédalia Tazartès"}] -$ curl -XGET localhost:8080/private -H "servant-auth-cookie: bad-key" +$ curl -XGET localhost:8080/private -H "Cookie: servant-auth-cookie=bad-key" Invalid Cookie $ curl -XGET localhost:8080/public From 78cf24af40c0561d85b6b54b2c499e00def1fe1c Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sat, 14 Dec 2019 22:20:51 +0200 Subject: [PATCH 21/31] Add changelog.d config --- changelog.d/config | 2 ++ 1 file changed, 2 insertions(+) create mode 100644 changelog.d/config diff --git a/changelog.d/config b/changelog.d/config new file mode 100644 index 00000000..bb3c2c48 --- /dev/null +++ b/changelog.d/config @@ -0,0 +1,2 @@ +organization: haskell-servant +repository: servant From 164ae93c31c5b0dbad552310259a480ac23e3515 Mon Sep 17 00:00:00 2001 From: Eric Torreborre Date: Thu, 5 Sep 2019 08:47:14 +0200 Subject: [PATCH 22/31] added a function to create Client.Request in ClientEnv --- changelog.d/pr-1213 | 11 ++++++++ .../using-free-client/UsingFreeClient.lhs | 10 +++---- servant-client/src/Servant/Client.hs | 1 + .../src/Servant/Client/Internal/HttpClient.hs | 26 ++++++++++++++----- .../Client/Internal/HttpClient/Streaming.hs | 13 +++++----- .../src/Servant/Client/Streaming.hs | 1 + .../test/Servant/ClientTestUtils.hs | 4 +++ servant-client/test/Servant/SuccessSpec.hs | 17 ++++++++++-- stack.yaml | 6 ++++- 9 files changed, 69 insertions(+), 20 deletions(-) create mode 100644 changelog.d/pr-1213 diff --git a/changelog.d/pr-1213 b/changelog.d/pr-1213 new file mode 100644 index 00000000..faecdd83 --- /dev/null +++ b/changelog.d/pr-1213 @@ -0,0 +1,11 @@ +synopsis: Added a function to create Client.Request in ClientEnv +packages: servant-client +prs: #1213 #1255 +description: { + +The new member `makeClientRequest` of `ClientEnv` is used to create +`http-client` `Request` from `servant-client-core` `Request`. +This functionality can be used for example to set +dynamic timeouts for each request. + +} diff --git a/doc/cookbook/using-free-client/UsingFreeClient.lhs b/doc/cookbook/using-free-client/UsingFreeClient.lhs index fe64b6eb..d72ad6d5 100644 --- a/doc/cookbook/using-free-client/UsingFreeClient.lhs +++ b/doc/cookbook/using-free-client/UsingFreeClient.lhs @@ -2,7 +2,7 @@ or simply put: _a practical introduction to `Servant.Client.Free`_. -Someone asked on IRC how one could access the intermediate Requests (resp. Responses) +Someone asked on IRC how one could access the intermediate Requests (resp. Responses) produced (resp. received) by client functions derived using servant-client. My response to such inquiries is: to extend `servant-client` in an ad-hoc way (e.g for testing or debugging purposes), use `Servant.Client.Free`. This recipe shows how. @@ -119,7 +119,7 @@ Now we can use `servant-client`'s internals to convert servant's `Request` to http-client's `Request`, and we can inspect it: ```haskell - let req' = I.requestToClientRequest burl req + let req' = I.defaultMakeClientRequest burl req putStrLn $ "Making request: " ++ show req' ``` @@ -136,11 +136,11 @@ and calling the continuation. We should get a `Pure` value. ```haskell let res = I.clientResponseToResponse id res' - + case k res of Pure n -> putStrLn $ "Expected 1764, got " ++ show n - _ -> + _ -> putStrLn "ERROR: didn't got a response" ``` @@ -153,7 +153,7 @@ and responses available for us to inspect, since `RunClient` only gives us access to one `Request` or `Response` at a time. On the other hand, a "batch collection" of requests and/or responses can be achieved -with both free clients and a custom `RunClient` instance rather easily, for example +with both free clients and a custom `RunClient` instance rather easily, for example by using a `Writer [(Request, Response)]` monad. Here is an example of running our small `test` against a running server: diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 1ecc07db..e0c8dab5 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -9,6 +9,7 @@ module Servant.Client , runClientM , ClientEnv(..) , mkClientEnv + , defaultMakeClientRequest , hoistClient , module Servant.Client.Core.Reexport ) where diff --git a/servant-client/src/Servant/Client/Internal/HttpClient.hs b/servant-client/src/Servant/Client/Internal/HttpClient.hs index ec8a63e5..c25c8a93 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient.hs @@ -72,16 +72,27 @@ import qualified Network.HTTP.Client as Client import qualified Servant.Types.SourceT as S -- | The environment in which a request is run. +-- The 'baseUrl' and 'makeClientRequest' function are used to create a @http-client@ request. +-- Cookies are then added to that request if a 'CookieJar' is set on the environment. +-- Finally the request is executed with the 'manager'. +-- The 'makeClientRequest' function can be used to modify the request to execute and set values which +-- are not specified on a @servant@ 'Request' like 'responseTimeout' or 'redirectCount' data ClientEnv = ClientEnv { manager :: Client.Manager , baseUrl :: BaseUrl , cookieJar :: Maybe (TVar Client.CookieJar) + , makeClientRequest :: BaseUrl -> Request -> Client.Request + -- ^ this function can be used to customize the creation of @http-client@ requests from @servant@ requests. Default value: 'defaultMakeClientRequest' + -- Note that: + -- 1. 'makeClientRequest' exists to allow overriding operational semantics e.g. 'responseTimeout' per request, + -- If you need global modifications, you should use 'managerModifyRequest' + -- 2. the 'cookieJar', if defined, is being applied after 'makeClientRequest' is called. } -- | 'ClientEnv' smart constructor. mkClientEnv :: Client.Manager -> BaseUrl -> ClientEnv -mkClientEnv mgr burl = ClientEnv mgr burl Nothing +mkClientEnv mgr burl = ClientEnv mgr burl Nothing defaultMakeClientRequest -- | Generates a set of client functions for an API. -- @@ -152,8 +163,8 @@ runClientM cm env = runExceptT $ flip runReaderT env $ unClientM cm performRequest :: Request -> ClientM Response performRequest req = do - ClientEnv m burl cookieJar' <- ask - let clientRequest = requestToClientRequest burl req + ClientEnv m burl cookieJar' createClientRequest <- ask + let clientRequest = createClientRequest burl req request <- case cookieJar' of Nothing -> pure clientRequest Just cj -> liftIO $ do @@ -162,7 +173,7 @@ performRequest req = do oldCookieJar <- readTVar cj let (newRequest, newCookieJar) = Client.insertCookiesIntoRequest - (requestToClientRequest burl req) + clientRequest oldCookieJar now writeTVar cj newCookieJar @@ -215,8 +226,11 @@ clientResponseToResponse f r = Response , responseHttpVersion = Client.responseVersion r } -requestToClientRequest :: BaseUrl -> Request -> Client.Request -requestToClientRequest burl r = Client.defaultRequest +-- | Create a @http-client@ 'Client.Request' from a @servant@ 'Request' +-- The 'Client.host', 'Client.path' and 'Client.port' fields are extracted from the 'BaseUrl' +-- otherwise the body, headers and query string are derived from the @servant@ 'Request' +defaultMakeClientRequest :: BaseUrl -> Request -> Client.Request +defaultMakeClientRequest burl r = Client.defaultRequest { Client.method = requestMethod r , Client.host = fromString $ baseUrlHost burl , Client.port = baseUrlPort burl diff --git a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs index 449c638d..2f5a1cb7 100644 --- a/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs +++ b/servant-client/src/Servant/Client/Internal/HttpClient/Streaming.hs @@ -12,7 +12,7 @@ module Servant.Client.Internal.HttpClient.Streaming ( ClientEnv (..), mkClientEnv, clientResponseToResponse, - requestToClientRequest, + defaultMakeClientRequest, catchConnectionError, ) where @@ -55,7 +55,7 @@ import Servant.Client.Core import Servant.Client.Internal.HttpClient (ClientEnv (..), catchConnectionError, clientResponseToResponse, mkClientEnv, mkFailureResponse, - requestToClientRequest) + defaultMakeClientRequest) import qualified Servant.Types.SourceT as S @@ -139,8 +139,8 @@ runClientM cm env = withClientM cm env (evaluate . force) performRequest :: Request -> ClientM Response performRequest req = do -- TODO: should use Client.withResponse here too - ClientEnv m burl cookieJar' <- ask - let clientRequest = requestToClientRequest burl req + ClientEnv m burl cookieJar' createClientRequest <- ask + let clientRequest = createClientRequest burl req request <- case cookieJar' of Nothing -> pure clientRequest Just cj -> liftIO $ do @@ -149,7 +149,7 @@ performRequest req = do oldCookieJar <- readTVar cj let (newRequest, newCookieJar) = Client.insertCookiesIntoRequest - (requestToClientRequest burl req) + clientRequest oldCookieJar now writeTVar cj newCookieJar @@ -173,7 +173,8 @@ performWithStreamingRequest :: Request -> (StreamingResponse -> IO a) -> ClientM performWithStreamingRequest req k = do m <- asks manager burl <- asks baseUrl - let request = requestToClientRequest burl req + createClientRequest <- asks makeClientRequest + let request = createClientRequest burl req ClientM $ lift $ lift $ Codensity $ \k1 -> Client.withResponse request m $ \res -> do let status = Client.responseStatus res diff --git a/servant-client/src/Servant/Client/Streaming.hs b/servant-client/src/Servant/Client/Streaming.hs index d4e8721d..5800df0d 100644 --- a/servant-client/src/Servant/Client/Streaming.hs +++ b/servant-client/src/Servant/Client/Streaming.hs @@ -10,6 +10,7 @@ module Servant.Client.Streaming , runClientM , ClientEnv(..) , mkClientEnv + , defaultMakeClientRequest , hoistClient , module Servant.Client.Core.Reexport ) where diff --git a/servant-client/test/Servant/ClientTestUtils.hs b/servant-client/test/Servant/ClientTestUtils.hs index 1509574c..6f385010 100644 --- a/servant-client/test/Servant/ClientTestUtils.hs +++ b/servant-client/test/Servant/ClientTestUtils.hs @@ -93,6 +93,7 @@ type Api = :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person] :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool :<|> "rawSuccess" :> Raw + :<|> "rawSuccessPassHeaders" :> Raw :<|> "rawFailure" :> Raw :<|> "multiple" :> Capture "first" String :> @@ -118,6 +119,7 @@ getQueryParam :: Maybe String -> ClientM Person getQueryParams :: [String] -> ClientM [Person] getQueryFlag :: Bool -> ClientM Bool getRawSuccess :: HTTP.Method -> ClientM Response +getRawSuccessPassHeaders :: HTTP.Method -> ClientM Response getRawFailure :: HTTP.Method -> ClientM Response getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> ClientM (String, Maybe Int, Bool, [(String, [Rational])]) @@ -135,6 +137,7 @@ getRoot :<|> getQueryParams :<|> getQueryFlag :<|> getRawSuccess + :<|> getRawSuccessPassHeaders :<|> getRawFailure :<|> getMultiple :<|> getRespHeaders @@ -157,6 +160,7 @@ server = serve api ( :<|> (\ names -> return (zipWith Person names [0..])) :<|> return :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.ok200 [] "rawSuccess") + :<|> (Tagged $ \ request respond -> (respond $ Wai.responseLBS HTTP.ok200 (Wai.requestHeaders $ request) "rawSuccess")) :<|> (Tagged $ \ _request respond -> respond $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure") :<|> (\ a b c d -> return (a, b, c, d)) :<|> (return $ addHeader 1729 $ addHeader "eg2" True) diff --git a/servant-client/test/Servant/SuccessSpec.hs b/servant-client/test/Servant/SuccessSpec.hs index d16cfd79..272b607c 100644 --- a/servant-client/test/Servant/SuccessSpec.hs +++ b/servant-client/test/Servant/SuccessSpec.hs @@ -42,6 +42,7 @@ import Servant.API (NoContent (NoContent), getHeaders) import Servant.Client import qualified Servant.Client.Core.Request as Req +import Servant.Client.Internal.HttpClient (defaultMakeClientRequest) import Servant.Test.ComprehensiveAPI import Servant.ClientTestUtils @@ -125,11 +126,24 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do it "Stores Cookie in CookieJar after a redirect" $ \(_, baseUrl) -> do mgr <- C.newManager C.defaultManagerSettings cj <- atomically . newTVar $ C.createCookieJar [] - _ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj)) + _ <- runClientM (getRedirectWithCookie HTTP.methodGet) (ClientEnv mgr baseUrl (Just cj) defaultMakeClientRequest) cookie <- listToMaybe . C.destroyCookieJar <$> atomically (readTVar cj) C.cookie_name <$> cookie `shouldBe` Just "testcookie" C.cookie_value <$> cookie `shouldBe` Just "test" + it "Can modify the outgoing Request using the ClientEnv" $ \(_, baseUrl) -> do + mgr <- C.newManager C.defaultManagerSettings + -- In proper situation, extra headers should probably be visible in API type. + -- However, testing for response timeout is difficult, so we test with something which is easy to observe + let createClientRequest url r = (defaultMakeClientRequest url r) { C.requestHeaders = [("X-Added-Header", "XXX")] } + let clientEnv = (mkClientEnv mgr baseUrl) { makeClientRequest = createClientRequest } + res <- runClientM (getRawSuccessPassHeaders HTTP.methodGet) clientEnv + case res of + Left e -> + assertFailure $ show e + Right r -> + ("X-Added-Header", "XXX") `elem` toList (responseHeaders r) `shouldBe` True + modifyMaxSuccess (const 20) $ do it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) -> property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body -> @@ -137,4 +151,3 @@ successSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do result <- left show <$> runClient (getMultiple cap num flag body) baseUrl return $ result === Right (cap, num, flag, body) - diff --git a/stack.yaml b/stack.yaml index a4855c36..47a7eab0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -17,16 +17,20 @@ packages: extra-deps: - base-compat-0.10.5 +- base-orphans-0.8.1 - conduit-1.3.1 - hspec-2.6.0 - hspec-core-2.6.0 - hspec-discover-2.6.0 -- http-api-data-0.4 +- http-api-data-0.4.1 - http-media-0.7.1.3 +- http-types-0.12.3 - network-2.8.0.0 - pipes-safe-2.3.1 - QuickCheck-2.12.6.1 - resourcet-1.2.2 - sop-core-0.4.0.0 +- time-compat-1.9.2.2 +- unordered-containers-0.2.10.0 - wai-extra-3.0.24.3 - tasty-1.1.0.4 From 05b64ed652e4c49b43abaef44d8e51080ef42dca Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sat, 14 Dec 2019 23:15:17 +0200 Subject: [PATCH 23/31] Go through changelog entries so far --- changelog.d/issue1028 | 10 +++++++++- changelog.d/issue1200 | 4 +++- changelog.d/issue1206 | 13 ------------- changelog.d/issue1240 | 1 + changelog.d/jsaddle | 3 +++ changelog.d/pr1156 | 17 +++++++++++++++++ changelog.d/pr1190 | 7 +++++++ changelog.d/pr1194 | 3 +++ changelog.d/pr1197 | 4 ++++ changelog.d/pr1201 | 3 +++ changelog.d/{pr-1213 => pr1213} | 1 + changelog.d/{pull1238 => pr1238} | 1 + changelog.d/todo | 7 ------- changelog.d/z-ci-tweaks | 17 +++++++++++++++++ changelog.d/z-cookbook | 9 +++++++++ changelog.d/z-dependency-upgrades | 8 ++++++++ changelog.d/z-documentation-updates | 7 +++++++ 17 files changed, 93 insertions(+), 22 deletions(-) delete mode 100644 changelog.d/issue1206 create mode 100644 changelog.d/jsaddle create mode 100644 changelog.d/pr1156 create mode 100644 changelog.d/pr1190 create mode 100644 changelog.d/pr1194 create mode 100644 changelog.d/pr1197 create mode 100644 changelog.d/pr1201 rename changelog.d/{pr-1213 => pr1213} (92%) rename changelog.d/{pull1238 => pr1238} (75%) delete mode 100644 changelog.d/todo create mode 100644 changelog.d/z-ci-tweaks create mode 100644 changelog.d/z-cookbook create mode 100644 changelog.d/z-dependency-upgrades create mode 100644 changelog.d/z-documentation-updates diff --git a/changelog.d/issue1028 b/changelog.d/issue1028 index aaa51e50..73cede30 100644 --- a/changelog.d/issue1028 +++ b/changelog.d/issue1028 @@ -5,6 +5,14 @@ significance: significant description: { -TBW +The `NoContent` API endpoints should now use `NoContentVerb` combinator. +The API type changes are usually of the kind + +```diff +- :<|> PostNoContent '[JSON] NoContent ++ :<|> PostNoContent +``` + +i.e. one doesn't need to specify the content-type anymore. There is no content. } diff --git a/changelog.d/issue1200 b/changelog.d/issue1200 index ad664066..885a2571 100644 --- a/changelog.d/issue1200 +++ b/changelog.d/issue1200 @@ -1,10 +1,12 @@ synopsis: Fix Verb with headers checking content type differently +packages: servant-client-core servant-client prs: #1204 issues: #1200 packages: servant-client servant-client-core servant-http-streams description: { -TBW +For `Verb`s with response `Headers`, the implementation didn't check +for the content-type of the response. Now it does. } diff --git a/changelog.d/issue1206 b/changelog.d/issue1206 deleted file mode 100644 index e6e1f1ae..00000000 --- a/changelog.d/issue1206 +++ /dev/null @@ -1,13 +0,0 @@ -synopsis: Fix broken links in Tutorial documentation. -issues: #1206 - -description: { - - In servant/doc/tutorial/Client.lhs, several links point to an .lhs file, - which show as broken in the live web documentation. Changing the suffix to - .html displays the correct documentation. - - In servant/doc/tutorial/Authentication.lhs, a link to GHC documentation for - Type Families pointed to a 404'd page. A link to existing GHC documentation - was substituted. -} diff --git a/changelog.d/issue1240 b/changelog.d/issue1240 index 95f6b05e..dce11a69 100644 --- a/changelog.d/issue1240 +++ b/changelog.d/issue1240 @@ -1,4 +1,5 @@ synopsis: Merge documentation from duplicate routes +packages: servant-docs prs: #1241 issues: #1240 diff --git a/changelog.d/jsaddle b/changelog.d/jsaddle new file mode 100644 index 00000000..02dcf5b4 --- /dev/null +++ b/changelog.d/jsaddle @@ -0,0 +1,3 @@ +synopsis: Progress on servant-jsaddle +packages: servant-jsaddle +prs: #1216 diff --git a/changelog.d/pr1156 b/changelog.d/pr1156 new file mode 100644 index 00000000..91726ae9 --- /dev/null +++ b/changelog.d/pr1156 @@ -0,0 +1,17 @@ +synopsis: `Capture` can be `Lenient` +issues: #1155 +prs: #1156 +significance: significant +description: { + +You can specify a lenient capture as + +```haskell +:<|> "capture-lenient" :> Capture' '[Lenient] "foo" Int :> GET +``` + +which will make the capture always succeed. Handlers will be of the +type `Either String CapturedType`, where `Left err` represents +the possible parse failure. + +} diff --git a/changelog.d/pr1190 b/changelog.d/pr1190 new file mode 100644 index 00000000..e6a308c4 --- /dev/null +++ b/changelog.d/pr1190 @@ -0,0 +1,7 @@ +synopsis: Add sponsorship button +prs: #1190 +description: { + +[Well-Typed](https://www.well-typed.com/) + +} diff --git a/changelog.d/pr1194 b/changelog.d/pr1194 new file mode 100644 index 00000000..53136662 --- /dev/null +++ b/changelog.d/pr1194 @@ -0,0 +1,3 @@ +synopsis: Prevent race-conditions in testing +packages: servant-docs +prs: #1194 diff --git a/changelog.d/pr1197 b/changelog.d/pr1197 new file mode 100644 index 00000000..bc041c62 --- /dev/null +++ b/changelog.d/pr1197 @@ -0,0 +1,4 @@ +synopsis: `HasClient` instance for `Stream` with `Headers` +packages: servant-client servant-client servant-http-streams +prs: #1197 +issues: #1170 diff --git a/changelog.d/pr1201 b/changelog.d/pr1201 new file mode 100644 index 00000000..0724fc38 --- /dev/null +++ b/changelog.d/pr1201 @@ -0,0 +1,3 @@ +synopsis: Remove unused extensions from cabal file +packages: servant +prs: #1201 diff --git a/changelog.d/pr-1213 b/changelog.d/pr1213 similarity index 92% rename from changelog.d/pr-1213 rename to changelog.d/pr1213 index faecdd83..3cb5f15b 100644 --- a/changelog.d/pr-1213 +++ b/changelog.d/pr1213 @@ -1,5 +1,6 @@ synopsis: Added a function to create Client.Request in ClientEnv packages: servant-client +significance: significant prs: #1213 #1255 description: { diff --git a/changelog.d/pull1238 b/changelog.d/pr1238 similarity index 75% rename from changelog.d/pull1238 rename to changelog.d/pr1238 index eeca9ddb..5b0d838c 100644 --- a/changelog.d/pull1238 +++ b/changelog.d/pr1238 @@ -1,2 +1,3 @@ synopsis: Redact the authorization header in Show and exceptions +packages: servant-client prs: #1238 diff --git a/changelog.d/todo b/changelog.d/todo deleted file mode 100644 index a4b587c3..00000000 --- a/changelog.d/todo +++ /dev/null @@ -1,7 +0,0 @@ -synopsis: unclassified pull requests -prs: #1229 #1224 #1226 #1216 #1214 #1194 -prs: #1194 #1201 #1198 #1197 #1190 #1188 -prs: #1183 #1181 #1182 #1175 #1175 #1174 -prs: #1173 #1171 #1154 #1162 #1157 #1159 -prs: #1156 -prs: #1233 diff --git a/changelog.d/z-ci-tweaks b/changelog.d/z-ci-tweaks new file mode 100644 index 00000000..b3e531eb --- /dev/null +++ b/changelog.d/z-ci-tweaks @@ -0,0 +1,17 @@ +synopsis: CI and testing tweaks. +prs: + #1154 + #1157 + #1182 + #1214 + #1229 + #1233 + #1242 + #1250 + +description: { + +We are experiencing some bitrotting of cookbook recipe dependencies, +therefore some of them aren't build as part of our CI anymore. + +} diff --git a/changelog.d/z-cookbook b/changelog.d/z-cookbook new file mode 100644 index 00000000..71dca975 --- /dev/null +++ b/changelog.d/z-cookbook @@ -0,0 +1,9 @@ +synopsis: New cookbook recipes +prs: #1171 #1088 #1198 + +description: { + +- [OIDC Recipe](#TODO) +- [MySQL Recipe](#TODO) + +} diff --git a/changelog.d/z-dependency-upgrades b/changelog.d/z-dependency-upgrades new file mode 100644 index 00000000..8e7197bc --- /dev/null +++ b/changelog.d/z-dependency-upgrades @@ -0,0 +1,8 @@ +synopsis: Dependency upgrades +prs: + #1181 + #1183 + #1188 + #1224 + #1245 + #1173 diff --git a/changelog.d/z-documentation-updates b/changelog.d/z-documentation-updates new file mode 100644 index 00000000..d14667e2 --- /dev/null +++ b/changelog.d/z-documentation-updates @@ -0,0 +1,7 @@ +synopsis: Documentation updates +prs: + #1174 + #1175 + #1234 + #1244 + #1162 From f7d5c0149f026b3e0a6117f1e5836fe4043da1fe Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sun, 15 Dec 2019 01:12:05 +0200 Subject: [PATCH 24/31] Allow warp-3.3 in master --- changelog.d/z-dependency-upgrades | 3 ++- servant-conduit/servant-conduit.cabal | 2 +- servant-machines/servant-machines.cabal | 2 +- servant-pipes/servant-pipes.cabal | 2 +- servant-server/servant-server.cabal | 4 ++-- 5 files changed, 7 insertions(+), 6 deletions(-) diff --git a/changelog.d/z-dependency-upgrades b/changelog.d/z-dependency-upgrades index 8e7197bc..43d72ef0 100644 --- a/changelog.d/z-dependency-upgrades +++ b/changelog.d/z-dependency-upgrades @@ -1,8 +1,9 @@ synopsis: Dependency upgrades prs: + #1173 #1181 #1183 #1188 #1224 #1245 - #1173 + #1257 diff --git a/servant-conduit/servant-conduit.cabal b/servant-conduit/servant-conduit.cabal index e1247803..4aec51d8 100644 --- a/servant-conduit/servant-conduit.cabal +++ b/servant-conduit/servant-conduit.cabal @@ -63,6 +63,6 @@ test-suite example , servant-server >=0.15 && <0.17 , servant-client >=0.15 && <0.17 , wai >=3.2.1.2 && <3.3 - , warp >=3.2.25 && <3.3 + , warp >=3.2.25 && <3.4 , http-client default-language: Haskell2010 diff --git a/servant-machines/servant-machines.cabal b/servant-machines/servant-machines.cabal index 80aeb450..31f1de7d 100644 --- a/servant-machines/servant-machines.cabal +++ b/servant-machines/servant-machines.cabal @@ -60,6 +60,6 @@ test-suite example , servant-server >=0.15 && <0.17 , servant-client >=0.15 && <0.17 , wai >=3.2.1.2 && <3.3 - , warp >=3.2.25 && <3.3 + , warp >=3.2.25 && <3.4 , http-client default-language: Haskell2010 diff --git a/servant-pipes/servant-pipes.cabal b/servant-pipes/servant-pipes.cabal index 480ddd26..5fdc4b5a 100644 --- a/servant-pipes/servant-pipes.cabal +++ b/servant-pipes/servant-pipes.cabal @@ -63,6 +63,6 @@ test-suite example , servant-server >=0.15 && <0.17 , servant-client >=0.15 && <0.17 , wai >=3.2.1.2 && <3.3 - , warp >=3.2.25 && <3.3 + , warp >=3.2.25 && <3.4 , http-client default-language: Haskell2010 diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 1e81a47a..0372ac16 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -121,7 +121,7 @@ executable greet build-depends: aeson >= 1.4.1.0 && < 1.5 - , warp >= 3.2.25 && < 3.3 + , warp >= 3.2.25 && < 3.4 test-suite spec type: exitcode-stdio-1.0 @@ -165,7 +165,7 @@ test-suite spec aeson >= 1.4.1.0 && < 1.5 , directory >= 1.3.0.0 && < 1.4 , hspec >= 2.6.0 && < 2.8 - , hspec-wai >= 0.9.0 && < 0.10 + , hspec-wai >= 0.10.1 && < 0.11 , QuickCheck >= 2.12.6.1 && < 2.14 , should-not-typecheck >= 2.1.0 && < 2.2 , temporary >= 1.3 && < 1.4 From 544487d15abf006392ae47dc2340b32d837e615d Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sun, 15 Dec 2019 16:05:09 +0200 Subject: [PATCH 25/31] Update stack.yaml to resolver lts-14.17 --- stack.yaml | 25 ++++--------------------- 1 file changed, 4 insertions(+), 21 deletions(-) diff --git a/stack.yaml b/stack.yaml index 47a7eab0..491c55b1 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,10 +1,10 @@ -# Let's try to keep resolver at the first day of the month -resolver: nightly-2018-09-28 # Last nightly with GHC-8.4.3 +resolver: lts-14.17 packages: -- servant-client/ - servant-client-core/ +- servant-client/ - servant-docs/ - servant-foreign/ +- servant-http-streams/ - servant-server/ - servant/ @@ -16,21 +16,4 @@ packages: # - doc/tutorial/ extra-deps: -- base-compat-0.10.5 -- base-orphans-0.8.1 -- conduit-1.3.1 -- hspec-2.6.0 -- hspec-core-2.6.0 -- hspec-discover-2.6.0 -- http-api-data-0.4.1 -- http-media-0.7.1.3 -- http-types-0.12.3 -- network-2.8.0.0 -- pipes-safe-2.3.1 -- QuickCheck-2.12.6.1 -- resourcet-1.2.2 -- sop-core-0.4.0.0 -- time-compat-1.9.2.2 -- unordered-containers-0.2.10.0 -- wai-extra-3.0.24.3 -- tasty-1.1.0.4 +- hspec-wai-0.10.1 From 069d08787421abfb00f8cd6db80ceb3edb82b8ac Mon Sep 17 00:00:00 2001 From: Matthias Heinzel Date: Tue, 3 Dec 2019 21:37:32 +0100 Subject: [PATCH 26/31] Fix compilation warnings --- changelog.d/z-ci-tweaks | 2 ++ servant-server/src/Servant/Server/Internal.hs | 6 +++--- servant-server/src/Servant/Server/Internal/DelayedIO.hs | 7 +++---- 3 files changed, 8 insertions(+), 7 deletions(-) diff --git a/changelog.d/z-ci-tweaks b/changelog.d/z-ci-tweaks index b3e531eb..331e5679 100644 --- a/changelog.d/z-ci-tweaks +++ b/changelog.d/z-ci-tweaks @@ -7,7 +7,9 @@ prs: #1229 #1233 #1242 + #1247 #1250 + #1258 description: { diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index b9a94035..6b732c11 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -80,7 +80,7 @@ import Servant.API import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), AllCTUnrender (..), AllMime, MimeRender (..), MimeUnrender (..), canHandleAcceptH, - NoContent (NoContent)) + NoContent) import Servant.API.Modifiers (FoldLenient, FoldRequired, RequestArgument, unfoldRequestArgument) @@ -89,7 +89,7 @@ import Servant.API.ResponseHeaders import qualified Servant.Types.SourceT as S import Web.HttpApiData (FromHttpApiData, parseHeader, parseQueryParam, - parseUrlPieceMaybe, parseUrlPieces, parseUrlPiece) + parseUrlPieces, parseUrlPiece) import Servant.Server.Internal.BasicAuth import Servant.Server.Internal.Context @@ -272,7 +272,7 @@ noContentRouter method status action = leafRouter route' where route' env request respond = runAction (action `addMethodCheck` methodCheck method request) - env request respond $ \ output -> + env request respond $ \ _output -> Route $ responseLBS status [] "" instance {-# OVERLAPPABLE #-} diff --git a/servant-server/src/Servant/Server/Internal/DelayedIO.hs b/servant-server/src/Servant/Server/Internal/DelayedIO.hs index 52b6aff5..48f35b9d 100644 --- a/servant-server/src/Servant/Server/Internal/DelayedIO.hs +++ b/servant-server/src/Servant/Server/Internal/DelayedIO.hs @@ -12,13 +12,12 @@ import Control.Monad.Reader import Control.Monad.Trans (MonadIO (..), MonadTrans (..)) import Control.Monad.Trans.Control - (ComposeSt, MonadBaseControl (..), MonadTransControl (..), - defaultLiftBaseWith, defaultRestoreM) + (MonadBaseControl (..)) import Control.Monad.Trans.Resource (MonadResource (..), ResourceT, runInternalState, - runResourceT, transResourceT, withInternalState) + transResourceT, withInternalState) import Network.Wai - (Application, Request, Response, ResponseReceived) + (Request) import Servant.Server.Internal.RouteResult import Servant.Server.Internal.ServerError From b4e5aa0deff238e117137be68a4345bb02b7a80b Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 19 Dec 2019 13:16:04 +0200 Subject: [PATCH 27/31] Add 1247 to documentation updates changelog --- changelog.d/z-documentation-updates | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/changelog.d/z-documentation-updates b/changelog.d/z-documentation-updates index d14667e2..3d8b2215 100644 --- a/changelog.d/z-documentation-updates +++ b/changelog.d/z-documentation-updates @@ -1,7 +1,8 @@ synopsis: Documentation updates prs: + #1162 #1174 #1175 #1234 #1244 - #1162 + #1247 From 28c4533659316f9a99deb72588ea456d7111b30e Mon Sep 17 00:00:00 2001 From: Ilia Rodionov Date: Sat, 7 Dec 2019 16:12:05 +0300 Subject: [PATCH 28/31] use queryString not rawQueryString, enables param rewrites with Middleware possible --- servant-server/src/Servant/Server/Internal.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 6b732c11..f1a24a19 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -64,7 +64,7 @@ import Network.Socket (SockAddr) import Network.Wai (Application, Request, httpVersion, isSecure, lazyRequestBody, - rawQueryString, remoteHost, requestBody, requestHeaders, + queryString, remoteHost, requestBody, requestHeaders, requestMethod, responseLBS, responseStream, vault) import Prelude () import Prelude.Compat @@ -452,7 +452,7 @@ instance hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context subserver = - let querytext req = parseQueryText $ rawQueryString req + let querytext = queryToQueryText . queryString paramname = cs $ symbolVal (Proxy :: Proxy sym) parseParam :: Request -> DelayedIO (RequestArgument mods a) @@ -519,8 +519,8 @@ instance (KnownSymbol sym, FromHttpApiData a, HasServer api context) params :: [T.Text] params = mapMaybe snd . filter (looksLikeParam . fst) - . parseQueryText - . rawQueryString + . queryToQueryText + . queryString $ req looksLikeParam name = name == paramname || name == (paramname <> "[]") @@ -546,7 +546,7 @@ instance (KnownSymbol sym, HasServer api context) hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s route Proxy context subserver = - let querytext r = parseQueryText $ rawQueryString r + let querytext = queryToQueryText . queryString param r = case lookup paramname (querytext r) of Just Nothing -> True -- param is there, with no value Just (Just v) -> examine v -- param with a value From 40582c40e45fc263b037429a61bf9432560b7963 Mon Sep 17 00:00:00 2001 From: Ilia Rodionov Date: Thu, 26 Dec 2019 17:01:10 +0300 Subject: [PATCH 29/31] add query rewriting tests and changelog item add prs: #1249 add ps1249 changelog item --- changelog.d/pr1249 | 14 ++ servant-server/test/Servant/ServerSpec.hs | 218 +++++++++++----------- 2 files changed, 127 insertions(+), 105 deletions(-) create mode 100644 changelog.d/pr1249 diff --git a/changelog.d/pr1249 b/changelog.d/pr1249 new file mode 100644 index 00000000..ff15673a --- /dev/null +++ b/changelog.d/pr1249 @@ -0,0 +1,14 @@ +synopsis: use queryString to parse QueryParam, QueryParams and QueryFlag +packages: servant-server +prs: #1249 +description: { + +Some APIs need query parameters rewriting, e.g. in order to support + for multiple casing (camel, snake, etc) or something to that effect. + +This could be easily achieved by using WAI Middleware and modyfing +request's `Query`. But QueryParam, QueryParams and QueryFlag use +`rawQueryString`. By using `queryString` rather then `rawQueryString` +we can enable such rewritings. + +} diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index ff87d04b..90e72667 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -25,6 +25,8 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as Base64 import Data.Char (toUpper) +import Data.Maybe + (fromMaybe) import Data.Proxy (Proxy (Proxy)) import Data.String @@ -35,26 +37,26 @@ import qualified Data.Text as T import GHC.Generics (Generic) import Network.HTTP.Types - (Status (..), hAccept, hContentType, imATeapot418, + (QueryItem, Status (..), hAccept, hContentType, imATeapot418, methodDelete, methodGet, methodHead, methodPatch, methodPost, methodPut, ok200, parseQuery) import Network.Wai - (Application, Request, pathInfo, queryString, rawQueryString, - requestHeaders, responseLBS) + (Application, Middleware, Request, pathInfo, queryString, + rawQueryString, requestHeaders, responseLBS) import Network.Wai.Test (defaultRequest, request, runSession, simpleBody, simpleHeaders, simpleStatus) import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, - BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll, Lenient, Strict, Delete, - EmptyAPI, Get, Header, Headers, HttpVersion, IsSecure (..), - JSON, NoContent (..), NoFraming, OctetStream, Patch, - PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw, - RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Verb, - NoContentVerb, addHeader) + BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll, + Delete, EmptyAPI, Get, Header, Headers, HttpVersion, + IsSecure (..), JSON, Lenient, NoContent (..), NoContentVerb, + NoFraming, OctetStream, Patch, PlainText, Post, Put, + QueryFlag, QueryParam, QueryParams, Raw, RemoteHost, ReqBody, + SourceIO, StdMethod (..), Stream, Strict, Verb, addHeader) import Servant.Server (Context ((:.), EmptyContext), Handler, Server, Tagged (..), - emptyServer, err400, err401, err403, err404, serve, serveWithContext) + emptyServer, err401, err403, err404, serve, serveWithContext) import Servant.Test.ComprehensiveAPI import qualified Servant.Types.SourceT as S import Test.Hspec @@ -218,7 +220,7 @@ captureServer = getLegs :<|> getEars :<|> getEyes _ -> throwError err404 getEars :: Either String Integer -> Handler Animal - getEars (Left e) = return chimera -- ignore integer parse error, return weird animal + getEars (Left _) = return chimera -- ignore integer parse error, return weird animal getEars (Right 2) = return jerry getEars (Right _) = throwError err404 @@ -339,117 +341,123 @@ qpServer = queryParamServer :<|> qpNames :<|> qpCapitalize :<|> qpAge :<|> qpAge queryParamServer (Just name_) = return alice{name = name_} queryParamServer Nothing = return alice + + queryParamSpec :: Spec queryParamSpec = do + let mkRequest params pinfo = Network.Wai.Test.request defaultRequest + { rawQueryString = params + , queryString = parseQuery params + , pathInfo = pinfo + } + describe "Servant.API.QueryParam" $ do it "allows retrieving simple GET parameters" $ - (flip runSession) (serve queryParamApi qpServer) $ do - let params1 = "?name=bob" - response1 <- Network.Wai.Test.request defaultRequest{ - rawQueryString = params1, - queryString = parseQuery params1 - } - liftIO $ do - decode' (simpleBody response1) `shouldBe` Just alice{ - name = "bob" - } - - it "allows retrieving lists in GET parameters" $ - (flip runSession) (serve queryParamApi qpServer) $ do - let params2 = "?names[]=bob&names[]=john" - response2 <- Network.Wai.Test.request defaultRequest{ - rawQueryString = params2, - queryString = parseQuery params2, - pathInfo = ["a"] - } - liftIO $ - decode' (simpleBody response2) `shouldBe` Just alice{ - name = "john" - } - - it "parses a query parameter" $ - (flip runSession) (serve queryParamApi qpServer) $ do - let params = "?age=55" - response <- Network.Wai.Test.request defaultRequest{ - rawQueryString = params, - queryString = parseQuery params, - pathInfo = ["param"] - } - liftIO $ - decode' (simpleBody response) `shouldBe` Just alice{ - age = 55 + flip runSession (serve queryParamApi qpServer) $ do + response1 <- mkRequest "?name=bob" [] + liftIO $ decode' (simpleBody response1) `shouldBe` Just alice + { name = "bob" } + it "allows retrieving lists in GET parameters" $ + flip runSession (serve queryParamApi qpServer) $ do + response2 <- mkRequest "?names[]=bob&names[]=john" ["a"] + liftIO $ decode' (simpleBody response2) `shouldBe` Just alice + { name = "john" + } + + it "parses a query parameter" $ + flip runSession (serve queryParamApi qpServer) $ do + response <- mkRequest "?age=55" ["param"] + liftIO $ decode' (simpleBody response) `shouldBe` Just alice + { age = 55 + } + it "generates an error on query parameter parse failure" $ - (flip runSession) (serve queryParamApi qpServer) $ do - let params = "?age=foo" - response <- Network.Wai.Test.request defaultRequest{ - rawQueryString = params, - queryString = parseQuery params, - pathInfo = ["param"] - } + flip runSession (serve queryParamApi qpServer) $ do + response <- mkRequest "?age=foo" ["param"] liftIO $ statusCode (simpleStatus response) `shouldBe` 400 return () it "parses multiple query parameters" $ - (flip runSession) (serve queryParamApi qpServer) $ do - let params = "?ages=10&ages=22" - response <- Network.Wai.Test.request defaultRequest{ - rawQueryString = params, - queryString = parseQuery params, - pathInfo = ["multiparam"] - } - liftIO $ - decode' (simpleBody response) `shouldBe` Just alice{ - age = 32 - } + flip runSession (serve queryParamApi qpServer) $ do + response <- mkRequest "?ages=10&ages=22" ["multiparam"] + liftIO $ decode' (simpleBody response) `shouldBe` Just alice + { age = 32 + } it "generates an error on parse failures of multiple parameters" $ - (flip runSession) (serve queryParamApi qpServer) $ do - let params = "?ages=2&ages=foo" - response <- Network.Wai.Test.request defaultRequest{ - rawQueryString = params, - queryString = parseQuery params, - pathInfo = ["multiparam"] - } + flip runSession (serve queryParamApi qpServer) $ do + response <- mkRequest "?ages=2&ages=foo" ["multiparam"] liftIO $ statusCode (simpleStatus response) `shouldBe` 400 return () - it "allows retrieving value-less GET parameters" $ - (flip runSession) (serve queryParamApi qpServer) $ do - let params3 = "?capitalize" - response3 <- Network.Wai.Test.request defaultRequest{ - rawQueryString = params3, - queryString = parseQuery params3, - pathInfo = ["b"] - } - liftIO $ - decode' (simpleBody response3) `shouldBe` Just alice{ - name = "ALICE" - } + flip runSession (serve queryParamApi qpServer) $ do + response3 <- mkRequest "?capitalize" ["b"] + liftIO $ decode' (simpleBody response3) `shouldBe` Just alice + { name = "ALICE" + } - let params3' = "?capitalize=" - response3' <- Network.Wai.Test.request defaultRequest{ - rawQueryString = params3', - queryString = parseQuery params3', - pathInfo = ["b"] - } - liftIO $ - decode' (simpleBody response3') `shouldBe` Just alice{ - name = "ALICE" - } + response3' <- mkRequest "?capitalize=" ["b"] + liftIO $ decode' (simpleBody response3') `shouldBe` Just alice + { name = "ALICE" + } - let params3'' = "?unknown=" - response3'' <- Network.Wai.Test.request defaultRequest{ - rawQueryString = params3'', - queryString = parseQuery params3'', - pathInfo = ["b"] - } - liftIO $ - decode' (simpleBody response3'') `shouldBe` Just alice{ - name = "Alice" - } + response3'' <- mkRequest "?unknown=" ["b"] + liftIO $ decode' (simpleBody response3'') `shouldBe` Just alice + { name = "Alice" + } + + describe "Uses queryString instead of rawQueryString" $ do + -- test query parameters rewriter + let queryRewriter :: Middleware + queryRewriter app req = app req + { queryString = fmap rewrite $ queryString req + } + where + rewrite :: QueryItem -> QueryItem + rewrite (k, v) = (fromMaybe k (BS.stripPrefix "person_" k), v) + + let app = queryRewriter $ serve queryParamApi qpServer + + it "allows rewriting for simple GET/query parameters" $ + flip runSession app $ do + response1 <- mkRequest "?person_name=bob" [] + liftIO $ decode' (simpleBody response1) `shouldBe` Just alice + { name = "bob" + } + + it "allows rewriting for lists in GET parameters" $ + flip runSession app $ do + response2 <- mkRequest "?person_names[]=bob&person_names[]=john" ["a"] + liftIO $ decode' (simpleBody response2) `shouldBe` Just alice + { name = "john" + } + + it "allows rewriting when parsing multiple query parameters" $ + flip runSession app $ do + response <- mkRequest "?person_ages=10&person_ages=22" ["multiparam"] + liftIO $ decode' (simpleBody response) `shouldBe` Just alice + { age = 32 + } + + it "allows retrieving value-less GET parameters" $ + flip runSession app $ do + response3 <- mkRequest "?person_capitalize" ["b"] + liftIO $ decode' (simpleBody response3) `shouldBe` Just alice + { name = "ALICE" + } + + response3' <- mkRequest "?person_capitalize=" ["b"] + liftIO $ decode' (simpleBody response3') `shouldBe` Just alice + { name = "ALICE" + } + + response3'' <- mkRequest "?person_unknown=" ["b"] + liftIO $ decode' (simpleBody response3'') `shouldBe` Just alice + { name = "Alice" + } -- }}} ------------------------------------------------------------------------------ @@ -544,7 +552,7 @@ rawSpec :: Spec rawSpec = do describe "Servant.API.Raw" $ do it "runs applications" $ do - (flip runSession) (serve rawApi (rawApplication (const (42 :: Integer)))) $ do + flip runSession (serve rawApi (rawApplication (const (42 :: Integer)))) $ do response <- Network.Wai.Test.request defaultRequest{ pathInfo = ["foo"] } @@ -552,7 +560,7 @@ rawSpec = do simpleBody response `shouldBe` "42" it "gets the pathInfo modified" $ do - (flip runSession) (serve rawApi (rawApplication pathInfo)) $ do + flip runSession (serve rawApi (rawApplication pathInfo)) $ do response <- Network.Wai.Test.request defaultRequest{ pathInfo = ["foo", "bar"] } From 524b07224ff8466416716e72d5ff9afa483464cb Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Thu, 9 Jan 2020 22:19:24 +0200 Subject: [PATCH 30/31] Change build-type: Simple; run doctests on CI via haskell-ci Don't use hspec-discover in tutorial, so doctests work on CI --- .travis.yml | 53 ++++++++++++++--------------- Makefile | 10 ++++++ cabal.haskell-ci | 3 ++ cabal.project | 3 ++ changelog.d/pr1249 | 3 +- changelog.d/pr1263 | 11 ++++++ doc/tutorial/test/Spec.hs | 12 ++++++- doc/tutorial/tutorial.cabal | 2 -- servant-server/Setup.hs | 33 +----------------- servant-server/servant-server.cabal | 21 +----------- servant-server/test/doctests.hs | 27 --------------- servant/Setup.hs | 33 +----------------- servant/servant.cabal | 31 +---------------- servant/test/Servant/LinksSpec.hs | 3 ++ servant/test/doctests.hs | 27 --------------- 15 files changed, 72 insertions(+), 200 deletions(-) create mode 100644 changelog.d/pr1263 delete mode 100644 servant-server/test/doctests.hs delete mode 100644 servant/test/doctests.hs diff --git a/.travis.yml b/.travis.yml index 0fafe196..272e8f08 100644 --- a/.travis.yml +++ b/.travis.yml @@ -4,7 +4,7 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.9.20191209 +# version: 0.9.20200110 # version: ~> 1.0 language: c @@ -73,26 +73,8 @@ before_install: - TOP=$(pwd) - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" - echo $HCNUMVER - - CABAL="$CABAL -vnormal+nowrap+markoutput" + - CABAL="$CABAL -vnormal+nowrap" - set -o pipefail - - | - echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk - echo 'BEGIN { state = "output"; }' >> .colorful.awk - echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk - echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk - echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk - echo ' if (state == "cabal") {' >> .colorful.awk - echo ' print blue($0)' >> .colorful.awk - echo ' } else {' >> .colorful.awk - echo ' print $0' >> .colorful.awk - echo ' }' >> .colorful.awk - echo '}' >> .colorful.awk - - cat .colorful.awk - - | - color_cabal_output () { - awk -f $TOP/.colorful.awk - } - - echo text | color_cabal_output install: - ${CABAL} --version - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" @@ -133,8 +115,9 @@ install: - cat $CABALHOME/config - rm -fv cabal.project cabal.project.local cabal.project.freeze - travis_retry ${CABAL} v2-update -v - - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 cabal-plan --constraint='cabal-plan ^>=0.6.0.0' --constraint='cabal-plan +exe' | color_cabal_output) ; fi - - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 hspec-discover | color_cabal_output) ; fi + - if ! $GHCJS ; then (cd /tmp && ${CABAL} v2-install $WITHCOMPILER -j2 doctest --constraint='doctest ==0.16.2.*') ; fi + - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 cabal-plan --constraint='cabal-plan ^>=0.6.0.0' --constraint='cabal-plan +exe') ; fi + - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 hspec-discover) ; fi # Generate cabal.project - rm -rf cabal.project cabal.project.local cabal.project.freeze - touch cabal.project @@ -212,14 +195,14 @@ install: - 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/using-free-client/configure.ac" ]; then (cd "doc/cookbook/using-free-client" && autoreconf -i); fi - - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output + - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - rm cabal.project.freeze script: - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) # Packaging... - echo 'Packaging...' && echo -en 'travis_fold:start:sdist\\r' - - ${CABAL} v2-sdist all | color_cabal_output + - ${CABAL} v2-sdist all - echo -en 'travis_fold:end:sdist\\r' # Unpacking... - echo 'Unpacking...' && echo -en 'travis_fold:start:unpack\\r' @@ -335,15 +318,29 @@ script: # Building with tests and benchmarks... - echo 'Building with tests and benchmarks...' && echo -en 'travis_fold:start:build-everything\\r' # build & run tests, build benchmarks - - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output + - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all - echo -en 'travis_fold:end:build-everything\\r' # Testing... - - if ! $GHCJS ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi + - if ! $GHCJS ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all ; fi - if $GHCJS ; then cabal-plan list-bins '*:test:*' | while read -r line; do testpkg=$(echo "$line" | perl -pe 's/:.*//'); testexe=$(echo "$line" | awk '{ print $2 }'); echo "testing $textexe in package $textpkg"; (cd "$(pkgdir $testpkg)" && nodejs "$testexe".jsexe/all.js); done ; fi + # Doctest... + - echo 'Doctest...' && echo -en 'travis_fold:start:doctest\\r' + - perl -i -e 'while () { print unless /package-id\s+(base-compat-batteries)-\d+(\.\d+)*/; }' .ghc.environment.* + - if ! $GHCJS ; then (cd ${PKGDIR_servant} && doctest src) ; fi + - if ! $GHCJS ; then (cd ${PKGDIR_servant_client} && doctest src) ; fi + - if ! $GHCJS ; then (cd ${PKGDIR_servant_client_core} && doctest src) ; fi + - if ! $GHCJS ; then (cd ${PKGDIR_servant_http_streams} && doctest src) ; fi + - if ! $GHCJS ; then (cd ${PKGDIR_servant_docs} && doctest src) ; fi + - if ! $GHCJS ; then (cd ${PKGDIR_servant_foreign} && doctest src) ; fi + - if ! $GHCJS ; then (cd ${PKGDIR_servant_server} && doctest src) ; fi + - if ! $GHCJS ; then (cd ${PKGDIR_servant_machines} && doctest src) ; fi + - if ! $GHCJS ; then (cd ${PKGDIR_servant_conduit} && doctest src) ; fi + - if ! $GHCJS ; then (cd ${PKGDIR_servant_pipes} && doctest src) ; fi + - echo -en 'travis_fold:end:doctest\\r' # haddock... - echo 'haddock...' && echo -en 'travis_fold:start:haddock\\r' - - if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all | color_cabal_output ; fi + - if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all ; fi - echo -en 'travis_fold:end:haddock\\r' -# REGENDATA ("0.9.20191209",["--config=cabal.haskell-ci","--output=.travis.yml","cabal.project"]) +# REGENDATA ("0.9.20200110",["--config=cabal.haskell-ci","--output=.travis.yml","cabal.project"]) # EOF diff --git a/Makefile b/Makefile index 34180491..2caf4c05 100644 --- a/Makefile +++ b/Makefile @@ -20,3 +20,13 @@ build-ghcjs : packdeps : packdeps */*.cabal + +doctest : doctest-servant doctest-servant-server + perl -i -e 'while () { print unless /package-id\s+base-compat-\d+(\.\d+)*/; }' .ghc.environment.* + +doctest-servant : + (cd servant && doctest src) + (cd servant && doctest test/Servant/LinksSpec.hs) + +doctest-servant-server : + (cd servant-server && doctest src) diff --git a/cabal.haskell-ci b/cabal.haskell-ci index 85c02cf6..ac041d53 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -4,6 +4,9 @@ branches: master jobs-selection: any google-chrome: True ghcjs-tests: True +doctest: True +doctest-filter-packages: base-compat-batteries +doctest-skip: tutorial -- https://github.com/haskell/cabal/issues/6176 ghcjs-tools: hspec-discover diff --git a/cabal.project b/cabal.project index d926827c..11c22cb4 100644 --- a/cabal.project +++ b/cabal.project @@ -76,3 +76,6 @@ allow-newer: jsaddle-dom-0.9.3.2:lens allow-newer: jsaddle-warp-0.9.6.0:time constraints: base-compat ^>=0.11 + +-- needed for doctests +write-ghc-environment-files: always diff --git a/changelog.d/pr1249 b/changelog.d/pr1249 index ff15673a..3a5c772a 100644 --- a/changelog.d/pr1249 +++ b/changelog.d/pr1249 @@ -1,6 +1,7 @@ synopsis: use queryString to parse QueryParam, QueryParams and QueryFlag packages: servant-server -prs: #1249 +prs: #1249 #1262 +significance: significant description: { Some APIs need query parameters rewriting, e.g. in order to support diff --git a/changelog.d/pr1263 b/changelog.d/pr1263 new file mode 100644 index 00000000..593bcd1b --- /dev/null +++ b/changelog.d/pr1263 @@ -0,0 +1,11 @@ +synopsis: Make packages `build-type: Simple` +packages: servant servant-server +prs: #1263 +significance: significant +description: { + +We used `build-type: Custom`, but it's problematic e.g. +for cross-compiling. The benefit is small, as the doctests +can be run other ways too (though not so conviniently). + +} diff --git a/doc/tutorial/test/Spec.hs b/doc/tutorial/test/Spec.hs index a824f8c3..4808302a 100644 --- a/doc/tutorial/test/Spec.hs +++ b/doc/tutorial/test/Spec.hs @@ -1 +1,11 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +module Main where + +import qualified JavascriptSpec + +import Test.Hspec (Spec, hspec, describe) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = describe "Javascript" JavascriptSpec.spec diff --git a/doc/tutorial/tutorial.cabal b/doc/tutorial/tutorial.cabal index 296b6476..ce245b65 100644 --- a/doc/tutorial/tutorial.cabal +++ b/doc/tutorial/tutorial.cabal @@ -83,8 +83,6 @@ test-suite spec hs-source-dirs: test main-is: Spec.hs other-modules: JavascriptSpec - build-tool-depends: - hspec-discover:hspec-discover build-depends: base , tutorial , hspec diff --git a/servant-server/Setup.hs b/servant-server/Setup.hs index 8ec54a08..44671092 100644 --- a/servant-server/Setup.hs +++ b/servant-server/Setup.hs @@ -1,33 +1,2 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wall #-} -module Main (main) where - -#ifndef MIN_VERSION_cabal_doctest -#define MIN_VERSION_cabal_doctest(x,y,z) 0 -#endif - -#if MIN_VERSION_cabal_doctest(1,0,0) - -import Distribution.Extra.Doctest ( defaultMainWithDoctests ) -main :: IO () -main = defaultMainWithDoctests "doctests" - -#else - -#ifdef MIN_VERSION_Cabal --- If the macro is defined, we have new cabal-install, --- but for some reason we don't have cabal-doctest in package-db --- --- Probably we are running cabal sdist, when otherwise using new-build --- workflow -#warning You are configuring this package without cabal-doctest installed. \ - The doctests test-suite will not work as a result. \ - To fix this, install cabal-doctest before configuring. -#endif - -import Distribution.Simple - -main :: IO () +import Distribution.Simple main = defaultMain - -#endif diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 0372ac16..a3cadcaf 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -22,7 +22,7 @@ license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors -build-type: Custom +build-type: Simple tested-with: GHC ==8.0.2 || ==8.2.2 @@ -38,12 +38,6 @@ source-repository head type: git location: http://github.com/haskell-servant/servant.git -custom-setup - setup-depends: - base >= 4 && <5, - Cabal, - cabal-doctest >= 1.0.6 && <1.1 - library exposed-modules: Servant @@ -173,16 +167,3 @@ test-suite spec build-tool-depends: hspec-discover:hspec-discover >= 2.6.0 && <2.8 - -test-suite doctests - build-depends: - base - , servant-server - , doctest >= 0.16.0 && <0.17 - type: exitcode-stdio-1.0 - main-is: test/doctests.hs - buildable: True - default-language: Haskell2010 - ghc-options: -Wall -threaded - if impl(ghc >= 8.2) - x-doctest-options: -fdiagnostics-color=never diff --git a/servant-server/test/doctests.hs b/servant-server/test/doctests.hs deleted file mode 100644 index c27aa580..00000000 --- a/servant-server/test/doctests.hs +++ /dev/null @@ -1,27 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Main (doctests) --- Copyright : (C) 2012-14 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : portable --- --- This module provides doctests for a project based on the actual versions --- of the packages it was built with. It requires a corresponding Setup.lhs --- to be added to the project ------------------------------------------------------------------------------ -module Main where - -import Build_doctests - (flags, module_sources, pkgs) -import Data.Foldable - (traverse_) -import Test.DocTest - -main :: IO () -main = do - traverse_ putStrLn args - doctest args - where - args = flags ++ pkgs ++ module_sources diff --git a/servant/Setup.hs b/servant/Setup.hs index 8ec54a08..44671092 100644 --- a/servant/Setup.hs +++ b/servant/Setup.hs @@ -1,33 +1,2 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wall #-} -module Main (main) where - -#ifndef MIN_VERSION_cabal_doctest -#define MIN_VERSION_cabal_doctest(x,y,z) 0 -#endif - -#if MIN_VERSION_cabal_doctest(1,0,0) - -import Distribution.Extra.Doctest ( defaultMainWithDoctests ) -main :: IO () -main = defaultMainWithDoctests "doctests" - -#else - -#ifdef MIN_VERSION_Cabal --- If the macro is defined, we have new cabal-install, --- but for some reason we don't have cabal-doctest in package-db --- --- Probably we are running cabal sdist, when otherwise using new-build --- workflow -#warning You are configuring this package without cabal-doctest installed. \ - The doctests test-suite will not work as a result. \ - To fix this, install cabal-doctest before configuring. -#endif - -import Distribution.Simple - -main :: IO () +import Distribution.Simple main = defaultMain - -#endif diff --git a/servant/servant.cabal b/servant/servant.cabal index b44f9f48..aef26744 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -18,7 +18,7 @@ license-file: LICENSE author: Servant Contributors maintainer: haskell-servant-maintainers@googlegroups.com copyright: 2014-2016 Zalora South East Asia Pte Ltd, 2016-2019 Servant Contributors -build-type: Custom +build-type: Simple tested-with: GHC ==8.0.2 @@ -35,12 +35,6 @@ source-repository head type: git location: http://github.com/haskell-servant/servant.git -custom-setup - setup-depends: - base >= 4 && <5, - Cabal, - cabal-doctest >= 1.0.6 && <1.1 - library exposed-modules: Servant.API @@ -176,26 +170,3 @@ test-suite spec build-tool-depends: hspec-discover:hspec-discover >= 2.6.0 && < 2.8 - -test-suite doctests - if impl(ghcjs) - buildable: False - - build-depends: - base - , servant - , doctest >= 0.16.0 && <0.17 - - -- We test Links failure with doctest, so we need extra dependencies - build-depends: - hspec >= 2.6.0 && < 2.8 - - type: exitcode-stdio-1.0 - main-is: test/doctests.hs - buildable: True - default-language: Haskell2010 - ghc-options: -Wall -threaded - if impl(ghc >= 8.2) - x-doctest-options: -fdiagnostics-color=never - x-doctest-source-dirs: test - x-doctest-modules: Servant.LinksSpec diff --git a/servant/test/Servant/LinksSpec.hs b/servant/test/Servant/LinksSpec.hs index 1c448ba0..845f5ee7 100644 --- a/servant/test/Servant/LinksSpec.hs +++ b/servant/test/Servant/LinksSpec.hs @@ -92,6 +92,9 @@ spec = describe "Servant.Links" $ do let firstLink :<|> _ = allLinks comprehensiveAPIWithoutRaw firstLink `shouldBeLink` "" +-- The doctests below aren't run on CI, setting that up is tricky. +-- They are run by makefile rule, however. + -- | -- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed, -- we'll just use doctest diff --git a/servant/test/doctests.hs b/servant/test/doctests.hs deleted file mode 100644 index c27aa580..00000000 --- a/servant/test/doctests.hs +++ /dev/null @@ -1,27 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Main (doctests) --- Copyright : (C) 2012-14 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : portable --- --- This module provides doctests for a project based on the actual versions --- of the packages it was built with. It requires a corresponding Setup.lhs --- to be added to the project ------------------------------------------------------------------------------ -module Main where - -import Build_doctests - (flags, module_sources, pkgs) -import Data.Foldable - (traverse_) -import Test.DocTest - -main :: IO () -main = do - traverse_ putStrLn args - doctest args - where - args = flags ++ pkgs ++ module_sources From 21e6000b09443e011c9d683898d634a9a3d6f9f8 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Fri, 10 Jan 2020 01:20:48 +0200 Subject: [PATCH 31/31] Remove servant-jssadle (moved to own repository) --- .travis.yml | 24 -- cabal.project | 14 - servant-jsaddle/CHANGELOG.md | 4 - servant-jsaddle/LICENSE | 30 -- servant-jsaddle/README.md | 15 - servant-jsaddle/Setup.hs | 2 - servant-jsaddle/servant-jsaddle.cabal | 125 ------- .../Client/Internal/JSaddleXhrClient.hs | 311 ------------------ servant-jsaddle/src/Servant/Client/JSaddle.hs | 20 -- .../test/Servant/Client/JSaddleSpec.hs | 173 ---------- servant-jsaddle/test/Spec.hs | 8 - 11 files changed, 726 deletions(-) delete mode 100644 servant-jsaddle/CHANGELOG.md delete mode 100644 servant-jsaddle/LICENSE delete mode 100644 servant-jsaddle/README.md delete mode 100644 servant-jsaddle/Setup.hs delete mode 100644 servant-jsaddle/servant-jsaddle.cabal delete mode 100644 servant-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs delete mode 100644 servant-jsaddle/src/Servant/Client/JSaddle.hs delete mode 100644 servant-jsaddle/test/Servant/Client/JSaddleSpec.hs delete mode 100644 servant-jsaddle/test/Spec.hs diff --git a/.travis.yml b/.travis.yml index 272e8f08..4f839a90 100644 --- a/.travis.yml +++ b/.travis.yml @@ -157,18 +157,6 @@ install: echo "allow-newer: io-streams-1.5.1.0:network" >> cabal.project echo "allow-newer: io-streams-1.5.1.0:primitive" >> cabal.project echo "allow-newer: openssl-streams-1.2.2.0:network" >> cabal.project - echo "allow-newer: jsaddle-0.9.6.0:lens" >> cabal.project - echo "allow-newer: jsaddle-0.9.6.0:primitive" >> cabal.project - echo "allow-newer: jsaddle-0.9.6.0:time" >> cabal.project - echo "allow-newer: jsaddle-dom-0.9.3.1:base" >> cabal.project - echo "allow-newer: jsaddle-dom-0.9.3.1:base-compat" >> cabal.project - echo "allow-newer: jsaddle-dom-0.9.3.1:Cabal" >> cabal.project - echo "allow-newer: jsaddle-dom-0.9.3.1:lens" >> cabal.project - echo "allow-newer: jsaddle-dom-0.9.3.2:base" >> cabal.project - echo "allow-newer: jsaddle-dom-0.9.3.2:base-compat" >> cabal.project - echo "allow-newer: jsaddle-dom-0.9.3.2:Cabal" >> cabal.project - echo "allow-newer: jsaddle-dom-0.9.3.2:lens" >> cabal.project - echo "allow-newer: jsaddle-warp-0.9.6.0:time" >> cabal.project echo "optimization: False" >> cabal.project - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-file-upload|cookbook-generic|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true @@ -271,18 +259,6 @@ script: echo "allow-newer: io-streams-1.5.1.0:network" >> cabal.project echo "allow-newer: io-streams-1.5.1.0:primitive" >> cabal.project echo "allow-newer: openssl-streams-1.2.2.0:network" >> cabal.project - echo "allow-newer: jsaddle-0.9.6.0:lens" >> cabal.project - echo "allow-newer: jsaddle-0.9.6.0:primitive" >> cabal.project - echo "allow-newer: jsaddle-0.9.6.0:time" >> cabal.project - echo "allow-newer: jsaddle-dom-0.9.3.1:base" >> cabal.project - echo "allow-newer: jsaddle-dom-0.9.3.1:base-compat" >> cabal.project - echo "allow-newer: jsaddle-dom-0.9.3.1:Cabal" >> cabal.project - echo "allow-newer: jsaddle-dom-0.9.3.1:lens" >> cabal.project - echo "allow-newer: jsaddle-dom-0.9.3.2:base" >> cabal.project - echo "allow-newer: jsaddle-dom-0.9.3.2:base-compat" >> cabal.project - echo "allow-newer: jsaddle-dom-0.9.3.2:Cabal" >> cabal.project - echo "allow-newer: jsaddle-dom-0.9.3.2:lens" >> cabal.project - echo "allow-newer: jsaddle-warp-0.9.6.0:time" >> cabal.project echo "optimization: False" >> cabal.project - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(cookbook-basic-auth|cookbook-basic-streaming|cookbook-curl-mock|cookbook-db-postgres-pool|cookbook-file-upload|cookbook-generic|cookbook-pagination|cookbook-structuring-apis|cookbook-testing|cookbook-using-custom-monad|cookbook-using-free-client|servant|servant-client|servant-client-core|servant-conduit|servant-docs|servant-foreign|servant-http-streams|servant-machines|servant-pipes|servant-server|tutorial)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true diff --git a/cabal.project b/cabal.project index 11c22cb4..4f29900b 100644 --- a/cabal.project +++ b/cabal.project @@ -61,20 +61,6 @@ allow-newer: openssl-streams-1.2.2.0:network -- https://github.com/nurpax/sqlite-simple/issues/74 constraints: sqlite-simple < 0 --- jsaddle -allow-newer: jsaddle-0.9.6.0:lens -allow-newer: jsaddle-0.9.6.0:primitive -allow-newer: jsaddle-0.9.6.0:time -allow-newer: jsaddle-dom-0.9.3.1:base -allow-newer: jsaddle-dom-0.9.3.1:base-compat -allow-newer: jsaddle-dom-0.9.3.1:Cabal -allow-newer: jsaddle-dom-0.9.3.1:lens -allow-newer: jsaddle-dom-0.9.3.2:base -allow-newer: jsaddle-dom-0.9.3.2:base-compat -allow-newer: jsaddle-dom-0.9.3.2:Cabal -allow-newer: jsaddle-dom-0.9.3.2:lens -allow-newer: jsaddle-warp-0.9.6.0:time - constraints: base-compat ^>=0.11 -- needed for doctests diff --git a/servant-jsaddle/CHANGELOG.md b/servant-jsaddle/CHANGELOG.md deleted file mode 100644 index 53231096..00000000 --- a/servant-jsaddle/CHANGELOG.md +++ /dev/null @@ -1,4 +0,0 @@ -X.Y ----- - -Initial release diff --git a/servant-jsaddle/LICENSE b/servant-jsaddle/LICENSE deleted file mode 100644 index 9717a9ce..00000000 --- a/servant-jsaddle/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) 2014-2016, Zalora South East Asia Pte Ltd, Servant Contributors - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Zalora South East Asia Pte Ltd nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/servant-jsaddle/README.md b/servant-jsaddle/README.md deleted file mode 100644 index ada9aeef..00000000 --- a/servant-jsaddle/README.md +++ /dev/null @@ -1,15 +0,0 @@ -# `servant-client-jsaddle` - -This is a an implementation of the `servant-client-core` API on top of `jsaddle`, a framework that lets you write Haskell programs that compile to javascript to run in a browser or compile to native code that connects to a browser. - -It is similar to `servant-client-ghcjs`, except it supports native compilation and native GHCi. It even reuses some of the logic from `servant-client-ghcjs`. - -# Build - -This package comes with a test suite that depends on `jsaddle-webkit2gtk`. You may want to skip that because of the heavy dependency footprint. - - cabal new-build --allow-newer=aeson,http-types --disable-tests - -# Usage - -TBD. Similar to `servant-client` and `servant-client-ghcjs`. diff --git a/servant-jsaddle/Setup.hs b/servant-jsaddle/Setup.hs deleted file mode 100644 index 44671092..00000000 --- a/servant-jsaddle/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/servant-jsaddle/servant-jsaddle.cabal b/servant-jsaddle/servant-jsaddle.cabal deleted file mode 100644 index 4ff54b6d..00000000 --- a/servant-jsaddle/servant-jsaddle.cabal +++ /dev/null @@ -1,125 +0,0 @@ -name: servant-jsaddle -version: 0.16 -synopsis: - automatic derivation of querying functions for servant webservices for jsaddle - -description: - This library lets you automatically derive Haskell functions that - let you query each endpoint of a webservice. - . - See . - . - - -license: BSD3 -license-file: LICENSE -author: Servant Contributors -maintainer: haskell-servant-maintainers@googlegroups.com -copyright: - 2014-2016 Zalora South East Asia Pte Ltd, 2016-2017 Servant Contributors - -category: Servant, Web -build-type: Simple -cabal-version: >=1.10 -tested-with: - GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1 - , GHCJS ==8.4 - -homepage: http://haskell-servant.readthedocs.org/ -bug-reports: http://github.com/haskell-servant/servant/issues -extra-source-files: - CHANGELOG.md - README.md - -source-repository head - type: git - location: http://github.com/haskell-servant/servant.git - -library - default-language: Haskell2010 - hs-source-dirs: src - ghc-options: -Wall - exposed-modules: - Servant.Client.Internal.JSaddleXhrClient - Servant.Client.JSaddle - - -- Bundled with GHC: Lower bound to not force re-installs - -- text and mtl are bundled starting with GHC-8.4 - build-depends: - base >=4.9 && <4.14 - , bytestring >=0.10.8.1 && <0.11 - , containers >=0.5.7.1 && <0.7 - , mtl >=2.2.2 && <2.3 - , text >=1.2.3.0 && <1.3 - , transformers >=0.5.2.0 && <0.6 - - if impl(ghcjs -any) - build-depends: ghcjs-base - - -- Servant dependencies. - -- Strict dependency on `servant-client-core` as we re-export things. - build-depends: servant-client-core >=0.16 && <0.16.1 - build-depends: - base-compat >=0.10.5 && <0.12 - , case-insensitive >=1.2.0.0 && <1.3 - , exceptions >=0.10.0 && <0.11 - , ghcjs-dom >=0.9.4.0 && <0.10 - , http-media >=0.7.1.3 && <0.9 - , http-types >=0.12.2 && <0.13 - , jsaddle >=0.9.6.0 && <0.10 - , monad-control >=1.0.2.3 && <1.1 - , semigroupoids >=5.3.1 && <5.4 - , string-conversions >=0.3 && <0.5 - , transformers-base >=0.4.4 && <0.5 - - if impl(ghc >=8.0) - ghc-options: -Wno-redundant-constraints - -test-suite spec - type: exitcode-stdio-1.0 - ghc-options: -Wall - default-language: Haskell2010 - hs-source-dirs: test - main-is: Spec.hs - - if impl(ghcjs -any) - build-depends: - base - , servant-jsaddle - - else - other-modules: Servant.Client.JSaddleSpec - - -- Dependencies inherited from the library. No need to specify bounds. - build-depends: - base - , bytestring - , containers - , exceptions - , ghcjs-dom - , http-media - , http-types - , jsaddle - , mtl - , process - , semigroupoids - , servant - , servant-client-core - , servant-jsaddle - , servant-server - , string-conversions - , text - , wai - , wai-cors - , wai-extra - , warp - , websockets - - -- Additonal dependencies - build-depends: - aeson - , hspec - , jsaddle-warp - , QuickCheck - - build-tool-depends: hspec-discover:hspec-discover >=2.6.0 && <2.8 diff --git a/servant-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs b/servant-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs deleted file mode 100644 index e219ff2e..00000000 --- a/servant-jsaddle/src/Servant/Client/Internal/JSaddleXhrClient.hs +++ /dev/null @@ -1,311 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - -module Servant.Client.Internal.JSaddleXhrClient where - -import Prelude () -import Prelude.Compat - -import Control.Concurrent - (MVar, newEmptyMVar, takeMVar, tryPutMVar) -import Control.Exception - (Exception, toException) -import Control.Monad - (forM_, unless, void) -import Control.Monad.Catch - (MonadCatch, MonadThrow, catch) -import Control.Monad.Error.Class - (MonadError (..)) -import Control.Monad.IO.Class - (MonadIO (..)) -import Control.Monad.Reader - (MonadReader, ReaderT, asks, runReaderT) -import Control.Monad.Trans.Except - (ExceptT, runExceptT) -import Data.Bifunctor - (bimap, first, second) -import Data.ByteString.Builder - (toLazyByteString) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as BSL -import qualified Data.ByteString.Lazy as L -import Data.CaseInsensitive - (mk, original) -import Data.Char - (isSpace) -import Data.Foldable - (toList) -import Data.Functor.Alt - (Alt (..)) -import Data.Proxy - (Proxy (..)) -import qualified Data.Sequence as Seq -import Data.String.Conversions - (cs) -import qualified Data.Text.Encoding as T -import qualified Data.Text.Encoding.Error as T -import GHC.Generics -import qualified GHCJS.Buffer as Buffer -import qualified GHCJS.DOM -import qualified GHCJS.DOM.EventM as JSDOM -import qualified GHCJS.DOM.Location as Location -import GHCJS.DOM.Types - (DOM, DOMContext, askDOM, runDOM) -import qualified GHCJS.DOM.Types as JS -import qualified GHCJS.DOM.Window as Window -import qualified GHCJS.DOM.XMLHttpRequest as JS -import qualified JavaScript.TypedArray.ArrayBuffer as ArrayBuffer -import qualified Language.Javascript.JSaddle.Types as JSaddle -import Network.HTTP.Media - (renderHeader) -import Network.HTTP.Types - (ResponseHeaders, http11, mkStatus, renderQuery, statusCode) -import System.IO - (hPutStrLn, stderr) - -import Servant.Client.Core - --- Note: assuming encoding UTF-8 - -data ClientEnv - = ClientEnv - { baseUrl :: BaseUrl - -- | Modify the XMLHttpRequest at will, right before sending. - , fixUpXhr :: JS.XMLHttpRequest -> DOM () - } - -data JSaddleConnectionError = JSaddleConnectionError - deriving (Eq, Show) - -instance Exception JSaddleConnectionError - --- | Default 'ClientEnv' -mkClientEnv :: BaseUrl -> ClientEnv -mkClientEnv burl = ClientEnv burl (const (pure ())) - -instance Show ClientEnv where - showsPrec prec (ClientEnv burl _) = - showParen (prec >= 11) - ( showString "ClientEnv {" - . showString "baseUrl = " - . showsPrec 0 burl - . showString ", fixUpXhr = " - . showString "}" - ) - -client :: HasClient ClientM api => Proxy api -> Client ClientM api -client api = api `clientIn` (Proxy :: Proxy ClientM) - -newtype ClientM a = ClientM - { fromClientM :: ReaderT ClientEnv (ExceptT ClientError DOM) a } - deriving ( Functor, Applicative, Monad, MonadIO, Generic - , MonadReader ClientEnv, MonadError ClientError) -deriving instance MonadThrow DOM => MonadThrow ClientM -deriving instance MonadCatch DOM => MonadCatch ClientM - --- | Try clients in order, last error is preserved. -instance Alt ClientM where - a b = a `catchError` const b - -instance RunClient ClientM where - throwClientError = throwError - runRequest r = do - d <- ClientM askDOM - performRequest d r - -runClientM :: ClientM a -> ClientEnv -> DOM (Either ClientError a) -runClientM cm env = runExceptT $ flip runReaderT env $ fromClientM cm - -runClientM' :: ClientM a -> DOM (Either ClientError a) -runClientM' m = do - burl <- getDefaultBaseUrl - runClientM m (mkClientEnv burl) - -getDefaultBaseUrl :: DOM BaseUrl -getDefaultBaseUrl = do - win <- GHCJS.DOM.currentWindow >>= \mw -> case mw of - Just x -> pure x - Nothing -> fail "Can not determine default base url without window." - curLoc <- Window.getLocation win - - protocolStr <- Location.getProtocol curLoc - portStr <- Location.getPort curLoc - hostname <- Location.getHostname curLoc - - let protocol - | (protocolStr :: JS.JSString) == "https:" - = Https - | otherwise = Http - - port :: Int - port | null portStr = case protocol of - Http -> 80 - Https -> 443 - | otherwise = read portStr - - pure (BaseUrl protocol hostname port "") - -performRequest :: DOMContext -> Request -> ClientM Response -performRequest domc req = do - xhr <- JS.newXMLHttpRequest `runDOM` domc - burl <- asks baseUrl - fixUp <- asks fixUpXhr - performXhr xhr burl req fixUp `runDOM` domc - resp <- toResponse domc xhr - - let status = statusCode (responseStatusCode resp) - unless (status >= 200 && status < 300) $ - throwError $ mkFailureResponse burl req resp - - pure resp - - --- * performing requests --- Performs the xhr and blocks until the response was received -performXhr :: JS.XMLHttpRequest -> BaseUrl -> Request -> (JS.XMLHttpRequest -> DOM ()) -> DOM () -performXhr xhr burl request fixUp = do - - let username, password :: Maybe JS.JSString - username = Nothing; password = Nothing - - JS.open xhr (decodeUtf8Lenient $ requestMethod request) (toUrl burl request) True username password - setHeaders xhr request - fixUp xhr - - waiter <- liftIO $ newEmptyMVar - - cleanup <- JSDOM.on xhr JS.readyStateChange $ do - state <- JS.getReadyState xhr - case state of - -- onReadyStateChange's callback can fire state 4 - -- (which means "request finished and response is ready") - -- multiple times. By using tryPutMVar, only the first time - -- state 4 is fired will cause an MVar to be put. Subsequent - -- fires are ignored. - 4 -> void $ liftIO $ tryPutMVar waiter () - _ -> return () - - sendXhr xhr (toBody request) `catch` handleXHRError waiter -- We handle any errors in `toResponse`. - - liftIO $ takeMVar waiter - - cleanup - - where - - handleXHRError :: MVar () -> JS.XHRError -> DOM () - handleXHRError waiter e = do - liftIO $ hPutStrLn stderr $ "servant-client-jsaddle: exception in `sendXhr` (should get handled in response handling): " <> show e - void $ liftIO $ tryPutMVar waiter () - - -toUrl :: BaseUrl -> Request -> JS.JSString -toUrl burl request = - let pathS = JS.toJSString $ decodeUtf8Lenient $ L.toStrict $ toLazyByteString $ - requestPath request - queryS = - JS.toJSString $ decodeUtf8Lenient $ - renderQuery True $ - toList $ - requestQueryString request - in JS.toJSString (showBaseUrl burl) <> pathS <> queryS :: JS.JSString - -setHeaders :: JS.XMLHttpRequest -> Request -> DOM () -setHeaders xhr request = do - forM_ (toList $ requestAccept request) $ \mediaType -> -- FIXME review - JS.setRequestHeader - xhr - ("Accept" :: JS.JSString) - (decodeUtf8Lenient $ renderHeader mediaType) - - forM_ (requestBody request) $ \(_, mediaType) -> - JS.setRequestHeader - xhr - ("Content-Type" :: JS.JSString) - (decodeUtf8Lenient $ renderHeader mediaType) - - forM_ (toList $ requestHeaders request) $ \(key, value) -> - JS.setRequestHeader xhr (decodeUtf8Lenient $ original key) (decodeUtf8Lenient value) - --- ArrayBufferView is a type that only exists in the spec and covers many concrete types. -castMutableArrayBufferToArrayBufferView :: ArrayBuffer.MutableArrayBuffer -> DOM JS.ArrayBufferView -castMutableArrayBufferToArrayBufferView x = JS.liftJSM $ do - JS.fromJSValUnchecked $ JS.pToJSVal x - -mkFailureResponse :: BaseUrl -> Request -> ResponseF BSL.ByteString -> ClientError -mkFailureResponse burl request = - FailureResponse (bimap (const ()) f request) - where - f b = (burl, BSL.toStrict $ toLazyByteString b) - -sendXhr :: JS.XMLHttpRequest -> Maybe L.ByteString -> DOM () -sendXhr xhr Nothing = JS.send xhr -sendXhr xhr (Just body) = do - -- Reason for copy: hopefully offset will be 0 and length b == len - -- FIXME: use a typed array constructor that accepts offset and length and skip the copy - (b, _offset, _len) <- JSaddle.ghcjsPure $ Buffer.fromByteString $ BS.copy $ L.toStrict body - b' <- Buffer.thaw b - b'' <- JSaddle.ghcjsPure $ Buffer.getArrayBuffer b' - JS.sendArrayBuffer xhr =<< castMutableArrayBufferToArrayBufferView b'' - -toBody :: Request -> Maybe L.ByteString -toBody request = case requestBody request of - Nothing -> Nothing - Just (RequestBodyLBS "", _) -> Nothing - Just (RequestBodyLBS x, _) -> Just x - Just (RequestBodyBS "", _) -> Nothing - Just (RequestBodyBS x, _) -> Just $ L.fromStrict x - Just (RequestBodySource _, _) -> error "RequestBodySource isn't supported" - --- * inspecting the xhr response - --- This function is only supposed to handle 'ConnectionError's. Other --- 'ClientError's are created in Servant.Client.Req. -toResponse :: DOMContext -> JS.XMLHttpRequest -> ClientM Response -toResponse domc xhr = do - let inDom :: DOM a -> ClientM a - inDom = flip runDOM domc - status <- inDom $ JS.getStatus xhr - case status of - 0 -> throwError $ ConnectionError $ toException JSaddleConnectionError - _ -> inDom $ do - statusText <- BS.pack <$> JS.getStatusText xhr - headers <- parseHeaders <$> JS.getAllResponseHeaders xhr - responseText <- maybe "" (L.fromStrict . BS.pack) <$> JS.getResponseText xhr -- FIXME: Text/Binary? Performance? Test? - pure Response - { responseStatusCode = mkStatus (fromIntegral status) statusText - , responseBody = responseText - , responseHeaders = Seq.fromList headers - , responseHttpVersion = http11 -- this is made up - } - -parseHeaders :: String -> ResponseHeaders -parseHeaders s = - (first mk . first strip . second strip . parseHeader) <$> - splitOn "\r\n" (cs s) - where - parseHeader :: BS.ByteString -> (BS.ByteString, BS.ByteString) - parseHeader h = case BS.breakSubstring ":" (cs h) of - (key, BS.drop 1 -> value) -> (key, value) - - splitOn :: BS.ByteString -> BS.ByteString -> [BS.ByteString] - splitOn separator input = case BS.breakSubstring separator input of - (prefix, "") -> [prefix] - (prefix, rest) -> prefix : splitOn separator (BS.drop (BS.length separator) rest) - - strip :: BS.ByteString -> BS.ByteString - strip = BS.dropWhile isSpace . BS.reverse . BS.dropWhile isSpace . BS.reverse - -decodeUtf8Lenient :: BS.ByteString -> JS.JSString -decodeUtf8Lenient = JS.toJSString . T.decodeUtf8With T.lenientDecode diff --git a/servant-jsaddle/src/Servant/Client/JSaddle.hs b/servant-jsaddle/src/Servant/Client/JSaddle.hs deleted file mode 100644 index f3a65ce1..00000000 --- a/servant-jsaddle/src/Servant/Client/JSaddle.hs +++ /dev/null @@ -1,20 +0,0 @@ --- | This module provides 'client' which can automatically generate --- querying functions for each endpoint just from the type representing your --- API. -module Servant.Client.JSaddle - ( - client - , ClientM - , runClientM - , runClientM' - - -- * Configuration - , ClientEnv(..) - , mkClientEnv - , getDefaultBaseUrl - - , module Servant.Client.Core.Reexport - ) where - -import Servant.Client.Internal.JSaddleXhrClient -import Servant.Client.Core.Reexport diff --git a/servant-jsaddle/test/Servant/Client/JSaddleSpec.hs b/servant-jsaddle/test/Servant/Client/JSaddleSpec.hs deleted file mode 100644 index 55c29fbf..00000000 --- a/servant-jsaddle/test/Servant/Client/JSaddleSpec.hs +++ /dev/null @@ -1,173 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -module Servant.Client.JSaddleSpec where - -import Control.Concurrent - (threadDelay) -import Control.Concurrent.MVar - (newEmptyMVar, putMVar, takeMVar) -import Control.Exception - (handle, throwIO) -import Control.Monad.Trans -import Data.Aeson -import Data.ByteString - (ByteString) -import qualified Data.ByteString as B -import Data.Proxy -import Data.String -import Data.Word -import GHC.Generics -import qualified GHCJS.DOM -import qualified GHCJS.DOM.Window as Window -import Language.Javascript.JSaddle.Monad - (JSM) -import qualified Language.Javascript.JSaddle.Monad as JSaddle -import qualified Language.Javascript.JSaddle.Run as Run -import qualified Language.Javascript.JSaddle.WebSockets as WS -import qualified Network.HTTP.Types as Http -import qualified Network.Wai as Wai -import Network.Wai.Handler.Warp as Warp -import Network.Wai.Middleware.AddHeaders -import Network.Wai.Middleware.Cors - (simpleCors) -import Network.WebSockets - (defaultConnectionOptions) -import qualified Network.WebSockets as WS -import Servant.API -import Servant.Client.JSaddle -import Servant.Server -import qualified System.Process as P -import Test.Hspec - -type TestApi = ReqBody '[OctetStream] ByteString :> Post '[JSON] TestResponse -testApi :: Proxy TestApi -testApi = Proxy - -data TestResponse = TestResponse { byteList :: [Word8] } - deriving (Generic, ToJSON, FromJSON, Show, Eq) - -testServer :: Server TestApi -testServer x = do - pure . TestResponse . B.unpack $ x - -testClient :: Client ClientM TestApi -testClient = client testApi - --- WARNING: approximation! -jsaddleFinally :: JSM b -> JSM a -> JSM a -jsaddleFinally handler m = JSaddle.bracket (pure ()) (const handler) (const m) --- jsaddleFinally handler m = JSaddle.catch (m <* handler) (\e -> handler >> throw (e :: SomeException)) - -close :: JSM () -close = do - mw <- GHCJS.DOM.currentWindow - case mw of - Just w -> do - liftIO $ putStrLn "Closing window..." - Window.close w - Nothing -> liftIO $ putStrLn "Can't close the window!" - - - -spec :: Spec -spec = do - describe "Servant.Client.JSaddle" $ do - it "Receive a properly encoded response" $ do - -- A mvar to tell promptly when we are done - done <- newEmptyMVar - - -- How this work: - -- - -- 1. we start server warp, which serves simple API - -- 2. we start client warp, which serves jsaddle running the 'action' - -- 3. we run google-chrome-stable to open jsaddle page and to run the test - - let action :: Int -> JSM () - action serverPort = do - liftIO $ threadDelay $ 500 * 1000 - -- a mix of valid utf-8 and non-utf8 bytes - let bytes = [0x01, 0xff, 0x02, 0xfe, 0x03, 0xfd, 0x00, 0x64, 0xc3, 0xbb, 0x68, 0xc3] - response <- flip runClientM clientEnv $ testClient (B.pack bytes) - liftIO $ print response - liftIO $ response `shouldBe` Right (TestResponse bytes) - - -- we are done. - liftIO $ putMVar done () - where - clientEnv = mkClientEnv BaseUrl - { baseUrlScheme = Http - , baseUrlHost = "localhost" - , baseUrlPort = fromIntegral serverPort - , baseUrlPath = "/" - } - - let serverApp :: IO Application - serverApp = pure $ logRequest $ addCors $ serve testApi testServer - - let handler :: WS.ConnectionException -> IO () - handler WS.ConnectionClosed = return () - handler e = throwIO e - - handle handler $ Warp.testWithApplication serverApp $ \serverPort -> do - threadDelay $ 500 * 1000 - - let clientApp :: IO Application - clientApp = WS.jsaddleOr defaultConnectionOptions (action serverPort >> Run.syncPoint) WS.jsaddleApp - - Warp.testWithApplication (simpleCors <$> clientApp) $ \clientPort -> do - threadDelay $ 500 * 1000 - - putStrLn $ "server http://localhost:" ++ show serverPort - putStrLn $ "client http://localhost:" ++ show clientPort - putStrLn $ "google-chrome-stable --headless --disable-gpu --screenshot http://localhost:" ++ show clientPort - - - -- Run headless chrome - -- https://docs.travis-ci.com/user/gui-and-headless-browsers/#using-the-chrome-addon-in-the-headless-mode - -- https://developers.google.com/web/updates/2017/04/headless-chrome - hdl <- P.spawnProcess "google-chrome-stable" - [ "--headless" - , "--disable-gpu" - , "--remote-debugging-port=9222" -- TODO: bind to random port - , "http://localhost:" ++ show clientPort - ] - - -- wait for test to run. - takeMVar done - - -- kill chrome - P.terminateProcess hdl - -------------------------------------------------------------------------------- --- Logger middleware -------------------------------------------------------------------------------- - -logRequest :: Wai.Middleware -logRequest app request respond = do - putStrLn "Request" - print request - app request $ \response -> do - putStrLn "Response Headers" - mapM_ print (Wai.responseHeaders response) - respond response - -------------------------------------------------------------------------------- --- OPTIONS -------------------------------------------------------------------------------- - -corsHeaders :: (IsString s1, IsString s2) => [(s1, s2)] -corsHeaders = - [ ("Access-Control-Allow-Origin", "*") - , ("Access-Control-Allow-Methods", "POST") - , ("Access-Control-Allow-Headers", "content-type") - ] - -addCors :: Wai.Middleware -addCors app request respond = - if Wai.requestMethod request == "OPTIONS" - then respond $ Wai.responseLBS Http.status200 corsHeaders "" - else addHeaders corsHeaders app request respond diff --git a/servant-jsaddle/test/Spec.hs b/servant-jsaddle/test/Spec.hs deleted file mode 100644 index 394ef87e..00000000 --- a/servant-jsaddle/test/Spec.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE CPP #-} -#ifdef __GHCJS__ -module Main (main) where -main :: IO () -main = return () -#else -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} -#endif