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

    import Blaze.ByteString.Builder.ByteString (insertByteString)
    import Codec.Compression.GZip (compress)
    import Control.Applicative
    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 {
        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.
      , eMimeType :: MimeType      -- ^ The mime type.
      , 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 {
        embLocation   :: !T.Text
      , embMime       :: !MimeType
      , embEtag       :: !B.ByteString
      , embCompressed :: !Bool
      , embContent    :: !B.ByteString
    }

    -- | This structure is used at runtime to hold the reload entries.
    data ReloadEntry = ReloadEntry {
        reloadLocation :: !T.Text
      , reloadMime     :: !MimeType
      , 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 b = [| unsafeDupablePerformIO (unsafePackAddressLen (I# $lenE) $ctE) |]
        where
            lenE = litE $ intPrimL $ toInteger $ B.length b
            ctE = litE $ stringPrimL $ B.unpack 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 b = [| unsafeDupablePerformIO (unsafePackAddressLen (I# $lenE) $ctE) |]
        where
            lenE = litE $ intPrimL $ toInteger $ BL.length b
            ctE = litE $ stringPrimL $ BL.unpack 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 loc mime (Left (etag, ct))) =
            [| Left $ EmbeddedEntry (T.pack $locE)
                                    $(bytestringE mime)
                                    $(bytestringE $ T.encodeUtf8 etag)
                                    (1 == I# $compressedE)
                                    $(bytestringLazyE ct')
            |]
        where
            locE = litE $ stringL $ T.unpack loc
            (compressed, ct') = tryCompress mime ct
            compressedE = litE $ intPrimL $ if compressed then 1 else 0

    mkEntry (EmbeddableEntry loc mime (Right expr)) =
            [| Right $ ReloadEntry (T.pack $locE)
                                   $(bytestringE mime)
                                   $expr
            |]
        where
            locE = litE $ stringL $ T.unpack loc

    -- | Converts an embedded entry to a file
    embeddedToFile :: EmbeddedEntry -> File
    embeddedToFile entry = File
        { fileGetSize = fromIntegral $ B.length $ embContent entry
        , fileToResponse = \s h ->
            let h' = if embCompressed entry
                        then h ++ [("Content-Encoding", "gzip")]
                        else h
             in W.responseBuilder s h' $ insertByteString $ embContent 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 = unsafeToPiece $ embLocation entry
        , fileGetHash = return $ if B.null (embEtag entry)
                                     then Nothing
                                     else Just $ embEtag entry
        , fileGetModified = Nothing
        }

    -- | Converts a reload entry to a file
    reloadToFile :: ReloadEntry -> IO File
    reloadToFile entry = do
        (etag, ct) <- reloadContent entry
        let etag' = T.encodeUtf8 etag
        return $ File
            { fileGetSize = fromIntegral $ BL.length ct
            , fileToResponse = \s h -> W.responseLBS s h ct
            -- Similar to above the entire path needs to be in the fileName.
            , fileName = unsafeToPiece $ reloadLocation entry
            , fileGetHash = return $ if T.null etag then Nothing else Just etag'
            , fileGetModified = Nothing
            }

    -- | Build a static settings based on a filemap.
    filemapToSettings :: M.HashMap T.Text (MimeType, IO File) -> StaticSettings
    filemapToSettings mfiles = (defaultWebAppSettings "")
                                  { ssLookupFile = lookupFile
                                  , ssGetMimeType = lookupMime
                                  }
        where
            piecesToFile p = T.intercalate "/" $ map fromPiece p

            lookupFile [] = return LRNotFound
            lookupFile p =
                case M.lookup (piecesToFile p) mfiles of
                    Nothing -> return LRNotFound
                    Just (_,act) -> LRFile <$> act

            lookupMime (File { fileName = p }) =
                case M.lookup (fromPiece p) mfiles of
                    Just (mime,_) -> return mime
                    Nothing -> return $ defaultMimeLookup $ fromPiece p

    -- | Create a 'StaticSettings' from a list of entries.  Executed at run time.
    entriesToSt :: [Either EmbeddedEntry ReloadEntry] -> StaticSettings
    entriesToSt entries = hmap `seq` filemapToSettings hmap
        where
            embFiles = [ (embLocation e, (embMime e, return $ embeddedToFile e)) | e <- lefts entries]
            reloadFiles = [ (reloadLocation r, (reloadMime r, reloadToFile r)) | r <- rights entries]
            hmap = M.fromList $ embFiles ++ 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 action = do
        entries <- runIO action
        [| entriesToSt $(listE $ map mkEntry entries) |]

    shouldCompress :: MimeType -> Bool
    shouldCompress m = "text/" `B.isPrefixOf` m || m `elem` extra
        where
            extra = [ "application/json"
                    , "application/javascript"
                    , "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 mime ct
            | shouldCompress mime = (c, ct')
            | otherwise = (False, ct)
        where
            compressed = compress ct
            c = BL.length compressed < BL.length ct
            ct' = if c then compressed else ct