{-# 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
    hashLookup <- String -> IO ETagLookup
cachedETagLookup String
dir
    return $ Static $ webAppSettingsWithLookup dir hashLookup

-- | Same as 'static', but does not assumes that the files do not
-- change and checks their modification time whenever a request
-- is made.
staticDevel :: FilePath -> IO Static
staticDevel :: String -> IO Static
staticDevel String
dir = do
    hashLookup <- String -> IO ETagLookup
cachedETagLookupDevel String
dir
    return $ Static $ webAppSettingsWithLookup dir 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 $(String -> Q Exp
embedDir String
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
$c== :: Route Static -> Route Static -> Bool
== :: Route Static -> Route Static -> Bool
$c/= :: Route Static -> Route Static -> Bool
/= :: Route Static -> Route Static -> Bool
Eq, Int -> Route Static -> ShowS
[Route Static] -> ShowS
Route Static -> String
(Int -> Route Static -> ShowS)
-> (Route Static -> String)
-> ([Route Static] -> ShowS)
-> Show (Route Static)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Route Static -> ShowS
showsPrec :: Int -> Route Static -> ShowS
$cshow :: Route Static -> String
show :: Route Static -> String
$cshowList :: [Route Static] -> ShowS
showList :: [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
$creadsPrec :: Int -> ReadS (Route Static)
readsPrec :: Int -> ReadS (Route Static)
$creadList :: ReadS [Route Static]
readList :: ReadS [Route Static]
$creadPrec :: ReadPrec (Route Static)
readPrec :: ReadPrec (Route Static)
$creadListPrec :: ReadPrec [Route Static]
readListPrec :: ReadPrec [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) = 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
ysreParentRunner :: ParentRunner master
ysreGetSub :: master -> Static
ysreToParentRoute :: Route Static -> Route master
ysreParentEnv :: YesodRunnerEnv master
ysreGetSub :: forall sub parent. YesodSubRunnerEnv sub parent -> parent -> sub
ysreParentEnv :: forall sub parent.
YesodSubRunnerEnv sub parent -> YesodRunnerEnv parent
ysreParentRunner :: forall sub parent.
YesodSubRunnerEnv sub parent -> ParentRunner parent
ysreToParentRoute :: forall sub parent.
YesodSubRunnerEnv sub parent -> Route sub -> Route parent
..} Request
req =
        ParentRunner master
ysreParentRunner HandlerFor master TypedContent
handlert YesodRunnerEnv master
ysreParentEnv ((Route Static -> Route master)
-> Maybe (Route Static) -> Maybe (Route master)
forall a b. (a -> b) -> Maybe a -> Maybe b
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 :: 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 = (StateT (Map String String) IO [[String]]
 -> Map String String -> IO [[String]])
-> Map String String
-> StateT (Map String String) IO [[String]]
-> IO [[String]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT (Map String String) IO [[String]]
-> Map String String -> IO [[String]]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT Map String String
forall k a. Map k a
M.empty (StateT (Map String String) IO [[String]] -> IO [[String]])
-> (String -> StateT (Map String String) IO [[String]])
-> String
-> IO [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
 -> ([String] -> [String])
 -> StateT (Map String String) IO [[String]])
-> ([String] -> [String])
-> String
-> StateT (Map String String) IO [[String]]
forall a b c. (a -> b -> c) -> b -> a -> c
flip String
-> ([String] -> [String])
-> StateT (Map String String) IO [[String]]
go [String] -> [String]
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
        allContents <- IO [String] -> StateT (Map String String) IO [String]
forall a. IO a -> StateT (Map String String) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> StateT (Map String String) IO [String])
-> IO [String] -> StateT (Map String String) IO [String]
forall a b. (a -> b) -> a -> b
$ ([String] -> [String]
forall a. Ord a => [a] -> [a]
sort ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
notHidden) ([String] -> [String]) -> IO [String] -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO [String]
getDirectoryContents String
fp
        let fullPath :: String -> String
            fullPath String
f = String
fp String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'/' Char -> ShowS
forall a. a -> [a] -> [a]
: String
f
        files <- liftIO $ filterM (doesFileExist . fullPath) allContents
        let files' = (String -> [String]) -> [String] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> [String]
front ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return) [String]
files
        files'' <- mapM dedupe files'
        dirs <- liftIO $ filterM (doesDirectoryExist . fullPath) allContents
        dirs' <- mapM (\String
f -> String
-> ([String] -> [String])
-> StateT (Map String String) IO [[String]]
go (ShowS
fullPath String
f) ([String] -> [String]
front ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) String
f)) dirs
        return $ concat $ files'' : 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 = (String -> StateT (Map String String) IO String)
