1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE CPP #-}
-- | Various utilities used in the scaffolded site.
module Yesod.Default.Util
( addStaticContentExternal
, globFile
, widgetFileNoReload
, widgetFileReload
, widgetFileJsCss
) where
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString.Lazy as L
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 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 Data.Maybe (catMaybes)
-- | 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
-> GHandler sub master (Maybe (Either Text (Route master, [(Text, Text)])))
addStaticContentExternal minify hash staticDir toRoute ext' _ content = do
liftIO $ createDirectoryIfMissing True statictmp
exists <- liftIO $ doesFileExist fn'
unless exists $ liftIO $ L.writeFile fn' content'
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 = hash content ++ '.' : unpack ext'
statictmp = staticDir ++ "/tmp/"
fn' = statictmp ++ fn
content' :: L.ByteString
content'
| ext' == "js" = either (const content) id $ minify content
| otherwise = content
-- | expects a file extension for each type, e.g: hamlet lucius julius
globFile :: String -> String -> FilePath
globFile kind x = "templates/" ++ x ++ "." ++ kind
widgetFileNoReload :: FilePath -> Q Exp
widgetFileNoReload x = combine "widgetFileNoReload" x
[ whenExists x False "hamlet" whamletFile
, whenExists x True "cassius" cassiusFile
, whenExists x True "julius" juliusFile
, whenExists x True "lucius" luciusFile
]
widgetFileReload :: FilePath -> Q Exp
widgetFileReload x = combine "widgetFileReload" x
[ whenExists x False "hamlet" whamletFile
, whenExists x True "cassius" cassiusFileReload
, whenExists x True "julius" juliusFileReload
, whenExists x True "lucius" luciusFileReload
]
widgetFileJsCss :: (String, FilePath -> Q Exp) -- ^ JavaScript file extenstion and loading function. example: ("julius", juliusFileReload)
-> (String, FilePath -> Q Exp) -- ^ Css file extenstion and loading function. example: ("cassius", cassiusFileReload)
-> FilePath -> Q Exp
widgetFileJsCss (jsExt, jsLoad) (csExt, csLoad) x = combine "widgetFileJsCss" x
[ whenExists x False "hamlet" whamletFile
, whenExists x True csExt csLoad
, whenExists x True jsExt jsLoad
]
combine :: String -> String -> [Q (Maybe Exp)] -> Q Exp
combine func file qmexps = do
mexps <- sequence qmexps
case catMaybes mexps of
[] -> error $ concat
[ "Called "
, func
, " on "
, show file
, ", but no template were found."
]
exps -> return $ DoE $ map NoBindS exps
whenExists :: String
-> Bool -- ^ requires toWidget wrap
-> String -> (FilePath -> Q Exp) -> Q (Maybe Exp)
whenExists = warnUnlessExists False
warnUnlessExists :: Bool
-> String
-> Bool -- ^ requires toWidget wrap
-> String -> (FilePath -> Q Exp) -> Q (Maybe Exp)
warnUnlessExists shouldWarn x wrap glob f = do
let fn = globFile glob 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
|
