servant-combinators (empty) → 0.0.1
raw patch · 15 files changed
+1120/−0 lines, 15 filesdep +QuickCheckdep +aesondep +async
Dependencies added: QuickCheck, aeson, async, base, bytestring, case-insensitive, clientsession, containers, cookie, http-client, http-conduit, http-types, servant, servant-combinators, servant-server, tasty, tasty-quickcheck, text, time, vault, wai, warp
Files
- LICENSE +19/−0
- lib/Servant/API/Cookies.hs +257/−0
- lib/Servant/API/HeaderList.hs +56/−0
- lib/Servant/API/QueryString.hs +57/−0
- lib/Servant/API/RawQueryString.hs +53/−0
- lib/Servant/API/RawRequest.hs +44/−0
- servant-combinators.cabal +143/−0
- src/LiveTest.hs +3/−0
- tests/Main.hs +60/−0
- tests/TestCookies.hs +139/−0
- tests/TestHeaders.hs +73/−0
- tests/TestLib.hs +28/−0
- tests/TestQueryString.hs +73/−0
- tests/TestRawQueryString.hs +51/−0
- tests/TestRawRequest.hs +64/−0
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2023 Adam McCullough <merlinfmct87@gmail.com>++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ lib/Servant/API/Cookies.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE FlexibleContexts #-}++{- |Description: This module provides access to cookie data, in the+ form of a SessionMap.+-}+module Servant.API.Cookies where++import Data.ByteString (ByteString)+import Data.ByteString.Lazy (toStrict)+import Data.ByteString.Builder (toLazyByteString)+import Data.Functor ((<&>))+import Data.Kind (Type)+import Data.Map.Strict (Map)+import Data.Time.Clock (getCurrentTime, secondsToDiffTime)+import Network.Wai+import Servant+import Servant.Server.Internal.Delayed (addHeaderCheck)+import Servant.Server.Internal.DelayedIO (DelayedIO, delayedFailFatal, withRequest)+import Web.ClientSession+import Web.Cookie++import qualified Data.Map.Strict as Map+import qualified Data.Vault.Lazy as Vault+import qualified Network.HTTP.Types.Header as NTH++-- |A SessionMap is a hash map of session data from a request.+type SessionMap = Map ByteString ByteString++{- |+ A SetCookieHeader is a convenience type for adding a "Set-Cookie"+ header that expects a SetCookie record type.++ I wanted to have the header name be NTH.hSetCookie for extra "use+ the known correct value" goodness, but that breaks the type magic+ Servant relies upon.+-}+type SetCookieHeader a = Headers '[Servant.Header "Set-Cookie" SetCookie] a++{- |+ The @ProvideCookies@ and @WithCookies@ combinator work in tandem+ together -- the @ProvideCookies@ combinator parses the cookies from+ the request and stores them in the WAI request Vault, the+ @WithCookies@ combinator provides the cookies as a hash map to the+ handler.+-}+data ProvideCookies (mods :: [Type])++{- |+ As mentioned above, the @WithCookies@ combinator provides+ already-parsed cookies to the handler as a SessionMap.++ The cookie values are assumed to be encrypted with a+ @Web.ClientSession.Key@. Likewise, @updateCookies@ encrypts the+ cookies on the outbound side via this mechanism.++ Example:++@+import Control.Monad.IO.Class (liftIO)+import Servant+import ServantExtras.Cookies++import qualified Data.Map.Strict as Map++type MyAPI = "my-cookie-enabled-endpoint"+ :> ProvideCookies '[Required]+ :> WithCookies '[Required]+ :> Get '[JSON] NoContent++myServer :: Server MyAPI+myServer = cookieEndpointHandler+ where+ cookieEndpointHandler :: SessionMap -> Handler NoContent+ cookieEndpointHandler sMap =+ let mCookieValue = lookup "MerlinWasHere" $ Map.toList sMap in+ case mCookieValue of+ Nothing -> do+ liftIO $ print "Merlin was *NOT* here!"+ throwError err400 { errBody = "Clearly you've missed something." }+ Just message -> do+ liftIO $ do+ print "Merlin WAS here, and he left us a message!"+ print message+ pure NoContent+@+-}+data WithCookies (mods :: [Type])++{- |+ @HasCookies@ and @HasCookiesMaybe@ are internal utitily types. You should only need to use @ProvideCookies@ and @WithCookies@.++ As an aside, they're separate types (rather than a single type with+ a (mods :: [Type]) ) phantom type because the term-level values show up+ in the instances, and I didn't see a clean way to separate them out+ by case, and only covering one value from the sum type made Haskell+ (rightly) complain.+-}+data HasCookies = HasCookies++{- |+ @HasCookies@ and @HasCookiesMaybe@ are internal utitily types. You should only need to use @ProvideCookies@ and @WithCookies@.+-}+data HasCookiesMaybe = HasCookiesMaybe++instance+ ( HasServer api (HasCookies ': ctx)+ , HasContextEntry ctx (Vault.Key SessionMap)+ , HasContextEntry ctx (Key) -- for encrypting/decrypting the cookie+ ) =>+ HasServer (ProvideCookies '[Required] :> api) ctx+ where+ type ServerT (ProvideCookies '[Required] :> api) m = ServerT api m++ hoistServerWithContext _ _ nt server =+ hoistServerWithContext (Proxy @api) (Proxy @(HasCookies ': ctx)) nt server++ route _ ctx server =+ route (Proxy @api) (HasCookies :. ctx) server <&> \app req respK -> do+ let+ mCookie = lookup NTH.hCookie (requestHeaders req)+ key = getContextEntry ctx :: Vault.Key SessionMap+ encKey = getContextEntry ctx :: Key+ mCookie' = mCookie >>= (decrypt encKey)+ cookies = maybe Map.empty (Map.fromList . parseCookies) mCookie'+ req' = req {vault = Vault.insert key cookies (vault req)}+ app req' respK++instance+ ( HasServer api (HasCookiesMaybe ': ctx)+ , HasContextEntry ctx (Vault.Key (Maybe SessionMap))+ , HasContextEntry ctx (Key) -- for encrypting/decrypting the cookie+ ) =>+ HasServer (ProvideCookies '[Optional] :> api) ctx+ where+ type ServerT (ProvideCookies '[Optional] :> api) m = ServerT api m++ hoistServerWithContext _ _ nt server =+ hoistServerWithContext (Proxy @api) (Proxy @(HasCookiesMaybe ': ctx)) nt server++ route _ ctx server =+ route (Proxy @api) ((HasCookiesMaybe) :. ctx) server <&> \app req respK -> do+ let+ mCookie = (Map.fromList . parseCookies) <$> lookup NTH.hCookie (requestHeaders req)+ key = getContextEntry ctx :: Vault.Key (Maybe SessionMap)+ req' = req {vault = Vault.insert key mCookie (vault req)}+ app req' respK++instance+ ( HasServer api ctx+ , HasContextEntry ctx HasCookies+ , HasContextEntry ctx (Vault.Key SessionMap)+ ) =>+ HasServer (WithCookies '[Required] :> api) ctx+ where+ type ServerT (WithCookies '[Required] :> api) m = SessionMap -> ServerT api m++ hoistServerWithContext _ ctx nt server =+ hoistServerWithContext (Proxy @api) ctx nt . server++ route _ ctx server =+ route (Proxy @api) ctx $+ server `addHeaderCheck` retrieveCookies+ where+ retrieveCookies :: DelayedIO SessionMap+ retrieveCookies = withRequest $ \req -> do+ let key = getContextEntry ctx :: Vault.Key SessionMap+ case Vault.lookup key (vault req) of+ Just cookies -> pure cookies+ Nothing ->+ delayedFailFatal $+ err500+ { errBody = "Something has gone horribly wrong; could not find cached cookies."+ }++instance+ ( HasServer api ctx+ , HasContextEntry ctx (HasCookiesMaybe)+ , HasContextEntry ctx (Vault.Key (Maybe SessionMap))+ ) =>+ HasServer (WithCookies '[Optional] :> api) ctx+ where+ type ServerT (WithCookies '[Optional] :> api) m = Maybe SessionMap -> ServerT api m++ hoistServerWithContext _ ctx nt server =+ hoistServerWithContext (Proxy @api) ctx nt . server++ route _ ctx server =+ route (Proxy @api) ctx $+ server `addHeaderCheck` retrieveCookies+ where+ retrieveCookies :: DelayedIO (Maybe SessionMap)+ retrieveCookies = withRequest $ \req -> do+ let key = getContextEntry ctx :: Vault.Key (Maybe SessionMap)+ case Vault.lookup key (vault req) of+ Just cookies -> pure cookies+ Nothing ->+ delayedFailFatal $+ err500+ { -- TODO: Maybe the error message should be pulled from+ -- the Context?+ errBody = "Something has gone horribly wrong; could not find cached cookies."+ }++{- |+ This function takes a SessionMap and provides a "Set-Cookie" header+ to set the SessionData to a newly minted value of your choice.+-}+updateCookies ::+ Key ->+ SessionMap ->+ SetCookie ->+ ByteString ->+ a ->+ IO (SetCookieHeader a)+updateCookies cookieEncryptKey sessionMap setCookieDefaults cookieName value = do+ -- let newCookies = newMap `Map.difference` oldMap+ -- changedCookies = Map.filterWithKey (checkIfMapValueChanged oldMap) oldMap+ -- setCookieList = fmap snd $ Map.toList $ Map.mapWithKey (keyValueToSetCookie setCookieDefaults) changedCookies+ let+ -- We use renderCookies with a long laborious function chain to+ -- avoid depending on the version of Web.Cookie that has the+ -- @renderCookiesBS@ function, which was introduced in a very+ -- recent of the cookies library. The prod code I'm writing this+ -- library for is still on lts-18.27, so I take some extra pains+ -- to still support that release.+ cookieBS :: ByteString+ cookieBS = toStrict . toLazyByteString . renderCookies $ Map.toList sessionMap++ sessionMapEncrypted <- encryptIO cookieEncryptKey cookieBS++ let+ setCookie =+ setCookieDefaults+ { setCookieName = cookieName+ , setCookieValue = sessionMapEncrypted+ }++ pure $ addHeader setCookie value++{- |+ This function clears session data, for a fresh, minty-clean+ experience. The archetypal use case is when a user logs out from+ your server.+-}+clearSession :: SetCookie -> a -> IO (SetCookieHeader a)+clearSession setCookieDefaults value = do+ now <- getCurrentTime+ let+ immediateMaxAge = secondsToDiffTime 0+ setCookie =+ setCookieDefaults+ { setCookieName = ""+ , setCookieValue = ""+ , setCookieExpires = Just now+ , setCookieMaxAge = Just immediateMaxAge+ }+ pure $ addHeader setCookie value
+ lib/Servant/API/HeaderList.hs view
@@ -0,0 +1,56 @@+{- |Description: This module provides a way to get _all_ the headers+ from a request, rather than asking for them piecemeal.+-}+module Servant.API.HeaderList where++import Network.Wai+import Servant+import Servant.Server.Internal.Delayed (passToServer)++import qualified Network.HTTP.Types.Header as NTH (Header)++{- |+ The HeaderList combinator provides a list of+ @Network.HTTP.Types.Header.Header@ values from the WAI request.++ Example:++@+import Control.Monad.IO.Class (liftIO)+import Servant+import ServantExtras.HeaderList++import qualified Network.HTTP.Types.Header as NTH (Header)++type MyAPI = "my-header-endpoint"+ :> HeaderList+ :> Get '[JSON] NoContent++myServer :: Server MyAPI+myServer = headerEndpointHandler+ where+ headerEndpointHandler :: [NTH.Header] -> Handler NoContent+ headerEndpointHandler headers =+ let mCookieValue = lookup "merlinWasHere" headers in+ case mCookieValue of+ Nothing -> do+ liftIO $ print "Merlin was *NOT* here!"+ throwError err400 { errBody = "Clearly you've missed something." }+ Just message -> do+ liftIO $ do+ print "Merlin WAS here, and he left us a message!"+ print message+ pure NoContent+@+-}+data HeaderList++instance HasServer api ctx => HasServer (HeaderList :> api) ctx where+ type ServerT (HeaderList :> api) m = [NTH.Header] -> ServerT api m++ hoistServerWithContext _ ctx nt server =+ hoistServerWithContext (Proxy @api) ctx nt . server+ route _ ctx server =+ route (Proxy @api) ctx $+ server `passToServer` \req ->+ requestHeaders req
+ lib/Servant/API/QueryString.hs view
@@ -0,0 +1,57 @@+{- |Description: Combinator for Servant to allow Handlers access to the full query+ string from the WAI request.+-}+module Servant.API.QueryString where++import Network.HTTP.Types (Query)+import Network.Wai+import Servant+import Servant.Server.Internal.Delayed (passToServer)++{- |+ @QueryString@ provides handlers access to the full query string from+ the WAI request, rather than pulling each element explicitly. This+ allows for dynamic query management, or to simply take in many+ queries in one argument.++ Example:++@+import Control.Monad.IO.Class (liftIO)+import Network.HTTP.Types (Query, renderQuery)+import Servant+import ServantExtras.QueryString++type MyAPI = "my-cookie-enabled-endpoint"+ :> QueryString+ :> Get '[JSON] NoContent++myServer :: Server MyAPI+myServer = queryEndpointHandler+ where+ queryEndpointHandler :: Query -> Handler NoContent+ queryEndpointHandler query = do+ liftIO $ print $ renderQuery True query+ let mCookieValue = lookup "merlinWasHere" query in+ case mCookieValue of+ Nothing -> do+ liftIO $ print "Merlin was *NOT* here!"+ throwError err400 { errBody = "Clearly you've missed something." }+ Just message -> do+ liftIO $ do+ print "Merlin WAS here, and he left us a message!"+ print message+ pure NoContent+@+-}+data QueryString++instance HasServer api ctx => HasServer (QueryString :> api) ctx where+ type ServerT (QueryString :> api) m = Query -> ServerT api m++ hoistServerWithContext _ ctx nt server =+ hoistServerWithContext (Proxy @api) ctx nt . server+ route _ ctx server =+ route (Proxy @api) ctx $+ server `passToServer` \req ->+ queryString req
+ lib/Servant/API/RawQueryString.hs view
@@ -0,0 +1,53 @@+{- |Description: Provides a combinator to access the Query String in+ its raw form, from the WAI request.+-}+module Servant.API.RawQueryString where++import Data.ByteString (ByteString)+import Network.Wai+import Servant+import Servant.Server.Internal.Delayed (passToServer)++{- |+ @RawQueryString@ gives handler authors a combinator to access the raw+ (that is, un-parsed) query string from the WAI request, as a+ ByteString.++ Generally speaking, you should prefer to use the @QueryString@+ combinator, but if you need access to the raw value, this combinator+ provides it.++ Example:++@+import Control.Monad.IO.Class (liftIO)+import Servant+import ServantExtras.RawQueryString++import qualified Network.HTTP.Types.Header as NTH (Header)++type MyAPI = "my-query-endpoint"+ :> RawQueryString+ :> Get '[JSON] NoContent++myServer :: Server MyAPI+myServer = queryEndpointHandler+ where+ queryEndpointHandler :: ByteString -> Handler NoContent+ queryEndpointHandler queryStr =+ -- do something with the ByteString, like pass it to a+ -- sub-process++@+-}+data RawQueryString++instance HasServer api ctx => HasServer (RawQueryString :> api) ctx where+ type ServerT (RawQueryString :> api) m = ByteString -> ServerT api m++ hoistServerWithContext _ ctx nt server =+ hoistServerWithContext (Proxy @api) ctx nt . server+ route _ ctx server =+ route (Proxy @api) ctx $+ server `passToServer` \req ->+ rawQueryString req
+ lib/Servant/API/RawRequest.hs view
@@ -0,0 +1,44 @@+{- |Description: Provide a combinator to give handlers access to the+ raw WAI request.+-}+module Servant.API.RawRequest where++import Network.Wai+import Servant+import Servant.Server.Internal.Delayed (passToServer)++{- |+ @RawRequest@ provides the `Network.Wai.Request` field from the WAI request.++ Example:++@+import Control.Monad.IO.Class (liftIO)+import Network.Wai+import Servant+import ServantExtras.RawRequest++type MyAPI = "my-request-endpoint"+ :> RawRequest+ :> Get '[JSON] NoContent++myServer :: Server MyAPI+myServer = requestEndpointHandler+ where+ requestEndpointHandler :: Request -> Handler NoContent+ requestEndpointHandler req =+ -- Do something clever with the request+ pure NoContent+@+-}+data RawRequest++instance HasServer api ctx => HasServer (RawRequest :> api) ctx where+ type ServerT (RawRequest :> api) m = Request -> ServerT api m++ hoistServerWithContext _ ctx nt server =+ hoistServerWithContext (Proxy @api) ctx nt . server+ route _ ctx server =+ route (Proxy @api) ctx $+ server `passToServer` \req ->+ req
+ servant-combinators.cabal view
@@ -0,0 +1,143 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.35.1.+--+-- see: https://github.com/sol/hpack++name: servant-combinators+version: 0.0.1+synopsis: Extra servant combinators for full WAI functionality.+description: Servant covers most of the data in a raw WAI request, but misses a few fields. This library aims to let handler authors get all the information about a request they need.+category: web+homepage: https://github.com/TheWizardTower/servant-combinators#readme+bug-reports: https://github.com/TheWizardTower/servant-combinators/issues+author: Adam McCullough <merlinfmct87@gmail.com>+maintainer: Adam McCullough <merlinfmct87@gmail.com>+copyright: © 2023 Adam McCullough+license: MIT+license-file: LICENSE+build-type: Simple+tested-with:+ GHC == 8.8.4 , GHC == 9.2.4++source-repository head+ type: git+ location: https://github.com/TheWizardTower/servant-combinators++library+ exposed-modules:+ Servant.API.Cookies+ Servant.API.HeaderList+ Servant.API.QueryString+ Servant.API.RawQueryString+ Servant.API.RawRequest+ other-modules:+ Paths_servant_combinators+ hs-source-dirs:+ lib+ default-extensions:+ DataKinds+ FlexibleInstances+ MultiParamTypeClasses+ OverloadedStrings+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeOperators+ ghc-options: -Wall -Wwarn -fwarn-tabs+ build-depends:+ QuickCheck+ , aeson+ , base >=4.14 && <4.17+ , bytestring+ , clientsession+ , containers+ , cookie+ , http-types+ , servant+ , servant-server+ , tasty+ , text+ , time+ , vault+ , wai+ default-language: Haskell2010++executable live-test+ main-is: LiveTest.hs+ hs-source-dirs:+ src+ default-extensions:+ DataKinds+ FlexibleInstances+ MultiParamTypeClasses+ OverloadedStrings+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeOperators+ ghc-options: -Wall -Wwarn -fwarn-tabs -threaded+ build-depends:+ QuickCheck+ , aeson+ , base >=4.14 && <4.17+ , bytestring+ , clientsession+ , containers+ , cookie+ , http-types+ , servant+ , servant-server+ , tasty+ , text+ , time+ , vault+ , wai+ default-language: Haskell2010++test-suite check+ type: exitcode-stdio-1.0+ main-is: Main.hs+ other-modules:+ TestCookies+ TestHeaders+ TestLib+ TestQueryString+ TestRawQueryString+ TestRawRequest+ hs-source-dirs:+ tests+ default-extensions:+ DataKinds+ FlexibleInstances+ MultiParamTypeClasses+ OverloadedStrings+ ScopedTypeVariables+ TypeApplications+ TypeFamilies+ TypeOperators+ ghc-options: -Wall -Wwarn -fwarn-tabs -threaded+ build-depends:+ QuickCheck+ , aeson+ , async+ , base >=4.14 && <4.17+ , bytestring+ , case-insensitive+ , clientsession+ , containers+ , cookie+ , http-client+ , http-conduit+ , http-types+ , servant+ , servant-combinators+ , servant-server+ , tasty+ , tasty-quickcheck+ , text+ , time+ , vault+ , wai+ , warp+ default-language: Haskell2010
+ src/LiveTest.hs view
@@ -0,0 +1,3 @@+main :: IO ()+main = do+ putStrLn "Main!"
+ tests/Main.hs view
@@ -0,0 +1,60 @@+module Main where++import Network.Wai.Handler.Warp (run)+import Servant+import Servant.API.Cookies (SessionMap)+import Test.Tasty+import TestCookies (CookieAPI, cookieProps, cookieServer)+import TestHeaders (HeaderAPI, headerProps, headerServer)+import TestLib (testFunctionGeneric)+import TestQueryString (QueryStrAPI, queryStrProps, queryStrServer)+import TestRawQueryString (RawQueryStrAPI, rawQueryStrProps, rawQueryStrServer)+import TestRawRequest (RawRequestAPI, rawRequestProps, rawRequestServer)+import Web.ClientSession++import qualified Data.Vault.Lazy as Vault++type TopLevelAPI =+ CookieAPI+ :<|> HeaderAPI+ :<|> QueryStrAPI+ :<|> RawQueryStrAPI+ :<|> RawRequestAPI++topLevelServer :: Key -> Server TopLevelAPI+topLevelServer encKey =+ cookieServer encKey+ :<|> headerServer+ :<|> queryStrServer+ :<|> rawQueryStrServer+ :<|> rawRequestServer++topLevelProps :: Key -> Int -> TestTree+topLevelProps key port =+ testGroup+ "Main tests"+ [ cookieProps key port+ , headerProps port+ , queryStrProps port+ , rawQueryStrProps port+ , rawRequestProps port+ ]++mkTestApplication :: Key -> IO Application+mkTestApplication encKey = do+ key <- Vault.newKey :: IO (Vault.Key SessionMap)+ pure $+ serveWithContext+ (Proxy @TopLevelAPI)+ (encKey :. key :. EmptyContext)+ (topLevelServer encKey)++runTopLevelServer :: Key -> Int -> IO ()+runTopLevelServer key port = do+ app <- mkTestApplication key+ run port app++main :: IO ()+main = do+ (_initKeyBS, encKey) <- randomKey+ testFunctionGeneric (runTopLevelServer encKey) (topLevelProps encKey) 8080
+ tests/TestCookies.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module TestCookies where++import Control.Monad.IO.Class (liftIO)+import Data.Bifunctor (bimap)+import Data.ByteString (ByteString)+import Data.CaseInsensitive (mk)+import Data.Map.Strict (Map)+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8)+import Network.HTTP.Client (method)+import Network.Wai+import Servant+import Servant.API.Cookies+import Servant.Server.Internal.Delayed (addAcceptCheck)+import Servant.Server.Internal.DelayedIO (DelayedIO, delayedFailFatal, withRequest)+import Test.QuickCheck.Monadic (PropertyM (..), assert, monadicIO)+import Test.Tasty+import TestLib (returns400, success)+import Web.ClientSession+import Web.Cookie++import qualified Data.Map.Strict as Map+import qualified Data.Vault.Lazy as Vault+import qualified Network.HTTP.Simple as S+import qualified Network.HTTP.Types.Header as NTH+import qualified Test.Tasty.QuickCheck as QC++data CheckTestCookie++instance+ ( HasServer api ctx+ , HasContextEntry ctx HasCookies+ , HasContextEntry ctx (Vault.Key SessionMap)+ ) =>+ HasServer (CheckTestCookie :> api) ctx+ where+ type ServerT (CheckTestCookie :> api) m = ServerT api m++ hoistServerWithContext _ ctx nt server =+ hoistServerWithContext (Proxy @api) ctx nt server++ route _ ctx server =+ route (Proxy @api) ctx $+ server `addAcceptCheck` checkTestCookie+ where+ checkTestCookie :: DelayedIO ()+ checkTestCookie = withRequest $ \req -> do+ let key = getContextEntry ctx :: Vault.Key SessionMap+ vlookup = Vault.lookup key (vault req) >>= Map.lookup "TEST_COOKIE"+ case vlookup of+ Just _ -> pure ()+ Nothing ->+ delayedFailFatal $+ err400+ { errBody = "TEST_COOKIE cookie not set."+ }++type CookieAPI =+ ProvideCookies '[Required]+ :> ( "add-cookie"+ :> Get '[JSON] (SetCookieHeader NoContent)+ :<|> "check-cookies"+ :> CheckTestCookie+ :> WithCookies '[Required]+ :> Get '[JSON] (Map Text Text)+ )++cookieServer :: Key -> Server CookieAPI+cookieServer key = addCookie key :<|> showCookie+ where+ addCookie :: Key -> Handler (SetCookieHeader NoContent)+ addCookie keyArg =+ let sMap =+ Map.fromList [("TEST_COOKIE", "FOOBAR")]+ in liftIO $+ updateCookies+ keyArg+ sMap+ defaultSetCookie+ "servant_cookie"+ NoContent++ showCookie :: SessionMap -> Handler (Map Text Text)+ showCookie sMap = do+ let kvs = Map.toList sMap+ pure $ Map.fromList $ fmap (bimap decodeUtf8 decodeUtf8) kvs++cookieProps :: Key -> Int -> TestTree+cookieProps encKey port =+ testGroup+ "Cookies"+ [ QC.testProperty "Fetching a non-existent cookie returns a 400" $+ monadicIO $ do+ result <- (fetchCheckCookieEndpoint port Nothing) >>= returns400+ assert $ result == True+ , QC.testProperty "Calling add-cookie returns a 200, and adds a Set-Cookie header" $+ monadicIO $ do+ res1 <- (fetchCreateCookieEndpoint port)+ assert1 <- success res1+ assert $ assert1 == True+ let setCookieStr = lookup NTH.hSetCookie $ S.getResponseHeaders res1+ setCookieParsed = setCookieValue . parseSetCookie <$> setCookieStr+ sCookieVal = setCookieParsed >>= decrypt encKey+ assert $ sCookieVal == Just "TEST_COOKIE=FOOBAR"+ , QC.testProperty "Fetching the create-cookie, then check-cookie endpoints should work" $+ monadicIO $ do+ res1 <- fetchCreateCookieEndpoint port+ assert1 <- success res1+ assert $ assert1 == True+ encCookieVal <- liftIO $ encryptIO encKey "TEST_COOKIE=FOOBAR"+ let+ cookieHeader :: [NTH.Header]+ cookieHeader = [((mk "Cookie" :: NTH.HeaderName), encCookieVal)]+ res2 <- fetchCheckCookieEndpoint port $ Just cookieHeader+ assert2 <- success res2+ assert $ assert2 == True+ ]+ where+ fetchCheckCookieEndpoint :: Int -> Maybe [NTH.Header] -> PropertyM IO (S.Response ByteString)+ fetchCheckCookieEndpoint port' mHeader = do+ let initReq = S.parseRequest_ $ "http://localhost:" <> (show port') <> "/check-cookies"+ headerList = maybe [] id mHeader+ foldFunction pair reqAcc = uncurry S.addRequestHeader pair reqAcc+ reqHeader = foldr foldFunction initReq headerList+ req = reqHeader {method = "GET"}+ in do+ resp <- S.httpBS req+ pure resp++ fetchCreateCookieEndpoint :: Int -> PropertyM IO (S.Response ByteString)+ fetchCreateCookieEndpoint port' = do+ let initReq = S.parseRequest_ $ "http://localhost:" <> (show port') <> "/add-cookie"+ req = initReq {method = "GET"}+ in do+ resp <- S.httpBS req+ pure resp
+ tests/TestHeaders.hs view
@@ -0,0 +1,73 @@+module TestHeaders where++import Data.ByteString (ByteString)+import Data.CaseInsensitive (mk)+import Network.HTTP.Client (method)+import Servant+import Servant.API.HeaderList+import Test.QuickCheck.Monadic (PropertyM (..), assert, monadicIO)+import Test.Tasty+import TestLib (returns400, success)++import qualified Network.HTTP.Simple as S+import qualified Network.HTTP.Types.Header as NTH+import qualified Test.Tasty.QuickCheck as QC++myHeaderList :: [NTH.Header]+myHeaderList =+ [+ ( (mk "MerlinWasHere" :: NTH.HeaderName)+ , "TEST_COOKIE=FOOBAR"+ )+ ,+ ( (mk "OtherHeader" :: NTH.HeaderName)+ , "FOOBAR"+ )+ ]++type HeaderAPI =+ "check-headers"+ :> HeaderList+ :> Get '[JSON] NoContent++headerServer :: Server HeaderAPI+headerServer = checkHeader+ where+ checkHeader :: [NTH.Header] -> Handler NoContent+ checkHeader headers = do+ let headerIntersection = all (\a -> elem a headers) myHeaderList+ case headerIntersection of+ True -> do+ pure NoContent+ False -> do+ throwError err400++headerProps :: Int -> TestTree+headerProps port =+ testGroup+ "HeaderList"+ [ QC.testProperty "The endpoint should error with no headers present" $+ monadicIO $ do+ result <- (fetchHeaderEndpoint port Nothing) >>= returns400+ assert $ result == True+ , QC.testProperty "The endpoint should return a 200 if a header is added" $+ monadicIO $ do+ result <- (fetchHeaderEndpoint port (Just $ myHeaderList)) >>= success+ assert $ result == True+ ]+ where+ fetchHeaderEndpoint :: Int -> Maybe [NTH.Header] -> PropertyM IO (S.Response ByteString)+ fetchHeaderEndpoint port' mHeaderList =+ let+ initReq =+ S.parseRequest_ $+ "http://localhost:"+ <> (show port')+ <> "/check-headers"+ headerList = maybe [] id mHeaderList+ reqHeader = S.setRequestHeaders headerList initReq+ req = reqHeader {method = "GET"}+ in+ do+ resp <- S.httpBS req+ pure resp
+ tests/TestLib.hs view
@@ -0,0 +1,28 @@+module TestLib where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (cancel, withAsync)+import Data.ByteString (ByteString)+import Test.QuickCheck.Monadic (PropertyM (..))+import Test.Tasty++import qualified Network.HTTP.Simple as S++testFunctionGeneric :: (Int -> IO a) -> (Int -> TestTree) -> Int -> IO ()+testFunctionGeneric server tests port = do+ withAsync (server port) $ \serverAsync -> do+ -- Sleep five seconds, to ensure the server can come online.+ threadDelay (5 * 100000)+ defaultMain $ tests port+ cancel serverAsync++success :: S.Response ByteString -> PropertyM IO Bool+success resp = do+ let respCode = S.getResponseStatusCode resp+ respBool = (respCode <= 200) && 299 >= respCode+ pure respBool++returns400 :: S.Response ByteString -> PropertyM IO Bool+returns400 resp = do+ let respCode = S.getResponseStatusCode resp+ pure $ respCode == 400
+ tests/TestQueryString.hs view
@@ -0,0 +1,73 @@+module TestQueryString where++import Data.ByteString+import Network.HTTP.Client (method)+import Network.HTTP.Types+import Servant+import Servant.API.QueryString+import Test.QuickCheck.Monadic (PropertyM (..), assert, monadicIO)+import Test.Tasty+import TestLib (returns400, success)++import qualified Network.HTTP.Simple as S+import qualified Test.Tasty.QuickCheck as QC++type QueryStrAPI =+ "check-query-flag" :> QueryString :> Get '[JSON] NoContent+ :<|> "check-query-value" :> QueryString :> Get '[JSON] NoContent++queryStrServer :: Server QueryStrAPI+queryStrServer = queryFlag :<|> queryVal+ where+ queryFlag :: Query -> Handler NoContent+ queryFlag query = do+ case lookup "test_value" query of+ Nothing -> throwError err400 {errBody = "Omitted query flag"}+ Just flag -> case flag of+ Nothing -> pure NoContent -- value was a flag, as we expect+ Just _b -> throwError err400 {errBody = "Flag was given a value, incorrect"}++ queryVal :: Query -> Handler NoContent+ queryVal query = do+ case lookup "test_value" query of+ Nothing -> throwError err400 {errBody = "Omitted query key-valke pair"}+ Just val -> case val of+ Nothing -> throwError err400 {errBody = "Value in key-value pair query omitted, incorrect"}+ Just _b -> pure NoContent++queryStrProps :: Int -> TestTree+queryStrProps port =+ testGroup+ "QueryString"+ [ QC.testProperty "Query flags should have a 'Nothing' as a value" $+ monadicIO $ do+ result <- (fetchEndpoint port "flag" "") >>= success+ assert $ result == True+ , QC.testProperty "Query Flag endpoint should error if given a value" $+ monadicIO $ do+ result <- (fetchEndpoint port "flag" "=value") >>= returns400+ assert $ result == True+ , QC.testProperty "Value endpoint expects a value" $+ monadicIO $ do+ result <- (fetchEndpoint port "value" "=value") >>= success+ assert $ result == True+ , QC.testProperty "Value endponit errors if given a flag" $+ monadicIO $ do+ result <- (fetchEndpoint port "value" "") >>= returns400+ assert $ result == True+ ]+ where+ fetchEndpoint :: Int -> String -> String -> PropertyM IO (S.Response ByteString)+ fetchEndpoint port' flagOrVal value = do+ let initReq =+ S.parseRequest_ $+ "http://localhost:"+ <> (show port')+ <> "/check-query-"+ <> flagOrVal+ <> "?test_value"+ <> value+ req = initReq {method = "GET"}+ in do+ resp <- S.httpBS req+ pure resp
+ tests/TestRawQueryString.hs view
@@ -0,0 +1,51 @@+module TestRawQueryString where++import Data.ByteString+import Network.HTTP.Client (method)+import Servant+import Servant.API.RawQueryString+import Test.QuickCheck.Monadic (PropertyM (..), assert, monadicIO)+import Test.Tasty+import TestLib (returns400, success)++import qualified Network.HTTP.Simple as S+import qualified Test.Tasty.QuickCheck as QC++type RawQueryStrAPI =+ "check-raw-query" :> RawQueryString :> Get '[JSON] NoContent++rawQueryStrServer :: Server RawQueryStrAPI+rawQueryStrServer = rawQuery+ where+ rawQuery :: ByteString -> Handler NoContent+ rawQuery rQuery = do+ case rQuery == "?test_value=foobar" of+ True -> pure NoContent+ False -> throwError err400 {errBody = "Invalid query flag passed."}++rawQueryStrProps :: Int -> TestTree+rawQueryStrProps port =+ testGroup+ "RawQueryString"+ [ QC.testProperty "Raw query endpoint recognizes the correct string" $+ monadicIO $ do+ result <- (fetchEndpoint port "?test_value=foobar") >>= success+ assert $ result == True+ , QC.testProperty "Raw query endpoint rejects incorrect string" $+ monadicIO $ do+ result <- (fetchEndpoint port "?invalid") >>= returns400+ assert $ result == True+ ]+ where+ fetchEndpoint :: Int -> String -> PropertyM IO (S.Response ByteString)+ fetchEndpoint port' value = do+ let initReq =+ S.parseRequest_ $+ "http://localhost:"+ <> (show port')+ <> "/check-raw-query"+ <> value+ req = initReq {method = "GET"}+ in do+ resp <- S.httpBS req+ pure resp
+ tests/TestRawRequest.hs view
@@ -0,0 +1,64 @@+module TestRawRequest where++import Data.ByteString+import Data.CaseInsensitive (mk)+import Network.HTTP.Client (method)+import Network.Wai (Request (..))+import Servant+import Servant.API.RawRequest+import Test.QuickCheck.Monadic (PropertyM (..), assert, monadicIO)+import Test.Tasty+import TestLib (returns400, success)++import qualified Network.HTTP.Simple as S+import qualified Network.HTTP.Types.Header as NTH+import qualified Test.Tasty.QuickCheck as QC++type RawRequestAPI =+ "check-raw-request" :> RawRequest :> Get '[JSON] NoContent++rawRequestServer :: Server RawRequestAPI+rawRequestServer = rawRequest+ where+ rawRequest :: Request -> Handler NoContent+ rawRequest req = do+ let reqHeaders = requestHeaders req+ reqQS = queryString req+ case (lookup "testHeader" reqHeaders, reqQS == [("test_query", Just "val")]) of+ (Just "foo", True) -> pure NoContent+ (_, _) -> throwError err400 {errBody = "Missing value"}++headerList :: [NTH.Header]+headerList = [(mk "testHeader", "foo")]++rawRequestProps :: Int -> TestTree+rawRequestProps port =+ testGroup+ "RawRequest"+ [ QC.testProperty "Raw Request holds the headers, query string of the original request." $+ monadicIO $ do+ result <- (fetchEndpoint port "?test_query=val" headerList) >>= success+ assert $ result == True+ , QC.testProperty "Raw Reuest rejects a request with missing headers" $+ monadicIO $ do+ result <- (fetchEndpoint port "?test_query=val" []) >>= returns400+ assert $ result == True+ , QC.testProperty "Raw Reuest rejects a request with missing query string" $+ monadicIO $ do+ result <- (fetchEndpoint port "?invalid" headerList) >>= returns400+ assert $ result == True+ ]+ where+ fetchEndpoint :: Int -> String -> [NTH.Header] -> PropertyM IO (S.Response ByteString)+ fetchEndpoint port' queryVal hList = do+ let initReq =+ S.parseRequest_ $+ "http://localhost:"+ <> (show port')+ <> "/check-raw-request"+ <> queryVal+ reqHeader = S.setRequestHeaders hList initReq+ req = reqHeader {method = "GET"}+ in do+ resp <- S.httpBS req+ pure resp