From f469c2637b0fea2bc87d991b85b6d0e18eb135c4 Mon Sep 17 00:00:00 2001
From: Anton Kholomiov <anton.kholomiov@gmail.com>
Date: Fri, 3 Nov 2023 20:24:54 +0300
Subject: [PATCH] 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)
+    }