{-# 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 -> ByteString
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 -> ByteString
embMime       :: !MimeType
  , EmbeddedEntry -> ByteString
embEtag       :: !B.ByteString
  , EmbeddedEntry -> Bool
embCompressed :: !Bool
  , EmbeddedEntry -> ByteString
embContent    :: !B.ByteString
}

-- | This structure is used at runtime to hold the reload entries.
data ReloadEntry = ReloadEntry {
    ReloadEntry -> Text
reloadLocation :: !T.Text
  , ReloadEntry -> ByteString
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 :: ByteString -> ExpQ
bytestringE ByteString
b = [| unsafeDupablePerformIO (unsafePackAddressLen (I# $lenE) $ctE) |]
    where
        lenE :: ExpQ
lenE = forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ Integer -> Lit
intPrimL forall a b. (a -> b) -> a -> b
$ forall a. Integral a => a -> Integer
toInteger forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
b
        ctE :: ExpQ
ctE = forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ [Word8] -> Lit
stringPrimL forall a b. (a -> b) -> a -> b
$ ByteString -> [Word8]
B.unpack ByteString
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 = forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ Integer -> Lit
intPrimL forall a b. (a -> b) -> a -> b
$ forall a. Integral a => a -> Integer
toInteger forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BL.length ByteString
b
        ctE :: ExpQ
ctE = forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ [Word8] -> Lit
stringPrimL 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 ByteString
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 = forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
loc
        (Bool
compressed, ByteString
ct') = ByteString -> ByteString -> (Bool, ByteString)
tryCompress ByteString
mime ByteString
ct
        compressedE :: ExpQ
compressedE = forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ Integer -> Lit
intPrimL forall a b. (a -> b) -> a -> b
$ if Bool
compressed then Integer
1 else Integer
0

mkEntry (EmbeddableEntry Text
loc ByteString
mime (Right ExpQ
expr)) =
        [| Right $ ReloadEntry (T.pack $locE)
                               $(bytestringE mime)
                               $expr
        |]
    where
        locE :: ExpQ
locE = forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall a b. (a -> b) -> a -> b
$ String -> Lit
stringL 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
    { fileGetSize :: Integer
fileGetSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length forall a b. (a -> b) -> a -> b
$ EmbeddedEntry -> ByteString
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 forall a. [a] -> [a] -> [a]
++ [(HeaderName
"Content-Encoding", ByteString
"gzip")]
                    else ResponseHeaders
h
         in Status -> ResponseHeaders -> Builder -> Response
W.responseBuilder Status
s ResponseHeaders
h' forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteStringInsert forall a b. (a -> b) -> a -> b
$ EmbeddedEntry -> ByteString
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 forall a b. (a -> b) -> a -> b
$ EmbeddedEntry -> Text
embLocation EmbeddedEntry
entry
    , fileGetHash :: IO (Maybe ByteString)
fileGetHash = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if ByteString -> Bool
B.null (EmbeddedEntry -> ByteString
embEtag EmbeddedEntry
entry)
                                 then forall a. Maybe a
Nothing
                                 else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ EmbeddedEntry -> ByteString
embEtag EmbeddedEntry
entry
    , fileGetModified :: Maybe EpochTime
fileGetModified = 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' :: ByteString
etag' = Text -> ByteString
T.encodeUtf8 Text
etag
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ File
        { fileGetSize :: Integer
fileGetSize = forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 forall a b. (a -> b) -> a -> b
$ ReloadEntry -> Text
reloadLocation ReloadEntry
entry
        , fileGetHash :: IO (Maybe ByteString)
fileGetHash = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Text -> Bool
T.null Text
etag then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just ByteString
etag'
        , fileGetModified :: Maybe EpochTime
fileGetModified = 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 (ByteString, IO File) -> StaticSettings
filemapToSettings HashMap Text (ByteString, IO File)
mfiles = (String -> StaticSettings
defaultWebAppSettings String
"")
                              { ssLookupFile :: Pieces -> IO LookupResult
ssLookupFile = Pieces -> IO LookupResult
lookupFile
                              , ssGetMimeType :: File -> IO ByteString
ssGetMimeType = forall {m :: * -> *}. Monad m => File -> m ByteString
lookupMime
                              }
    where
        piecesToFile :: Pieces -> Text
piecesToFile Pieces
p = Text -> [Text] -> Text
T.intercalate Text
"/" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Piece -> Text
fromPiece Pieces
p

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

        lookupMime :: File -> m ByteString
lookupMime (File { fileName :: File -> Piece
fileName = Piece
p }) =
            case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
M.lookup (Piece -> Text
fromPiece Piece
p) HashMap Text (ByteString, IO File)
mfiles of
                Just (ByteString
mime,IO File
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
mime
                Maybe (ByteString, IO File)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Text -> ByteString
defaultMimeLookup 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 (ByteString, IO File)
hmap seq :: forall a b. a -> b -> b
`seq` HashMap Text (ByteString, IO File) -> StaticSettings
filemapToSettings HashMap Text (ByteString, IO File)
hmap
    where
        embFiles :: [(Text, (ByteString, IO File))]
embFiles = [ (EmbeddedEntry -> Text
embLocation EmbeddedEntry
e, (EmbeddedEntry -> ByteString
embMime EmbeddedEntry
e, forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ EmbeddedEntry -> File
embeddedToFile EmbeddedEntry
e)) | EmbeddedEntry
e <- forall a b. [Either a b] -> [a]
lefts [Either EmbeddedEntry ReloadEntry]
entries]
        reloadFiles :: [(Text, (ByteString, IO File))]
reloadFiles = [ (ReloadEntry -> Text
reloadLocation ReloadEntry
r, (ReloadEntry -> ByteString
reloadMime ReloadEntry
r, ReloadEntry -> IO File
reloadToFile ReloadEntry
r)) | ReloadEntry
r <- forall a b. [Either a b] -> [b]
rights [Either EmbeddedEntry ReloadEntry]
entries]
        hmap :: HashMap Text (ByteString, IO File)
hmap = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList forall a b. (a -> b) -> a -> b
$ [(Text, (ByteString, IO File))]
embFiles forall a. [a] -> [a] -> [a]
++ [(Text, (ByteString, 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 <- forall a. IO a -> Q a
runIO IO [EmbeddableEntry]
action
    [| entriesToSt $(listE $ map mkEntry entries) |]

shouldCompress :: MimeType -> Bool
shouldCompress :: ByteString -> Bool
shouldCompress ByteString
m = ByteString
"text/" ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
m Bool -> Bool -> Bool
|| ByteString
m forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString]
extra
    where
        extra :: [ByteString]
extra = [ ByteString
"application/json"
                , ByteString
"application/javascript"
                , ByteString
"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 :: ByteString -> ByteString -> (Bool, ByteString)
tryCompress ByteString
mime ByteString
ct
        | ByteString -> Bool
shouldCompress ByteString
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 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