{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
---------------------------------------------------------
--
-- | 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 'urlParamRenderOverride'
-- 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
      -- * Combining CSS/JS
      -- $combining
    , combineStylesheets'
    , combineScripts'
      -- ** Settings
    , CombineSettings
    , csStaticDir
    , csCssPostProcess
    , csJsPostProcess
    , csCssPreProcess
    , csJsPreProcess
    , csCombinedFolder
      -- * Template Haskell helpers
    , staticFiles
    , staticFilesList
    , staticFilesMap
    , staticFilesMergeMap
    , publicFiles
      -- * Hashing
    , base64md5
      -- * Embed
    , embed
#ifdef TEST_EXPORT
    , getFileListPieces
#endif
    ) where

import System.Directory
import qualified System.FilePath as FP
import Control.Monad
import Data.FileEmbed (embedDir)

import Yesod.Core
import Yesod.Core.Types

import Data.List (intercalate, sort)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax as TH

import Crypto.Hash.Conduit (hashFile, sinkHash)
import Crypto.Hash (MD5, Digest)
import Control.Monad.Trans.State

import qualified Data.ByteArray as ByteArray
import qualified Data.ByteString.Base64
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import Data.Text (Text, pack)
import qualified Data.Text as T
import qualified Data.Map as M
import Data.IORef (readIORef, newIORef, writeIORef)
import Data.Char (isLower, isDigit)
import Data.List (foldl')
import qualified Data.ByteString as S
import System.PosixCompat.Files (getFileStatus, modificationTime)
import System.Posix.Types (EpochTime)
import Conduit
import System.FilePath ((</>), (<.>), takeDirectory)
import qualified System.FilePath as F
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TLE
import Data.Default
--import Text.Lucius (luciusRTMinified)

import Network.Wai (pathInfo)
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 :: FilePath -> IO Static
static :: String -> IO Static
static String
dir = do
    ETagLookup
hashLookup <- String -> IO ETagLookup
cachedETagLookup String
dir
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ StaticSettings -> Static
Static forall a b. (a -> b) -> a -> b
$ String -> ETagLookup -> StaticSettings
webAppSettingsWithLookup String
dir ETagLookup
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 :: FilePath -> IO Static
staticDevel :: String -> IO Static
staticDevel String
dir = do
    ETagLookup
hashLookup <- String -> IO ETagLookup
cachedETagLookupDevel String
dir
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ StaticSettings -> Static
Static forall a b. (a -> b) -> a -> b
$ String -> ETagLookup -> StaticSettings
webAppSettingsWithLookup String
dir ETagLookup
hashLookup

-- | Produce a 'Static' based on embedding all of the static files' contents in the
-- executable at compile time.
--
-- You should use "Yesod.EmbeddedStatic" instead, it is much more powerful.
--
-- 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 :: FilePath -> Q Exp
embed :: String -> Q Exp
embed String
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 (Route Static -> Route Static -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Route Static -> Route Static -> Bool
$c/= :: Route Static -> Route Static -> Bool
== :: Route Static -> Route Static -> Bool
$c== :: Route Static -> Route Static -> Bool
Eq, Int -> Route Static -> ShowS
[Route Static] -> ShowS
Route Static -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Route Static] -> ShowS
$cshowList :: [Route Static] -> ShowS
show :: Route Static -> String
$cshow :: Route Static -> String
showsPrec :: Int -> Route Static -> ShowS
$cshowsPrec :: Int -> Route Static -> ShowS
Show, ReadPrec [Route Static]
ReadPrec (Route Static)
Int -> ReadS (Route Static)
ReadS [Route Static]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Route Static]
$creadListPrec :: ReadPrec [Route Static]
readPrec :: ReadPrec (Route Static)
$creadPrec :: ReadPrec (Route Static)
readList :: ReadS [Route Static]
$creadList :: ReadS [Route Static]
readsPrec :: Int -> ReadS (Route Static)
$creadsPrec :: Int -> ReadS (Route Static)
Read)
    renderRoute :: Route Static -> ([Text], [(Text, Text)])
