wai-middleware-content-type 0.0.4 → 0.1.0

raw patch · 16 files changed

+179/−158 lines, 16 filesdep +urlpathsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: urlpath

API changes (from Hackage documentation)

Files

• Setup.hs +1/−51
• src/Network/Wai/Middleware/ContentType.hs +110/−58
• src/Network/Wai/Middleware/ContentType/Blaze.hs +2/−0
• src/Network/Wai/Middleware/ContentType/Builder.hs +4/−2
• src/Network/Wai/Middleware/ContentType/ByteString.hs +2/−2
• src/Network/Wai/Middleware/ContentType/Cassius.hs +2/−1
• src/Network/Wai/Middleware/ContentType/Clay.hs +2/−0
• src/Network/Wai/Middleware/ContentType/Json.hs +2/−0
• src/Network/Wai/Middleware/ContentType/Julius.hs +2/−0
• src/Network/Wai/Middleware/ContentType/Lucid.hs +2/−0
• src/Network/Wai/Middleware/ContentType/Lucius.hs +2/−0
• src/Network/Wai/Middleware/ContentType/Middleware.hs +1/−1
• src/Network/Wai/Middleware/ContentType/Pandoc.hs +3/−2
• src/Network/Wai/Middleware/ContentType/Text.hs +2/−0
• src/Network/Wai/Middleware/ContentType/Types.hs +40/−40
• wai-middleware-content-type.cabal +2/−1

@@ -1,52 +1,2 @@ import Distribution.Simple-import Distribution.Simple.PreProcess-import Distribution.Simple.Setup (ConfigFlags(..))-import Distribution.PackageDescription (PackageDescription(..), FlagName(..))-import Distribution.Simple.Utils ( rawSystemExitCode, findProgramVersion )-import System.Exit-import Distribution.Verbosity ( Verbosity )-import Distribution.Simple.Utils (info, notice, installOrdinaryFiles)-import Distribution.Simple.Setup-import Distribution.Simple.Program (simpleProgram, Program(..))-import Distribution.Simple.LocalBuildInfo-import Data.Version-import Control.Monad (when)-import qualified Control.Exception as E--main :: IO ()-main = defaultMainWithHooks $ simpleUserHooks {-      -- enable hsb2hs preprocessor for .hsb files-      hookedPreProcessors = [ppBlobSuffixHandler]-    , hookedPrograms = [(simpleProgram "hsb2hs"){-                           programFindVersion = \verbosity fp ->-                             findProgramVersion "--version" id verbosity fp }]-    , postCopy = installManPage-    }--ppBlobSuffixHandler :: PPSuffixHandler-ppBlobSuffixHandler = ("hsb", \_ lbi ->-  PreProcessor {-    platformIndependent = True,-    runPreProcessor = mkSimplePreProcessor $ \infile outfile verbosity ->-      do let embedData = case lookup (FlagName "embed_data_files")-                              (configConfigurationsFlags (configFlags lbi)) of-                              Just True -> True-                              _         -> False-         when embedData $-            do info verbosity $ "Preprocessing " ++ infile ++ " to " ++ outfile-               ec <- rawSystemExitCode verbosity "hsb2hs"-                          [infile, infile, outfile]-               case ec of-                    ExitSuccess   -> return ()-                    ExitFailure _ -> error "hsb2hs is needed to build this program"-  })--installManPage :: Args -> CopyFlags-               -> PackageDescription -> LocalBuildInfo -> IO ()-installManPage _ flags pkg lbi = do-  let verbosity = fromFlag (copyVerbosity flags)-  let copydest  = fromFlag (copyDest flags)-  let mandest   = mandir (absoluteInstallDirs pkg lbi copydest)-                     ++ "/man1"-  notice verbosity $ "Copying man page to " ++ mandest-  installOrdinaryFiles verbosity mandest [("man", "wai-middleware-content-type.1")]+main = defaultMain

