{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

{- |
Module      :  Servant.Static.TH.Internal.Mime

Copyright   :  Dennis Gosnell 2017
License     :  BSD3

Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)
Stability   :  experimental
Portability :  unknown

This module exports functions and datatypes for using many different mime
types.
-}

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)

-- | Hold 'Type's and functions work working with a given file type, like
-- @html@ or @js@.
--
-- You can find examples of 'MimeTypeInfo' in the function
-- 'extensionMimeTypeMap'.
data MimeTypeInfo = MimeTypeInfo
  { MimeTypeInfo -> Q Type
mimeTypeInfoContentType :: Q Type
    -- ^ A @'Q' 'Type'@ representing a type to use for the content type of a
    -- Servant API.  For instance, HTML files will use something like
    -- @[t|'HTML'|]@, while Javascript files will use something like
    -- @[t|'JS'|]@.
  , MimeTypeInfo -> Q Type
mimeTypeInfoRespType :: Q Type
    -- ^ A @'Q' 'Type'@ representing the type to use for the return vale of a
    -- Servant API.  For instance, HTML files will use something like
    -- @[t|'Html'|]@, while JavascriptFiles will use something like
    -- @[t|'ByteString'|]@.
  , MimeTypeInfo -> ByteString -> Q Exp
mimeTypeInfoToExpression :: ByteString -> Q Exp
    -- ^ A function that turns a 'ByteString' into an 'Exp'.  For an example,
    -- look at 'htmlToExp' and 'byteStringtoExp'.
  }

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|]

-- | A mapping from an extension like @html@ or @js@ to a 'MimeTypeInfo' for
-- that extension.
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)
  ]

-- | Just like 'extensionToMimeTypeInfo', but throw an error using 'fail' if
-- the extension for the given 'FilePath' is not found.
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."

-- | Lookup the 'MimeTypeInfo' for a given 'FilePath' (that has an extension
-- like @.html@ or @.js@).  Returns 'Nothing' if the 'MimeTypeInfo' for the
-- given extension is not found.
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

-------------------------
-- Supported MimeTypes --
-------------------------

-- CSS

data CSS deriving Typeable

-- | @text\/css@
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

-- GIF

data GIF deriving Typeable

-- | @image\/gif@
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

-- JPEG

data JPEG deriving Typeable

-- | @image\/jpeg@
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



-- ICO

-- | @since 0.2.0.0
data ICO deriving Typeable

-- | @icon\/ico@
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

-- JS

data JS deriving Typeable

-- | @application\/javascript@
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

-- PNG

data PNG deriving Typeable

-- | @image\/png@
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

-- SVG

data SVG deriving Typeable

-- | @image\/svg@
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

-- TXT

data TXT deriving Typeable

-- | @text\/plain@
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

-- EOT

-- | @since 0.2.0.0
data EOT deriving Typeable

-- | @fonts\/eot@
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

-- TTF

-- | @since 0.2.0.0
data TTF deriving Typeable

-- | @fonts\/ttf@
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

-- WOFF

-- | @since 0.2.0.0
data WOFF deriving Typeable

-- | @fonts\/woff@
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

-- WOFF2

-- | @since 0.2.0.0
data WOFF2 deriving Typeable

-- | @fonts\/woff2@
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


-- | JSON file
data JSON deriving Typeable

-- | @application\/json@
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


-- | XML file
data XML deriving Typeable

-- | @application\/xml@
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


-- | GEXF file (xml for graph application)
data GEXF deriving Typeable

-- | @application\/gexf@
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


-- | WASM file (WebAssembly bytecode)
data WASM deriving Typeable

-- | @application\/wasm@
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