106 lines
4.1 KiB
Haskell
106 lines
4.1 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE CPP #-}
|
|
-- | Various utilities used in the scaffolded site.
|
|
module Yesod.Default.Util
|
|
( addStaticContentExternal
|
|
, globFile
|
|
, widgetFileProduction
|
|
, widgetFileDebug
|
|
, runWaiApp
|
|
) 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 (unless)
|
|
import System.Directory (doesFileExist, createDirectoryIfMissing)
|
|
import Language.Haskell.TH.Syntax
|
|
import Text.Lucius (luciusFile, luciusFileDebug)
|
|
import Text.Julius (juliusFile, juliusFileDebug)
|
|
import Text.Cassius (cassiusFile, cassiusFileDebug)
|
|
import Data.Monoid (mempty)
|
|
import Network.Wai (Application)
|
|
|
|
#ifndef WINDOWS
|
|
import qualified System.Posix.Signals as Signal
|
|
import Control.Concurrent (forkIO, killThread)
|
|
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
|
|
#endif
|
|
|
|
-- | 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 root folder for each type, e.g: hamlet/ lucius/ julius/
|
|
globFile :: String -> String -> FilePath
|
|
globFile kind x = kind ++ "/" ++ x ++ "." ++ kind
|
|
|
|
widgetFileProduction :: FilePath -> Q Exp
|
|
widgetFileProduction x = do
|
|
let h = whenExists x "hamlet" whamletFile
|
|
let c = whenExists x "cassius" cassiusFile
|
|
let j = whenExists x "julius" juliusFile
|
|
let l = whenExists x "lucius" luciusFile
|
|
[|$h >> addCassius $c >> addJulius $j >> addLucius $l|]
|
|
|
|
widgetFileDebug :: FilePath -> Q Exp
|
|
widgetFileDebug x = do
|
|
let h = whenExists x "hamlet" whamletFile
|
|
let c = whenExists x "cassius" cassiusFileDebug
|
|
let j = whenExists x "julius" juliusFileDebug
|
|
let l = whenExists x "lucius" luciusFileDebug
|
|
[|$h >> addCassius $c >> addJulius $j >> addLucius $l|]
|
|
|
|
whenExists :: String -> String -> (FilePath -> Q Exp) -> Q Exp
|
|
whenExists x glob f = do
|
|
let fn = globFile glob x
|
|
e <- qRunIO $ doesFileExist fn
|
|
if e then f fn else [|mempty|]
|
|
|
|
-- | A signal-aware runner for WAI applications. On Windows, this doesn't do
|
|
-- anything special. On POSIX systems, this installs a signal handler for INT
|
|
-- and automatically kills the application when the signal is received. This
|
|
-- allows you to add cleanup code (like log flushing) after an application
|
|
-- exits.
|
|
runWaiApp :: (Application -> IO ()) -> Application -> IO ()
|
|
#ifdef WINDOWS
|
|
runWaiApp f app = f app
|
|
#else
|
|
runWaiApp f app = do
|
|
tid <- forkIO $ f app >> return ()
|
|
flag <- newEmptyMVar
|
|
_ <- Signal.installHandler Signal.sigINT (Signal.CatchOnce $ do
|
|
killThread tid
|
|
putMVar flag ()) Nothing
|
|
takeMVar flag
|
|
#endif
|