@@ -2,96 +2,148 @@     OverloadedStrings   #-} +{- |+Module      : Network.Wai.Middleware.ContentType+Copyright   : (c) 2015 Athan Clark++License     : BSD-3+Maintainer  : athan.clark@gmail.com+Stability   : experimental+Portability : GHC++Import this module to use all the application end-point combinators:++> {-# LANGUAGE+>     OverloadedStrings+>   #-}+>+> import Network.Wai.Middleware.ContentType+> import qualified Data.Text as T+> import qualified Lucid as L+>+> myApp :: MonadIO m => MiddlewareT+> myApp = fileExtsToMiddleware $ do+>   text "Text!"+>   json ("Json!" :: T.Text)+>   lucid (L.toHtmlRaw ("Html!" :: T.Text))++If you would like to embed a 'Network.Wai.Trans.MiddlewareT' as a response to+a particular supported file extension / content type, import+"Network.Wai.Middleware.ContentType.Middleware":++> import Network.Wai.Middleware.ContentType+> import Network.Wai.Middleware.ContentType.Middleware+>+> myApp = fileExtsToMiddleware $+>   middleware Css myMiddleware+-}+ module Network.Wai.Middleware.ContentType-  ( module X-  , fileExtsToMiddleware+  ( -- * Utilities+    fileExtsToMiddleware   , lookupResponse   , possibleFileExts+  , allFileExts+  , AcceptHeader+  , -- * Re-Exports+    module Network.Wai.Middleware.ContentType.Types+  , module Network.Wai.Middleware.ContentType.Blaze+  , module Network.Wai.Middleware.ContentType.Builder+  , module Network.Wai.Middleware.ContentType.ByteString+  , module Network.Wai.Middleware.ContentType.Cassius+  , module Network.Wai.Middleware.ContentType.Clay+  , module Network.Wai.Middleware.ContentType.Json+  , module Network.Wai.Middleware.ContentType.Julius+  , module Network.Wai.Middleware.ContentType.Lucid+  , module Network.Wai.Middleware.ContentType.Lucius+  , module Network.Wai.Middleware.ContentType.Text+  , module Network.Wai.Middleware.ContentType.Pandoc   ) where -import Network.Wai.Middleware.ContentType.Types      as X hiding (tell)-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 Network.Wai.Middleware.ContentType.Types hiding (tell')+import Network.Wai.Middleware.ContentType.Blaze+import Network.Wai.Middleware.ContentType.Builder+import Network.Wai.Middleware.ContentType.ByteString+import Network.Wai.Middleware.ContentType.Cassius+import Network.Wai.Middleware.ContentType.Clay+import Network.Wai.Middleware.ContentType.Json+import Network.Wai.Middleware.ContentType.Julius+import Network.Wai.Middleware.ContentType.Lucid+import Network.Wai.Middleware.ContentType.Lucius+import Network.Wai.Middleware.ContentType.Text+import Network.Wai.Middleware.ContentType.Pandoc  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+import Control.Monad   type AcceptHeader = BS.ByteString  -- | Turn a map of content types to middlewares, into a middleware.-fileExtsToMiddleware :: MonadIO m =>-                        FileExtListenerT (MiddlewareT m) m ()-                     -> MiddlewareT m+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+      mFe = getFileExt req+  mMiddleware <- lookupResponse mAcceptBS mFe contentRoutes   fromMaybe (app req respond) $ do-    m <- mMiddleware-    return $ m app req respond+    mid <- mMiddleware+    return $ mid app req respond  -- | Given an HTTP @Accept@ header and a content type to base lookups off of, and -- a map of responses, find a response.-lookupResponse :: Monad m =>-                  Maybe AcceptHeader-               -> FileExt-               -> FileExtListenerT a m ()-               -> m (Maybe a)-lookupResponse mAcceptBS f fexts = do+lookupResponse :: ( MonadIO m+                  ) => Maybe AcceptHeader+                    -> Maybe FileExt+                    -> FileExtListenerT (MiddlewareT m) m ()+                    -> m (Maybe (MiddlewareT m))+lookupResponse mAcceptBS mFe fexts = do   femap <- execFileExtListenerT fexts-  return $ lookupFileExt mAcceptBS f femap+  return $ lookupFileExt 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+    lookupFileExt xs =+      let attempts = maybe allFileExts (possibleFileExts mFe) mAcceptBS+      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+possibleFileExts :: Maybe FileExt -> AcceptHeader -> [FileExt]+possibleFileExts mFe accept = 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-    sortFE Markdown   xs = [Markdown, Text]         `intersect` xs+    computed :: [FileExt]+    computed = findFE $ 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, Markdown])+                            ] accept+                , mapAccept [ ("text/markdown" :: BS.ByteString, [Markdown])+                            ] accept+                , mapAccept [ ("text/css" :: BS.ByteString, [Css])+                            ] accept+                ] +    wildcard :: [FileExt]+    wildcard = findFE $ fromMaybe [] $ mapAccept [ ("*/*" :: BS.ByteString, allFileExts)+                                                 ] accept ++    findFE :: [FileExt] -> [FileExt]+    findFE xs = maybe xs (\fe -> fe <$ guard (fe `elem` xs)) mFe+++-- | All file extensions, in the order of preference+allFileExts :: [FileExt]+allFileExts = [Html,Text,Json,JavaScript,Css,Markdown] 

