{-# LANGUAGE
    OverloadedStrings
  , FlexibleContexts
  #-}

{- |
Module      : Network.Wai.Middleware.ContentType
Copyright   : (c) 2015 Athan Clark

License     : BSD-3
Maintainer  : athan.clark@gmail.com
Stability   : experimental
Portability : GHC

-}

module Network.Wai.Middleware.ContentType
  ( lookupFileExt
  , fileExtsToMiddleware

  , -- * Re-Exports
    module Network.Wai.Middleware.ContentType.Types
  , module Network.Wai.Middleware.ContentType.Blaze
  , 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
  ) where

import Network.Wai.Middleware.ContentType.Types hiding (tell')
import Network.Wai.Middleware.ContentType.Blaze
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 (Response, requestHeaders, pathInfo)
import Network.Wai.Trans (MiddlewareT)
import Network.Wai.Logger (withStdoutLogger)
import qualified Data.HashMap.Lazy as HM
import Data.Monoid (First (..))
import Control.Monad.Trans.Control.Aligned (MonadBaseControl (..))
import Data.Singleton.Class (Extractable (..))



-- | Given an HTTP @Accept@ header and a content type to base lookups off of, and
-- a map of responses, find a response.
lookupFileExt :: Maybe AcceptHeader
              -> Maybe FileExt
              -> FileExtMap
              -> Maybe Response
lookupFileExt :: Maybe AcceptHeader -> Maybe FileExt -> FileExtMap -> Maybe Response
lookupFileExt Maybe AcceptHeader
mAcceptBS Maybe FileExt
mFe FileExtMap
m =
    forall a. First a -> Maybe a
getFirst
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\FileExt
fe -> forall a. Maybe a -> First a
First forall a b. (a -> b) -> a -> b
$ ResponseVia -> Response
runResponseVia forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup FileExt
fe FileExtMap
m)
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FileExt] -> [FileExt]
findFE
  forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall k v. HashMap k v -> [k]
HM.keys FileExtMap
m) ([FileExt] -> AcceptHeader -> [FileExt]
possibleFileExts forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [k]
HM.keys FileExtMap
m) Maybe AcceptHeader
mAcceptBS
  where
    findFE :: [FileExt] -> [FileExt]
    findFE :: [FileExt] -> [FileExt]
findFE [FileExt]
xs =
      case Maybe FileExt
mFe of
        Maybe FileExt
Nothing -> [FileExt]
xs
        Just FileExt
fe | FileExt
fe forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FileExt]
xs -> [FileExt
fe]
                | Bool
otherwise    -> []


fileExtsToMiddleware :: MonadBaseControl IO m stM
                     => Extractable stM
                     => FileExtListenerT urlbase m a
                     -> MiddlewareT m
fileExtsToMiddleware :: forall (m :: * -> *) (stM :: * -> *) urlbase a.
(MonadBaseControl IO m stM, Extractable stM) =>
FileExtListenerT urlbase m a -> MiddlewareT m
fileExtsToMiddleware FileExtListenerT urlbase m a
xs ApplicationT m
app Request
req Response -> m ResponseReceived
respond =
  forall (b :: * -> *) (m :: * -> *) (stM :: * -> *) a.
MonadBaseControl b m stM =>
(RunInBase m b stM -> b a) -> m a
liftBaseWith forall a b. (a -> b) -> a -> b
$ \RunInBase m IO stM
runInBase -> forall a. (ApacheLogger -> IO a) -> IO a
withStdoutLogger forall a b. (a -> b) -> a -> b
$ \ApacheLogger
aplogger -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Extractable f => f a -> a
runSingleton forall a b. (a -> b) -> a -> b
$ RunInBase m IO stM
runInBase forall a b. (a -> b) -> a -> b
$ do
    FileExtMap
m <- forall (m :: * -> *) urlbase a.
Monad m =>
FileExtListenerT urlbase m a
-> Maybe (Status -> Maybe Integer -> IO ()) -> m FileExtMap
execFileExtListenerT FileExtListenerT urlbase m a
xs (forall a. a -> Maybe a
Just (ApacheLogger
aplogger Request
req))
    let mAcceptHeader :: Maybe AcceptHeader
mAcceptHeader = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Accept" (Request -> RequestHeaders
requestHeaders Request
req)
        mFileExt :: Maybe FileExt
mFileExt      = [Text] -> Maybe FileExt
getFileExt (Request -> [Text]
pathInfo Request
req)
    case Maybe AcceptHeader -> Maybe FileExt -> FileExtMap -> Maybe Response
lookupFileExt Maybe AcceptHeader
mAcceptHeader Maybe FileExt
mFileExt FileExtMap
m of
      Maybe Response
Nothing -> ApplicationT m
app Request
req Response -> m ResponseReceived
respond
      Just Response
r  -> Response -> m ResponseReceived
respond Response
r