git.iko.soy/servant-quickcheck
on master help sign in
More predicates, blog post
commit530fdba5c0b117d24ee75e03c2f7ea0ced905e2e authorJulian K. Arni <jkarni@gmail.com> dateSun 1 May 2016, 14:29 (10 years ago) parent64c845c
15 files changed+626−47
compare with master
unifiedsplit
doc/doc.cabal+36−18 doc/posts/Announcement.anansi+167 doc/posts/LICENSE+30 doc/posts/Makefile+22 doc/posts/Setup.hs+2 doc/posts/announcement.md+118 doc/posts/posts.cabal+47 doc/posts/src/Main.hs+71 doc/posts/src/Spec.hs+34 doc/posts/src/schema.sql+9 doc/posts/stack.yaml+46 servant-quickcheck.cabal+1−1 src/Servant/QuickCheck.hs+1 src/Servant/QuickCheck/Internal/Predicates.hs+41−28 stack.yaml+1
doc/doc.cabal+36−18
@@ -7,24 +7,39 @@ maintainer: jkarni@gmail.com
77build-type: Simple
88cabal-version: >=1.10
99
10−library
11− exposed-modules: ServersEqual
12− other-extensions: DataKinds, TypeOperators
13− build-depends: base >=4.8 && <4.9
14− , servant-server == 0.7.*
15− , servant-quickcheck
16− , servant-client
17− , QuickCheck
18− , stm
19− , containers
20− , transformers
21− , warp
22− , aeson
23− ghc-options: -Wall -Werror -pgmL markdown-unlit
24− default-language: Haskell2010
10+-- library
11+-- exposed-modules: ServersEqual
12+-- other-extensions: DataKinds, TypeOperators
13+-- build-depends: base >=4.8 && <4.9
14+-- , servant-server == 0.7.*
15+-- , servant-quickcheck
16+-- , servant-client
17+-- , QuickCheck
18+-- , stm
19+-- , containers
20+-- , transformers
21+-- , warp
22+-- , aeson
23+-- ghc-options: -Wall -Werror -pgmL markdown-unlit
24+-- default-language: Haskell2010
25+--
26+-- executable doc
27+-- main-is: Main.hs
28+-- build-depends: base >=4.8 && <4.9
29+-- , servant-server == 0.7.*
30+-- , servant-quickcheck
31+-- , servant-client
32+-- , QuickCheck
33+-- , stm
34+-- , containers
35+-- , transformers
36+-- , warp
37+-- , aeson
38+-- default-language: Haskell2010
39+-- ghc-options: -Wall -Werror -pgmL markdown-unlit
2540
26−executable doc
27− main-is: Main.hs
41+executable announcement
42+ main-is: Announcement.lhs
2843 build-depends: base >=4.8 && <4.9
2944 , servant-server == 0.7.*
3045 , servant-quickcheck
@@ -35,5 +50,8 @@ executable doc
3550 , transformers
3651 , warp
3752 , aeson
53+ , hspec
54+ , postgresql-simple
55+ , text
3856 default-language: Haskell2010
39− ghc-options: -Wall -Werror -pgmL markdown-unlit
57+ ghc-options: -Wall
doc/posts/Announcement.anansinew file+167
@@ -0,0 +1,167 @@
1+:loom anansi.markdown
2+
3+# Announcing servant-quickcheck
4+
5+Some time ago, we released `servant-mock`. The idea behind it is to use
6+`QuickCheck` to create a mock server that accords with a servant API. Not long
7+after, we started thinking about an analog that would, instead of mocking a
8+server, mock a client instead - i.e., generate random requests that conform to
9+an API description.
10+
11+This is much closer to the traditional use of `QuickCheck`. The most obvious
12+use-case is checking that properties hold of an *entire* server rather than of
13+individual endpoints.
14+
15+## `serverSatisfies`
16+
17+There are a variety of best practices in writing web APIs that aren't always
18+obvious. As a running example, let's use a simple service that allows adding,
19+removing, and querying biological species. Our SQL schema is:
20+
21+:d schema.sql
22+
23+CREATE TABLE genus (
24+ genus_name text PRIMARY KEY,
25+ genus_family text NOT NULL
26+);
27+
28+CREATE TABLE species (
29+ species_name text PRIMARY KEY,
30+ species_genus text NOT NULL REFERENCES genus (genus_name)
31+)
32+:
33+
34+And our actual application:
35+
36+:d Main.hs
37+{-# LANGUAGE DataKinds #-}
38+{-# LANGUAGE DeriveAnyClass #-}
39+{-# LANGUAGE DeriveGeneric #-}
40+{-# LANGUAGE TypeOperators #-}
41+{-# LANGUAGE OverloadedStrings #-}
42+{-# LANGUAGE RecordWildCards #-}
43+module Main where
44+
45+import Servant
46+import Data.Aeson
47+import Database.PostgreSQL.Simple
48+import GHC.Generics (Generic)
49+import Data.Text (Text)
50+import Network.Wai.Handler.Warp
51+import Control.Monad.IO.Class (liftIO)
52+
53+type API
54+ = "species" :> (Capture "species-name" Text :> ( Get '[JSON] Species
55+ :<|> Delete '[JSON] ())
56+ :<|> ReqBody '[JSON] Species :> Post '[JSON] ())
57+ -- The plural of 'species' is unfortunately also 'species'
58+ :<|> "speciess" :> Get '[JSON] [Species]
59+
60+api :: Proxy API
61+api = Proxy
62+
63+data Species = Species
64+ { speciesName :: Text
65+ , speciesGenus :: Text
66+ } deriving (Eq, Show, Read, Generic, ToJSON, FromJSON)
67+
68+data Genus = Genus
69+ { genusName :: Text
70+ , genusFamily :: Text
71+ } deriving (Eq, Show, Read, Generic, ToJSON, FromJSON)
72+
73+instance FromRow Genus
74+instance FromRow Species
75+
76+server :: Connection -> Server API
77+server conn = ((\sname -> liftIO (lookupSpecies conn sname)
78+ :<|> liftIO (deleteSpecies conn sname))
79+ :<|> (\species -> liftIO $ insertSpecies conn species))
80+ :<|> (liftIO $ allSpecies conn)
81+
82+lookupSpecies :: Connection -> Text -> IO Species
83+lookupSpecies conn name = do
84+ [s] <- query conn "SELECT * FROM species WHERE species_name = ?" (Only name)
85+ return s
86+
87+deleteSpecies :: Connection -> Text -> IO ()
88+deleteSpecies conn name = do
89+ _ <- execute conn "DELETE FROM species WHERE species_name = ?" (Only name)
90+ return ()
91+
92+insertSpecies :: Connection -> Species -> IO ()
93+insertSpecies conn Species{..} = do
94+ _ <- execute conn "INSERT INTO species (species_name, species_genus) VALUES (?)" (speciesName, speciesGenus)
95+ return ()
96+
97+allSpecies :: Connection -> IO [Species]
98+allSpecies conn = do
99+ query_ conn "SELECT * FROM species"
100+
101+main :: IO ()
102+main = do
103+ conn <- connectPostgreSQL "dbname=servant-quickcheck"
104+ run 8090 (serve api $ server conn)
105+:
106+
107+(You'll also also need to run:
108+
109+```
110+createdb servant-quickcheck
111+psql --file schema.sql -d servant-quickcheck
112+```
113+
114+If you want to run this example.)
115+
116+This is a plausible effort. You might want to spend a moment thinking about what
117+could be improved.
118+
119+:d Spec.hs
120+
121+{-# LANGUAGE OverloadedStrings #-}
122+module Spec (main) where
123+
124+import Main (server, api, Species(..))
125+import Test.Hspec
126+import Test.QuickCheck.Instances
127+import Servant.QuickCheck
128+import Test.QuickCheck (Arbitrary(..))
129+import Database.PostgreSQL.Simple (connectPostgreSQL)
130+
131+spec :: Spec
132+spec = describe "the species application" $ do
133+ let pserver = do
134+ conn <- connectPostgreSQL "dbname=servant-quickcheck"
135+ return $ server conn
136+
137+ it "should not return 500s" $ do
138+ withServantServer api pserver $ \url ->
139+ serverSatisfies api url defaultArgs (not500 <%> mempty)
140+
141+ it "should not return top-level json" $ do
142+ withServantServer api pserver $ \url ->
143+ serverSatisfies api url defaultArgs (onlyJsonObjects <%> mempty)
144+
145+main :: IO ()
146+main = do
147+ hspec spec
148+
149+instance Arbitrary Species where
150+ arbitrary = Species <$> arbitrary <*> arbitrary
151+:
152+
153+
154+**Note**: This post is an anansi literate file that generates multiple source
155+files. They are:
156+
157+:f Main.hs
158+|Main.hs|
159+:
160+
161+:f schema.sql
162+|schema.sql|
163+:
164+
165+:f Spec.hs
166+|Spec.hs|
167+:
doc/posts/LICENSEnew file+30
@@ -0,0 +1,30 @@
1+Copyright (c) 2016, Julian K. Arni
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
11+ * Redistributions in binary form must reproduce the above
12+ copyright notice, this list of conditions and the following
13+ disclaimer in the documentation and/or other materials provided
14+ with the distribution.
15+
16+ * Neither the name of Julian K. Arni nor the names of other
17+ contributors may be used to endorse or promote products derived
18+ from this software without specific prior written permission.
19+
20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
doc/posts/Makefilenew file+22
@@ -0,0 +1,22 @@
1+FILES = src/Main.hs src/Spec.hs src/schema.sql
2+
3+src/$(FILES): Announcement.anansi
4+ anansi tangle -o "src" Announcement.anansi
5+
6+announcement.md: Announcement.anansi
7+ anansi weave -o "announcement.md" Announcement.anansi
8+
9+.stack-work/bin/posts: $(FILES) stack.yaml posts.cabal
10+ stack build
11+
12+
13+
14+run: .stack-work/bin/posts
15+ stack exec posts
16+
17+test: .stack-work/bin/posts
18+ stack test
19+
20+post: announcement.md
21+
22+.PHONY: post run test
doc/posts/Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
doc/posts/announcement.mdnew file+118
@@ -0,0 +1,118 @@
1+
2+# Announcing servant-quickcheck
3+
4+Some time ago, we released `servant-mock`. The idea behind it is to use
5+`QuickCheck` to create a mock server that accords with a servant API. Not long
6+after, we started thinking about an analog that would, instead of mocking a
7+server, mock a client instead - i.e., generate random requests that conform to
8+an API description.
9+
10+This is much closer to the traditional use of `QuickCheck`. The most obvious
11+use-case is checking that properties hold of an *entire* server rather than of
12+individual endpoints.
13+
14+## `serverSatisfies`
15+
16+There are a variety of best practices in writing web APIs that aren't always
17+obvious. As a running example, let's use a simple service that allows adding,
18+removing, and querying biological species. Our SQL schema is:
19+
20+
21+> **«schema.sql»**
22+
23+>
24+> CREATE TABLE genus (
25+> genus_name text PRIMARY KEY,
26+> genus_family text NOT NULL
27+> )
28+>
29+> CREATE TABLE species (
30+> species_name text PRIMARY KEY,
31+> species_genus text NOT NULL REFERENCES genus (genus_name)
32+> )
33+
34+
35+And our actual application:
36+
37+
38+> **«Main.hs»**
39+
40+> {-# LANGUAGE DataKinds #-}
41+> {-# LANGUAGE DeriveAnyClass #-}
42+> {-# LANGUAGE DeriveGeneric #-}
43+> {-# LANGUAGE TypeOperators #-}
44+> {-# LANGUAGE OverloadedStrings #-}
45+> {-# LANGUAGE RecordWildCards #-}
46+> import Servant
47+> import Data.Aeson
48+> import Database.PostgreSQL.Simple
49+> import GHC.Generics (Generic)
50+> import Data.Text (Text)
51+> import Network.Wai.Handler.Warp
52+> import Control.Monad.IO.Class (liftIO)
53+>
54+> type API
55+> = "species" :> (Capture "species-name" Text :> ( Get '[JSON] Species
56+> :<|> Delete '[JSON] ())
57+> :<|> ReqBody '[JSON] Species :> Post '[JSON] ()
58+> :<|> "count" :> Get '[JSON] Int)
59+>
60+> api :: Proxy API
61+> api = Proxy
62+>
63+> data Species = Species
64+> { speciesName :: Text
65+> , speciesGenus :: Text
66+> } deriving (Eq, Show, Read, Generic, ToJSON, FromJSON)
67+>
68+> data Genus = Genus
69+> { genusName :: Text
70+> , genusFamily :: Text
71+> } deriving (Eq, Show, Read, Generic, ToJSON, FromJSON)
72+>
73+> instance FromRow Genus
74+> instance FromRow Species
75+>
76+> server :: Connection -> Server API
77+> server conn = (\sname -> liftIO (lookupSpecies conn sname)
78+> :<|> liftIO (deleteSpecies conn sname))
79+> :<|> (\species -> liftIO $ insertSpecies conn species)
80+> :<|> (liftIO $ countSpecies conn)
81+>
82+> lookupSpecies :: Connection -> Text -> IO Species
83+> lookupSpecies conn name = do
84+> [s] <- query conn "SELECT * FROM species WHERE species_name == ?" (Only name)
85+> return s
86+>
87+> deleteSpecies :: Connection -> Text -> IO ()
88+> deleteSpecies conn name = do
89+> _ <- execute conn "DELETE FROM species WHERE species_name == ?" (Only name)
90+> return ()
91+>
92+> insertSpecies :: Connection -> Species -> IO ()
93+> insertSpecies conn Species{..} = do
94+> _ <- execute conn "INSERT INTO species (species_name, species_genus) VALUES (?)" (speciesName, speciesGenus)
95+> return ()
96+>
97+> countSpecies :: Connection -> IO Int
98+> countSpecies conn = do
99+> [Only count] <- query_ conn "SELECT count(*) FROM species"
100+> return count
101+>
102+> main :: IO ()
103+> main = do
104+> conn <- connectPostgreSQL ""
105+> run 8090 (serve api $ server conn)
106+
107+
108+
109+> **» Main.hs**
110+
111+> «Main.hs»
112+
113+
114+
115+> **» schema.sql**
116+
117+> «schema.sql»
118+
doc/posts/posts.cabalnew file+47
@@ -0,0 +1,47 @@
1+-- Initial posts.cabal generated by cabal init. For further documentation,
2+-- see http://haskell.org/cabal/users-guide/
3+
4+name: posts
5+version: 0.1.0.0
6+-- synopsis:
7+-- description:
8+license: BSD3
9+license-file: LICENSE
10+author: Julian K. Arni
11+maintainer: jkarni@gmail.com
12+-- copyright:
13+-- category:
14+build-type: Simple
15+-- extra-source-files:
16+cabal-version: >=1.10
17+
18+executable posts
19+ main-is: Main.hs
20+ build-depends: base >=4.8 && <4.9
21+ , servant-server >=0.5 && <0.8
22+ , aeson >=0.9 && <0.12
23+ , text == 1.*
24+ , warp >=3.0 && <3.3
25+ , transformers >=0.4 && <0.5
26+ , postgresql-simple
27+ hs-source-dirs: src
28+ ghc-options: -Wall -O2 -threaded
29+ default-language: Haskell2010
30+
31+test-suite spec
32+ type: exitcode-stdio-1.0
33+ ghc-options: -Wall -O2 -threaded
34+ default-language: Haskell2010
35+ hs-source-dirs: src
36+ main-is: Spec.hs
37+ build-depends: base == 4.*
38+ , servant-quickcheck
39+ , hspec == 2.*
40+ , servant-server >=0.5 && <0.8
41+ , aeson >=0.9 && <0.12
42+ , text == 1.*
43+ , warp >=3.0 && <3.3
44+ , transformers >=0.4 && <0.5
45+ , postgresql-simple
46+ , quickcheck-instances
47+ , QuickCheck
doc/posts/src/Main.hsnew file+71
@@ -0,0 +1,71 @@
1+#line 158 "Announcement.anansi"
2+
3+#line 37 "Announcement.anansi"
4+{-# LANGUAGE DataKinds #-}
5+{-# LANGUAGE DeriveAnyClass #-}
6+{-# LANGUAGE DeriveGeneric #-}
7+{-# LANGUAGE TypeOperators #-}
8+{-# LANGUAGE OverloadedStrings #-}
9+{-# LANGUAGE RecordWildCards #-}
10+module Main where
11+
12+import Servant
13+import Data.Aeson
14+import Database.PostgreSQL.Simple
15+import GHC.Generics (Generic)
16+import Data.Text (Text)
17+import Network.Wai.Handler.Warp
18+import Control.Monad.IO.Class (liftIO)
19+
20+type API
21+ = "species" :> (Capture "species-name" Text :> ( Get '[JSON] Species
22+ :<|> Delete '[JSON] ())
23+ :<|> ReqBody '[JSON] Species :> Post '[JSON] ())
24+ -- The plural of 'species' is unfortunately also 'species'
25+ :<|> "speciess" :> Get '[JSON] [Species]
26+
27+api :: Proxy API
28+api = Proxy
29+
30+data Species = Species
31+ { speciesName :: Text
32+ , speciesGenus :: Text
33+ } deriving (Eq, Show, Read, Generic, ToJSON, FromJSON)
34+
35+data Genus = Genus
36+ { genusName :: Text
37+ , genusFamily :: Text
38+ } deriving (Eq, Show, Read, Generic, ToJSON, FromJSON)
39+
40+instance FromRow Genus
41+instance FromRow Species
42+
43+server :: Connection -> Server API
44+server conn = ((\sname -> liftIO (lookupSpecies conn sname)
45+ :<|> liftIO (deleteSpecies conn sname))
46+ :<|> (\species -> liftIO $ insertSpecies conn species))
47+ :<|> (liftIO $ allSpecies conn)
48+
49+lookupSpecies :: Connection -> Text -> IO Species
50+lookupSpecies conn name = do
51+ [s] <- query conn "SELECT * FROM species WHERE species_name = ?" (Only name)
52+ return s
53+
54+deleteSpecies :: Connection -> Text -> IO ()
55+deleteSpecies conn name = do
56+ _ <- execute conn "DELETE FROM species WHERE species_name = ?" (Only name)
57+ return ()
58+
59+insertSpecies :: Connection -> Species -> IO ()
60+insertSpecies conn Species{..} = do
61+ _ <- execute conn "INSERT INTO species (species_name, species_genus) VALUES (?)" (speciesName, speciesGenus)
62+ return ()
63+
64+allSpecies :: Connection -> IO [Species]
65+allSpecies conn = do
66+ query_ conn "SELECT * FROM species"
67+
68+main :: IO ()
69+main = do
70+ conn <- connectPostgreSQL "dbname=servant-quickcheck"
71+ run 8090 (serve api $ server conn)
doc/posts/src/Spec.hsnew file+34
@@ -0,0 +1,34 @@
1+#line 166 "Announcement.anansi"
2+
3+#line 120 "Announcement.anansi"
4+
5+{-# LANGUAGE OverloadedStrings #-}
6+module Spec (main) where
7+
8+import Main (server, api, Species(..))
9+import Test.Hspec
10+import Test.QuickCheck.Instances
11+import Servant.QuickCheck
12+import Test.QuickCheck (Arbitrary(..))
13+import Database.PostgreSQL.Simple (connectPostgreSQL)
14+
15+spec :: Spec
16+spec = describe "the species application" $ do
17+ let pserver = do
18+ conn <- connectPostgreSQL "dbname=servant-quickcheck"
19+ return $ server conn
20+
21+ it "should not return 500s" $ do
22+ withServantServer api pserver $ \url ->
23+ serverSatisfies api url defaultArgs (not500 <%> mempty)
24+
25+ it "should not return top-level json" $ do
26+ withServantServer api pserver $ \url ->
27+ serverSatisfies api url defaultArgs (onlyJsonObjects <%> mempty)
28+
29+main :: IO ()
30+main = do
31+ hspec spec
32+
33+instance Arbitrary Species where
34+ arbitrary = Species <$> arbitrary <*> arbitrary
doc/posts/src/schema.sqlnew file+9
@@ -0,0 +1,9 @@
1+CREATE TABLE genus (
2+ genus_name text PRIMARY KEY,
3+ genus_family text NOT NULL
4+);
5+
6+CREATE TABLE species (
7+ species_name text PRIMARY KEY,
8+ species_genus text NOT NULL REFERENCES genus (genus_name)
9+)
doc/posts/stack.yamlnew file+46
@@ -0,0 +1,46 @@
1+# This file was automatically generated by stack init
2+# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/
3+
4+
5+# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
6+resolver: lts-5.14
7+
8+# Local packages, usually specified by relative directory name
9+packages:
10+- '../..'
11+- '.'
12+# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
13+extra-deps:
14+- aeson-0.11.1.4
15+- fast-logger-2.4.6
16+- http2-1.6.0
17+- servant-0.7
18+- servant-server-0.7
19+- servant-client-0.7
20+- servant-quickcheck-0.1.0.0
21+- text-1.2.2.1
22+- warp-3.2.6
23+
24+# Override default flag values for local packages and extra-deps
25+flags: {}
26+
27+# Extra package databases containing global packages
28+extra-package-dbs: []
29+
30+# Control whether we use the GHC we find on the path
31+# system-ghc: true
32+
33+# Require a specific version of stack, using version ranges
34+# require-stack-version: -any # Default
35+# require-stack-version: >= 1.0.0
36+
37+# Override the architecture used by stack, especially useful on Windows
38+# arch: i386
39+# arch: x86_64
40+
41+# Extra directories used by stack for building
42+# extra-include-dirs: [/path/to/dir]
43+# extra-lib-dirs: [/path/to/dir]
44+
45+# Allow a newer minor version of GHC than the snapshot specifies
46+# compiler-check: newer-minor
servant-quickcheck.cabal+1−1
@@ -20,7 +20,7 @@ flag long-tests
2020library
2121 exposed-modules: Servant.QuickCheck
2222 , Servant.QuickCheck.Internal
23− , Servant.QuickCheck.Internal.Benchmarking
23+ -- , Servant.QuickCheck.Internal.Benchmarking
2424 , Servant.QuickCheck.Internal.Predicates
2525 , Servant.QuickCheck.Internal.HasGenRequest
2626 , Servant.QuickCheck.Internal.QuickCheck
src/Servant/QuickCheck.hs+1
@@ -32,6 +32,7 @@ module Servant.QuickCheck
3232 , unauthorizedContainsWWWAuthenticate
3333 , getsHaveCacheControlHeader
3434 , headsHaveCacheControlHeader
35+ , createContainsValidLocation
3536 -- *** Predicate utilities and types
3637 , (<%>)
3738 , Predicates
src/Servant/QuickCheck/Internal/Predicates.hs+41−28
@@ -1,4 +1,3 @@
1−{-# LANGUAGE MultiWayIf #-}
21module Servant.QuickCheck.Internal.Predicates where
32
43import Control.Monad
@@ -10,15 +9,19 @@ import qualified Data.ByteString.Lazy as LBS
109import Data.CaseInsensitive (mk)
1110import Data.Either (isRight)
1211import Data.List.Split (wordsBy)
13−import Data.Maybe (isJust)
12+import Data.Maybe (fromMaybe, isJust, maybeToList)
1413import Data.Monoid ((<>))
1514import Data.Text (Text)
1615import GHC.Generics (Generic)
1716import Network.HTTP.Client (Manager, Request, Response, httpLbs,
18− method, responseBody, responseHeaders,
17+ method, parseUrl, requestHeaders,
18+ responseBody, responseHeaders,
1919 responseStatus)
20+import Network.HTTP.Media (matchAccept)
2021import Network.HTTP.Types (methodGet, methodHead, parseMethod,
21− status401, renderStdMethod, status405, status500)
22+ renderStdMethod, status200, status201,
23+ status300, status401, status405,
24+ status500)
2225
2326-- | [__Best Practice__]
2427--
@@ -72,16 +75,22 @@ onlyJsonObjects
7275--
7376-- * 201 Created: <https://tools.ietf.org/html/rfc7231#section-6.3.2 RFC 7231 Section 6.3.2>
7477-- * Location header: <https://tools.ietf.org/html/rfc7231#section-7.1.2 RFC 7231 Section 7.1.2>
75−{-createContainsValidLocation :: RequestPredicate Text Bool-}
76−{-createContainsValidLocation-}
77− {-= RequestPredicate-}
78− {-{ reqPredName = "createContainsValidLocation"-}
79− {-, reqResps = \req mg -> do-}
80− {-resp <- httpLbs mgr req-}
81− {-if responseStatus resp == status201-}
82− {-then case lookup "Location" $ responseHeaders resp of-}
83− {-Nothing -> return []-}
84− {-Just l -> if-}
78+createContainsValidLocation :: RequestPredicate Text Bool
79+createContainsValidLocation
80+ = RequestPredicate
81+ { reqPredName = "createContainsValidLocation"
82+ , reqResps = \req mgr -> do
83+ resp <- httpLbs req mgr
84+ if responseStatus resp == status201
85+ then case lookup "Location" $ responseHeaders resp of
86+ Nothing -> return (False, [resp])
87+ Just l -> case parseUrl $ SBSC.unpack l of
88+ Nothing -> return (False, [resp])
89+ Just x -> do
90+ resp2 <- httpLbs x mgr
91+ return (status2XX resp2, [resp, resp2])
92+ else return (True, [resp])
93+ }
8594
8695{-
8796getsHaveLastModifiedHeader :: ResponsePredicate Text Bool
@@ -120,8 +129,9 @@ notAllowedContainsAllowHeader
120129 go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
121130 $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
122131
123− {-
124−-- | When a request contains an @Accept@ header, the server must either return
132+-- | [__RFC Compliance__]
133+--
134+-- When a request contains an @Accept@ header, the server must either return
125135-- content in one of the requested representations, or respond with @406 Not
126136-- Acceptable@.
127137--
@@ -133,18 +143,18 @@ notAllowedContainsAllowHeader
133143-- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>
134144honoursAcceptHeader :: RequestPredicate b Bool
135145honoursAcceptHeader
136− = RequestPredicate name (ResponsePredicate name $ \req mgr -> do
137−
138− resp <- httpLbs req mgr
139− let scode = responseStatus resp
140− sctype = maybeToList $ lookup "Content-Type" $ responseHeaders resp
141− sacc = fromMaybe "*/*" $ lookup "Accept" $ requestHeaders req
142− if 100 < scode && scode < 300
143− then isJust matchAccept sacc sctype
144− else True)
145− where name = "honoursAcceptHeader"
146+ = RequestPredicate
147+ { reqPredName = "honoursAcceptHeader"
148+ , reqResps = \req mgr -> do
149+ resp <- httpLbs req mgr
150+ let scode = responseStatus resp
151+ sctype = lookup "Content-Type" $ responseHeaders resp
152+ sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
153+ if 100 < scode && scode < 300
154+ then return (isJust $ sctype >>= \x -> matchAccept x sacc, [resp])
155+ else return (True, [resp])
156+ }
146157
147−-}
148158-- | [__Best Practice__]
149159--
150160-- Whether or not a representation should be cached, it is good practice to
@@ -179,7 +189,7 @@ headsHaveCacheControlHeader
179189 , reqResps = \req mgr -> if method req == methodHead
180190 then do
181191 resp <- httpLbs req mgr
182− let good = isJust $ lookup "Cache-Control" $ responseHeaders resp
192+ let good = hasValidHeader "Cache-Control" (const True) resp
183193 return (good, [resp])
184194 else return (True, [])
185195 }
@@ -334,3 +344,6 @@ hasValidHeader :: SBS.ByteString -> (SBS.ByteString -> Bool) -> Response b -> Bo
334344hasValidHeader hdr p r = case lookup (mk hdr) (responseHeaders r) of
335345 Nothing -> False
336346 Just v -> p v
347+
348+status2XX :: Response b -> Bool
349+status2XX r = status200 <= responseStatus r && responseStatus r < status300
stack.yaml+1
@@ -4,6 +4,7 @@ resolver: nightly-2016-04-20
44# Local packages, usually specified by relative directory name
55packages:
66- '.'
7+
78# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
89extra-deps:
910- servant-0.7