{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
-- | Various utilities used in the scaffolded site.
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 -- purposely using complete import so that Haddock will see addStaticContent
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))

-- | An implementation of 'addStaticContent' which stores the contents in an
-- external file. Files are created in the given static folder with names based
-- on a hash of their content. This allows expiration dates to be set far in
-- the future without worry of users receiving stale content.
addStaticContentExternal
    :: (L.ByteString -> Either a L.ByteString) -- ^ javascript minifier
    -> (L.ByteString -> String) -- ^ hash function to determine file name
    -> FilePath -- ^ location of static directory. files will be placed within a "tmp" subfolder
    -> ([Text] -> Route master) -- ^ route constructor, taking a list of pieces
    -> Text -- ^ filename extension
    -> Text -- ^ mime type
    -> L.ByteString -- ^ file contents
    -> 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
    -- by basing the hash off of the un-minified content, we avoid a costly
    -- minification if the file already exists
    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

-- | expects a file extension for each type, e.g: hamlet lucius julius
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

-- | `globFile` but returned path is absolute and within the package the Q Exp is evaluated
-- @since 1.6.1.0
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 -- ^ requires toWidget wrap
           -> 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 -- ^ requires toWidget wrap
                 -> 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