diff --git a/solga.cabal b/solga.cabal --- a/solga.cabal +++ b/solga.cabal @@ -1,5 +1,5 @@ name: solga -version: 0.1.0.0 +version: 0.1.0.1 synopsis: Simple typesafe web routing description: A library for easily specifying web APIs and implementing them in a type-safe way. license: MIT @@ -24,7 +24,31 @@ aeson, wai-extra, http-types, - resourcet + resourcet, + safe-exceptions hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + +test-suite solga-tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Test.hs + ghc-options: -Wall + default-language: Haskell2010 + build-depends: base + , solga + , text + , bytestring + , wai + , wai-extra + , aeson + , hspec + , hspec-wai + , hspec-wai-json + , http-types + , unordered-containers + , hashable + , vector + , scientific + , QuickCheck diff --git a/src/Solga.hs b/src/Solga.hs --- a/src/Solga.hs +++ b/src/Solga.hs @@ -50,7 +50,7 @@ ) where import Control.Applicative -import Control.Exception +import Control.Exception.Safe import Control.Monad import Control.Monad.Trans.Resource import qualified Data.Aeson as Aeson @@ -98,12 +98,16 @@ next <- f router nextRouter next cont --- | Serve a `Router` with Solga, returning `SolgaError`s as HTTP responses. +-- | Serve a `Router` with Solga, returning `SolgaError`s as HTTP responses and other errors as HTTP 500. serve :: Router r => r -> Wai.Application -serve router req cont = catch (serveThrow router req cont) $ \case - SolgaError { errorStatus, errorMessage } -> - cont $ Wai.responseBuilder errorStatus [] $ - Builder.byteString $ encodeUtf8 errorMessage +serve router req cont = + serveThrow router req cont + `catchAny` \someEx -> + let + ( status, body ) = case fromException someEx of + Just SolgaError { errorStatus, errorMessage } -> ( errorStatus, Builder.byteString $ encodeUtf8 errorMessage ) + Nothing -> ( HTTP.internalServerError500, "Internal Server Error" ) + in cont $ Wai.responseBuilder status [] body -- | Serve a `Router` with Solga, throwing `SolgaError`s. serveThrow :: Router r => r -> Wai.Application diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Main (main) where + +import Test.Hspec +import Test.Hspec.Wai +import Test.Hspec.Wai.JSON +import Test.Hspec.Wai.QuickCheck +import Test.QuickCheck (genericShrink) + +import Data.Aeson hiding (json) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Builder as BSB +import Data.Hashable +import qualified Data.Scientific as S +import qualified Data.Text as T +import qualified Data.HashMap.Strict as HMS +import qualified Data.Vector as V +import Data.Traversable +import GHC.Generics (Generic) +import Network.HTTP.Types.URI +import Network.Wai.Test + +import Solga + +main :: IO () +main = hspec spec + +data TestAPI = TestAPI + { basic :: "basic" /> Get T.Text + , echoJSON :: "echo-json" /> ReqBodyJSON Value :> Post Value + , internalError :: "fubar" /> Get T.Text + , echoCapture :: "echo-capture" /> Capture T.Text :> Get T.Text + } deriving (Generic) +instance Router TestAPI + +testAPI :: TestAPI +testAPI = TestAPI + { basic = brief (return "basic") + , echoJSON = brief return + , internalError = brief (return $ error "quality programming") + , echoCapture = brief return + } + +spec :: Spec +spec = with (return $ serve testAPI) $ do + -- tests basic routing + describe "GET /basic" $ do + it "responds with 200" $ do + get "/basic" `shouldRespondWith` 200 + + it "responds with 404 for the wrong method" $ do + post "/basic" "" `shouldRespondWith` 404 + + it "responds with \"basic\"" $ do + get "/basic" `shouldRespondWith` [json|"basic"|] + + describe "GET /doesnt-exist" $ + it "responds with 404" $ do + get "/doesnt-exist" `shouldRespondWith` 404 + + -- tests ReqBodyJSON and JSON + describe "POST /echo-json" $ do + it "responds with 200" $ + post "/echo-json" [json|"test"|] `shouldRespondWith` 200 + + it "responds with correct content type" $ + post "/echo-json" [json|"test"|] `shouldRespondWith` + 200 { matchHeaders = ["Content-Type" <:> "application/json"] } + + it "responds with same JSON" $ property $ \val -> do + resp <- post "/echo-json" (encode val) + liftIO $ decode (simpleBody resp) `shouldBe` Just (val :: Value) + + -- tests exception handling + describe "GET /fubar" $ do + it "responds with 500" $ + get "/fubar" `shouldRespondWith` 500 + + -- tests Capture + describe "GET /echo-capture" $ do + it "responds with 200" $ + get "/echo-capture/test" `shouldRespondWith` 200 + + it "responds with captured segment" $ property $ \seg -> do + let path = LBS.toStrict $ BSB.toLazyByteString $ encodePathSegments [ "echo-capture", seg ] + resp <- get path + liftIO $ decode (simpleBody resp) `shouldBe` Just (String seg) + +deriving instance Generic Value + +instance Arbitrary Value where + arbitrary = sized arbJSON + where + arbJSON :: Int -> Gen Value + arbJSON n + | n == 0 = oneof leaves + | otherwise = oneof (leaves ++ branches (arbJSON (n `div` 4))) + leaves = + [ String <$> arbitrary + , Number <$> arbitrary + , Bool <$> arbitrary + , pure Null + ] + branches child = + [ do + values <- scale (`div` 4) (listOf child) + entries <- for values $ \val -> do + key <- arbitrary + return ( key, val ) + return $ Object $ HMS.fromList entries + , (Array . V.fromList) <$> scale (`div` 4) (listOf child) + ] + shrink = genericShrink + +instance (Eq key, Hashable key, Arbitrary key, Arbitrary value) => Arbitrary (HMS.HashMap key value) where + arbitrary = HMS.fromList <$> arbitrary + shrink = map HMS.fromList . shrink . HMS.toList + +instance Arbitrary T.Text where + arbitrary = T.pack <$> arbitrary + shrink = map T.pack . shrink . T.unpack + +instance Arbitrary a => Arbitrary (V.Vector a) where + arbitrary = V.fromList <$> arbitrary + shrink = map V.fromList . shrink . V.toList + +instance Arbitrary S.Scientific where + arbitrary = S.scientific <$> arbitrary <*> arbitrary + shrink s = map (uncurry S.scientific) $ shrink $ ( S.coefficient s, S.base10Exponent s )