{-# 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
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True [Char]
statictmp
Bool
exists <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
doesFileExist [Char]
fn'
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exists forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (n :: * -> *) o a.
(MonadUnliftIO m, MonadIO n) =>
[Char] -> (ConduitM ByteString o n () -> m a) -> m a
withSinkFileCautious [Char]
fn' forall a b. (a -> b) -> a -> b
$ \ConduitM ByteString Void (HandlerFor master) ()
sink ->
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) lazy strict i.
(Monad m, LazySequence lazy strict) =>
lazy -> ConduitT i strict m ()
sourceLazy ByteString
content' 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ 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 forall a. [a] -> [a] -> [a]
++ Char
'.' forall a. a -> [a] -> [a]
: Text -> [Char]
unpack Text
ext'
statictmp :: [Char]
statictmp = [Char]
staticDir forall a. [a] -> [a] -> [a]
++ [Char]
"/tmp/"
fn' :: [Char]
fn' = [Char]
statictmp forall a. [a] -> [a] -> [a]
++ [Char]
fn
content' :: L.ByteString
content' :: ByteString
content'
| Text
ext' forall a. Eq a => a -> a -> Bool
== Text
"js" = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const ByteString
content) forall a. a -> a
id 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/" forall a. [a] -> [a] -> [a]
++ [Char]
x forall a. [a] -> [a] -> [a]
++ [Char]
"." forall a. [a] -> [a] -> [a]
++ [Char]
kind
globFilePackage :: String -> String -> Q FilePath
globFilePackage :: [Char] -> [Char] -> Q [Char]
globFilePackage = ([Char] -> Q [Char]
makeRelativeToProject forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) 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 forall a b. (a -> b) -> a -> b
$ WidgetFileSettings -> HamletSettings -> [TemplateLanguage]
wfsLanguages WidgetFileSettings
wfs 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 forall a b. (a -> b) -> a -> b
$ WidgetFileSettings -> HamletSettings -> [TemplateLanguage]
wfsLanguages WidgetFileSettings
wfs 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 forall a. [Maybe a] -> [a]
catMaybes [Maybe Exp]
mexps of
[] -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [Char]
"Called "
, [Char]
func
, [Char]
" on "
, 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe ModName -> [Stmt] -> Exp
DoE forall a. Maybe a
Nothing forall a b. (a -> b) -> a -> b
$ 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 = 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 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 <- forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Bool
doesFileExist [Char]
fn
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
shouldWarn Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
e) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"widget file not found: " 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|]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Exp
tw Exp -> Exp -> Exp
`AppE` Exp
ex
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Exp
ex
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing