packages feed

webgear-server 1.0.4 → 1.0.5

raw patch · 11 files changed

+55/−46 lines, 11 filesdep ~basedep ~josedep ~webgear-core

Dependency ranges changed: base, jose, webgear-core

Files

CHANGELOG.md view
@@ -2,6 +2,11 @@  ## [Unreleased] +## [1.0.5] - 2023-05-04++### Changed+- Update dependency bounds and GHC versions+ ## [1.0.4] - 2022-08-27  ### Changed@@ -52,7 +57,8 @@ - Automated tests - Documentation -[Unreleased]: https://github.com/haskell-webgear/webgear/compare/v1.0.4...HEAD+[Unreleased]: https://github.com/haskell-webgear/webgear/compare/v1.0.5...HEAD+[1.0.5]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.5 [1.0.4]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.4 [1.0.3]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.3 [1.0.2]: https://github.com/haskell-webgear/webgear/releases/tag/v1.0.2
src/WebGear/Server/Handler.hs view
@@ -34,10 +34,10 @@ newtype ServerHandler m a b = ServerHandler {unServerHandler :: (a, RoutePath) -> m (Either RouteMismatch b, RoutePath)}  instance Monad m => Cat.Category (ServerHandler m) where-  {-# INLINEABLE id #-}+  {-# INLINE id #-}   id = ServerHandler $ \(a, s) -> pure (Right a, s) -  {-# INLINEABLE (.) #-}+  {-# INLINE (.) #-}   ServerHandler f . ServerHandler g = ServerHandler $ \(a, s) ->     g (a, s) >>= \case       (Left e, s') -> pure (Left e, s')@@ -46,31 +46,31 @@ instance Monad m => Arrow (ServerHandler m) where   arr f = ServerHandler (\(a, s) -> pure (Right (f a), s)) -  {-# INLINEABLE first #-}+  {-# INLINE first #-}   first (ServerHandler f) = ServerHandler $ \((a, c), s) ->     f (a, s) >>= \case       (Left e, s') -> pure (Left e, s')       (Right b, s') -> pure (Right (b, c), s') -  {-# INLINEABLE second #-}+  {-# INLINE second #-}   second (ServerHandler f) = ServerHandler $ \((c, a), s) ->     f (a, s) >>= \case       (Left e, s') -> pure (Left e, s')       (Right b, s') -> pure (Right (c, b), s')  instance Monad m => ArrowZero (ServerHandler m) where-  {-# INLINEABLE zeroArrow #-}+  {-# INLINE zeroArrow #-}   zeroArrow = ServerHandler (\(_a, s) -> pure (Left mempty, s))  instance Monad m => ArrowPlus (ServerHandler m) where-  {-# INLINEABLE (<+>) #-}+  {-# INLINE (<+>) #-}   ServerHandler f <+> ServerHandler g = ServerHandler $ \(a, s) ->     f (a, s) >>= \case       (Left _e, _s') -> g (a, s)       (Right b, s') -> pure (Right b, s')  instance Monad m => ArrowChoice (ServerHandler m) where-  {-# INLINEABLE left #-}+  {-# INLINE left #-}   left (ServerHandler f) = ServerHandler $ \(bd, s) ->     case bd of       Right d -> pure (Right (Right d), s)@@ -79,7 +79,7 @@           (Left e, s') -> pure (Left e, s')           (Right c, s') -> pure (Right (Left c), s') -  {-# INLINEABLE right #-}+  {-# INLINE right #-}   right (ServerHandler f) = ServerHandler $ \(db, s) ->     case db of       Left d -> pure (Right (Left d), s)@@ -89,16 +89,16 @@           (Right c, s') -> pure (Right (Right c), s')  instance Monad m => ArrowError RouteMismatch (ServerHandler m) where-  {-# INLINEABLE raise #-}+  {-# INLINE raise #-}   raise = ServerHandler $ \(e, s) -> pure (Left e, s) -  {-# INLINEABLE handle #-}+  {-# INLINE handle #-}   (ServerHandler action) `handle` (ServerHandler errHandler) = ServerHandler $ \(a, s) ->     action (a, s) >>= \case       (Left e, s') -> errHandler ((a, e), s')       (Right b, s') -> pure (Right b, s') -  {-# INLINEABLE tryInUnless #-}+  {-# INLINE tryInUnless #-}   tryInUnless (ServerHandler action) (ServerHandler resHandler) (ServerHandler errHandler) =     ServerHandler $ \(a, s) ->       action (a, s) >>= \case@@ -106,20 +106,20 @@         (Right b, s') -> resHandler ((a, b), s')  instance Monad m => Handler (ServerHandler m) m where-  {-# INLINEABLE arrM #-}+  {-# INLINE arrM #-}   arrM :: (a -> m b) -> ServerHandler m a b   arrM f = ServerHandler $ \(a, s) -> f a >>= \b -> pure (Right b, s) -  {-# INLINEABLE consumeRoute #-}+  {-# INLINE consumeRoute #-}   consumeRoute :: ServerHandler m RoutePath a -> ServerHandler m () a   consumeRoute (ServerHandler h) = ServerHandler $     \((), path) -> h (path, RoutePath []) -  {-# INLINEABLE setDescription #-}+  {-# INLINE setDescription #-}   setDescription :: Description -> ServerHandler m a a   setDescription _ = Cat.id -  {-# INLINEABLE setSummary #-}+  {-# INLINE setSummary #-}   setSummary :: Summary -> ServerHandler m a a   setSummary _ = Cat.id @@ -135,6 +135,7 @@   -- | The result of the arrow   m (Either RouteMismatch b) runServerHandler (ServerHandler h) path a = fst <$> h (a, path)+{-# INLINE runServerHandler #-}  -- | Convert a ServerHandler to a WAI application toApplication :: ServerHandler IO (Linked '[] Request) Response -> Wai.Application@@ -154,6 +155,10 @@     addServerHeader :: Response -> Response     addServerHeader resp@Response{..} = resp{responseHeaders = responseHeaders <> webGearServerHeader} +    webGearServerHeader :: HM.HashMap HTTP.HeaderName ByteString+    webGearServerHeader = HM.singleton HTTP.hServer (fromString $ "WebGear/" ++ showVersion version)+{-# INLINE toApplication #-}+ {- | Transform a `ServerHandler` running in one monad to another monad.   This is useful in cases where the server is running in a custom@@ -178,6 +183,4 @@   ServerHandler n a b transform f (ServerHandler g) =   ServerHandler $ f . g--webGearServerHeader :: HM.HashMap HTTP.HeaderName ByteString-webGearServerHeader = HM.singleton HTTP.hServer (fromString $ "WebGear/" ++ showVersion version)+{-# INLINE transform #-}
src/WebGear/Server/Trait/Auth/Basic.hs view
@@ -33,7 +33,7 @@   ) =>   Get (ServerHandler m) (BasicAuth' Required scheme m e a) Request   where-  {-# INLINEABLE getTrait #-}+  {-# INLINE getTrait #-}   getTrait ::     BasicAuth' Required scheme m e a ->     ServerHandler m (Linked ts Request) (Either (BasicAuthError e) a)@@ -64,7 +64,7 @@   ) =>   Get (ServerHandler m) (BasicAuth' Optional scheme m e a) Request   where-  {-# INLINEABLE getTrait #-}+  {-# INLINE getTrait #-}   getTrait ::     BasicAuth' Optional scheme m e a ->     ServerHandler m (Linked ts Request) (Either Void (Either (BasicAuthError e) a))
src/WebGear/Server/Trait/Auth/JWT.hs view
@@ -23,7 +23,7 @@ import WebGear.Server.Handler (ServerHandler)  instance (MonadTime m, Get (ServerHandler m) (AuthorizationHeader scheme) Request) => Get (ServerHandler m) (JWTAuth' Required scheme m e a) Request where-  {-# INLINEABLE getTrait #-}+  {-# INLINE getTrait #-}   getTrait ::     JWTAuth' Required scheme m e a ->     ServerHandler m (Linked ts Request) (Either (JWTAuthError e) a)@@ -46,7 +46,7 @@         lift (toJWTAttribute claims) >>= either (throwError . JWTAuthAttributeError) pure  instance (MonadTime m, Get (ServerHandler m) (AuthorizationHeader scheme) Request) => Get (ServerHandler m) (JWTAuth' Optional scheme m e a) Request where-  {-# INLINEABLE getTrait #-}+  {-# INLINE getTrait #-}   getTrait ::     JWTAuth' Optional scheme m e a ->     ServerHandler m (Linked ts Request) (Either Void (Either (JWTAuthError e) a))
src/WebGear/Server/Trait/Body.hs view
@@ -19,7 +19,7 @@ import WebGear.Server.Handler (ServerHandler)  instance (MonadIO m, FromByteString val) => Get (ServerHandler m) (Body val) Request where-  {-# INLINEABLE getTrait #-}+  {-# INLINE getTrait #-}   getTrait :: Body val -> ServerHandler m (Linked ts Request) (Either Text val)   getTrait (Body _) = arrM $ \request -> do     chunks <- takeWhileM (/= mempty) $ repeat $ liftIO $ getRequestBodyChunk $ unlink request@@ -28,7 +28,7 @@       Right t -> Right t  instance (Monad m, ToByteString val) => Set (ServerHandler m) (Body val) Response where-  {-# INLINEABLE setTrait #-}+  {-# INLINE setTrait #-}   setTrait ::     Body val ->     (Linked ts Response -> Response -> val -> Linked (Body val : ts) Response) ->@@ -47,7 +47,7 @@     returnA -< f linkedResponse response' val  instance (MonadIO m, Aeson.FromJSON val) => Get (ServerHandler m) (JSONBody val) Request where-  {-# INLINEABLE getTrait #-}+  {-# INLINE getTrait #-}   getTrait :: JSONBody val -> ServerHandler m (Linked ts Request) (Either Text val)   getTrait (JSONBody _) = arrM $ \request -> do     chunks <- takeWhileM (/= mempty) $ repeat $ liftIO $ getRequestBodyChunk $ unlink request@@ -56,7 +56,7 @@       Right t -> Right t  instance (Monad m, Aeson.ToJSON val) => Set (ServerHandler m) (JSONBody val) Response where-  {-# INLINEABLE setTrait #-}+  {-# INLINE setTrait #-}   setTrait ::     JSONBody val ->     (Linked ts Response -> Response -> val -> Linked (JSONBody val : ts) Response) ->
src/WebGear/Server/Trait/Header.hs view
@@ -29,7 +29,7 @@   returnA -< parseHeader <$> requestHeader headerName (unlink req)  instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (Header Required Strict name val) Request where-  {-# INLINEABLE getTrait #-}+  {-# INLINE getTrait #-}   getTrait ::     Header Required Strict name val ->     ServerHandler m (Linked ts Request) (Either (Either HeaderNotFound HeaderParseError) val)@@ -41,7 +41,7 @@         Just (Right x) -> Right x  instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (Header Optional Strict name val) Request where-  {-# INLINEABLE getTrait #-}+  {-# INLINE getTrait #-}   getTrait ::     Header Optional Strict name val ->     ServerHandler m (Linked ts Request) (Either HeaderParseError (Maybe val))@@ -53,7 +53,7 @@         Just (Right x) -> Right $ Just x  instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (Header Required Lenient name val) Request where-  {-# INLINEABLE getTrait #-}+  {-# INLINE getTrait #-}   getTrait ::     Header Required Lenient name val ->     ServerHandler m (Linked ts Request) (Either HeaderNotFound (Either Text val))@@ -65,7 +65,7 @@         Just (Right x) -> Right $ Right x  instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (Header Optional Lenient name val) Request where-  {-# INLINEABLE getTrait #-}+  {-# INLINE getTrait #-}   getTrait ::     Header Optional Lenient name val ->     ServerHandler m (Linked ts Request) (Either Void (Maybe (Either Text val)))@@ -77,7 +77,7 @@         Just (Right x) -> Right $ Just $ Right x  instance (Monad m, KnownSymbol name, ToByteString val) => Set (ServerHandler m) (Header Required Strict name val) Response where-  {-# INLINEABLE setTrait #-}+  {-# INLINE setTrait #-}   setTrait ::     Header Required Strict name val ->     (Linked ts Response -> Response -> val -> Linked (Header Required Strict name val : ts) Response) ->@@ -89,7 +89,7 @@     returnA -< f l response' val  instance (Monad m, KnownSymbol name, ToByteString val) => Set (ServerHandler m) (Header Optional Strict name val) Response where-  {-# INLINEABLE setTrait #-}+  {-# INLINE setTrait #-}   setTrait ::     Header Optional Strict name val ->     (Linked ts Response -> Response -> Maybe val -> Linked (Header Optional Strict name val : ts) Response) ->
src/WebGear/Server/Trait/Method.hs view
@@ -11,7 +11,7 @@ import WebGear.Server.Handler (ServerHandler)  instance Monad m => Get (ServerHandler m) Method Request where-  {-# INLINEABLE getTrait #-}+  {-# INLINE getTrait #-}   getTrait :: Method -> ServerHandler m (Linked ts Request) (Either MethodMismatch HTTP.StdMethod)   getTrait (Method method) = proc request -> do     let expectedMethod = HTTP.renderStdMethod method
src/WebGear/Server/Trait/Path.hs view
@@ -13,7 +13,7 @@ import WebGear.Server.Handler (ServerHandler (..))  instance Monad m => Get (ServerHandler m) Path Request where-  {-# INLINEABLE getTrait #-}+  {-# INLINE getTrait #-}   getTrait :: Path -> ServerHandler m (Linked ts Request) (Either () ())   getTrait (Path p) = ServerHandler $ \(_, path@(RoutePath remaining)) -> do     let expected = filter (/= "") $ Text.splitOn "/" p@@ -22,7 +22,7 @@       Nothing -> (Right (Left ()), path)  instance (Monad m, FromHttpApiData val) => Get (ServerHandler m) (PathVar tag val) Request where-  {-# INLINEABLE getTrait #-}+  {-# INLINE getTrait #-}   getTrait :: PathVar tag val -> ServerHandler m (Linked ts Request) (Either PathVarError val)   getTrait PathVar = ServerHandler $ \(_, path@(RoutePath remaining)) -> do     pure $ case remaining of@@ -33,7 +33,7 @@           Right val -> (Right (Right val), RoutePath ps)  instance Monad m => Get (ServerHandler m) PathEnd Request where-  {-# INLINEABLE getTrait #-}+  {-# INLINE getTrait #-}   getTrait :: PathEnd -> ServerHandler m (Linked ts Request) (Either () ())   getTrait PathEnd = ServerHandler f     where
src/WebGear/Server/Trait/QueryParam.hs view
@@ -32,7 +32,7 @@   returnA -< parseQueryParam <$> (find ((== name) . fst) params >>= snd)  instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (QueryParam Required Strict name val) Request where-  {-# INLINEABLE getTrait #-}+  {-# INLINE getTrait #-}   getTrait ::     QueryParam Required Strict name val ->     ServerHandler m (Linked ts Request) (Either (Either ParamNotFound ParamParseError) val)@@ -44,7 +44,7 @@         Just (Right x) -> Right x  instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (QueryParam Optional Strict name val) Request where-  {-# INLINEABLE getTrait #-}+  {-# INLINE getTrait #-}   getTrait ::     QueryParam Optional Strict name val ->     ServerHandler m (Linked ts Request) (Either ParamParseError (Maybe val))@@ -56,7 +56,7 @@         Just (Right x) -> Right $ Just x  instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (QueryParam Required Lenient name val) Request where-  {-# INLINEABLE getTrait #-}+  {-# INLINE getTrait #-}   getTrait ::     QueryParam Required Lenient name val ->     ServerHandler m (Linked ts Request) (Either ParamNotFound (Either Text val))@@ -68,7 +68,7 @@         Just (Right x) -> Right $ Right x  instance (Monad m, KnownSymbol name, FromHttpApiData val) => Get (ServerHandler m) (QueryParam Optional Lenient name val) Request where-  {-# INLINEABLE getTrait #-}+  {-# INLINE getTrait #-}   getTrait ::     QueryParam Optional Lenient name val ->     ServerHandler m (Linked ts Request) (Either Void (Maybe (Either Text val)))
src/WebGear/Server/Trait/Status.hs view
@@ -11,7 +11,7 @@ import WebGear.Server.Handler (ServerHandler)  instance Monad m => Set (ServerHandler m) Status Response where-  {-# INLINEABLE setTrait #-}+  {-# INLINE setTrait #-}   setTrait ::     Status ->     (Linked ts Response -> Response -> HTTP.Status -> Linked (Status : ts) Response) ->
webgear-server.cabal view
@@ -1,6 +1,6 @@ cabal-version:       2.4 name:                webgear-server-version:             1.0.4+version:             1.0.5 synopsis:            Composable, type-safe library to build HTTP API servers description:     WebGear is a library to for building composable, type-safe HTTP API servers.@@ -53,13 +53,13 @@                       TypeApplications                       TypeFamilies                       TypeOperators-  build-depends:      base >=4.13.0.0 && <4.18+  build-depends:      base >=4.13.0.0 && <4.19                     , base64-bytestring >=1.0.0.3 && <1.3                     , bytestring >=0.10.10.1 && <0.12                     , http-types ==0.12.*                     , text >=1.2.0.0 && <2.1                     , wai ==3.2.*-                    , webgear-core ==1.0.4+                    , webgear-core ==1.0.5   ghc-options:        -Wall                       -Wno-unticked-promoted-constructors                       -Wcompat@@ -97,7 +97,7 @@                     , bytestring-conversion ==0.3.*                     , http-api-data >=0.4.2 && <0.6                     , http-media ==0.8.*-                    , jose >=0.8.3.1 && <0.10+                    , jose >=0.8.3.1 && <0.11                     , monad-time >=0.3.0.0 && <0.5                     , mtl >=2.2 && <2.4                     , unordered-containers ==0.2.*