-> [String] -> StateT (Map String String) IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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
        m <- StateT (Map String String) IO (Map String String)
forall (m :: * -> *) s. Monad m => StateT s m s
get
        case M.lookup s m of
            Just String
s' -> String -> StateT (Map String String) IO String
forall a. a -> StateT (Map String String) IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
s'
            Maybe String
Nothing -> do
                Map String String -> StateT (Map String String) IO ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (Map String String -> StateT (Map String String) IO ())
-> Map String String -> StateT (Map String String) IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> Map String String -> Map String String
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
s String
s Map String String
m
                String -> StateT (Map String String) IO String
forall a. a -> StateT (Map String String) IO a
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 ((String -> [String]) -> [String] -> [[String]]
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) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') String
x
         in String
a String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
split (Int -> ShowS
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 (((String, String) -> ([String], [String]))
-> [(String, String)] -> [([String], [String])]
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 = Map String String -> [(String, String)]
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) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') String
x
         in String
a String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
split (Int -> ShowS
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
  fs <- IO [[String]] -> Q [[String]]
forall a. IO a -> Q a
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO [[String]] -> Q [[String]]) -> IO [[String]] -> Q [[String]]
forall a b. (a -> b) -> a -> b
$ String -> IO [[String]]
getFileListPieces String
fp
  let filesList = ([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> String
FP.joinPath [[String]]
fs
      mergedMapList = Map String String -> [(String, String)]
forall k a. Map k a -> [(k, a)]
M.toList (Map String String -> [(String, String)])
-> Map String String -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ (Map String String -> String -> Map String String)
-> Map String String -> [String] -> Map String String
forall b a. (b -> a -> b) -> 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
  mkStaticFilesList' fp (map splitBoth mergedMapList) 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 = Map String String -> [(String, String)]
forall k a. Map k a -> [(k, a)]
M.toList Map String String
m
    invertedMap :: Map String String
invertedMap = [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, String)] -> Map String String)
-> [(String, String)] -> Map String String
forall a b. (a -> b) -> a -> b
$ ((String, String) -> (String, String))
-> [(String, String)] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> (String, String)
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) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') String
x
         in String
