http-interchange-0.2.0.0: test/Main.hs

{-# language DeriveAnyClass #-}
{-# language DerivingStrategies #-}

module Main
  ( main
  ) where

import Control.Monad (when)
import Data.Aeson (FromJSON)
import GHC.Generics (Generic)
import Http.Types (Request,Header)
import System.FilePath (takeBaseName, replaceExtension)
import Test.Tasty (defaultMain, TestTree, testGroup)
import Test.Tasty.Golden (goldenVsString, findByExtension)
import Http.Headers (Headers)
import Text.Show.Pretty (ppShow)

import qualified Data.Aeson as Aeson
import qualified Data.ByteString.Lazy.Char8 as LBC8
import qualified Data.Bytes as Bytes
import qualified Data.Bytes.Chunks as Chunks
import qualified Data.List as List
import qualified Data.Primitive as PM
import qualified GHC.Exts as Exts
import qualified Http.Header
import qualified Http.Headers as Headers
import qualified Http.Request as Request
import qualified Http.Response as Response

main :: IO ()
main = defaultMain =<< goldenTests

deriving stock instance Generic Header
deriving stock instance Generic Request.RequestLine
deriving stock instance Generic Request.Request

deriving anyclass instance FromJSON Header
deriving anyclass instance FromJSON Request.RequestLine
deriving anyclass instance FromJSON Request.Request

instance FromJSON Headers where
  parseJSON = fmap Headers.fromArray . Aeson.parseJSON

goldenTests :: IO TestTree
goldenTests = do
  responseFiles <- List.sort <$> findByExtension [".input"] "golden/response"
  requestFiles <- List.sort <$> findByExtension [".json"] "golden/request"
  return $ testGroup "http"
    [ testGroup "response"
      [ goldenVsString
          (takeBaseName file) -- test name
          outFile -- golden file path
          (do contents <- Bytes.readFile file
              when (PM.sizeofPrimArray (Bytes.findIndices (Exts.fromList [0x0d,0x0a]) contents) < 2) $ do
                fail "Expected at least 2 CRLF sequences. Possible fix: unix2dos."
              case Response.decode 128 contents of
                Nothing -> fail "Could not decode HTTP response prelude"
                Just resp -> pure (LBC8.pack (addTrailingNewline (ppShow resp)))
          )
      | file <- responseFiles
      , let outFile = replaceExtension file ".output"
      ]
    , testGroup "request"
      [ goldenVsString
          (takeBaseName file) -- test name
          outFile -- golden file path
          (do req :: Request <- either fail pure =<< Aeson.eitherDecodeFileStrict' file
              pure $ LBC8.fromStrict $ Bytes.toByteString $ Chunks.concat $ Request.toChunks req
          )
      | file <- requestFiles
      , let outFile = replaceExtension file ".output"
      ]
    ]

-- If the trailing newline is missing, add it. The pretty-show library
-- has a defect of omitting it, but if prett-show ever changes, this
-- function will prevent that change from breaking all the tests here.
addTrailingNewline :: String -> String
addTrailingNewline [] = "\n"
addTrailingNewline [x] = case x of
  '\n' -> [x]
  _ -> [x,'\n']
addTrailingNewline (x : xs) = x : addTrailingNewline xs