{-# 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 forall a b. (a -> b) -> a -> b
$ FilePath -> FileName
T.pack FilePath
f
let entry :: Entry
entry = forall a. Default a => a
def {
ebHaskellName :: Maybe Name
ebHaskellName = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FilePath -> Name
pathToName FilePath
loc
, ebLocation :: FilePath
ebLocation = FilePath
loc
, ebMimeType :: ByteString
ebMimeType = ByteString
mime
, ebProductionContent :: IO ByteString
ebProductionContent = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
BL.fromStrict (FilePath -> IO ByteString
BS.readFile FilePath
f)
, ebDevelReload :: ExpQ
ebDevelReload = [| fmap BL.fromStrict
(BS.readFile $(litE $ stringL f)) |]
}
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
[FilePath]
names <- forall a. Ord a => [a] -> [a]
sort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO [FilePath]
getDirectoryContents FilePath
topdir
let properNames :: [FilePath]
properNames = forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FilePath
".", FilePath
".."]) [FilePath]
names
[[(FilePath, FilePath)]]
paths <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [FilePath]
properNames forall a b. (a -> b) -> a -> b
$ \FilePath
name -> do
let path :: FilePath
path = FilePath
topdir FilePath -> FilePath -> FilePath
</> FilePath
name
let loc :: FilePath
loc = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
prefix then FilePath
name else FilePath
prefix forall a. [a] -> [a] -> [a]
++ FilePath
"/" forall a. [a] -> [a] -> [a]
++ FilePath
name
Bool
isDirectory <- FilePath -> IO Bool
doesDirectoryExist FilePath
path
if Bool
isDirectory
then FilePath -> FilePath -> IO [(FilePath, FilePath)]
getRecursiveContents FilePath
loc FilePath
path
else forall (m :: * -> *) a. Monad m => a -> m a
return [(FilePath
loc, FilePath
path)]
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(FilePath, FilePath)]]
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
[(FilePath, FilePath)]
files <- forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO [(FilePath, FilePath)]
getRecursiveContents FilePath
loc FilePath
dir
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FilePath -> FilePath -> Generator
embedFileAt) [(FilePath, FilePath)]
files
concatFiles :: Location -> [FilePath] -> Generator
concatFiles :: FilePath -> [FilePath] -> Generator
concatFiles FilePath
loc [FilePath]
files = FilePath
-> (ByteString -> IO ByteString) -> [FilePath] -> Generator
concatFilesWith FilePath
loc 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 forall a b. (a -> b) -> a -> b
$ FilePath
"Creating " forall a. [a] -> [a] -> [a]
++ FilePath
loc
[ByteString] -> ByteString
BL.concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO ByteString
BL.readFile [FilePath]
files forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> IO ByteString
process
expFiles :: ExpQ
expFiles = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (m :: * -> *). Quote m => Lit -> m Exp
litE forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Lit
stringL) [FilePath]
files
expCt :: ExpQ
expCt = [| BL.concat <$> mapM BL.readFile $expFiles |]
mime :: ByteString
mime = FileName -> ByteString
defaultMimeLookup forall a b. (a -> b) -> a -> b
$ FilePath -> FileName
T.pack FilePath
loc
forall (m :: * -> *) a. Monad m => a -> m a
return [forall a. Default a => a
def { ebHaskellName :: Maybe Name
ebHaskellName = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ FilePath -> Name
pathToName FilePath
loc
, ebLocation :: FilePath
ebLocation = FilePath
loc
, ebMimeType :: ByteString
ebMimeType = ByteString
mime
, ebProductionContent :: IO ByteString
ebProductionContent = IO ByteString
load
, ebDevelReload :: ExpQ
ebDevelReload = ExpQ
expCt
}]
jasmine :: BL.ByteString -> IO BL.ByteString
jasmine :: ByteString -> IO ByteString
jasmine ByteString
ct = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const ByteString
ct) forall a. a -> a
id 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
Maybe FilePath
mpath <- FilePath -> IO (Maybe FilePath)
findExecutable FilePath
f
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe FilePath
mpath) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$ FilePath
"Unable to find " forall a. [a] -> [a] -> [a]
++ FilePath
f
let p :: CreateProcess
p = (FilePath -> [FilePath] -> CreateProcess
Proc.proc FilePath
f [FilePath]
opts)
{ std_in :: StdStream
Proc.std_in = StdStream
Proc.CreatePipe
, std_out :: StdStream
Proc.std_out = StdStream
Proc.CreatePipe
}
(Just Handle
hin, Just Handle
hout, Maybe Handle
_, ProcessHandle
ph) <- CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
Proc.createProcess CreateProcess
p
(ByteString
compressed, (), ExitCode
code) <- forall a. Concurrently a -> IO a
runConcurrently forall a b. (a -> b) -> a -> b
$ (,,)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
A.<$> forall a. IO a -> Concurrently a
Concurrently (forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle Handle
hout 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)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
A.<*> forall a. IO a -> Concurrently a
Concurrently (Handle -> ByteString -> IO ()
BL.hPut Handle
hin ByteString
ct forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
hin)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
A.<*> forall a. IO a -> Concurrently a
Concurrently (ProcessHandle -> IO ExitCode
Proc.waitForProcess ProcessHandle
ph)
if ExitCode
code forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess
then do
FilePath -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ FilePath
"Compressed successfully with " forall a. [a] -> [a] -> [a]
++ FilePath
f
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
compressed
else forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ FilePath
"compressTool: compression failed with " forall a. [a] -> [a] -> [a]
++ FilePath
f
tryCompressTools :: [BL.ByteString -> IO BL.ByteString] -> BL.ByteString -> IO BL.ByteString
tryCompressTools :: [ByteString -> IO ByteString] -> ByteString -> IO ByteString
tryCompressTools [] ByteString
x = forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
tryCompressTools (ByteString -> IO ByteString
p:[ByteString -> IO ByteString]
ps) ByteString
x = do
Either SomeException ByteString
mres <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ ByteString -> IO ByteString
p ByteString
x
case Either SomeException ByteString
mres of
Left (SomeException
err :: SomeException) -> do
FilePath -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ 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 -> 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' 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
'_'
name :: FilePath
name = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
replace FilePath
f
routeName :: Name
routeName = FilePath -> Name
mkName forall a b. (a -> b) -> a -> b
$
case () of
()
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
name -> forall a. HasCallStack => FilePath -> a
error FilePath
"null-named file"
| Char -> Bool
isDigit (forall a. [a] -> a
head FilePath
name) -> Char
'_' forall a. a -> [a] -> [a]
: FilePath
name
| Char -> Bool
isLower (forall a. [a] -> a
head FilePath
name) -> FilePath
name
| Bool
otherwise -> Char
'_' forall a. a -> [a] -> [a]
: FilePath
name