From 27034d594e3570b19750a1bd978d22dd7e7f1854 Mon Sep 17 00:00:00 2001 From: Anton Kholomiov Date: Fri, 3 Nov 2023 19:45:12 +0300 Subject: [PATCH 1/7] Adds API tests --- Makefile | 2 +- mig-server/mig-server.cabal | 9 +++-- mig/mig.cabal | 25 ++++++++++++++ mig/package.yaml | 61 +++++++++++++++++++++------------ mig/test/Spec.hs | 7 ++++ mig/test/Test/Api.hs | 67 +++++++++++++++++++++++++++++++++++++ 6 files changed, 143 insertions(+), 28 deletions(-) create mode 100644 mig/test/Spec.hs create mode 100644 mig/test/Test/Api.hs diff --git a/Makefile b/Makefile index 41f2137..9595e10 100644 --- a/Makefile +++ b/Makefile @@ -4,7 +4,7 @@ build: stack build test: - stack test + stack test mig run: stack run diff --git a/mig-server/mig-server.cabal b/mig-server/mig-server.cabal index 335106d..4742363 100644 --- a/mig-server/mig-server.cabal +++ b/mig-server/mig-server.cabal @@ -37,24 +37,23 @@ description: With library mig we can build lightweight and composable ser > -- | Init simple hello world server whith two routes: > server :: Server IO > server = - > "api" /. "v1" /. - > mconcat + > "api/v1" /. > [ "hello" /. hello > , "bye" /. bye > ] > > -- | Handler takes no inputs and marked as Get HTTP-request that returns Text. > hello :: Get (Resp Text) - > hello = Get $ pure $ ok "Hello World" + > hello = pure $ ok "Hello World" > > -- | Handle with URL-param query and json body input as Post HTTP-request that returns Text. > bye :: Query "name" Text -> Body Text -> Post (Resp Text) - > bye (Query name) (Body greeting) = Post $ + > bye (Query name) (Body greeting) = > pure $ ok $ "Bye to " <> name <> " " <> greeting . Please see: . - * quick start guide at + * quick start guide at . * examples directory for more fun servers: at category: Web diff --git a/mig/mig.cabal b/mig/mig.cabal index bb566ff..9f38798 100644 --- a/mig/mig.cabal +++ b/mig/mig.cabal @@ -88,3 +88,28 @@ library , text , transformers default-language: GHC2021 + +test-suite mig-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.Api + hs-source-dirs: + test + default-extensions: + OverloadedStrings + TypeFamilies + OverloadedRecordDot + DuplicateRecordFields + LambdaCase + DerivingStrategies + StrictData + AllowAmbiguousTypes + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wunused-packages -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , containers + , hspec + , mig + , text + default-language: GHC2021 diff --git a/mig/package.yaml b/mig/package.yaml index 0e52777..3b633c0 100644 --- a/mig/package.yaml +++ b/mig/package.yaml @@ -28,28 +28,6 @@ description: | . * examples directory for more fun servers: at -dependencies: -- base >= 4.7 && < 5 -- aeson -- text -- http-types -- blaze-html -- bytestring -- containers -- mtl -- exceptions -- http-api-data -- http-media -- case-insensitive -- safe -- openapi3 -- filepath -- extra -- insert-ordered-containers -- lens -- lrucache -- transformers - default-extensions: - OverloadedStrings - TypeFamilies @@ -77,3 +55,42 @@ ghc-options: library: source-dirs: src + dependencies: + - base >= 4.7 && < 5 + - aeson + - text + - http-types + - blaze-html + - bytestring + - containers + - mtl + - exceptions + - http-api-data + - http-media + - case-insensitive + - safe + - openapi3 + - filepath + - extra + - insert-ordered-containers + - lens + - lrucache + - transformers + +tests: + mig-test: + main: Spec.hs + other-modules: + Test.Api + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - base >= 4.7 && < 5 + - containers + - mig + - hspec + - text + diff --git a/mig/test/Spec.hs b/mig/test/Spec.hs new file mode 100644 index 0000000..7c4db64 --- /dev/null +++ b/mig/test/Spec.hs @@ -0,0 +1,7 @@ +import Test.Api qualified as Api + +import Test.Hspec + +main :: IO () +main = + hspec $ Api.spec diff --git a/mig/test/Test/Api.hs b/mig/test/Test/Api.hs new file mode 100644 index 0000000..f304810 --- /dev/null +++ b/mig/test/Test/Api.hs @@ -0,0 +1,67 @@ +module Test.Api (spec) where + +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Mig.Core.Api +import Test.Hspec + +spec :: Spec +spec = describe "Api tests" $ do + checkRoutes + checkCaptures + checkFlatApi + +-- static routes + +checkRoutes :: Spec +checkRoutes = do + it "enter route (positive cases)" $ do + getPath ["api", "v1", "hello"] helloApi `shouldBe` Just ("hello", mempty) + getPath ["api", "v1", "bye"] helloApi `shouldBe` Just ("bye", mempty) + it "enter route (negative cases)" $ do + getPath ["api", "v1"] helloApi `shouldBe` Nothing + getPath [] helloApi `shouldBe` Nothing + getPath ["api", "v1", "hello", "there"] helloApi `shouldBe` Nothing + getPath ["api", "v1"] (mempty @(Api Text)) `shouldBe` Nothing + getPath [] (mempty @(Api Text)) `shouldBe` Nothing + +helloApi :: Api Text +helloApi = + WithPath "api/v1" $ + mconcat + [ WithPath "hello" (HandleRoute "hello") + , WithPath "bye" (HandleRoute "bye") + ] + +-- flat api + +checkFlatApi :: Spec +checkFlatApi = + it "flat api" $ + flatApi helloApi + `shouldBe` [ ("api/v1/hello", "hello") + , ("api/v1/bye", "bye") + ] + +-- captures + +checkCaptures :: Spec +checkCaptures = do + it "captures (positive cases)" $ do + getPath ["api", "capture1", "hello"] captureApi + `shouldBe` Just ("capture1", Map.fromList [("name1", "hello")]) + getPath ["api", "capture2", "hello", "bye"] captureApi + `shouldBe` Just ("capture2", Map.fromList [("name1", "hello"), ("name2", "bye")]) + + it "captures (negative cases)" $ do + getPath ["api", "capture1"] captureApi `shouldBe` Nothing + getPath ["api", "capture2", "hello"] captureApi `shouldBe` Nothing + getPath ["api", "capture2", "hello", "bye", "error"] captureApi `shouldBe` Nothing + +captureApi :: Api Text +captureApi = + WithPath "api" $ + mconcat + [ WithPath ("capture1" <> Path [CapturePath "name1"]) (HandleRoute "capture1") + , WithPath ("capture2" <> Path [CapturePath "name1", CapturePath "name2"]) (HandleRoute "capture2") + ] From f469c2637b0fea2bc87d991b85b6d0e18eb135c4 Mon Sep 17 00:00:00 2001 From: Anton Kholomiov Date: Fri, 3 Nov 2023 20:24:54 +0300 Subject: [PATCH 2/7] Adds hwllo wrold server tests --- mig/mig.cabal | 6 ++- mig/package.yaml | 3 ++ mig/src/Mig/Core/Types/Http.hs | 2 + mig/test/Spec.hs | 5 +- mig/test/Test/Api.hs | 2 +- mig/test/Test/Server/Hello.hs | 85 ++++++++++++++++++++++++++++++++++ 6 files changed, 99 insertions(+), 4 deletions(-) create mode 100644 mig/test/Test/Server/Hello.hs diff --git a/mig/mig.cabal b/mig/mig.cabal index 9f38798..0125e55 100644 --- a/mig/mig.cabal +++ b/mig/mig.cabal @@ -93,7 +93,7 @@ test-suite mig-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - Test.Api + Test.Api Test.Server.Hello hs-source-dirs: test default-extensions: @@ -107,9 +107,11 @@ test-suite mig-test AllowAmbiguousTypes ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -Wunused-packages -threaded -rtsopts -with-rtsopts=-N build-depends: - base >=4.7 && <5 + aeson + , base >=4.7 && <5 , containers , hspec + , http-types , mig , text default-language: GHC2021 diff --git a/mig/package.yaml b/mig/package.yaml index 3b633c0..f644109 100644 --- a/mig/package.yaml +++ b/mig/package.yaml @@ -82,15 +82,18 @@ tests: main: Spec.hs other-modules: Test.Api + Test.Server.Hello source-dirs: test ghc-options: - -threaded - -rtsopts - -with-rtsopts=-N dependencies: + - aeson - base >= 4.7 && < 5 - containers - mig - hspec - text + - http-types diff --git a/mig/src/Mig/Core/Types/Http.hs b/mig/src/Mig/Core/Types/Http.hs index f045d68..b9ac03a 100644 --- a/mig/src/Mig/Core/Types/Http.hs +++ b/mig/src/Mig/Core/Types/Http.hs @@ -46,6 +46,7 @@ data Response = Response , body :: ResponseBody -- ^ response body } + deriving (Show, Eq) -- | Response with no content noContentResponse :: Status -> Response @@ -56,6 +57,7 @@ data ResponseBody = RawResp MediaType BL.ByteString | FileResp FilePath | StreamResp + deriving (Show, Eq) -- | Http request data Request = Request diff --git a/mig/test/Spec.hs b/mig/test/Spec.hs index 7c4db64..da6d373 100644 --- a/mig/test/Spec.hs +++ b/mig/test/Spec.hs @@ -1,7 +1,10 @@ import Test.Api qualified as Api +import Test.Server.Hello qualified as Server.Hello import Test.Hspec main :: IO () main = - hspec $ Api.spec + hspec $ do + Api.spec + Server.Hello.spec diff --git a/mig/test/Test/Api.hs b/mig/test/Test/Api.hs index f304810..e0b174c 100644 --- a/mig/test/Test/Api.hs +++ b/mig/test/Test/Api.hs @@ -6,7 +6,7 @@ import Mig.Core.Api import Test.Hspec spec :: Spec -spec = describe "Api tests" $ do +spec = describe "api" $ do checkRoutes checkCaptures checkFlatApi diff --git a/mig/test/Test/Server/Hello.hs b/mig/test/Test/Server/Hello.hs new file mode 100644 index 0000000..51d4f30 --- /dev/null +++ b/mig/test/Test/Server/Hello.hs @@ -0,0 +1,85 @@ +module Test.Server.Hello (spec) where + +import Data.Aeson qualified as Json +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Mig.Core +import Mig.Core qualified as Request (Request (..)) +import Network.HTTP.Types.Method (methodGet, methodPost) +import Network.HTTP.Types.Status (ok200) +import Test.Hspec + +-- hello world server + +server :: Server IO +server = + "api/v1" + /. [ "hello" /. handleHello + , "bye" /. handleBye + ] + +handleHello :: Get IO (Resp Json Text) +handleHello = pure $ ok "hello" + +handleBye :: Get IO (Resp Json Text) +handleBye = pure $ ok "bye" + +-- tests + +-- we use low-level representation of server as a function: Request -> m (Maybe Response) +-- to check server properties without wpawning a full server environment +spec :: Spec +spec = describe "hello world server" $ do + describe "plain route finder" $ specBy plainApiStrategy + describe "tree route finder" $ specBy treeApiStrategy + +specBy :: FindRoute nf IO -> Spec +specBy finder = do + checkPositiveRoutes + checkNegativeRoutes + where + serverFun :: ServerFun IO + serverFun = fromServer finder server + + checkPositiveRoutes = do + it "call routes (positive case)" $ do + serverFun helloReq `shouldReturn` helloResp + serverFun byeReq `shouldReturn` byeResp + + checkNegativeRoutes = do + describe "negative cases" $ do + it "wrong path" $ do + serverFun emptyReq `shouldReturn` Nothing + serverFun wrongPathReq `shouldReturn` Nothing + it "wrong method" $ do + serverFun (helloReq{Request.method = methodPost}) `shouldReturn` Nothing + it "wrong output media type" $ do + serverFun (helloReq{Request.headers = Map.fromList [("Accept", "text/html")]}) `shouldReturn` Nothing + + helloReq = emptyReq{path = ["api", "v1", "hello"]} + helloResp = Just $ jsonResp @Text "hello" + + byeReq = emptyReq{path = ["api", "v1", "bye"]} + byeResp = Just $ jsonResp @Text "bye" + + wrongPathReq = emptyReq{path = ["api", "v2", "hello"]} + +emptyReq :: Request +emptyReq = + Request + { path = [] + , query = mempty + , capture = mempty + , headers = Map.fromList [("Accept", "application/json")] + , method = methodGet + , readBody = pure (Right "") + , isSecure = False + } + +jsonResp :: (Json.ToJSON a) => a -> Response +jsonResp a = + Response + { status = ok200 + , headers = [("Content-Type", "application/json")] + , body = RawResp "application/json" (Json.encode a) + } From 24d18020328b8d8f40830443f5bb40e6df9836dc Mon Sep 17 00:00:00 2001 From: Anton Kholomiov Date: Fri, 3 Nov 2023 20:40:21 +0300 Subject: [PATCH 3/7] Add more test server cases --- mig/test/Spec.hs | 3 +- mig/test/Test/Api.hs | 49 ++++++++++++++++++------------- mig/test/Test/Server.hs | 12 ++++++++ mig/test/Test/Server/Counter.hs | 6 ++++ mig/test/Test/Server/Hello.hs | 2 +- mig/test/Test/Server/RouteArgs.hs | 6 ++++ 6 files changed, 56 insertions(+), 22 deletions(-) create mode 100644 mig/test/Test/Server.hs create mode 100644 mig/test/Test/Server/Counter.hs create mode 100644 mig/test/Test/Server/RouteArgs.hs diff --git a/mig/test/Spec.hs b/mig/test/Spec.hs index da6d373..3218caf 100644 --- a/mig/test/Spec.hs +++ b/mig/test/Spec.hs @@ -7,4 +7,5 @@ main :: IO () main = hspec $ do Api.spec - Server.Hello.spec + describe "server" $ do + Server.Hello.spec diff --git a/mig/test/Test/Api.hs b/mig/test/Test/Api.hs index e0b174c..9f249ea 100644 --- a/mig/test/Test/Api.hs +++ b/mig/test/Test/Api.hs @@ -11,6 +11,9 @@ spec = describe "api" $ do checkCaptures checkFlatApi +notFound :: (Show a, Eq a) => Maybe a -> Expectation +notFound a = a `shouldBe` Nothing + -- static routes checkRoutes :: Spec @@ -18,12 +21,15 @@ checkRoutes = do it "enter route (positive cases)" $ do getPath ["api", "v1", "hello"] helloApi `shouldBe` Just ("hello", mempty) getPath ["api", "v1", "bye"] helloApi `shouldBe` Just ("bye", mempty) - it "enter route (negative cases)" $ do - getPath ["api", "v1"] helloApi `shouldBe` Nothing - getPath [] helloApi `shouldBe` Nothing - getPath ["api", "v1", "hello", "there"] helloApi `shouldBe` Nothing - getPath ["api", "v1"] (mempty @(Api Text)) `shouldBe` Nothing - getPath [] (mempty @(Api Text)) `shouldBe` Nothing + it "enter route (negative cases)" $ + mapM_ + notFound + [ getPath ["api", "v1"] helloApi + , getPath [] helloApi + , getPath ["api", "v1", "hello", "there"] helloApi + , getPath ["api", "v1"] (mempty @(Api Text)) + , getPath [] (mempty @(Api Text)) + ] helloApi :: Api Text helloApi = @@ -33,16 +39,6 @@ helloApi = , WithPath "bye" (HandleRoute "bye") ] --- flat api - -checkFlatApi :: Spec -checkFlatApi = - it "flat api" $ - flatApi helloApi - `shouldBe` [ ("api/v1/hello", "hello") - , ("api/v1/bye", "bye") - ] - -- captures checkCaptures :: Spec @@ -53,10 +49,13 @@ checkCaptures = do getPath ["api", "capture2", "hello", "bye"] captureApi `shouldBe` Just ("capture2", Map.fromList [("name1", "hello"), ("name2", "bye")]) - it "captures (negative cases)" $ do - getPath ["api", "capture1"] captureApi `shouldBe` Nothing - getPath ["api", "capture2", "hello"] captureApi `shouldBe` Nothing - getPath ["api", "capture2", "hello", "bye", "error"] captureApi `shouldBe` Nothing + it "captures (negative cases)" $ + mapM_ + (notFound . flip getPath captureApi) + [ ["api", "capture1"] + , ["api", "capture2", "hello"] + , ["api", "capture2", "hello", "bye", "error"] + ] captureApi :: Api Text captureApi = @@ -65,3 +64,13 @@ captureApi = [ WithPath ("capture1" <> Path [CapturePath "name1"]) (HandleRoute "capture1") , WithPath ("capture2" <> Path [CapturePath "name1", CapturePath "name2"]) (HandleRoute "capture2") ] + +-- flat api + +checkFlatApi :: Spec +checkFlatApi = + it "flat api" $ + flatApi helloApi + `shouldBe` [ ("api/v1/hello", "hello") + , ("api/v1/bye", "bye") + ] diff --git a/mig/test/Test/Server.hs b/mig/test/Test/Server.hs new file mode 100644 index 0000000..17962fb --- /dev/null +++ b/mig/test/Test/Server.hs @@ -0,0 +1,12 @@ +module Test.Server (spec) where + +import Test.Server.Hello qualified as Hello +import Test.Server.RouteArgs qualified as RouteArgs +import Test.Server.Counter qualified as Counter +import Test.Hspec + +spec :: Spec +spec = describe "server" $ do + Hello.spec + RouteArgs.spec + Counter.spec diff --git a/mig/test/Test/Server/Counter.hs b/mig/test/Test/Server/Counter.hs new file mode 100644 index 0000000..9f87e69 --- /dev/null +++ b/mig/test/Test/Server/Counter.hs @@ -0,0 +1,6 @@ +module Test.Server.Counter (spec) where + +import Test.Hspec + +spec :: Spec +spec = describe "counter server" $ pure () diff --git a/mig/test/Test/Server/Hello.hs b/mig/test/Test/Server/Hello.hs index 51d4f30..caf99f5 100644 --- a/mig/test/Test/Server/Hello.hs +++ b/mig/test/Test/Server/Hello.hs @@ -27,7 +27,7 @@ handleBye = pure $ ok "bye" -- tests -- we use low-level representation of server as a function: Request -> m (Maybe Response) --- to check server properties without wpawning a full server environment +-- to check server properties without launching in a full server environment spec :: Spec spec = describe "hello world server" $ do describe "plain route finder" $ specBy plainApiStrategy diff --git a/mig/test/Test/Server/RouteArgs.hs b/mig/test/Test/Server/RouteArgs.hs new file mode 100644 index 0000000..da4cf9a --- /dev/null +++ b/mig/test/Test/Server/RouteArgs.hs @@ -0,0 +1,6 @@ +module Test.Server.RouteArgs (spec) where + +import Test.Hspec + +spec :: Spec +spec = describe "route args server" $ pure () From f42ead5f8a97f025e58a551c99fdd88b111d4be6 Mon Sep 17 00:00:00 2001 From: Anton Kholomiov Date: Sat, 4 Nov 2023 11:04:28 +0300 Subject: [PATCH 4/7] Test case for readerT based server --- mig/mig.cabal | 9 ++- mig/package.yaml | 4 +- mig/test/Spec.hs | 5 +- mig/test/Test/Server/Common.hs | 30 ++++++++++ mig/test/Test/Server/Counter.hs | 93 ++++++++++++++++++++++++++++++- mig/test/Test/Server/Hello.hs | 25 +-------- mig/test/Test/Server/RouteArgs.hs | 4 ++ 7 files changed, 139 insertions(+), 31 deletions(-) create mode 100644 mig/test/Test/Server/Common.hs diff --git a/mig/mig.cabal b/mig/mig.cabal index 0125e55..d58a9ac 100644 --- a/mig/mig.cabal +++ b/mig/mig.cabal @@ -93,7 +93,13 @@ test-suite mig-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - Test.Api Test.Server.Hello + Test.Api + Test.Server + Test.Server.Common + Test.Server.Counter + Test.Server.Hello + Test.Server.RouteArgs + Paths_mig hs-source-dirs: test default-extensions: @@ -113,5 +119,6 @@ test-suite mig-test , hspec , http-types , mig + , mtl , text default-language: GHC2021 diff --git a/mig/package.yaml b/mig/package.yaml index f644109..4c019aa 100644 --- a/mig/package.yaml +++ b/mig/package.yaml @@ -80,9 +80,6 @@ library: tests: mig-test: main: Spec.hs - other-modules: - Test.Api - Test.Server.Hello source-dirs: test ghc-options: - -threaded @@ -96,4 +93,5 @@ tests: - hspec - text - http-types + - mtl diff --git a/mig/test/Spec.hs b/mig/test/Spec.hs index 3218caf..b03f415 100644 --- a/mig/test/Spec.hs +++ b/mig/test/Spec.hs @@ -1,5 +1,5 @@ import Test.Api qualified as Api -import Test.Server.Hello qualified as Server.Hello +import Test.Server qualified as Server import Test.Hspec @@ -7,5 +7,4 @@ main :: IO () main = hspec $ do Api.spec - describe "server" $ do - Server.Hello.spec + Server.spec diff --git a/mig/test/Test/Server/Common.hs b/mig/test/Test/Server/Common.hs new file mode 100644 index 0000000..beada12 --- /dev/null +++ b/mig/test/Test/Server/Common.hs @@ -0,0 +1,30 @@ +module Test.Server.Common ( + emptyReq, + jsonResp, +) where + +import Data.Aeson qualified as Json +import Data.Map.Strict qualified as Map +import Mig.Core +import Network.HTTP.Types.Method (methodGet) +import Network.HTTP.Types.Status (ok200) + +emptyReq :: Request +emptyReq = + Request + { path = [] + , query = mempty + , capture = mempty + , headers = Map.fromList [("Accept", "application/json")] + , method = methodGet + , readBody = pure (Right "") + , isSecure = False + } + +jsonResp :: (Json.ToJSON a) => a -> Response +jsonResp a = + Response + { status = ok200 + , headers = [("Content-Type", "application/json")] + , body = RawResp "application/json" (Json.encode a) + } diff --git a/mig/test/Test/Server/Counter.hs b/mig/test/Test/Server/Counter.hs index 9f87e69..204843a 100644 --- a/mig/test/Test/Server/Counter.hs +++ b/mig/test/Test/Server/Counter.hs @@ -1,6 +1,97 @@ +{-# LANGUAGE DataKinds #-} + +-- | Test case for ReaderT based server module Test.Server.Counter (spec) where +import Control.Monad.Reader +import Data.Aeson qualified as Json +import Data.IORef +import Data.Maybe +import Data.Text qualified as Text +import Mig.Core +import Network.HTTP.Types.Method (methodPost) import Test.Hspec +import Test.Server.Common + +------------------------------------------------------------------------------------- +-- server definition + +newtype Env = Env (IORef Int) + +initEnv :: IO Env +initEnv = Env <$> newIORef 0 + +newtype App a = App (ReaderT Env IO a) + deriving newtype (Functor, Applicative, Monad, MonadReader Env, MonadIO) + +runApp :: Env -> App a -> IO a +runApp env (App act) = runReaderT act env + +{-| Server has two routes: + +* get - to querry current state +* put - to add some integer to the state +-} +server :: Server App +server = + "counter" + /. [ "get" /. handleGet + , "put" /. handlePut + ] + +-- | Get handler. It logs the call and returns current state +handleGet :: Get App (Resp Json Int) +handleGet = Send $ do + Env ref <- ask + liftIO $ ok <$> readIORef ref + +-- | Put handler. It logs the call and updates the state with integer which is read from URL +handlePut :: Capture "arg" Int -> Post App (Resp Json ()) +handlePut (Capture val) = Send $ do + Env ref <- ask + liftIO $ ok <$> atomicModifyIORef' ref (\cur -> (cur + val, ())) + +------------------------------------------------------------------------------------- +-- test cases spec :: Spec -spec = describe "counter server" $ pure () +spec = describe "counter server (ReaderT)" $ do + describe "plain route finder" $ specBy plainApiStrategy + describe "tree route finder" $ specBy treeApiStrategy + +specBy :: FindRoute normalForm App -> Spec +specBy findRoute = + it "run accumulator script" $ + script serverFun [1, 2, 3, 4] `shouldReturn` [1, 3, 6, 10] + where + serverFun = fromServer findRoute server + +{-| Puts inputs to server and returns result of "counter/get" method call +on each increment +-} +script :: ServerFun App -> [Int] -> IO [Int] +script f inputs = do + env <- initEnv + runApp env $ catMaybes <$> mapM go inputs + where + go :: Int -> App (Maybe Int) + go n = fmap (parseInt =<<) $ do + mRes <- f (putReq n) + if (isJust mRes) + then f getReq + else pure Nothing + + putReq :: Int -> Request + putReq increment = + emptyReq + { method = methodPost + , path = ["counter", "put", Text.pack (show increment)] + } + + getReq :: Request + getReq = emptyReq{path = ["counter", "get"]} + + parseInt :: Response -> Maybe Int + parseInt resp = case resp.body of + RawResp "application/json" bsResp -> Json.decode bsResp + _ -> Nothing diff --git a/mig/test/Test/Server/Hello.hs b/mig/test/Test/Server/Hello.hs index caf99f5..28134b3 100644 --- a/mig/test/Test/Server/Hello.hs +++ b/mig/test/Test/Server/Hello.hs @@ -1,13 +1,12 @@ module Test.Server.Hello (spec) where -import Data.Aeson qualified as Json import Data.Map.Strict qualified as Map import Data.Text (Text) import Mig.Core import Mig.Core qualified as Request (Request (..)) -import Network.HTTP.Types.Method (methodGet, methodPost) -import Network.HTTP.Types.Status (ok200) +import Network.HTTP.Types.Method (methodPost) import Test.Hspec +import Test.Server.Common -- hello world server @@ -63,23 +62,3 @@ specBy finder = do byeResp = Just $ jsonResp @Text "bye" wrongPathReq = emptyReq{path = ["api", "v2", "hello"]} - -emptyReq :: Request -emptyReq = - Request - { path = [] - , query = mempty - , capture = mempty - , headers = Map.fromList [("Accept", "application/json")] - , method = methodGet - , readBody = pure (Right "") - , isSecure = False - } - -jsonResp :: (Json.ToJSON a) => a -> Response -jsonResp a = - Response - { status = ok200 - , headers = [("Content-Type", "application/json")] - , body = RawResp "application/json" (Json.encode a) - } diff --git a/mig/test/Test/Server/RouteArgs.hs b/mig/test/Test/Server/RouteArgs.hs index da4cf9a..2a491c0 100644 --- a/mig/test/Test/Server/RouteArgs.hs +++ b/mig/test/Test/Server/RouteArgs.hs @@ -2,5 +2,9 @@ module Test.Server.RouteArgs (spec) where import Test.Hspec +-- server + +-- test cases + spec :: Spec spec = describe "route args server" $ pure () From 0fd193ff3529c9d0c49c7f744e35d85b8e2d1ef8 Mon Sep 17 00:00:00 2001 From: Anton Kholomiov Date: Sat, 4 Nov 2023 11:08:33 +0300 Subject: [PATCH 5/7] Fix formatting --- mig/test/Test/Server.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/mig/test/Test/Server.hs b/mig/test/Test/Server.hs index 17962fb..f0ab991 100644 --- a/mig/test/Test/Server.hs +++ b/mig/test/Test/Server.hs @@ -1,9 +1,9 @@ module Test.Server (spec) where +import Test.Hspec +import Test.Server.Counter qualified as Counter import Test.Server.Hello qualified as Hello import Test.Server.RouteArgs qualified as RouteArgs -import Test.Server.Counter qualified as Counter -import Test.Hspec spec :: Spec spec = describe "server" $ do From 69542103d52b01285aa765d7308717dcdc718f37 Mon Sep 17 00:00:00 2001 From: Anton Kholomiov Date: Sat, 4 Nov 2023 13:08:57 +0300 Subject: [PATCH 6/7] Tests for request types --- mig/mig.cabal | 3 + mig/package.yaml | 4 +- mig/src/Mig/Core/Types/Http.hs | 1 + mig/test/Test/Server/Common.hs | 6 + mig/test/Test/Server/Counter.hs | 8 +- mig/test/Test/Server/RouteArgs.hs | 284 +++++++++++++++++++++++++++++- 6 files changed, 297 insertions(+), 9 deletions(-) diff --git a/mig/mig.cabal b/mig/mig.cabal index d58a9ac..6f22d13 100644 --- a/mig/mig.cabal +++ b/mig/mig.cabal @@ -115,10 +115,13 @@ test-suite mig-test build-depends: aeson , base >=4.7 && <5 + , bytestring , containers , hspec + , http-api-data , http-types , mig , mtl + , openapi3 , text default-language: GHC2021 diff --git a/mig/package.yaml b/mig/package.yaml index 4c019aa..a06e40f 100644 --- a/mig/package.yaml +++ b/mig/package.yaml @@ -94,4 +94,6 @@ tests: - text - http-types - mtl - + - openapi3 + - http-api-data + - bytestring diff --git a/mig/src/Mig/Core/Types/Http.hs b/mig/src/Mig/Core/Types/Http.hs index b9ac03a..215dbc3 100644 --- a/mig/src/Mig/Core/Types/Http.hs +++ b/mig/src/Mig/Core/Types/Http.hs @@ -6,6 +6,7 @@ module Mig.Core.Types.Http ( Request (..), Response (..), ResponseBody (..), + HeaderMap, QueryMap, ToText (..), diff --git a/mig/test/Test/Server/Common.hs b/mig/test/Test/Server/Common.hs index beada12..94c9989 100644 --- a/mig/test/Test/Server/Common.hs +++ b/mig/test/Test/Server/Common.hs @@ -1,6 +1,7 @@ module Test.Server.Common ( emptyReq, jsonResp, + parseResp, ) where import Data.Aeson qualified as Json @@ -28,3 +29,8 @@ jsonResp a = , headers = [("Content-Type", "application/json")] , body = RawResp "application/json" (Json.encode a) } + +parseResp :: (Json.FromJSON a) => Response -> Maybe a +parseResp resp = case resp.body of + RawResp "application/json" bsResp -> Json.decode bsResp + _ -> Nothing diff --git a/mig/test/Test/Server/Counter.hs b/mig/test/Test/Server/Counter.hs index 204843a..eea5d08 100644 --- a/mig/test/Test/Server/Counter.hs +++ b/mig/test/Test/Server/Counter.hs @@ -4,7 +4,6 @@ module Test.Server.Counter (spec) where import Control.Monad.Reader -import Data.Aeson qualified as Json import Data.IORef import Data.Maybe import Data.Text qualified as Text @@ -75,7 +74,7 @@ script f inputs = do runApp env $ catMaybes <$> mapM go inputs where go :: Int -> App (Maybe Int) - go n = fmap (parseInt =<<) $ do + go n = fmap (parseResp =<<) $ do mRes <- f (putReq n) if (isJust mRes) then f getReq @@ -90,8 +89,3 @@ script f inputs = do getReq :: Request getReq = emptyReq{path = ["counter", "get"]} - - parseInt :: Response -> Maybe Int - parseInt resp = case resp.body of - RawResp "application/json" bsResp -> Json.decode bsResp - _ -> Nothing diff --git a/mig/test/Test/Server/RouteArgs.hs b/mig/test/Test/Server/RouteArgs.hs index 2a491c0..af70102 100644 --- a/mig/test/Test/Server/RouteArgs.hs +++ b/mig/test/Test/Server/RouteArgs.hs @@ -1,10 +1,292 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} + +-- | Tests for various inputs for requests module Test.Server.RouteArgs (spec) where +import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson qualified as Json +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as BL +import Data.Map.Strict qualified as Map +import Data.OpenApi (ToParamSchema, ToSchema) +import Data.Text (Text) +import Data.Text qualified as Text +import GHC.Generics (Generic) +import Mig.Core +import Mig.Core qualified as Request (Request (..)) +import Network.HTTP.Types.Method (Method, methodGet, methodPost) +import Network.HTTP.Types.Status (badRequest400, ok200, status400, status500) import Test.Hspec +import Test.Server.Common +import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) +------------------------------------------------------------------------------------- -- server +server :: Server IO +server = + "api" + /. [ "succ" + /. [ "query" /. handleSuccQuery + , "header" /. handleSuccHeader + , "optional" /. handleSuccOpt + , "optional-header" /. handleSuccHeaderOpt + ] + , -- several query params + "add" /. handleAdd + , -- query flag + "add-if" /. handleAddIf + , -- capture + "mul" /. handleMul + , -- json body as input + "add-json" /. handleAddJson + , -- return error + "square-root" /. handleSquareRoot + ] + +{-| Using several inputs: header argument and required query +and using conditional output status +-} +handleSuccQuery :: Query "value" Int -> Get IO (Resp Json Int) +handleSuccQuery (Query n) = + pure $ ok (succ n) + +newtype Value = Value Int + deriving newtype (FromHttpApiData, ToHttpApiData, ToText, ToParamSchema) + +{-| Using several inputs: header argument and required query +and using conditional output status +-} +handleSuccHeader :: Header "value" Value -> Get IO (Resp Json Int) +handleSuccHeader (Header (Value n)) = do + pure $ ok (succ n) + +-- | Using optional query parameters and error as RespOr. +handleSuccOpt :: Optional "value" Int -> Get IO (RespOr Json Text Int) +handleSuccOpt (Optional n) = do + pure $ ok $ maybe 0 succ n + +-- | Using optional header parameters and error as RespOr. +handleSuccHeaderOpt :: OptionalHeader "value" Int -> Get IO (RespOr Json Text Int) +handleSuccHeaderOpt (OptionalHeader n) = do + pure $ ok $ maybe 0 succ n + +{-| Using custom headers in response and several input query parameters. +Note that function can have any number of arguments. +We encode the input type with proper type-wrapper. +-} +handleAdd :: Query "a" Int -> Query "b" Int -> Get IO (Resp Json Int) +handleAdd (Query a) (Query b) = do + pure $ ok $ a + b + +-- | Using query flag if flag is false returns 0 +handleAddIf :: Query "a" Int -> Query "b" Int -> QueryFlag "perform" -> Get IO (Resp Json Int) +handleAddIf (Query a) (Query b) (QueryFlag addFlag) = do + pure $ + ok $ + if addFlag + then (a + b) + else 0 + +{-| Using capture as arguments. This route expects two arguments +captured in URL. For example: + +> http://localhost:8085/hello/api/mul/3/100 +-} +handleMul :: Capture "a" Int -> Capture "b" Int -> Get IO (Resp Json Int) +handleMul (Capture a) (Capture b) = do + pure $ ok (a * b) + +data AddInput = AddInput + { a :: Int + , b :: Int + } + deriving (Generic, ToJSON, FromJSON, ToSchema) + +-- | Using JSON as input +handleAddJson :: Body Json AddInput -> Post IO (Resp Json Int) +handleAddJson (Body (AddInput a b)) = do + pure $ ok $ a + b + +handleSquareRoot :: Body Json Float -> Post IO (RespOr Json Text Float) +handleSquareRoot (Body arg) = + pure $ + if arg >= 0 + then ok (sqrt arg) + else bad badRequest400 sqrtError + +sqrtError :: Text +sqrtError = "Argument for square root should be non-negative" + +------------------------------------------------------------------------------------- -- test cases +-- we use low-level representation of server as a function: Request -> m (Maybe Response) +-- to check server properties without launching in a full server environment spec :: Spec -spec = describe "route args server" $ pure () +spec = describe "route args server: check route inputs" $ do + describe "plain route finder" $ specBy plainApiStrategy + describe "tree route finder" $ specBy treeApiStrategy + +specBy :: FindRoute normalForm IO -> Spec +specBy finder = do + describe "request" $ do + checkQuery + checkOptionalQuery + checkHeader + checkOptionalHeader + checkQueryFlag + checkCapture + checkBody + where + serverFun :: ServerFun IO + serverFun = fromServer finder server + + shouldReq :: forall a. (Json.FromJSON a, Show a, Eq a) => Request -> Maybe a -> Expectation + shouldReq req expected = + fmap (parseResp @a =<<) (serverFun req) `shouldReturn` expected + + toQuery :: forall a. (Json.ToJSON a) => ByteString -> a -> QueryMap + toQuery name val = Map.singleton name (Just $ BL.toStrict $ Json.encode @a val) + + -- queries + + checkQuery :: Spec + checkQuery = + describe "query" $ do + it "one query" $ shouldReq @Int queryReq (Just 2) + it "missing query" $ shouldReq @Int (queryReq{query = mempty}) Nothing + it "two queries" $ shouldReq @Int (twoQueryReq 2 2) (Just 4) + + queryReq :: Request + queryReq = + emptyReq + { path = ["api", "succ", "query"] + , query = toQuery @Int "value" 1 + } + + twoQueryReq :: Int -> Int -> Request + twoQueryReq a b = + emptyReq + { path = ["api", "add"] + , query = toQuery "a" a <> toQuery "b" b + } + + -- optional query + + checkOptionalQuery :: Spec + checkOptionalQuery = + describe "optional query" $ do + it "with query" $ shouldReq @Int optionalQueryReq (Just 2) + it "no query (ok, default case)" $ shouldReq @Int (optionalQueryReq{query = mempty}) (Just 0) + + optionalQueryReq :: Request + optionalQueryReq = + emptyReq + { path = ["api", "succ", "optional"] + , query = toQuery @Int "value" 1 + } + + -- query flag + + checkQueryFlag :: Spec + checkQueryFlag = + describe "query flag" $ do + it "flag true" $ shouldReq @Int (queryFlagReq (Just True) 2 3) (Just 5) + it "flag false" $ shouldReq @Int (queryFlagReq (Just False) 2 3) (Just 0) + it "flag missing" $ shouldReq @Int (queryFlagReq Nothing 2 3) (Just 0) + + queryFlagReq :: Maybe Bool -> Int -> Int -> Request + queryFlagReq mFlag a b = + emptyReq + { path = ["api", "add-if"] + , query = mconcat [toQuery "a" a, toQuery "b" b] <> maybe mempty (toQuery "perform") mFlag + } + + -- headers + + checkHeader :: Spec + checkHeader = + describe "header" $ do + describe "input header" $ do + it "positive case" $ shouldReq @Int headerReq (Just 2) + it "missing header" $ shouldReq @Int (headerReq{Request.headers = mempty}) Nothing + + headerReq :: Request + headerReq = + emptyReq + { path = ["api", "succ", "header"] + , Request.headers = Map.singleton "value" (BL.toStrict $ Json.encode @Int 1) + } + + -- optional headers + + checkOptionalHeader :: Spec + checkOptionalHeader = + describe "optional header" $ do + it "with header" $ shouldReq @Int optionalHeaderReq (Just 2) + it "no header (ok, default case)" $ shouldReq @Int (optionalHeaderReq{Request.headers = mempty}) (Just 0) + + optionalHeaderReq :: Request + optionalHeaderReq = + emptyReq + { path = ["api", "succ", "optional-header"] + , Request.headers = Map.singleton "value" (BL.toStrict $ Json.encode @Int 1) + } + + -- captures + + checkCapture :: Spec + checkCapture = + describe "capture" $ do + it "positive case" $ shouldReq @Int (captureReq [2, 3]) (Just 6) + it "not enough captures" $ shouldReq @Int ((captureReq [2]){capture = mempty}) Nothing + it "too many captures" $ shouldReq @Int ((captureReq [2, 3, 4]){capture = mempty}) Nothing + it "missing captures" $ shouldReq @Int ((captureReq []){capture = mempty}) Nothing + + captureReq :: [Int] -> Request + captureReq args = + emptyReq + { path = ["api", "mul"] <> fmap (Text.pack . show) args + } + + -- body + + checkBody :: Spec + checkBody = + describe "body" $ do + it "positive case 1" $ shouldReq @Int (bodyReq methodPost 2 3) (Just 5) + it "positive case 2" $ shouldReq @Float (sqrtBodyReq 9) (Just 3) + it "no body" $ shouldReq @Int noBodyReq Nothing + it "wrong method" $ shouldReq @Int (bodyReq methodGet 2 2) Nothing + it "bad argument" $ shouldReq @Text (sqrtBodyReq (-9)) (Just sqrtError) + + bodyReq :: Method -> Int -> Int -> Request + bodyReq reqMethod a b = + emptyReq + { path = ["api", "add-json"] + , method = reqMethod + , readBody = pure $ Right $ Json.encode $ AddInput a b + , Request.headers = jsonHeaders + } + + noBodyReq :: Request + noBodyReq = + emptyReq + { path = ["api", "add-json"] + , method = methodPost + , Request.headers = jsonHeaders + } + + sqrtBodyReq :: Float -> Request + sqrtBodyReq a = + emptyReq + { path = ["api", "square-root"] + , method = methodPost + , readBody = pure $ Right $ Json.encode a + , Request.headers = jsonHeaders + } + + jsonHeaders :: HeaderMap + jsonHeaders = Map.fromList [("accept", "application/json"), ("content-type", "application/json")] From ffa4330d8dd30852ea05689e8e93e848671010a2 Mon Sep 17 00:00:00 2001 From: Anton Kholomiov Date: Sat, 4 Nov 2023 16:06:57 +0300 Subject: [PATCH 7/7] Tests for response --- Makefile | 2 +- mig/test/Test/Server/RouteArgs.hs | 97 ++++++++++++++++++++++++++++++- 2 files changed, 95 insertions(+), 4 deletions(-) diff --git a/Makefile b/Makefile index 9595e10..8c98241 100644 --- a/Makefile +++ b/Makefile @@ -4,7 +4,7 @@ build: stack build test: - stack test mig + stack test run: stack run diff --git a/mig/test/Test/Server/RouteArgs.hs b/mig/test/Test/Server/RouteArgs.hs index af70102..eaf50e5 100644 --- a/mig/test/Test/Server/RouteArgs.hs +++ b/mig/test/Test/Server/RouteArgs.hs @@ -10,13 +10,15 @@ import Data.ByteString (ByteString) import Data.ByteString.Lazy qualified as BL import Data.Map.Strict qualified as Map import Data.OpenApi (ToParamSchema, ToSchema) +import Data.String import Data.Text (Text) import Data.Text qualified as Text import GHC.Generics (Generic) import Mig.Core import Mig.Core qualified as Request (Request (..)) +import Mig.Core qualified as Response (Response (..)) import Network.HTTP.Types.Method (Method, methodGet, methodPost) -import Network.HTTP.Types.Status (badRequest400, ok200, status400, status500) +import Network.HTTP.Types.Status (badRequest400, status201) import Test.Hspec import Test.Server.Common import Web.HttpApiData (FromHttpApiData (..), ToHttpApiData (..)) @@ -43,6 +45,12 @@ server = "add-json" /. handleAddJson , -- return error "square-root" /. handleSquareRoot + , "response" + /. [ "status" /. handleStatus + , "header" /. handleHeader + , "error1" /. handleError1 + , "error2" /. handleError2 + ] ] {-| Using several inputs: header argument and required query @@ -116,6 +124,24 @@ handleSquareRoot (Body arg) = then ok (sqrt arg) else bad badRequest400 sqrtError +handleStatus :: Get IO (Resp Json Text) +handleStatus = pure $ setStatus status201 $ ok "Status is 201" + +handleHeader :: Capture "name" Text -> Capture "value" Text -> Get IO (Resp Json Text) +handleHeader (Capture name) (Capture value) = + pure $ setHeader (fromString $ Text.unpack name) value $ ok "Set custom header" + +handleError1 :: Get IO (Resp Json Text) +handleError1 = pure $ bad badRequest400 badRequestError + +handleError2 :: Capture "value" Int -> Get IO (RespOr Json Text Int) +handleError2 (Capture n) + | n > 0 = pure $ ok n + | otherwise = pure $ bad badRequest400 badRequestError + +badRequestError :: Text +badRequestError = "Error: bad request" + sqrtError :: Text sqrtError = "Argument for square root should be non-negative" @@ -139,6 +165,10 @@ specBy finder = do checkQueryFlag checkCapture checkBody + describe "response" $ do + checkStatus + checkHeaders + checkErrors where serverFun :: ServerFun IO serverFun = fromServer finder server @@ -150,6 +180,9 @@ specBy finder = do toQuery :: forall a. (Json.ToJSON a) => ByteString -> a -> QueryMap toQuery name val = Map.singleton name (Just $ BL.toStrict $ Json.encode @a val) + jsonHeaders :: HeaderMap + jsonHeaders = Map.fromList [("accept", "application/json"), ("content-type", "application/json")] + -- queries checkQuery :: Spec @@ -288,5 +321,63 @@ specBy finder = do , Request.headers = jsonHeaders } - jsonHeaders :: HeaderMap - jsonHeaders = Map.fromList [("accept", "application/json"), ("content-type", "application/json")] + -- response status + + checkStatus :: Spec + checkStatus = + describe "status" $ do + it "can set result status" $ + (fmap (.status) <$> serverFun statusReq) `shouldReturn` Just status201 + it "can set error status" $ + (fmap (.status) <$> serverFun (sqrtBodyReq (-1))) `shouldReturn` Just badRequest400 + + statusReq :: Request + statusReq = + emptyReq + { path = ["api", "response", "status"] + } + + -- response headers + + checkHeaders :: Spec + checkHeaders = + describe "headers" $ + it "can set headers" $ + shouldHeader "foo" "bar" + where + shouldHeader name value = + fmap (any (== header) . Response.headers) <$> serverFun (customHeaderReq name value) + `shouldReturn` Just True + where + header = (fromString $ Text.unpack name, fromString $ Text.unpack value) + + customHeaderReq :: Text -> Text -> Request + customHeaderReq name value = + emptyReq + { path = ["api", "response", "header", name, value] + } + + -- response errors + + checkErrors :: Spec + checkErrors = + describe "custom errors" $ do + it "error has the same type as result" $ + shouldBadReq (customErrorReq ["error1"]) + it "error has different type" $ + shouldBadReq (customErrorReq ["error2", "0"]) + it "no error on positive input" $ + shouldReq @Int (customErrorReq ["error2", "1"]) (Just 1) + where + shouldBadReq req = + fmap (maybe False isBadReq) (serverFun req) `shouldReturn` True + + isBadReq resp = + resp.status == badRequest400 + && parseResp @Text resp == Just badRequestError + + customErrorReq :: [Text] -> Request + customErrorReq args = + emptyReq + { path = ["api", "response"] <> args + }