a String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
split (Int -> ShowS
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 String -> Map String String -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member String
p Map String String
iDict
      then Map String String
st
      else String -> String -> Map String String -> Map String String
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
    fs <- String -> IO [[String]]
getFileListPieces String
dir
    hashAlist fs >>= return . M.fromList
  where
    hashAlist :: [[String]] -> IO [(FilePath, S8.ByteString)]
    hashAlist :: [[String]] -> IO [(String, ByteString)]
hashAlist [[String]]
fs = ([String] -> IO (String, ByteString))
-> [[String]] -> IO [(String, ByteString)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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
                             h <- String -> IO String
base64md5File String
file
                             return (file, S8.pack h)

pathFromRawPieces :: FilePath -> [String] -> FilePath
pathFromRawPieces :: String -> [String] -> String
pathFromRawPieces =
    (String -> ShowS) -> String -> [String] -> String
forall b a. (b -> a -> b) -> b -> [a] -> b
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 String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'/' Char -> ShowS
forall a. a -> [a] -> [a]
: String
b

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


cachedETagLookup :: FilePath -> IO ETagLookup
cachedETagLookup :: String -> IO ETagLookup
cachedETagLookup String
dir = do
    etags <- String -> IO (Map String ByteString)
mkHashMap String
dir
    return $ (\String
f -> Maybe ByteString -> IO (Maybe ByteString)
forall a. a -> IO a
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
$ String -> Map String ByteString -> Maybe ByteString
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
    fs <- IO [[String]] -> Q [[String]]
forall a. IO a -> Q a
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO [[String]] -> Q [[String]]) -> IO [[String]] -> Q [[String]]
forall a b. (a -> b) -> a -> b
$ String -> IO [[String]]
getFileListPieces String
fp
    mkStaticFilesList fp fs 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 ([[String]] -> [[String]] -> [([String], [String])]
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
    [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (([String], [String]) -> Q [Dec])
-> [([String], [String])] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([String], [String]) -> Q [Dec]
mkRoute [([String], [String])]
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 :: ([String], [String]) -> Q [Dec]
mkRoute ([String]
alias, [String]
f) = do
        let name' :: String
name' = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"_" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
replace') [String]
alias
            routeName :: Name
routeName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$
                case () of
                    ()
                        | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
name' -> ShowS
forall a. HasCallStack => String -> a
error String
"null-named file"
                        | Char -> Bool
isDigit (String -> Char
forall a. HasCallStack => [a] -> a
head String
name') -> Char
'_' Char -> ShowS
forall a. a -> [a] -> [a]
: String
name'
                        | Char -> Bool
isLower (String -> Char
forall a. HasCallStack => [a] -> a
head String
name') -> String
name'
                        | Bool
otherwise -> Char
'_' Char -> ShowS
forall a. a -> [a] -> [a]
: String
name'
        f' <- [|map pack $([String] -> Q Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => [String] -> m Exp
TH.lift [String]
f)|]
        qs <- if makeHash
                    then do hash <- qRunIO $ base64md5File $ pathFromRawPieces fp f
                            [|[(pack "etag", pack $(TH.lift hash))]|]
                    else return $ ListE []
        return
            [ SigD routeName $ ConT ''StaticRoute
            , FunD routeName
                [ Clause [] (NormalB $ (ConE 'StaticRoute) `AppE` f' `AppE` qs) []
                ]
            ]

base64md5File :: FilePath -> IO String
base64md5File :: String -> IO String
base64md5File = (Digest MD5 -> String) -> IO (Digest MD5) -> IO String
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> String
base64 (ByteString -> String)
-> (Digest MD5 -> ByteString) -> Digest MD5 -> String
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 String)
-> (String -> IO (Digest MD5)) -> String -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO (Digest MD5)
forall (m :: * -> *) hash.
(MonadIO m, HashAlgorithm hash) =>
String -> 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 -> String
base64md5 ByteString
lbs =
            ByteString -> String
base64 (ByteString -> String) -> ByteString -> String
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 ()
-> ConduitT ByteString Void Identity (Digest MD5)
-> ConduitT () Void Identity (Digest MD5)
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString Void Identity (Digest MD5)
Consumer ByteString 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 -> String
base64 = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
tr
       ShowS -> (ByteString -> String) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
8
       ShowS -> (ByteString -> String) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
S8.unpack
       (ByteString -> String)
-> (ByteString -> ByteString) -> ByteString -> String
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
csStaticDir :: CombineSettings -> String
csCssPostProcess :: CombineSettings -> [String] -> ByteString -> IO ByteString
csJsPostProcess :: CombineSettings -> [String] -> ByteString -> IO ByteString
csCssPreProcess :: CombineSettings -> Text -> IO Text
csJsPreProcess :: CombineSettings -> Text -> IO Text
csCombinedFolder :: CombineSettings -> String
csStaticDir :: String
csCssPostProcess :: [String] -> ByteString -> IO ByteString
csJsPostProcess :: [String] -> ByteString -> IO ByteString
csCssPreProcess :: Text -> IO Text
csJsPreProcess :: Text -> IO Text
csCombinedFolder :: String
..} [Route Static]
routes = do
    texts <- IO Text -> Q Text
forall a. IO a -> Q a
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
$ [String] -> ConduitT () (Element [String]) (ResourceT IO) ()
forall (m :: * -> *) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
yieldMany [String]
fps
                   ConduitT () String (ResourceT IO) ()
-> ConduitT String Void (ResourceT IO) Text
-> ConduitT () Void (ResourceT IO) Text
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| (String -> ConduitT String Text (ResourceT IO) ())
-> ConduitT String Text (ResourceT IO) ()
forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever String -> ConduitT String Text (ResourceT IO) ()
forall {m :: * -> *} {a}.
(MonadResource m, MonadThrow m) =>
String -> ConduitT a Text m ()
readUTFFile
                   ConduitT String Text (ResourceT IO) ()
-> ConduitT Text Void (ResourceT IO) Text
-> ConduitT String Void (ResourceT IO) Text
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Text Void (ResourceT IO) Text
forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
sinkLazy
    ltext <- qRunIO $ preProcess texts
    bs    <- qRunIO $ postProcess fps $ TLE.encodeUtf8 ltext
    let hash' = ByteString -> String
base64md5 ByteString
bs
        suffix = String
csCombinedFolder String -> ShowS
</> String
hash' String -> ShowS
<.> String
extension
        fp = String
csStaticDir String -> ShowS
</> String
suffix
    qRunIO $ do
        createDirectoryIfMissing True $ takeDirectory fp
        L.writeFile fp bs
    let pieces = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack ([Text] -> [String]) -> [Text] -> [String]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/" (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
suffix
    [|StaticRoute (map pack pieces) []|]
  where
    fps :: [FilePath]
    fps :: [String]
fps = (Route Static -> String) -> [Route Static] -> [String]
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 ((Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [Text]
pieces)
    readUTFFile :: String -> ConduitT a Text m ()
readUTFFile String
fp = String -> ConduitT a ByteString m ()
forall (m :: * -> *) i.
MonadResource m =>
String -> ConduitT i ByteString m ()
sourceFile String
fp ConduitT a ByteString m ()
-> ConduitT ByteString Text m () -> ConduitT a Text m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT ByteString Text m ()
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 = (ByteString -> IO ByteString)
-> [String] -> ByteString -> IO ByteString
forall a b. a -> b -> a
const ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
        , csJsPostProcess :: [String] -> ByteString -> IO ByteString
csJsPostProcess = (ByteString -> IO ByteString)
-> [String] -> ByteString -> IO ByteString
forall a b. a -> b -> a
const ByteString -> IO ByteString
forall a. a -> IO a
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 a. a -> IO a
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
. HasCallStack => Text -> Text -> Text -> Text
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
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
TL.replace Text
"\"/static/" Text
"\"../"
        , csJsPreProcess :: Text -> IO Text
csJsPreProcess = Text -> IO Text
forall a. a -> IO a
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 =
    ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall a b. (a -> b) -> Q a -> Q b
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 $([Text] -> Q Exp
liftTexts [Text]
x) $([(Text, Text)] -> Q Exp
liftPairs [(Text, Text)]
y)|]

    liftTexts :: [Text] -> Q Exp
liftTexts = ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall a b. (a -> b) -> Q a -> Q b
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Text -> Q Exp
forall {m :: * -> *}. Quote m => Text -> m Exp
liftT
    liftT :: Text -> m Exp
liftT Text
t = [|pack $(String -> m Exp
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
forall (m :: * -> *). Quote m => String -> m Exp
TH.lift (String -> m Exp) -> String -> m Exp
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t)|]

    liftPairs :: [(Text, Text)] -> Q Exp
liftPairs = ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall a b. (a -> b) -> Q a -> Q b
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Text, Text) -> Q Exp
forall {m :: * -> *}. Quote m => (Text, Text) -> m Exp
liftPair
    liftPair :: (Text, Text) -> m Exp
liftPair (Text
x, Text
y) = [|($(Text -> m Exp
forall {m :: * -> *}. Quote m => Text -> m Exp
liftT Text
x), $(Text -> m Exp
forall {m :: * -> *}. Quote m => Text -> m Exp
liftT Text
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 . $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE Name
con)) $([Route Static] -> Q Exp
liftRoutes [Route Static]
routes) |]
    | Bool
otherwise = [| addStylesheet $ $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE Name
con) $(CombineType -> CombineSettings -> [Route Static] -> Q Exp
combineStatics' CombineType
CSS CombineSettings
cs [Route Static]
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 . $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE Name
con)) $([Route Static] -> Q Exp
liftRoutes [Route Static]
routes) |]
    | Bool
otherwise = [| addScript $ $(Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Exp
ConE Name
con) $(CombineType -> CombineSettings -> [Route Static] -> Q Exp
combineStatics' CombineType
JS CombineSettings
cs [Route Static]
routes) |]