renderRoute (StaticRoute [Text]
x [(Text, Text)]
y) = ([Text]
x, [(Text, Text)]
y)
instance ParseRoute Static where
    parseRoute :: ([Text], [(Text, Text)]) -> Maybe (Route Static)
parseRoute ([Text]
x, [(Text, Text)]
y) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Text] -> [(Text, Text)] -> Route Static
StaticRoute [Text]
x [(Text, Text)]
y

instance YesodSubDispatch Static master where
    yesodSubDispatch :: YesodSubRunnerEnv Static master -> Application
yesodSubDispatch YesodSubRunnerEnv {YesodRunnerEnv master
master -> Static
ParentRunner master
Route Static -> Route master
ysreToParentRoute :: forall sub parent.
YesodSubRunnerEnv sub parent -> Route sub -> Route parent
ysreParentRunner :: forall sub parent.
YesodSubRunnerEnv sub parent -> ParentRunner parent
ysreParentEnv :: forall sub parent.
YesodSubRunnerEnv sub parent -> YesodRunnerEnv parent
ysreGetSub :: forall sub parent. YesodSubRunnerEnv sub parent -> parent -> sub
ysreParentEnv :: YesodRunnerEnv master
ysreToParentRoute :: Route Static -> Route master
ysreGetSub :: master -> Static
ysreParentRunner :: ParentRunner master
..} Request
req =
        ParentRunner master
ysreParentRunner HandlerFor master TypedContent
handlert YesodRunnerEnv master
ysreParentEnv (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Route Static -> Route master
ysreToParentRoute Maybe (Route Static)
route) Request
req
      where
        route :: Maybe (Route Static)
route = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Text] -> [(Text, Text)] -> Route Static
StaticRoute (Request -> [Text]
pathInfo Request
req) []

        Static StaticSettings
set = master -> Static
ysreGetSub forall a b. (a -> b) -> a -> b
$ forall site. YesodRunnerEnv site -> site
yreSite forall a b. (a -> b) -> a -> b
$ YesodRunnerEnv master
ysreParentEnv
        handlert :: HandlerFor master TypedContent
handlert = forall (m :: * -> *) b. MonadHandler m => Application -> m b
sendWaiApplication forall a b. (a -> b) -> a -> b
$ StaticSettings -> Application
staticApp StaticSettings
set

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

getFileListPieces :: FilePath -> IO [[String]]
getFileListPieces :: String -> IO [[String]]
getFileListPieces = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT forall k a. Map k a
M.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip String
-> ([String] -> [String])
-> StateT (Map String String) IO [[String]]
go forall a. a -> a
id
  where
    go :: String
       -> ([String] -> [String])
       -> StateT (M.Map String String) IO [[String]]
    go :: String
-> ([String] -> [String])
-> StateT (Map String String) IO [[String]]
go String
fp [String] -> [String]
front = do
        [String]
allContents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ (forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
notHidden) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO [String]
getDirectoryContents String
fp
        let fullPath :: String -> String
            fullPath :: ShowS
fullPath String
f = String
fp forall a. [a] -> [a] -> [a]
++ Char
'/' forall a. a -> [a] -> [a]
: String
f
        [String]
files <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
doesFileExist forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
fullPath) [String]
allContents
        let files' :: [[String]]
files' = forall a b. (a -> b) -> [a] -> [b]
map ([String] -> [String]
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return) [String]
files
        [[String]]
files'' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [String] -> StateT (Map String String) IO [String]
dedupe [[String]]
files'
        [String]
dirs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
doesDirectoryExist forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
fullPath) [String]
allContents
        [[[String]]]
dirs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\String
f -> String
-> ([String] -> [String])
-> StateT (Map String String) IO [[String]]
go (ShowS
fullPath String
f) ([String] -> [String]
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) String
f)) [String]
dirs
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ [[String]]
files'' forall a. a -> [a] -> [a]
: [[[String]]]
dirs'

    -- Reuse data buffers for identical strings
    dedupe :: [String] -> StateT (M.Map String String) IO [String]
    dedupe :: [String] -> StateT (Map String String) IO [String]
