diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ -# Changelog for dormouse +# Changelog for dormouse-client + +## v0.2.0.0 + +- Added `IsUrl url` constraint to functions in `MonadDormouseTestClient` so that `asAnyUrl` can be applied to the supplied urls. This facilitates testing correct urls are supplied. ## Unreleased changes diff --git a/dormouse-client.cabal b/dormouse-client.cabal --- a/dormouse-client.cabal +++ b/dormouse-client.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 53a8941fce30957b33c0c2573f20f976e663b6a0d21e6feed28a68ff8b5d68e3 +-- hash: 196468c6e841b939083b6f97fca2642a4a3be8d5b8e7cf475711a583af3f470a name: dormouse-client -version: 0.1.0.1 +version: 0.2.0.0 synopsis: Simple, type-safe and testable HTTP client description: An HTTP client designed to be productive, easy to use, easy to test, flexible and safe! . @@ -97,7 +97,6 @@ Dormouse.Client.Types Dormouse.Client.Generators.Json Dormouse.Client.Generators.Text - Dormouse.Client.Generators.UriComponents Dormouse.Client.Headers.MediaTypeSpec Dormouse.Client.PayloadSpec Dormouse.Client.StatusSpec diff --git a/src/Dormouse/Client/Test/Class.hs b/src/Dormouse/Client/Test/Class.hs --- a/src/Dormouse/Client/Test/Class.hs +++ b/src/Dormouse/Client/Test/Class.hs @@ -25,6 +25,7 @@ import Dormouse.Client.Class ( MonadDormouseClient(..) ) import Dormouse.Client.Payload ( RawRequestPayload(..) ) import Dormouse.Client.Types ( HttpRequest(..), HttpResponse(..) ) +import Dormouse.Url ( IsUrl ) import Streamly ( SerialT ) import qualified Streamly.Prelude as S import qualified Streamly.External.ByteString as SEB @@ -33,12 +34,12 @@ -- | MonadDormouseTestClient describes the capability to send and receive specifically ByteString typed HTTP Requests and Responses class Monad m => MonadDormouseTestClient m where -- | Make the supplied HTTP request, expecting an HTTP response with a Lazy ByteString body to be delivered in some @MonadDormouseTest m@ - expectLbs :: HttpRequest scheme method LB.ByteString contentTag acceptTag -> m (HttpResponse LB.ByteString) + expectLbs :: IsUrl url => HttpRequest url method LB.ByteString contentTag acceptTag -> m (HttpResponse LB.ByteString) expectLbs req = do resp <- expectBs $ req {requestBody = LB.toStrict $ requestBody req} return $ resp {responseBody = LB.fromStrict $ responseBody resp} -- | Make the supplied HTTP request, expecting an HTTP response with a Strict ByteString body to be delivered in some @MonadDormouseTest m@ - expectBs :: HttpRequest scheme method SB.ByteString contentTag acceptTag -> m (HttpResponse SB.ByteString) + expectBs :: IsUrl url => HttpRequest url method SB.ByteString contentTag acceptTag -> m (HttpResponse SB.ByteString) expectBs req = do resp <- expectLbs $ req {requestBody = LB.fromStrict $ requestBody req} return $ resp {responseBody = LB.toStrict $ responseBody resp} diff --git a/test/Dormouse/Client/Generators/UriComponents.hs b/test/Dormouse/Client/Generators/UriComponents.hs deleted file mode 100644 --- a/test/Dormouse/Client/Generators/UriComponents.hs +++ /dev/null @@ -1,246 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Dormouse.Client.Generators.UriComponents - ( genValidScheme - , genInvalidScheme - , genValidUsername - , genInvalidUsername - , genValidPassword - , genInvalidPassword - , genValidUserInfo - , genInvalidUserInfo - , genValidIPv4 - , genValidRegName - , genValidHost - , genValidPort - , genValidAuthority - , genValidPathAbsAuth - , genValidPathAbsNoAuth - , genValidPathRel - , genValidQuery - , genValidFragment - , genValidAbsoluteUri - ) - where - -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 -import Data.ByteString.Internal (c2w, w2c) -import qualified Data.Char as C -import qualified Data.Text as T -import Dormouse.Uri.Encode -import Dormouse.Uri.RFC3986 -import Hedgehog -import qualified Hedgehog.Gen as Gen -import qualified Hedgehog.Range as Range - -genPercentEncoded :: Gen B.ByteString -genPercentEncoded = do - char <- Gen.filter C.isPrint Gen.unicode - let t = T.pack $ [char] - let percentEncoded = encodeUnless (const False) t - return $ percentEncoded - -genValidScheme :: Gen B.ByteString -genValidScheme = do - first <- Gen.filter isAsciiAlpha Gen.ascii - bs <- Gen.list (Range.constant 0 10) (Gen.filter isSchemeChar Gen.ascii) - return . B8.pack $ (first : bs ++ [':']) - -data SchemeFailureMode - = NonAsciiFirstChar - | InvalidSchemeChar - | NoTrailingSemicolon - -schemeFailureMode :: Int -> SchemeFailureMode -schemeFailureMode 1 = NonAsciiFirstChar -schemeFailureMode 2 = InvalidSchemeChar -schemeFailureMode 3 = NoTrailingSemicolon -schemeFailureMode _ = undefined - -genInvalidScheme :: Gen B.ByteString -genInvalidScheme = do - failureMode <- fmap schemeFailureMode $ Gen.element [1..3] - first <- case failureMode of - NonAsciiFirstChar -> Gen.filter (not . isAsciiAlpha) Gen.ascii - _ -> Gen.filter isAsciiAlpha Gen.ascii - remainder <- case failureMode of - InvalidSchemeChar -> do - let c = Gen.filter (\x -> (not $ isSchemeChar x) && x /= ':') Gen.ascii - Gen.list (Range.constant 1 10) c - _ -> do - let c = Gen.filter isSchemeChar Gen.ascii - Gen.list (Range.constant 0 10) c - let finalBs = case failureMode of - NoTrailingSemicolon -> first : remainder - _ -> first : remainder ++ [':'] - return $ B8.pack finalBs - -genUsernameChar :: Gen B.ByteString -genUsernameChar = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isUsernameChar Gen.ascii)] - -genValidUsername :: Gen B.ByteString -genValidUsername = do - list <- Gen.list (Range.constant 1 20) genUsernameChar - return $ B.intercalate "" list - -genInvalidUsername :: Gen B.ByteString -genInvalidUsername = do - invalids <- Gen.list (Range.constant 1 5) genInvalidUsernameChar - valids <- Gen.list (Range.constant 0 15) genUsernameChar - fmap (B.intercalate "") $ Gen.shuffle $ invalids ++ valids - where - genInvalidUsernameChar = fmap (B8.pack . return) $ Gen.filter (\x -> (not $ isUsernameChar x) && x /= '%' && C.isPrint x) Gen.ascii - -genPasswordChar :: Gen B.ByteString -genPasswordChar = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isPasswordChar Gen.ascii)] - -genValidPassword :: Gen B.ByteString -genValidPassword = do - list <- Gen.list (Range.constant 1 20) genPasswordChar - return $ B.intercalate "" list - -genInvalidPassword :: Gen B.ByteString -genInvalidPassword = do - invalids <- Gen.list (Range.constant 1 5) genInvalidPasswordChar - valids <- Gen.list (Range.constant 0 15) genPasswordChar - fmap (B.intercalate "") $ Gen.shuffle $ invalids ++ valids - where - genInvalidPasswordChar = fmap (B8.pack . return) $ Gen.filter (\x -> (not $ isPasswordChar x) && x /= '%' && C.isPrint x) Gen.ascii - -genValidUserInfo :: Gen B.ByteString -genValidUserInfo = do - username <- genValidUsername - maybePassword <- Gen.maybe genValidPassword - let passwordSuffix = maybe B.empty (B.cons $ c2w ':') maybePassword - return $ B.append (B.append username passwordSuffix) "@" - -data UserInfoFailureMode - = InvalidUsername - | InvalidPassword - | MissingAtSuffix - -userInfoFailureMode :: Int -> UserInfoFailureMode -userInfoFailureMode 1 = InvalidUsername -userInfoFailureMode 2 = InvalidPassword -userInfoFailureMode 3 = MissingAtSuffix -userInfoFailureMode _ = undefined - -genInvalidUserInfo :: Gen B.ByteString -genInvalidUserInfo = do - failureMode <- fmap userInfoFailureMode $ Gen.element [1..3] - username <- case failureMode of - InvalidUsername -> Gen.filter (B.all (\x -> w2c x /= ':')) genInvalidUsername -- if the username is supposed to be invalid, ensure that ':' is not present, otherwise the user info could be interpreted as valid if valid chars precede the ':' - _ -> genValidUsername - maybePassword <- case failureMode of - InvalidPassword -> fmap Just genInvalidPassword - _ -> Gen.maybe $ genValidPassword - let passwordSuffix = maybe B.empty (B.cons $ c2w ':') maybePassword - let complete = case failureMode of - MissingAtSuffix -> B.append (B.append username passwordSuffix) "#" - _ -> B.append (B.append username passwordSuffix) "@" - return complete - -genValidIPv4 :: Gen B.ByteString -genValidIPv4 = do - ipChars <- (\a b c d -> show a <> "." <> show b <> "." <> show c <> "." <> show d) <$> genOctet <*> genOctet <*> genOctet <*> genOctet - return $ B8.pack ipChars - where - genOctet = Gen.word8 Range.constantBounded - -genValidRegName :: Gen B.ByteString -genValidRegName = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isRegNameChar Gen.ascii)] - -genValidHost :: Gen B.ByteString -genValidHost = Gen.choice [genValidIPv4, genValidRegName] - -genValidPort :: Gen B.ByteString -genValidPort = fmap (B.append ":" . B8.pack . show) $ Gen.word16 Range.constantBounded - -genValidAuthority :: Gen B.ByteString -genValidAuthority = do - maybeUserInfo <- Gen.maybe genValidUserInfo - let userInfoPrefix = maybe B.empty id maybeUserInfo - host <- genValidHost - maybePort <- Gen.maybe genValidPort - let portSuffix = maybe B.empty id maybePort - return . B.append "//" . B.append userInfoPrefix $ B.append host portSuffix - -genPathChar :: Gen B.ByteString -genPathChar = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isPathChar Gen.ascii)] - -genPathSegment :: Gen B.ByteString -genPathSegment = fmap (B.intercalate "") $ Gen.list (Range.constant 0 20) genPathChar - -genPathSegmentNz :: Gen B.ByteString -genPathSegmentNz = fmap (B.intercalate "") $ Gen.list (Range.constant 1 20) genPathChar - -genPathCharNc :: Gen B.ByteString -genPathCharNc = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isPathCharNoColon Gen.ascii)] - -genPathSegmentNzNc :: Gen B.ByteString -genPathSegmentNzNc = fmap (B.intercalate "") $ Gen.list (Range.constant 1 20) genPathCharNc - -genPathsAbEmpty :: Gen B.ByteString -genPathsAbEmpty = do - components <- Gen.list (Range.constant 1 10) genPathSegment - return . B.append "/" $ B.intercalate "/" components - -genPathsAbsolute :: Gen B.ByteString -genPathsAbsolute = do - first <- genPathSegmentNz - components <- Gen.list (Range.constant 0 10) genPathSegment - return . B.append "/" . B.append first $ B.intercalate "/" components - -genPathsNoScheme :: Gen B.ByteString -genPathsNoScheme = do - first <- genPathSegmentNzNc - components <- Gen.list (Range.constant 0 10) genPathSegment - return . B.append first . B.append "/" $ B.intercalate "/" components - -genPathsRootless :: Gen B.ByteString -genPathsRootless = do - first <- genPathSegmentNz - components <- Gen.list (Range.constant 0 10) genPathSegment - return . B.append first . B.append "/" $ B.intercalate "/" components - -genValidPathsEmpty :: Gen B.ByteString -genValidPathsEmpty = return B.empty - -genValidPathAbsAuth :: Gen B.ByteString -genValidPathAbsAuth = Gen.choice [genPathsAbEmpty, genPathsAbsolute, genValidPathsEmpty] - -genValidPathAbsNoAuth :: Gen B.ByteString -genValidPathAbsNoAuth = Gen.choice [genPathsAbsolute, genPathsRootless, genValidPathsEmpty] - -genValidPathRel :: Gen B.ByteString -genValidPathRel = Gen.choice [genPathsAbsolute, genPathsNoScheme, genValidPathsEmpty] - -genQueryChar :: Gen B.ByteString -genQueryChar = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isQueryChar Gen.ascii)] - -genValidQuery :: Gen B.ByteString -genValidQuery = do - list <- Gen.list (Range.constant 1 50) genQueryChar - return $ B.append "?" $ B.intercalate "" list - -genFragmentChar :: Gen B.ByteString -genFragmentChar = Gen.frequency [(1, genPercentEncoded), (25, fmap (B8.pack . return) $ Gen.filter isFragmentChar Gen.ascii)] - -genValidFragment :: Gen B.ByteString -genValidFragment = do - list <- Gen.list (Range.constant 1 50) genFragmentChar - return $ B.append "#" $ B.intercalate "" list - -genValidAbsoluteUri :: Gen B.ByteString -genValidAbsoluteUri = do - scheme <- genValidScheme - authority <- Gen.maybe genValidAuthority - path <- case authority of - Just _ -> genValidPathAbsAuth - Nothing -> genValidPathAbsNoAuth - query <- Gen.maybe genValidQuery - fragment <- Gen.maybe genValidFragment - return . B.intercalate "" $ [scheme, maybe B.empty id authority, path, maybe B.empty id query, maybe B.empty id fragment] - - diff --git a/test/Dormouse/ClientSpec.hs b/test/Dormouse/ClientSpec.hs --- a/test/Dormouse/ClientSpec.hs +++ b/test/Dormouse/ClientSpec.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ViewPatterns #-} module Dormouse.ClientSpec ( spec @@ -29,6 +31,7 @@ , sentContentType :: MVar (Maybe B.ByteString) , sentAcceptHeader :: MVar (Maybe B.ByteString) , returnJson :: MVar (Maybe (LB.ByteString)) + , triggered :: MVar Bool } newtype TestM a = TestM { unTestM :: ReaderT TestEnv IO a } deriving (Functor, Applicative, Monad, MonadReader TestEnv, MonadIO, MonadThrow) @@ -37,18 +40,29 @@ runTestM deps app = flip runReaderT deps $ unTestM app instance MonadDormouseTestClient TestM where - expectLbs req = do - testEnv <- ask - _ <- liftIO . swapMVar (sentJson testEnv) . Just $ requestBody req - _ <- liftIO . swapMVar (sentContentType testEnv) . getHeaderValue "Content-Type" $ req - _ <- liftIO . swapMVar (sentAcceptHeader testEnv) . getHeaderValue "Accept" $ req - maybeResponseJson <- liftIO . readMVar $ returnJson testEnv - let respBs = maybe (encode ()) id $ maybeResponseJson - pure HttpResponse - { responseStatusCode = 200 - , responseHeaders = Map.empty - , responseBody = respBs - } + expectLbs (req @ HttpRequest { requestUrl = u, requestMethod = method, requestBody = body, requestHeaders = headers }) = do + let reqUrl = asAnyUrl u + case (reqUrl, method) of + ([url|https://starfleet.com/captains|], GET) -> do + testEnv <- ask + _ <- liftIO . swapMVar (triggered testEnv) $ True + pure HttpResponse + { responseStatusCode = 200 + , responseHeaders = Map.empty + , responseBody = encode () + } + _ -> do + testEnv <- ask + _ <- liftIO . swapMVar (sentJson testEnv) . Just $ requestBody req + _ <- liftIO . swapMVar (sentContentType testEnv) . getHeaderValue "Content-Type" $ req + _ <- liftIO . swapMVar (sentAcceptHeader testEnv) . getHeaderValue "Accept" $ req + maybeResponseJson <- liftIO . readMVar $ returnJson testEnv + let respBs = maybe (encode ()) id $ maybeResponseJson + pure HttpResponse + { responseStatusCode = 200 + , responseHeaders = Map.empty + , responseBody = respBs + } spec :: Spec spec = before setup $ do @@ -98,17 +112,25 @@ let actualJson = responseBody r actualJson === arbJson actualAcceptHeader === Nothing + it "matches the expected url and method" $ \(_, _, _, _, testEnv, _) -> do + hedgehog $ do + let req = get [https|https://starfleet.com/captains|] + r :: HttpResponse Value <- liftIO $ runTestM testEnv $ expectAs json req + t <- liftIO . readMVar $ triggered testEnv + t === True where setup = do sentJson' <- newMVar Nothing sentContentType' <- newMVar Nothing sentAcceptHeader' <- newMVar Nothing returnJson' <- newMVar Nothing + triggered' <- newMVar False let testEnv = TestEnv { sentJson = sentJson' , sentContentType = sentContentType' , sentAcceptHeader = sentAcceptHeader' , returnJson = returnJson' + , triggered = triggered' } let jsonGenRanges = JsonGenRanges { stringRanges = Range.constant 0 15