{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
module Yesod.Default.Util
( addStaticContentExternal
, globFile
, globFilePackage
, widgetFileNoReload
, widgetFileReload
, TemplateLanguage (..)
, defaultTemplateLanguages
, WidgetFileSettings
, wfsLanguages
, wfsHamletSettings
) where
import qualified Data.ByteString.Lazy as L
import Data.FileEmbed (makeRelativeToProject)
import Data.Text (Text, pack, unpack)
import Yesod.Core
import Control.Monad (when, unless)
import Conduit
import System.Directory (doesFileExist, createDirectoryIfMissing)
import Language.Haskell.TH.Syntax
import Text.Lucius (luciusFile, luciusFileReload)
import Text.Julius (juliusFile, juliusFileReload)
import Text.Cassius (cassiusFile, cassiusFileReload)
import Text.Hamlet (HamletSettings, defaultHamletSettings)
import Data.Maybe (catMaybes)
import Data.Default.Class (Default (def))
addStaticContentExternal
:: (L.ByteString -> Either a L.ByteString)
-> (L.ByteString -> String)
-> FilePath
-> ([Text] -> Route master)
-> Text
-> Text
-> L.ByteString
-> HandlerFor master (Maybe (Either Text (Route master, [(Text, Text)])))
addStaticContentExternal :: (ByteString -> Either a ByteString)
-> (ByteString -> String)
-> String
-> ([Text] -> Route master)
-> Text
-> Text
-> ByteString
-> HandlerFor
master (Maybe (Either Text (Route master, [(Text, Text)])))
addStaticContentExternal minify :: ByteString -> Either a ByteString
minify hash :: ByteString -> String
hash staticDir :: String
staticDir toRoute :: [Text] -> Route master
toRoute ext' :: Text
ext' _ content :: ByteString
content = do
IO () -> HandlerFor master ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> HandlerFor master ()) -> IO () -> HandlerFor master ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
statictmp
Bool
exists <- IO Bool -> HandlerFor master Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> HandlerFor master Bool)
-> IO Bool -> HandlerFor master Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
fn'
Bool -> HandlerFor master () -> HandlerFor master ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists (HandlerFor master () -> HandlerFor master ())
-> HandlerFor master () -> HandlerFor master ()
forall a b. (a -> b) -> a -> b
$ String
-> (ConduitM ByteString Void (HandlerFor master) ()
-> HandlerFor master ())
-> HandlerFor master ()
forall (m :: * -> *) (n :: * -> *) o a.
(MonadUnliftIO m, MonadIO n) =>
String -> (ConduitM ByteString o n () -> m a) -> m a
withSinkFileCautious String
fn' ((ConduitM ByteString Void (HandlerFor master) ()
-> HandlerFor master ())
-> HandlerFor master ())
-> (ConduitM ByteString Void (HandlerFor master) ()
-> HandlerFor master ())
-> HandlerFor master ()
forall a b. (a -> b) -> a -> b
$ \sink :: ConduitM ByteString Void (HandlerFor master) ()
sink ->
ConduitT () Void (HandlerFor master) () -> HandlerFor master ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void (HandlerFor master) () -> HandlerFor master ())
-> ConduitT () Void (HandlerFor master) () -> HandlerFor master ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ConduitT () ByteString (HandlerFor master) ()
forall (m :: * -> *) lazy strict i.
(Monad m, LazySequence lazy strict) =>
lazy -> ConduitT i strict m ()
sourceLazy ByteString
content' ConduitT () ByteString (HandlerFor master) ()
-> ConduitM ByteString Void (HandlerFor master) ()
-> ConduitT () Void (HandlerFor master) ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM ByteString Void (HandlerFor master) ()
sink
Maybe (Either Text (Route master, [(Text, Text)]))
-> HandlerFor
master (Maybe (Either Text (Route master, [(Text, Text)])))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either Text (Route master, [(Text, Text)]))
-> HandlerFor
master (Maybe (Either Text (Route master, [(Text, Text)]))))
-> Maybe (Either Text (Route master, [(Text, Text)]))
-> HandlerFor
master (Maybe (Either Text (Route master, [(Text, Text)])))
forall a b. (a -> b) -> a -> b
$ Either Text (Route master, [(Text, Text)])
-> Maybe (Either Text (Route master, [(Text, Text)]))
forall a. a -> Maybe a
Just (Either Text (Route master, [(Text, Text)])
-> Maybe (Either Text (Route master, [(Text, Text)])))
-> Either Text (Route master, [(Text, Text)])
-> Maybe (Either Text (Route master, [(Text, Text)]))
forall a b. (a -> b) -> a -> b
$ (Route master, [(Text, Text)])
-> Either Text (Route master, [(Text, Text)])
forall a b. b -> Either a b
Right ([Text] -> Route master
toRoute ["tmp", String -> Text
pack String
fn], [])
where
fn, statictmp, fn' :: FilePath
fn :: String
fn = ByteString -> String
hash ByteString
content String -> String -> String
forall a. [a] -> [a] -> [a]
++ '.' Char -> String -> String
forall a. a -> [a] -> [a]
: Text -> String
unpack Text
ext'
statictmp :: String
statictmp = String
staticDir String -> String -> String
forall a. [a] -> [a] -> [a]
++ "/tmp/"
fn' :: String
fn' = String
statictmp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fn
content' :: L.ByteString
content' :: ByteString
content'
| Text
ext' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "js" = (a -> ByteString)
-> (ByteString -> ByteString) -> Either a ByteString -> ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ByteString -> a -> ByteString
forall a b. a -> b -> a
const ByteString
content) ByteString -> ByteString
forall a. a -> a
id (Either a ByteString -> ByteString)
-> Either a ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Either a ByteString
minify ByteString
content
| Bool
otherwise = ByteString
content
globFile :: String -> String -> FilePath
globFile :: String -> String -> String
globFile kind :: String
kind x :: String
x = "templates/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ "." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
kind
globFilePackage :: String -> String -> Q FilePath
globFilePackage :: String -> String -> Q String
globFilePackage = (String -> Q String
makeRelativeToProject (String -> Q String) -> (String -> String) -> String -> Q String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) ((String -> String) -> String -> Q String)
-> (String -> String -> String) -> String -> String -> Q String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
globFile
data TemplateLanguage = TemplateLanguage
{ TemplateLanguage -> Bool
tlRequiresToWidget :: Bool
, TemplateLanguage -> String
tlExtension :: String
, TemplateLanguage -> String -> Q Exp
tlNoReload :: FilePath -> Q Exp
, TemplateLanguage -> String -> Q Exp
tlReload :: FilePath -> Q Exp
}
defaultTemplateLanguages :: HamletSettings -> [TemplateLanguage]
defaultTemplateLanguages :: HamletSettings -> [TemplateLanguage]
defaultTemplateLanguages hset :: HamletSettings
hset =
[ Bool
-> String
-> (String -> Q Exp)
-> (String -> Q Exp)
-> TemplateLanguage
TemplateLanguage Bool
False "hamlet" String -> Q Exp
whamletFile' String -> Q Exp
whamletFile'
, Bool
-> String
-> (String -> Q Exp)
-> (String -> Q Exp)
-> TemplateLanguage
TemplateLanguage Bool
True "cassius" String -> Q Exp
cassiusFile String -> Q Exp
cassiusFileReload
, Bool
-> String
-> (String -> Q Exp)
-> (String -> Q Exp)
-> TemplateLanguage
TemplateLanguage Bool
True "julius" String -> Q Exp
juliusFile String -> Q Exp
juliusFileReload
, Bool
-> String
-> (String -> Q Exp)
-> (String -> Q Exp)
-> TemplateLanguage
TemplateLanguage Bool
True "lucius" String -> Q Exp
luciusFile String -> Q Exp
luciusFileReload
]
where
whamletFile' :: String -> Q Exp
whamletFile' = HamletSettings -> String -> Q Exp
whamletFileWithSettings HamletSettings
hset
data WidgetFileSettings = WidgetFileSettings
{ WidgetFileSettings -> HamletSettings -> [TemplateLanguage]
wfsLanguages :: HamletSettings -> [TemplateLanguage]
, WidgetFileSettings -> HamletSettings
wfsHamletSettings :: HamletSettings
}
instance Default WidgetFileSettings where
def :: WidgetFileSettings
def = (HamletSettings -> [TemplateLanguage])
-> HamletSettings -> WidgetFileSettings
WidgetFileSettings HamletSettings -> [TemplateLanguage]
defaultTemplateLanguages HamletSettings
defaultHamletSettings
widgetFileNoReload :: WidgetFileSettings -> FilePath -> Q Exp
widgetFileNoReload :: WidgetFileSettings -> String -> Q Exp
widgetFileNoReload wfs :: WidgetFileSettings
wfs x :: String
x = String -> String -> Bool -> [TemplateLanguage] -> Q Exp
combine "widgetFileNoReload" String
x Bool
False ([TemplateLanguage] -> Q Exp) -> [TemplateLanguage] -> Q Exp
forall a b. (a -> b) -> a -> b
$ WidgetFileSettings -> HamletSettings -> [TemplateLanguage]
wfsLanguages WidgetFileSettings
wfs (HamletSettings -> [TemplateLanguage])
-> HamletSettings -> [TemplateLanguage]
forall a b. (a -> b) -> a -> b
$ WidgetFileSettings -> HamletSettings
wfsHamletSettings WidgetFileSettings
wfs
widgetFileReload :: WidgetFileSettings -> FilePath -> Q Exp
widgetFileReload :: WidgetFileSettings -> String -> Q Exp
widgetFileReload wfs :: WidgetFileSettings
wfs x :: String
x = String -> String -> Bool -> [TemplateLanguage] -> Q Exp
combine "widgetFileReload" String
x Bool
True ([TemplateLanguage] -> Q Exp) -> [TemplateLanguage] -> Q Exp
forall a b. (a -> b) -> a -> b
$ WidgetFileSettings -> HamletSettings -> [TemplateLanguage]
wfsLanguages WidgetFileSettings
wfs (HamletSettings -> [TemplateLanguage])
-> HamletSettings -> [TemplateLanguage]
forall a b. (a -> b) -> a -> b
$ WidgetFileSettings -> HamletSettings
wfsHamletSettings WidgetFileSettings
wfs
combine :: String -> String -> Bool -> [TemplateLanguage] -> Q Exp
combine :: String -> String -> Bool -> [TemplateLanguage] -> Q Exp
combine func :: String
func file :: String
file isReload :: Bool
isReload tls :: [TemplateLanguage]
tls = do
[Maybe Exp]
mexps <- Q [Maybe Exp]
qmexps
case [Maybe Exp] -> [Exp]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Exp]
mexps of
[] -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ "Called "
, String
func
, " on "
, String -> String
forall a. Show a => a -> String
show String
file
, ", but no templates were found."
]
exps :: [Exp]
exps -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Stmt] -> Exp
DoE ([Stmt] -> Exp) -> [Stmt] -> Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Stmt) -> [Exp] -> [Stmt]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Stmt
NoBindS [Exp]
exps
where
qmexps :: Q [Maybe Exp]
qmexps :: Q [Maybe Exp]
qmexps = (TemplateLanguage -> Q (Maybe Exp))
-> [TemplateLanguage] -> Q [Maybe Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TemplateLanguage -> Q (Maybe Exp)
go [TemplateLanguage]
tls
go :: TemplateLanguage -> Q (Maybe Exp)
go :: TemplateLanguage -> Q (Maybe Exp)
go tl :: TemplateLanguage
tl = String -> Bool -> String -> (String -> Q Exp) -> Q (Maybe Exp)
whenExists String
file (TemplateLanguage -> Bool
tlRequiresToWidget TemplateLanguage
tl) (TemplateLanguage -> String
tlExtension TemplateLanguage
tl) ((if Bool
isReload then TemplateLanguage -> String -> Q Exp
tlReload else TemplateLanguage -> String -> Q Exp
tlNoReload) TemplateLanguage
tl)
whenExists :: String
-> Bool
-> String -> (FilePath -> Q Exp) -> Q (Maybe Exp)
whenExists :: String -> Bool -> String -> (String -> Q Exp) -> Q (Maybe Exp)
whenExists = Bool
-> String -> Bool -> String -> (String -> Q Exp) -> Q (Maybe Exp)
warnUnlessExists Bool
False
warnUnlessExists :: Bool
-> String
-> Bool
-> String -> (FilePath -> Q Exp) -> Q (Maybe Exp)
warnUnlessExists :: Bool
-> String -> Bool -> String -> (String -> Q Exp) -> Q (Maybe Exp)
warnUnlessExists shouldWarn :: Bool
shouldWarn x :: String
x wrap :: Bool
wrap glob :: String
glob f :: String -> Q Exp
f = do
String
fn <- String -> String -> Q String
globFilePackage String
glob String
x
Bool
e <- IO Bool -> Q Bool
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO Bool -> Q Bool) -> IO Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
fn
Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
shouldWarn Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
e) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ IO () -> Q ()
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO () -> Q ()) -> IO () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "widget file not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fn
if Bool
e
then do
Exp
ex <- String -> Q Exp
f String
fn
if Bool
wrap
then do
Exp
tw <- [|toWidget|]
Maybe Exp -> Q (Maybe Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Exp -> Q (Maybe Exp)) -> Maybe Exp -> Q (Maybe Exp)
forall a b. (a -> b) -> a -> b
$ Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Exp -> Maybe Exp) -> Exp -> Maybe Exp
forall a b. (a -> b) -> a -> b
$ Exp
tw Exp -> Exp -> Exp
`AppE` Exp
ex
else Maybe Exp -> Q (Maybe Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Exp -> Q (Maybe Exp)) -> Maybe Exp -> Q (Maybe Exp)
forall a b. (a -> b) -> a -> b
$ Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
ex
else Maybe Exp -> Q (Maybe Exp)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Exp
forall a. Maybe a
Nothing