Add basic tests, add test support in CI

.github/workflows/haskell.yml

@@ -26,7 +26,7 @@ jobs:
         ghc-version: ${{ matrix.ghc }}
         cabal-version: ${{ matrix.cabal }}
     - name: Configure main repo
-      run: cabal new-configure --disable-optimization
+      run: cabal new-configure --disable-optimization --enable-tests
     - name: Freeze
       run: cabal freeze
     - uses: actions/[email protected]
@@ -46,3 +46,5 @@ jobs:
         cabal new-build || { # macOS + TH = QQ
           cabal clean && cabal new-build
         }
+    - name: Run tests
+      run: cabal new-test --test-show-details=direct

.nvimrc

@@ -7,7 +7,7 @@ let g:ale_lint_on_text_changed = 'never'
 let g:ale_lint_on_insert_leave = 0
 let g:ale_lint_on_enter = 0
 
-call ale#Set('haskell_cabal_build_options', '--disable-optimization')
+call ale#Set('haskell_cabal_build_options', '--disable-optimization --enable-tests')
 call ale#Set('c_cc_executable', 'gcc')
 call ale#Set('c_cc_options', '-std=c99 -march=native -Wall -Wextra')
 

app/Main.hs

@@ -1,36 +1,7 @@
-{-# LANGUAGE OverloadedStrings #-}
-
 module Main (main) where
 
-import Jsonifier (toByteString)
-import Shields (parseResponse, renderResponse)
-import Snap.Core
-  ( Snap,
-    finishWith,
-    getResponse,
-    getsRequest,
-    ifTop,
-    modifyResponse,
-    rqQueryParams,
-    setContentType,
-    setResponseStatus,
-    writeBS,
-  )
+import Shields.Api (api)
 import Snap.Http.Server (defaultConfig, httpServe)
 
 main :: IO ()
 main = httpServe defaultConfig api
-
--- Helpers
-
-api :: Snap ()
-api = ifTop $ do
-  queryParams <- getsRequest rqQueryParams
-  case parseResponse queryParams of
-    Nothing -> do
-      modifyResponse . setResponseStatus 500 $ "Invalid badge request"
-      getResponse >>= finishWith
-    Just sr -> do
-      writeBS . toByteString . renderResponse $ sr
-      resp <- getResponse
-      finishWith . setContentType "application/json" $ resp

shields.cabal

@@ -30,13 +30,17 @@ common lang
 
 library shields-lib
   import:          lang
-  exposed-modules: Shields
+  exposed-modules:
+    Shields.Api
+    Shields.Response
+
   build-depends:
     , base        ==4.14.1.0
     , bytestring  ^>=0.10.12.1
     , containers  ^>=0.6.4.1
     , jsonifier   ^>=0.1.1
     , ptr-poker   ^>=0.1.1.3
+    , snap-core   ^>=1.0.4.2
 
   hs-source-dirs:  src
 
@@ -47,10 +51,26 @@ executable shields
   main-is:        Main.hs
   build-depends:
     , base
-    , jsonifier
     , shields-lib
-    , snap-core    ^>=1.0.4.2
     , snap-server  ^>=1.1.2.0
 
   ghc-options:    -O2 -threaded -with-rtsopts=-N
   hs-source-dirs: app
+
+-- Tests
+
+test-suite response
+  import:         lang
+  type:           exitcode-stdio-1.0
+  main-is:        Main.hs
+  build-depends:
+    , base
+    , case-insensitive  ^>=1.2.1.0
+    , containers
+    , shields-lib
+    , snap-core
+    , tasty             ^>=1.4.1
+    , tasty-hunit       ^>=0.10.0.3
+
+  ghc-options:    -O2 -threaded -with-rtsopts=-N
+  hs-source-dirs: test/response

src/Shields/Api.hs

@@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Shields.Api (api) where
+
+import Jsonifier (toByteString)
+import Shields.Response (parseResponse, renderResponse)
+import Snap.Core
+  ( Snap,
+    finishWith,
+    getResponse,
+    getsRequest,
+    ifTop,
+    modifyResponse,
+    rqQueryParams,
+    setContentType,
+    setResponseStatus,
+    writeBS,
+  )
+
+-- | @since 1.0.0
+api :: Snap ()
+api = ifTop $ do
+  queryParams <- getsRequest rqQueryParams
+  case parseResponse queryParams of
+    Nothing -> do
+      modifyResponse . setResponseStatus 500 $ "Invalid badge request"
+      getResponse >>= finishWith
+    Just sr -> do
+      writeBS . toByteString . renderResponse $ sr
+      resp <- getResponse
+      finishWith . setContentType "application/json" $ resp

src/Shields.hs → src/Shields/Response.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TupleSections #-}
 
-module Shields
+module Shields.Response
   ( Colour,
     renderColour,
     parseColour,

test/response/Main.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main (main) where
+
+import Data.CaseInsensitive (mk)
+import qualified Data.Map.Strict as M
+import Shields.Api (api)
+import Snap.Core (getHeader, rspStatus, rspStatusReason)
+import Snap.Test (RequestBuilder, get, runHandler)
+import Test.Tasty (TestTree, defaultMain, testGroup)
+import Test.Tasty.HUnit (assertEqual, testCase)
+
+main :: IO ()
+main = defaultMain tests
+
+tests :: TestTree
+tests =
+  testGroup
+    "Responses"
+    [ testCase "Get, /, no query params" $ do
+        resp <- runHandler getTopLevelNoQP api
+        assertEqual "Status code is 500" 500 . rspStatus $ resp
+        assertEqual "Explains that badge request is invalid" "Invalid badge request"
+          . rspStatusReason
+          $ resp,
+      testCase "Get, /, label only" $ do
+        resp <- runHandler getTopLevelLabelOnly api
+        assertEqual "Status code is 200" 200 . rspStatus $ resp
+        assertEqual "Content type is JSON" (Just "application/json")
+          . getHeader (mk "content-type")
+          $ resp
+    ]
+
+-- Helpers
+
+getTopLevelNoQP :: RequestBuilder IO ()
+getTopLevelNoQP = get "/" M.empty
+
+getTopLevelLabelOnly :: RequestBuilder IO ()
+getTopLevelLabelOnly = get "/" . M.singleton "label" $ ["foo"]