diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Change log +## v1.2.0 + +- Drop support for GHC < 9.0. +- Test against GHC 9.0 through 9.12. +- Relax upper bounds to next-major for `aeson` (`<3`), `formatting` + (`<8`), `http-api-data` (`<1`), and `text` (`<3`). + ## v1.1.1 - Ensure support for GHC 9.4 diff --git a/src/Webby/Server.hs b/src/Webby/Server.hs --- a/src/Webby/Server.hs +++ b/src/Webby/Server.hs @@ -259,7 +259,9 @@ runWebbyM wEnv $ handler `E.catches` ( shortCircuitHandler - <> fmap (\(WebbyExceptionHandler e) -> E.Handler e) (maybeToList exceptionHandlerMay) + <> fmap + (\(WebbyExceptionHandler e) -> E.Handler e) + (maybeToList exceptionHandlerMay) ) webbyReply wEnv respond ) diff --git a/src/Webby/Types.hs b/src/Webby/Types.hs --- a/src/Webby/Types.hs +++ b/src/Webby/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StrictData #-} module Webby.Types where diff --git a/test/AppTests.hs b/test/AppTests.hs new file mode 100644 --- /dev/null +++ b/test/AppTests.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings #-} + +module AppTests (appTests) where + +import qualified Data.Aeson as A +import qualified Network.Wai.Test as WT +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) +import qualified UnliftIO.Exception as E +import Webby +import Prelude + +newtype TestEnv = TestEnv () + +data Boom = Boom + deriving stock (Show) + +instance E.Exception Boom + +routes :: [Route TestEnv] +routes = + [ get "/hello" (text "hi"), + get "/users/:id" $ do + uid <- getCapture "id" + text uid, + get "/teapot" $ do + setStatus status418 + _ <- finish + setStatus status200, + get "/boom" (E.throwIO Boom), + get "/search" $ do + mq <- param "q" + text $ fromMaybe "missing" mq, + get "/page" $ do + n <- param_ "n" :: WebbyM TestEnv Int + text $ show n, + post "/echo-json" $ do + v <- jsonData :: WebbyM TestEnv A.Value + json v, + get "/add-headers" $ do + addHeader ("X-Foo", "a") + addHeader ("X-Foo", "b") + text "ok", + get "/set-headers" $ do + setHeader ("X-Foo", "a") + setHeader ("X-Foo", "b") + text "ok" + ] + +boomHandler :: Boom -> WebbyM TestEnv () +boomHandler _ = do + setStatus status503 + text "boom-handled" + +mkApp :: IO Application +mkApp = + mkWebbyApp (TestEnv ()) $ + setExceptionHandler boomHandler $ + setRoutes routes defaultWebbyServerConfig + +mkReq :: ByteString -> Request +mkReq = WT.setPath defaultRequest + +mkJsonPost :: ByteString -> LByteString -> WT.SRequest +mkJsonPost path body = + WT.SRequest + (WT.setPath + (defaultRequest + { requestMethod = methodPost, + requestHeaders = [(hContentType, "application/json")] + }) + path) + body + +run :: WT.Session a -> IO a +run sess = mkApp >>= WT.runSession sess + +appTests :: TestTree +appTests = + testGroup + "App round-trip" + [ testCase "404 on unmatched route" $ + run $ do + r <- WT.request (mkReq "/nope") + liftIO $ WT.simpleStatus r @?= status404, + testCase "200 + body on basic GET" $ + run $ do + r <- WT.request (mkReq "/hello") + liftIO $ do + WT.simpleStatus r @?= status200 + WT.simpleBody r @?= "hi", + testCase "capture extraction echoes path segment" $ + run $ do + r <- WT.request (mkReq "/users/42") + liftIO $ do + WT.simpleStatus r @?= status200 + WT.simpleBody r @?= "42", + testCase "finish short-circuits and preserves earlier setStatus" $ + run $ do + r <- WT.request (mkReq "/teapot") + liftIO $ WT.simpleStatus r @?= status418, + testCase "custom exceptionHandler runs on thrown exception" $ + run $ do + r <- WT.request (mkReq "/boom") + liftIO $ do + WT.simpleStatus r @?= status503 + WT.simpleBody r @?= "boom-handled", + testCase "param returns Just for present query param" $ + run $ do + r <- WT.request (mkReq "/search?q=foo") + liftIO $ do + WT.simpleStatus r @?= status200 + WT.simpleBody r @?= "foo", + testCase "param returns Nothing when missing" $ + run $ do + r <- WT.request (mkReq "/search") + liftIO $ do + WT.simpleStatus r @?= status200 + WT.simpleBody r @?= "missing", + testCase "param_ parses typed value" $ + run $ do + r <- WT.request (mkReq "/page?n=42") + liftIO $ do + WT.simpleStatus r @?= status200 + WT.simpleBody r @?= "42", + testCase "param_ returns 400 on unparseable value" $ + run $ do + r <- WT.request (mkReq "/page?n=abc") + liftIO $ WT.simpleStatus r @?= status400, + testCase "jsonData round-trips a Value" $ + run $ do + let body = "{\"x\":42}" + r <- WT.srequest (mkJsonPost "/echo-json" body) + liftIO $ do + WT.simpleStatus r @?= status200 + A.decode (WT.simpleBody r) @?= (A.decode body :: Maybe A.Value), + testCase "jsonData returns 400 on malformed body" $ + run $ do + r <- WT.srequest (mkJsonPost "/echo-json" "not json") + liftIO $ do + WT.simpleStatus r @?= status400 + WT.simpleBody r @?= "Invalid JSON body", + testCase "addHeader appends duplicate header values" $ + run $ do + r <- WT.request (mkReq "/add-headers") + liftIO $ + filter ((== "X-Foo") . fst) (WT.simpleHeaders r) + @?= [("X-Foo", "a"), ("X-Foo", "b")], + testCase "setHeader replaces an existing header value" $ + run $ do + r <- WT.request (mkReq "/set-headers") + liftIO $ + filter ((== "X-Foo") . fst) (WT.simpleHeaders r) + @?= [("X-Foo", "b")] + ] diff --git a/test/ErrorTests.hs b/test/ErrorTests.hs new file mode 100644 --- /dev/null +++ b/test/ErrorTests.hs @@ -0,0 +1,19 @@ +module ErrorTests (errorTests) where + +import qualified UnliftIO.Exception as E +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@?=)) +import qualified Test.Tasty.HUnit as HUnit +import Webby.Types +import Prelude + +errorTests :: TestTree +errorTests = testGroup "WebbyError displayException" [unitTests] + where + unitTests = HUnit.testCase "renders each constructor" $ do + E.displayException (WebbyJSONParseError "ignored") + @?= "Invalid JSON body" + E.displayException (WebbyParamParseError "page" "not an integer") + @?= "Param parse error: page not an integer" + E.displayException (WebbyMissingCapture "userId") + @?= "userId missing" diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,4 +1,6 @@ +import AppTests (appTests) import qualified Data.HashMap.Strict as H +import ErrorTests (errorTests) import Network.Wai.Internal import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit ((@?=)) @@ -11,7 +13,7 @@ main = defaultMain tests tests :: TestTree -tests = testGroup "Webby Tests" [matchRequestTests] +tests = testGroup "Webby Tests" [matchRequestTests, errorTests, appTests] matchRequestTests :: TestTree matchRequestTests = testGroup "matchRequest" [unitTests] diff --git a/webby.cabal b/webby.cabal --- a/webby.cabal +++ b/webby.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: webby -version: 1.1.1 +version: 1.2.0 synopsis: A super-simple web server framework description: A super-simple, easy to use web server framework inspired by Scotty. The goals of the project are: (1) Be easy to use (2) Allow @@ -18,13 +18,13 @@ README.md extra-source-files: examples/*.hs -tested-with: GHC == 8.4.4 - GHC == 8.6.5 - GHC == 8.8.4 - GHC == 8.10.7 - GHC == 9.0.2 +tested-with: GHC == 9.0.2 GHC == 9.2.7 GHC == 9.4.4 + GHC == 9.6.7 + GHC == 9.8.4 + GHC == 9.10.3 + GHC == 9.12.4 source-repository head type: git @@ -36,25 +36,23 @@ -Widentities -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wredundant-constraints + -Wmissing-deriving-strategies + -Werror=missing-deriving-strategies + -Winvalid-haddock + -fhide-source-paths -haddock - if impl(ghc >= 8.0) - ghc-options: -Wredundant-constraints - if impl(ghc >= 8.2) - ghc-options: -fhide-source-paths -- Add this when we have time. Fixing partial-fields requires major version -- bump at this time. - -- if impl(ghc >= 8.4) - -- ghc-options: -Wpartial-fields - -- -Wmissing-export-lists + -- ghc-options: -Wpartial-fields + -- -Wmissing-export-lists - if impl(ghc >= 8.8) - ghc-options: -Wmissing-deriving-strategies - -Werror=missing-deriving-strategies - if impl(ghc >= 8.10) - ghc-options: -Wunused-packages - if impl(ghc >= 9.0) - ghc-options: -Winvalid-haddock + -- -Wunused-packages is intentionally NOT enabled: combined with + -- `mixins: base hiding (Prelude)` below, GHC can't see uses of the + -- base- package-id (imports go through the mixin alias), so it + -- spuriously flags base as unused. Confirmed still firing on GHC 9.6.7, + -- 9.8.4, 9.10.3, and 9.12.4 (cabal 3.14.2.0). See GHC issue #19518. if impl(ghc >= 9.2) ghc-options: -Wredundant-bang-patterns -Woperator-whitespace @@ -81,16 +79,16 @@ autogen-modules: Paths_webby build-depends: - aeson >=1.4 && <2.2 - , base >=4.7 && <5 + aeson >=1.4 && <3 + , base >=4.15 && <5 , binary >=0.8 && <1 , bytestring >=0.10 && <1 - , formatting >=6.3.7 && <7.2 - , http-api-data >=0.4 && <0.6 + , formatting >=6.3.7 && <8 + , http-api-data >=0.4 && <1 , http-types ==0.12.* - , relude >=0.7 + , relude >=0.7 && <2 , resourcet ==1.2.* - , text >=1.2 && <2.1 + , text >=1.2 && <3 , unliftio >=0.2.13 && <0.3 , unliftio-core ==0.2.* , unordered-containers >=0.2.9 && <0.3 @@ -112,14 +110,23 @@ base-settings type: exitcode-stdio-1.0 main-is: Spec.hs + other-modules: + AppTests + ErrorTests + Webby hs-source-dirs: src test ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: - tasty + bytestring + , http-types + , tasty , tasty-hunit , tasty-quickcheck + , text + , wai + , wai-extra , webby Flag examples @@ -131,11 +138,11 @@ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 default-extensions: OverloadedStrings - build-depends: base >= 4.7 && < 5 + build-depends: base >= 4.15 && < 5 , http-types , relude , text - , warp + , warp < 4 , webby , unliftio , unordered-containers