{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
module Yesod.Static
(
Static (..)
, Route (..)
, StaticRoute
, static
, staticDevel
, combineStylesheets'
, combineScripts'
, CombineSettings
, csStaticDir
, csCssPostProcess
, csJsPostProcess
, csCssPreProcess
, csJsPreProcess
, csCombinedFolder
, staticFiles
, staticFilesList
, staticFilesMap
, staticFilesMergeMap
, publicFiles
, base64md5
, 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 Network.Wai (pathInfo)
import Network.Wai.Application.Static
( StaticSettings (..)
, staticApp
, webAppSettingsWithLookup
, embeddedSettings
)
import WaiAppStatic.Storage.Filesystem (ETagLookup)
newtype Static = Static StaticSettings
type StaticRoute = Route Static
static :: FilePath -> IO Static
static :: String -> IO Static
static String
dir = do
ETagLookup
hashLookup <- String -> IO ETagLookup
cachedETagLookup String
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
$ String -> ETagLookup -> StaticSettings
webAppSettingsWithLookup String
dir ETagLookup
hashLookup
staticDevel :: FilePath -> IO Static
staticDevel :: String -> IO Static
staticDevel String
dir = do
ETagLookup
hashLookup <- String -> IO ETagLookup
cachedETagLookupDevel String
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
$ String -> ETagLookup -> StaticSettings
webAppSettingsWithLookup String
dir ETagLookup
hashLookup
embed :: FilePath -> Q Exp
embed :: String -> Q Exp
embed String
fp = [|Static (embeddedSettings $(embedDir fp))|]
instance RenderRoute Static where
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 -> 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
showList :: [Route Static] -> ShowS
$cshowList :: [Route Static] -> ShowS
show :: Route Static -> String
$cshow :: Route Static -> String
showsPrec :: Int -> Route Static -> ShowS
$cshowsPrec :: Int -> Route Static -> ShowS
Show, ReadPrec [Route Static]
ReadPrec (Route Static)
Int -> ReadS (Route Static)
ReadS [Route Static]
(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 [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 :: forall sub parent.
YesodSubRunnerEnv sub parent -> ParentRunner parent
ysreGetSub :: forall sub parent. YesodSubRunnerEnv sub parent -> parent -> sub
ysreToParentRoute :: forall sub parent.
YesodSubRunnerEnv sub parent -> Route sub -> Route parent
ysreParentEnv :: forall sub parent.
YesodSubRunnerEnv sub parent -> YesodRunnerEnv parent
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 :: 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
[String]
allContents <- IO [String] -> StateT (Map String String) IO [String]
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO [String]
getDirectoryContents String
fp
let fullPath :: String -> String
fullPath :: ShowS
fullPath String
f = String
fp String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'/' Char -> ShowS
forall a. a -> [a] -> [a]
: String
f
[String]
files <- IO [String] -> StateT (Map String String) IO [String]
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 -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
doesFileExist (String -> IO Bool) -> ShowS -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
fullPath) [String]
allContents
let files' :: [[String]]
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 (m :: * -> *) a. Monad m => a -> m a
return) [String]
files
[[String]]
files'' <- ([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)
mapM [String] -> StateT (Map String String) IO [String]
dedupe [[String]]
files'
[String]
dirs <- IO [String] -> StateT (Map String String) IO [String]
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 -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
doesDirectoryExist (String -> IO Bool) -> ShowS -> String -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
fullPath) [String]
allContents
[[[String]]]
dirs' <- (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)
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)) [String]
dirs
[[String]] -> StateT (Map String String) IO [[String]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[String]] -> StateT (Map String String) IO [[String]])
-> [[String]] -> StateT (Map String String) IO [[String]]
forall a b. (a -> b) -> a -> b
$ [[[String]]] -> [[String]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[String]]] -> [[String]]) -> [[[String]]] -> [[String]]
forall a b. (a -> b) -> a -> b
$ [[String]]
files'' [[String]] -> [[[String]]] -> [[[String]]]
forall a. a -> [a] -> [a]
: [[[String]]]
dirs'
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)
mapM String -> StateT (Map String String) IO String
dedupe'
dedupe' :: String -> StateT (M.Map String String) IO String
dedupe' :: String -> StateT (Map String String) IO String
dedupe' String
s = do
Map String String
m <- StateT (Map String String) IO (Map String String)
forall (m :: * -> *) s. Monad m => StateT s m s
get
case String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
s Map String String
m of
Just String
s' -> String -> StateT (Map String String) IO String
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 (m :: * -> *) a. Monad m => a -> m a
return String
s
staticFiles :: FilePath -> Q [Dec]
staticFiles :: String -> Q [Dec]
staticFiles String
dir = String -> Q [Dec]
mkStaticFiles String
dir
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)
publicFiles :: FilePath -> Q [Dec]
publicFiles :: String -> Q [Dec]
publicFiles String
dir = String -> Bool -> Q [Dec]
mkStaticFiles' String
dir Bool
False
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)
staticFilesMergeMap :: FilePath -> M.Map FilePath FilePath -> Q [Dec]
staticFilesMergeMap :: String -> Map String String -> Q [Dec]
staticFilesMergeMap String
fp Map String String
m = do
[[String]]
fs <- IO [[String]] -> Q [[String]]
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]
filesList = ([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> String
FP.joinPath [[String]]
fs
mergedMapList :: [(String, String)]
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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Map String String
-> Map String String -> String -> Map String String
checkedInsert Map String String
invertedMap) Map String String
m [String]
filesList
String -> [([String], [String])] -> Bool -> Q [Dec]
mkStaticFilesList' String
fp (((String, String) -> ([String], [String]))
-> [(String, String)] -> [([String], [String])]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> ([String], [String])
splitBoth [(String, String)]
mergedMapList) Bool
True
where
splitBoth :: (String, String) -> ([String], [String])
splitBoth (String
k, String
v) = (String -> [String]
split String
k, String -> [String]
split String
v)
swap :: (b, a) -> (a, b)
swap (b
x, a
y) = (a
y, b
x)
mapList :: [(String, String)]
mapList = 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)
checkedInsert
:: M.Map FilePath FilePath
-> M.Map FilePath FilePath
-> 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
[[String]]
fs <- String -> IO [[String]]
getFileListPieces String
dir
[[String]] -> IO [(String, ByteString)]
hashAlist [[String]]
fs IO [(String, ByteString)]
-> ([(String, ByteString)] -> IO (Map String ByteString))
-> IO (Map String ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Map String ByteString -> IO (Map String ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Map String ByteString -> IO (Map String ByteString))
-> ([(String, ByteString)] -> Map String ByteString)
-> [(String, ByteString)]
-> IO (Map String ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, ByteString)] -> Map String ByteString
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
where
hashAlist :: [[String]] -> IO [(FilePath, S8.ByteString)]
hashAlist :: [[String]] -> IO [(String, ByteString)]
hashAlist [[String]]
fs = ([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)
mapM [String] -> IO (String, ByteString)
hashPair [[String]]
fs
where
hashPair :: [String] -> IO (FilePath, S8.ByteString)
hashPair :: [String] -> IO (String, ByteString)
hashPair [String]
pieces = do let file :: String
file = String -> [String] -> String
pathFromRawPieces String
dir [String]
pieces
String
h <- String -> IO String
base64md5File String
file
(String, ByteString) -> IO (String, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
file, String -> ByteString
S8.pack String
h)
pathFromRawPieces :: FilePath -> [String] -> FilePath
pathFromRawPieces :: String -> [String] -> String
pathFromRawPieces =
(String -> ShowS) -> String -> [String] -> String
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
Map String ByteString
etags <- String -> IO (Map String ByteString)
mkHashMap String
dir
IORef (Map String EpochTime)
mtimeVar <- Map String EpochTime -> IO (IORef (Map String EpochTime))
forall a. a -> IO (IORef a)
newIORef (Map String 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
$ \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 (m :: * -> *) a. Monad m => a -> m a
return Maybe ByteString
forall a. Maybe a
Nothing
Just ByteString
checksum -> do
FileStatus
fs <- String -> IO FileStatus
getFileStatus String
f
let newt :: EpochTime
newt = FileStatus -> EpochTime
modificationTime FileStatus
fs
Map String EpochTime
mtimes <- IORef (Map String EpochTime) -> IO (Map String EpochTime)
forall a. IORef a -> IO a
readIORef IORef (Map String EpochTime)
mtimeVar
EpochTime
oldt <- case String -> Map String EpochTime -> Maybe EpochTime
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
f Map String EpochTime
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 (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 :: String -> IO ETagLookup
cachedETagLookup String
dir = do
Map String ByteString
etags <- String -> IO (Map String ByteString)
mkHashMap String
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
$ (\String
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
$ 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
-> Bool
-> Q [Dec]
mkStaticFiles' :: String -> Bool -> Q [Dec]
mkStaticFiles' String
fp Bool
makeHash = do
[[String]]
fs <- IO [[String]] -> Q [[String]]
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
String -> [[String]] -> Bool -> Q [Dec]
mkStaticFilesList String
fp [[String]]
fs Bool
makeHash
mkStaticFilesList
:: FilePath
-> [[String]]
-> Bool
-> 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
-> [([String], [String])]
-> Bool
-> 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 (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)
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 (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. [a] -> a
head String
name') -> Char
'_' Char -> ShowS
forall a. a -> [a] -> [a]
: String
name'
| Char -> Bool
isLower (String -> Char
forall a. [a] -> a
head String
name') -> String
name'
| Bool
otherwise -> Char
'_' Char -> ShowS
forall a. a -> [a] -> [a]
: String
name'
Exp
f' <- [|map pack $(TH.lift f)|]
Exp
qs <- if Bool
makeHash
then do String
hash <- IO String -> Q String
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
base64md5File (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
pathFromRawPieces String
fp [String]
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 :: String -> IO String
base64md5File = (Digest MD5 -> String) -> IO (Digest MD5) -> IO String
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 ()
-> 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 -> 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
data CombineType = JS | CSS
combineStatics' :: CombineType
-> CombineSettings
-> [Route Static]
-> Q Exp
combineStatics' :: CombineType -> CombineSettings -> [Route Static] -> Q Exp
combineStatics' CombineType
combineType CombineSettings {String
[String] -> ByteString -> IO ByteString
Text -> IO Text
csCombinedFolder :: String
csJsPreProcess :: Text -> IO Text
csCssPreProcess :: Text -> IO Text
csJsPostProcess :: [String] -> ByteString -> IO ByteString
csCssPostProcess :: [String] -> ByteString -> IO ByteString
csStaticDir :: String
csCombinedFolder :: CombineSettings -> String
csJsPreProcess :: CombineSettings -> Text -> IO Text
csCssPreProcess :: CombineSettings -> Text -> IO Text
csJsPostProcess :: CombineSettings -> [String] -> ByteString -> IO ByteString
csCssPostProcess :: CombineSettings -> [String] -> ByteString -> IO ByteString
csStaticDir :: CombineSettings -> String
..} [Route Static]
routes = do
Text
texts <- 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
$ [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) ()
-> ConduitM String 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
.| (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 -> ConduitM a Text m ()
readUTFFile
ConduitT String Text (ResourceT IO) ()
-> ConduitM Text Void (ResourceT IO) Text
-> ConduitM String 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
$ [String] -> ByteString -> IO ByteString
postProcess [String]
fps (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TLE.encodeUtf8 Text
ltext
let hash' :: String
hash' = ByteString -> String
base64md5 ByteString
bs
suffix :: String
suffix = String
csCombinedFolder String -> ShowS
</> String
hash' String -> ShowS
<.> String
extension
fp :: String
fp = String
csStaticDir String -> ShowS
</> String
suffix
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 -> String -> IO ()
createDirectoryIfMissing Bool
True (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ShowS
takeDirectory String
fp
String -> ByteString -> IO ()
L.writeFile String
fp ByteString
bs
let pieces :: [String]
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
$ 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 -> ConduitM 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 ()
-> 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 :: [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 CombineSettings = CombineSettings
{ CombineSettings -> String
csStaticDir :: FilePath
, CombineSettings -> [String] -> ByteString -> IO ByteString
csCssPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString
, CombineSettings -> [String] -> ByteString -> IO ByteString
csJsPostProcess :: [FilePath] -> L.ByteString -> IO L.ByteString
, CombineSettings -> Text -> IO Text
csCssPreProcess :: TL.Text -> IO TL.Text
, CombineSettings -> Text -> IO Text
csJsPreProcess :: TL.Text -> IO TL.Text
, CombineSettings -> String
csCombinedFolder :: FilePath
}
instance Default CombineSettings where
def :: CombineSettings
def = CombineSettings :: String
-> ([String] -> ByteString -> IO ByteString)
-> ([String] -> ByteString -> IO ByteString)
-> (Text -> IO Text)
-> (Text -> IO Text)
-> String
-> CombineSettings
CombineSettings
{ csStaticDir :: String
csStaticDir = String
"static"
, csCssPostProcess :: [String] -> ByteString -> IO ByteString
csCssPostProcess = (ByteString -> IO ByteString)
-> [String] -> ByteString -> IO ByteString
forall a b. a -> b -> a
const ByteString -> IO ByteString
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 (m :: * -> *) a. Monad m => a -> m a
return
, 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 :: String
csCombinedFolder = String
"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 [Text]
x [(Text, Text)]
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
forall {m :: * -> *}. Quote m => Text -> m Exp
liftT
liftT :: Text -> m Exp
liftT Text
t = [|pack $(TH.lift $ T.unpack t)|]
liftPairs :: [(Text, Text)] -> Q Exp
liftPairs = ([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
forall {m :: * -> *}. Quote m => (Text, Text) -> m Exp
liftPair
liftPair :: (Text, Text) -> m Exp
liftPair (Text
x, Text
y) = [|($(liftT x), $(liftT y))|]
combineStylesheets' :: Bool
-> CombineSettings
-> Name
-> [Route Static]
-> 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) |]
combineScripts' :: Bool
-> CombineSettings
-> Name
-> [Route Static]
-> 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) |]