dedupe = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> StateT (Map String String) IO String
dedupe'

    dedupe' :: String -> StateT (M.Map String String) IO String
    dedupe' :: String -> StateT (Map String String) IO String
dedupe' String
s = do
        Map String String
m <- forall (m :: * -> *) s. Monad m => StateT s m s
get
        case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
s Map String String
m of
            Just String
s' -> forall (m :: * -> *) a. Monad m => a -> m a
return String
s'
            Maybe String
Nothing -> do
                forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
s String
s Map String String
m
                forall (m :: * -> *) a. Monad m => a -> m a
return String
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 :: FilePath -> Q [Dec]
staticFiles :: String -> Q [Dec]
staticFiles String
dir = String -> Q [Dec]
mkStaticFiles String
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 :: FilePath -> [FilePath] -> Q [Dec]
staticFilesList :: String -> [String] -> Q [Dec]
staticFilesList String
dir [String]
fs =
    String -> [[String]] -> Bool -> Q [Dec]
mkStaticFilesList String
dir (forall a b. (a -> b) -> [a] -> [b]
map String -> [String]
split [String]
fs) Bool
True
  where
    split :: FilePath -> [String]
    split :: String -> [String]
split [] = []
    split String
x =
        let (String
a, String
b) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'/') String
x
         in String
a forall a. a -> [a] -> [a]
: String -> [String]
split (forall a. Int -> [a] -> [a]
drop Int
1 String
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 :: FilePath -> Q [Dec]
publicFiles :: String -> Q [Dec]
publicFiles String
dir = String -> Bool -> Q [Dec]
mkStaticFiles' String
dir Bool
False

-- | Similar to 'staticFilesList', but takes a mapping of
-- unmunged names to fingerprinted file names.
--
-- @since 1.5.3
staticFilesMap :: FilePath -> M.Map FilePath FilePath -> Q [Dec]
staticFilesMap :: String -> Map String String -> Q [Dec]
staticFilesMap String
fp Map String String
m = String -> [([String], [String])] -> Bool -> Q [Dec]
mkStaticFilesList' String
fp (forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> ([String], [String])
splitBoth [(String, String)]
mapList) Bool
True
  where
    splitBoth :: (String, String) -> ([String], [String])
splitBoth (String
k, String
v) = (String -> [String]
split String
k, String -> [String]
split String
v)
    mapList :: [(String, String)]
mapList = forall k a. Map k a -> [(k, a)]
M.toList Map String String
m
    split :: FilePath -> [String]
    split :: String -> [String]
split [] = []
    split String
x =
        let (String
a, String
b) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'/') String
x
         in String
a forall a. a -> [a] -> [a]
: String -> [String]
split (forall a. Int -> [a] -> [a]
drop Int
1 String
b)

-- | Similar to 'staticFilesMergeMap', but also generates identifiers
-- for all files in the specified directory that don't have a
-- fingerprinted version.
--
-- @since 1.5.3
staticFilesMergeMap :: FilePath -> M.Map FilePath FilePath -> Q [Dec]
staticFilesMergeMap :: String -> Map String String -> Q [Dec]
staticFilesMergeMap String
fp Map String String
m = do
  [[String]]
fs <- forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ String -> IO [[String]]
getFileListPieces String
fp
  let filesList :: [String]
filesList = forall a b. (a -> b) -> [a] -> [b]
map [String] -> String
FP.joinPath [[String]]
fs
      mergedMapList :: [(String, String)]
mergedMapList = forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Map String String
-> Map String String -> String -> Map String String
checkedInsert Map String String
invertedMap) Map String String
m [String]
filesList
  String -> [([String], [String])] -> Bool -> Q [Dec]
mkStaticFilesList' String
fp (forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> ([String], [String])
splitBoth [(String, String)]
mergedMapList) Bool
True
  where
    splitBoth :: (String, String) -> ([String], [String])
splitBoth (String
k, String
v) = (String -> [String]
split String
k, String -> [String]
split String
v)
    swap :: (b, a) -> (a, b)
swap (b
x, a
y) = (a
y, b
x)
    mapList :: [(String, String)]
mapList = forall k a. Map k a -> [(k, a)]
M.toList Map String String
m
    invertedMap :: Map String String
invertedMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {b} {a}. (b, a) -> (a, b)
swap [(String, String)]
mapList
    split :: FilePath -> [String]
    split :: String -> [String]
split [] = []
    split String
x =
        let (String
a, String
b) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'/') String
x
         in String
a forall a. a -> [a] -> [a]
: String -> [String]
split (forall a. Int -> [a] -> [a]
drop Int
1 String
b)
    -- We want to keep mappings for all files that are pre-fingerprinted,
    -- so this function checks against all of the existing fingerprinted files and
    -- only inserts a new mapping if it's not a fingerprinted file.
    checkedInsert
      :: M.Map FilePath FilePath -- inverted dictionary
      -> M.Map FilePath FilePath -- accumulating state
      -> FilePath
      -> M.Map FilePath FilePath
    checkedInsert :: Map String String
-> Map String String -> String -> Map String String
checkedInsert Map String String
iDict Map String String
st String
p = if forall k a. Ord k => k -> Map k a -> Bool
M.member String
p Map String String
iDict
      then Map String String
st
      else forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
p String
p Map String String
st

mkHashMap :: FilePath -> IO (M.Map FilePath S8.ByteString)
mkHashMap :: String -> IO (Map String ByteString)
mkHashMap String
dir = do
    [[String]]
fs <- String -> IO [[String]]
getFileListPieces String
dir
    [[String]] -> IO [(String, ByteString)]
hashAlist [[String]]
fs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
  where
    hashAlist :: [[String]] -> IO [(FilePath, S8.ByteString)]
    hashAlist :: [[String]] -> IO [(String, ByteString)]
hashAlist [[String]]
fs = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [String] -> IO (String, ByteString)
hashPair [[String]]
fs
      where
        hashPair :: [String] -> IO (FilePath, S8.ByteString)
        hashPair :: [String] -> IO (String, ByteString)
hashPair [String]
pieces = do let file :: String
file = String -> [String] -> String
pathFromRawPieces String
dir [String]
pieces
                             String
h <- String -> IO String
base64md5File String
file
                             forall (m :: * -> *) a. Monad m => a -> m a
return (String
file, String -> ByteString
S8.pack String
h)

pathFromRawPieces :: FilePath -> [String] -> FilePath
pathFromRawPieces :: String -> [String] -> String
pathFromRawPieces =
    forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' String -> ShowS
append
  where
    append :: String -> ShowS
append String
a String
b = String
a forall a. [a] -> [a] -> [a]
++ Char
'/' forall a. a -> [a] -> [a]
: String
b

cachedETagLookupDevel :: FilePath -> IO ETagLookup
cachedETagLookupDevel :: String -> IO ETagLookup
cachedETagLookupDevel String
dir = do
    Map String ByteString
etags <- String -> IO (Map String ByteString)
mkHashMap String
dir
    IORef (Map String EpochTime)
mtimeVar <- forall a. a -> IO (IORef a)
newIORef (forall k a. Map k a
M.empty :: M.Map FilePath EpochTime)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \String
f ->
      case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
f Map String ByteString
etags of
        Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
        Just ByteString
checksum -> do
          FileStatus
fs <- String -> IO FileStatus
getFileStatus String
f
          let newt :: EpochTime
newt = FileStatus -> EpochTime
modificationTime FileStatus
fs
          Map String EpochTime
mtimes <- forall a. IORef a -> IO a
readIORef IORef (Map String EpochTime)
mtimeVar
          EpochTime
oldt <- case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
f Map String EpochTime
mtimes of
            Maybe EpochTime
Nothing -> forall a. IORef a -> a -> IO ()
writeIORef IORef (Map String EpochTime)
mtimeVar (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
f EpochTime
newt Map String EpochTime
mtimes) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return EpochTime
newt
            Just EpochTime
