wai-middleware-content-type 0.1.0 → 0.1.0.1

raw patch · 10 files changed

+387/−34 lines, 10 filesdep +hspecdep +hspec-waidep +pandoc-typesdep ~urlpathdep ~wai-transformersnew-component:exe:examplePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: hspec, hspec-wai, pandoc-types, tasty, tasty-hspec, warp

Dependency ranges changed: urlpath, wai-transformers

API changes (from Hackage documentation)

Files

• examples/Example.hs +32/−0
• src/Network/Wai/Middleware/ContentType.hs +27/−16
• src/Network/Wai/Middleware/ContentType/Cassius.hs +6/−6
• src/Network/Wai/Middleware/ContentType/Julius.hs +2/−1
• src/Network/Wai/Middleware/ContentType/Lucius.hs +6/−6
• src/Network/Wai/Middleware/ContentType/Pandoc.hs +1/−1
• src/Network/Wai/Middleware/ContentType/Types.hs +9/−2
• test/Network/Wai/Middleware/ContentTypeSpec.hs +176/−0
• test/Spec.hs +13/−0
• wai-middleware-content-type.cabal +115/−2

@@ -0,0 +1,32 @@+{-# LANGUAGE+    OverloadedStrings+  #-}++module Main where++import Network.Wai.Handler.Warp+import Network.Wai.Trans+import Network.Wai.Middleware.ContentType+import Network.HTTP.Types+import qualified Data.Text as T+import qualified Lucid     as L+import Control.Monad.IO.Class+++data AppError = AppError++myListener :: MonadIO m => FileExtListenerT (MiddlewareT m) m ()+myListener = do+  text "Text!"+  json ("Json!" :: T.Text)+  lucid (L.toHtmlRaw ("Html!" :: T.Text))++myApp :: MonadIO m => MiddlewareT m+myApp = fileExtsToMiddleware myListener++main :: IO ()+main = run 3000 (myApp defApp)+  where+    defApp :: Application+    defApp _ respond =+      respond $ textOnlyStatus status404 "404"

@@ -43,7 +43,7 @@     fileExtsToMiddleware   , lookupResponse   , possibleFileExts-  , allFileExts+  , invalidEncoding   , AcceptHeader   , -- * Re-Exports     module Network.Wai.Middleware.ContentType.Types@@ -76,6 +76,8 @@ import Network.Wai.Middleware.ContentType.Text import Network.Wai.Middleware.ContentType.Pandoc +import Network.Wai.Middleware.ContentType.Middleware (middleware)+ import qualified Data.ByteString as BS import qualified Data.Map as Map import Data.Maybe (fromMaybe, catMaybes)@@ -92,7 +94,7 @@                           -> MiddlewareT m fileExtsToMiddleware contentRoutes app req respond = do   let mAcceptBS = Prelude.lookup ("Accept" :: HeaderName) $ requestHeaders req-      mFe = getFileExt req+      mFe       = getFileExt req   mMiddleware <- lookupResponse mAcceptBS mFe contentRoutes   fromMaybe (app req respond) $ do     mid <- mMiddleware@@ -110,19 +112,26 @@   return $ lookupFileExt femap   where     lookupFileExt xs =-      let attempts = maybe allFileExts (possibleFileExts mFe) mAcceptBS-      in  getFirst $ foldMap (\f' -> First $ Map.lookup f' xs) attempts+      let attempts = findFE $ maybe allFileExts possibleFileExts mAcceptBS+      in  getFirst $ foldMap (First . flip Map.lookup xs) attempts +    findFE :: [FileExt] -> [FileExt]+    findFE xs =+      case mFe of+        Nothing -> []+        Just fe | fe == None -> xs+                | otherwise  -> fe <$ guard (fe `elem` xs) --- | Takes a file extension and an @Accept@ header, and returns the other++-- | Takes an @Accept@ header and returns the other -- file types handleable, in order of prescedence.-possibleFileExts :: Maybe FileExt -> AcceptHeader -> [FileExt]-possibleFileExts mFe accept = if not (null wildcard) then wildcard else computed+possibleFileExts :: AcceptHeader -> [FileExt]+possibleFileExts accept = if not (null wildcard) then wildcard else computed   where     computed :: [FileExt]-    computed = findFE $ concat $+    computed = concat $       catMaybes [ mapAccept [ ("application/json"       :: BS.ByteString, [Json])-                            , ("application/javascript" :: BS.ByteString, [Json,JavaScript])+                            , ("application/javascript" :: BS.ByteString, [JavaScript,Json])                             ] accept                 , mapAccept [ ("text/html" :: BS.ByteString, [Html])                             ] accept@@ -135,15 +144,17 @@                 ]      wildcard :: [FileExt]-    wildcard = findFE $ fromMaybe [] $ mapAccept [ ("*/*" :: BS.ByteString, allFileExts)-                                                 ] accept+    wildcard = fromMaybe [] $ mapAccept [ ("*/*" :: BS.ByteString, allFileExts)+                                        ] accept  -    findFE :: [FileExt] -> [FileExt]-    findFE xs = maybe xs (\fe -> fe <$ guard (fe `elem` xs)) mFe +-- | Use this combinator as the last one, as a "catch-all":+--+--   > myApp = do+--   >   text "foo"+--   >   invalidEncoding myErrorHandler+invalidEncoding :: MonadIO m => MiddlewareT m -> FileExtListenerT (MiddlewareT m) m ()+invalidEncoding mid = mapM_ (`middleware` mid) allFileExts --- | All file extensions, in the order of preference-allFileExts :: [FileExt]-allFileExts = [Html,Text,Json,JavaScript,Css,Markdown] 

@@ -16,22 +16,22 @@  -- | 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")]+cassius = cassiusStatusHeaders status200 [("Content-Type", "text/css")]  cassiusWith :: MonadIO m =>                (Response -> Response) -> Css             -> FileExtListenerT (MiddlewareT m) m ()-cassiusWith f = cassiusStatusHeadersWith f status200 [("Content-Type", "cassius/css")]+cassiusWith f = cassiusStatusHeadersWith f status200 [("Content-Type", "text/css")]  cassiusStatus :: MonadIO m =>                  Status -> Css               -> FileExtListenerT (MiddlewareT m) m ()-cassiusStatus s = cassiusStatusHeaders s [("Content-Type", "cassius/css")]+cassiusStatus s = cassiusStatusHeaders s [("Content-Type", "text/css")]  cassiusStatusWith :: MonadIO m =>                      (Response -> Response) -> Status -> Css                   -> FileExtListenerT (MiddlewareT m) m ()-cassiusStatusWith f s = cassiusStatusHeadersWith f s [("Content-Type", "cassius/css")]+cassiusStatusWith f s = cassiusStatusHeadersWith f s [("Content-Type", "text/css")]  cassiusHeaders :: MonadIO m =>                   RequestHeaders -> Css@@ -58,10 +58,10 @@ -- * 'Network.Wai.Response' Only  cassiusOnly :: Css -> Response-cassiusOnly = cassiusOnlyStatusHeaders status200 [("Content-Type", "cassius/css")]+cassiusOnly = cassiusOnlyStatusHeaders status200 [("Content-Type", "text/css")]  cassiusOnlyStatus :: Status -> Css -> Response-cassiusOnlyStatus s = cassiusOnlyStatusHeaders s [("Content-Type", "cassius/css")]+cassiusOnlyStatus s = cassiusOnlyStatusHeaders s [("Content-Type", "text/css")]  cassiusOnlyHeaders :: RequestHeaders -> Css -> Response cassiusOnlyHeaders = cassiusOnlyStatusHeaders status200

@@ -3,6 +3,7 @@ module Network.Wai.Middleware.ContentType.Julius where  import           Network.Wai.Middleware.ContentType.Types+import qualified Network.Wai.Middleware.ContentType.Types as CT import           Network.Wai.Middleware.ContentType.ByteString import           Network.HTTP.Types                      (RequestHeaders, Status, status200) import           Network.Wai.Trans@@ -53,7 +54,7 @@                            (Response -> Response) -> Status -> RequestHeaders -> Javascript                         -> FileExtListenerT (MiddlewareT m) m () juliusStatusHeadersWith f s hs i =-  bytestringStatusWith f Json s hs $ LT.encodeUtf8 $ renderJavascript i+  bytestringStatusWith f CT.JavaScript s hs $ LT.encodeUtf8 $ renderJavascript i   -- * 'Network.Wai.Response' Only

@@ -16,22 +16,22 @@  -- | 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")]+lucius = luciusStatusHeaders status200 [("Content-Type", "text/css")]  luciusWith :: MonadIO m =>               (Response -> Response) -> Css            -> FileExtListenerT (MiddlewareT m) m ()-luciusWith f = luciusStatusHeadersWith f status200 [("Content-Type", "lucius/css")]+luciusWith f = luciusStatusHeadersWith f status200 [("Content-Type", "text/css")]  luciusStatus :: MonadIO m =>                 Status -> Css              -> FileExtListenerT (MiddlewareT m) m ()-luciusStatus s = luciusStatusHeaders s [("Content-Type", "lucius/css")]+luciusStatus s = luciusStatusHeaders s [("Content-Type", "text/css")]  luciusStatusWith :: MonadIO m =>                     (Response -> Response) -> Status -> Css                  -> FileExtListenerT (MiddlewareT m) m ()-luciusStatusWith f s = luciusStatusHeadersWith f s [("Content-Type", "lucius/css")]+luciusStatusWith f s = luciusStatusHeadersWith f s [("Content-Type", "text/css")]  luciusHeaders :: MonadIO m =>                  RequestHeaders -> Css@@ -58,10 +58,10 @@ -- * 'Network.Wai.Response' Only  luciusOnly :: Css -> Response-luciusOnly = luciusOnlyStatusHeaders status200 [("Content-Type", "lucius/css")]+luciusOnly = luciusOnlyStatusHeaders status200 [("Content-Type", "text/css")]  luciusOnlyStatus :: Status -> Css -> Response-luciusOnlyStatus s = luciusOnlyStatusHeaders s [("Content-Type", "lucius/css")]+luciusOnlyStatus s = luciusOnlyStatusHeaders s [("Content-Type", "text/css")]  luciusOnlyHeaders :: RequestHeaders -> Css -> Response luciusOnlyHeaders = luciusOnlyStatusHeaders status200

@@ -53,7 +53,7 @@                           (Response -> Response) -> Status -> RequestHeaders -> P.Pandoc                        -> FileExtListenerT (MiddlewareT m) m () markdownStatusHeadersWith f s hs i =-  bytestringStatusWith f Html s hs . LT.encodeUtf8 . LT.pack $ P.writeMarkdown P.def i+  bytestringStatusWith f Markdown s hs . LT.encodeUtf8 . LT.pack $ P.writeMarkdown P.def i   -- * 'Network.Wai.Response' Only

@@ -23,6 +23,7 @@ module Network.Wai.Middleware.ContentType.Types   ( -- * Types     FileExt (..)+  , allFileExts   , getFileExt   , toExt   , FileExtMap@@ -64,19 +65,25 @@              | Json              | Text              | Markdown+             | None   deriving (Show, Eq, Ord) +-- | All file extensions, in the order of likeliness+allFileExts :: [FileExt]+allFileExts = [Html,Text,Json,JavaScript,Css,Markdown] + -- | Gets the known file extension from a Request's 'Network.Wai.pathInfo'. getFileExt :: Request -> Maybe FileExt getFileExt req = case pathInfo req of-  [] -> Nothing+  [] -> Just None   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+toExt x | x == ""              = Just None+        | x `elem` htmls       = Just Html         | x `elem` csss        = Just Css         | x `elem` javascripts = Just JavaScript         | x `elem` jsons       = Just Json

@@ -0,0 +1,176 @@+{-# LANGUAGE+    OverloadedStrings+  , QuasiQuotes+  #-}++module Network.Wai.Middleware.ContentTypeSpec where++import Network.Wai.Middleware.ContentType+import Network.Wai.Trans+import Network.HTTP.Types+import qualified Data.Text      as T+import qualified Data.Text.Lazy as LT+import qualified Lucid          as L+import qualified Text.Lucius    as SL+import qualified Text.Julius    as SJ+import qualified Text.Pandoc    as P+import Test.Hspec+import Test.Hspec.Wai   as HW++++mockServer :: Spec+mockServer = do+  describe "All Requests Respond to the Accept Header" $+    with (return app) $ do+      describe "Text" $+        it "should respond with 200" $+        HW.request "GET" "/" [("Accept", "text/plain")] "" `shouldRespondWith`+        "" { matchStatus = 200+           , matchBody = Just "Text!"+           }+      describe "Json" $+        it "should respond with 200" $+        HW.request "GET" "/" [("Accept", "application/json")] "" `shouldRespondWith`+        "" { matchStatus = 200+           , matchBody = Just "\"Json!\""+           }+      describe "Html" $+        it "should respond with 200" $+        HW.request "GET" "/" [("Accept", "text/html")] "" `shouldRespondWith`+        "" { matchStatus = 200+           , matchBody = Just "Html!"+           }+      describe "Css" $+        it "should respond with 200" $+        HW.request "GET" "/" [("Accept", "text/css")] "" `shouldRespondWith`+        "" { matchStatus = 200+           , matchBody = Just "body{background:#fff}"+           }+      describe "JavaScript" $+        it "should respond with 200" $+        HW.request "GET" "/" [("Accept", "application/javascript")] "" `shouldRespondWith`+        "" { matchStatus = 200+           , matchBody = Just "function foo () {return;}"+           }+      describe "Markdown" $+        it "should respond with 200" $+        HW.request "GET" "/" [("Accept", "text/markdown")] "" `shouldRespondWith`+        "" { matchStatus = 200+           , matchBody = Just "*Pandoc*!"+           }+  describe "All Requests Respond to the File Extension" $+    with (return app) $ do+      describe "Text" $+        it "should respond with 200" $+        HW.get "/index.txt" `shouldRespondWith`+        "" { matchStatus = 200+           , matchBody = Just "Text!"+           }+      describe "Json" $+        it "should respond with 200" $+        HW.get "/index.json" `shouldRespondWith`+        "" { matchStatus = 200+           , matchBody = Just "\"Json!\""+           }+      describe "Html" $+        it "should respond with 200" $+        HW.get "index.html" `shouldRespondWith`+        "" { matchStatus = 200+           , matchBody = Just "Html!"+           }+      describe "Css" $+        it "should respond with 200" $+        HW.get "/index.css" `shouldRespondWith`+        "" { matchStatus = 200+           , matchBody = Just "body{background:#fff}"+           }+      describe "JavaScript" $+        it "should respond with 200" $+        HW.get "/index.js" `shouldRespondWith`+        "" { matchStatus = 200+           , matchBody = Just "function foo () {return;}"+           }+      describe "Markdown" $+        it "should respond with 200" $+        HW.get "/index.md" `shouldRespondWith`+        "" { matchStatus = 200+           , matchBody = Just "*Pandoc*!"+           }+  describe "All Requests Respond to Both" $+    with (return app) $ do+      describe "Text" $+        it "should respond with 200" $+        HW.request "GET" "/index.txt" [("Accept", "text/plain")] "" `shouldRespondWith`+        "" { matchStatus = 200+           , matchBody = Just "Text!"+           }+      describe "Json" $+        it "should respond with 200" $+        HW.request "GET" "/index.json" [("Accept", "application/json")] "" `shouldRespondWith`+        "" { matchStatus = 200+           , matchBody = Just "\"Json!\""+           }+      describe "Html" $+        it "should respond with 200" $+        HW.request "GET" "/index.html" [("Accept", "text/html")] "" `shouldRespondWith`+        "" { matchStatus = 200+           , matchBody = Just "Html!"+           }+      describe "Css" $+        it "should respond with 200" $+        HW.request "GET" "/index.css" [("Accept", "text/css")] "" `shouldRespondWith`+        "" { matchStatus = 200+           , matchBody = Just "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;}"+           }+      describe "Markdown" $+        it "should respond with 200" $+        HW.request "GET" "/index.md" [("Accept", "text/markdown")] "" `shouldRespondWith`+        "" { matchStatus = 200+           , matchBody = Just "*Pandoc*!"+           }+  describe "Outlier behavior" $+    with (return app) $ do+      describe "No extension, with header" $+        it " should respond with 200" $+        HW.request "GET" "/index" [("Accept", "text/plain")] "" `shouldRespondWith`+        "" { matchStatus = 200+           , matchBody = Just "Text!"+           }+      describe ".markdown & text/plain" $+        it " should respond with 200" $+        HW.request "GET" "/index.md" [("Accept", "text/plain")] "" `shouldRespondWith`+        "" { matchStatus = 200+           , matchBody = Just "*Pandoc*!"+           }+  describe "Unfulfillable accept headers should break" $+    with (return app) $ do+      describe "Text on non-ContentType" $+        it "should respond with 406" $+        HW.request "GET" "/index.txt" [("Accept", "foo/bar")] "" `shouldRespondWith`+        406+      describe "Json with non-file extension" $+        it "should respond with 406" $+        HW.request "GET" "/index.asdf" [("Accept", "application/json")] "" `shouldRespondWith`+        406++app :: Application+app = fileExtsToMiddleware allExamples $ \_ resp ->+  resp $ textOnlyStatus status406 "Something went wrong"++allExamples :: FileExtListenerT Middleware IO ()+allExamples = do+  text "Text!"+  json ("Json!" :: T.Text)+  lucid (L.toHtmlRaw ("Html!" :: T.Text))+  cassius ([SL.lucius|body {background: #fff;}|] undefined)+  julius  ([SJ.julius|function foo () {return;}|] undefined)+  markdown $ case P.readMarkdown P.def "*Pandoc*!" of+               Left e -> error $ show e+               Right p -> p

@@ -0,0 +1,13 @@+module Main where++import Network.Wai.Middleware.ContentTypeSpec++import Test.Tasty+import Test.Tasty.Hspec as TH+++main :: IO ()+main = do+  wai <- TH.testSpec "Network.Wai.Middleware.ContentType" mockServer+  defaultMain $ testGroup "Testing..."+    [wai]

@@ -1,5 +1,5 @@ Name:                   wai-middleware-content-type-Version:                0.1.0+Version:                0.1.0.1 Author:                 Athan Clark <athan.clark@gmail.com> Maintainer:             Athan Clark <athan.clark@gmail.com> License:                BSD3@@ -10,6 +10,12 @@ Build-Type:             Simple Category:               Web ++Flag Example+  Description:          Build a trivial example+  Default:              False++ Library   Default-Language:     Haskell2010   HS-Source-Dirs:       src@@ -51,8 +57,115 @@                       , transformers-base                       , urlpath >= 5.0.0.1                       , wai-                      , wai-transformers >= 0.0.3+                      , wai-transformers >= 0.0.4                       , wai-util++Test-Suite test+  Type:                 exitcode-stdio-1.0+  Default-Language:     Haskell2010+  HS-Source-Dirs:       src+                      , test+  GHC-Options:          -Wall -threaded+  Main-Is:              Spec.hs+  Other-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.Pandoc+                        Network.Wai.Middleware.ContentType.Text+                        Network.Wai.Middleware.ContentType.Middleware+                        Network.Wai.Middleware.ContentTypeSpec+  Build-Depends:        base >= 4.8 && < 5+                      , aeson+                      , blaze-builder+                      , blaze-html+                      , bytestring+                      , clay+                      , containers+                      , exceptions+                      , hspec+                      , hspec-wai+                      , http-media+                      , http-types+                      , lucid+                      , mmorph+                      , monad-control+                      , monad-logger+                      , mtl+                      , pandoc+                      , pandoc-types+                      , resourcet+                      , shakespeare+                      , text+                      , tasty+                      , tasty-hspec+                      , transformers+                      , transformers-base+                      , urlpath+                      , wai+                      , wai-transformers+                      , wai-util+                      , warp++Executable example+  if flag(Example)+    Buildable: True+  else+    Buildable: False+  Default-Language:     Haskell2010+  HS-Source-Dirs:       src+                      , examples+  GHC-Options:          -Wall -threaded+  Main-Is:              Example.hs+  Other-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.Pandoc+                        Network.Wai.Middleware.ContentType.Text+                        Network.Wai.Middleware.ContentType.Middleware+  Build-Depends:        base >= 4.8 && < 5+                      , aeson+                      , blaze-builder+                      , blaze-html+                      , bytestring+                      , clay+                      , containers+                      , exceptions+                      , http-media+                      , http-types+                      , lucid+                      , mmorph+                      , monad-control+                      , monad-logger+                      , mtl+                      , pandoc+                      , resourcet+                      , shakespeare+                      , text+                      , transformers+                      , transformers-base+                      , urlpath+                      , wai+                      , wai-transformers+                      , wai-util+                      , warp++  Source-Repository head   Type:                 git