{-# LANGUAGE TemplateHaskell, QuasiQuotes, ScopedTypeVariables #-}
module Yesod.EmbeddedStatic.Generators (
Location
, embedFile
, embedFileAt
, embedDir
, embedDirAt
, concatFiles
, concatFilesWith
, jasmine
, uglifyJs
, yuiJavascript
, yuiCSS
, closureJs
, compressTool
, tryCompressTools
, pathToName
) where
import Control.Applicative as A ((<$>), (<*>))
import Control.Exception (try, SomeException)
import Control.Monad (forM, when)
import Data.Char (isDigit, isLower)
import Data.Default (def)
import Data.Maybe (isNothing)
import Language.Haskell.TH
import Network.Mime (defaultMimeLookup)
import System.Directory (doesDirectoryExist, getDirectoryContents, findExecutable)
import System.FilePath ((</>))
import Text.Jasmine (minifym)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Conduit
import qualified Data.Text as T
import qualified System.Process as Proc
import System.Exit (ExitCode (ExitSuccess))
import Control.Concurrent.Async (Concurrently (..))
import System.IO (hClose)
import Data.List (sort)
import Yesod.EmbeddedStatic.Types
embedFile :: FilePath -> Generator
embedFile :: FilePath -> Generator
embedFile FilePath
f = FilePath -> FilePath -> Generator
embedFileAt FilePath
f FilePath
f
embedFileAt :: Location -> FilePath -> Generator
embedFileAt :: FilePath -> FilePath -> Generator
embedFileAt FilePath
loc FilePath
f = do
let mime :: ByteString
mime = FileName -> ByteString
defaultMimeLookup (FileName -> ByteString) -> FileName -> ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> FileName
T.pack FilePath
f
let entry :: Entry
entry = Entry
forall a. Default a => a
def {
ebHaskellName = Just $ pathToName loc
, ebLocation = loc
, ebMimeType = mime
, ebProductionContent = fmap BL.fromStrict (BS.readFile f)
, ebDevelReload = [| fmap BL.fromStrict
(BS.readFile $(litE $ stringL f)) |]
}
[Entry] -> Generator
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Entry
entry]
getRecursiveContents :: Location
-> FilePath
-> IO [(Location,FilePath)]
getRecursiveContents :: FilePath -> FilePath -> IO [(FilePath, FilePath)]
getRecursiveContents FilePath
prefix FilePath
topdir = do
names <- [FilePath] -> [FilePath]
forall a. Ord a => [a] -> [a]
sort ([FilePath] -> [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
getDirectoryContents FilePath
topdir
let properNames = (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FilePath
".", FilePath
".."]) [FilePath]
names
paths <- forM properNames $ \FilePath
name -> do
let path :: FilePath
path = FilePath
topdir FilePath -> FilePath -> FilePath
</> FilePath
name
let loc :: FilePath
loc = if FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
prefix then FilePath
name else FilePath
prefix FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
name
isDirectory <- FilePath -> IO Bool
doesDirectoryExist FilePath
path
if isDirectory
then getRecursiveContents loc path
else return [(loc, path)]
return (concat paths)
embedDir :: FilePath -> Generator
embedDir :: FilePath -> Generator
embedDir = FilePath -> FilePath -> Generator
embedDirAt FilePath
""
embedDirAt :: Location -> FilePath -> Generator
embedDirAt :: FilePath -> FilePath -> Generator
embedDirAt FilePath
loc FilePath
dir = do
files <- IO [(FilePath, FilePath)] -> Q [(FilePath, FilePath)]
forall a. IO a -> Q a
runIO (IO [(FilePath, FilePath)] -> Q [(FilePath, FilePath)])
-> IO [(FilePath, FilePath)] -> Q [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO [(FilePath, FilePath)]
getRecursiveContents FilePath
loc FilePath
dir
concat <$> mapM (uncurry embedFileAt) files
concatFiles :: Location -> [FilePath] -> Generator
concatFiles :: FilePath -> [FilePath] -> Generator
concatFiles FilePath
loc [FilePath]
files = FilePath
-> (ByteString -> IO ByteString) -> [FilePath] -> Generator
concatFilesWith FilePath
loc ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [FilePath]
files
concatFilesWith :: Location -> (BL.ByteString -> IO BL.ByteString) -> [FilePath] -> Generator
concatFilesWith :: FilePath
-> (ByteString -> IO ByteString) -> [FilePath] -> Generator
concatFilesWith FilePath
loc ByteString -> IO ByteString
process [FilePath]
files = do
let load :: IO ByteString
load = do FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Creating " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
loc
[ByteString] -> ByteString
BL.concat ([ByteString] -> ByteString) -> IO [ByteString] -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (FilePath -> IO ByteString) -> [FilePath] -> IO [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 FilePath -> IO ByteString
BL.readFile [FilePath]
files IO ByteString -> (ByteString -> IO ByteString) -> IO ByteString
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO ByteString
process
expFiles :: Q Exp
expFiles = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (FilePath -> Q Exp) -> [FilePath] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (Lit -> Q Exp
forall (m :: * -> *). Quote m => Lit -> m Exp
litE (Lit -> Q Exp) -> (FilePath -> Lit) -> FilePath -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Lit
stringL) [FilePath]
files
expCt :: Q Exp
expCt = [| BL.concat <$> mapM BL.readFile $Q Exp
expFiles |]
mime :: ByteString
mime = FileName -> ByteString
defaultMimeLookup (FileName -> ByteString) -> FileName -> ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> FileName
T.pack FilePath
loc
[Entry] -> Generator
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Entry
forall a. Default a => a
def { ebHaskellName = Just $ pathToName loc
, ebLocation = loc
, ebMimeType = mime
, ebProductionContent = load
, ebDevelReload = expCt
}]
jasmine :: BL.ByteString -> IO BL.ByteString
jasmine :: ByteString -> IO ByteString
jasmine ByteString
ct = ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ (FilePath -> ByteString)
-> (ByteString -> ByteString)
-> Either FilePath ByteString
-> ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ByteString -> FilePath -> ByteString
forall a b. a -> b -> a
const ByteString
ct) ByteString -> ByteString
forall a. a -> a
id (Either FilePath ByteString -> ByteString)
-> Either FilePath ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Either FilePath ByteString
minifym ByteString
ct
uglifyJs :: BL.ByteString -> IO BL.ByteString
uglifyJs :: ByteString -> IO ByteString
uglifyJs = FilePath -> [FilePath] -> ByteString -> IO ByteString
compressTool FilePath
"uglifyjs" [FilePath
"-", FilePath
"-m", FilePath
"-c"]
yuiJavascript :: BL.ByteString -> IO BL.ByteString
yuiJavascript :: ByteString -> IO ByteString
yuiJavascript = FilePath -> [FilePath] -> ByteString -> IO ByteString
compressTool FilePath
"yuicompressor" [FilePath
"--type", FilePath
"js"]
yuiCSS :: BL.ByteString -> IO BL.ByteString
yuiCSS :: ByteString -> IO ByteString
yuiCSS = FilePath -> [FilePath] -> ByteString -> IO ByteString
compressTool FilePath
"yuicompressor" [FilePath
"--type", FilePath
"css"]
closureJs :: BL.ByteString -> IO BL.ByteString
closureJs :: ByteString -> IO ByteString
closureJs = FilePath -> [FilePath] -> ByteString -> IO ByteString
compressTool FilePath
"closure" []
compressTool :: FilePath
-> [String]
-> BL.ByteString -> IO BL.ByteString
compressTool :: FilePath -> [FilePath] -> ByteString -> IO ByteString
compressTool FilePath
f [FilePath]
opts ByteString
ct = do
mpath <- FilePath -> IO (Maybe FilePath)
findExecutable FilePath
f
when (isNothing mpath) $
fail $ "Unable to find " ++ f
let p = (FilePath -> [FilePath] -> CreateProcess
Proc.proc FilePath
f [FilePath]
opts)
{ Proc.std_in = Proc.CreatePipe
, Proc.std_out = Proc.CreatePipe
}
(Just hin, Just hout, _, ph) <- Proc.createProcess p
(compressed, (), code) <- runConcurrently $ (,,)
A.<$> Concurrently (runConduit $ sourceHandle hout .| sinkLazy)
A.<*> Concurrently (BL.hPut hin ct >> hClose hin)
A.<*> Concurrently (Proc.waitForProcess ph)
if code == ExitSuccess
then do
putStrLn $ "Compressed successfully with " ++ f
return compressed
else error $ "compressTool: compression failed with " ++ f
tryCompressTools :: [BL.ByteString -> IO BL.ByteString] -> BL.ByteString -> IO BL.ByteString
tryCompressTools :: [ByteString -> IO ByteString] -> ByteString -> IO ByteString
tryCompressTools [] ByteString
x = ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
tryCompressTools (ByteString -> IO ByteString
p:[ByteString -> IO ByteString]
ps) ByteString
x = do
mres <- IO ByteString -> IO (Either SomeException ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO ByteString -> IO (Either SomeException ByteString))
-> IO ByteString -> IO (Either SomeException ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> IO ByteString
p ByteString
x
case mres of
Left (SomeException
err :: SomeException) -> do
FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
err
[ByteString -> IO ByteString] -> ByteString -> IO ByteString
tryCompressTools [ByteString -> IO ByteString]
ps ByteString
x
Right ByteString
res -> ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
res
pathToName :: FilePath -> Name
pathToName :: FilePath -> Name
pathToName FilePath
f = Name
routeName
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
'_'
name :: FilePath
name = (Char -> Char) -> FilePath -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
replace FilePath
f
routeName :: Name
routeName = FilePath -> Name
mkName (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$
case () of
()
| FilePath -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
name -> FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
error FilePath
"null-named file"
| Char -> Bool
isDigit (FilePath -> Char
forall a. HasCallStack => [a] -> a
head FilePath
name) -> Char
'_' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
name
| Char -> Bool
isLower (FilePath -> Char
forall a. HasCallStack => [a] -> a
head FilePath
name) -> FilePath
name
| Bool
otherwise -> Char
'_' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
name