{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Servant.Static.TH.Internal.Mime where
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as LByteString
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Monoid ((<>))
import Data.Proxy (Proxy)
import Data.Text (pack, unpack)
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Typeable (Typeable)
import Language.Haskell.TH
(Exp(AppE, LitE, VarE), Lit(StringL), Q, Type, appE, stringE, varE)
import Network.HTTP.Media (MediaType, (//))
import Servant.HTML.Blaze (HTML)
import Servant.API (Accept(contentType), MimeRender(mimeRender))
import System.FilePath (takeExtension)
import Text.Blaze.Html (Html, preEscapedToHtml)
import Servant.Static.TH.Internal.Util
(getExtension, removeLeadingPeriod)
data MimeTypeInfo = MimeTypeInfo
{ MimeTypeInfo -> Q Type
mimeTypeInfoContentType :: Q Type
, MimeTypeInfo -> Q Type
mimeTypeInfoRespType :: Q Type
, MimeTypeInfo -> ByteString -> Q Exp
mimeTypeInfoToExpression :: ByteString -> Q Exp
}
stringToBs :: String -> ByteString
stringToBs :: String -> ByteString
stringToBs = String -> ByteString
B8.pack
byteStringToExp :: ByteString -> Q Exp
byteStringToExp :: ByteString -> Q Exp
byteStringToExp ByteString
byteString = do
Exp
helper <- [| stringToBs |]
let !chars :: String
chars = ByteString -> String
B8.unpack ByteString
byteString
Exp -> Q Exp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$! Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pure) (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$! Exp -> Exp -> Exp
AppE Exp
helper (Exp -> Exp) -> Exp -> Exp
forall a b. (a -> b) -> a -> b
$! Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$! String -> Lit
StringL String
chars
utf8ByteStringToExp :: ByteString -> Q Exp
utf8ByteStringToExp :: ByteString -> Q Exp
utf8ByteStringToExp ByteString
byteString =
let stringExp :: Q Exp
stringExp = String -> Q Exp
stringE (String -> Q Exp) -> (Text -> String) -> Text -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
unpack (Text -> Q Exp) -> Text -> Q Exp
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
byteString
packedExp :: Q Exp
packedExp = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE 'pack) Q Exp
stringExp
byteStringExp :: Q Exp
byteStringExp = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE 'encodeUtf8) Q Exp
packedExp
in Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE 'pure) Q Exp
byteStringExp
htmlToExp :: ByteString -> Q Exp
htmlToExp :: ByteString -> Q Exp
htmlToExp ByteString
byteString =
let fileContentsString :: String
fileContentsString = Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode ByteString
byteString
in [e|pure $ (preEscapedToHtml :: String -> Html) fileContentsString|]
extensionMimeTypeMap :: Map String MimeTypeInfo
extensionMimeTypeMap :: Map String MimeTypeInfo
extensionMimeTypeMap =
[ (String
"css", Q Type -> Q Type -> (ByteString -> Q Exp) -> MimeTypeInfo
MimeTypeInfo [t|CSS|] [t|ByteString|] ByteString -> Q Exp
byteStringToExp)
, (String
"eot", Q Type -> Q Type -> (ByteString -> Q Exp) -> MimeTypeInfo
MimeTypeInfo [t|EOT|] [t|ByteString|] ByteString -> Q Exp
byteStringToExp)
, (String
"gexf", Q Type -> Q Type -> (ByteString -> Q Exp) -> MimeTypeInfo
MimeTypeInfo [t|GEXF|] [t|ByteString|] ByteString -> Q Exp
byteStringToExp)
, (String
"gif", Q Type -> Q Type -> (ByteString -> Q Exp) -> MimeTypeInfo
MimeTypeInfo [t|GIF|] [t|ByteString|] ByteString -> Q Exp
byteStringToExp)
, (String
"htm", Q Type -> Q Type -> (ByteString -> Q Exp) -> MimeTypeInfo
MimeTypeInfo [t|HTML|] [t|Html|] ByteString -> Q Exp
htmlToExp)
, (String
"html", Q Type -> Q Type -> (ByteString -> Q Exp) -> MimeTypeInfo
MimeTypeInfo [t|HTML|] [t|Html|] ByteString -> Q Exp
htmlToExp)
, (String
"ico", Q Type -> Q Type -> (ByteString -> Q Exp) -> MimeTypeInfo
MimeTypeInfo [t|ICO|] [t|ByteString|] ByteString -> Q Exp
byteStringToExp)
, (String
"jpeg", Q Type -> Q Type -> (ByteString -> Q Exp) -> MimeTypeInfo
MimeTypeInfo [t|JPEG|] [t|ByteString|] ByteString -> Q Exp
byteStringToExp)
, (String
"jpg", Q Type -> Q Type -> (ByteString -> Q Exp) -> MimeTypeInfo
MimeTypeInfo [t|JPEG|] [t|ByteString|] ByteString -> Q Exp
byteStringToExp)
, (String
"js", Q Type -> Q Type -> (ByteString -> Q Exp) -> MimeTypeInfo
MimeTypeInfo [t|JS|] [t|ByteString|] ByteString -> Q Exp
byteStringToExp)
, (String
"json", Q Type -> Q Type -> (ByteString -> Q Exp) -> MimeTypeInfo
MimeTypeInfo [t|JSON|] [t|ByteString|] ByteString -> Q Exp
byteStringToExp)
, (String
"map", Q Type -> Q Type -> (ByteString -> Q Exp) -> MimeTypeInfo
MimeTypeInfo [t|JSON|] [t|ByteString|] ByteString -> Q Exp
byteStringToExp)
, (String
"png", Q Type -> Q Type -> (ByteString -> Q Exp) -> MimeTypeInfo
MimeTypeInfo [t|PNG|] [t|ByteString|] ByteString -> Q Exp
byteStringToExp)
, (String
"svg", Q Type -> Q Type -> (ByteString -> Q Exp) -> MimeTypeInfo
MimeTypeInfo [t|SVG|] [t|ByteString|] ByteString -> Q Exp
byteStringToExp)
, (String
"ttf", Q Type -> Q Type -> (ByteString -> Q Exp) -> MimeTypeInfo
MimeTypeInfo [t|TTF|] [t|ByteString|] ByteString -> Q Exp
byteStringToExp)
, (String
"txt", Q Type -> Q Type -> (ByteString -> Q Exp) -> MimeTypeInfo
MimeTypeInfo [t|TXT|] [t|ByteString|] ByteString -> Q Exp
byteStringToExp)
, (String
"wasm", Q Type -> Q Type -> (ByteString -> Q Exp) -> MimeTypeInfo
MimeTypeInfo [t|WASM|] [t|ByteString|] ByteString -> Q Exp
byteStringToExp)
, (String
"woff", Q Type -> Q Type -> (ByteString -> Q Exp) -> MimeTypeInfo
MimeTypeInfo [t|WOFF|] [t|ByteString|] ByteString -> Q Exp
byteStringToExp)
, (String
"woff2",Q Type -> Q Type -> (ByteString -> Q Exp) -> MimeTypeInfo
MimeTypeInfo [t|WOFF2|][t|ByteString|] ByteString -> Q Exp
byteStringToExp)
, (String
"xml", Q Type -> Q Type -> (ByteString -> Q Exp) -> MimeTypeInfo
MimeTypeInfo [t|XML|] [t|ByteString|] ByteString -> Q Exp
byteStringToExp)
]
extensionToMimeTypeInfoEx :: FilePath -> Q MimeTypeInfo
extensionToMimeTypeInfoEx :: String -> Q MimeTypeInfo
extensionToMimeTypeInfoEx String
file =
case String -> Maybe MimeTypeInfo
extensionToMimeTypeInfo String
file of
Just MimeTypeInfo
mimeTypeInfo -> MimeTypeInfo -> Q MimeTypeInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure MimeTypeInfo
mimeTypeInfo
Maybe MimeTypeInfo
Nothing ->
let extension :: String
extension = String -> String
getExtension String
file
in String -> Q MimeTypeInfo
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q MimeTypeInfo) -> String -> Q MimeTypeInfo
forall a b. (a -> b) -> a -> b
$
String
"Unknown extension type \"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
extension String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\". Please report as bug."
extensionToMimeTypeInfo :: FilePath -> Maybe MimeTypeInfo
extensionToMimeTypeInfo :: String -> Maybe MimeTypeInfo
extensionToMimeTypeInfo String
file =
String -> Map String MimeTypeInfo -> Maybe MimeTypeInfo
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup
(String -> String
removeLeadingPeriod (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
takeExtension String
file)
Map String MimeTypeInfo
extensionMimeTypeMap
data CSS deriving Typeable
instance Accept CSS where
contentType :: Proxy CSS -> MediaType
contentType :: Proxy CSS -> MediaType
contentType Proxy CSS
_ = ByteString
"text" ByteString -> ByteString -> MediaType
// ByteString
"css"
instance MimeRender CSS ByteString where
mimeRender :: Proxy CSS -> ByteString -> LByteString.ByteString
mimeRender :: Proxy CSS -> ByteString -> ByteString
mimeRender Proxy CSS
_ = ByteString -> ByteString
LByteString.fromStrict
data GIF deriving Typeable
instance Accept GIF where
contentType :: Proxy GIF -> MediaType
contentType :: Proxy GIF -> MediaType
contentType Proxy GIF
_ = ByteString
"image" ByteString -> ByteString -> MediaType
// ByteString
"gif"
instance MimeRender GIF ByteString where
mimeRender :: Proxy GIF -> ByteString -> LByteString.ByteString
mimeRender :: Proxy GIF -> ByteString -> ByteString
mimeRender Proxy GIF
_ = ByteString -> ByteString
LByteString.fromStrict
data JPEG deriving Typeable
instance Accept JPEG where
contentType :: Proxy JPEG -> MediaType
contentType :: Proxy JPEG -> MediaType
contentType Proxy JPEG
_ = ByteString
"image" ByteString -> ByteString -> MediaType
// ByteString
"jpeg"
instance MimeRender JPEG ByteString where
mimeRender :: Proxy JPEG -> ByteString -> LByteString.ByteString
mimeRender :: Proxy JPEG -> ByteString -> ByteString
mimeRender Proxy JPEG
_ = ByteString -> ByteString
LByteString.fromStrict
data ICO deriving Typeable
instance Accept ICO where
contentType :: Proxy ICO -> MediaType
contentType :: Proxy ICO -> MediaType
contentType Proxy ICO
_ = ByteString
"image" ByteString -> ByteString -> MediaType
// ByteString
"x-icon"
instance MimeRender ICO ByteString where
mimeRender :: Proxy ICO -> ByteString -> LByteString.ByteString
mimeRender :: Proxy ICO -> ByteString -> ByteString
mimeRender Proxy ICO
_ = ByteString -> ByteString
LByteString.fromStrict
data JS deriving Typeable
instance Accept JS where
contentType :: Proxy JS -> MediaType
contentType :: Proxy JS -> MediaType
contentType Proxy JS
_ = ByteString
"application" ByteString -> ByteString -> MediaType
// ByteString
"javascript"
instance MimeRender JS ByteString where
mimeRender :: Proxy JS -> ByteString -> LByteString.ByteString
mimeRender :: Proxy JS -> ByteString -> ByteString
mimeRender Proxy JS
_ = ByteString -> ByteString
LByteString.fromStrict
data PNG deriving Typeable
instance Accept PNG where
contentType :: Proxy PNG -> MediaType
contentType :: Proxy PNG -> MediaType
contentType Proxy PNG
_ = ByteString
"image" ByteString -> ByteString -> MediaType
// ByteString
"png"
instance MimeRender PNG ByteString where
mimeRender :: Proxy PNG -> ByteString -> LByteString.ByteString
mimeRender :: Proxy PNG -> ByteString -> ByteString
mimeRender Proxy PNG
_ = ByteString -> ByteString
LByteString.fromStrict
data SVG deriving Typeable
instance Accept SVG where
contentType :: Proxy SVG -> MediaType
contentType :: Proxy SVG -> MediaType
contentType Proxy SVG
_ = ByteString
"image" ByteString -> ByteString -> MediaType
// ByteString
"svg+xml"
instance MimeRender SVG ByteString where
mimeRender :: Proxy SVG -> ByteString -> LByteString.ByteString
mimeRender :: Proxy SVG -> ByteString -> ByteString
mimeRender Proxy SVG
_ = ByteString -> ByteString
LByteString.fromStrict
data TXT deriving Typeable
instance Accept TXT where
contentType :: Proxy TXT -> MediaType
contentType :: Proxy TXT -> MediaType
contentType Proxy TXT
_ = ByteString
"text" ByteString -> ByteString -> MediaType
// ByteString
"plain"
instance MimeRender TXT ByteString where
mimeRender :: Proxy TXT -> ByteString -> LByteString.ByteString
mimeRender :: Proxy TXT -> ByteString -> ByteString
mimeRender Proxy TXT
_ = ByteString -> ByteString
LByteString.fromStrict
data EOT deriving Typeable
instance Accept EOT where
contentType :: Proxy EOT -> MediaType
contentType :: Proxy EOT -> MediaType
contentType Proxy EOT
_ = ByteString
"application" ByteString -> ByteString -> MediaType
// ByteString
"vnd.ms-fontobject"
instance MimeRender EOT ByteString where
mimeRender :: Proxy EOT -> ByteString -> LByteString.ByteString
mimeRender :: Proxy EOT -> ByteString -> ByteString
mimeRender Proxy EOT
_ = ByteString -> ByteString
LByteString.fromStrict
data TTF deriving Typeable
instance Accept TTF where
contentType :: Proxy TTF -> MediaType
contentType :: Proxy TTF -> MediaType
contentType Proxy TTF
_ = ByteString
"application" ByteString -> ByteString -> MediaType
// ByteString
"x-font-truetype"
instance MimeRender TTF ByteString where
mimeRender :: Proxy TTF -> ByteString -> LByteString.ByteString
mimeRender :: Proxy TTF -> ByteString -> ByteString
mimeRender Proxy TTF
_ = ByteString -> ByteString
LByteString.fromStrict
data WOFF deriving Typeable
instance Accept WOFF where
contentType :: Proxy WOFF -> MediaType
contentType :: Proxy WOFF -> MediaType
contentType Proxy WOFF
_ = ByteString
"font" ByteString -> ByteString -> MediaType
// ByteString
"woff"
instance MimeRender WOFF ByteString where
mimeRender :: Proxy WOFF -> ByteString -> LByteString.ByteString
mimeRender :: Proxy WOFF -> ByteString -> ByteString
mimeRender Proxy WOFF
_ = ByteString -> ByteString
LByteString.fromStrict
data WOFF2 deriving Typeable
instance Accept WOFF2 where
contentType :: Proxy WOFF2 -> MediaType
contentType :: Proxy WOFF2 -> MediaType
contentType Proxy WOFF2
_ = ByteString
"font" ByteString -> ByteString -> MediaType
// ByteString
"woff2"
instance MimeRender WOFF2 ByteString where
mimeRender :: Proxy WOFF2 -> ByteString -> LByteString.ByteString
mimeRender :: Proxy WOFF2 -> ByteString -> ByteString
mimeRender Proxy WOFF2
_ = ByteString -> ByteString
LByteString.fromStrict
data JSON deriving Typeable
instance Accept JSON where
contentType :: Proxy JSON -> MediaType
contentType :: Proxy JSON -> MediaType
contentType Proxy JSON
_ = ByteString
"application" ByteString -> ByteString -> MediaType
// ByteString
"json"
instance MimeRender JSON ByteString where
mimeRender :: Proxy JSON -> ByteString -> LByteString.ByteString
mimeRender :: Proxy JSON -> ByteString -> ByteString
mimeRender Proxy JSON
_ = ByteString -> ByteString
LByteString.fromStrict
data XML deriving Typeable
instance Accept XML where
contentType :: Proxy XML -> MediaType
contentType :: Proxy XML -> MediaType
contentType Proxy XML
_ = ByteString
"application" ByteString -> ByteString -> MediaType
// ByteString
"xml"
instance MimeRender XML ByteString where
mimeRender :: Proxy XML -> ByteString -> LByteString.ByteString
mimeRender :: Proxy XML -> ByteString -> ByteString
mimeRender Proxy XML
_ = ByteString -> ByteString
LByteString.fromStrict
data GEXF deriving Typeable
instance Accept GEXF where
contentType :: Proxy GEXF -> MediaType
contentType :: Proxy GEXF -> MediaType
contentType Proxy GEXF
_ = ByteString
"application" ByteString -> ByteString -> MediaType
// ByteString
"gexf"
instance MimeRender GEXF ByteString where
mimeRender :: Proxy GEXF -> ByteString -> LByteString.ByteString
mimeRender :: Proxy GEXF -> ByteString -> ByteString
mimeRender Proxy GEXF
_ = ByteString -> ByteString
LByteString.fromStrict
data WASM deriving Typeable
instance Accept WASM where
contentType :: Proxy WASM -> MediaType
contentType :: Proxy WASM -> MediaType
contentType Proxy WASM
_ = ByteString
"application" ByteString -> ByteString -> MediaType
// ByteString
"wasm"
instance MimeRender WASM ByteString where
mimeRender :: Proxy WASM -> ByteString -> LByteString.ByteString
mimeRender :: Proxy WASM -> ByteString -> ByteString
mimeRender Proxy WASM
_ = ByteString -> ByteString
LByteString.fromStrict