{-# 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 :: FilePath -> IO Static
static FilePath
dir = do
    ETagLookup
hashLookup <- FilePath -> IO ETagLookup
cachedETagLookup FilePath
dir
    Static -> IO Static
forall (m :: * -> *) a. Monad m => a -> m a
return (Static -> IO Static) -> Static -> IO Static
forall a b. (a -> b) -> a -> b
$ StaticSettings -> Static
Static (StaticSettings -> Static) -> StaticSettings -> Static
forall a b. (a -> b) -> a -> b
$ FilePath -> ETagLookup -> StaticSettings
webAppSettingsWithLookup FilePath
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 :: FilePath -> IO Static
staticDevel FilePath
dir = do
    ETagLookup
hashLookup <- FilePath -> IO ETagLookup
cachedETagLookupDevel FilePath
dir
    Static -> IO Static
forall (m :: * -> *) a. Monad m => a -> m a
return (Static -> IO Static) -> Static -> IO Static
forall a b. (a -> b) -> a -> b
$ StaticSettings -> Static
Static (StaticSettings -> Static) -> StaticSettings -> Static
forall a b. (a -> b) -> a -> b
$ FilePath -> ETagLookup -> StaticSettings
webAppSettingsWithLookup FilePath
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 :: FilePath -> Q Exp
embed FilePath
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
(Route Static -> Route Static -> Bool)
-> (Route Static -> Route Static -> Bool) -> Eq (Route Static)
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 -> FilePath
(Int -> Route Static -> ShowS)
-> (Route Static -> FilePath)
-> ([Route Static] -> ShowS)
-> Show (Route Static)
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Route Static] -> ShowS
$cshowList :: [Route Static] -> ShowS
show :: Route Static -> FilePath
$cshow :: Route Static -> FilePath
showsPrec :: Int -> Route Static -> ShowS
$cshowsPrec :: Int -> Route Static -> ShowS
Show, ReadPrec [Route Static]
ReadPrec (Route Static)
Int -> ReadS (Route Static)
ReadS [Route Static]
(Int -> ReadS (Route Static))
-> ReadS [Route Static]
-> ReadPrec (Route Static)
-> ReadPrec [Route Static]
-> Read (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 x y) = ([Text]
x, [(Text, Text)]
y)
instance ParseRoute Static where
    parseRoute :: ([Text], [(Text, Text)]) -> Maybe (Route Static)
parseRoute ([Text]
x, [(Text, Text)]
y) = Route Static -> Maybe (Route Static)
forall a. a -> Maybe a
Just (Route Static -> Maybe (Route Static))
-> Route Static -> Maybe (Route Static)
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 ((Route Static -> Route master)
-> Maybe (Route Static) -> Maybe (Route master)
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 = Route Static -> Maybe (Route Static)
forall a. a -> Maybe a
Just (Route Static -> Maybe (Route Static))
-> Route Static -> Maybe (Route Static)
forall a b. (a -> b) -> a -> b
$ [Text] -> [(Text, Text)] -> Route Static
StaticRoute (Request -> [Text]
pathInfo Request
req) []

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

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

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

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

    dedupe' :: String -> StateT (M.Map String String) IO String
    dedupe' :: FilePath -> StateT (Map FilePath FilePath) IO FilePath
dedupe' FilePath
s = do
        Map FilePath FilePath
m <- StateT (Map FilePath FilePath) IO (Map FilePath FilePath)
forall (m :: * -> *) s. Monad m => StateT s m s
get
        case FilePath -> Map FilePath FilePath -> Maybe FilePath
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FilePath
s Map FilePath FilePath
m of
            Just FilePath
s' -> FilePath -> StateT (Map FilePath FilePath) IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
s'
            Maybe FilePath
Nothing -> do
                Map FilePath FilePath -> StateT (Map FilePath FilePath) IO ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Map FilePath FilePath -> StateT (Map FilePath FilePath) IO ())
-> Map FilePath FilePath -> StateT (Map FilePath FilePath) IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
-> FilePath -> Map FilePath FilePath -> Map FilePath FilePath
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert FilePath
s FilePath
s Map FilePath FilePath
m
                FilePath -> StateT (Map FilePath FilePath) IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
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 :: FilePath -> Q [Dec]
staticFiles FilePath
dir = FilePath -> Q [Dec]
mkStaticFiles FilePath
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 :: FilePath -> [FilePath] -> Q [Dec]
staticFilesList FilePath
dir [FilePath]
fs =
    FilePath -> [[FilePath]] -> Bool -> Q [Dec]