oldt -> forall (m :: * -> *) a. Monad m => a -> m a
return EpochTime
oldt
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if EpochTime
newt forall a. Eq a => a -> a -> Bool
/= EpochTime
oldt then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just ByteString
checksum


cachedETagLookup :: FilePath -> IO ETagLookup
cachedETagLookup :: String -> IO ETagLookup
cachedETagLookup String
dir = do
    Map String ByteString
etags <- String -> IO (Map String ByteString)
mkHashMap String
dir
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (\String
f -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
f Map String ByteString
etags)

mkStaticFiles :: FilePath -> Q [Dec]
mkStaticFiles :: String -> Q [Dec]
mkStaticFiles String
fp = String -> Bool -> Q [Dec]
mkStaticFiles' String
fp Bool
True

mkStaticFiles' :: FilePath -- ^ static directory
               -> Bool     -- ^ append checksum query parameter
               -> Q [Dec]
mkStaticFiles' :: String -> Bool -> Q [Dec]
mkStaticFiles' String
fp Bool
makeHash = do
    [[String]]
fs <- forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ String -> IO [[String]]
getFileListPieces String
fp
    String -> [[String]] -> Bool -> Q [Dec]
mkStaticFilesList String
fp [[String]]
fs Bool
makeHash

mkStaticFilesList
    :: FilePath -- ^ static directory
    -> [[String]] -- ^ list of files to create identifiers for
    -> Bool     -- ^ append checksum query parameter
    -> Q [Dec]
mkStaticFilesList :: String -> [[String]] -> Bool -> Q [Dec]
mkStaticFilesList String
fp [[String]]
fs Bool
makeHash = String -> [([String], [String])] -> Bool -> Q [Dec]
mkStaticFilesList' String
fp (forall a b. [a] -> [b] -> [(a, b)]
zip [[String]]
fs [[String]]
fs) Bool
makeHash

mkStaticFilesList'
    :: FilePath -- ^ static directory
    -> [([String], [String])] -- ^ list of files to create identifiers for, where
                              -- the first argument of the tuple is the identifier
                              -- alias and the second is the actual file name
    -> Bool     -- ^ append checksum query parameter
    -> Q [Dec]
mkStaticFilesList' :: String -> [([String], [String])] -> Bool -> Q [Dec]
mkStaticFilesList' String
fp [([String], [String])]
fs Bool
makeHash = do
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([String], [String]) -> Q [Dec]
mkRoute [([String], [String])]
fs
  where
    replace' :: Char -> Char
replace' Char
c
        | Char
'A' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'Z' = Char
c
        | Char
'a' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'z' = Char
c
        | Char
'0' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'9' = Char
c
        | Bool
otherwise = Char
'_'
    mkRoute :: ([String], [String]) -> Q [Dec]
mkRoute ([String]
alias, [String]
f) = do
        let name' :: String
name' = forall a. [a] -> [[a]] -> [a]
intercalate String
"_" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
replace') [String]
alias
            routeName :: Name
routeName = String -> Name
mkName forall a b. (a -> b) -> a -> b
$
                case () of
                    ()
                        | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
name' -> forall a. HasCallStack => String -> a
error String
"null-named file"
                        | Char -> Bool
