{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
module Snap.Extras.SpliceUtils.Interpreted
( paramSplice
, utilSplices
, addUtilSplices
, selectSplice
, runTextAreas
, scriptsSplice
, ifFlagSplice
) where
-------------------------------------------------------------------------------
import Control.Monad
import Control.Monad.Trans.Class
import qualified Data.Configurator as C
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Snap
import Snap.Extras.SpliceUtils.Common
import Snap.Snaplet.Heist.Interpreted
import Heist
import Heist.Splices
import Heist.Interpreted
import Text.XmlHtml
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- | Bind splices offered in this module in your 'Initializer'
addUtilSplices :: HasHeist b => Initializer b v ()
addUtilSplices = addSplices utilSplices
-------------------------------------------------------------------------------
-- | A list of splices offered in this module
utilSplices :: [(Text, SnapletISplice b)]
utilSplices =
[ ("rqparam", paramSplice)
]
------------------------------------------------------------------------------
-- | Gets the value of a request parameter. Example use:
--
--
paramSplice :: MonadSnap m => Splice m
paramSplice = do
at <- liftM (getAttribute "name") getParamNode
val <- case at of
Just at' -> lift . getParam $ T.encodeUtf8 at'
Nothing -> return Nothing
return $ maybe [] ((:[]) . TextNode . T.decodeUtf8) val
-------------------------------------------------------------------------------
-- | Assume text area contains the name of a splice as Text.
--
-- This is helpful when you pass a default value to digestive-functors
-- by putting the name of a splice as the value of a textarea tag.
--
-- > heistLocal runTextAreas $ render "joo/index"
runTextAreas :: Monad m => HeistState m -> HeistState m
runTextAreas = bindSplices [ ("textarea", ta)]
where
ta = do
hs <- getHS
n@(Element t ats _) <- getParamNode
let nm = nodeText n
case lookupSplice nm hs of
Just spl -> do
ns <- spl
return [Element t ats ns]
Nothing -> return $ [Element t ats []]
-------------------------------------------------------------------------------
-- | Splice helper for when you're rendering a select element
selectSplice
:: Monad m
=> Text
-- ^ A name for the select element
-> Text
-- ^ An id for the select element
-> [(Text, Text)]
-- ^ value, shown text pairs
-> Maybe Text
-- ^ Default value
-> Splice m
selectSplice nm fid xs defv =
callTemplate "_select"
[("options", opts), ("name", textSplice nm), ("id", textSplice fid)]
where
opts = mapSplices gen xs
gen (val,txt) = runChildrenWith
[ ("val", textSplice val)
, ("text", textSplice txt)
, ("ifSelected", ifISplice $ maybe False (== val) defv)
, ("ifNotSelected", ifISplice $ maybe True (/= val) defv) ]
------------------------------------------------------------------------------
-- | Searches a directory on disk and all its subdirectories for all files
-- with names that don't begin with an underscore and end with a .js
-- extension. It then returns script tags for each of these files.
--
-- You can use this function to create a splice:
--
-- > ("staticscripts", scriptsSplice "static/js" "/")
--
-- Then when you use the @\@ tag in your templates, it will
-- automatically include all the javascript code in the @static/js@ directory.
scriptsSplice :: MonadIO m
=> FilePath
-- ^ Path to the directory on disk holding the javascript files.
-> String
-- ^ A prefix to add to the src attribute of each script tag.
-> m [Node]
scriptsSplice d prefix = do
scripts <- getScripts d
return $ concat $ map includeJavascript scripts
where
includeJavascript script =
[Element "script" [("src", T.pack $ prefix ++ script)] []]
-------------------------------------------------------------------------------
-- | Check to see if the boolean flag named by the "ref" attribute is
-- present and set to true in snaplet user config file. If so, run
-- what's inside this splice, if not, simply omit that part.
--
-- Example:
--
-- >
-- > stuff...
-- >
--
-- This will look for an entry inside your .cfg file:
--
-- > beta-functions-enabled = true
ifFlagSplice :: SnapletISplice b
ifFlagSplice = do
Element _ ats es <- getParamNode
conf <- lift getSnapletUserConfig
case lookup "ref" ats of
Nothing -> return []
Just flag -> do
res <- liftIO $ C.lookup conf flag
case res of
Just True -> return es
_ -> return []