{-# 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 hiding (makeRelativeToProject)
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 :: forall a master.
(ByteString -> Either a ByteString)
-> (ByteString -> [Char])
-> [Char]
-> ([Text] -> Route master)
-> Text
-> Text
-> ByteString
-> HandlerFor
master (Maybe (Either Text (Route master, [(Text, Text)])))
addStaticContentExternal ByteString -> Either a ByteString
minify ByteString -> [Char]
hash [Char]
staticDir [Text] -> Route master
toRoute Text
ext' Text
_ ByteString
content = do
IO () -> HandlerFor master ()
forall a. IO a -> HandlerFor master a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> HandlerFor master ()) -> IO () -> HandlerFor master ()
forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
statictmp
Bool
exists <- IO Bool -> HandlerFor master Bool
forall a. IO a -> HandlerFor master a
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
$ [Char] -> IO Bool
doesFileExist [Char]
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
$ [Char]
-> (ConduitM ByteString Void (HandlerFor master) ()
-> HandlerFor master ())
-> HandlerFor master ()
forall (m :: * -> *) (n :: * -> *) o a.
(MonadUnliftIO m, MonadIO n) =>
[Char] -> (ConduitM ByteString o n () -> m a) -> m a
withSinkFileCautious [Char]
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
$ \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 =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT 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 a. a -> HandlerFor master a
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 [Text
"tmp", [Char] -> Text
pack [Char]
fn], [])
where
fn, statictmp, fn' :: FilePath
fn :: [Char]
fn = ByteString -> [Char]
hash ByteString
content [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char
'.' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Text -> [Char]
unpack Text
ext'
statictmp :: [Char]
statictmp = [Char]
staticDir [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"/tmp/"
fn' :: [Char]
fn' = [Char]
statictmp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
fn
content' :: L.ByteString
content' :: ByteString
content'
| Text
ext' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"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 :: [Char] -> [Char] -> [Char]
globFile [Char]
kind [Char]
x = [Char]
"templates/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"." [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
kind
globFilePackage :: String -> String -> Q FilePath
globFilePackage :: [Char] -> [Char] -> Q [Char]
globFilePackage = ([Char] -> Q [Char]
makeRelativeToProject ([Char] -> Q [Char]) -> ([Char] -> [Char]) -> [Char] -> Q [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (([Char] -> [Char]) -> [Char] -> Q [Char])
-> ([Char] -> [Char] -> [Char]) -> [Char] -> [Char] -> Q [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> [Char]
globFile
data TemplateLanguage = TemplateLanguage
{ TemplateLanguage -> Bool
tlRequiresToWidget :: Bool
, TemplateLanguage -> [Char]
tlExtension :: String
, TemplateLanguage -> [Char] -> Q Exp
tlNoReload :: FilePath -> Q Exp
, TemplateLanguage -> [Char] -> Q Exp
tlReload :: FilePath -> Q Exp
}
defaultTemplateLanguages :: HamletSettings -> [TemplateLanguage]
defaultTemplateLanguages :: HamletSettings -> [TemplateLanguage]
defaultTemplateLanguages HamletSettings
hset =
[ Bool
-> [Char]
-> ([Char] -> Q Exp)
-> ([Char] -> Q Exp)
-> TemplateLanguage
TemplateLanguage Bool
False [Char]
"hamlet" [Char] -> Q Exp
whamletFile' [Char] -> Q Exp
whamletFile'
, Bool
-> [Char]
-> ([Char] -> Q Exp)
-> ([Char] -> Q Exp)
-> TemplateLanguage
TemplateLanguage Bool
True [Char]
"cassius" [Char] -> Q Exp
cassiusFile [Char] -> Q Exp
cassiusFileReload
, Bool
-> [Char]
-> ([Char] -> Q Exp)
-> ([Char] -> Q Exp)
-> TemplateLanguage
TemplateLanguage Bool
True [Char]
"julius" [Char] -> Q Exp
juliusFile [Char] -> Q Exp
juliusFileReload
, Bool
-> [Char]
-> ([Char] -> Q Exp)
-> ([Char] -> Q Exp)
-> TemplateLanguage
TemplateLanguage Bool
True [Char]
"lucius" [Char] -> Q Exp
luciusFile [Char] -> Q Exp
luciusFileReload
]
where
whamletFile' :: [Char] -> Q Exp
whamletFile' = HamletSettings -> [Char] -> 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 -> [Char] -> Q Exp
widgetFileNoReload WidgetFileSettings
wfs [Char]
x = [Char] -> [Char] -> Bool -> [TemplateLanguage] -> Q Exp
combine [Char]
"widgetFileNoReload" [Char]
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 -> [Char] -> Q Exp
widgetFileReload WidgetFileSettings
wfs [Char]
x = [Char] -> [Char] -> Bool -> [TemplateLanguage] -> Q Exp
combine [Char]
"widgetFileReload" [Char]
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 :: [Char] -> [Char] -> Bool -> [TemplateLanguage] -> Q Exp
combine [Char]
func [Char]
file Bool
isReload [TemplateLanguage]
tls = do
[Maybe Exp]
mexps <- Q [Maybe Exp]
qmexps
case [Maybe Exp] -> [Exp]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Exp]
mexps of
[] -> [Char] -> Q Exp
forall a. HasCallStack => [Char] -> a
error ([Char] -> Q Exp) -> [Char] -> Q Exp
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Called "
, [Char]
func
, [Char]
" on "
, [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
file
, [Char]
", but no templates were found."
]
#if MIN_VERSION_template_haskell(2,17,0)
[Exp]
exps -> 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
$ Maybe ModName -> [Stmt] -> Exp
DoE Maybe ModName
forall a. Maybe a
Nothing ([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
#else
exps -> return $ DoE $ map NoBindS exps
#endif
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TemplateLanguage -> Q (Maybe Exp)
go [TemplateLanguage]
tls
go :: TemplateLanguage -> Q (Maybe Exp)
go :: TemplateLanguage -> Q (Maybe Exp)
go TemplateLanguage
tl = [Char] -> Bool -> [Char] -> ([Char] -> Q Exp) -> Q (Maybe Exp)
whenExists [Char]
file (TemplateLanguage -> Bool
tlRequiresToWidget TemplateLanguage
tl) (TemplateLanguage -> [Char]
tlExtension TemplateLanguage
tl) ((if Bool
isReload then TemplateLanguage -> [Char] -> Q Exp
tlReload else TemplateLanguage -> [Char] -> Q Exp
tlNoReload) TemplateLanguage
tl)
whenExists :: String
-> Bool
-> String -> (FilePath -> Q Exp) -> Q (Maybe Exp)
whenExists :: [Char] -> Bool -> [Char] -> ([Char] -> Q Exp) -> Q (Maybe Exp)
whenExists = Bool
-> [Char] -> Bool -> [Char] -> ([Char] -> Q Exp) -> Q (Maybe Exp)
warnUnlessExists Bool
False
warnUnlessExists :: Bool
-> String
-> Bool
-> String -> (FilePath -> Q Exp) -> Q (Maybe Exp)
warnUnlessExists :: Bool
-> [Char] -> Bool -> [Char] -> ([Char] -> Q Exp) -> Q (Maybe Exp)
warnUnlessExists Bool
shouldWarn [Char]
x Bool
wrap [Char]
glob [Char] -> Q Exp
f = do
[Char]
fn <- [Char] -> [Char] -> Q [Char]
globFilePackage [Char]
glob [Char]
x
Bool
e <- IO Bool -> Q Bool
forall a. IO a -> Q a
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
$ [Char] -> IO Bool
doesFileExist [Char]
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 a. IO a -> Q a
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO () -> Q ()) -> IO () -> Q ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"widget file not found: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
fn
if Bool
e
then do
Exp
ex <- [Char] -> Q Exp
f [Char]
fn
if Bool
wrap
then do
Exp
tw <- [|toWidget|]
Maybe Exp -> Q (Maybe Exp)
forall a. a -> Q a
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 a. a -> Q a
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 a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Exp
forall a. Maybe a
Nothing