isDigit (forall a. [a] -> a
head String
name') -> Char
'_' forall a. a -> [a] -> [a]
: String
name'
                        | Char -> Bool
isLower (forall a. [a] -> a
head String
name') -> String
name'
                        | Bool
otherwise -> Char
'_' forall a. a -> [a] -> [a]
: String
name'
        Exp
f' <- [|map pack $(TH.lift f)|]
        Exp
qs <- if Bool
makeHash
                    then do String
hash <- forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ String -> IO String
base64md5File forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
pathFromRawPieces String
fp [String]
f
                            [|[(pack "etag", pack $(TH.lift hash))]|]
                    else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
ListE []
        forall (m :: * -> *) a. Monad m => a -> m a
return
            [ Name -> Type -> Dec
SigD Name
routeName forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''StaticRoute
            , Name -> [Clause] -> Dec
FunD Name
routeName
                [ [Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ (Name -> Exp
ConE 'StaticRoute) Exp -> Exp -> Exp
`AppE` Exp
f' Exp -> Exp -> Exp
`AppE` Exp
qs) []
                ]
            ]

base64md5File :: FilePath -> IO String
base64md5File :: String -> IO String
base64md5File = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> String
base64 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {bout}. ByteArray bout => Digest MD5 -> bout
encode) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) hash.
(MonadIO m, HashAlgorithm hash) =>
String -> m (Digest hash)
hashFile
    where encode :: Digest MD5 -> bout
encode Digest MD5
d = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (Digest MD5
d :: Digest MD5)

base64md5 :: L.ByteString -> String
base64md5 :: ByteString -> String
base64md5 ByteString
lbs =
            ByteString -> String
base64 forall a b. (a -> b) -> a -> b
$ forall {bout}. ByteArray bout => Digest MD5 -> bout
encode
          forall a b. (a -> b) -> a -> b
$ forall r. ConduitT () Void Identity r -> r
runConduitPure
          forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) lazy strict i.
(Monad m, LazySequence lazy strict) =>
lazy -> ConduitT i strict m ()
Conduit.sourceLazy ByteString
lbs forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) hash.
(Monad m, HashAlgorithm hash) =>
Consumer ByteString m (Digest hash)
sinkHash
  where
    encode :: Digest MD5 -> bout
encode Digest MD5
d = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (Digest MD5
d :: Digest MD5)

base64 :: S.ByteString -> String
base64 :: ByteString -> String
base64 = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
tr
       forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
8
       forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
S8.unpack
       forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Data.ByteString.Base64.encode
  where
    tr :: Char -> Char
tr Char
'+' = Char
'-'
    tr Char
'/' = Char
'_'
    tr Char
c   = Char
c

-- $combining
--
-- A common scenario on a site is the desire to include many external CSS and
-- Javascript files on every page. Doing so via the Widget functionality in
-- Yesod will work, but would also mean that the same content will be
-- downloaded many times. A better approach would be to combine all of these
-- files together into a single static file and serve that as a static resource
-- for every page. That resource can be cached on the client, and bandwidth
-- usage reduced.
--
-- This could be done as a manual process, but that becomes tedious. Instead,
-- you can use some Template Haskell code which will combine these files into a
-- single static file at compile time.

data CombineType = JS | CSS

combineStatics' :: CombineType
                -> CombineSettings
                -> [Route Static] -- ^ files to combine
                -> Q Exp
combineStatics' :: CombineType -> CombineSettings -> [Route Static] -> Q Exp
combineStatics' CombineType
combineType CombineSettings {String
[String] -> ByteString -> IO ByteString
Text -> IO Text
csCombinedFolder :: String
csJsPreProcess :: Text -> IO Text
csCssPreProcess :: Text -> IO Text
csJsPostProcess :: [String] -> ByteString -> IO ByteString
csCssPostProcess :: [String] -> ByteString -> IO ByteString
csStaticDir :: String
csCombinedFolder :: CombineSettings -> String
csJsPreProcess :: CombineSettings -> Text -> IO Text
csCssPreProcess :: CombineSettings -> Text -> IO Text
csJsPostProcess :: CombineSettings -> [String] -> ByteString -> IO ByteString
csCssPostProcess :: CombineSettings -> [String] -> ByteString -> IO ByteString
csStaticDir :: CombineSettings -> String
..} [Route Static]
routes = do
    Text
texts <- forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes
                    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
yieldMany [String]
fps
                   forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever forall {m :: * -> *} {a}.
(MonadResource m, MonadThrow m) =>
String -> ConduitT a Text m ()
readUTFFile
                   forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
sinkLazy
    Text
ltext <- forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ Text -> IO Text
preProcess Text
texts
    ByteString
