servant-static-th-0.2.3.0: src/Servant/Static/TH/Internal/Mime.hs

{-# 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
  { 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'|]@.
  , 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'|]@.
  , 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 = 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|]

-- | A mapping from an extension like @html@ or @js@ to a 'MimeTypeInfo' for
-- that extension.
extensionMimeTypeMap :: Map String MimeTypeInfo
extensionMimeTypeMap =
  [ ("css",  MimeTypeInfo [t|CSS|]  [t|ByteString|] byteStringToExp)
  , ("eot",  MimeTypeInfo [t|EOT|]  [t|ByteString|] byteStringToExp)
  , ("gexf", MimeTypeInfo [t|GEXF|] [t|ByteString|] byteStringToExp)
  , ("gif",  MimeTypeInfo [t|GIF|]  [t|ByteString|] byteStringToExp)
  , ("htm",  MimeTypeInfo [t|HTML|] [t|Html|]             htmlToExp)
  , ("html", MimeTypeInfo [t|HTML|] [t|Html|]             htmlToExp)
  , ("ico",  MimeTypeInfo [t|ICO|]  [t|ByteString|] byteStringToExp)
  , ("jpeg", MimeTypeInfo [t|JPEG|] [t|ByteString|] byteStringToExp)
  , ("jpg",  MimeTypeInfo [t|JPEG|] [t|ByteString|] byteStringToExp)
  , ("js",   MimeTypeInfo [t|JS|]   [t|ByteString|] byteStringToExp)
  , ("json", MimeTypeInfo [t|JSON|] [t|ByteString|] byteStringToExp)
  , ("map",  MimeTypeInfo [t|JSON|] [t|ByteString|] byteStringToExp)
  , ("png",  MimeTypeInfo [t|PNG|]  [t|ByteString|] byteStringToExp)
  , ("svg",  MimeTypeInfo [t|SVG|]  [t|ByteString|] byteStringToExp)
  , ("ttf",  MimeTypeInfo [t|TTF|]  [t|ByteString|] byteStringToExp)
  , ("txt",  MimeTypeInfo [t|TXT|]  [t|ByteString|] byteStringToExp)
  , ("woff", MimeTypeInfo [t|WOFF|] [t|ByteString|] byteStringToExp)
  , ("woff2",MimeTypeInfo [t|WOFF2|][t|ByteString|] byteStringToExp)
  , ("xml",  MimeTypeInfo [t|XML|]  [t|ByteString|] 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 file =
  case extensionToMimeTypeInfo file of
    Just mimeTypeInfo -> pure mimeTypeInfo
    Nothing ->
      let extension = getExtension file
      in fail $
        "Unknown extension type \"" <> extension <> "\".  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 file =
  Map.lookup
    (removeLeadingPeriod $ takeExtension file)
    extensionMimeTypeMap

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

-- CSS

data CSS deriving Typeable

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

-- GIF

data GIF deriving Typeable

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

-- JPEG

data JPEG deriving Typeable

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



-- ICO

-- | @since 0.2.0.0
data ICO deriving Typeable

-- | @icon\/ico@
instance Accept ICO where
  contentType :: Proxy ICO -> MediaType
  contentType _ = "image" // "x-icon"

instance MimeRender ICO ByteString where
  mimeRender :: Proxy ICO -> ByteString -> LByteString.ByteString
  mimeRender _ = LByteString.fromStrict

-- JS

data JS deriving Typeable

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

-- PNG

data PNG deriving Typeable

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

-- SVG

data SVG deriving Typeable

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

-- TXT

data TXT deriving Typeable

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

-- EOT

-- | @since 0.2.0.0
data EOT deriving Typeable

-- | @fonts\/eot@
instance Accept EOT where
  contentType :: Proxy EOT -> MediaType
  contentType _ = "application" // "vnd.ms-fontobject"

instance MimeRender EOT ByteString where
  mimeRender :: Proxy EOT -> ByteString -> LByteString.ByteString
  mimeRender _ = LByteString.fromStrict

-- TTF

-- | @since 0.2.0.0
data TTF deriving Typeable

-- | @fonts\/ttf@
instance Accept TTF where
  contentType :: Proxy TTF -> MediaType
  contentType _ = "application" // "x-font-truetype"

instance MimeRender TTF ByteString where
  mimeRender :: Proxy TTF -> ByteString -> LByteString.ByteString
  mimeRender _ = LByteString.fromStrict

-- WOFF

-- | @since 0.2.0.0
data WOFF deriving Typeable

-- | @fonts\/woff@
instance Accept WOFF where
  contentType :: Proxy WOFF -> MediaType
  contentType _ = "font" // "woff"

instance MimeRender WOFF ByteString where
  mimeRender :: Proxy WOFF -> ByteString -> LByteString.ByteString
  mimeRender _ = LByteString.fromStrict

-- WOFF2

-- | @since 0.2.0.0
data WOFF2 deriving Typeable

-- | @fonts\/woff2@
instance Accept WOFF2 where
  contentType :: Proxy WOFF2 -> MediaType
  contentType _ = "font" // "woff2"

instance MimeRender WOFF2 ByteString where
  mimeRender :: Proxy WOFF2 -> ByteString -> LByteString.ByteString
  mimeRender _ = LByteString.fromStrict


-- | JSON file
data JSON deriving Typeable

-- | @application\/json@
instance Accept JSON where
  contentType :: Proxy JSON -> MediaType
  contentType _ = "application" // "json"

instance MimeRender JSON ByteString where
  mimeRender :: Proxy JSON -> ByteString -> LByteString.ByteString
  mimeRender _ = LByteString.fromStrict


-- | XML file
data XML deriving Typeable

-- | @application\/xml@
instance Accept XML where
  contentType :: Proxy XML -> MediaType
  contentType _ = "application" // "xml"

instance MimeRender XML ByteString where
  mimeRender :: Proxy XML -> ByteString -> LByteString.ByteString
  mimeRender _ = LByteString.fromStrict


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

-- | @application\/gexf@
instance Accept GEXF where
  contentType :: Proxy GEXF -> MediaType
  contentType _ = "application" // "gexf"

instance MimeRender GEXF ByteString where
  mimeRender :: Proxy GEXF -> ByteString -> LByteString.ByteString
  mimeRender _ = LByteString.fromStrict