module Network.Wai.Middleware.ContentType
(
fileExtsToMiddleware
, lookupResponse
, possibleFileExts
, invalidEncoding
, AcceptHeader
,
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.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 Network.Wai.Middleware.ContentType.Middleware (middleware)
import qualified Data.ByteString as BS
import qualified Data.HashMap.Lazy as HM
import Data.Maybe (fromMaybe, catMaybes)
import Data.Monoid
import Control.Monad.Trans
import Control.Monad
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
mFe = getFileExt (pathInfo req)
mMiddleware <- lookupResponse mAcceptBS mFe contentRoutes
fromMaybe (app req respond) $ do
mid <- mMiddleware
return $ mid app req respond
lookupResponse :: ( MonadIO m
) => Maybe AcceptHeader
-> Maybe FileExt
-> FileExtListenerT (MiddlewareT m) m ()
-> m (Maybe (MiddlewareT m))
lookupResponse mAcceptBS mFe fexts =
lookupFileExt <$> execFileExtListenerT fexts
where
lookupFileExt xs =
let attempts = findFE $ maybe allFileExts possibleFileExts mAcceptBS
in getFirst $ foldMap (First . flip HM.lookup xs) attempts
findFE :: [FileExt] -> [FileExt]
findFE xs =
case mFe of
Nothing -> xs
Just fe -> fe <$ guard (fe `elem` xs)
possibleFileExts :: AcceptHeader -> [FileExt]
possibleFileExts accept = if not (null wildcard) then wildcard else computed
where
computed :: [FileExt]
computed = concat $
catMaybes [ mapAccept [ ("application/json" :: BS.ByteString, [Json])
, ("application/javascript" :: BS.ByteString, [JavaScript,Json])
] 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 = fromMaybe [] $ mapAccept [ ("*/*" :: BS.ByteString, allFileExts)
] accept
invalidEncoding :: MonadIO m => MiddlewareT m -> FileExtListenerT (MiddlewareT m) m ()
invalidEncoding mid = mapM_ (`middleware` mid) allFileExts