bs    <- forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ [String] -> ByteString -> IO ByteString
postProcess [String]
fps forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TLE.encodeUtf8 Text
ltext
    let hash' :: String
hash' = ByteString -> String
base64md5 ByteString
bs
        suffix :: String
suffix = String
csCombinedFolder String -> ShowS
</> String
hash' String -> ShowS
<.> String
extension
        fp :: String
fp = String
csStaticDir String -> ShowS
</> String
suffix
    forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ do
        Bool -> String -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ ShowS
takeDirectory String
fp
        String -> ByteString -> IO ()
L.writeFile String
fp ByteString
bs
    let pieces :: [String]
pieces = forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"/" forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
suffix
    [|StaticRoute (map pack pieces) []|]
  where
    fps :: [FilePath]
    fps :: [String]
fps = forall a b. (a -> b) -> [a] -> [b]
map Route Static -> String
toFP [Route Static]
routes
    toFP :: Route Static -> String
toFP (StaticRoute [Text]
pieces [(Text, Text)]
_) = String
csStaticDir String -> ShowS
</> [String] -> String
F.joinPath (forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [Text]
pieces)
    readUTFFile :: String -> ConduitT a Text m ()
readUTFFile String
fp = forall (m :: * -> *) i.
MonadResource m =>
String -> ConduitT i ByteString m ()
sourceFile String
fp forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). MonadThrow m => ConduitT ByteString Text m ()
decodeUtf8C
    postProcess :: [String] -> ByteString -> IO ByteString
postProcess =
        case CombineType
combineType of
            CombineType
JS -> [String] -> ByteString -> IO ByteString
csJsPostProcess
            CombineType
CSS -> [String] -> ByteString -> IO ByteString
csCssPostProcess
    preProcess :: Text -> IO Text
preProcess =
        case CombineType
combineType of
            CombineType
JS -> Text -> IO Text
csJsPreProcess
            CombineType
CSS -> Text -> IO Text
csCssPreProcess
    extension :: String
extension =
        case CombineType
combineType of
            CombineType
JS -> String
"js"
            CombineType
CSS -> String
"css"

-- | Data type for holding all settings for combining files.
--
-- This data type is a settings type. For more information, see:
--
-- <http://www.yesodweb.com/book/settings-types>
--
-- Since 1.2.0
data CombineSettings = CombineSettings
    { CombineSettings -> String
csStaticDir :: FilePath
    -- ^ File path containing static files.
    --
    -- Default: static
    --
    -- Since 1.2.0
    , CombineSettings -> [String] -> ByteString -> IO ByteString
csCssPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString
    -- ^ Post processing to be performed on CSS files.
    --
    -- Default: Pass-through.
    --
    -- Since 1.2.0
    , CombineSettings -> [String] -> ByteString -> IO ByteString
csJsPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString
    -- ^ Post processing to be performed on Javascript files.
    --
    -- Default: Pass-through.
    --
    -- Since 1.2.0
    , CombineSettings -> Text -> IO Text
csCssPreProcess :: TL.Text -> IO TL.Text
    -- ^ Pre-processing to be performed on CSS files.
    --
    -- Default: convert all occurences of /static/ to ../
    --
    -- Since 1.2.0
    , CombineSettings -> Text -> IO Text
csJsPreProcess :: TL.Text -> IO TL.Text
    -- ^ Pre-processing to be performed on Javascript files.
    --
    -- Default: Pass-through.
    --
    -- Since 1.2.0
    , CombineSettings -> String
csCombinedFolder :: FilePath
    -- ^ Subfolder to put combined files into.
    --
    -- Default: combined
    --
    -- Since 1.2.0
    }

instance Default CombineSettings where
    def :: CombineSettings
