{-# 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
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 :: (ByteString -> Either a ByteString)
-> (ByteString -> String)
-> String
-> ([Text] -> Route master)
-> Text
-> Text
-> ByteString
-> HandlerFor
     master (Maybe (Either Text (Route master, [(Text, Text)])))
addStaticContentExternal ByteString -> Either a ByteString
minify ByteString -> String
hash String
staticDir [Text] -> Route master
toRoute Text
ext' Text
_ ByteString
content = do
    IO () -> HandlerFor master ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> HandlerFor master ()) -> IO () -> HandlerFor master ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
statictmp
    Bool
exists <- IO Bool -> HandlerFor master Bool
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
$ String -> IO Bool
doesFileExist String
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
$ String
-> (ConduitM ByteString Void (HandlerFor master) ()
    -> HandlerFor master ())
-> HandlerFor master ()
forall (m :: * -> *) (n :: * -> *) o a.
(MonadUnliftIO m, MonadIO n) =>
String -> (ConduitM ByteString o n () -> m a) -> m a
withSinkFileCautious String
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 =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM 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 (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", String -> Text
pack String
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 :: String
fn = ByteString -> String
hash ByteString
content String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: Text -> String
unpack Text
ext'
    statictmp :: String
statictmp = String
staticDir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/tmp/"
    fn' :: String
fn' = String
statictmp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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 :: String -> String -> String
globFile String
kind String
x = String
"templates/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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 :: String -> String -> Q String
globFilePackage = (String -> Q String
makeRelativeToProject (String -> Q String) -> (String -> String) -> String -> Q String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) ((String -> String) -> String -> Q String)
-> (String -> String -> String) -> String -> String -> Q String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
globFile

data TemplateLanguage = TemplateLanguage
    { TemplateLanguage -> Bool
tlRequiresToWidget :: Bool
    , TemplateLanguage -> String
tlExtension :: String
    , TemplateLanguage -> String -> Q Exp
tlNoReload :: FilePath -> Q Exp
    , TemplateLanguage -> String -> Q Exp
tlReload :: FilePath -> Q Exp
    }

defaultTemplateLanguages :: HamletSettings -> [TemplateLanguage]
defaultTemplateLanguages :: HamletSettings -> [TemplateLanguage]
defaultTemplateLanguages HamletSettings
hset =
    [ Bool
-> String
-> (String -> Q Exp)
-> (String -> Q Exp)
-> TemplateLanguage
TemplateLanguage Bool
False String
"hamlet"  String -> Q Exp
whamletFile' String -> Q Exp
whamletFile'
    , Bool
-> String
-> (String -> Q Exp)
-> (String -> Q Exp)
-> TemplateLanguage
TemplateLanguage Bool
True  String
"cassius" String -> Q Exp
cassiusFile  String -> Q Exp
cassiusFileReload
    , Bool
-> String
-> (String -> Q Exp)
-> (String -> Q Exp)
-> TemplateLanguage
TemplateLanguage Bool
True  String
"julius"  String -> Q Exp
juliusFile   String -> Q Exp
juliusFileReload
    , Bool
-> String
-> (String -> Q Exp)
-> (String -> Q Exp)
-> TemplateLanguage
TemplateLanguage Bool
True  String
"lucius"  String -> Q Exp
luciusFile   String -> Q Exp
luciusFileReload
    ]
  where
    whamletFile' :: String -> Q Exp
whamletFile' = HamletSettings -> String -> 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 -> String -> Q Exp
widgetFileNoReload WidgetFileSettings
wfs String
x = String -> String -> Bool -> [TemplateLanguage] -> Q Exp
combine String
"widgetFileNoReload" String
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 -> String -> Q Exp
widgetFileReload WidgetFileSettings
wfs String
x = String -> String -> Bool -> [TemplateLanguage] -> Q Exp
combine String
"widgetFileReload" String
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 :: String -> String -> Bool -> [TemplateLanguage] -> Q Exp
combine String
func String
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
        [] -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
            [ String
"Called "
            , String
func
            , String
" on "
            , String -> String
forall a. Show a => a -> String
show String
file
            , String
", but no templates were found."
            ]
#if MIN_VERSION_template_haskell(2,17,0)
        exps -> return $ DoE Nothing $ map NoBindS exps
#else
        [Exp]
exps -> Exp -> Q Exp
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Stmt] -> Exp
DoE ([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
#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)
mapM TemplateLanguage -> Q (Maybe Exp)
go [TemplateLanguage]
tls

    go :: TemplateLanguage -> Q (Maybe Exp)
    go :: TemplateLanguage -> Q (Maybe Exp)
go TemplateLanguage
tl = String -> Bool -> String -> (String -> Q Exp) -> Q (Maybe Exp)
whenExists String
file (TemplateLanguage -> Bool
tlRequiresToWidget TemplateLanguage
tl) (TemplateLanguage -> String
tlExtension TemplateLanguage
tl) ((if Bool
isReload then TemplateLanguage -> String -> Q Exp
tlReload else TemplateLanguage -> String -> Q Exp
tlNoReload) TemplateLanguage
tl)

whenExists :: String
           -> Bool -- ^ requires toWidget wrap
           -> String -> (FilePath -> Q Exp) -> Q (Maybe Exp)
whenExists :: String -> Bool -> String -> (String -> Q Exp) -> Q (Maybe Exp)
whenExists = Bool
-> String -> Bool -> String -> (String -> Q Exp) -> Q (Maybe Exp)
warnUnlessExists Bool
False

warnUnlessExists :: Bool
                 -> String
                 -> Bool -- ^ requires toWidget wrap
                 -> String -> (FilePath -> Q Exp) -> Q (Maybe Exp)
warnUnlessExists :: Bool
-> String -> Bool -> String -> (String -> Q Exp) -> Q (Maybe Exp)
warnUnlessExists Bool
shouldWarn String
x Bool
wrap String
glob String -> Q Exp
f = do
    String
fn <- String -> String -> Q String
globFilePackage String
glob String
x
    Bool
e <- IO Bool -> Q Bool
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
$ String -> IO Bool
doesFileExist String
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 (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO () -> Q ()) -> IO () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"widget file not found: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fn
    if Bool
e
        then do
            Exp
ex <- String -> Q Exp
f String
fn
            if Bool
wrap
                then do
                    Exp
tw <- [|toWidget|]
                    Maybe Exp -> Q (Maybe Exp)
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 (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 (m :: * -> *) a. Monad m => a -> m a
return Maybe Exp
forall a. Maybe a
Nothing