{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

-- | 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
#if MIN_VERSION_template_haskell(2,19,0)
    hiding (makeRelativeToProject)
#endif
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
    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'
    unless exists $ withSinkFileCautious fn' $ \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
    return $ Just $ Right (toRoute ["tmp", pack 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
    mexps <- Q [Maybe Exp]
qmexps
    case catMaybes 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
    fn <- [Char] -> [Char] -> Q [Char]
globFilePackage [Char]
glob [Char]
x
    e <- qRunIO $ doesFileExist fn
    when (shouldWarn && not e) $ qRunIO $ putStrLn $ "widget file not found: " ++ fn
    if e
        then do
            ex <- f fn
            if wrap
                then do
                    tw <- [|toWidget|]
                    return $ Just $ tw `AppE` ex
                else return $ Just ex
        else return Nothing