haskell/servant-quickcheck
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

More predicates, blog post

Browse Source
This commit is contained in:
Julian K. Arni 2016-05-01 14:29:47 +02:00
parent 64c845cb45
commit 530fdba5c0
15 changed files with 626 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
doc/doc.cabal
View File

@ -7,24 +7,39 @@ maintainer: jkarni@gmail.com
build-type: Simple build-type: Simple
cabal-version: >=1.10 cabal-version: >=1.10
library -- library
exposed-modules: ServersEqual -- exposed-modules: ServersEqual
other-extensions: DataKinds, TypeOperators -- other-extensions: DataKinds, TypeOperators
build-depends: base >=4.8 && <4.9 -- build-depends: base >=4.8 && <4.9
, servant-server == 0.7.* -- , servant-server == 0.7.*
, servant-quickcheck -- , servant-quickcheck
, servant-client -- , servant-client
, QuickCheck -- , QuickCheck
, stm -- , stm
, containers -- , containers
, transformers -- , transformers
, warp -- , warp
, aeson -- , aeson
ghc-options: -Wall -Werror -pgmL markdown-unlit -- ghc-options: -Wall -Werror -pgmL markdown-unlit
default-language: Haskell2010 -- default-language: Haskell2010
--
-- executable doc
-- main-is: Main.hs
-- build-depends: base >=4.8 && <4.9
-- , servant-server == 0.7.*
-- , servant-quickcheck
-- , servant-client
-- , QuickCheck
-- , stm
-- , containers
-- , transformers
-- , warp
-- , aeson
-- default-language: Haskell2010
-- ghc-options: -Wall -Werror -pgmL markdown-unlit
executable doc executable announcement
main-is: Main.hs main-is: Announcement.lhs
build-depends: base >=4.8 && <4.9 build-depends: base >=4.8 && <4.9
, servant-server == 0.7.* , servant-server == 0.7.*
, servant-quickcheck , servant-quickcheck
@ -35,5 +50,8 @@ executable doc
, transformers , transformers
, warp , warp
, aeson , aeson
, hspec
, postgresql-simple
, text
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall -Werror -pgmL markdown-unlit ghc-options: -Wall

167
doc/posts/Announcement.anansi Normal file
View File

