packages feed

wai-middleware-content-type (empty) → 0.0.0

raw patch · 15 files changed

+946/−0 lines, 15 filesdep +aesondep +basedep +blaze-builder

Dependencies added: aeson, base, blaze-builder, blaze-html, bytestring, clay, containers, http-media, http-types, lucid, mtl, shakespeare, text, transformers, wai, wai-transformers, wai-util

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Athan Clark++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Athan Clark nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ src/Network/Wai/Middleware/ContentType.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE+    OverloadedStrings+  #-}++module Network.Wai.Middleware.ContentType+  ( module X+  , fileExtsToMiddleware+  , lookupResponse+  , possibleFileExts+  ) where++import Network.Wai.Middleware.ContentType.Types      as X+import Network.Wai.Middleware.ContentType.Blaze      as X+import Network.Wai.Middleware.ContentType.Builder    as X+import Network.Wai.Middleware.ContentType.ByteString as X+import Network.Wai.Middleware.ContentType.Cassius    as X+import Network.Wai.Middleware.ContentType.Clay       as X+import Network.Wai.Middleware.ContentType.Json       as X+import Network.Wai.Middleware.ContentType.Julius     as X+import Network.Wai.Middleware.ContentType.Lucid      as X+import Network.Wai.Middleware.ContentType.Lucius     as X+import Network.Wai.Middleware.ContentType.Text       as X++import Network.Wai.Trans+import Network.HTTP.Types (HeaderName)+import Network.HTTP.Media (mapAccept)++import qualified Data.ByteString as BS+import qualified Data.Map as Map+import Data.List (intersect, nub)+import Data.Maybe (fromMaybe, catMaybes)+import Data.Monoid+import Control.Monad.Trans+++type AcceptHeader = BS.ByteString++fileExtsToMiddleware :: MonadIO m =>+                        FileExtListenerT (MiddlewareT m) m ()+                     -> MiddlewareT m+fileExtsToMiddleware contentRoutes app req respond = do+  let mAcceptBS = Prelude.lookup ("Accept" :: HeaderName) $ requestHeaders req+      fe = getFileExt req+  mMiddleware <- lookupResponse mAcceptBS fe contentRoutes+  fromMaybe (app req respond) $ do+    m <- mMiddleware+    return $ m app req respond+++lookupResponse :: Monad m =>+                  Maybe AcceptHeader+               -> FileExt+               -> FileExtListenerT a m ()+               -> m (Maybe a)+lookupResponse mAcceptBS f fexts = do+  femap <- execFileExtListenerT fexts+  return $ lookupFileExt mAcceptBS f femap+  where+    lookupFileExt mAccept k (FileExts xs) =+      let attempts = maybe [Html,Text,Json,JavaScript,Css]+                       (possibleFileExts k) mAccept+      in getFirst $ foldMap (\f' -> First $ Map.lookup f' xs) attempts+++-- | Takes a file extension and an @Accept@ header, and returns the other+-- file types handleable, in order of prescedence.+possibleFileExts :: FileExt -> AcceptHeader -> [FileExt]+possibleFileExts fe accept =+  let computed = sortFE fe $ nub $ concat $+        catMaybes [ mapAccept [ ("application/json" :: BS.ByteString, [Json])+                              , ("application/javascript" :: BS.ByteString, [Json,JavaScript])+                              ] accept+                  , mapAccept [ ("text/html" :: BS.ByteString, [Html])+                              ] accept+                  , mapAccept [ ("text/plain" :: BS.ByteString, [Text])+                              ] accept+                  , mapAccept [ ("text/css" :: BS.ByteString, [Css])+                              ] accept+                  ]++      wildcard = concat $+        catMaybes [ mapAccept [ ("*/*" :: BS.ByteString, [Html,Text,Json,JavaScript,Css])+                              ] accept+                  ]+  in if not (null wildcard) then wildcard else computed+  where+    sortFE Html       xs = [Html, Text]             `intersect` xs+    sortFE JavaScript xs = [JavaScript, Text]       `intersect` xs+    sortFE Json       xs = [Json, JavaScript, Text] `intersect` xs+    sortFE Css        xs = [Css, Text]              `intersect` xs+    sortFE Text       xs = [Text]                   `intersect` xs+++
+ src/Network/Wai/Middleware/ContentType/Blaze.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Middleware.ContentType.Blaze where++import           Network.Wai.Middleware.ContentType.Types+import           Network.Wai.Middleware.ContentType.ByteString++import qualified Data.Text.Lazy.Encoding                 as LT+import           Network.HTTP.Types                      (RequestHeaders,+                                                          Status, status200)+import           Network.Wai.Trans+import qualified Text.Blaze.Html                         as H+import qualified Text.Blaze.Html.Renderer.Text           as H++import           Control.Monad.Writer+++-- | Uses @Html@ as the key in the map, and @"text/html"@ as the content type.+blaze :: MonadIO m =>+         H.Html -> FileExtListenerT (MiddlewareT m) m ()+blaze = blazeStatusHeaders status200 [("Content-Type", "text/html")]++blazeWith :: MonadIO m =>+             (Response -> Response) -> H.Html+          -> FileExtListenerT (MiddlewareT m) m ()+blazeWith f = blazeStatusHeadersWith f status200 [("Content-Type", "text/html")]++blazeStatus :: MonadIO m =>+               Status -> H.Html+            -> FileExtListenerT (MiddlewareT m) m ()+blazeStatus s = blazeStatusHeaders s [("Content-Type", "text/html")]++blazeStatusWith :: MonadIO m =>+                   (Response -> Response) -> Status -> H.Html+                -> FileExtListenerT (MiddlewareT m) m ()+blazeStatusWith f s = blazeStatusHeadersWith f s [("Content-Type", "text/html")]++blazeHeaders :: MonadIO m =>+                RequestHeaders -> H.Html+             -> FileExtListenerT (MiddlewareT m) m ()+blazeHeaders = blazeStatusHeaders status200++blazeHeadersWith :: MonadIO m =>+                    (Response -> Response) -> RequestHeaders -> H.Html+                 -> FileExtListenerT (MiddlewareT m) m ()+blazeHeadersWith f = blazeStatusHeadersWith f status200++blazeStatusHeaders :: MonadIO m =>+                      Status -> RequestHeaders -> H.Html+                   -> FileExtListenerT (MiddlewareT m) m ()+blazeStatusHeaders = blazeStatusHeadersWith id++blazeStatusHeadersWith :: MonadIO m =>+                          (Response -> Response) -> Status -> RequestHeaders -> H.Html+                       -> FileExtListenerT (MiddlewareT m) m ()+blazeStatusHeadersWith f s hs i =+  bytestringStatusWith f Html s hs $ LT.encodeUtf8 $ H.renderHtml i++++blazeOnly :: H.Html -> Response+blazeOnly = blazeOnlyStatusHeaders status200 [("Content-Type", "text/html")]++blazeOnlyHeaders :: RequestHeaders -> H.Html -> Response+blazeOnlyHeaders = blazeOnlyStatusHeaders status200++blazeOnlyStatus :: Status -> H.Html -> Response+blazeOnlyStatus s = blazeOnlyStatusHeaders s [("Content-Type", "text/html")]++blazeOnlyStatusHeaders :: Status -> RequestHeaders -> H.Html -> Response+blazeOnlyStatusHeaders s hs i =+  bytestringOnlyStatus s hs $ LT.encodeUtf8 $ H.renderHtml i
+ src/Network/Wai/Middleware/ContentType/Builder.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Middleware.ContentType.Builder where++import           Network.Wai.Middleware.ContentType.Types+import           Network.HTTP.Types                      (RequestHeaders, Status, status200)+import           Network.Wai.Trans++import qualified Data.ByteString.Builder                 as BU+import qualified Data.Map                                as Map++import           Control.Monad.Writer+++-- | A builder is ambiguous, therefore we require @RequestHeaders@ and a @FileExt@ to be explicitly+-- supplied.+builder :: MonadIO m =>+           FileExt -> RequestHeaders -> BU.Builder+        -> FileExtListenerT (MiddlewareT m) m ()+builder e  = builderStatus e status200++builderWith :: MonadIO m =>+               (Response -> Response) -> FileExt -> RequestHeaders -> BU.Builder+            -> FileExtListenerT (MiddlewareT m) m ()+builderWith f e = builderStatusWith f e status200++builderStatus :: MonadIO m =>+                 FileExt -> Status -> RequestHeaders -> BU.Builder+              -> FileExtListenerT (MiddlewareT m) m ()+builderStatus = builderStatusWith id++builderStatusWith :: MonadIO m =>+                     (Response -> Response) -> FileExt -> Status -> RequestHeaders -> BU.Builder+                  -> FileExtListenerT (MiddlewareT m) m ()+builderStatusWith f e s hs i =+  let r = builderOnlyStatus s hs i in+  FileExtListenerT $ tell $+    FileExts $ Map.singleton e $ \_ _ respond -> liftIO $ respond $ f r++++builderOnly :: RequestHeaders -> BU.Builder -> Response+builderOnly = builderOnlyStatus status200++-- | The exact same thing as @Network.Wai.responseBuilder@.+builderOnlyStatus :: Status -> RequestHeaders -> BU.Builder -> Response+builderOnlyStatus = responseBuilder
+ src/Network/Wai/Middleware/ContentType/ByteString.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Middleware.ContentType.ByteString where++import           Network.Wai.Middleware.ContentType.Types+import           Network.Wai.Middleware.ContentType.Middleware+import           Network.HTTP.Types                      (RequestHeaders, Status, status200)+import           Network.Wai.Trans+import qualified Network.Wai.Util                        as U++import qualified Data.ByteString.Lazy                    as B+import           Data.Map++import           Control.Monad.IO.Class (liftIO)+import           Control.Monad.Writer+++-- * Lifted @MiddlewareT@++-- | @ByteString@ is ambiguous - we need to know what @RequestHeaders@ and @FileExt@ should be associated.+bytestring :: MonadIO m => FileExt -> RequestHeaders -> B.ByteString+           -> FileExtListenerT (MiddlewareT m) m ()+bytestring e = bytestringStatus e status200++bytestringWith :: MonadIO m => (Response -> Response) -> FileExt -> RequestHeaders -> B.ByteString+               -> FileExtListenerT (MiddlewareT m) m ()+bytestringWith f e = bytestringStatusWith f e status200++bytestringStatus :: MonadIO m => FileExt -> Status -> RequestHeaders -> B.ByteString+                 -> FileExtListenerT (MiddlewareT m) m ()+bytestringStatus = bytestringStatusWith id++bytestringStatusWith :: MonadIO m =>+                        (Response -> Response)+                     -> FileExt+                     -> Status+                     -> RequestHeaders+                     -> B.ByteString+                     -> FileExtListenerT (MiddlewareT m) m ()+bytestringStatusWith f fe s hs i = do+  r <- lift $ U.bytestring s hs i+  middleware fe $ \_ _ respond -> liftIO $ respond $ f r+++-- * Raw @Response@s++bytestringOnly :: RequestHeaders -> B.ByteString -> Response+bytestringOnly = bytestringOnlyStatus status200++-- | The exact same thing as @Network.Wai.responseLBS@.+bytestringOnlyStatus :: Status -> RequestHeaders -> B.ByteString -> Response+bytestringOnlyStatus = responseLBS
+ src/Network/Wai/Middleware/ContentType/Cassius.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Middleware.ContentType.Cassius where++import           Network.Wai.Middleware.ContentType.Types as FE+import           Network.Wai.Middleware.ContentType.ByteString+import           Network.HTTP.Types                      (RequestHeaders, Status, status200)+import           Network.Wai.Trans++import           Text.Cassius+import qualified Data.Text.Lazy.Encoding                 as LT++import           Control.Monad.Writer+++-- | Uses @cassius@ as the key in the map, and @"cassius/plain"@ as the content type.+cassius :: MonadIO m => Css -> FileExtListenerT (MiddlewareT m) m ()+cassius = cassiusStatusHeaders status200 [("Content-Type", "cassius/css")]++cassiusWith :: MonadIO m =>+               (Response -> Response) -> Css+            -> FileExtListenerT (MiddlewareT m) m ()+cassiusWith f = cassiusStatusHeadersWith f status200 [("Content-Type", "cassius/css")]++cassiusStatus :: MonadIO m =>+                 Status -> Css+              -> FileExtListenerT (MiddlewareT m) m ()+cassiusStatus s = cassiusStatusHeaders s [("Content-Type", "cassius/css")]++cassiusStatusWith :: MonadIO m =>+                     (Response -> Response) -> Status -> Css+                  -> FileExtListenerT (MiddlewareT m) m ()+cassiusStatusWith f s = cassiusStatusHeadersWith f s [("Content-Type", "cassius/css")]++cassiusHeaders :: MonadIO m =>+                  RequestHeaders -> Css+               -> FileExtListenerT (MiddlewareT m) m ()+cassiusHeaders = cassiusStatusHeaders status200++cassiusHeadersWith :: MonadIO m =>+                      (Response -> Response) -> RequestHeaders -> Css+                   -> FileExtListenerT (MiddlewareT m) m ()+cassiusHeadersWith f = cassiusStatusHeadersWith f status200++cassiusStatusHeaders :: MonadIO m =>+                        Status -> RequestHeaders -> Css+                     -> FileExtListenerT (MiddlewareT m) m ()+cassiusStatusHeaders = cassiusStatusHeadersWith id++cassiusStatusHeadersWith :: MonadIO m =>+                            (Response -> Response) -> Status -> RequestHeaders -> Css+                         -> FileExtListenerT (MiddlewareT m) m ()+cassiusStatusHeadersWith f s hs i =+  bytestringStatusWith f Css s hs $ LT.encodeUtf8 $ renderCss i+++++cassiusOnly :: Css -> Response+cassiusOnly = cassiusOnlyStatusHeaders status200 [("Content-Type", "cassius/css")]++cassiusOnlyStatus :: Status -> Css -> Response+cassiusOnlyStatus s = cassiusOnlyStatusHeaders s [("Content-Type", "cassius/css")]++cassiusOnlyHeaders :: RequestHeaders -> Css -> Response+cassiusOnlyHeaders = cassiusOnlyStatusHeaders status200++cassiusOnlyStatusHeaders :: Status -> RequestHeaders -> Css -> Response+cassiusOnlyStatusHeaders s hs i = bytestringOnlyStatus s hs $ LT.encodeUtf8 $ renderCss i
+ src/Network/Wai/Middleware/ContentType/Clay.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Middleware.ContentType.Clay where++import           Network.Wai.Middleware.ContentType.Types+import           Network.Wai.Middleware.ContentType.ByteString+import           Network.HTTP.Types                      (RequestHeaders, Status, status200)+import           Network.Wai.Trans++import           Clay.Render+import           Clay.Stylesheet+import qualified Data.Text.Lazy.Encoding                 as LT++import           Control.Monad.Writer+++-- | Uses @Text@ as the key in the map, and @"text/css"@ as the content type.+clay :: MonadIO m =>+        Config -> [App] -> Css+     -> FileExtListenerT (MiddlewareT m) m ()+clay c as = clayStatusHeaders c as status200 [("Content-Type", "text/css")]++clayWith :: MonadIO m =>+            (Response -> Response) -> Config -> [App] -> Css+         -> FileExtListenerT (MiddlewareT m) m ()+clayWith f c as = clayStatusHeadersWith f c as status200 [("Content-Type", "text/css")]++clayStatus :: MonadIO m =>+              Config -> [App] -> Status -> Css+           -> FileExtListenerT (MiddlewareT m) m ()+clayStatus c as s = clayStatusHeaders c as s [("Content-Type", "text/css")]++clayStatusWith :: MonadIO m =>+                  (Response -> Response) -> Config -> [App] -> Status -> Css+               -> FileExtListenerT (MiddlewareT m) m ()+clayStatusWith f c as s = clayStatusHeadersWith f c as s [("Content-Type", "text/css")]++clayHeaders :: MonadIO m =>+               Config -> [App] -> RequestHeaders -> Css+            -> FileExtListenerT (MiddlewareT m) m ()+clayHeaders c as = clayStatusHeaders c as status200++clayHeadersWith :: MonadIO m =>+                   (Response -> Response) -> Config -> [App] -> RequestHeaders -> Css+                -> FileExtListenerT (MiddlewareT m) m ()+clayHeadersWith f c as = clayStatusHeadersWith f c as status200++clayStatusHeaders :: MonadIO m =>+                     Config -> [App] -> Status -> RequestHeaders -> Css+                  -> FileExtListenerT (MiddlewareT m) m ()+clayStatusHeaders = clayStatusHeadersWith id++clayStatusHeadersWith :: MonadIO m =>+                         (Response -> Response) -> Config -> [App] -> Status -> RequestHeaders -> Css+                      -> FileExtListenerT (MiddlewareT m) m ()+clayStatusHeadersWith f c as s hs i =+  bytestringStatusWith f Css s hs $ LT.encodeUtf8 $ renderWith c as i+++++clayOnly :: Config -> [App] -> Css -> Response+clayOnly c as = clayOnlyStatusHeaders c as status200 [("Content-Type", "text/css")]++clayOnlyStatus :: Config -> [App] -> Status -> Css -> Response+clayOnlyStatus c as s = clayOnlyStatusHeaders c as s [("Content-Type", "text/css")]++clayOnlyHeaders :: Config -> [App] -> RequestHeaders -> Css -> Response+clayOnlyHeaders c as = clayOnlyStatusHeaders c as status200++clayOnlyStatusHeaders :: Config -> [App] -> Status -> RequestHeaders -> Css -> Response+clayOnlyStatusHeaders c as s hs i = bytestringOnlyStatus s hs $ LT.encodeUtf8 $ renderWith c as i
+ src/Network/Wai/Middleware/ContentType/Json.hs view
@@ -0,0 +1,111 @@+{-# 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                      (RequestHeaders, Status, status200)+import           Network.Wai.Trans++import qualified Data.Aeson                              as A++import           Control.Monad.Writer++++-- | Uses @Json@ as the key in the map, and @"application/json"@ as the content type.+json :: ( A.ToJSON j+        , MonadIO m+        ) => j -> FileExtListenerT (MiddlewareT m) m ()+json = jsonStatusHeaders status200 [("Content-Type", "application/json")]++jsonWith :: ( A.ToJSON j+            , MonadIO m+            ) => (Response -> Response) -> j -> FileExtListenerT (MiddlewareT m) m ()+jsonWith f = jsonStatusHeadersWith f status200 [("Content-Type", "application/json")]++jsonStatus :: ( A.ToJSON j+              , MonadIO m+              ) => Status -> j -> FileExtListenerT (MiddlewareT m) m ()+jsonStatus s = jsonStatusHeaders s [("Content-Type", "application/json")]++jsonStatusWith :: ( A.ToJSON j+                  , MonadIO m+                  ) => (Response -> Response) -> Status -> j+                    -> FileExtListenerT (MiddlewareT m) m ()+jsonStatusWith f s = jsonStatusHeadersWith f s [("Content-Type", "application/json")]++-- | Uses @Json@ as the key in the map, and @"application/javascript"@ as the content type.+jsonp :: ( A.ToJSON j+         , MonadIO m+         ) => j -> FileExtListenerT (MiddlewareT m) m ()+jsonp = jsonStatusHeaders status200 [("Content-Type", "application/javascript")]++jsonpWith :: ( A.ToJSON j+             , MonadIO m+             ) => (Response -> Response) -> j -> FileExtListenerT (MiddlewareT m) m ()+jsonpWith f = jsonStatusHeadersWith f status200 [("Content-Type", "application/javascript")]++jsonpStatus :: ( A.ToJSON j+               , MonadIO m+               ) => Status -> j -> FileExtListenerT (MiddlewareT m) m ()+jsonpStatus s = jsonStatusHeaders s [("Content-Type", "application/javascript")]++jsonpStatusWith :: ( A.ToJSON j+                   , MonadIO m+                   ) => (Response -> Response) -> Status -> j+                     -> FileExtListenerT (MiddlewareT m) m ()+jsonpStatusWith f s = jsonStatusHeadersWith f s [("Content-Type", "application/javascript")]++jsonHeaders :: ( A.ToJSON j+               , MonadIO m+               ) => RequestHeaders -> j+                 -> FileExtListenerT (MiddlewareT m) m ()+jsonHeaders = jsonStatusHeaders status200++jsonHeadersWith :: ( A.ToJSON j+                   , MonadIO m+                   ) => (Response -> Response) -> RequestHeaders -> j+                     -> FileExtListenerT (MiddlewareT m) m ()+jsonHeadersWith f = jsonStatusHeadersWith f status200++jsonStatusHeaders :: ( A.ToJSON j+                     , MonadIO m+                     ) => Status -> RequestHeaders -> j+                       -> FileExtListenerT (MiddlewareT m) m ()+jsonStatusHeaders = jsonStatusHeadersWith id++jsonStatusHeadersWith :: ( A.ToJSON j+                         , MonadIO m+                         ) => (Response -> Response) -> Status -> RequestHeaders -> j+                           -> FileExtListenerT (MiddlewareT m) m ()+jsonStatusHeadersWith f s hs i =+  bytestringStatusWith f Json s hs $ A.encode i+++++jsonOnly :: A.ToJSON j =>+            j -> Response+jsonOnly = jsonOnlyStatusHeaders status200 [("Content-Type", "application/json")]++jsonOnlyStatus :: A.ToJSON j =>+            Status -> j -> Response+jsonOnlyStatus s = jsonOnlyStatusHeaders s [("Content-Type", "application/json")]++jsonpOnly :: A.ToJSON j =>+            j -> Response+jsonpOnly = jsonOnlyStatusHeaders status200 [("Content-Type", "application/javascript")]++jsonpOnlyStatus :: A.ToJSON j =>+            Status -> j -> Response+jsonpOnlyStatus s = jsonOnlyStatusHeaders s [("Content-Type", "application/javascript")]++jsonOnlyHeaders :: A.ToJSON j =>+            RequestHeaders -> j -> Response+jsonOnlyHeaders = jsonOnlyStatusHeaders status200++jsonOnlyStatusHeaders :: A.ToJSON j =>+            Status -> RequestHeaders -> j -> Response+jsonOnlyStatusHeaders s hs i =+  bytestringOnlyStatus s hs $ A.encode i
+ src/Network/Wai/Middleware/ContentType/Julius.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Middleware.ContentType.Julius where++import           Network.Wai.Middleware.ContentType.Types+import           Network.Wai.Middleware.ContentType.ByteString+import           Network.HTTP.Types                      (RequestHeaders, Status, status200)+import           Network.Wai.Trans++import           Text.Julius+import qualified Data.Text.Lazy.Encoding                 as LT++import           Control.Monad.Writer+++-- | Uses @julius@ as the key in the map, and @"application/javascript"@ as the content type.+julius :: MonadIO m =>+          Javascript -> FileExtListenerT (MiddlewareT m) m ()+julius = juliusStatusHeaders status200 [("Content-Type", "application/javascript")]++juliusWith :: MonadIO m =>+              (Response -> Response) -> Javascript+           -> FileExtListenerT (MiddlewareT m) m ()+juliusWith f = juliusStatusHeadersWith f status200 [("Content-Type", "application/javascript")]++juliusStatus :: MonadIO m =>+                Status -> Javascript+             -> FileExtListenerT (MiddlewareT m) m ()+juliusStatus s = juliusStatusHeaders s [("Content-Type", "application/javascript")]++juliusStatusWith :: MonadIO m =>+                    (Response -> Response) -> Status -> Javascript+                 -> FileExtListenerT (MiddlewareT m) m ()+juliusStatusWith f s = juliusStatusHeadersWith f s [("Content-Type", "application/javascript")]++juliusHeaders :: MonadIO m =>+                 RequestHeaders -> Javascript+              -> FileExtListenerT (MiddlewareT m) m ()+juliusHeaders = juliusStatusHeaders status200++juliusHeadersWith :: MonadIO m =>+                     (Response -> Response) -> RequestHeaders -> Javascript+                  -> FileExtListenerT (MiddlewareT m) m ()+juliusHeadersWith f = juliusStatusHeadersWith f status200++juliusStatusHeaders :: MonadIO m =>+                       Status -> RequestHeaders -> Javascript+                    -> FileExtListenerT (MiddlewareT m) m ()+juliusStatusHeaders = juliusStatusHeadersWith id++juliusStatusHeadersWith :: MonadIO m =>+                           (Response -> Response) -> Status -> RequestHeaders -> Javascript+                        -> FileExtListenerT (MiddlewareT m) m ()+juliusStatusHeadersWith f s hs i =+  bytestringStatusWith f Json s hs $ LT.encodeUtf8 $ renderJavascript i++++juliusOnly :: Javascript -> Response+juliusOnly = juliusOnlyStatusHeaders status200 [("Content-Type", "application/javascript")]++juliusOnlyStatus :: Status -> Javascript -> Response+juliusOnlyStatus s = juliusOnlyStatusHeaders s [("Content-Type", "application/javascript")]++juliusOnlyHeaders :: RequestHeaders -> Javascript -> Response+juliusOnlyHeaders = juliusOnlyStatusHeaders status200++juliusOnlyStatusHeaders :: Status -> RequestHeaders -> Javascript -> Response+juliusOnlyStatusHeaders s hs i = bytestringOnlyStatus s hs $ LT.encodeUtf8 $ renderJavascript i
+ src/Network/Wai/Middleware/ContentType/Lucid.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Middleware.ContentType.Lucid where++import           Network.Wai.Middleware.ContentType.Types+import           Network.Wai.Middleware.ContentType.ByteString+import           Network.HTTP.Types                      (RequestHeaders, Status, status200)+import           Network.Wai.Trans++import qualified Lucid.Base                              as L++import           Control.Monad.Writer+++-- | Uses the @Html@ key in the map, and @"text/html"@ as the content type.+lucid :: MonadIO m => L.HtmlT m () -> FileExtListenerT (MiddlewareT m) m ()+lucid = lucidStatusHeaders status200 [("Content-Type", "text/html")]++lucidWith :: MonadIO m =>+             (Response -> Response) -> L.HtmlT m ()+          -> FileExtListenerT (MiddlewareT m) m ()+lucidWith f = lucidStatusHeadersWith f status200 [("Content-Type", "text/html")]++lucidStatus :: MonadIO m =>+               Status -> L.HtmlT m ()+            -> FileExtListenerT (MiddlewareT m) m ()+lucidStatus s = lucidStatusHeaders s [("Content-Type", "text/html")]++lucidStatusWith :: MonadIO m =>+                   (Response -> Response) -> Status -> L.HtmlT m ()+                -> FileExtListenerT (MiddlewareT m) m ()+lucidStatusWith f s = lucidStatusHeadersWith f s [("Content-Type", "text/html")]++lucidHeaders :: MonadIO m =>+                RequestHeaders -> L.HtmlT m ()+             -> FileExtListenerT (MiddlewareT m) m ()+lucidHeaders = lucidStatusHeaders status200++lucidHeadersWith :: MonadIO m =>+                    (Response -> Response) -> RequestHeaders -> L.HtmlT m ()+                 -> FileExtListenerT (MiddlewareT m) m ()+lucidHeadersWith f = lucidStatusHeadersWith f status200++lucidStatusHeaders :: MonadIO m =>+                      Status -> RequestHeaders -> L.HtmlT m ()+                   -> FileExtListenerT (MiddlewareT m) m ()+lucidStatusHeaders = lucidStatusHeadersWith id++lucidStatusHeadersWith :: MonadIO m =>+                          (Response -> Response) -> Status -> RequestHeaders -> L.HtmlT m ()+                       -> FileExtListenerT (MiddlewareT m) m ()+lucidStatusHeadersWith f s hs i = do+  i' <- lift $ L.renderBST i+  bytestringStatusWith f Html s hs i'+++++lucidOnly :: Monad m =>+             L.HtmlT m () -> m Response+lucidOnly = lucidOnlyStatusHeaders status200 [("Content-Type", "text/html")]++lucidOnlyStatus :: Monad m =>+             Status -> L.HtmlT m () -> m Response+lucidOnlyStatus s = lucidOnlyStatusHeaders s [("Content-Type", "text/html")]++lucidOnlyHeaders :: Monad m =>+             RequestHeaders -> L.HtmlT m () -> m Response+lucidOnlyHeaders = lucidOnlyStatusHeaders status200++lucidOnlyStatusHeaders :: Monad m =>+             Status -> RequestHeaders -> L.HtmlT m () -> m Response+lucidOnlyStatusHeaders s hs i = liftM (bytestringOnlyStatus s hs) $ L.renderBST i
+ src/Network/Wai/Middleware/ContentType/Lucius.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Middleware.ContentType.Lucius where++import           Network.Wai.Middleware.ContentType.Types+import           Network.Wai.Middleware.ContentType.ByteString+import           Network.HTTP.Types                      (RequestHeaders, Status, status200)+import           Network.Wai.Trans++import           Text.Lucius+import qualified Data.Text.Lazy.Encoding                 as LT++import           Control.Monad.Writer+++-- | Uses @lucius@ as the key in the map, and @"lucius/css"@ as the content type.+lucius :: MonadIO m => Css -> FileExtListenerT (MiddlewareT m) m ()+lucius = luciusStatusHeaders status200 [("Content-Type", "lucius/css")]++luciusWith :: MonadIO m =>+              (Response -> Response) -> Css+           -> FileExtListenerT (MiddlewareT m) m ()+luciusWith f = luciusStatusHeadersWith f status200 [("Content-Type", "lucius/css")]++luciusStatus :: MonadIO m =>+                Status -> Css+             -> FileExtListenerT (MiddlewareT m) m ()+luciusStatus s = luciusStatusHeaders s [("Content-Type", "lucius/css")]++luciusStatusWith :: MonadIO m =>+                    (Response -> Response) -> Status -> Css+                 -> FileExtListenerT (MiddlewareT m) m ()+luciusStatusWith f s = luciusStatusHeadersWith f s [("Content-Type", "lucius/css")]++luciusHeaders :: MonadIO m =>+                 RequestHeaders -> Css+              -> FileExtListenerT (MiddlewareT m) m ()+luciusHeaders = luciusStatusHeaders status200++luciusHeadersWith :: MonadIO m =>+                     (Response -> Response) -> RequestHeaders -> Css+                  -> FileExtListenerT (MiddlewareT m) m ()+luciusHeadersWith f = luciusStatusHeadersWith f status200++luciusStatusHeaders :: MonadIO m =>+                       Status -> RequestHeaders -> Css+                    -> FileExtListenerT (MiddlewareT m) m ()+luciusStatusHeaders = luciusStatusHeadersWith id++luciusStatusHeadersWith :: MonadIO m =>+                           (Response -> Response) -> Status -> RequestHeaders -> Css+                        -> FileExtListenerT (MiddlewareT m) m ()+luciusStatusHeadersWith f s hs i =+  bytestringStatusWith f Css s hs $ LT.encodeUtf8 $ renderCss i++++luciusOnly :: Css -> Response+luciusOnly = luciusOnlyStatusHeaders status200 [("Content-Type", "lucius/css")]++luciusOnlyStatus :: Status -> Css -> Response+luciusOnlyStatus s = luciusOnlyStatusHeaders s [("Content-Type", "lucius/css")]++luciusOnlyHeaders :: RequestHeaders -> Css -> Response+luciusOnlyHeaders = luciusOnlyStatusHeaders status200++luciusOnlyStatusHeaders :: Status -> RequestHeaders -> Css -> Response+luciusOnlyStatusHeaders s hs i = bytestringOnlyStatus s hs $ LT.encodeUtf8 $ renderCss i
+ src/Network/Wai/Middleware/ContentType/Middleware.hs view
@@ -0,0 +1,14 @@+module Network.Wai.Middleware.ContentType.Middleware where++import Network.Wai.Middleware.ContentType.Types+import Network.Wai.Trans+import qualified Data.Map as Map+import Control.Monad.Writer+++-- | Lifts a @MiddlewareT@ directly as a response to a file extension.+middleware :: Monad m =>+              FileExt+           -> MiddlewareT m+           -> FileExtListenerT (MiddlewareT m) m ()+middleware f m = tell $ FileExts $ Map.singleton f m
+ src/Network/Wai/Middleware/ContentType/Text.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Middleware.ContentType.Text where++import           Network.Wai.Middleware.ContentType.Types+import           Network.Wai.Middleware.ContentType.ByteString+import           Network.HTTP.Types                      (RequestHeaders, Status, status200)+import           Network.Wai.Trans++import qualified Data.Text.Lazy                          as LT+import qualified Data.Text.Lazy.Encoding                 as LT++import           Control.Monad.Writer+++-- | Uses @Text@ as the key in the map, and @"text/plain"@ as the content type.+text :: MonadIO m => LT.Text -> FileExtListenerT (MiddlewareT m) m ()+text = textStatusHeaders status200 [("Content-Type", "text/plain")]++textWith :: MonadIO m =>+            (Response -> Response) -> LT.Text+         -> FileExtListenerT (MiddlewareT m) m ()+textWith f = textStatusHeadersWith f status200 [("Content-Type", "text/plain")]++textStatus :: MonadIO m =>+              Status -> LT.Text+           -> FileExtListenerT (MiddlewareT m) m ()+textStatus s = textStatusHeaders s [("Content-Type", "text/plain")]++textStatusWith :: MonadIO m =>+                  (Response -> Response) -> Status -> LT.Text+               -> FileExtListenerT (MiddlewareT m) m ()+textStatusWith f s = textStatusHeadersWith f s [("Content-Type", "text/plain")]++textHeaders :: MonadIO m =>+               RequestHeaders -> LT.Text+            -> FileExtListenerT (MiddlewareT m) m ()+textHeaders = textStatusHeaders status200++textHeadersWith :: MonadIO m =>+                   (Response -> Response) -> RequestHeaders -> LT.Text+                -> FileExtListenerT (MiddlewareT m) m ()+textHeadersWith f = textStatusHeadersWith f status200++textStatusHeaders :: MonadIO m =>+                     Status -> RequestHeaders -> LT.Text+                  -> FileExtListenerT (MiddlewareT m) m ()+textStatusHeaders = textStatusHeadersWith id++textStatusHeadersWith :: MonadIO m =>+                         (Response -> Response) -> Status -> RequestHeaders -> LT.Text+                      -> FileExtListenerT (MiddlewareT m) m ()+textStatusHeadersWith f s hs i =+  bytestringStatusWith f Text s hs $ LT.encodeUtf8 i+++++textOnly :: LT.Text -> Response+textOnly = textOnlyStatusHeaders status200 [("Content-Type", "text/plain")]++textOnlyStatus :: Status -> LT.Text -> Response+textOnlyStatus s = textOnlyStatusHeaders s [("Content-Type", "text/plain")]++textOnlyHeaders :: RequestHeaders -> LT.Text -> Response+textOnlyHeaders = textOnlyStatusHeaders status200++textOnlyStatusHeaders :: Status -> RequestHeaders -> LT.Text -> Response+textOnlyStatusHeaders s hs i = bytestringOnlyStatus s hs $ LT.encodeUtf8 i
+ src/Network/Wai/Middleware/ContentType/Types.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE+    DeriveFunctor+  , DeriveTraversable+  , GeneralizedNewtypeDeriving+  , OverloadedStrings+  , StandaloneDeriving+  , FlexibleInstances+  , MultiParamTypeClasses+  #-}++module Network.Wai.Middleware.ContentType.Types where++import           Network.Wai+import qualified Data.Text              as T+import           Data.Map+import           Data.Maybe (fromMaybe)+import           Control.Monad.Trans+import           Control.Monad.Writer+++-- | Supported file extensions+data FileExt = Html+             | Css+             | JavaScript+             | Json+             | Text+  deriving (Show, Eq, Ord)+++getFileExt :: Request -> FileExt+getFileExt req = fromMaybe Html $ case pathInfo req of+  [] -> Just Html+  xs -> toExt $ T.dropWhile (/= '.') $ last xs++toExt :: T.Text -> Maybe FileExt+toExt x | x `elem` htmls       = Just Html+        | x `elem` csss        = Just Css+        | x `elem` javascripts = Just JavaScript+        | x `elem` jsons       = Just Json+        | x `elem` texts       = Just Text+        | otherwise            = Nothing+  where+    htmls       = [".htm", ".html"]+    csss        = [".css"]+    javascripts = [".js", ".javascript"]+    jsons       = [".json"]+    texts       = [".txt"]++newtype FileExts a = FileExts { unFileExts :: Map FileExt a }+  deriving (Show, Eq, Monoid, Functor, Foldable, Traversable)++newtype FileExtListenerT r m a =+  FileExtListenerT { runFileExtListenerT :: WriterT (FileExts r) m a }+    deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadWriter (FileExts r))++execFileExtListenerT :: Monad m => FileExtListenerT r m a -> m (FileExts r)+execFileExtListenerT = execWriterT . runFileExtListenerT
+ wai-middleware-content-type.cabal view
@@ -0,0 +1,49 @@+Name:                   wai-middleware-content-type+Version:                0.0.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.+-- Description:+Cabal-Version:          >= 1.10+Build-Type:             Simple++Library+  Default-Language:     Haskell2010+  HS-Source-Dirs:       src+  GHC-Options:          -Wall+  Exposed-Modules:      Network.Wai.Middleware.ContentType+                        Network.Wai.Middleware.ContentType.Types+                        Network.Wai.Middleware.ContentType.Blaze+                        Network.Wai.Middleware.ContentType.Builder+                        Network.Wai.Middleware.ContentType.ByteString+                        Network.Wai.Middleware.ContentType.Cassius+                        Network.Wai.Middleware.ContentType.Clay+                        Network.Wai.Middleware.ContentType.Json+                        Network.Wai.Middleware.ContentType.Julius+                        Network.Wai.Middleware.ContentType.Lucid+                        Network.Wai.Middleware.ContentType.Lucius+                        Network.Wai.Middleware.ContentType.Text+                        Network.Wai.Middleware.ContentType.Middleware+  Build-Depends:        base >= 4.6 && < 5+                      , aeson+                      , blaze-builder+                      , blaze-html+                      , bytestring+                      , clay+                      , containers+                      , http-media+                      , http-types+                      , lucid+                      , mtl+                      , shakespeare+                      , text+                      , transformers+                      , wai+                      , wai-transformers+                      , wai-util++Source-Repository head+  Type:                 git+  Location:             https://github.com/athanclark/wai-middleware-content-type.git