diff --git a/Hspec/Client.hs b/Hspec/Client.hs --- a/Hspec/Client.hs +++ b/Hspec/Client.hs @@ -2,8 +2,10 @@ import Hspec.Utils import qualified Hspec.Client.BasicAuth +import qualified Hspec.Client.Raw hspec :: IO [TestTree] hspec = do return . testGroup "Client" <$> Hspec.Client.BasicAuth.hspec + <> Hspec.Client.Raw.hspec diff --git a/Hspec/Client/BasicAuth.hs b/Hspec/Client/BasicAuth.hs --- a/Hspec/Client/BasicAuth.hs +++ b/Hspec/Client/BasicAuth.hs @@ -25,6 +25,7 @@ import Symantic.HTTP import Symantic.HTTP.Client import Symantic.HTTP.Server +import Hspec.Utils () import Hspec.Utils.Server api = diff --git a/Hspec/Client/Raw.hs b/Hspec/Client/Raw.hs new file mode 100644 --- /dev/null +++ b/Hspec/Client/Raw.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} +module Hspec.Client.Raw where + +import Data.Either (Either(..)) +import Data.Function (($)) +import System.IO (IO) +import Test.Hspec +import Test.Tasty +import Test.Tasty.Hspec +import Test.Tasty.HUnit (assertFailure) +import Text.Show (Show(..)) +import qualified Network.HTTP.Client as Client +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wai as Wai + +import Symantic.HTTP +import Symantic.HTTP.Client +import Symantic.HTTP.Server +import Hspec.Utils +import Hspec.Utils.Server + +api = "success" raw + "failure" raw + +srv = server api $ + route_success :!: + route_failure + where + route_success _req res = res $ Wai.responseLBS HTTP.ok200 [] "rawSuccess" + route_failure _req res = res $ Wai.responseLBS HTTP.badRequest400 [] "rawFailure" + +cli_success + :!: cli_failure + = client api + +hspec :: IO [TestTree] +hspec = testSpecs $ describe "raw" $ + beforeAll (runTestServer srv) $ + afterAll killTestServer $ do + it "raw on success" $ \TestServer{..} -> do + res <- runClient env (cli_success HTTP.methodGet) + case res of + Left e -> assertFailure $ show e + Right r -> do + Client.responseStatus r `shouldBe` HTTP.status200 + Client.responseBody r `shouldBe` "rawSuccess" + it "raw should return a Left in case of failure" $ \TestServer{..} -> do + res <- runClient env (cli_failure HTTP.methodGet) + case res of + Right (_a::ClientResponse) -> do + assertFailure "expected Left, but got Right" + Left (ClientError_FailureResponse r) -> do + Client.responseStatus r `shouldBe` HTTP.status400 + Client.responseBody r `shouldBe` "rawFailure" + Left e -> assertFailure $ "expected FailureResponse, but got " <> show e diff --git a/Hspec/Server.hs b/Hspec/Server.hs --- a/Hspec/Server.hs +++ b/Hspec/Server.hs @@ -2,8 +2,12 @@ import Hspec.Utils import qualified Hspec.Server.Error +import qualified Hspec.Server.Raw +import qualified Hspec.Server.Router hspec :: IO [TestTree] hspec = do return . testGroup "Server" <$> Hspec.Server.Error.hspec + <> Hspec.Server.Raw.hspec + <> Hspec.Server.Router.hspec diff --git a/Hspec/Server/Error.hs b/Hspec/Server/Error.hs --- a/Hspec/Server/Error.hs +++ b/Hspec/Server/Error.hs @@ -120,7 +120,6 @@ expectationFailure $ "badParam + badBody == badBody: " <> show badBothRes - badContentType = (HTTP.hContentType, "application/json") badAccept = (HTTP.hAccept, "application/json") badMethod = HTTP.methodGet diff --git a/Hspec/Server/Raw.hs b/Hspec/Server/Raw.hs new file mode 100644 --- /dev/null +++ b/Hspec/Server/Raw.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS -Wno-missing-signatures #-} +module Hspec.Server.Raw where + +import Data.Int (Int) +import Data.String (String, IsString(..)) +import System.IO (IO) +import Text.Show (Show(..)) +import qualified Control.Monad.Classes as MC +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wai as Wai +import qualified Network.Wai.Test as Wai +import qualified Network.Wai.Test +import Data.Function (const) + +import Symantic.HTTP +import Symantic.HTTP.Server +import Hspec.Utils + +api = "foo" raw + +rawApplication :: Show a => (Wai.Request -> a) -> Wai.Application +rawApplication f req res = + res $ Wai.responseLBS HTTP.ok200 [] (fromString $ show $ f req) + +hspec = testSpecs $ describe "Raw" $ do + it "runs applications" $ do + (`Wai.runSession` server api (rawApplication (const (42 :: Int)))) $ do + res <- Network.Wai.Test.request Wai.defaultRequest + { Wai.pathInfo = ["foo"] } + MC.exec @IO $ do + Wai.simpleBody res `shouldBe` "42" + it "gets the pathInfo modified" $ do + (`Wai.runSession` server api (rawApplication Wai.pathInfo)) $ do + res <- Network.Wai.Test.request Wai.defaultRequest + { Wai.pathInfo = ["foo", "bar"] } + MC.exec @IO $ do + Wai.simpleBody res `shouldBe` fromString (show ["bar" :: String]) diff --git a/Hspec/Server/Router.hs b/Hspec/Server/Router.hs new file mode 100644 --- /dev/null +++ b/Hspec/Server/Router.hs @@ -0,0 +1,186 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS -Wno-missing-signatures #-} +{-# OPTIONS -Wno-orphans #-} +module Hspec.Server.Router where + +import Control.Monad (unless) +import Data.Bool +import Data.Char (Char) +import Data.Eq (Eq(..)) +import Data.Int (Int) +import Data.String (String) +import System.IO (IO, putStrLn) +import Text.Show (Show(..)) +import qualified Control.Monad.Classes as MC +import qualified Data.List as List +import qualified Data.Map.Strict as Map +import qualified Network.Wai.Handler.Warp as Warp +import qualified Test.Hspec as Hspec + +import Symantic.HTTP +import Symantic.HTTP.Server +import Hspec.Utils + +hspec = testSpecs $ describe "Router" $ do + it "distributes endpoints through static paths" $ do + inp_Endpoint `shouldRouteAs` exp_Endpoint + it "distributes nested routes through static paths" $ do + inp_Static `shouldRouteAs` exp_Static + it "properly reorders permuted static paths" $ do + inp_Permute `shouldRouteAs` exp_Permute + it "properly reorders permuted static paths in the presence of raw in end" $ do + inp_PermuteRawEnd `shouldRouteAs` exp_PermuteRawEnd + it "properly reorders permuted static paths in the presence of raw in beginning" $ do + inp_PermuteRawBegin `shouldRouteAs` exp_PermuteRawBegin + it "properly reorders permuted static paths in the presence of raw in middle" $ do + inp_PermuteRawMiddle `shouldRouteAs` exp_PermuteRawMiddle + {- NOTE: this is semantically incorrect. + it "distributes nested routes through dynamic paths" $ do + inp_Dynamic `shouldRouteAs` exp_Dynamic + -} + it "properly handles mixing static paths at different levels" $ do + inp_Level `shouldRouteAs` exp_Level + +-- * Utils + +routerEq :: + forall repr a b c d. repr ~ Server => + Router repr a b -> Router repr c d -> Bool +routerEq x0 y0 = + {- + let r = go + (Dbg.trace ("eq: x: " <> show x0) x0) + (Dbg.trace ("eq: y: " <> show y0) y0) in + Dbg.trace ("eq: r: " <> show r) r + -} + go x0 y0 + where + go :: Router repr a b -> Router repr c d -> Bool + go (Router_Seg x) (Router_Seg y) = x == y + go (Router_Cat xa xb) (Router_Cat ya yb) = routerEq xa ya && routerEq xb yb + go (Router_Alt xl xr) (Router_Alt yl yr) = routerEq xl yl && routerEq xr yr + go (Router_Cap xn) (Router_Cap yn) = xn == yn + go (Router_Map xs) (Router_Map ys) = + let xl = Map.toList xs in + let yl = Map.toList ys in + (List.length xl == List.length yl &&) $ + List.and $ + (\((kx, x),(ky, y)) -> kx==ky && routerEq x y) <$> + List.zip xl yl + go (Router_Caps xs) (Router_Caps ys) = goCaps xs ys + where + goCaps :: Captures (Router repr) xs b -> Captures (Router repr) ys d -> Bool + goCaps (Captures0 _xa xn xr) (Captures0 _ya yn yr) = xn == yn && routerEq xr yr + goCaps (Captures2 xx xy) (Captures2 yx yy) = goCaps xx yx && goCaps xy yy + goCaps _ _ = False -- FIXME: may wrongly return False if captures are not in the same order + go (Router_Union _u x) y = routerEq x y + go x (Router_Union _u y) = routerEq x y + go Router_Any{} Router_Any{} = True + go _x _y = False + +shouldRouteAs :: Router Server a b -> Router Server c d -> Hspec.Expectation +shouldRouteAs inp exp = + let inpR = router inp in + let expR = router exp in + unless (inpR`routerEq`expR) $ + Hspec.expectationFailure $ "expected:\n" <> show expR <> "\nbut got:\n" <> show inpR + +-- * APIs + +end = get @String @'[PlainText] + +inp_Endpoint = "a" end "a" end +exp_Endpoint = "a" (end end) + +inp_Static = "a" "b" end "a" "c" end +exp_Static = "a" ("b" end "c" end) + +{- +inp_Dynamic = + "a" capture @Int "foo" <.> "b" end + "a" capture @Bool "bar" <.> "c" end + "a" capture @Char "baz" <.> "d" end +exp_Dynamic = + "a" captures (Captures2 (Captures2 (Captures0 (Proxy @(Int -> Res)) "foo") + (Captures0 (Proxy @(Bool -> Res)) "bar")) + (Captures0 (Proxy @(Char -> Res)) "baz")) + <.> ("b" end "c" end "d" end) +type Res = ResponseArgs (Router Server) String '[PlainText] +-} + +inp_Permute = + "a" "b" "c" end + "b" "a" "c" end + "a" "c" "b" end + "c" "a" "b" end + "b" "c" "a" end + "c" "b" "a" end + "a" "a" "b" end + "a" "a" "c" end +exp_Permute = + "a" ("b" "c" end + "c" "b" end + "a" "b" end) + "b" ("a" "c" end + "c" "a" end) + "c" ("a" "b" end + "b" "a" end) + "a" "a" "c" end + +inp_PermuteRawEnd = + "a" "b" "c" end + "b" "a" "c" end + "a" "c" "b" end + "c" "a" "b" end + "b" "c" "a" end + "c" "b" "a" end + "a" "a" "b" end + "a" "a" "c" end + raw +exp_PermuteRawEnd = exp_Permute raw + +inp_PermuteRawBegin = + raw + "a" "b" "c" end + "b" "a" "c" end + "a" "c" "b" end + "c" "a" "b" end + "b" "c" "a" end + "c" "b" "a" end + "a" "a" "b" end + "a" "a" "c" end +exp_PermuteRawBegin = raw exp_Permute + +inp_PermuteRawMiddle = + "a" "b" "c" end + "b" "a" "c" end + "a" "c" "b" end + raw + "c" "a" "b" end + "b" "c" "a" end + "c" "b" "a" end +exp_PermuteRawMiddle = + "a" ("b" "c" end + "c" "b" end) + "b" "a" "c" end + raw + "b" "c" "a" end + "c" ("a" "b" end + "b" "a" end) + +inp_Level1 = + "a" "b" end + "a" end +inp_Level2 = + "b" end + "a" "c" end + end +inp_Level = + inp_Level1 + inp_Level2 +exp_Level = + "a" ("b" end "c" end end) + "b" end + end diff --git a/Hspec/Utils.hs b/Hspec/Utils.hs --- a/Hspec/Utils.hs +++ b/Hspec/Utils.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Hspec.Utils ( module Test.Hspec , module Test.Tasty , module Test.Tasty.Hspec + , module Hspec.Utils , ($), (.) , Functor(..), (<$>) , Applicative(..) @@ -10,12 +13,56 @@ , IO ) where +import Data.Bool +import Data.Eq (Eq(..)) +import Data.Maybe (Maybe(..)) +import Data.Ord (Ord(..)) +import Data.Semigroup (Semigroup(..)) import Control.Applicative (Applicative(..)) import Control.Monad (Monad(..), (=<<)) -import Data.Function (($), (.)) +import Data.Function (($), (.), id) import Data.Functor (Functor(..), (<$>)) -import Data.Semigroup (Semigroup(..)) import System.IO (IO) import Test.Hspec import Test.Tasty import Test.Tasty.Hspec +import Text.Show (Show(..), showString, showParen, ShowS) +import qualified Data.Map.Strict as Map +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import qualified Test.Hspec.Wai as Wai + +import Symantic.HTTP +import Symantic.HTTP.Server + +instance (repr ~ Server) => Show (Router repr a b) where + showsPrec p = \case + Router_Any{} -> showString "X" + Router_Map ms -> showParen (p>=10) $ showString "map [" . go (Map.toList ms) . showString "]" + where + go :: forall h k. [(PathSegment, Router repr h k)] -> ShowS + go [] = id + go ((n, r):xs) = + (showParen True $ showString (show n<>", ") . showsPrec 0 r) . + case xs of + [] -> id + _ -> showString ", " . go xs + Router_Seg s -> showsPrec 10 s + Router_Cat x y -> showParen (p>=4) $ showsPrec 4 x . showString " <.> " . showsPrec 4 y + Router_Alt x y -> showParen (p>=3) $ showsPrec 3 x . showString " " . showsPrec 3 y + Router_Cap n -> showString (":"<>n) + Router_Union _u x -> showsPrec p x + Router_Caps cs -> showParen (p>=10) $ showString "cap [" . go cs . showString "]" + where + go :: Captures (Router repr) cs k -> ShowS + go (Captures0 _a n r) = showParen True $ showString (":"<>n<>", ") . showsPrec 0 r + go (Captures2 x y) = go x . showString ", " . go y + +mkBody :: Wai.Body -> Wai.MatchBody +mkBody b = Wai.MatchBody $ \_ b' -> + if b == b' + then Nothing + else Just $ TL.unpack $ + "expecting: "<>TL.decodeUtf8 b<> + " but got: "<>TL.decodeUtf8 b'<>"\n" + diff --git a/symantic-http-test.cabal b/symantic-http-test.cabal --- a/symantic-http-test.cabal +++ b/symantic-http-test.cabal @@ -2,7 +2,7 @@ -- PVP: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.0.0.20190324 +version: 0.0.1.20190410 category: Protocol synopsis: Test symantic-http and its companion libraries description: @@ -41,9 +41,12 @@ Hspec Hspec.Client Hspec.Client.BasicAuth + Hspec.Client.Raw Hspec.Pipes Hspec.Server Hspec.Server.Error + Hspec.Server.Raw + Hspec.Server.Router Hspec.Utils Hspec.Utils.Server -- HUnit @@ -71,9 +74,9 @@ -fno-warn-tabs -fhide-source-paths build-depends: - symantic-http >= 0.0 + symantic-http >= 0.1.1 , symantic-http-client >= 0.0 - , symantic-http-server >= 0.0 + , symantic-http-server >= 0.1.1 , symantic-http-pipes >= 0.0 , base >= 4.10 && < 5 , base64-bytestring >= 1.0.0.1