wai-middleware-content-type 0.3.0 → 0.4.0

raw patch · 14 files changed

+185/−71 lines, 14 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• src/Network/Wai/Middleware/ContentType.hs +8/−6
• src/Network/Wai/Middleware/ContentType/Blaze.hs +12/−3
• src/Network/Wai/Middleware/ContentType/ByteString.hs +8/−3
• src/Network/Wai/Middleware/ContentType/Cassius.hs +13/−3
• src/Network/Wai/Middleware/ContentType/Clay.hs +13/−3
• src/Network/Wai/Middleware/ContentType/Json.hs +8/−3
• src/Network/Wai/Middleware/ContentType/Julius.hs +13/−3
• src/Network/Wai/Middleware/ContentType/Lucid.hs +13/−4
• src/Network/Wai/Middleware/ContentType/Lucius.hs +13/−3
• src/Network/Wai/Middleware/ContentType/Pandoc.hs +13/−3
• src/Network/Wai/Middleware/ContentType/Text.hs +12/−3
• src/Network/Wai/Middleware/ContentType/Types.hs +55/−25
• test/Network/Wai/Middleware/ContentTypeSpec.hs +2/−2
• wai-middleware-content-type.cabal +2/−7

@@ -53,11 +53,13 @@ -- a map of responses, find a response. lookupFileExt :: Maybe AcceptHeader               -> Maybe FileExt-              -> FileExtMap r-              -> Maybe r-lookupFileExt mAcceptBS mFe fexts =-  getFirst . foldMap (First . flip HM.lookup fexts) . findFE $-    maybe allFileExts possibleFileExts mAcceptBS+              -> FileExtMap+              -> Maybe Response+lookupFileExt mAcceptBS mFe map =+    getFirst+  . foldMap (\fe -> First $ runResponseVia <$> HM.lookup fe map)+  . findFE+  $ maybe allFileExts possibleFileExts mAcceptBS   where     findFE :: [FileExt] -> [FileExt]     findFE xs =@@ -65,7 +67,7 @@         Nothing -> xs         Just fe -> fe <$ guard (fe `elem` xs) -fileExtsToMiddleware :: Monad m => FileExtListenerT Response m a -> MiddlewareT m+fileExtsToMiddleware :: Monad m => FileExtListenerT m a -> MiddlewareT m fileExtsToMiddleware xs app req respond = do   map <- execFileExtListenerT xs   let mAcceptHeader = lookup "Accept" (requestHeaders req)

