{-# 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
hashLookup <- String -> IO ETagLookup
cachedETagLookup String
dir
return $ Static $ webAppSettingsWithLookup dir hashLookup
staticDevel :: FilePath -> IO Static
staticDevel :: String -> IO Static
staticDevel String
dir = do
hashLookup <- String -> IO ETagLookup
cachedETagLookupDevel String
dir
return $ Static $ webAppSettingsWithLookup dir hashLookup
embed :: FilePath -> Q Exp
embed :: String -> Q Exp
embed String
fp = [|Static (embeddedSettings $(String -> Q Exp
embedDir String
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
$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'
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
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
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)
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
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
-> Bool
-> 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
-> [[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 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
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
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 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 = (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
, 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))|]
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 . $(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) |]
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 . $(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) |]