{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings, MagicHash, CPP #-}
module WaiAppStatic.Storage.Embedded.TH(
    Etag
  , EmbeddableEntry(..)
  , mkSettings
) where

import Data.ByteString.Builder.Extra (byteStringInsert)
import Codec.Compression.GZip (compress)
import Data.ByteString.Unsafe (unsafePackAddressLen)
import Data.Either (lefts, rights)
import GHC.Exts (Int(..))
import Language.Haskell.TH
import Network.Mime (MimeType, defaultMimeLookup)
import System.IO.Unsafe (unsafeDupablePerformIO)
import WaiAppStatic.Types
import WaiAppStatic.Storage.Filesystem (defaultWebAppSettings)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
#if !MIN_VERSION_template_haskell(2, 8, 0)
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy.Char8 as BL8
#endif
import qualified Data.HashMap.Strict as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Network.Wai as W

-- | An Etag is used to return 304 Not Modified responses so the client does not need
--   to download resources a second time.  Usually the etag is built from a hash of
--   the content.  To disable Etags, you can pass the empty string.  This will cause the
--   content to be redownloaded on every request.
type Etag = T.Text

-- | Used at compile time to hold data about an entry to embed into the compiled executable.
data EmbeddableEntry = EmbeddableEntry {
    EmbeddableEntry -> Text
eLocation :: T.Text        -- ^ The location where this resource should be served from.  The
                               --   location can contain forward slashes (/) to simulate directories,
                               --   but must not end with a forward slash.
  , EmbeddableEntry -> MimeType
eMimeType :: MimeType      -- ^ The mime type.
  , EmbeddableEntry -> Either (Text, ByteString) ExpQ
eContent  :: Either (Etag, BL.ByteString) ExpQ
                    -- ^ The content itself.  The content can be given as a tag and bytestring,
                    --   in which case the content will be embedded directly into the execuatble.
                    --   Alternatively, the content can be given as a template haskell expression
                    --   returning @IO ('Etag', 'BL.ByteString')@ in which case this action will
                    --   be executed on every request to reload the content (this is useful
                    --   for a debugging mode).
}

-- | This structure is used at runtime to hold the entry.
data EmbeddedEntry = EmbeddedEntry {
    EmbeddedEntry -> Text
embLocation   :: !T.Text
  , EmbeddedEntry -> MimeType
embMime       :: !MimeType
  , EmbeddedEntry -> MimeType
embEtag       :: !B.ByteString
  , EmbeddedEntry -> Bool
embCompressed :: !Bool
  , EmbeddedEntry -> MimeType
embContent    :: !B.ByteString
}

-- | This structure is used at runtime to hold the reload entries.
data ReloadEntry = ReloadEntry {
    ReloadEntry -> Text
reloadLocation :: !T.Text
  , ReloadEntry -> MimeType
reloadMime     :: !MimeType
  , ReloadEntry -> IO (Text, ByteString)
reloadContent  :: IO (T.Text, BL.ByteString)
}

-- The use of unsafePackAddressLen is safe here because the length
-- is correct and we will only be reading from the bytestring, never
-- modifying it.
--
-- The only IO within unsafePackAddressLen is within newForeignPtr_ where
-- a new IORef is created as newIORef (NoFinalizers, []) to hold the finalizer
-- for the pointer.  Since the pointer for the content will never have a finalizer
-- added, we do not care if this finalizer IORef gets created more than once since
-- the IORef will always be holding (NoFinalizers, []).  Therefore
-- unsafeDupablePerformIO is safe.
bytestringE :: B.ByteString -> ExpQ
#if MIN_VERSION_template_haskell(2, 8, 0)
bytestringE :: MimeType -> ExpQ
bytestringE MimeType
b = [| unsafeDupablePerformIO (unsafePackAddressLen (I# $lenE) $ctE) |]
    where
        lenE :: ExpQ
lenE = Lit -> ExpQ
litE (Lit -> ExpQ) -> Lit -> ExpQ
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
intPrimL (Integer -> Lit) -> Integer -> Lit
forall a b. (a -> b) -> a -> b
$ Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ MimeType -> Int
B.length MimeType
b
        ctE :: ExpQ
ctE = Lit -> ExpQ
litE (Lit -> ExpQ) -> Lit -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Word8] -> Lit
stringPrimL ([Word8] -> Lit) -> [Word8] -> Lit
forall a b. (a -> b) -> a -> b
$ MimeType -> [Word8]
B.unpack MimeType
b
#else
bytestringE b =
    [| B8.pack $s |]
  where
    s = litE $ stringL $ B8.unpack b
#endif

bytestringLazyE :: BL.ByteString -> ExpQ
#if MIN_VERSION_template_haskell(2, 8, 0)
bytestringLazyE :: ByteString -> ExpQ
bytestringLazyE ByteString
b = [| unsafeDupablePerformIO (unsafePackAddressLen (I# $lenE) $ctE) |]
    where
        lenE :: ExpQ
lenE = Lit -> ExpQ
litE (Lit -> ExpQ) -> Lit -> ExpQ
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
intPrimL (Integer -> Lit) -> Integer -> Lit
forall a b. (a -> b) -> a -> b
$ Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Int64 -> Integer) -> Int64 -> Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BL.length ByteString
b
        ctE :: ExpQ
ctE = Lit -> ExpQ
litE (Lit -> ExpQ) -> Lit -> ExpQ
forall a b. (a -> b) -> a -> b
$ [Word8] -> Lit
stringPrimL ([Word8] -> Lit) -> [Word8] -> Lit
forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
BL.unpack ByteString
b
#else
bytestringLazyE b =
    [| B8.pack $s |]
  where
    s = litE $ stringL $ BL8.unpack b
#endif

-- | A template haskell expression which creates either an EmbeddedEntry or ReloadEntry.
mkEntry :: EmbeddableEntry -> ExpQ
mkEntry :: EmbeddableEntry -> ExpQ
mkEntry (EmbeddableEntry Text
loc MimeType
mime (Left (Text
etag, ByteString
ct))) =
        [| Left $ EmbeddedEntry (T.pack $locE)
                                $(bytestringE mime)
                                $(bytestringE $ T.encodeUtf8 etag)
                                (1 == I# $compressedE)
                                $(bytestringLazyE ct')
        |]
    where
        locE :: ExpQ
locE = Lit -> ExpQ
litE (Lit -> ExpQ) -> Lit -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
loc
        (Bool
compressed, ByteString
ct') = MimeType -> ByteString -> (Bool, ByteString)
tryCompress MimeType
mime ByteString
ct
        compressedE :: ExpQ
compressedE = Lit -> ExpQ
litE (Lit -> ExpQ) -> Lit -> ExpQ
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
intPrimL (Integer -> Lit) -> Integer -> Lit
forall a b. (a -> b) -> a -> b
$ if Bool
compressed then Integer
1 else Integer
0

mkEntry (EmbeddableEntry Text
loc MimeType
mime (Right ExpQ
expr)) =
        [| Right $ ReloadEntry (T.pack $locE)
                               $(bytestringE mime)
                               $expr
        |]
    where
        locE :: ExpQ
locE = Lit -> ExpQ
litE (Lit -> ExpQ) -> Lit -> ExpQ
forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL (String -> Lit) -> String -> Lit
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
loc

-- | Converts an embedded entry to a file
embeddedToFile :: EmbeddedEntry -> File
embeddedToFile :: EmbeddedEntry -> File
embeddedToFile EmbeddedEntry
entry = File :: Integer
-> (Status -> ResponseHeaders -> Response)
-> Piece
-> IO (Maybe MimeType)
-> Maybe EpochTime
-> File
File
    { fileGetSize :: Integer
fileGetSize = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Integer) -> Int -> Integer
forall a b. (a -> b) -> a -> b
$ MimeType -> Int
B.length (MimeType -> Int) -> MimeType -> Int
forall a b. (a -> b) -> a -> b
$ EmbeddedEntry -> MimeType
embContent EmbeddedEntry
entry
    , fileToResponse :: Status -> ResponseHeaders -> Response
fileToResponse = \Status
s ResponseHeaders
h ->
        let h' :: ResponseHeaders
h' = if EmbeddedEntry -> Bool
embCompressed EmbeddedEntry
entry
                    then ResponseHeaders
h ResponseHeaders -> ResponseHeaders -> ResponseHeaders
forall a. [a] -> [a] -> [a]
++ [(HeaderName
"Content-Encoding", MimeType
"gzip")]
                    else ResponseHeaders
h
         in Status -> ResponseHeaders -> Builder -> Response
W.responseBuilder Status
s ResponseHeaders
h' (Builder -> Response) -> Builder -> Response
forall a b. (a -> b) -> a -> b
$ MimeType -> Builder
byteStringInsert (MimeType -> Builder) -> MimeType -> Builder
forall a b. (a -> b) -> a -> b
$ EmbeddedEntry -> MimeType
embContent EmbeddedEntry
entry

    -- Usually the fileName should just be the filename not the entire path,
    -- but we need the whole path to make the lookup within lookupMime
    -- possible.  lookupMime is provided only with the File and from that
    -- we must find the mime type. Putting the path here is OK since
    -- within staticApp the fileName is used for directory listings which
    -- we have disabled.
    , fileName :: Piece
fileName = Text -> Piece
unsafeToPiece (Text -> Piece) -> Text -> Piece
forall a b. (a -> b) -> a -> b
$ EmbeddedEntry -> Text
embLocation EmbeddedEntry
entry
    , fileGetHash :: IO (Maybe MimeType)
fileGetHash = Maybe MimeType -> IO (Maybe MimeType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe MimeType -> IO (Maybe MimeType))
-> Maybe MimeType -> IO (Maybe MimeType)
forall a b. (a -> b) -> a -> b
$ if MimeType -> Bool
B.null (EmbeddedEntry -> MimeType
embEtag EmbeddedEntry
entry)
                                 then Maybe MimeType
forall a. Maybe a
Nothing
                                 else MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just (MimeType -> Maybe MimeType) -> MimeType -> Maybe MimeType
forall a b. (a -> b) -> a -> b
$ EmbeddedEntry -> MimeType
embEtag EmbeddedEntry
entry
    , fileGetModified :: Maybe EpochTime
fileGetModified = Maybe EpochTime
forall a. Maybe a
Nothing
    }

-- | Converts a reload entry to a file
reloadToFile :: ReloadEntry -> IO File
reloadToFile :: ReloadEntry -> IO File
reloadToFile ReloadEntry
entry = do
    (Text
etag, ByteString
ct) <- ReloadEntry -> IO (Text, ByteString)
reloadContent ReloadEntry
entry
    let etag' :: MimeType
etag' = Text -> MimeType
T.encodeUtf8 Text
etag
    File -> IO File
forall (m :: * -> *) a. Monad m => a -> m a
return (File -> IO File) -> File -> IO File
forall a b. (a -> b) -> a -> b
$ File :: Integer
-> (Status -> ResponseHeaders -> Response)
-> Piece
-> IO (Maybe MimeType)
-> Maybe EpochTime
-> File
File
        { fileGetSize :: Integer
fileGetSize = Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Integer) -> Int64 -> Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BL.length ByteString
ct
        , fileToResponse :: Status -> ResponseHeaders -> Response
fileToResponse = \Status
s ResponseHeaders
h -> Status -> ResponseHeaders -> ByteString -> Response
W.responseLBS Status
s ResponseHeaders
h ByteString
ct
        -- Similar to above the entire path needs to be in the fileName.
        , fileName :: Piece
fileName = Text -> Piece
unsafeToPiece (Text -> Piece) -> Text -> Piece
forall a b. (a -> b) -> a -> b
$ ReloadEntry -> Text
reloadLocation ReloadEntry
entry
        , fileGetHash :: IO (Maybe MimeType)
fileGetHash = Maybe MimeType -> IO (Maybe MimeType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe MimeType -> IO (Maybe MimeType))
-> Maybe MimeType -> IO (Maybe MimeType)
forall a b. (a -> b) -> a -> b
$ if Text -> Bool
T.null Text
etag then Maybe MimeType
forall a. Maybe a
Nothing else MimeType -> Maybe MimeType
forall a. a -> Maybe a
Just MimeType
etag'
        , fileGetModified :: Maybe EpochTime
fileGetModified = Maybe EpochTime
forall a. Maybe a
Nothing
        }


-- | Build a static settings based on a filemap.
filemapToSettings :: M.HashMap T.Text (MimeType, IO File) -> StaticSettings
filemapToSettings :: HashMap Text (MimeType, IO File) -> StaticSettings
filemapToSettings HashMap Text (MimeType, IO File)
mfiles = (String -> StaticSettings
defaultWebAppSettings String
"")
                              { ssLookupFile :: Pieces -> IO LookupResult
ssLookupFile = Pieces -> IO LookupResult
lookupFile
                              , ssGetMimeType :: File -> IO MimeType
ssGetMimeType = File -> IO MimeType
forall (m :: * -> *). Monad m => File -> m MimeType
lookupMime
                              }
    where
        piecesToFile :: Pieces -> Text
piecesToFile Pieces
p = Text -> [Text] -> Text
T.intercalate Text
"/" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Piece -> Text) -> Pieces -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Piece -> Text
fromPiece Pieces
p

        lookupFile :: Pieces -> IO LookupResult
lookupFile [] = LookupResult -> IO LookupResult
forall (m :: * -> *) a. Monad m => a -> m a
return LookupResult
LRNotFound
        lookupFile Pieces
p =
            case Text
-> HashMap Text (MimeType, IO File) -> Maybe (MimeType, IO File)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup (Pieces -> Text
piecesToFile Pieces
p) HashMap Text (MimeType, IO File)
mfiles of
                Maybe (MimeType, IO File)
Nothing -> LookupResult -> IO LookupResult
forall (m :: * -> *) a. Monad m => a -> m a
return LookupResult
LRNotFound
                Just (MimeType
_,IO File
act) -> File -> LookupResult
LRFile (File -> LookupResult) -> IO File -> IO LookupResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO File
act

        lookupMime :: File -> m MimeType
lookupMime (File { fileName :: File -> Piece
fileName = Piece
p }) =
            case Text
-> HashMap Text (MimeType, IO File) -> Maybe (MimeType, IO File)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup (Piece -> Text
fromPiece Piece
p) HashMap Text (MimeType, IO File)
mfiles of
                Just (MimeType
mime,IO File
_) -> MimeType -> m MimeType
forall (m :: * -> *) a. Monad m => a -> m a
return MimeType
mime
                Maybe (MimeType, IO File)
Nothing -> MimeType -> m MimeType
forall (m :: * -> *) a. Monad m => a -> m a
return (MimeType -> m MimeType) -> MimeType -> m MimeType
forall a b. (a -> b) -> a -> b
$ Text -> MimeType
defaultMimeLookup (Text -> MimeType) -> Text -> MimeType
forall a b. (a -> b) -> a -> b
$ Piece -> Text
fromPiece Piece
p

-- | Create a 'StaticSettings' from a list of entries.  Executed at run time.
entriesToSt :: [Either EmbeddedEntry ReloadEntry] -> StaticSettings
entriesToSt :: [Either EmbeddedEntry ReloadEntry] -> StaticSettings
entriesToSt [Either EmbeddedEntry ReloadEntry]
entries = HashMap Text (MimeType, IO File)
hmap HashMap Text (MimeType, IO File)
-> StaticSettings -> StaticSettings
`seq` HashMap Text (MimeType, IO File) -> StaticSettings
filemapToSettings HashMap Text (MimeType, IO File)
hmap
    where
        embFiles :: [(Text, (MimeType, IO File))]
embFiles = [ (EmbeddedEntry -> Text
embLocation EmbeddedEntry
e, (EmbeddedEntry -> MimeType
embMime EmbeddedEntry
e, File -> IO File
forall (m :: * -> *) a. Monad m => a -> m a
return (File -> IO File) -> File -> IO File
forall a b. (a -> b) -> a -> b
$ EmbeddedEntry -> File
embeddedToFile EmbeddedEntry
e)) | EmbeddedEntry
e <- [Either EmbeddedEntry ReloadEntry] -> [EmbeddedEntry]
forall a b. [Either a b] -> [a]
lefts [Either EmbeddedEntry ReloadEntry]
entries]
        reloadFiles :: [(Text, (MimeType, IO File))]
reloadFiles = [ (ReloadEntry -> Text
reloadLocation ReloadEntry
r, (ReloadEntry -> MimeType
reloadMime ReloadEntry
r, ReloadEntry -> IO File
reloadToFile ReloadEntry
r)) | ReloadEntry
r <- [Either EmbeddedEntry ReloadEntry] -> [ReloadEntry]
forall a b. [Either a b] -> [b]
rights [Either EmbeddedEntry ReloadEntry]
entries]
        hmap :: HashMap Text (MimeType, IO File)
hmap = [(Text, (MimeType, IO File))] -> HashMap Text (MimeType, IO File)
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList ([(Text, (MimeType, IO File))] -> HashMap Text (MimeType, IO File))
-> [(Text, (MimeType, IO File))]
-> HashMap Text (MimeType, IO File)
forall a b. (a -> b) -> a -> b
$ [(Text, (MimeType, IO File))]
embFiles [(Text, (MimeType, IO File))]
-> [(Text, (MimeType, IO File))] -> [(Text, (MimeType, IO File))]
forall a. [a] -> [a] -> [a]
++ [(Text, (MimeType, IO File))]
reloadFiles

-- | Create a 'StaticSettings' at compile time that embeds resources directly into the compiled
--   executable.  The embedded resources are precompressed (depending on mime type)
--   so that during runtime the resource can be served very quickly.
--
--   Because of GHC Template Haskell stage restrictions, you must define
--   the entries in a different module than where you create the 'StaticSettings'.
--   For example,
--
-- > {-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
-- > module A (mkEmbedded) where
-- > 
-- > import WaiAppStatic.Storage.Embedded
-- > import Crypto.Hash.MD5 (hashlazy)
-- > import qualified Data.ByteString.Lazy as BL
-- > import qualified Data.ByteString.Base64 as B64
-- > import qualified Data.Text as T
-- > import qualified Data.Text.Encoding as T
-- > 
-- > hash :: BL.ByteString -> T.Text
-- > hash = T.take 8 . T.decodeUtf8 . B64.encode . hashlazy
-- > 
-- > mkEmbedded :: IO [EmbeddableEntry]
-- > mkEmbedded = do
-- >     file <- BL.readFile "test.css"
-- >     let emb = EmbeddableEntry {
-- >                   eLocation = "somedir/test.css"
-- >                 , eMimeType = "text/css"
-- >                 , eContent  = Left (hash file, file)
-- >                 }
-- > 
-- >     let reload = EmbeddableEntry {
-- >                      eLocation = "anotherdir/test2.txt"
-- >                    , eMimeType = "text/plain"
-- >                    , eContent  = Right [| BL.readFile "test2.txt" >>= \c -> return (hash c, c) |]
-- >                    }
-- > 
-- >     return [emb, reload]
--
-- The above @mkEmbedded@ will be executed at compile time.  It loads the contents of test.css and
-- computes the hash of test.css for the etag.  The content will be available at the URL somedir/test.css.
-- Internally, 'embedApp' below will attempt to compress the content at compile time. The compression will
-- only happen if the compressed content is shorter than the original and the mime type is either text or
-- javascript.  If the content is compressed, at runtime the precomputed compressed content will be served
-- with the appropriate HTTP header. If 'embedApp' decides not to compress the content, it will be
-- served directly.
--
-- Secondly, @mkEmbedded@ creates a reloadable entry.  This will be available at the URL anotherdir/test2.txt.
-- Whenver a request comes in for anotherdir/test2.txt, the action inside the quasiquote in eContent will
-- be executed.  This will re-read the test2.txt file and recompute its hash.
--
-- Finally, here is a module which uses the above action to create a 'W.Application'.
--
-- > {-# LANGUAGE TemplateHaskell #-}
-- > module B where
-- > 
-- > import A
-- > import Network.Wai (Application)
-- > import Network.Wai.Application.Static (staticApp)
-- > import WaiAppStatic.Storage.Embedded
-- > import Network.Wai.Handler.Warp (run)
-- > 
-- > myApp :: Application
-- > myApp = staticApp $(mkSettings mkEmbedded)
-- > 
-- > main :: IO ()
-- > main = run 3000 myApp
mkSettings :: IO [EmbeddableEntry] -> ExpQ
mkSettings :: IO [EmbeddableEntry] -> ExpQ
mkSettings IO [EmbeddableEntry]
action = do
    [EmbeddableEntry]
entries <- IO [EmbeddableEntry] -> Q [EmbeddableEntry]
forall a. IO a -> Q a
runIO IO [EmbeddableEntry]
action
    [| entriesToSt $(listE $ map mkEntry entries) |]

shouldCompress :: MimeType -> Bool
shouldCompress :: MimeType -> Bool
shouldCompress MimeType
m = MimeType
"text/" MimeType -> MimeType -> Bool
`B.isPrefixOf` MimeType
m Bool -> Bool -> Bool
|| MimeType
m MimeType -> [MimeType] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [MimeType]
extra
    where
        extra :: [MimeType]
extra = [ MimeType
"application/json"
                , MimeType
"application/javascript"
                , MimeType
"application/ecmascript"
                ]

-- | Only compress if the mime type is correct and the compressed text is actually shorter.
tryCompress :: MimeType -> BL.ByteString -> (Bool, BL.ByteString)
tryCompress :: MimeType -> ByteString -> (Bool, ByteString)
tryCompress MimeType
mime ByteString
ct
        | MimeType -> Bool
shouldCompress MimeType
mime = (Bool
c, ByteString
ct')
        | Bool
otherwise = (Bool
False, ByteString
ct)
    where
        compressed :: ByteString
compressed = ByteString -> ByteString
compress ByteString
ct
        c :: Bool
c = ByteString -> Int64
BL.length ByteString
compressed Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< ByteString -> Int64
BL.length ByteString
ct
        ct' :: ByteString
ct' = if Bool
c then ByteString
compressed else ByteString
ct