mkStaticFilesList FilePath
dir ((FilePath -> [FilePath]) -> [FilePath] -> [[FilePath]]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> [FilePath]
split [FilePath]
fs) Bool
True
  where
    split :: FilePath -> [String]
    split :: FilePath -> [FilePath]
split [] = []
    split FilePath
x =
        let (FilePath
a, FilePath
b) = (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') FilePath
x
         in FilePath
a FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: FilePath -> [FilePath]
split (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 FilePath
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 :: FilePath -> Q [Dec]
publicFiles FilePath
dir = FilePath -> Bool -> Q [Dec]
mkStaticFiles' FilePath
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 :: FilePath -> Map FilePath FilePath -> Q [Dec]
staticFilesMap FilePath
fp Map FilePath FilePath
m = FilePath -> [([FilePath], [FilePath])] -> Bool -> Q [Dec]
mkStaticFilesList' FilePath
fp (((FilePath, FilePath) -> ([FilePath], [FilePath]))
-> [(FilePath, FilePath)] -> [([FilePath], [FilePath])]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, FilePath) -> ([FilePath], [FilePath])
splitBoth [(FilePath, FilePath)]
mapList) Bool
True
  where
    splitBoth :: (FilePath, FilePath) -> ([FilePath], [FilePath])
splitBoth (FilePath
k, FilePath
v) = (FilePath -> [FilePath]
split FilePath
k, FilePath -> [FilePath]
split FilePath
v)
    mapList :: [(FilePath, FilePath)]
mapList = Map FilePath FilePath -> [(FilePath, FilePath)]
forall k a. Map k a -> [(k, a)]
M.toList Map FilePath FilePath
m
    split :: FilePath -> [String]
    split :: FilePath -> [FilePath]
split [] = []
    split FilePath
x =
        let (FilePath
a, FilePath
b) = (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') FilePath
x
         in FilePath
a FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: FilePath -> [FilePath]
split (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 FilePath
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 :: FilePath -> Map FilePath FilePath -> Q [Dec]
staticFilesMergeMap FilePath
fp Map FilePath FilePath
m = do
  [[FilePath]]
fs <- IO [[FilePath]] -> Q [[FilePath]]
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO [[FilePath]] -> Q [[FilePath]])
-> IO [[FilePath]] -> Q [[FilePath]]
forall a b. (a -> b) -> a -> b
$ FilePath -> IO [[FilePath]]
getFileListPieces FilePath
fp
  let filesList :: [FilePath]
filesList = ([FilePath] -> FilePath) -> [[FilePath]] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map [FilePath] -> FilePath
FP.joinPath [[FilePath]]
fs
      mergedMapList :: [(FilePath, FilePath)]
mergedMapList = Map FilePath FilePath -> [(FilePath, FilePath)]
forall k a. Map k a -> [(k, a)]
M.toList (Map FilePath FilePath -> [(FilePath, FilePath)])
-> Map FilePath FilePath -> [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ (Map FilePath FilePath -> FilePath -> Map FilePath FilePath)
-> Map FilePath FilePath -> [FilePath] -> Map FilePath FilePath
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Map FilePath FilePath
-> Map FilePath FilePath -> FilePath -> Map FilePath FilePath
checkedInsert Map FilePath FilePath
invertedMap) Map FilePath FilePath
m [FilePath]
filesList
  FilePath -> [([FilePath], [FilePath])] -> Bool -> Q [Dec]
mkStaticFilesList' FilePath
fp (((FilePath, FilePath) -> ([FilePath], [FilePath]))
-> [(FilePath, FilePath)] -> [([FilePath], [FilePath])]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, FilePath) -> ([FilePath], [FilePath])
splitBoth [(FilePath, FilePath)]
mergedMapList) Bool
True
  where
    splitBoth :: (FilePath, FilePath) -> ([FilePath], [FilePath])
splitBoth (FilePath
k, FilePath
v) = (FilePath -> [FilePath]
split FilePath
k, FilePath -> [FilePath]
split FilePath
v)
    swap :: (b, a) -> (a, b)
swap (b
x, a
y) = (a
y, b
x)
    mapList :: [(FilePath, FilePath)]
mapList = Map FilePath FilePath -> [(FilePath, FilePath)]
forall k a. Map k a -> [(k, a)]
M.toList Map FilePath FilePath
m
    invertedMap :: Map FilePath FilePath
invertedMap = [(FilePath, FilePath)] -> Map FilePath FilePath
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(FilePath, FilePath)] -> Map FilePath FilePath)
-> [(FilePath, FilePath)] -> Map FilePath FilePath
forall a b. (a -> b) -> a -> b
$ ((FilePath, FilePath) -> (FilePath, FilePath))
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, FilePath) -> (FilePath, FilePath)
forall b a. (b, a) -> (a, b)
swap [(FilePath, FilePath)]
mapList
    split :: FilePath -> [String]
    split :: FilePath -> [FilePath]