@@ -1,7 +1,11 @@+{-# LANGUAGE+    OverloadedStrings+  #-}+ module Network.Wai.Middleware.ContentType.Blaze where  import           Network.Wai.Middleware.ContentType.Types-import           Network.HTTP.Types                      (Status, ResponseHeaders)+import           Network.HTTP.Types                      (status200, Status, ResponseHeaders) import           Network.Wai                             (Response, responseBuilder)  import qualified Text.Blaze.Html                         as H@@ -13,9 +17,14 @@  blaze :: Monad m =>          H.Html-      -> FileExtListenerT (Status -> ResponseHeaders -> Response) m ()+      -> FileExtListenerT m () blaze i =-  tell' $ HM.singleton Html (blazeOnly i)+  tell' $ HM.singleton Html $+    ResponseVia+      i+      status200+      [("Content-Type", "text/html")]+      blazeOnly  {-# INLINEABLE blaze #-} 

@@ -1,7 +1,7 @@ module Network.Wai.Middleware.ContentType.ByteString where  import           Network.Wai.Middleware.ContentType.Types-import           Network.HTTP.Types                      (Status, ResponseHeaders)+import           Network.HTTP.Types                      (status200, Status, ResponseHeaders) import           Network.Wai                             (Response, responseLBS)  import qualified Data.ByteString.Lazy                    as LBS@@ -14,9 +14,14 @@ bytestring :: Monad m =>               FileExt            -> LBS.ByteString-           -> FileExtListenerT (Status -> ResponseHeaders -> Response) m ()+           -> FileExtListenerT m () bytestring fe i =-  tell' $ HM.singleton fe (bytestringOnly i)+  tell' $ HM.singleton fe $+    ResponseVia+      i+      status200+      []+      bytestringOnly  {-# INLINEABLE bytestring #-} 

@@ -1,8 +1,13 @@+{-# LANGUAGE+    OverloadedStrings+  #-}++ module Network.Wai.Middleware.ContentType.Cassius where  import           Network.Wai.Middleware.ContentType.Types as CT import           Network.Wai.Middleware.ContentType.Text-import           Network.HTTP.Types                       (Status, ResponseHeaders)+import           Network.HTTP.Types                       (status200, Status, ResponseHeaders) import           Network.Wai                              (Response)  import           Text.Cassius@@ -13,9 +18,14 @@  cassius :: Monad m =>            Css-        -> FileExtListenerT (Status -> ResponseHeaders -> Response) m ()+        -> FileExtListenerT m () cassius i =-  tell' $ HM.singleton CT.Css (cassiusOnly i)+  tell' $ HM.singleton CT.Css $+    ResponseVia+      i+      status200+      [("Content-Type", "text/css")]+      cassiusOnly  {-# INLINEABLE cassius #-} 

@@ -1,8 +1,13 @@+{-# LANGUAGE+    OverloadedStrings+  #-}++ module Network.Wai.Middleware.ContentType.Clay where  import           Network.Wai.Middleware.ContentType.Types as CT import           Network.Wai.Middleware.ContentType.Text-import           Network.HTTP.Types                       (Status, ResponseHeaders)+import           Network.HTTP.Types                       (status200, Status, ResponseHeaders) import           Network.Wai                              (Response)  import           Clay.Render@@ -14,9 +19,14 @@  clay :: Monad m =>         Config -> [App] -> Css-     -> FileExtListenerT (Status -> ResponseHeaders -> Response) m ()+     -> FileExtListenerT m () clay c as i =-  tell' $ HM.singleton CT.Css (clayOnly c as i)+  tell' $ HM.singleton CT.Css $+    ResponseVia+      (c,as,i)+      status200+      [("Content-Type","text/css")]+      (\(c,as,i) -> clayOnly c as i)  {-# INLINEABLE clay #-} 

@@ -1,8 +1,12 @@+{-# LANGUAGE+    OverloadedStrings+  #-}+ module Network.Wai.Middleware.ContentType.Json where  import           Network.Wai.Middleware.ContentType.Types import           Network.Wai.Middleware.ContentType.ByteString-import           Network.HTTP.Types                      (Status, ResponseHeaders)+import           Network.HTTP.Types                      (status200, Status, ResponseHeaders) import           Network.Wai                             (Response)  import qualified Data.Aeson                              as A@@ -14,9 +18,10 @@ json :: ( A.ToJSON j         , Monad m         ) => j-          -> FileExtListenerT (Status -> ResponseHeaders -> Response) m ()+          -> FileExtListenerT m () json =-  bytestring Json . A.encode+  (overFileExts [Json] $ mapHeaders (("Content-Type","application/json"):))+  . bytestring Json . A.encode  {-# INLINEABLE json #-} 

@@ -1,8 +1,13 @@+{-# LANGUAGE+    OverloadedStrings+  #-}++ module Network.Wai.Middleware.ContentType.Julius where  import           Network.Wai.Middleware.ContentType.Types as CT import           Network.Wai.Middleware.ContentType.Text-import           Network.HTTP.Types                       (Status, ResponseHeaders)+import           Network.HTTP.Types                       (status200, Status, ResponseHeaders) import           Network.Wai                              (Response)  import           Text.Julius@@ -13,9 +18,14 @@  julius :: Monad m =>           Javascript-       -> FileExtListenerT (Status -> ResponseHeaders -> Response) m ()+       -> FileExtListenerT m () julius i =-  tell' $ HM.singleton CT.JavaScript (juliusOnly i)+  tell' $ HM.singleton CT.JavaScript $+    ResponseVia+      i+      status200+      [("Content-Type","application/javascript")]+      juliusOnly  {-# INLINEABLE julius #-} 

@@ -1,7 +1,11 @@+{-# LANGUAGE+    OverloadedStrings+  #-}+ module Network.Wai.Middleware.ContentType.Lucid where  import           Network.Wai.Middleware.ContentType.Types-import           Network.HTTP.Types                      (Status, ResponseHeaders)+import           Network.HTTP.Types                      (status200, Status, ResponseHeaders) import           Network.Wai                             (Response, responseBuilder)  import qualified Lucid.Base                              as L@@ -13,10 +17,15 @@  lucid :: Monad m =>          L.HtmlT m ()-      -> FileExtListenerT (Status -> ResponseHeaders -> Response) m ()+      -> FileExtListenerT m () lucid i = do-  i' <- lift (lucidOnly i)-  tell' (HM.singleton Html i')+  f <- lift (lucidOnly i)+  tell' $ HM.singleton Html $+    ResponseVia+      i+      status200+      [("Content-Type","text/html")]+      (const f)  {-# INLINEABLE lucid #-} 

@@ -1,8 +1,13 @@+{-# LANGUAGE+    OverloadedStrings+  #-}++ module Network.Wai.Middleware.ContentType.Lucius where  import           Network.Wai.Middleware.ContentType.Types as CT import           Network.Wai.Middleware.ContentType.Text-import           Network.HTTP.Types                       (Status, ResponseHeaders)+import           Network.HTTP.Types                       (status200, Status, ResponseHeaders) import           Network.Wai                              (Response)  import           Text.Lucius@@ -13,9 +18,14 @@  lucius :: Monad m =>           Css-       -> FileExtListenerT (Status -> ResponseHeaders -> Response) m ()+       -> FileExtListenerT m () lucius i =-  tell' $ HM.singleton CT.Css (luciusOnly i)+  tell' $ HM.singleton CT.Css $+    ResponseVia+      i+      status200+      [("Content-Type","text/css")]+      luciusOnly  {-# INLINEABLE lucius #-} 

@@ -1,8 +1,13 @@+{-# LANGUAGE+    OverloadedStrings+  #-}++ module Network.Wai.Middleware.ContentType.Pandoc where  import           Network.Wai.Middleware.ContentType.Types import           Network.Wai.Middleware.ContentType.Text-import           Network.HTTP.Types                       (Status, ResponseHeaders)+import           Network.HTTP.Types                       (status200, Status, ResponseHeaders) import           Network.Wai                              (Response)  import qualified Data.Text.Lazy                           as LT@@ -14,9 +19,14 @@  markdown :: Monad m =>             P.Pandoc-         -> FileExtListenerT (Status -> ResponseHeaders -> Response) m ()+         -> FileExtListenerT m () markdown i =-  tell' $ HM.singleton Markdown (markdownOnly i)+  tell' $ HM.singleton Markdown $+    ResponseVia+      i+      status200+      [("Content-Type","text/markdown")]+      markdownOnly  {-# INLINEABLE markdown #-} 

@@ -1,7 +1,11 @@+{-# LANGUAGE+    OverloadedStrings+  #-}+ module Network.Wai.Middleware.ContentType.Text where  import           Network.Wai.Middleware.ContentType.Types-import           Network.HTTP.Types                       (Status, ResponseHeaders)+import           Network.HTTP.Types                       (status200, Status, ResponseHeaders) import           Network.Wai                              (Response, responseBuilder)  import qualified Data.Text.Lazy                           as LT@@ -13,9 +17,14 @@  text :: Monad m =>         LT.Text-     -> FileExtListenerT (Status -> ResponseHeaders -> Response) m ()+     -> FileExtListenerT m () text i =-  tell' $ HM.singleton Text (textOnly i)+  tell' $ HM.singleton Text $+    ResponseVia+      i+      status200+      [("Content-Type", "text/plain")]+      textOnly  {-# INLINEABLE text #-} 

@@ -8,6 +8,7 @@   , StandaloneDeriving   , UndecidableInstances   , MultiParamTypeClasses+  , ExistentialQuantification   , GeneralizedNewtypeDeriving   #-} @@ -27,10 +28,15 @@   , allFileExts   , getFileExt   , toExt+  , ResponseVia (..)+  , runResponseVia+  , mapStatus+  , mapHeaders   , FileExtMap   , FileExtListenerT (..)   , execFileExtListenerT-  , mapResponse+  , overFileExts+  , mapFileExtMap   , -- * Utilities     tell'   , AcceptHeader@@ -118,9 +124,37 @@ {-# INLINEABLE toExt #-}  +-- ayy, lamo. Basically.+data ResponseVia = forall a. ResponseVia+  { responseData     :: !a+  , responseStatus   :: !Status+  , responseHeaders  :: !ResponseHeaders+  , responseFunction :: !(a -> Status -> ResponseHeaders -> Response)+  } -type FileExtMap a = HashMap FileExt a+runResponseVia :: ResponseVia -> Response+runResponseVia (ResponseVia d s hs f) = f d s hs +mapStatus :: (Status -> Status) -> ResponseVia -> ResponseVia+mapStatus f (ResponseVia d s hs f') = ResponseVia d (f s) hs f'++mapHeaders :: (ResponseHeaders -> ResponseHeaders) -> ResponseVia -> ResponseVia+mapHeaders f (ResponseVia d s hs f') = ResponseVia d s (f hs) f'++overFileExts :: Monad m =>+                [FileExt]+             -> (ResponseVia -> ResponseVia)+             -> FileExtListenerT m a+             -> FileExtListenerT m a+overFileExts fs f (FileExtListenerT xs) = do+  i <- get+  let i' = HM.mapWithKey (\k x -> if k `elem` fs then f x else x) i+  (x, o) <- lift (runStateT xs i')+  put o+  pure x++type FileExtMap = HashMap FileExt ResponseVia+ -- | The monad for our DSL - when using the combinators, our result will be this --   type: --@@ -128,43 +162,39 @@ --   > myListener = do --   >   text "Text!" --   >   json ("Json!" :: T.Text)-newtype FileExtListenerT r m a = FileExtListenerT-  { runFileExtListenerT :: StateT (FileExtMap r) m a+newtype FileExtListenerT m a = FileExtListenerT+  { runFileExtListenerT :: StateT FileExtMap m a   } deriving ( Functor, Applicative, Alternative, Monad, MonadFix, MonadPlus, MonadIO-             , MonadTrans, MonadReader r', MonadWriter w, MonadState (FileExtMap r)+             , MonadTrans, MonadReader r', MonadWriter w, MonadState FileExtMap              , MonadCont, MonadError e, MonadBase b, MonadThrow, MonadCatch              , MonadMask, MonadLogger, MonadUrl b f, MFunctor              ) -deriving instance (MonadResource m, MonadBase IO m) => MonadResource (FileExtListenerT r m)+deriving instance (MonadResource m, MonadBase IO m) => MonadResource (FileExtListenerT m) -instance MonadTransControl (FileExtListenerT r) where-  type StT (FileExtListenerT r) a = StT (StateT (FileExtMap r)) a+instance MonadTransControl FileExtListenerT where+  type StT FileExtListenerT a = StT (StateT FileExtMap) a   liftWith = defaultLiftWith FileExtListenerT runFileExtListenerT   restoreT = defaultRestoreT FileExtListenerT  instance ( MonadBaseControl b m-         ) => MonadBaseControl b (FileExtListenerT r m) where-  type StM (FileExtListenerT r m) a = ComposeSt (FileExtListenerT r) m a+         ) => MonadBaseControl b (FileExtListenerT m) where+  type StM (FileExtListenerT m) a = ComposeSt FileExtListenerT m a   liftBaseWith = defaultLiftBaseWith   restoreM     = defaultRestoreM -mapResponse :: Monad m =>-               ((Status -> ResponseHeaders -> Response) -> Response)-            -> FileExtListenerT (Status -> ResponseHeaders -> Response) m a-            -> FileExtListenerT Response m a-mapResponse f (FileExtListenerT xs) =-  FileExtListenerT $ mapState (HM.map f) (HM.map (const . const)) xs-  where-    mapState to from xs = do-      i <- get-      (x,s) <- lift (runStateT xs (from i))-      put (to s)-      pure x--execFileExtListenerT :: Monad m => FileExtListenerT r m a -> m (FileExtMap r)+execFileExtListenerT :: Monad m => FileExtListenerT m a -> m FileExtMap execFileExtListenerT xs = execStateT (runFileExtListenerT xs) mempty +mapFileExtMap :: ( Monad m+                 ) => (FileExtMap -> FileExtMap)+                   -> FileExtListenerT m a+                   -> FileExtListenerT m a+mapFileExtMap f (FileExtListenerT xs) = do+  map      <- get+  (x,map') <- lift (runStateT xs (f map))+  put map'+  return x   -- * Headers@@ -205,7 +235,7 @@ --   > myApp = do --   >   text "foo" --   >   invalidEncoding myErrorHandler -- handles all except text/plain-invalidEncoding :: Monad m => r -> FileExtListenerT r m ()+invalidEncoding :: Monad m => ResponseVia -> FileExtListenerT m () invalidEncoding r = mapM_ (\t -> tell' $ HM.singleton t r) allFileExts  {-# INLINEABLE invalidEncoding #-}

@@ -162,8 +162,8 @@   fileExtsToMiddleware allExamples $   (\req respond -> respond (textOnly "Something went wrong" status406 [])) -allExamples :: FileExtListenerT Response IO ()-allExamples = mapResponse (\f -> f status200 []) $ do+allExamples :: FileExtListenerT IO ()+allExamples = do   text "Text!"   json ("Json!" :: T.Text)   lucid (L.toHtmlRaw ("Html!" :: T.Text))

@@ -1,19 +1,14 @@ Name:                   wai-middleware-content-type-Version:                0.3.0+Version:                0.4.0 Author:                 Athan Clark <athan.clark@gmail.com> Maintainer:             Athan Clark <athan.clark@gmail.com> License:                BSD3 License-File:           LICENSE-Synopsis:               Route to different middlewares based on the incoming Accept header.+Synopsis:               A simple WAI library for responding with content. -- Description: Cabal-Version:          >= 1.10 Build-Type:             Simple Category:               Web---Flag Example-  Description:          Build a trivial example-  Default:              False   Library