module Servant.Static.TH.Internal.Mime where
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
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 (unpack)
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Typeable (Typeable)
import Language.Haskell.TH (Exp, Q, Type)
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
}
byteStringToExp :: ByteString -> Q Exp
byteStringToExp byteString =
let word8List = ByteString.unpack byteString
in [e|pure $ ByteString.pack word8List|]
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)
, ("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"
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