diff --git a/examples/Example.hs b/examples/Example.hs new file mode 100644 --- /dev/null +++ b/examples/Example.hs @@ -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" diff --git a/src/Network/Wai/Middleware/ContentType.hs b/src/Network/Wai/Middleware/ContentType.hs --- a/src/Network/Wai/Middleware/ContentType.hs +++ b/src/Network/Wai/Middleware/ContentType.hs @@ -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] diff --git a/src/Network/Wai/Middleware/ContentType/Cassius.hs b/src/Network/Wai/Middleware/ContentType/Cassius.hs --- a/src/Network/Wai/Middleware/ContentType/Cassius.hs +++ b/src/Network/Wai/Middleware/ContentType/Cassius.hs @@ -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 diff --git a/src/Network/Wai/Middleware/ContentType/Julius.hs b/src/Network/Wai/Middleware/ContentType/Julius.hs --- a/src/Network/Wai/Middleware/ContentType/Julius.hs +++ b/src/Network/Wai/Middleware/ContentType/Julius.hs @@ -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 diff --git a/src/Network/Wai/Middleware/ContentType/Lucius.hs b/src/Network/Wai/Middleware/ContentType/Lucius.hs --- a/src/Network/Wai/Middleware/ContentType/Lucius.hs +++ b/src/Network/Wai/Middleware/ContentType/Lucius.hs @@ -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 diff --git a/src/Network/Wai/Middleware/ContentType/Pandoc.hs b/src/Network/Wai/Middleware/ContentType/Pandoc.hs --- a/src/Network/Wai/Middleware/ContentType/Pandoc.hs +++ b/src/Network/Wai/Middleware/ContentType/Pandoc.hs @@ -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 diff --git a/src/Network/Wai/Middleware/ContentType/Types.hs b/src/Network/Wai/Middleware/ContentType/Types.hs --- a/src/Network/Wai/Middleware/ContentType/Types.hs +++ b/src/Network/Wai/Middleware/ContentType/Types.hs @@ -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 diff --git a/test/Network/Wai/Middleware/ContentTypeSpec.hs b/test/Network/Wai/Middleware/ContentTypeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Wai/Middleware/ContentTypeSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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] diff --git a/wai-middleware-content-type.cabal b/wai-middleware-content-type.cabal --- a/wai-middleware-content-type.cabal +++ b/wai-middleware-content-type.cabal @@ -1,5 +1,5 @@ Name: wai-middleware-content-type -Version: 0.1.0 +Version: 0.1.0.1 Author: Athan Clark Maintainer: Athan Clark 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