def = CombineSettings
        { csStaticDir :: String
csStaticDir = String
"static"
        {- Disabled due to: https://github.com/yesodweb/yesod/issues/623
        , csCssPostProcess = \fps ->
              either (error . (errorIntro fps)) (return . TLE.encodeUtf8)
            . flip luciusRTMinified []
            . TLE.decodeUtf8
        -}
        , csCssPostProcess :: [String] -> ByteString -> IO ByteString
csCssPostProcess = forall a b. a -> b -> a
const forall (m :: * -> *) a. Monad m => a -> m a
return
        , csJsPostProcess :: [String] -> ByteString -> IO ByteString
csJsPostProcess = forall a b. a -> b -> a
const forall (m :: * -> *) a. Monad m => a -> m a
return
           -- FIXME The following borders on a hack. With combining of files,
           -- the final location of the CSS is no longer fixed, so relative
           -- references will break. Instead, we switched to using /static/
           -- absolute references. However, when served from a separate domain
           -- name, this will break too. The solution is that, during
           -- development, we keep /static/, and in the combining phase, we
           -- replace /static with a relative reference to the parent folder.
        , csCssPreProcess :: Text -> IO Text
csCssPreProcess =
              forall (m :: * -> *) a. Monad m => a -> m a
return
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
TL.replace Text
"'/static/" Text
"'../"
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
TL.replace Text
"\"/static/" Text
"\"../"
        , csJsPreProcess :: Text -> IO Text
csJsPreProcess = forall (m :: * -> *) a. Monad m => a -> m a
return
        , csCombinedFolder :: String
csCombinedFolder = String
"combined"
        }

liftRoutes :: [Route Static] -> Q Exp
liftRoutes :: [Route Static] -> Q Exp
liftRoutes =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Route Static -> Q Exp
go
  where
    go :: Route Static -> Q Exp
    go :: Route Static -> Q Exp
go (StaticRoute [Text]
x [(Text, Text)]
y) = [|StaticRoute $(liftTexts x) $(liftPairs y)|]

    liftTexts :: [Text] -> Q Exp
liftTexts = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}. Quote m => Text -> m Exp
liftT
    liftT :: Text -> m Exp
liftT Text
t = [|pack $(TH.lift $ T.unpack t)|]

    liftPairs :: [(Text, Text)] -> Q Exp
liftPairs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}. Quote m => (Text, Text) -> m Exp
liftPair
    liftPair :: (Text, Text) -> m Exp
liftPair (Text
x, Text
y) = [|($(liftT x), $(liftT y))|]

-- | Combine multiple CSS files together. Common usage would be:
--
-- >>> combineStylesheets' development def 'StaticR [style1_css, style2_css]
--
-- Where @development@ is a variable in your site indicated whether you are in
-- development or production mode.
--
-- Since 1.2.0
combineStylesheets' :: Bool -- ^ development? if so, perform no combining
                    -> CombineSettings
                    -> Name -- ^ Static route constructor name, e.g. \'StaticR
                    -> [Route Static] -- ^ files to combine
                    -> Q Exp
combineStylesheets' :: Bool -> CombineSettings -> Name -> [Route Static] -> Q Exp
combineStylesheets' Bool
development CombineSettings
cs Name
con [Route Static]
routes
    | Bool
development = [| mapM_ (addStylesheet . $(return $ ConE con)) $(liftRoutes routes) |]
    | Bool
otherwise = [| addStylesheet $ $(return $ ConE con) $(combineStatics' CSS cs routes) |]


-- | Combine multiple JS files together. Common usage would be:
--
-- >>> combineScripts' development def 'StaticR [script1_js, script2_js]
--
-- Where @development@ is a variable in your site indicated whether you are in
-- development or production mode.
--
-- Since 1.2.0
combineScripts' :: Bool -- ^ development? if so, perform no combining
                -> CombineSettings
                -> Name -- ^ Static route constructor name, e.g. \'StaticR
                -> [Route Static] -- ^ files to combine
                -> Q Exp
combineScripts' :: Bool -> CombineSettings -> Name -> [Route Static] -> Q Exp
combineScripts' Bool
development CombineSettings
cs Name
con [Route Static]
routes
    | Bool
development = [| mapM_ (addScript . $(return $ ConE con)) $(liftRoutes routes) |]
    | Bool
otherwise = [| addScript $ $(return $ ConE con) $(combineStatics' JS cs routes) |]