diff --git a/snap-extras.cabal b/snap-extras.cabal --- a/snap-extras.cabal +++ b/snap-extras.cabal @@ -1,5 +1,5 @@ Name: snap-extras -Version: 0.1.7 +Version: 0.2.2 Synopsis: A collection of useful helpers and utilities for Snap web applications. Description: This package contains a collection of helper functions that come in handy in most practical, real-world @@ -34,23 +34,24 @@ hs-source-dirs: src Build-depends: - base >= 4 && < 5 + aeson >= 0.6 + , base >= 4 && < 5 + , blaze-html + , bytestring , containers + , data-lens >= 2.0 + , digestive-functors >= 0.3 + , digestive-functors-snap >= 0.3 + , directory-tree >= 0.10 && < 0.11 , filepath - , aeson >= 0.6 - , snap-core >= 0.7 - , snap >= 0.7 , heist >= 0.7 - , xmlhtml >= 0.1.6 - , bytestring - , text , safe - , data-lens >= 2.0 + , snap >= 0.7 + , snap-core >= 0.7 + , text , transformers - , blaze-html - , digestive-functors >= 0.3 - , digestive-functors-blaze >= 0.3 - , digestive-functors-snap >= 0.3 + , xmlhtml >= 0.1.6 + , configurator >= 0.2 -- Other-modules: diff --git a/src/Snap/Extras/SpliceUtils.hs b/src/Snap/Extras/SpliceUtils.hs --- a/src/Snap/Extras/SpliceUtils.hs +++ b/src/Snap/Extras/SpliceUtils.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} module Snap.Extras.SpliceUtils ( ifSplice @@ -8,16 +8,23 @@ , addUtilSplices , selectSplice , runTextAreas + , scriptsSplice + , ifFlagSplice ) where ------------------------------------------------------------------------------- import Control.Monad import Control.Monad.Trans.Class -import Data.Text (Text) -import qualified Data.Text.Encoding as T -import Snap.Core -import Snap.Snaplet +import qualified Data.Configurator as C +import qualified Data.Foldable as F +import Data.List +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Snap import Snap.Snaplet.Heist +import System.Directory.Tree +import System.FilePath import Text.Templating.Heist import Text.XmlHtml ------------------------------------------------------------------------------- @@ -32,15 +39,16 @@ ------------------------------------------------------------------------------- -- | A list of splices offered in this module utilSplices :: [(Text, SnapletSplice b v)] -utilSplices = - [("rqparam", liftHeist paramSplice)] +utilSplices = + [ ("rqparam", liftHeist paramSplice) + ] ------------------------------------------------------------------------------- -- | Run the splice contents if given condition is True, make splice -- disappear if not. ifSplice :: Monad m => Bool -> Splice m -ifSplice cond = +ifSplice cond = case cond of False -> return [] True -> runChildren @@ -56,9 +64,9 @@ Just at' -> lift . getParam $ T.encodeUtf8 at' Nothing -> return Nothing return $ maybe [] ((:[]) . TextNode . T.decodeUtf8) val - + ------------------------------------------------------------------------------- -- | Assume text are contains the name of a splice as Text. -- @@ -83,7 +91,7 @@ ------------------------------------------------------------------------------- -- | Splice helper for when you're rendering a select element selectSplice - :: Monad m + :: Monad m => Text -- ^ A name for the select element -> Text @@ -93,13 +101,70 @@ -> Maybe Text -- ^ Default value -> Splice m -selectSplice nm fid xs defv = - callTemplate "_select" +selectSplice nm fid xs defv = + callTemplate "_select" [("options", opts), ("name", textSplice nm), ("id", textSplice fid)] - where + where opts = mapSplices gen xs gen (val,txt) = runChildrenWith [ ("val", textSplice val) , ("text", textSplice txt) , ("ifSelected", ifSplice $ maybe False (== val) defv) , ("ifNotSelected", ifSplice $ 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 dir prefix = do + tree <- liftIO $ build dir + let files = F.foldMap ((:[]) . fst) $ zipPaths $ "" :/ free tree + scripts = filter visibleScripts files + return $ concat $ map includeJavascript scripts + where + visibleScripts fname = + isSuffixOf ".js" fname && not (isPrefixOf "_" (takeFileName fname)) + 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 :: SnapletSplice b v +ifFlagSplice = do + Element t ats es <- liftHeist getParamNode + conf <- liftHandler getSnapletUserConfig + liftHeist $ case lookup "ref" ats of + Nothing -> return [] + Just flag -> do + res <- liftIO $ C.lookup conf flag + case res of + Just True -> return es + _ -> return [] diff --git a/src/Snap/Extras/Tabs.hs b/src/Snap/Extras/Tabs.hs --- a/src/Snap/Extras/Tabs.hs +++ b/src/Snap/Extras/Tabs.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} -{-| +{-| Purpose of this module is to provide a simple, functional way to define tabs in Snap applications. @@ -7,11 +7,11 @@ -} module Snap.Extras.Tabs - ( + ( -- * Define Tabs in DOM via Heist initTabs , tabsSplice - + -- * Define Tabs in Haskell , TabActiveMode (..) , Tab @@ -26,10 +26,10 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import Snap.Core -import Text.Templating.Heist import Snap.Snaplet import Snap.Snaplet.Heist import Text.Templating.Heist +import Text.Templating.Heist import Text.XmlHtml import qualified Text.XmlHtml as X ------------------------------------------------------------------------------- @@ -50,7 +50,7 @@ ------------------------------------------------------------------------------- tabsSplice :: MonadSnap m => Splice m tabsSplice = do - context <- lift $ (T.decodeUtf8 . rqContextPath) `liftM` getRequest + context <- lift $ (T.decodeUtf8 . rqURI) `liftM` getRequest let bind = bindSplices [("tab", tabSplice context)] n <- getParamNode case n of @@ -66,20 +66,20 @@ let ps = do m <- wErr "tab must specify a 'match' attribute" $ lookup "match" attrs url <- wErr "tabs must specify a 'url' attribute" $ getAttribute "url" n - m' <- return $ case m of - "Exact" -> url == context - "Prefix" -> url `T.isPrefixOf` context - "Infix" -> url `T.isInfixOf` context - "None" -> False - _ -> error "Tab: Unknown match type" + m' <- case m of + "Exact" -> Right $ url == context + "Prefix" -> Right $ url `T.isPrefixOf` context + "Infix" -> Right $ url `T.isInfixOf` context + "None" -> Right $ False + _ -> Left "Unknown match type" ch <- return $ childNodes n return (url, ch, m') case ps of Left e -> error $ "Tab error: " ++ e Right (url, ch, match) -> do - let attr' = if match then ("class", "active") : attrs - else attrs - return $ [X.Element "li" attr' [link url ch]] + let attr' = if match then ("class", "active") : attrs else attrs + a = X.Element "a" (("href", url) : attrs) ch + return $ [X.Element "li" attr' [a]] ------------------------------------------------------------------------------- @@ -114,18 +114,18 @@ ------------------------------------------------------------------------------- -- | Make tabs from tab definitions. Use the 'tab' combinator to -- define individual options. -mkTabs - :: MonadSnap m - => Text +mkTabs + :: MonadSnap m + => Text -- ^ A class to be given to the parent ul tag - -> [Tab] + -> [Tab] -- ^ List of tabs in order -> Splice m mkTabs klass ts = do p <- lift $ (T.decodeUtf8 . rqContextPath) `liftM` getRequest return [X.Element "ul" [("class", klass)] (map ($ p) ts)] - + ------------------------------------------------------------------------------- -- | Tab item constructor to be used with 'mkTabs'. Just supply the -- given arguments here and it will create a 'Tab' ready to be used in @@ -137,18 +137,18 @@ -- Make sure to provide a trailing / when indicating URLs as snap -- context paths contain it and active tab checks will be confused -- without it. -tab - :: Text +tab + :: Text -- ^ Target URL for tab - -> Text + -> Text -- ^ A text/label for tab - -> [(Text, Text)] + -> [(Text, Text)] -- ^ A list of attributes as key=val - -> TabActiveMode + -> TabActiveMode -- ^ A 'TabActiveMode' for this tab -> Tab tab url text attr md context = X.Element "li" attr' [tlink url text] - where + where cur = case md of TAMExactMatch -> url == context TAMPrefixMatch -> url `T.isPrefixOf` context