split [] = []
    split FilePath
x =
        let (FilePath
a, FilePath
b) = (Char -> Bool) -> FilePath -> (FilePath, FilePath)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') FilePath
x
         in FilePath
a FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: FilePath -> [FilePath]
split (Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 FilePath
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 FilePath FilePath
-> Map FilePath FilePath -> FilePath -> Map FilePath FilePath
checkedInsert Map FilePath FilePath
iDict Map FilePath FilePath
st FilePath
p = if FilePath -> Map FilePath FilePath -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member FilePath
p Map FilePath FilePath
iDict
      then Map FilePath FilePath
st
      else FilePath
-> FilePath -> Map FilePath FilePath -> Map FilePath FilePath
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert FilePath
p FilePath
p Map FilePath FilePath
st

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

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

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


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

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

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

mkStaticFilesList
    :: FilePath -- ^ static directory
    -> [[String]] -- ^ list of files to create identifiers for
    -> Bool     -- ^ append checksum query parameter
    -> Q [Dec]
mkStaticFilesList :: FilePath -> [[FilePath]] -> Bool -> Q [Dec]
mkStaticFilesList FilePath
fp [[FilePath]]
fs Bool
makeHash = FilePath -> [([FilePath], [FilePath])] -> Bool -> Q [Dec]
mkStaticFilesList' FilePath
fp ([[FilePath]] -> [[FilePath]] -> [([FilePath], [FilePath])]
forall a b. [a] -> [b] -> [(a, b)]
zip [[FilePath]]
fs [[FilePath]]
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' :: FilePath -> [([FilePath], [FilePath])] -> Bool -> Q [Dec]
mkStaticFilesList' FilePath
fp [([FilePath], [FilePath])]
fs Bool
makeHash = do
    [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (([FilePath], [FilePath]) -> Q [Dec])
-> [([FilePath], [FilePath])] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([FilePath], [FilePath]) -> Q [Dec]
mkRoute [([FilePath], [FilePath])]
fs
  where
    replace' :: Char -> Char
replace' Char
c
        | Char
'A' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z' = Char
c
        | Char
'a' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z' = Char
c
        | Char
'0' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' = Char
c
        | Bool
otherwise = Char
'_'
    mkRoute :: ([FilePath], [FilePath]) -> Q [Dec]
mkRoute ([FilePath]
alias, [FilePath]
f) = do
        let name' :: FilePath
name' = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"_" ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ ShowS -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
replace') [FilePath]
alias
            routeName :: Name
routeName = FilePath -> Name
mkName (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$
                case () of
                    ()
                        | FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
name' -> ShowS
forall a. HasCallStack => FilePath -> a
error FilePath
"null-named file"
                        | Char -> Bool
isDigit (FilePath -> Char
forall a. [a] -> a
head FilePath
name') -> Char
'_' Char -> ShowS
forall a. a -> [a] -> [a]
: FilePath
name'
                        | Char -> Bool
isLower (FilePath -> Char
forall a. [a] -> a
head FilePath
name') -> FilePath
name'
                        | Bool
otherwise -> Char
'_' Char -> ShowS
forall a. a -> [a] -> [a]
: FilePath
name'
        Exp
f' <- [|map pack $(TH.lift f)|]
        Exp
qs <- if Bool
makeHash
                    then do FilePath
hash <- IO FilePath -> Q FilePath
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO FilePath -> Q FilePath) -> IO FilePath -> Q FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IO FilePath
base64md5File (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath
pathFromRawPieces FilePath
fp [FilePath]
f
                            [|[(pack "etag", pack $(TH.lift hash))]|]
                    else Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
ListE []
        [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return
            [ Name -> Type -> Dec
SigD Name
routeName (Type -> Dec) -> Type -> Dec
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 (Exp -> Body) -> Exp -> Body
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 :: FilePath -> IO FilePath
base64md5File = (Digest MD5 -> FilePath) -> IO (Digest MD5) -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> FilePath
base64 (ByteString -> FilePath)
-> (Digest MD5 -> ByteString) -> Digest MD5 -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest MD5 -> ByteString
forall bout. ByteArray bout => Digest MD5 -> bout
encode) (IO (Digest MD5) -> IO FilePath)
-> (FilePath -> IO (Digest MD5)) -> FilePath -> IO FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO (Digest MD5)
forall (m :: * -> *) hash.
(MonadIO m, HashAlgorithm hash) =>
FilePath -> m (Digest hash)
hashFile
    where encode :: Digest MD5 -> bout
encode Digest MD5
d = Digest MD5 -> bout
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (Digest MD5
d :: Digest MD5)

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

base64 :: S.ByteString -> String
base64 :: ByteString -> FilePath
base64 = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
tr
       ShowS -> (ByteString -> FilePath) -> ByteString -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
8
       ShowS -> (ByteString -> FilePath) -> ByteString -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
S8.unpack
       (ByteString -> FilePath)
-> (ByteString -> ByteString) -> ByteString -> FilePath
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 {FilePath
[FilePath] -> ByteString -> IO ByteString
Text -> IO Text
csCombinedFolder :: FilePath
csJsPreProcess :: Text -> IO Text
csCssPreProcess :: Text -> IO Text
csJsPostProcess :: [FilePath] -> ByteString -> IO ByteString
csCssPostProcess :: [FilePath] -> ByteString -> IO ByteString
csStaticDir :: FilePath
csCombinedFolder :: CombineSettings -> FilePath
csJsPreProcess :: CombineSettings -> Text -> IO Text
csCssPreProcess :: CombineSettings -> Text -> IO Text
csJsPostProcess :: CombineSettings -> [FilePath] -> ByteString -> IO ByteString
csCssPostProcess :: CombineSettings -> [FilePath] -> ByteString -> IO ByteString
csStaticDir :: CombineSettings -> FilePath
..} [Route Static]
routes = do
    Text
texts <- IO Text -> Q Text
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO Text -> Q Text) -> IO Text -> Q Text
forall a b. (a -> b) -> a -> b
$ ConduitT () Void (ResourceT IO) Text -> IO Text
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes
                    (ConduitT () Void (ResourceT IO) Text -> IO Text)
-> ConduitT () Void (ResourceT IO) Text -> IO Text
forall a b. (a -> b) -> a -> b
$ [FilePath] -> ConduitT () (Element [FilePath]) (ResourceT IO) ()
forall (m :: * -> *) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
yieldMany [FilePath]
fps
                   ConduitT () FilePath (ResourceT IO) ()
-> ConduitM FilePath Void (ResourceT IO) Text
-> ConduitT () Void (ResourceT IO) Text
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (FilePath -> ConduitT FilePath Text (ResourceT IO) ())
-> ConduitT FilePath Text (ResourceT IO) ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever FilePath -> ConduitT FilePath Text (ResourceT IO) ()
forall (m :: * -> *) a.
(MonadResource m, MonadThrow m) =>
FilePath -> ConduitM a Text m ()
readUTFFile
                   ConduitT FilePath Text (ResourceT IO) ()
-> ConduitM Text Void (ResourceT IO) Text
-> ConduitM FilePath Void (ResourceT IO) Text
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM Text Void (ResourceT IO) Text
forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
sinkLazy
    Text
ltext <- IO Text -> Q Text
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO Text -> Q Text) -> IO Text -> Q Text
forall a b. (a -> b) -> a -> b
$ Text -> IO Text
preProcess Text
texts
    ByteString
bs    <- IO ByteString -> Q ByteString
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO ByteString -> Q ByteString) -> IO ByteString -> Q ByteString
forall a b. (a -> b) -> a -> b
$ [FilePath] -> ByteString -> IO ByteString
postProcess [FilePath]
fps (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TLE.encodeUtf8 Text
ltext
    let hash' :: FilePath
hash' = ByteString -> FilePath
base64md5 ByteString
bs
        suffix :: FilePath
suffix = FilePath
csCombinedFolder FilePath -> ShowS
</> FilePath
hash' FilePath -> ShowS
<.> FilePath
extension
        fp :: FilePath
fp = FilePath
csStaticDir FilePath -> ShowS
</> FilePath
suffix
    IO () -> Q ()
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO () -> Q ()) -> IO () -> Q ()
forall a b. (a -> b) -> a -> b
$ do
        Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ ShowS
takeDirectory FilePath
fp
        FilePath -> ByteString -> IO ()
L.writeFile FilePath
fp ByteString
bs
    let pieces :: [FilePath]
pieces = (Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
T.unpack ([Text] -> [FilePath]) -> [Text] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"/" (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
suffix
    [|StaticRoute (map pack pieces) []|]
  where
    fps :: [FilePath]
    fps :: [FilePath]
fps = (Route Static -> FilePath) -> [Route Static] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Route Static -> FilePath
toFP [Route Static]
routes
    toFP :: Route Static -> FilePath
toFP (StaticRoute pieces _) = FilePath
csStaticDir FilePath -> ShowS
</> [FilePath] -> FilePath
F.joinPath ((Text -> FilePath) -> [Text] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
T.unpack [Text]
pieces)
    readUTFFile :: FilePath -> ConduitM a Text m ()
readUTFFile FilePath
fp = FilePath -> ConduitT a ByteString m ()
forall (m :: * -> *) i.
MonadResource m =>
FilePath -> ConduitT i ByteString m ()
sourceFile FilePath
fp ConduitT a ByteString m ()
-> ConduitM ByteString Text m () -> ConduitM a Text m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ByteString Text m ()
forall (m :: * -> *). MonadThrow m => ConduitT ByteString Text m ()
decodeUtf8C
    postProcess :: [FilePath] -> ByteString -> IO ByteString
postProcess =
        case CombineType
combineType of
            CombineType
JS -> [FilePath] -> ByteString -> IO ByteString
csJsPostProcess
            CombineType
CSS -> [FilePath] -> 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 :: FilePath
extension =
        case CombineType
combineType of
            CombineType
JS -> FilePath
"js"
            CombineType
CSS -> FilePath
"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 -> FilePath
csStaticDir :: FilePath
    -- ^ File path containing static files.
    --
    -- Default: static
    --
    -- Since 1.2.0
    , CombineSettings -> [FilePath] -> 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 -> [FilePath] -> 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 -> FilePath
csCombinedFolder :: FilePath
    -- ^ Subfolder to put combined files into.
    --
    -- Default: combined
    --
    -- Since 1.2.0
    }

instance Default CombineSettings where
    def :: CombineSettings
def = CombineSettings :: FilePath
-> ([FilePath] -> ByteString -> IO ByteString)
-> ([FilePath] -> ByteString -> IO ByteString)
-> (Text -> IO Text)
-> (Text -> IO Text)
-> FilePath
-> CombineSettings
CombineSettings
        { csStaticDir :: FilePath
csStaticDir = FilePath
"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 :: [FilePath] -> ByteString -> IO ByteString
csCssPostProcess = (ByteString -> IO ByteString)
-> [FilePath] -> ByteString -> IO ByteString
forall a b. a -> b -> a
const ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return
        , csJsPostProcess :: [FilePath] -> ByteString -> IO ByteString
csJsPostProcess = (ByteString -> IO ByteString)
-> [FilePath] -> ByteString -> IO ByteString
forall a b. a -> b -> a
const ByteString -> IO ByteString
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 =
              Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return
            (Text -> IO Text) -> (Text -> Text) -> Text -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
TL.replace Text
"'/static/" Text
"'../"
            (Text -> Text) -> (Text -> Text) -> Text -> 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 = Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return
        , csCombinedFolder :: FilePath
csCombinedFolder = FilePath
"combined"
        }

liftRoutes :: [Route Static] -> Q Exp
liftRoutes :: [Route Static] -> Q Exp
liftRoutes =
    ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE (Q [Exp] -> Q Exp)
-> ([Route Static] -> Q [Exp]) -> [Route Static] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Route Static -> Q Exp) -> [Route Static] -> Q [Exp]
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 x y) = [|StaticRoute $(liftTexts x) $(liftPairs y)|]

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

    liftPairs :: [(Text, Text)] -> Q Exp
liftPairs = ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE (Q [Exp] -> Q Exp)
-> ([(Text, Text)] -> Q [Exp]) -> [(Text, Text)] -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text) -> Q Exp) -> [(Text, Text)] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Text, Text) -> Q Exp
liftPair
    liftPair :: (Text, Text) -> Q 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) |]