{-# 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ StaticSettings -> Static
Static forall a b. (a -> b) -> a -> b
$ String -> ETagLookup -> StaticSettings
webAppSettingsWithLookup String
dir ETagLookup
hashLookup
staticDevel :: FilePath -> IO Static
staticDevel :: String -> IO Static
staticDevel String
dir = do
ETagLookup
hashLookup <- String -> IO ETagLookup
cachedETagLookupDevel String
dir
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ StaticSettings -> Static
Static forall a b. (a -> b) -> a -> b
$ String -> ETagLookup -> StaticSettings
webAppSettingsWithLookup String
dir ETagLookup
hashLookup
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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Route Static -> Route Static -> Bool
$c/= :: Route Static -> Route Static -> Bool
== :: Route Static -> Route Static -> Bool
$c== :: Route Static -> Route Static -> Bool
Eq, Int -> Route Static -> ShowS
[Route Static] -> ShowS
Route Static -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Route Static] -> ShowS
$cshowList :: [Route Static] -> ShowS
show :: Route Static -> String
$cshow :: Route Static -> String
showsPrec :: Int -> Route Static -> ShowS
$cshowsPrec :: Int -> Route Static -> ShowS
Show, ReadPrec [Route Static]
ReadPrec (Route Static)
Int -> ReadS (Route Static)
ReadS [Route Static]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Route Static]
$creadListPrec :: ReadPrec [Route Static]
readPrec :: ReadPrec (Route Static)
$creadPrec :: ReadPrec (Route Static)
readList :: ReadS [Route Static]
$creadList :: ReadS [Route Static]
readsPrec :: Int -> ReadS (Route Static)
$creadsPrec :: Int -> ReadS (Route Static)
Read)
renderRoute :: Route Static -> ([Text], [(Text, Text)])
renderRoute (StaticRoute [Text]
x [(Text, Text)]
y) = ([Text]
x, [(Text, Text)]
y)
instance ParseRoute Static where
parseRoute :: ([Text], [(Text, Text)]) -> Maybe (Route Static)
parseRoute ([Text]
x, [(Text, Text)]
y) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Text] -> [(Text, Text)] -> Route Static
StaticRoute [Text]
x [(Text, Text)]
y
instance YesodSubDispatch Static master where
yesodSubDispatch :: YesodSubRunnerEnv Static master -> Application
yesodSubDispatch YesodSubRunnerEnv {YesodRunnerEnv master
master -> Static
ParentRunner master
Route Static -> Route master
ysreToParentRoute :: forall sub parent.
YesodSubRunnerEnv sub parent -> Route sub -> Route parent
ysreParentRunner :: forall sub parent.
YesodSubRunnerEnv sub parent -> ParentRunner parent
ysreParentEnv :: forall sub parent.
YesodSubRunnerEnv sub parent -> YesodRunnerEnv parent
ysreGetSub :: forall sub parent. YesodSubRunnerEnv sub parent -> parent -> sub
ysreParentEnv :: YesodRunnerEnv master
ysreToParentRoute :: Route Static -> Route master
ysreGetSub :: master -> Static
ysreParentRunner :: ParentRunner master
..} Request
req =
ParentRunner master
ysreParentRunner HandlerFor master TypedContent
handlert YesodRunnerEnv master
ysreParentEnv (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Route Static -> Route master
ysreToParentRoute Maybe (Route Static)
route) Request
req
where
route :: Maybe (Route Static)
route = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Text] -> [(Text, Text)] -> Route Static
StaticRoute (Request -> [Text]
pathInfo Request
req) []
Static StaticSettings
set = master -> Static
ysreGetSub forall a b. (a -> b) -> a -> b
$ forall site. YesodRunnerEnv site -> site
yreSite forall a b. (a -> b) -> a -> b
$ YesodRunnerEnv master
ysreParentEnv
handlert :: HandlerFor master TypedContent
handlert = forall (m :: * -> *) b. MonadHandler m => Application -> m b
sendWaiApplication forall a b. (a -> b) -> a -> b
$ StaticSettings -> Application
staticApp StaticSettings
set
notHidden :: FilePath -> Bool
notHidden :: String -> Bool
notHidden String
"tmp" = Bool
False
notHidden String
s =
case String
s of
Char
'.':String
_ -> Bool
False
String
_ -> Bool
True
getFileListPieces :: FilePath -> IO [[String]]
getFileListPieces :: String -> IO [[String]]
getFileListPieces = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT forall k a. Map k a
M.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip String
-> ([String] -> [String])
-> StateT (Map String String) IO [[String]]
go forall a. a -> a
id
where
go :: String
-> ([String] -> [String])
-> StateT (M.Map String String) IO [[String]]
go :: String
-> ([String] -> [String])
-> StateT (Map String String) IO [[String]]
go String
fp [String] -> [String]
front = do
[String]
allContents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ (forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
notHidden) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO [String]
getDirectoryContents String
fp
let fullPath :: String -> String
fullPath :: ShowS
fullPath String
f = String
fp forall a. [a] -> [a] -> [a]
++ Char
'/' forall a. a -> [a] -> [a]
: String
f
[String]
files <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
doesFileExist forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
fullPath) [String]
allContents
let files' :: [[String]]
files' = forall a b. (a -> b) -> [a] -> [b]
map ([String] -> [String]
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return) [String]
files
[[String]]
files'' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [String] -> StateT (Map String String) IO [String]
dedupe [[String]]
files'
[String]
dirs <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (String -> IO Bool
doesDirectoryExist forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
fullPath) [String]
allContents
[[[String]]]
dirs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\String
f -> String
-> ([String] -> [String])
-> StateT (Map String String) IO [[String]]
go (ShowS
fullPath String
f) ([String] -> [String]
front forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:) String
f)) [String]
dirs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ [[String]]
files'' forall a. a -> [a] -> [a]
: [[[String]]]
dirs'
dedupe :: [String] -> StateT (M.Map String String) IO [String]
dedupe :: [String] -> StateT (Map String String) IO [String]
dedupe = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> StateT (Map String String) IO String
dedupe'
dedupe' :: String -> StateT (M.Map String String) IO String
dedupe' :: String -> StateT (Map String String) IO String
dedupe' String
s = do
Map String String
m <- forall (m :: * -> *) s. Monad m => StateT s m s
get
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
s Map String String
m of
Just String
s' -> forall (m :: * -> *) a. Monad m => a -> m a
return String
s'
Maybe String
Nothing -> do
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
s String
s Map String String
m
forall (m :: * -> *) a. Monad m => a -> m a
return String
s
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 (forall a b. (a -> b) -> [a] -> [b]
map String -> [String]
split [String]
fs) Bool
True
where
split :: FilePath -> [String]
split :: String -> [String]
split [] = []
split String
x =
let (String
a, String
b) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'/') String
x
in String
a forall a. a -> [a] -> [a]
: String -> [String]
split (forall a. Int -> [a] -> [a]
drop Int
1 String
b)
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 (forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> ([String], [String])
splitBoth [(String, String)]
mapList) Bool
True
where
splitBoth :: (String, String) -> ([String], [String])
splitBoth (String
k, String
v) = (String -> [String]
split String
k, String -> [String]
split String
v)
mapList :: [(String, String)]
mapList = forall k a. Map k a -> [(k, a)]
M.toList Map String String
m
split :: FilePath -> [String]
split :: String -> [String]
split [] = []
split String
x =
let (String
a, String
b) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'/') String
x
in String
a forall a. a -> [a] -> [a]
: String -> [String]
split (forall a. Int -> [a] -> [a]
drop Int
1 String
b)
staticFilesMergeMap :: FilePath -> M.Map FilePath FilePath -> Q [Dec]
staticFilesMergeMap :: String -> Map String String -> Q [Dec]
staticFilesMergeMap String
fp Map String String
m = do
[[String]]
fs <- forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ String -> IO [[String]]
getFileListPieces String
fp
let filesList :: [String]
filesList = forall a b. (a -> b) -> [a] -> [b]
map [String] -> String
FP.joinPath [[String]]
fs
mergedMapList :: [(String, String)]
mergedMapList = forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Map String String
-> Map String String -> String -> Map String String
checkedInsert Map String String
invertedMap) Map String String
m [String]
filesList
String -> [([String], [String])] -> Bool -> Q [Dec]
mkStaticFilesList' String
fp (forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> ([String], [String])
splitBoth [(String, String)]
mergedMapList) Bool
True
where
splitBoth :: (String, String) -> ([String], [String])
splitBoth (String
k, String
v) = (String -> [String]
split String
k, String -> [String]
split String
v)
swap :: (b, a) -> (a, b)
swap (b
x, a
y) = (a
y, b
x)
mapList :: [(String, String)]
mapList = forall k a. Map k a -> [(k, a)]
M.toList Map String String
m
invertedMap :: Map String String
invertedMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {b} {a}. (b, a) -> (a, b)
swap [(String, String)]
mapList
split :: FilePath -> [String]
split :: String -> [String]
split [] = []
split String
x =
let (String
a, String
b) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'/') String
x
in String
a forall a. a -> [a] -> [a]
: String -> [String]
split (forall a. Int -> [a] -> [a]
drop Int
1 String
b)
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 forall k a. Ord k => k -> Map k a -> Bool
M.member String
p Map String String
iDict
then Map String String
st
else forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
p String
p Map String String
st
mkHashMap :: FilePath -> IO (M.Map FilePath S8.ByteString)
mkHashMap :: String -> IO (Map String ByteString)
mkHashMap String
dir = do
[[String]]
fs <- String -> IO [[String]]
getFileListPieces String
dir
[[String]] -> IO [(String, ByteString)]
hashAlist [[String]]
fs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
where
hashAlist :: [[String]] -> IO [(FilePath, S8.ByteString)]
hashAlist :: [[String]] -> IO [(String, ByteString)]
hashAlist [[String]]
fs = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [String] -> IO (String, ByteString)
hashPair [[String]]
fs
where
hashPair :: [String] -> IO (FilePath, S8.ByteString)
hashPair :: [String] -> IO (String, ByteString)
hashPair [String]
pieces = do let file :: String
file = String -> [String] -> String
pathFromRawPieces String
dir [String]
pieces
String
h <- String -> IO String
base64md5File String
file
forall (m :: * -> *) a. Monad m => a -> m a
return (String
file, String -> ByteString
S8.pack String
h)
pathFromRawPieces :: FilePath -> [String] -> FilePath
pathFromRawPieces :: String -> [String] -> String
pathFromRawPieces =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' String -> ShowS
append
where
append :: String -> ShowS
append String
a String
b = String
a forall a. [a] -> [a] -> [a]
++ Char
'/' forall a. a -> [a] -> [a]
: String
b
cachedETagLookupDevel :: FilePath -> IO ETagLookup
cachedETagLookupDevel :: String -> IO ETagLookup
cachedETagLookupDevel String
dir = do
Map String ByteString
etags <- String -> IO (Map String ByteString)
mkHashMap String
dir
IORef (Map String EpochTime)
mtimeVar <- forall a. a -> IO (IORef a)
newIORef (forall k a. Map k a
M.empty :: M.Map FilePath EpochTime)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \String
f ->
case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
f Map String ByteString
etags of
Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just ByteString
checksum -> do
FileStatus
fs <- String -> IO FileStatus
getFileStatus String
f
let newt :: EpochTime
newt = FileStatus -> EpochTime
modificationTime FileStatus
fs
Map String EpochTime
mtimes <- forall a. IORef a -> IO a
readIORef IORef (Map String EpochTime)
mtimeVar
EpochTime
oldt <- case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
f Map String EpochTime
mtimes of
Maybe EpochTime
Nothing -> forall a. IORef a -> a -> IO ()
writeIORef IORef (Map String EpochTime)
mtimeVar (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
f EpochTime
newt Map String EpochTime
mtimes) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return EpochTime
newt
Just EpochTime
oldt -> forall (m :: * -> *) a. Monad m => a -> m a
return EpochTime
oldt
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if EpochTime
newt forall a. Eq a => a -> a -> Bool
/= EpochTime
oldt then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just ByteString
checksum
cachedETagLookup :: FilePath -> IO ETagLookup
cachedETagLookup :: String -> IO ETagLookup
cachedETagLookup String
dir = do
Map String ByteString
etags <- String -> IO (Map String ByteString)
mkHashMap String
dir
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (\String
f -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
f Map String ByteString
etags)
mkStaticFiles :: FilePath -> Q [Dec]
mkStaticFiles :: String -> Q [Dec]
mkStaticFiles String
fp = String -> Bool -> Q [Dec]
mkStaticFiles' String
fp Bool
True
mkStaticFiles' :: FilePath
-> Bool
-> Q [Dec]
mkStaticFiles' :: String -> Bool -> Q [Dec]
mkStaticFiles' String
fp Bool
makeHash = do
[[String]]
fs <- forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ String -> IO [[String]]
getFileListPieces String
fp
String -> [[String]] -> Bool -> Q [Dec]
mkStaticFilesList String
fp [[String]]
fs Bool
makeHash
mkStaticFilesList
:: FilePath
-> [[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 (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
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([String], [String]) -> Q [Dec]
mkRoute [([String], [String])]
fs
where
replace' :: Char -> Char
replace' Char
c
| Char
'A' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'Z' = Char
c
| Char
'a' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'z' = Char
c
| Char
'0' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'9' = Char
c
| Bool
otherwise = Char
'_'
mkRoute :: ([String], [String]) -> Q [Dec]
mkRoute ([String]
alias, [String]
f) = do
let name' :: String
name' = forall a. [a] -> [[a]] -> [a]
intercalate String
"_" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
replace') [String]
alias
routeName :: Name
routeName = String -> Name
mkName forall a b. (a -> b) -> a -> b
$
case () of
()
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
name' -> forall a. HasCallStack => String -> a
error String
"null-named file"
| Char -> Bool
isDigit (forall a. [a] -> a
head String
name') -> Char
'_' forall a. a -> [a] -> [a]
: String
name'
| Char -> Bool
isLower (forall a. [a] -> a
head String
name') -> String
name'
| Bool
otherwise -> Char
'_' forall a. a -> [a] -> [a]
: String
name'
Exp
f' <- [|map pack $(TH.lift f)|]
Exp
qs <- if Bool
makeHash
then do String
hash <- forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ String -> IO String
base64md5File forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
pathFromRawPieces String
fp [String]
f
[|[(pack "etag", pack $(TH.lift hash))]|]
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
ListE []
forall (m :: * -> *) a. Monad m => a -> m a
return
[ Name -> Type -> Dec
SigD Name
routeName forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT ''StaticRoute
, Name -> [Clause] -> Dec
FunD Name
routeName
[ [Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB forall a b. (a -> b) -> a -> b
$ (Name -> Exp
ConE 'StaticRoute) Exp -> Exp -> Exp
`AppE` Exp
f' Exp -> Exp -> Exp
`AppE` Exp
qs) []
]
]
base64md5File :: FilePath -> IO String
base64md5File :: String -> IO String
base64md5File = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> String
base64 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {bout}. ByteArray bout => Digest MD5 -> bout
encode) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) hash.
(MonadIO m, HashAlgorithm hash) =>
String -> m (Digest hash)
hashFile
where encode :: Digest MD5 -> bout
encode Digest MD5
d = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (Digest MD5
d :: Digest MD5)
base64md5 :: L.ByteString -> String
base64md5 :: ByteString -> String
base64md5 ByteString
lbs =
ByteString -> String
base64 forall a b. (a -> b) -> a -> b
$ forall {bout}. ByteArray bout => Digest MD5 -> bout
encode
forall a b. (a -> b) -> a -> b
$ forall r. ConduitT () Void Identity r -> r
runConduitPure
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) lazy strict i.
(Monad m, LazySequence lazy strict) =>
lazy -> ConduitT i strict m ()
Conduit.sourceLazy ByteString
lbs forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) hash.
(Monad m, HashAlgorithm hash) =>
Consumer ByteString m (Digest hash)
sinkHash
where
encode :: Digest MD5 -> bout
encode Digest MD5
d = forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
ByteArray.convert (Digest MD5
d :: Digest MD5)
base64 :: S.ByteString -> String
base64 :: ByteString -> String
base64 = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
tr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
S8.unpack
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Data.ByteString.Base64.encode
where
tr :: Char -> Char
tr Char
'+' = Char
'-'
tr Char
'/' = Char
'_'
tr Char
c = Char
c
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 <- forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) mono i.
(Monad m, MonoFoldable mono) =>
mono -> ConduitT i (Element mono) m ()
yieldMany [String]
fps
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) i o r.
Monad m =>
(i -> ConduitT i o m r) -> ConduitT i o m ()
awaitForever forall {m :: * -> *} {a}.
(MonadResource m, MonadThrow m) =>
String -> ConduitT a Text m ()
readUTFFile
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) lazy strict o.
(Monad m, LazySequence lazy strict) =>
ConduitT strict o m lazy
sinkLazy
Text
ltext <- forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ Text -> IO Text
preProcess Text
texts
ByteString
bs <- forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ [String] -> ByteString -> IO ByteString
postProcess [String]
fps forall a b. (a -> b) -> a -> b
$ Text -> ByteString
TLE.encodeUtf8 Text
ltext
let hash' :: String
hash' = ByteString -> String
base64md5 ByteString
bs
suffix :: String
suffix = String
csCombinedFolder String -> ShowS
</> String
hash' String -> ShowS
<.> String
extension
fp :: String
fp = String
csStaticDir String -> ShowS
</> String
suffix
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ do
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ ShowS
takeDirectory String
fp
String -> ByteString -> IO ()
L.writeFile String
fp ByteString
bs
let pieces :: [String]
pieces = forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"/" forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
suffix
[|StaticRoute (map pack pieces) []|]
where
fps :: [FilePath]
fps :: [String]
fps = forall a b. (a -> b) -> [a] -> [b]
map Route Static -> String
toFP [Route Static]
routes
toFP :: Route Static -> String
toFP (StaticRoute [Text]
pieces [(Text, Text)]
_) = String
csStaticDir String -> ShowS
</> [String] -> String
F.joinPath (forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack [Text]
pieces)
readUTFFile :: String -> ConduitT a Text m ()
readUTFFile String
fp = forall (m :: * -> *) i.
MonadResource m =>
String -> ConduitT i ByteString m ()
sourceFile String
fp forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *). MonadThrow m => ConduitT ByteString Text m ()
decodeUtf8C
postProcess :: [String] -> ByteString -> IO ByteString
postProcess =
case CombineType
combineType of
CombineType
JS -> [String] -> ByteString -> IO ByteString
csJsPostProcess
CombineType
CSS -> [String] -> ByteString -> IO ByteString
csCssPostProcess
preProcess :: Text -> IO Text
preProcess =
case CombineType
combineType of
CombineType
JS -> Text -> IO Text
csJsPreProcess
CombineType
CSS -> Text -> IO Text
csCssPreProcess
extension :: String
extension =
case CombineType
combineType of
CombineType
JS -> String
"js"
CombineType
CSS -> String
"css"
data 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
{ csStaticDir :: String
csStaticDir = String
"static"
, csCssPostProcess :: [String] -> ByteString -> IO ByteString
csCssPostProcess = forall a b. a -> b -> a
const forall (m :: * -> *) a. Monad m => a -> m a
return
, csJsPostProcess :: [String] -> ByteString -> IO ByteString
csJsPostProcess = forall a b. a -> b -> a
const forall (m :: * -> *) a. Monad m => a -> m a
return
, csCssPreProcess :: Text -> IO Text
csCssPreProcess =
forall (m :: * -> *) a. Monad m => a -> m a
return
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
TL.replace Text
"'/static/" Text
"'../"
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text -> Text
TL.replace Text
"\"/static/" Text
"\"../"
, csJsPreProcess :: Text -> IO Text
csJsPreProcess = forall (m :: * -> *) a. Monad m => a -> m a
return
, csCombinedFolder :: String
csCombinedFolder = String
"combined"
}
liftRoutes :: [Route Static] -> Q Exp
liftRoutes :: [Route Static] -> Q Exp
liftRoutes =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Route Static -> Q Exp
go
where
go :: Route Static -> Q Exp
go :: Route Static -> Q Exp
go (StaticRoute [Text]
x [(Text, Text)]
y) = [|StaticRoute $(liftTexts x) $(liftPairs y)|]
liftTexts :: [Text] -> Q Exp
liftTexts = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}. Quote m => Text -> m Exp
liftT
liftT :: Text -> m Exp
liftT Text
t = [|pack $(TH.lift $ T.unpack t)|]
liftPairs :: [(Text, Text)] -> Q Exp
liftPairs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Exp] -> Exp
ListE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}. Quote m => (Text, Text) -> m Exp
liftPair
liftPair :: (Text, Text) -> m Exp
liftPair (Text
x, Text
y) = [|($(liftT x), $(liftT y))|]
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) |]