@ -0,0 +1,167 @@
:loom anansi.markdown
# Announcing servant-quickcheck
Some time ago, we released `servant-mock`. The idea behind it is to use
`QuickCheck` to create a mock server that accords with a servant API. Not long
after, we started thinking about an analog that would, instead of mocking a
server, mock a client instead - i.e., generate random requests that conform to
an API description.
This is much closer to the traditional use of `QuickCheck`. The most obvious
use-case is checking that properties hold of an *entire* server rather than of
individual endpoints.
## `serverSatisfies`
There are a variety of best practices in writing web APIs that aren't always
obvious. As a running example, let's use a simple service that allows adding,
removing, and querying biological species. Our SQL schema is:
:d schema.sql
CREATE TABLE genus (
genus_name text PRIMARY KEY,
genus_family text NOT NULL
);
CREATE TABLE species (
species_name text PRIMARY KEY,
species_genus text NOT NULL REFERENCES genus (genus_name)
)
:
And our actual application:
:d Main.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Main where
import Servant
import Data.Aeson
import Database.PostgreSQL.Simple
import GHC.Generics (Generic)
import Data.Text (Text)
import Network.Wai.Handler.Warp
import Control.Monad.IO.Class (liftIO)
type API
= "species" :> (Capture "species-name" Text :> ( Get '[JSON] Species
:<|> Delete '[JSON] ())
:<|> ReqBody '[JSON] Species :> Post '[JSON] ())
-- The plural of 'species' is unfortunately also 'species'
:<|> "speciess" :> Get '[JSON] [Species]
api :: Proxy API
api = Proxy
data Species = Species
{ speciesName :: Text
, speciesGenus :: Text
} deriving (Eq, Show, Read, Generic, ToJSON, FromJSON)
data Genus = Genus
{ genusName :: Text
, genusFamily :: Text
} deriving (Eq, Show, Read, Generic, ToJSON, FromJSON)
instance FromRow Genus
instance FromRow Species
server :: Connection -> Server API
server conn = ((\sname -> liftIO (lookupSpecies conn sname)
:<|> liftIO (deleteSpecies conn sname))
:<|> (\species -> liftIO $ insertSpecies conn species))
:<|> (liftIO $ allSpecies conn)
lookupSpecies :: Connection -> Text -> IO Species
lookupSpecies conn name = do
[s] <- query conn "SELECT * FROM species WHERE species_name = ?" (Only name)
return s
deleteSpecies :: Connection -> Text -> IO ()
deleteSpecies conn name = do
_ <- execute conn "DELETE FROM species WHERE species_name = ?" (Only name)
return ()
insertSpecies :: Connection -> Species -> IO ()
insertSpecies conn Species{..} = do
_ <- execute conn "INSERT INTO species (species_name, species_genus) VALUES (?)" (speciesName, speciesGenus)
return ()
allSpecies :: Connection -> IO [Species]
allSpecies conn = do
query_ conn "SELECT * FROM species"
main :: IO ()
main = do
conn <- connectPostgreSQL "dbname=servant-quickcheck"
run 8090 (serve api $ server conn)
:
(You'll also also need to run:
```
createdb servant-quickcheck
psql --file schema.sql -d servant-quickcheck
```
If you want to run this example.)
This is a plausible effort. You might want to spend a moment thinking about what
could be improved.
:d Spec.hs
{-# LANGUAGE OverloadedStrings #-}
module Spec (main) where
import Main (server, api, Species(..))
import Test.Hspec
import Test.QuickCheck.Instances
import Servant.QuickCheck
import Test.QuickCheck (Arbitrary(..))
import Database.PostgreSQL.Simple (connectPostgreSQL)
spec :: Spec
spec = describe "the species application" $ do
let pserver = do
conn <- connectPostgreSQL "dbname=servant-quickcheck"
return $ server conn
it "should not return 500s" $ do
withServantServer api pserver $ \url ->
serverSatisfies api url defaultArgs (not500 <%> mempty)
it "should not return top-level json" $ do
withServantServer api pserver $ \url ->
serverSatisfies api url defaultArgs (onlyJsonObjects <%> mempty)
main :: IO ()
main = do
hspec spec
instance Arbitrary Species where
arbitrary = Species <$> arbitrary <*> arbitrary
:
**Note**: This post is an anansi literate file that generates multiple source
files. They are:
:f Main.hs
|Main.hs|
:
:f schema.sql
|schema.sql|
:
:f Spec.hs
|Spec.hs|
:

30
doc/posts/LICENSE Normal file
View File

@ -0,0 +1,30 @@
Copyright (c) 2016, Julian K. Arni
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 Julian K. Arni 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.

22
doc/posts/Makefile Normal file
View File

@ -0,0 +1,22 @@
FILES = src/Main.hs src/Spec.hs src/schema.sql
src/$(FILES): Announcement.anansi
anansi tangle -o "src" Announcement.anansi
announcement.md: Announcement.anansi
anansi weave -o "announcement.md" Announcement.anansi
.stack-work/bin/posts: $(FILES) stack.yaml posts.cabal
stack build
run: .stack-work/bin/posts
stack exec posts
test: .stack-work/bin/posts
stack test
post: announcement.md
.PHONY: post run test

2
doc/posts/Setup.hs Normal file
View File

@ -0,0 +1,2 @@
import Distribution.Simple
main = defaultMain

118
doc/posts/announcement.md Normal file
View File

@ -0,0 +1,118 @@
# Announcing servant-quickcheck
Some time ago, we released `servant-mock`. The idea behind it is to use
`QuickCheck` to create a mock server that accords with a servant API. Not long
after, we started thinking about an analog that would, instead of mocking a
server, mock a client instead - i.e., generate random requests that conform to
an API description.
This is much closer to the traditional use of `QuickCheck`. The most obvious
use-case is checking that properties hold of an *entire* server rather than of
individual endpoints.
## `serverSatisfies`
There are a variety of best practices in writing web APIs that aren't always
obvious. As a running example, let's use a simple service that allows adding,
removing, and querying biological species. Our SQL schema is:
> **«schema.sql»**
>
> CREATE TABLE genus (
> genus_name text PRIMARY KEY,
> genus_family text NOT NULL
> )
>
> CREATE TABLE species (
> species_name text PRIMARY KEY,
> species_genus text NOT NULL REFERENCES genus (genus_name)
> )
And our actual application:
> **«Main.hs»**
> {-# LANGUAGE DataKinds #-}
> {-# LANGUAGE DeriveAnyClass #-}
> {-# LANGUAGE DeriveGeneric #-}
> {-# LANGUAGE TypeOperators #-}
> {-# LANGUAGE OverloadedStrings #-}
> {-# LANGUAGE RecordWildCards #-}
> import Servant
> import Data.Aeson
> import Database.PostgreSQL.Simple
> import GHC.Generics (Generic)
> import Data.Text (Text)
> import Network.Wai.Handler.Warp
> import Control.Monad.IO.Class (liftIO)
>
> type API
> = "species" :> (Capture "species-name" Text :> ( Get '[JSON] Species
> :<|> Delete '[JSON] ())
> :<|> ReqBody '[JSON] Species :> Post '[JSON] ()
> :<|> "count" :> Get '[JSON] Int)
>
> api :: Proxy API
> api = Proxy
>
> data Species = Species
> { speciesName :: Text
> , speciesGenus :: Text
> } deriving (Eq, Show, Read, Generic, ToJSON, FromJSON)
>
> data Genus = Genus
> { genusName :: Text
> , genusFamily :: Text
> } deriving (Eq, Show, Read, Generic, ToJSON, FromJSON)
>
> instance FromRow Genus
> instance FromRow Species
>
> server :: Connection -> Server API
> server conn = (\sname -> liftIO (lookupSpecies conn sname)
> :<|> liftIO (deleteSpecies conn sname))
> :<|> (\species -> liftIO $ insertSpecies conn species)
> :<|> (liftIO $ countSpecies conn)
>
> lookupSpecies :: Connection -> Text -> IO Species
> lookupSpecies conn name = do
> [s] <- query conn "SELECT * FROM species WHERE species_name == ?" (Only name)
> return s
>
> deleteSpecies :: Connection -> Text -> IO ()
> deleteSpecies conn name = do
> _ <- execute conn "DELETE FROM species WHERE species_name == ?" (Only name)
> return ()
>
> insertSpecies :: Connection -> Species -> IO ()
> insertSpecies conn Species{..} = do
> _ <- execute conn "INSERT INTO species (species_name, species_genus) VALUES (?)" (speciesName, speciesGenus)
> return ()
>
> countSpecies :: Connection -> IO Int
> countSpecies conn = do
> [Only count] <- query_ conn "SELECT count(*) FROM species"
> return count
>
> main :: IO ()
> main = do
> conn <- connectPostgreSQL ""
> run 8090 (serve api $ server conn)
> **» Main.hs**
> «Main.hs»
> **» schema.sql**
> «schema.sql»

47
doc/posts/posts.cabal Normal file
View File

@ -0,0 +1,47 @@
-- Initial posts.cabal generated by cabal init. For further documentation,
-- see http://haskell.org/cabal/users-guide/
name: posts
version: 0.1.0.0
-- synopsis:
-- description:
license: BSD3
license-file: LICENSE
author: Julian K. Arni
maintainer: jkarni@gmail.com
-- copyright:
-- category:
build-type: Simple
-- extra-source-files:
cabal-version: >=1.10
executable posts
main-is: Main.hs
build-depends: base >=4.8 && <4.9
, servant-server >=0.5 && <0.8
, aeson >=0.9 && <0.12
, text == 1.*
, warp >=3.0 && <3.3
, transformers >=0.4 && <0.5
, postgresql-simple
hs-source-dirs: src
ghc-options: -Wall -O2 -threaded
default-language: Haskell2010
test-suite spec
type: exitcode-stdio-1.0
ghc-options: -Wall -O2 -threaded
default-language: Haskell2010
hs-source-dirs: src
main-is: Spec.hs
build-depends: base == 4.*
, servant-quickcheck
, hspec == 2.*
, servant-server >=0.5 && <0.8
, aeson >=0.9 && <0.12
, text == 1.*
, warp >=3.0 && <3.3
, transformers >=0.4 && <0.5
, postgresql-simple
, quickcheck-instances
, QuickCheck

71
doc/posts/src/Main.hs Normal file
View File

@ -0,0 +1,71 @@
#line 158 "Announcement.anansi"
#line 37 "Announcement.anansi"
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Main where
import Servant
import Data.Aeson
import Database.PostgreSQL.Simple
import GHC.Generics (Generic)
import Data.Text (Text)
import Network.Wai.Handler.Warp
import Control.Monad.IO.Class (liftIO)
type API
= "species" :> (Capture "species-name" Text :> ( Get '[JSON] Species
:<|> Delete '[JSON] ())
:<|> ReqBody '[JSON] Species :> Post '[JSON] ())
-- The plural of 'species' is unfortunately also 'species'
:<|> "speciess" :> Get '[JSON] [Species]
api :: Proxy API
api = Proxy
data Species = Species
{ speciesName :: Text
, speciesGenus :: Text
} deriving (Eq, Show, Read, Generic, ToJSON, FromJSON)
data Genus = Genus
{ genusName :: Text
, genusFamily :: Text
} deriving (Eq, Show, Read, Generic, ToJSON, FromJSON)
instance FromRow Genus
instance FromRow Species
server :: Connection -> Server API
server conn = ((\sname -> liftIO (lookupSpecies conn sname)
:<|> liftIO (deleteSpecies conn sname))
:<|> (\species -> liftIO $ insertSpecies conn species))
:<|> (liftIO $ allSpecies conn)
lookupSpecies :: Connection -> Text -> IO Species
lookupSpecies conn name = do
[s] <- query conn "SELECT * FROM species WHERE species_name = ?" (Only name)
return s
deleteSpecies :: Connection -> Text -> IO ()
deleteSpecies conn name = do
_ <- execute conn "DELETE FROM species WHERE species_name = ?" (Only name)
return ()
insertSpecies :: Connection -> Species -> IO ()
insertSpecies conn Species{..} = do
_ <- execute conn "INSERT INTO species (species_name, species_genus) VALUES (?)" (speciesName, speciesGenus)
return ()
allSpecies :: Connection -> IO [Species]
allSpecies conn = do
query_ conn "SELECT * FROM species"
main :: IO ()
main = do
conn <- connectPostgreSQL "dbname=servant-quickcheck"
run 8090 (serve api $ server conn)

34
doc/posts/src/Spec.hs Normal file
View File

@ -0,0 +1,34 @@
#line 166 "Announcement.anansi"
#line 120 "Announcement.anansi"
{-# LANGUAGE OverloadedStrings #-}
module Spec (main) where
import Main (server, api, Species(..))
import Test.Hspec
import Test.QuickCheck.Instances
import Servant.QuickCheck
import Test.QuickCheck (Arbitrary(..))
import Database.PostgreSQL.Simple (connectPostgreSQL)
spec :: Spec
spec = describe "the species application" $ do
let pserver = do
conn <- connectPostgreSQL "dbname=servant-quickcheck"
return $ server conn
it "should not return 500s" $ do
withServantServer api pserver $ \url ->
serverSatisfies api url defaultArgs (not500 <%> mempty)
it "should not return top-level json" $ do
withServantServer api pserver $ \url ->
serverSatisfies api url defaultArgs (onlyJsonObjects <%> mempty)
main :: IO ()
main = do
hspec spec
instance Arbitrary Species where
arbitrary = Species <$> arbitrary <*> arbitrary

9
doc/posts/src/schema.sql Normal file
View File

@ -0,0 +1,9 @@
CREATE TABLE genus (
genus_name text PRIMARY KEY,
genus_family text NOT NULL
);
CREATE TABLE species (
species_name text PRIMARY KEY,
species_genus text NOT NULL REFERENCES genus (genus_name)
)

46
doc/posts/stack.yaml Normal file
View File

@ -0,0 +1,46 @@
# This file was automatically generated by stack init
# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/
# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
resolver: lts-5.14
# Local packages, usually specified by relative directory name
packages:
- '../..'
- '.'
# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
extra-deps:
- aeson-0.11.1.4
- fast-logger-2.4.6
- http2-1.6.0
- servant-0.7
- servant-server-0.7
- servant-client-0.7
- servant-quickcheck-0.1.0.0
- text-1.2.2.1
- warp-3.2.6
# Override default flag values for local packages and extra-deps
flags: {}
# Extra package databases containing global packages
extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: >= 1.0.0
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor

2
servant-quickcheck.cabal
View File

@ -20,7 +20,7 @@ flag long-tests
library library
exposed-modules: Servant.QuickCheck exposed-modules: Servant.QuickCheck
, Servant.QuickCheck.Internal , Servant.QuickCheck.Internal
, Servant.QuickCheck.Internal.Benchmarking -- , Servant.QuickCheck.Internal.Benchmarking
, Servant.QuickCheck.Internal.Predicates , Servant.QuickCheck.Internal.Predicates
, Servant.QuickCheck.Internal.HasGenRequest , Servant.QuickCheck.Internal.HasGenRequest
, Servant.QuickCheck.Internal.QuickCheck , Servant.QuickCheck.Internal.QuickCheck

1
src/Servant/QuickCheck.hs
View File

@ -32,6 +32,7 @@ module Servant.QuickCheck
, unauthorizedContainsWWWAuthenticate , unauthorizedContainsWWWAuthenticate
, getsHaveCacheControlHeader , getsHaveCacheControlHeader
, headsHaveCacheControlHeader , headsHaveCacheControlHeader
, createContainsValidLocation
-- *** Predicate utilities and types -- *** Predicate utilities and types
, (<%>) , (<%>)
, Predicates , Predicates

69
src/Servant/QuickCheck/Internal/Predicates.hs
View File

@ -1,4 +1,3 @@
{-# LANGUAGE MultiWayIf #-}
module Servant.QuickCheck.Internal.Predicates where module Servant.QuickCheck.Internal.Predicates where
import Control.Monad import Control.Monad
@ -10,15 +9,19 @@ import qualified Data.ByteString.Lazy as LBS
import Data.CaseInsensitive (mk) import Data.CaseInsensitive (mk)
import Data.Either (isRight) import Data.Either (isRight)
import Data.List.Split (wordsBy) import Data.List.Split (wordsBy)
import Data.Maybe (isJust) import Data.Maybe (fromMaybe, isJust, maybeToList)
import Data.Monoid ((<>)) import Data.Monoid ((<>))
import Data.Text (Text) import Data.Text (Text)
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Network.HTTP.Client (Manager, Request, Response, httpLbs, import Network.HTTP.Client (Manager, Request, Response, httpLbs,
method, responseBody, responseHeaders, method, parseUrl, requestHeaders,
responseBody, responseHeaders,
responseStatus) responseStatus)
import Network.HTTP.Media (matchAccept)
import Network.HTTP.Types (methodGet, methodHead, parseMethod, import Network.HTTP.Types (methodGet, methodHead, parseMethod,
status401, renderStdMethod, status405, status500) renderStdMethod, status200, status201,
status300, status401, status405,
status500)
-- | [__Best Practice__] -- | [__Best Practice__]
-- --
@ -72,16 +75,22 @@ onlyJsonObjects
-- --
-- * 201 Created: <https://tools.ietf.org/html/rfc7231#section-6.3.2 RFC 7231 Section 6.3.2> -- * 201 Created: <https://tools.ietf.org/html/rfc7231#section-6.3.2 RFC 7231 Section 6.3.2>
-- * Location header: <https://tools.ietf.org/html/rfc7231#section-7.1.2 RFC 7231 Section 7.1.2> -- * Location header: <https://tools.ietf.org/html/rfc7231#section-7.1.2 RFC 7231 Section 7.1.2>
{-createContainsValidLocation :: RequestPredicate Text Bool-} createContainsValidLocation :: RequestPredicate Text Bool
{-createContainsValidLocation-} createContainsValidLocation
{-= RequestPredicate-} = RequestPredicate
{-{ reqPredName = "createContainsValidLocation"-} { reqPredName = "createContainsValidLocation"
{-, reqResps = \req mg -> do-} , reqResps = \req mgr -> do
{-resp <- httpLbs mgr req-} resp <- httpLbs req mgr
{-if responseStatus resp == status201-} if responseStatus resp == status201
{-then case lookup "Location" $ responseHeaders resp of-} then case lookup "Location" $ responseHeaders resp of
{-Nothing -> return []-} Nothing -> return (False, [resp])
{-Just l -> if-} Just l -> case parseUrl $ SBSC.unpack l of
Nothing -> return (False, [resp])
Just x -> do
resp2 <- httpLbs x mgr
return (status2XX resp2, [resp, resp2])
else return (True, [resp])
}
{- {-
getsHaveLastModifiedHeader :: ResponsePredicate Text Bool getsHaveLastModifiedHeader :: ResponsePredicate Text Bool
@ -120,8 +129,9 @@ notAllowedContainsAllowHeader
go x = all (\y -> isRight $ parseMethod $ SBSC.pack y) go x = all (\y -> isRight $ parseMethod $ SBSC.pack y)
$ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x) $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x)
{- -- | [__RFC Compliance__]
-- | When a request contains an @Accept@ header, the server must either return --
-- When a request contains an @Accept@ header, the server must either return
-- content in one of the requested representations, or respond with @406 Not -- content in one of the requested representations, or respond with @406 Not
-- Acceptable@. -- Acceptable@.
-- --
@ -133,18 +143,18 @@ notAllowedContainsAllowHeader
-- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1> -- * @Accept@ header: <https://www.w3.org/Protocols/rfc2616/rfc2616-sec14.html RFC 2616 Section 14.1>
honoursAcceptHeader :: RequestPredicate b Bool honoursAcceptHeader :: RequestPredicate b Bool
honoursAcceptHeader honoursAcceptHeader
= RequestPredicate name (ResponsePredicate name $ \req mgr -> do = RequestPredicate
{ reqPredName = "honoursAcceptHeader"
, reqResps = \req mgr -> do
resp <- httpLbs req mgr
let scode = responseStatus resp
sctype = lookup "Content-Type" $ responseHeaders resp
sacc = fromMaybe "*/*" $ lookup "Accept" (requestHeaders req)
if 100 < scode && scode < 300
then return (isJust $ sctype >>= \x -> matchAccept x sacc, [resp])
else return (True, [resp])
}
resp <- httpLbs req mgr
let scode = responseStatus resp
sctype = maybeToList $ lookup "Content-Type" $ responseHeaders resp
sacc = fromMaybe "*/*" $ lookup "Accept" $ requestHeaders req
if 100 < scode && scode < 300
then isJust matchAccept sacc sctype
else True)
where name = "honoursAcceptHeader"
-}
-- | [__Best Practice__] -- | [__Best Practice__]
-- --
-- Whether or not a representation should be cached, it is good practice to -- Whether or not a representation should be cached, it is good practice to
@ -179,7 +189,7 @@ headsHaveCacheControlHeader
, reqResps = \req mgr -> if method req == methodHead , reqResps = \req mgr -> if method req == methodHead
then do then do
resp <- httpLbs req mgr resp <- httpLbs req mgr
let good = isJust $ lookup "Cache-Control" $ responseHeaders resp let good = hasValidHeader "Cache-Control" (const True) resp
return (good, [resp]) return (good, [resp])
else return (True, []) else return (True, [])
} }
@ -334,3 +344,6 @@ hasValidHeader :: SBS.ByteString -> (SBS.ByteString -> Bool) -> Response b -> Bo
hasValidHeader hdr p r = case lookup (mk hdr) (responseHeaders r) of hasValidHeader hdr p r = case lookup (mk hdr) (responseHeaders r) of
Nothing -> False Nothing -> False
Just v -> p v Just v -> p v
status2XX :: Response b -> Bool
status2XX r = status200 <= responseStatus r && responseStatus r < status300

1
stack.yaml
View File

@ -4,6 +4,7 @@ resolver: nightly-2016-04-20
# Local packages, usually specified by relative directory name # Local packages, usually specified by relative directory name
packages: packages:
- '.' - '.'
# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
extra-deps: extra-deps:
- servant-0.7 - servant-0.7