{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
---------------------------------------------------------
--
-- | Serve static files from a Yesod app.
--
-- This is great for developing your application, but also for a
-- dead-simple deployment.  Caching headers are automatically
-- taken care of.
--
-- If you are running a proxy server (like Apache or Nginx),
-- you may want to have that server do the static serving instead.
--
-- In fact, in an ideal setup you'll serve your static files from
-- a separate domain name to save time on transmitting
-- cookies. In that case, you may wish to use 'urlRenderOverride'
-- to redirect requests to this subsite to a separate domain
-- name.
--
-- Note that this module's static subsite ignores all files and
-- directories that are hidden by Unix conventions (i.e. start
-- with a dot, such as @\".ssh\"@) and the directory "tmp" on the
-- root of the directory with static files.
module Yesod.Static
    ( -- * Subsite
      Static (..)
    , Route (..)
    , StaticRoute
      -- * Smart constructor
    , static
    , staticDevel
    , embed
      -- * Template Haskell helpers
    , staticFiles
    , staticFilesList
    , publicFiles
      -- * Hashing
    , base64md5
#ifdef TEST_EXPORT
    , getFileListPieces
#endif
    ) where

import Prelude hiding (FilePath)
import qualified Prelude
import System.Directory
import Control.Arrow (second)
import Control.Monad
import Data.FileEmbed (embedDir)

import Yesod.Core hiding (lift)

import Data.List (intercalate)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax

import Crypto.Conduit (hashFile, sinkHash)
import Crypto.Hash.MD5 (MD5)
import Control.Monad.Trans.State
import Control.Monad.IO.Class (liftIO)

import qualified Data.ByteString.Base64
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.Serialize
import Data.Text (Text, pack)
import qualified Data.Text as T
import qualified Data.Set as S
import qualified Data.Map as M
import Data.IORef (readIORef, newIORef, writeIORef)
import Network.Wai (pathInfo)
import Data.Char (isLower, isDigit)
import Data.List (foldl', inits, tails)
import qualified Data.ByteString as S
import System.PosixCompat.Files (getFileStatus, modificationTime)
import System.Posix.Types (EpochTime)
import Data.Conduit (($$))
import Data.Conduit.List (sourceList)
import Data.Functor.Identity (runIdentity)
import qualified Filesystem.Path.CurrentOS as F

import Network.Wai.Application.Static
    ( StaticSettings (..)
    , staticApp
    , webAppSettingsWithLookup
    , embeddedSettings
    )
import WaiAppStatic.Storage.Filesystem (ETagLookup)

-- | Type used for the subsite with static contents.
newtype Static = Static StaticSettings

type StaticRoute = Route Static

-- | Produce a default value of 'Static' for a given file
-- folder.
--
-- Does not have index files or directory listings.  The static
-- files' contents /must not/ change, however new files can be
-- added.
static :: Prelude.FilePath -> IO Static
static dir = do
    hashLookup <- cachedETagLookup dir
    return $ Static $ webAppSettingsWithLookup (F.decodeString dir) hashLookup

-- | Same as 'static', but does not assumes that the files do not
-- change and checks their modification time whenever a request
-- is made.
staticDevel :: Prelude.FilePath -> IO Static
staticDevel dir = do
    hashLookup <- cachedETagLookupDevel dir
    return $ Static $ webAppSettingsWithLookup (F.decodeString dir) hashLookup

-- | Produce a 'Static' based on embedding all of the static
-- files' contents in the executable at compile time.
-- Nota Bene: if you replace the scaffolded 'static' call in Settings/StaticFiles.hs
-- you will need to change the scaffolded addStaticContent.  Otherwise, some of your
-- assets will be 404'ed.  This is because by default yesod will generate compile those
-- assets to @static/tmp@ which for 'static' is fine since they are served out of the
-- directory itself.  With embedded static, that will not work.
-- You can easily change @addStaticContent@ to @\_ _ _ -> return Nothing@ as a workaround.
-- This will cause yesod to embed those assets into the generated HTML file itself.
embed :: Prelude.FilePath -> Q Exp
embed fp = [|Static (embeddedSettings $(embedDir fp))|]

instance RenderRoute Static where
    -- | A route on the static subsite (see also 'staticFiles').
    --
    -- You may use this constructor directly to manually link to a
    -- static file.  The first argument is the sub-path to the file
    -- being served whereas the second argument is the key-value
    -- pairs in the query string.  For example,
    --
    -- > StaticRoute $ StaticR [\"thumb001.jpg\"] [(\"foo\", \"5\"), (\"bar\", \"choc\")]
    --
    -- would generate a url such as
    -- @http://www.example.com/static/thumb001.jpg?foo=5&bar=choc@
    -- The StaticRoute constructor can be used when the URL cannot be
    -- statically generated at compile-time (e.g. when generating
    -- image galleries).
    data Route Static = StaticRoute [Text] [(Text, Text)]
        deriving (Eq, Show, Read)
    renderRoute (StaticRoute x y) = (x, y)

instance Yesod master => YesodDispatch Static master where
    yesodDispatch _ _ (Static set) _ _ _ _ textPieces  _ req =
        staticApp set req { pathInfo = textPieces }

notHidden :: Prelude.FilePath -> Bool
notHidden "tmp" = False
notHidden s =
    case s of
        '.':_ -> False
        _ -> True

getFileListPieces :: Prelude.FilePath -> IO [[String]]
getFileListPieces = flip evalStateT M.empty . flip go id
  where
    go :: String
       -> ([String] -> [String])
       -> StateT (M.Map String String) IO [[String]]
    go fp front = do
        allContents <- liftIO $ filter notHidden `fmap` getDirectoryContents fp
        let fullPath :: String -> String
            fullPath f = fp ++ '/' : f
        files <- liftIO $ filterM (doesFileExist . fullPath) allContents
        let files' = map (front . return) files
        files'' <- mapM dedupe files'
        dirs <- liftIO $ filterM (doesDirectoryExist . fullPath) allContents
        dirs' <- mapM (\f -> go (fullPath f) (front . (:) f)) dirs
        return $ concat $ files'' : dirs'

    -- Reuse data buffers for identical strings
    dedupe :: [String] -> StateT (M.Map String String) IO [String]
    dedupe = mapM dedupe'

    dedupe' :: String -> StateT (M.Map String String) IO String
    dedupe' s = do
        m <- get
        case M.lookup s m of
            Just s' -> return s'
            Nothing -> do
                put $ M.insert s s m
                return s

-- | Template Haskell function that automatically creates routes
-- for all of your static files.
--
-- For example, if you used
--
-- > staticFiles "static/"
--
-- and you had files @\"static\/style.css\"@ and
-- @\"static\/js\/script.js\"@, then the following top-level
-- definitions would be created:
--
-- > style_css    = StaticRoute ["style.css"]    []
-- > js_script_js = StaticRoute ["js/script.js"] []
--
-- Note that dots (@.@), dashes (@-@) and slashes (@\/@) are
-- replaced by underscores (@\_@) to create valid Haskell
-- identifiers.
staticFiles :: Prelude.FilePath -> Q [Dec]
staticFiles dir = mkStaticFiles dir

-- | Same as 'staticFiles', but takes an explicit list of files
-- to create identifiers for. The files path given are relative
-- to the static folder. For example, to create routes for the
-- files @\"static\/js\/jquery.js\"@ and
-- @\"static\/css\/normalize.css\"@, you would use:
--
-- > staticFilesList \"static\" [\"js\/jquery.js\", \"css\/normalize.css\"]
--
-- This can be useful when you have a very large number of static
-- files, but only need to refer to a few of them from Haskell.
staticFilesList :: Prelude.FilePath -> [Prelude.FilePath] -> Q [Dec]
staticFilesList dir fs =
    mkStaticFilesList dir (map split fs) "StaticRoute" True
  where
    split :: Prelude.FilePath -> [String]
    split [] = []
    split x =
        let (a, b) = break (== '/') x
         in a : split (drop 1 b)

-- | Same as 'staticFiles', but doesn't append an ETag to the
-- query string.
--
-- Using 'publicFiles' will speed up the compilation, since there
-- won't be any need for hashing files during compile-time.
-- However, since the ETag ceases to be part of the URL, the
-- 'Static' subsite won't be able to set the expire date too far
-- on the future.  Browsers still will be able to cache the
-- contents, however they'll need send a request to the server to
-- see if their copy is up-to-date.
publicFiles :: Prelude.FilePath -> Q [Dec]
publicFiles dir = mkStaticFiles' dir "StaticRoute" False


mkHashMap :: Prelude.FilePath -> IO (M.Map F.FilePath S8.ByteString)
mkHashMap dir = do
    fs <- getFileListPieces dir
    hashAlist fs >>= return . M.fromList
  where
    hashAlist :: [[String]] -> IO [(F.FilePath, S8.ByteString)]
    hashAlist fs = mapM hashPair fs
      where
        hashPair :: [String] -> IO (F.FilePath, S8.ByteString)
        hashPair pieces = do let file = pathFromRawPieces dir pieces
                             h <- base64md5File file
                             return (F.decodeString file, S8.pack h)

pathFromRawPieces :: Prelude.FilePath -> [String] -> Prelude.FilePath
pathFromRawPieces =
    foldl' append
  where
    append a b = a ++ '/' : b

cachedETagLookupDevel :: Prelude.FilePath -> IO ETagLookup
cachedETagLookupDevel dir = do
    etags <- mkHashMap dir
    mtimeVar <- newIORef (M.empty :: M.Map F.FilePath EpochTime)
    return $ \f ->
      case M.lookup f etags of
        Nothing -> return Nothing
        Just checksum -> do
          fs <- getFileStatus $ F.encodeString f
          let newt = modificationTime fs
          mtimes <- readIORef mtimeVar
          oldt <- case M.lookup f mtimes of
            Nothing -> writeIORef mtimeVar (M.insert f newt mtimes) >> return newt
            Just oldt -> return oldt
          return $ if newt /= oldt then Nothing else Just checksum


cachedETagLookup :: Prelude.FilePath -> IO ETagLookup
cachedETagLookup dir = do
    etags <- mkHashMap dir
    return $ (\f -> return $ M.lookup f etags)

mkStaticFiles :: Prelude.FilePath -> Q [Dec]
mkStaticFiles fp = mkStaticFiles' fp "StaticRoute" True

mkStaticFiles' :: Prelude.FilePath -- ^ static directory
               -> String   -- ^ route constructor "StaticRoute"
               -> Bool     -- ^ append checksum query parameter
               -> Q [Dec]
mkStaticFiles' fp routeConName makeHash = do
    fs <- qRunIO $ getFileListPieces fp
    mkStaticFilesList fp fs routeConName makeHash

mkStaticFilesList
    :: Prelude.FilePath -- ^ static directory
    -> [[String]] -- ^ list of files to create identifiers for
    -> String   -- ^ route constructor "StaticRoute"
    -> Bool     -- ^ append checksum query parameter
    -> Q [Dec]
mkStaticFilesList fp fs routeConName makeHash = do
    let (squashedFinal, squashMap) = squashStrings ("etag" : concat fs)
    (squashedName, squashedDecl) <- mkSquashedStringsDecl squashedFinal
    let refName = mkSquashedReference squashedName squashMap
    routes <- concat `fmap` mapM (mkRoute refName) fs
    return (squashedDecl ++ routes)
  where
    replace' c
        | 'A' <= c && c <= 'Z' = c
        | 'a' <= c && c <= 'z' = c
        | '0' <= c && c <= '9' = c
        | otherwise = '_'
    mkSquashedStringsDecl squashedFinal = do
      name  <- newName "squashedStrings"
      pack' <- [|pack|]
      squashedFinal' <- lift squashedFinal
      let decl = [ SigD name (ConT ''Text)
                 , FunD name
                     [ Clause [] (NormalB $ pack' `AppE` squashedFinal') []
                     ]
                 ]
      return (name, decl)
    mkSquashedReference squashedName squashMap = \str ->
      case M.lookup str squashMap of
        Nothing         -> [|pack $(lift str)|]
        Just (pos, len) -> [|T.take len (T.drop pos $(return (VarE squashedName)))|]
    mkRoute refName f = do
        let name' = intercalate "_" $ map (map replace') f
            routeName = mkName $
                case () of
                    ()
                        | null name' -> error "null-named file"
                        | isDigit (head name') -> '_' : name'
                        | isLower (head name') -> name'
                        | otherwise -> '_' : name'
        f' <- ListE `fmap` mapM refName f
        let route = mkName routeConName
        qs <- if makeHash
                    then do hash <- qRunIO $ base64md5File $ pathFromRawPieces fp f
                            [|[($(refName "etag"), $(refName hash))]|]
                    else return $ ListE []
        return
            [ SigD routeName $ ConT route
            , FunD routeName
                [ Clause [] (NormalB $ (ConE route) `AppE` f' `AppE` qs) []
                ]
            ]


-- | Convert a list of 'String's into a single 'String' and a
-- 'M.Map' of the original 'String's into an offset and a length on
-- the resulting single 'String'.
squashStrings :: [String] -> (String, M.Map String (Int, Int))
squashStrings = second M.fromAscList . go 0 "" . S.toAscList . S.fromList
  where
    -- Length of the string of maximal length of characters from
    -- the end of the @lastString@ that are the same.  Uses a
    -- naive algorithm.
    calculateOverlap lastString newString =
      let -- Make both strings of equal length.
          len = length lastString `min` length newString
          lastString' = reverse $ take len $ reverse lastString
          newString'  =           take len           newString
          -- Using 'head' should be safe but we use another
          -- version to avoid unuseful messages while debugging.
          safeHead (x:_) = x
          safeHead []    = error "squashStrings/overlap: never here"
      in safeHead $ do
           (lastStringSuffix, newStringPrefix) <-
             tails lastString' `zip` reverse (inits newString')
           guard (lastStringSuffix == newStringPrefix)
           return (length lastStringSuffix)

    -- Position the new strings on the resulting string.
    go lastPos lastString (newString:nss) =
      let len     = length newString
          overlap = calculateOverlap lastString newString
          thisPos    = lastPos - overlap
          newLastPos = lastPos + len - overlap
          (recString, recMap) = go newLastPos newString nss
      in ( drop overlap newString ++ recString
         , (newString, (thisPos, len)) : recMap
         )
    go _ _ [] = ([], [])


base64md5File :: Prelude.FilePath -> IO String
base64md5File = fmap (base64 . encode) . hashFile
    where encode d = Data.Serialize.encode (d :: MD5)

base64md5 :: L.ByteString -> String
base64md5 lbs =
            base64 $ encode
          $ runIdentity
          $ sourceList (L.toChunks lbs) $$ sinkHash
  where
    encode d = Data.Serialize.encode (d :: MD5)

base64 :: S.ByteString -> String
base64 = map tr
       . take 8
       . S8.unpack
       . Data.ByteString.Base64.encode
  where
    tr '+' = '-'
    tr '/' = '_'
    tr c   = c