module Network.Wai.Middleware.ContentType.Types
(
FileExt (..)
, allFileExts
, getFileExt
, toExt
, FileExtMap
, FileExtListenerT (..)
, execFileExtListenerT
,
tell'
) where
import Network.Wai.Trans
import qualified Data.Text as T
import Data.HashMap.Lazy
import Data.Monoid
import Data.Url
import Data.Hashable
import Control.Applicative
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.Cont
import Control.Monad.Except
import Control.Monad.Trans.Control hiding (embed)
import Control.Monad.Trans.Resource
import Control.Monad.State
import Control.Monad.Writer hiding (tell)
import Control.Monad.Reader
import Control.Monad.Logger
import Control.Monad.Morph
import GHC.Generics
tell' :: (Monoid w, MonadState w m) => w -> m ()
tell' x = modify' (<> x)
data FileExt
= Html
| Css
| JavaScript
| Json
| Text
| Markdown
deriving (Show, Eq, Ord, Generic)
instance Hashable FileExt
allFileExts :: [FileExt]
allFileExts = [Html,Text,Json,JavaScript,Css,Markdown]
getFileExt :: [T.Text] -> Maybe FileExt
getFileExt chunks = case chunks of
[] -> Nothing
xs -> toExt . snd . T.breakOn "." $ last xs
toExt :: T.Text -> Maybe FileExt
toExt x | x `elem` htmls = Just Html
| x `elem` csss = Just Css
| x `elem` javascripts = Just JavaScript
| x `elem` jsons = Just Json
| x `elem` texts = Just Text
| x `elem` markdowns = Just Markdown
| otherwise = Nothing
where
htmls = [".htm", ".html"]
csss = [".css"]
javascripts = [".js", ".javascript"]
jsons = [".json"]
texts = [".txt"]
markdowns = [".md", ".markdown"]
type FileExtMap a = HashMap FileExt a
newtype FileExtListenerT r m a = FileExtListenerT
{ runFileExtListenerT :: StateT (FileExtMap r) m a
} deriving ( Functor, Applicative, Alternative, Monad, MonadFix, MonadPlus, MonadIO
, MonadTrans, MonadReader r', MonadWriter w, MonadState (FileExtMap r)
, MonadCont, MonadError e, MonadBase b, MonadThrow, MonadCatch
, 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 (FileExtMap r)) a
liftWith = defaultLiftWith FileExtListenerT runFileExtListenerT
restoreT = defaultRestoreT FileExtListenerT
instance ( MonadBaseControl b m
) => MonadBaseControl b (FileExtListenerT r m) where
type StM (FileExtListenerT r m) a = ComposeSt (FileExtListenerT r) m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
execFileExtListenerT :: Monad m => FileExtListenerT r m a -> m (FileExtMap r)
execFileExtListenerT xs = execStateT (runFileExtListenerT xs) mempty