diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2023 Adam McCullough + +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. diff --git a/lib/Servant/API/Cookies.hs b/lib/Servant/API/Cookies.hs new file mode 100644 --- /dev/null +++ b/lib/Servant/API/Cookies.hs @@ -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 diff --git a/lib/Servant/API/HeaderList.hs b/lib/Servant/API/HeaderList.hs new file mode 100644 --- /dev/null +++ b/lib/Servant/API/HeaderList.hs @@ -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 diff --git a/lib/Servant/API/QueryString.hs b/lib/Servant/API/QueryString.hs new file mode 100644 --- /dev/null +++ b/lib/Servant/API/QueryString.hs @@ -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 diff --git a/lib/Servant/API/RawQueryString.hs b/lib/Servant/API/RawQueryString.hs new file mode 100644 --- /dev/null +++ b/lib/Servant/API/RawQueryString.hs @@ -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 diff --git a/lib/Servant/API/RawRequest.hs b/lib/Servant/API/RawRequest.hs new file mode 100644 --- /dev/null +++ b/lib/Servant/API/RawRequest.hs @@ -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 diff --git a/servant-combinators.cabal b/servant-combinators.cabal new file mode 100644 --- /dev/null +++ b/servant-combinators.cabal @@ -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 +maintainer: Adam McCullough +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 diff --git a/src/LiveTest.hs b/src/LiveTest.hs new file mode 100644 --- /dev/null +++ b/src/LiveTest.hs @@ -0,0 +1,3 @@ +main :: IO () +main = do + putStrLn "Main!" diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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 diff --git a/tests/TestCookies.hs b/tests/TestCookies.hs new file mode 100644 --- /dev/null +++ b/tests/TestCookies.hs @@ -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 diff --git a/tests/TestHeaders.hs b/tests/TestHeaders.hs new file mode 100644 --- /dev/null +++ b/tests/TestHeaders.hs @@ -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 diff --git a/tests/TestLib.hs b/tests/TestLib.hs new file mode 100644 --- /dev/null +++ b/tests/TestLib.hs @@ -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 diff --git a/tests/TestQueryString.hs b/tests/TestQueryString.hs new file mode 100644 --- /dev/null +++ b/tests/TestQueryString.hs @@ -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 diff --git a/tests/TestRawQueryString.hs b/tests/TestRawQueryString.hs new file mode 100644 --- /dev/null +++ b/tests/TestRawQueryString.hs @@ -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 diff --git a/tests/TestRawRequest.hs b/tests/TestRawRequest.hs new file mode 100644 --- /dev/null +++ b/tests/TestRawRequest.hs @@ -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