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
{ mimeTypeInfoContentType :: Q Type
, mimeTypeInfoRespType :: Q Type
, mimeTypeInfoToExpression :: ByteString -> Q Exp
}
stringToBs :: String -> ByteString
stringToBs = B8.pack
byteStringToExp :: ByteString -> Q Exp
byteStringToExp byteString = do
helper <- [| stringToBs |]
let !chars = B8.unpack byteString
pure $! AppE (VarE 'pure) $! AppE helper $! LitE $! StringL chars
utf8ByteStringToExp :: ByteString -> Q Exp
utf8ByteStringToExp byteString =
let stringExp = stringE . unpack $ decodeUtf8With lenientDecode byteString
packedExp = appE (varE 'pack) stringExp
byteStringExp = appE (varE 'encodeUtf8) packedExp
in appE (varE 'pure) byteStringExp
htmlToExp :: ByteString -> Q Exp
htmlToExp byteString =
let fileContentsString = unpack $ decodeUtf8With lenientDecode byteString
in [e|pure $ (preEscapedToHtml :: String -> Html) fileContentsString|]
extensionMimeTypeMap :: Map String MimeTypeInfo
extensionMimeTypeMap =
[ ("css", MimeTypeInfo [t|CSS|] [t|ByteString|] byteStringToExp)
, ("gif", MimeTypeInfo [t|GIF|] [t|ByteString|] byteStringToExp)
, ("htm", MimeTypeInfo [t|HTML|] [t|Html|] htmlToExp)
, ("html", MimeTypeInfo [t|HTML|] [t|Html|] htmlToExp)
, ("jpeg", MimeTypeInfo [t|JPEG|] [t|ByteString|] byteStringToExp)
, ("jpg", MimeTypeInfo [t|JPEG|] [t|ByteString|] byteStringToExp)
, ("js", MimeTypeInfo [t|JS|] [t|ByteString|] byteStringToExp)
, ("png", MimeTypeInfo [t|PNG|] [t|ByteString|] byteStringToExp)
, ("svg", MimeTypeInfo [t|SVG|] [t|ByteString|] byteStringToExp)
, ("txt", MimeTypeInfo [t|TXT|] [t|ByteString|] byteStringToExp)
]
extensionToMimeTypeInfoEx :: FilePath -> Q MimeTypeInfo
extensionToMimeTypeInfoEx file =
case extensionToMimeTypeInfo file of
Just mimeTypeInfo -> pure mimeTypeInfo
Nothing ->
let extension = getExtension file
in fail $
"Unknown extension type \"" <> extension <> "\". Please report as bug."
extensionToMimeTypeInfo :: FilePath -> Maybe MimeTypeInfo
extensionToMimeTypeInfo file =
Map.lookup
(removeLeadingPeriod $ takeExtension file)
extensionMimeTypeMap
data CSS deriving Typeable
instance Accept CSS where
contentType :: Proxy CSS -> MediaType
contentType _ = "text" // "css"
instance MimeRender CSS ByteString where
mimeRender :: Proxy CSS -> ByteString -> LByteString.ByteString
mimeRender _ = LByteString.fromStrict
data GIF deriving Typeable
instance Accept GIF where
contentType :: Proxy GIF -> MediaType
contentType _ = "image" // "gif"
instance MimeRender GIF ByteString where
mimeRender :: Proxy GIF -> ByteString -> LByteString.ByteString
mimeRender _ = LByteString.fromStrict
data JPEG deriving Typeable
instance Accept JPEG where
contentType :: Proxy JPEG -> MediaType
contentType _ = "image" // "jpeg"
instance MimeRender JPEG ByteString where
mimeRender :: Proxy JPEG -> ByteString -> LByteString.ByteString
mimeRender _ = LByteString.fromStrict
data JS deriving Typeable
instance Accept JS where
contentType :: Proxy JS -> MediaType
contentType _ = "application" // "javascript"
instance MimeRender JS ByteString where
mimeRender :: Proxy JS -> ByteString -> LByteString.ByteString
mimeRender _ = LByteString.fromStrict
data PNG deriving Typeable
instance Accept PNG where
contentType :: Proxy PNG -> MediaType
contentType _ = "image" // "png"
instance MimeRender PNG ByteString where
mimeRender :: Proxy PNG -> ByteString -> LByteString.ByteString
mimeRender _ = LByteString.fromStrict
data SVG deriving Typeable
instance Accept SVG where
contentType :: Proxy SVG -> MediaType
contentType _ = "image" // "svg+xml"
instance MimeRender SVG ByteString where
mimeRender :: Proxy SVG -> ByteString -> LByteString.ByteString
mimeRender _ = LByteString.fromStrict
data TXT deriving Typeable
instance Accept TXT where
contentType :: Proxy TXT -> MediaType
contentType _ = "text" // "plain"
instance MimeRender TXT ByteString where
mimeRender :: Proxy TXT -> ByteString -> LByteString.ByteString
mimeRender _ = LByteString.fromStrict