@@ -14,6 +14,7 @@ import           Control.Monad.IO.Class                  (MonadIO)  +-- * Lifted Combinators  -- | Uses @Html@ as the key in the map, and @"text/html"@ as the content type. blaze :: MonadIO m =>@@ -57,6 +58,7 @@   bytestringStatusWith f Html s hs $ LT.encodeUtf8 $ H.renderHtml i  +-- * 'Network.Wai.Response' Only  blazeOnly :: H.Html -> Response blazeOnly = blazeOnlyStatusHeaders status200 [("Content-Type", "text/html")]

@@ -11,6 +11,7 @@ import           Control.Monad.IO.Class  +-- * Lifted Combinators  -- | A builder is ambiguous, therefore we require @RequestHeaders@ and a @FileExt@ to be explicitly -- supplied.@@ -34,10 +35,11 @@                   -> FileExtListenerT (MiddlewareT m) m () builderStatusWith f e s hs i =   let r = builderOnlyStatus s hs i in-  FileExtListenerT $ tell $-    FileExts $ Map.singleton e $ \_ _ respond -> respond (f r)+  FileExtListenerT $ tell' $+    Map.singleton e $ \_ _ respond -> respond (f r)  +-- * 'Network.Wai.Response' Only  builderOnly :: RequestHeaders -> BU.Builder -> Response builderOnly = builderOnlyStatus status200

@@ -13,7 +13,7 @@ import           Control.Monad.IO.Class  --- * Lifted @MiddlewareT@+-- * Lifted Combinators  -- | @ByteString@ is ambiguous - we need to know what @RequestHeaders@ and @FileExt@ should be associated. bytestring :: MonadIO m => FileExt -> RequestHeaders -> B.ByteString@@ -40,7 +40,7 @@   middleware fe $ \_ _ respond -> respond (f r)  --- * Raw @Response@s+-- * 'Network.Wai.Response' Only  bytestringOnly :: RequestHeaders -> B.ByteString -> Response bytestringOnly = bytestringOnlyStatus status200

@@ -12,6 +12,7 @@ import           Control.Monad.IO.Class                  (MonadIO)  +-- * Lifted Combinators  -- | Uses @cassius@ as the key in the map, and @"cassius/plain"@ as the content type. cassius :: MonadIO m => Css -> FileExtListenerT (MiddlewareT m) m ()@@ -54,7 +55,7 @@   bytestringStatusWith f Css s hs $ LT.encodeUtf8 $ renderCss i  -+-- * 'Network.Wai.Response' Only  cassiusOnly :: Css -> Response cassiusOnly = cassiusOnlyStatusHeaders status200 [("Content-Type", "cassius/css")]

@@ -13,6 +13,7 @@ import           Control.Monad.IO.Class                  (MonadIO)  +-- * Lifted Combinators  -- | Uses @Text@ as the key in the map, and @"text/css"@ as the content type. clay :: MonadIO m =>@@ -58,6 +59,7 @@   +-- * 'Network.Wai.Response' Only  clayOnly :: Config -> [App] -> Css -> Response clayOnly c as = clayOnlyStatusHeaders c as status200 [("Content-Type", "text/css")]

