{-# 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
    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
    -- 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 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

-- | 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/" forall a. [a] -> [a] -> [a]
++ [Char]
x forall a. [a] -> [a] -> [a]
++ [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 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 -- ^ 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 <- 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