diff --git a/doc/doc.cabal b/doc/doc.cabal index 3e3b074..6f4158d 100644 --- a/doc/doc.cabal +++ b/doc/doc.cabal @@ -7,24 +7,39 @@ maintainer: jkarni@gmail.com build-type: Simple cabal-version: >=1.10 -library - exposed-modules: ServersEqual - other-extensions: DataKinds, TypeOperators - build-depends: base >=4.8 && <4.9 - , servant-server == 0.7.* - , servant-quickcheck - , servant-client - , QuickCheck - , stm - , containers - , transformers - , warp - , aeson - ghc-options: -Wall -Werror -pgmL markdown-unlit - default-language: Haskell2010 +-- library +-- exposed-modules: ServersEqual +-- other-extensions: DataKinds, TypeOperators +-- build-depends: base >=4.8 && <4.9 +-- , servant-server == 0.7.* +-- , servant-quickcheck +-- , servant-client +-- , QuickCheck +-- , stm +-- , containers +-- , transformers +-- , warp +-- , aeson +-- ghc-options: -Wall -Werror -pgmL markdown-unlit +-- 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 - main-is: Main.hs +executable announcement + main-is: Announcement.lhs build-depends: base >=4.8 && <4.9 , servant-server == 0.7.* , servant-quickcheck @@ -35,5 +50,8 @@ executable doc , transformers , warp , aeson + , hspec + , postgresql-simple + , text default-language: Haskell2010 - ghc-options: -Wall -Werror -pgmL markdown-unlit + ghc-options: -Wall diff --git a/doc/posts/Announcement.anansi b/doc/posts/Announcement.anansi new file mode 100644 index 0000000..dd5abfd --- /dev/null +++ b/doc/posts/Announcement.anansi @@ -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| +: diff --git a/doc/posts/LICENSE b/doc/posts/LICENSE new file mode 100644 index 0000000..c4a51a2 --- /dev/null +++ b/doc/posts/LICENSE @@ -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. diff --git a/doc/posts/Makefile b/doc/posts/Makefile new file mode 100644 index 0000000..bdba6a5 --- /dev/null +++ b/doc/posts/Makefile @@ -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 diff --git a/doc/posts/Setup.hs b/doc/posts/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/doc/posts/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/doc/posts/announcement.md b/doc/posts/announcement.md new file mode 100644 index 0000000..5623b29 --- /dev/null +++ b/doc/posts/announcement.md @@ -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» + diff --git a/doc/posts/posts.cabal b/doc/posts/posts.cabal new file mode 100644 index 0000000..fd48fbf --- /dev/null +++ b/doc/posts/posts.cabal @@ -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 diff --git a/doc/posts/src/Main.hs b/doc/posts/src/Main.hs new file mode 100644 index 0000000..01a1f22 --- /dev/null +++ b/doc/posts/src/Main.hs @@ -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) diff --git a/doc/posts/src/Spec.hs b/doc/posts/src/Spec.hs new file mode 100644 index 0000000..df8c936 --- /dev/null +++ b/doc/posts/src/Spec.hs @@ -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 diff --git a/doc/posts/src/schema.sql b/doc/posts/src/schema.sql new file mode 100644 index 0000000..872f10c --- /dev/null +++ b/doc/posts/src/schema.sql @@ -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) +) diff --git a/doc/posts/stack.yaml b/doc/posts/stack.yaml new file mode 100644 index 0000000..b58bffa --- /dev/null +++ b/doc/posts/stack.yaml @@ -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 diff --git a/servant-quickcheck.cabal b/servant-quickcheck.cabal index e018d04..3289c79 100644 --- a/servant-quickcheck.cabal +++ b/servant-quickcheck.cabal @@ -20,7 +20,7 @@ flag long-tests library exposed-modules: Servant.QuickCheck , Servant.QuickCheck.Internal - , Servant.QuickCheck.Internal.Benchmarking + -- , Servant.QuickCheck.Internal.Benchmarking , Servant.QuickCheck.Internal.Predicates , Servant.QuickCheck.Internal.HasGenRequest , Servant.QuickCheck.Internal.QuickCheck diff --git a/src/Servant/QuickCheck.hs b/src/Servant/QuickCheck.hs index d9df91f..e6f1440 100644 --- a/src/Servant/QuickCheck.hs +++ b/src/Servant/QuickCheck.hs @@ -32,6 +32,7 @@ module Servant.QuickCheck , unauthorizedContainsWWWAuthenticate , getsHaveCacheControlHeader , headsHaveCacheControlHeader + , createContainsValidLocation -- *** Predicate utilities and types , (<%>) , Predicates diff --git a/src/Servant/QuickCheck/Internal/Predicates.hs b/src/Servant/QuickCheck/Internal/Predicates.hs index 4a7c5b8..a0fad97 100644 --- a/src/Servant/QuickCheck/Internal/Predicates.hs +++ b/src/Servant/QuickCheck/Internal/Predicates.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE MultiWayIf #-} module Servant.QuickCheck.Internal.Predicates where import Control.Monad @@ -10,15 +9,19 @@ import qualified Data.ByteString.Lazy as LBS import Data.CaseInsensitive (mk) import Data.Either (isRight) import Data.List.Split (wordsBy) -import Data.Maybe (isJust) +import Data.Maybe (fromMaybe, isJust, maybeToList) import Data.Monoid ((<>)) import Data.Text (Text) import GHC.Generics (Generic) import Network.HTTP.Client (Manager, Request, Response, httpLbs, - method, responseBody, responseHeaders, + method, parseUrl, requestHeaders, + responseBody, responseHeaders, responseStatus) +import Network.HTTP.Media (matchAccept) import Network.HTTP.Types (methodGet, methodHead, parseMethod, - status401, renderStdMethod, status405, status500) + renderStdMethod, status200, status201, + status300, status401, status405, + status500) -- | [__Best Practice__] -- @@ -72,16 +75,22 @@ onlyJsonObjects -- -- * 201 Created: -- * Location header: -{-createContainsValidLocation :: RequestPredicate Text Bool-} -{-createContainsValidLocation-} - {-= RequestPredicate-} - {-{ reqPredName = "createContainsValidLocation"-} - {-, reqResps = \req mg -> do-} - {-resp <- httpLbs mgr req-} - {-if responseStatus resp == status201-} - {-then case lookup "Location" $ responseHeaders resp of-} - {-Nothing -> return []-} - {-Just l -> if-} +createContainsValidLocation :: RequestPredicate Text Bool +createContainsValidLocation + = RequestPredicate + { reqPredName = "createContainsValidLocation" + , reqResps = \req mgr -> do + resp <- httpLbs req mgr + if responseStatus resp == status201 + then case lookup "Location" $ responseHeaders resp of + Nothing -> return (False, [resp]) + 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 @@ -120,8 +129,9 @@ notAllowedContainsAllowHeader go x = all (\y -> isRight $ parseMethod $ SBSC.pack y) $ wordsBy (`elem` (", " :: [Char])) (SBSC.unpack x) - {- --- | When a request contains an @Accept@ header, the server must either return +-- | [__RFC Compliance__] +-- +-- When a request contains an @Accept@ header, the server must either return -- content in one of the requested representations, or respond with @406 Not -- Acceptable@. -- @@ -133,18 +143,18 @@ notAllowedContainsAllowHeader -- * @Accept@ header: honoursAcceptHeader :: RequestPredicate b Bool 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__] -- -- 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 then do resp <- httpLbs req mgr - let good = isJust $ lookup "Cache-Control" $ responseHeaders resp + let good = hasValidHeader "Cache-Control" (const True) resp return (good, [resp]) 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 Nothing -> False Just v -> p v + +status2XX :: Response b -> Bool +status2XX r = status200 <= responseStatus r && responseStatus r < status300 diff --git a/stack.yaml b/stack.yaml index 3d17f46..9e9e331 100644 --- a/stack.yaml +++ b/stack.yaml @@ -4,6 +4,7 @@ resolver: nightly-2016-04-20 # 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: - servant-0.7