@@ -12,6 +12,7 @@   +-- * Lifted Combinators  -- | Uses @Json@ as the key in the map, and @"application/json"@ as the content type. json :: ( A.ToJSON j@@ -84,6 +85,7 @@   +-- * 'Network.Wai.Response' Only  jsonOnly :: A.ToJSON j =>             j -> Response

@@ -12,6 +12,7 @@ import           Control.Monad.IO.Class                  (MonadIO)  +-- * Lifted Combinators  -- | Uses @julius@ as the key in the map, and @"application/javascript"@ as the content type. julius :: MonadIO m =>@@ -55,6 +56,7 @@   bytestringStatusWith f Json s hs $ LT.encodeUtf8 $ renderJavascript i  +-- * 'Network.Wai.Response' Only  juliusOnly :: Javascript -> Response juliusOnly = juliusOnlyStatusHeaders status200 [("Content-Type", "application/javascript")]

@@ -11,6 +11,7 @@ import           Control.Monad.Trans  +-- * Lifted Combinators  -- | Uses the @Html@ key in the map, and @"text/html"@ as the content type. lucid :: MonadIO m => L.HtmlT m () -> FileExtListenerT (MiddlewareT m) m ()@@ -55,6 +56,7 @@   +-- * 'Network.Wai.Response' Only  lucidOnly :: Monad m =>              L.HtmlT m () -> m Response

@@ -12,6 +12,7 @@ import           Control.Monad.IO.Class                  (MonadIO)  +-- * Lifted Combinators  -- | Uses @lucius@ as the key in the map, and @"lucius/css"@ as the content type. lucius :: MonadIO m => Css -> FileExtListenerT (MiddlewareT m) m ()@@ -54,6 +55,7 @@   bytestringStatusWith f Css s hs $ LT.encodeUtf8 $ renderCss i  +-- * 'Network.Wai.Response' Only  luciusOnly :: Css -> Response luciusOnly = luciusOnlyStatusHeaders status200 [("Content-Type", "lucius/css")]

@@ -10,4 +10,4 @@               FileExt            -> MiddlewareT m            -> FileExtListenerT (MiddlewareT m) m ()-middleware f m = tell $ FileExts $ Map.singleton f m+middleware f m = tell' $ Map.singleton f m

@@ -13,6 +13,7 @@ import           Control.Monad.Trans  +-- * Lifted Combinators  -- | Uses the @Html@ key in the map, and @"text/html"@ as the content type. markdown :: MonadIO m => P.Pandoc -> FileExtListenerT (MiddlewareT m) m ()@@ -51,11 +52,11 @@ markdownStatusHeadersWith :: MonadIO m =>                           (Response -> Response) -> Status -> RequestHeaders -> P.Pandoc                        -> FileExtListenerT (MiddlewareT m) m ()-markdownStatusHeadersWith f s hs i = do+markdownStatusHeadersWith f s hs i =   bytestringStatusWith f Html s hs . LT.encodeUtf8 . LT.pack $ P.writeMarkdown P.def i  -+-- * 'Network.Wai.Response' Only  markdownOnly :: P.Pandoc -> Response markdownOnly = markdownOnlyStatusHeaders status200 [("Content-Type", "text/markdown")]

@@ -12,6 +12,7 @@ import           Control.Monad.IO.Class                  (MonadIO)  +-- * Lifted Combinators  -- | Uses @Text@ as the key in the map, and @"text/plain"@ as the content type. text :: MonadIO m => LT.Text -> FileExtListenerT (MiddlewareT m) m ()@@ -55,6 +56,7 @@   +-- * 'Network.Wai.Response' Only  textOnly :: LT.Text -> Response textOnly = textOnlyStatusHeaders status200 [("Content-Type", "text/plain")]

@@ -2,7 +2,6 @@     TypeFamilies   , DeriveFunctor   , FlexibleContexts-  , DeriveTraversable   , OverloadedStrings   , FlexibleInstances   , StandaloneDeriving@@ -11,23 +10,33 @@   , GeneralizedNewtypeDeriving   #-} +{- |+Module      : Network.Wai.Middleware.ContentType.Types+Copyright   : (c) 2015 Athan Clark++License     : BSD-3+Maintainer  : athan.clark@gmail.com+Stability   : experimental+Portability : GHC+-}+ module Network.Wai.Middleware.ContentType.Types-  ( FileExt (..)+  ( -- * Types+    FileExt (..)   , getFileExt   , toExt-  , FileExts (..)+  , FileExtMap   , FileExtListenerT (..)   , execFileExtListenerT-  , mapFileExts-  , tell+  , -- * Utilities+    tell'   ) where -import           Network.Wai+import           Network.Wai.Trans import qualified Data.Text              as T import           Data.Map-import           Data.Maybe (fromMaybe) import           Data.Monoid-import           Data.Foldable+import           Data.Url import           Control.Applicative import           Control.Monad.Base import           Control.Monad.Catch@@ -42,8 +51,9 @@ import           Control.Monad.Morph  -tell :: (Monoid w, MonadState w m) => w -> m ()-tell x = do+-- | Version of 'Control.Monad.Writer.tell' for 'Control.Monad.State.StateT'+tell' :: (Monoid w, MonadState w m) => w -> m ()+tell' x = do   xs <- get   put $ xs <> x @@ -57,21 +67,14 @@   deriving (Show, Eq, Ord)  -getFileExt :: Request -> FileExt-getFileExt req = fromMaybe Html $ case pathInfo req of-  [] -> Just Html-  xs -> toExt $ T.pack $ getLastExt $ T.unpack $ last xs-  where-    getLastExt ts = evalState (foldrM go [] ts) False-    go c soFar = do-      sawPeriod <- get-      if sawPeriod-      then return soFar-      else if c == '.'-           then do put True-                   return ('.' : soFar)-           else return (c : soFar)+-- | Gets the known file extension from a Request's 'Network.Wai.pathInfo'.+getFileExt :: Request -> Maybe FileExt+getFileExt req = case pathInfo req of+  [] -> Nothing+  xs -> toExt $ snd $ T.breakOn "." $ last xs +-- | matches a file extension (__including__ it's prefix dot - @.html@ for example)+--   to a known one. toExt :: T.Text -> Maybe FileExt toExt x | x `elem` htmls       = Just Html         | x `elem` csss        = Just Css@@ -88,21 +91,27 @@     texts       = [".txt"]     markdowns   = [".md", ".markdown"] -newtype FileExts a = FileExts { unFileExts :: Map FileExt a }-  deriving (Show, Eq, Monoid, Functor, Foldable, Traversable)+type FileExtMap a = Map FileExt a +-- | The monad for our DSL - when using the combinators, our result will be this+--   type:+--+--   > myListener :: FileExtListenerT (MiddlewareT m) m ()+--   > myListener = do+--   >   text "Text!"+--   >   json ("Json!" :: T.Text) newtype FileExtListenerT r m a =-  FileExtListenerT { runFileExtListenerT :: StateT (FileExts r) m a }+  FileExtListenerT { runFileExtListenerT :: StateT (FileExtMap r) m a }     deriving ( Functor, Applicative, Alternative, Monad, MonadFix, MonadPlus, MonadIO-             , MonadTrans, MonadReader r', MonadWriter w, MonadState (FileExts r)+             , MonadTrans, MonadReader r', MonadWriter w, MonadState (FileExtMap r)              , MonadCont, MonadError e, MonadBase b, MonadThrow, MonadCatch-             , MonadMask, MonadLogger, MFunctor+             , MonadMask, MonadLogger, MonadUrl b f, MFunctor              )  deriving instance (MonadResource m, MonadBase IO m) => MonadResource (FileExtListenerT r m)  instance MonadTransControl (FileExtListenerT r) where-  type StT (FileExtListenerT r) a = StT (StateT (FileExts r)) a+  type StT (FileExtListenerT r) a = StT (StateT (FileExtMap r)) a   liftWith = defaultLiftWith FileExtListenerT runFileExtListenerT   restoreT = defaultRestoreT FileExtListenerT @@ -113,14 +122,5 @@   restoreM     = defaultRestoreM  -execFileExtListenerT :: Monad m => FileExtListenerT r m a -> m (FileExts r)+execFileExtListenerT :: Monad m => FileExtListenerT r m a -> m (FileExtMap r) execFileExtListenerT xs = execStateT (runFileExtListenerT xs) mempty--mapFileExts :: Monad m =>-               (a -> b)-            -> FileExtListenerT a m () -> FileExtListenerT b m ()-mapFileExts f fl = do-  femap <- lift $ execFileExtListenerT fl-  tell $ f <$> femap--

@@ -1,5 +1,5 @@ Name:                   wai-middleware-content-type-Version:                0.0.4+Version:                0.1.0 Author:                 Athan Clark <athan.clark@gmail.com> Maintainer:             Athan Clark <athan.clark@gmail.com> License:                BSD3@@ -49,6 +49,7 @@                       , text                       , transformers                       , transformers-base+                      , urlpath >= 5.0.0.1                       , wai                       , wai-transformers >= 0.0.3                       , wai-util