wai-middleware-content-type 0.5.0.1 → 0.5.1

raw patch · 6 files changed

+85/−46 lines, 6 filesdep +extractable-singletondep +monad-control-aligneddep +wai-loggerPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: extractable-singleton, monad-control-aligned, wai-logger

API changes (from Hackage documentation)

Files

• src/Network/Wai/Middleware/ContentType.hs +17/−8
• src/Network/Wai/Middleware/ContentType/ByteString.hs +6/−2
• src/Network/Wai/Middleware/ContentType/Json.hs +2/−1
• src/Network/Wai/Middleware/ContentType/Types.hs +35/−13
• test/Network/Wai/Middleware/ContentTypeSpec.hs +21/−21
• wai-middleware-content-type.cabal +4/−1

@@ -1,5 +1,6 @@ {-# LANGUAGE     OverloadedStrings+  , FlexibleContexts   #-}  {- |@@ -45,10 +46,14 @@  import Network.Wai.Trans (Response, MiddlewareT, requestHeaders,                          pathInfo)+import Network.Wai.Logger (withStdoutLogger) import qualified Data.HashMap.Lazy as HM import qualified Data.HashSet  as HS import Data.Monoid import Control.Monad+import Control.Monad.Trans.Control.Aligned (MonadBaseControl (..))+import Data.Singleton.Class (Extractable (..))+import Debug.Trace (traceShow)   @@ -72,11 +77,15 @@                 | otherwise    -> []  -fileExtsToMiddleware :: Monad m => FileExtListenerT m a -> MiddlewareT m-fileExtsToMiddleware xs app req respond = do-  m <- execFileExtListenerT xs-  let mAcceptHeader = lookup "Accept" (requestHeaders req)-      mFileExt      = getFileExt (pathInfo req)-  case lookupFileExt mAcceptHeader mFileExt m of-    Nothing -> app req respond-    Just r  -> respond r+fileExtsToMiddleware :: MonadBaseControl IO m stM+                     => Extractable stM+                     => FileExtListenerT m a+                     -> MiddlewareT m+fileExtsToMiddleware xs app req respond =+  liftBaseWith $ \runInBase -> withStdoutLogger $ \aplogger -> fmap runSingleton $ runInBase $ do+    m <- execFileExtListenerT xs (Just (aplogger req))+    let mAcceptHeader = lookup "Accept" (requestHeaders req)+        mFileExt      = getFileExt (pathInfo req)+    case lookupFileExt mAcceptHeader mFileExt m of+      Nothing -> app req respond+      Just r  -> respond r

@@ -6,15 +6,19 @@  import qualified Data.ByteString.Lazy                    as LBS import qualified Data.HashMap.Lazy                       as HM+import           Control.Monad.Reader (ask)+import           Control.Monad.IO.Class (MonadIO (..))   -- * Lifted Combinators -bytestring :: Monad m =>+bytestring :: MonadIO m =>               FileExt            -> LBS.ByteString            -> FileExtListenerT m ()-bytestring fe i =+bytestring fe i = do+  aplogger <- getLogger+  liftIO $ aplogger status200 (Just $ fromIntegral $ LBS.length i)   tell' $ HM.singleton fe $     ResponseVia       i

@@ -10,13 +10,14 @@ import           Network.Wai                             (Response)  import qualified Data.Aeson                              as A+import           Control.Monad.IO.Class (MonadIO (..))    -- * Lifted Combinators  json :: ( A.ToJSON j-        , Monad m+        , MonadIO m         ) => j           -> FileExtListenerT m () json =

@@ -36,6 +36,7 @@   , execFileExtListenerT   , overFileExts   , mapFileExtMap+  , getLogger   , -- * Utilities     tell'   , AcceptHeader@@ -66,8 +67,9 @@  import           GHC.Generics import           Network.HTTP.Types (Status, ResponseHeaders)-import           Network.Wai.Trans (Response) import           Network.HTTP.Media (mapAccept)+import           Network.Wai.Trans (Response)+import           Network.Wai.Logger (ApacheLogger)   -- | Version of 'Control.Monad.Writer.tell' for 'Control.Monad.State.StateT'@@ -84,7 +86,7 @@   | Json   | Text   | Markdown-  | Other T.Text -- ^ incliding prefix period, i.e. `.foo`+  | Other T.Text -- ^ excluding prefix period, i.e. `foo`   deriving (Show, Eq, Ord, Generic)  instance Hashable FileExt@@ -145,10 +147,11 @@              -> (ResponseVia -> ResponseVia)              -> FileExtListenerT m a              -> FileExtListenerT m a-overFileExts fs f (FileExtListenerT xs) = do+overFileExts fs f (FileExtListenerT (ReaderT xs)) = do+  aplogger <- getLogger   i <- get   let i' = HM.mapWithKey (\k x -> if k `elem` fs then f x else x) i-  (x, o) <- lift (runStateT xs i')+  (x, o) <- lift (runStateT (xs aplogger) i')   put o   pure x @@ -162,13 +165,22 @@ --   >   text "Text!" --   >   json ("Json!" :: T.Text) newtype FileExtListenerT m a = FileExtListenerT-  { runFileExtListenerT :: StateT FileExtMap m a+  { runFileExtListenerT :: ReaderT (Status -> Maybe Integer -> IO ()) (StateT FileExtMap m) a   } deriving ( Functor, Applicative, Alternative, Monad, MonadFix, MonadPlus, MonadIO-             , MonadTrans, MonadReader r', MonadWriter w, MonadState FileExtMap+             , MonadWriter w, MonadState FileExtMap              , MonadCont, MonadError e, MonadBase b, MonadThrow, MonadCatch-             , MonadMask, MonadLogger, MonadUrl b f, MFunctor+             , MonadMask, MonadLogger, MonadUrl b f              ) +getLogger :: Monad m => FileExtListenerT m (Status -> Maybe Integer -> IO ())+getLogger = FileExtListenerT $ ReaderT $ \aplogger -> pure aplogger++instance MonadTrans FileExtListenerT where+  lift m = FileExtListenerT $ ReaderT $ \_ -> lift m++instance MonadReader r m => MonadReader r (FileExtListenerT m) where+  ask = FileExtListenerT $ ReaderT $ \_ -> ask+ instance Monad m => Monoid (FileExtListenerT m ()) where   mempty = FileExtListenerT $ put mempty   mappend x y = x >> y@@ -176,9 +188,11 @@ deriving instance (MonadResource m, MonadBase IO m) => MonadResource (FileExtListenerT m)  instance MonadTransControl FileExtListenerT where-  type StT FileExtListenerT a = StT (StateT FileExtMap) a-  liftWith = defaultLiftWith FileExtListenerT runFileExtListenerT-  restoreT = defaultRestoreT FileExtListenerT+  type StT FileExtListenerT a = StT (StateT FileExtMap)+        (StT (ReaderT (Status -> Maybe Integer -> IO ())) a)+  liftWith f = FileExtListenerT $ ReaderT $ \aplogger -> liftWith $ \runInBase ->+    f (\(FileExtListenerT (ReaderT xs)) -> runInBase (xs aplogger))+  restoreT x = FileExtListenerT $ ReaderT $ \_ -> restoreT x  instance ( MonadBaseControl b m          ) => MonadBaseControl b (FileExtListenerT m) where@@ -186,16 +200,24 @@   liftBaseWith = defaultLiftBaseWith   restoreM     = defaultRestoreM -execFileExtListenerT :: Monad m => FileExtListenerT m a -> m FileExtMap-execFileExtListenerT xs = execStateT (runFileExtListenerT xs) mempty+execFileExtListenerT :: Monad m+                     => FileExtListenerT m a+                     -> Maybe (Status -> Maybe Integer -> IO ())+                     -> m FileExtMap+execFileExtListenerT xs mL =+  execStateT+    ( runReaderT (runFileExtListenerT xs)+      (fromMaybe (\_ _ -> pure ()) mL)+    ) mempty  mapFileExtMap :: ( Monad m                  ) => (FileExtMap -> FileExtMap)                    -> FileExtListenerT m a                    -> FileExtListenerT m a mapFileExtMap f (FileExtListenerT xs) = do+  aplogger <- getLogger   m      <- get-  (x,m') <- lift (runStateT xs (f m))+  (x,m') <- lift (runStateT (runReaderT xs aplogger) (f m))   put m'   return x 

@@ -29,37 +29,37 @@         it "should respond with 200" $         HW.request "GET" "/" [("Accept", "text/plain")] "" `shouldRespondWith`         "" { matchStatus = 200-           , matchBody = Just "Text!"+           , matchBody = "Text!"            }       describe "Json" $         it "should respond with 200" $         HW.request "GET" "/" [("Accept", "application/json")] "" `shouldRespondWith`         "" { matchStatus = 200-           , matchBody = Just "\"Json!\""+           , matchBody = "\"Json!\""            }       describe "Html" $         it "should respond with 200" $         HW.request "GET" "/" [("Accept", "text/html")] "" `shouldRespondWith`         "" { matchStatus = 200-           , matchBody = Just "Html!"+           , matchBody = "Html!"            }       describe "Css" $         it "should respond with 200" $         HW.request "GET" "/" [("Accept", "text/css")] "" `shouldRespondWith`         "" { matchStatus = 200-           , matchBody = Just "body{background:#fff}"+           , matchBody = "body{background:#fff}"            }       describe "JavaScript" $         it "should respond with 200" $         HW.request "GET" "/" [("Accept", "application/javascript")] "" `shouldRespondWith`         "" { matchStatus = 200-           , matchBody = Just "function foo () {return;}"+           , matchBody = "function foo () {return;}"            }       describe "Markdown" $         it "should respond with 200" $         HW.request "GET" "/" [("Accept", "text/markdown")] "" `shouldRespondWith`         "" { matchStatus = 200-           , matchBody = Just "*Pandoc*!"+           , matchBody = "*Pandoc*!"            }   describe "All Requests Respond to the File Extension" $     with (return app) $ do@@ -67,43 +67,43 @@         it "should respond with 200" $         HW.get "/index.txt" `shouldRespondWith`         "" { matchStatus = 200-           , matchBody = Just "Text!"+           , matchBody = "Text!"            }       describe "Json" $         it "should respond with 200" $         HW.get "/index.json" `shouldRespondWith`         "" { matchStatus = 200-           , matchBody = Just "\"Json!\""+           , matchBody = "\"Json!\""            }       describe "Html" $         it "should respond with 200" $         HW.get "index.html" `shouldRespondWith`         "" { matchStatus = 200-           , matchBody = Just "Html!"+           , matchBody = "Html!"            }       describe "Css" $         it "should respond with 200" $         HW.get "/index.css" `shouldRespondWith`         "" { matchStatus = 200-           , matchBody = Just "body{background:#fff}"+           , matchBody = "body{background:#fff}"            }       describe "JavaScript" $         it "should respond with 200" $         HW.get "/index.js" `shouldRespondWith`         "" { matchStatus = 200-           , matchBody = Just "function foo () {return;}"+           , matchBody = "function foo () {return;}"            }       describe "Markdown" $         it "should respond with 200" $         HW.get "/index.md" `shouldRespondWith`         "" { matchStatus = 200-           , matchBody = Just "*Pandoc*!"+           , matchBody = "*Pandoc*!"            }       describe "Foo" $         it "should respond with 200" $         HW.get "/index.foo" `shouldRespondWith`         "" { matchStatus = 200-           , matchBody = Just "Foo"+           , matchBody = "Foo"            }   describe "All Requests Respond to Both" $     with (return app) $ do@@ -111,37 +111,37 @@         it "should respond with 200" $         HW.request "GET" "/index.txt" [("Accept", "text/plain")] "" `shouldRespondWith`         "" { matchStatus = 200-           , matchBody = Just "Text!"+           , matchBody = "Text!"            }       describe "Json" $         it "should respond with 200" $         HW.request "GET" "/index.json" [("Accept", "application/json")] "" `shouldRespondWith`         "" { matchStatus = 200-           , matchBody = Just "\"Json!\""+           , matchBody = "\"Json!\""            }       describe "Html" $         it "should respond with 200" $         HW.request "GET" "/index.html" [("Accept", "text/html")] "" `shouldRespondWith`         "" { matchStatus = 200-           , matchBody = Just "Html!"+           , matchBody = "Html!"            }       describe "Css" $         it "should respond with 200" $         HW.request "GET" "/index.css" [("Accept", "text/css")] "" `shouldRespondWith`         "" { matchStatus = 200-           , matchBody = Just "body{background:#fff}"+           , matchBody = "body{background:#fff}"            }       describe "JavaScript" $         it "should respond with 200" $         HW.request "GET" "/index.js" [("Accept", "application/javascript")] "" `shouldRespondWith`         "" { matchStatus = 200-           , matchBody = Just "function foo () {return;}"+           , matchBody = "function foo () {return;}"            }       describe "Markdown" $         it "should respond with 200" $         HW.request "GET" "/index.md" [("Accept", "text/markdown")] "" `shouldRespondWith`         "" { matchStatus = 200-           , matchBody = Just "*Pandoc*!"+           , matchBody = "*Pandoc*!"            }   describe "Outlier behavior" $     with (return app) $ do@@ -149,13 +149,13 @@         it " should respond with 200" $         HW.request "GET" "/index" [("Accept", "text/plain")] "" `shouldRespondWith`         "" { matchStatus = 200-           , matchBody = Just "Text!"+           , matchBody = "Text!"            }       describe ".markdown & text/plain" $         it " should respond with 200" $         HW.request "GET" "/index.md" [("Accept", "text/plain")] "" `shouldRespondWith`         "" { matchStatus = 200-           , matchBody = Just "*Pandoc*!"+           , matchBody = "*Pandoc*!"            }   describe "Unfulfillable accept headers should break" $     with (return app) $ do

@@ -1,5 +1,5 @@ Name:                   wai-middleware-content-type-Version:                0.5.0.1+Version:                0.5.1 Author:                 Athan Clark <athan.clark@gmail.com> Maintainer:             Athan Clark <athan.clark@gmail.com> License:                BSD3@@ -39,12 +39,14 @@                       , bytestring                       , clay                       , exceptions+                      , extractable-singleton                       , hashable                       , http-media                       , http-types                       , lucid                       , mmorph                       , monad-control+                      , monad-control-aligned                       , monad-logger                       , mtl                       , pandoc@@ -56,6 +58,7 @@                       , unordered-containers                       , urlpath >= 5.0.0.1                       , wai >= 3.2+                      , wai-logger                       , wai-transformers  Test-Suite test