snap-extras 0.1.7 → 0.2.2
raw patch · 3 files changed
+117/−51 lines, 3 filesdep +configuratordep +directory-treedep −digestive-functors-blaze
Dependencies added: configurator, directory-tree
Dependencies removed: digestive-functors-blaze
Files
- snap-extras.cabal +14/−13
- src/Snap/Extras/SpliceUtils.hs +78/−13
- src/Snap/Extras/Tabs.hs +25/−25
snap-extras.cabal view
@@ -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:
src/Snap/Extras/SpliceUtils.hs view
@@ -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 @\<staticscripts/\>@ 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:+--+-- > <flag ref="beta-functions-enabled">+-- > stuff...+-- > </flag>+--+-- 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 []
src/Snap/Extras/Tabs.hs view
@@ -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