diff --git a/package.yaml b/package.yaml index b87947d..cb76841 100644 --- a/package.yaml +++ b/package.yaml @@ -20,10 +20,10 @@ dependencies: - containers - hedgehog - mtl -- servant >= 0.17 -- servant-client >= 0.17 +- servant # >= 0.17 +- servant-client # >= 0.17 - servant-flatten -- servant-server >= 0.17 +- servant-server # >= 0.17 - string-conversions ghc-options: -Wall diff --git a/roboservant.cabal b/roboservant.cabal index 6c4c39a..66f44f8 100644 --- a/roboservant.cabal +++ b/roboservant.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- --- hash: 179b83962de30f5bcf8b13d2f0648b301a753367094171f21a68e60b5cb4e4d5 +-- hash: 0bfe1c9487789846b43d871520e7e546842a8ff9acb003e426d5282dac1e6aa1 name: roboservant version: 0.1.0.2 @@ -42,10 +42,10 @@ library , containers , hedgehog , mtl - , servant >=0.17 - , servant-client >=0.17 + , servant + , servant-client , servant-flatten - , servant-server >=0.17 + , servant-server , string-conversions default-language: Haskell2010 @@ -54,6 +54,7 @@ test-suite roboservant-test main-is: Spec.hs other-modules: Foo + Headers UnsafeIO Paths_roboservant hs-source-dirs: @@ -67,9 +68,9 @@ test-suite roboservant-test , hedgehog , mtl , roboservant - , servant >=0.17 - , servant-client >=0.17 + , servant + , servant-client , servant-flatten - , servant-server >=0.17 + , servant-server , string-conversions default-language: Haskell2010 diff --git a/test/Headers.hs b/test/Headers.hs new file mode 100644 index 0000000..704eb2a --- /dev/null +++ b/test/Headers.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} + +module Headers where + +import Data.Aeson +import Data.Typeable (Typeable) +import GHC.Generics (Generic) +import Servant + +newtype Foo = Foo Int + deriving (Generic, Eq, Show, Typeable) + deriving newtype (FromHttpApiData, ToHttpApiData) + +instance ToJSON Foo + +instance FromJSON Foo + +type Api = + "item" :> Get '[JSON] Foo + :<|> "itemAdd" :> Header "one" Foo :> Header "two" Foo :> Get '[JSON] Foo + :<|> "item" :> Capture "itemId" Foo :> Get '[JSON] () + +intro :: Handler Foo +intro = pure (Foo 1) + +combine :: Maybe Foo -> Maybe Foo -> Handler Foo +combine (Just (Foo a)) (Just (Foo b)) = pure (Foo (a + b)) +combine (Just a) Nothing = pure a +combine Nothing (Just a) = pure a +combine Nothing Nothing = pure (Foo 1) + + +eliminate :: Foo -> Handler () +eliminate (Foo a) + | a > 10 = throwError $ err500 {errBody = "eliminate blew up, oh no!"} + | otherwise = pure () + +server :: Server Api +server = + intro + :<|> combine + :<|> eliminate diff --git a/test/Spec.hs b/test/Spec.hs index c2ad495..2cc0965 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -2,6 +2,7 @@ {-# LANGUAGE TypeApplications #-} import qualified Foo +import qualified Headers import Hedgehog (Group (..), checkSequential, withTests) import qualified Roboservant as RS import qualified UnsafeIO @@ -17,6 +18,10 @@ main :: IO () main = do assert "should find an error in Foo" . not =<< checkSequential (Group "Foo" [("Foo", withTests 100000 $ RS.prop_sequential @Foo.FooApi Foo.fooServer)]) + + assert "should find an error in Headers" . not + =<< checkSequential (Group "Headers" [("Headers", withTests 10000 $ RS.prop_sequential @Headers.Api Headers.server)]) + -- The UnsafeIO checker does not actually really use the contextually aware stuff, though it -- could: it's mostly here to show how to test for concurrency problems. unsafeServer <- UnsafeIO.makeServer