packages feed

snap-extras (empty) → 0.1.7

raw patch · 13 files changed

+938/−0 lines, 13 filesdep +aesondep +basedep +blaze-htmlsetup-changed

Dependencies added: aeson, base, blaze-html, bytestring, containers, data-lens, digestive-functors, digestive-functors-blaze, digestive-functors-snap, filepath, heist, safe, snap, snap-core, text, transformers, xmlhtml

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2012, Ozgun Ataman++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Ozgun Ataman nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ resources/templates/_flash.tpl view
@@ -0,0 +1,4 @@+<div class='alert alert-${type}' data-alert='alert'>+  <a class="close" href="#">×</a>+  <message/> +</div>
+ resources/templates/_select.tpl view
@@ -0,0 +1,10 @@+<select name="${name}" id="${id}">+  <options>+    <ifSelected>+      <option selected value="${val}"><text/></option>+    </ifSelected>+    <ifNotSelected>+      <option value="${val}"><text/></option>+    </ifNotSelected>+  </options>+</select>
+ snap-extras.cabal view
@@ -0,0 +1,56 @@+Name:                snap-extras+Version:             0.1.7+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+             applications. Check individual modules to understand+             what's here. You can simply import Snap.Extras and use+             the initializer in there to get them all at once.+License:             BSD3+License-file:        LICENSE+Author:              Ozgun Ataman+Maintainer:          ozataman@gmail.com+Category:            Web, Snap+Build-type:          Simple+Cabal-version:       >= 1.6+++data-files:+  resources/templates/*.tpl++Library+  -- Modules exported by the library.+  Exposed-modules:     +    Snap.Extras+    Snap.Extras.CoreUtils+    Snap.Extras.TextUtils+    Snap.Extras.JSON+    Snap.Extras.FlashNotice+    Snap.Extras.SpliceUtils+    Snap.Extras.FormUtils+    Snap.Extras.Tabs+  other-modules:+    Paths_snap_extras++  hs-source-dirs: src+  Build-depends:+      base >= 4 && < 5+    , containers+    , 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+    , transformers+    , blaze-html+    , digestive-functors >= 0.3+    , digestive-functors-blaze >= 0.3+    , digestive-functors-snap >= 0.3+  +  -- Other-modules:       +
+ src/Snap/Extras.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Extras+    ( module Snap.Extras.CoreUtils+    , module Snap.Extras.TextUtils+    , module Snap.Extras.JSON+    , module Snap.Extras.FlashNotice+    , module Snap.Extras.SpliceUtils+    , module Snap.Extras.FormUtils+    , module Snap.Extras.Tabs+    , initExtras+    ) where++-------------------------------------------------------------------------------+import Data.Lens.Common+import Snap.Snaplet+import Snap.Snaplet.Heist+import Snap.Snaplet.Session+import System.FilePath.Posix+-------------------------------------------------------------------------------+import Snap.Extras.CoreUtils+import Snap.Extras.FlashNotice+import Snap.Extras.FormUtils+import Snap.Extras.JSON+import Snap.Extras.SpliceUtils+import Snap.Extras.Tabs+import Snap.Extras.TextUtils+-------------------------------------------------------------------------------+import Paths_snap_extras+-------------------------------------------------------------------------------+++-------------------------------------------------------------------------------+-- | Initialize all the 'Snap.Extras' functionality in your Snap app.+-- Currently, we don't need to keep any state and simply return ().+initExtras :: HasHeist b => Lens b (Snaplet SessionManager) -> SnapletInit b ()+initExtras session = +  makeSnaplet +    "Snap Extras" +    "Collection of utilities for web applications" +    (Just getDataDir) $ do+      addTemplatesAt "" . (</> "resources/templates") =<< getSnapletFilePath+      initFlashNotice session+      addUtilSplices+      initTabs
+ src/Snap/Extras/CoreUtils.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++module Snap.Extras.CoreUtils+    ( finishEarly+    , badReq+    , notFound+    , serverError+    , plainResponse+    , jsonResponse+    , jsResponse+    , easyLog+    , getParam'+    , reqParam+    , readParam+    , readMayParam+    ) where++-------------------------------------------------------------------------------+import Snap.Core+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B+import Control.Monad+import Safe+-------------------------------------------------------------------------------++++-------------------------------------------------------------------------------+-- | Discard anything after this and return given status code to HTTP+-- client immediately.+finishEarly :: MonadSnap m => Int -> ByteString -> m b +finishEarly code str = do+  modifyResponse $ setResponseStatus code str+  modifyResponse $ addHeader "Content-Type" "text/plain"+  writeBS str+  getResponse >>= finishWith+++-------------------------------------------------------------------------------+-- | Finish early with error code 400+badReq :: MonadSnap m => ByteString -> m b +badReq = finishEarly 400 +++-------------------------------------------------------------------------------+-- | Finish early with error code 404+notFound :: MonadSnap m => ByteString -> m b +notFound = finishEarly 404+++-------------------------------------------------------------------------------+-- | Finish early with error code 500+serverError :: MonadSnap m => ByteString -> m b +serverError = finishEarly 500+++-------------------------------------------------------------------------------+-- | Mark response as 'text/plain'+plainResponse :: MonadSnap m => m ()+plainResponse = modifyResponse $ setHeader "Content-Type" "text/plain"+++-------------------------------------------------------------------------------+-- | Mark response as 'application/json'+jsonResponse :: MonadSnap m => m ()+jsonResponse = modifyResponse $ setHeader "Content-Type" "application/json"+++-------------------------------------------------------------------------------+-- | Mark response as 'application/javascript'+jsResponse :: MonadSnap m => m ()+jsResponse = modifyResponse $ setHeader "Content-Type" "application/javascript"+++------------------------------------------------------------------------------+-- | Easier debug logging into error log. First argument is a+-- category/namespace and the second argument is anything that has a+-- 'Show' instance.+easyLog :: (Show t, MonadSnap m) => String -> t -> m ()+easyLog k v = logError . B.pack $ ("[Debug] " ++ k ++ ": " ++ show v)+++-------------------------------------------------------------------------------+-- | Alternate version of getParam that considers empty string Nothing+getParam' :: MonadSnap m => ByteString -> m (Maybe ByteString)+getParam' = return . maybe Nothing f <=< getParam+    where f "" = Nothing+          f x = Just x+++-------------------------------------------------------------------------------+-- | Require that a parameter is present or terminate early.+reqParam :: (MonadSnap m) => ByteString -> m ByteString+reqParam s = do+  p <- getParam s+  maybe (badReq $ B.concat ["Required parameter ", s, " is missing."]) return p+ ++-------------------------------------------------------------------------------+-- | Read a parameter from request. Be sure it is readable if it's+-- there, or else this will raise an error.+readParam :: (MonadSnap m, Read a) => ByteString -> m (Maybe a)+readParam k = fmap (readNote "readParam failed" . B.unpack) `fmap` getParam k+++-------------------------------------------------------------------------------+-- | Try to read a parameter from request. Computation may fail+-- because the param is not there, or because it can't be read.+readMayParam :: (MonadSnap m, Read a) => ByteString -> m (Maybe a)+readMayParam k = do +  p <- getParam k+  return $ readMay . B.unpack =<< p
+ src/Snap/Extras/FlashNotice.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++module Snap.Extras.FlashNotice+    ( initFlashNotice+    , flashInfo+    , flashWarning+    , flashSuccess+    , flashError+    , flashSplice+    ) where++-------------------------------------------------------------------------------+import           Control.Monad+import           Data.Lens.Common+import           Data.Text             (Text)+import qualified Data.Text             as T+import           Snap.Snaplet+import           Snap.Snaplet.Heist+import           Snap.Snaplet.Session+import           Text.Templating.Heist+import           Text.XmlHtml+-------------------------------------------------------------------------------+++-------------------------------------------------------------------------------+-- | Initialize the flash notice system. All you have to do now is to+-- add some flash tags in your application template. See 'flashSplice'+-- for examples.+initFlashNotice +    :: HasHeist b +    => Lens b (Snaplet SessionManager) -> Initializer b v ()+initFlashNotice session = do+  addSplices [("flash", flashSplice session)]+++-------------------------------------------------------------------------------+-- | Display an info message on next load of a page+flashInfo :: Lens b (Snaplet SessionManager) -> Text -> Handler b b ()+flashInfo session msg = withSession session $ with session $ setInSession "_info" msg+++-------------------------------------------------------------------------------+-- | Display an warning message on next load of a page+flashWarning :: Lens b (Snaplet SessionManager) -> Text -> Handler b b ()+flashWarning session msg = withSession session $ with session $ setInSession "_warning" msg+++-------------------------------------------------------------------------------+-- | Display a success message on next load of a page+flashSuccess :: Lens b (Snaplet SessionManager) -> Text -> Handler b b ()+flashSuccess session msg = withSession session $ with session $ setInSession "_success" msg+++-------------------------------------------------------------------------------+-- | Display an error message on next load of a page+flashError :: Lens b (Snaplet SessionManager) -> Text -> Handler b b ()+flashError session msg = withSession session $ with session $ setInSession "_error" msg+++-------------------------------------------------------------------------------+-- | A splice for rendering a given flash notice dirctive.+--+-- Ex: <flash type='warning'/>+-- Ex: <flash type='success'/>+flashSplice :: Lens b (Snaplet SessionManager) -> SnapletSplice b v+flashSplice session = do+  typ <- liftHeist $ liftM (getAttribute "type") getParamNode+  let typ' = maybe "warning" id typ+  let k = T.concat ["_", typ']+  msg <- liftHandler $ withTop session $ getFromSession k+  case msg of +    Nothing -> liftHeist $ return []+    Just msg' -> do+      liftHandler $ withTop session $ deleteFromSession k >> commitSession+      liftHeist $ callTemplateWithText "_flash"+           [ ("type", typ') , ("message", msg') ]+
+ src/Snap/Extras/FormUtils.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings         #-}+{-# LANGUAGE RecordWildCards           #-}++module Snap.Extras.FormUtils+    (+    -- * Transformers+      maybeTrans+    , readMayTrans+    , readTrans+    -- -- * Form Elements+    -- , submitCancel+    -- , submitOnly+    -- -- * Formatting Form Elements+    -- , inputFormat+    -- , dateInput+    -- -- * Running/Displaying Forms+    -- , showForm+    -- , runViewForm'+    ) where++-------------------------------------------------------------------------------+import           Control.Monad+import qualified Data.ByteString.Char8 as B+import           Data.List             (find)+import qualified Data.Map              as M+import           Data.Maybe+import           Data.String+import           Data.Text             (Text)+import qualified Data.Text             as T+import           Safe+import           Snap.Core+import           Text.Digestive+import           Text.Digestive.Snap+import           Text.Templating.Heist+-------------------------------------------------------------------------------+++                              ------------------+                              -- Transformers --+                              ------------------+++-------------------------------------------------------------------------------+-- | Transform to Nothing if field is empty string+maybeTrans+    :: (Eq a, IsString a)+    => a -> Result v (Maybe a)+maybeTrans x = f x+    where f "" = Success Nothing+          f a = Success $ Just a+++-------------------------------------------------------------------------------+-- | Maybe read into target value+readMayTrans+    :: Read a+    => Text -> Result v (Maybe a)+readMayTrans x = Success $ readMay (T.unpack x)+++-------------------------------------------------------------------------------+-- | Read into target value+readTrans+    :: (Read a, IsString v)+    => Text -> Result v a+readTrans a = maybe (Error "Unrecognized input") Success $ readMay . T.unpack $ a++++                              -------------------+                              -- Form Elements --+                              -------------------+++-- -------------------------------------------------------------------------------+-- -- | Submit and cancel buttons with markup+-- submitCancel+--     :: (Monad m, Functor m)+--     => String+--     -- ^ Submit button text+--     -> Text+--     -- ^ Cancel button text+--     -> Text+--     -- ^ Cancel button HREF+--     -> Form m i e (FormHtml Html) ()+-- submitCancel s ct cl = mapViewHtml enc (submit s)+--   where enc x = do+--           H.div ! A.class_ "form-actions" $ do+--             x+--             " "+--             H.a (text ct) ! A.href (textValue cl) ! A.class_ "btn"++-- -------------------------------------------------------------------------------+-- -- | Just a submit button with markup+-- submitOnly+--     :: (Monad m, Functor m)+--     => String+--     -- ^ Submit button text+--     -> Form m i e (FormHtml Html) ()+-- submitOnly s = mapViewHtml enc (submit s)+--   where enc x = do+--           H.div ! A.class_ "form-actions" $ x+++-- -------------------------------------------------------------------------------+-- -- | Input form element wrapper to add a class of 'input'+-- inputFormat+--     :: (Monad m, Functor m)+--     => Form m i e (FormHtml Html) a+--     -> Form m i e (FormHtml Html) a+-- inputFormat = mapViewHtml (H.div ! A.class_ "input")+++-- -------------------------------------------------------------------------------+-- -- | Add a 'datepicker' classed div tag surrounding the form element+-- dateInput+--     :: (Monad m, Functor m)+--     => Form m i e (FormHtml Html) a+--     -> Form m i e (FormHtml Html) a+-- dateInput = mapViewHtml (H.div ! A.class_ "datepicker")+++-- -------------------------------------------------------------------------------+-- -- | Render a form into a Heist splice+-- showForm+--     :: Monad m+--     => AttributeValue+--     -- ^ Form action target+--     -> AttributeValue+--     -- ^ Form submittion HTTP method+--     -> FormHtml (HtmlM a)+--     -- ^ Form to display+--     -> Splice m+-- showForm act mth frm =+--    let  (formHtml', enctype) = renderFormHtmlWith config frm+--         config = defaultHtmlConfig { htmlSubmitClasses = ["btn", "btn-primary"] }+--         frm' = H.form ! A.enctype (H.toValue $ show enctype) ! A.method mth+--                       ! A.action act $ formHtml' >> return ()+--    in return $ renderHtmlNodes frm'++++-- -------------------------------------------------------------------------------+-- -- | Version of runView that will use defaults when no related+-- -- parameters are found in the environment. This is particularly+-- -- designed for filter forms that have to be rendered all the time on+-- -- the page (as opposed to record create/update forms).+-- --+-- -- This is a pretty smart combinator and will try to do the "Right+-- -- Thing" automagically. It will:+-- --+-- -- 1. Look for the presence of a form namespace in Snap's 'Params'+-- --+-- -- 2. If it's there, it'll try to run the form and the views+-- --+-- -- 3. If no params are there, it'll assume that the form has not been+-- -- submitted, so it should be a default form. It just renders the view+-- -- in its default mode.+-- runViewForm'+--   :: MonadSnap m+--   => SnapForm m e t a+--   -- ^ A digestive-functor form+--   -> String+--   -- ^ Namespace used when rendering the form+--   -> m (t, Maybe a)+--   -- ^ The form's view and a possible form result+-- runViewForm' form nm = do+--   ps <- M.keys `fmap` getParams+--   case find (B.isInfixOf $ B.pack nm) ps of+--     Just _ -> runViewSnapForm form nm+--     Nothing -> do+--       view' <- viewForm form nm+--       return $ (view', Nothing)
+ src/Snap/Extras/JSON.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++module Snap.Extras.JSON+    ( +    -- * Parsing JSON from Request Body+      getBoundedJSON+    , getJSON+    , reqBoundedJSON+    , reqJSON+    , getJSONField+    , reqJSONField+    -- * Sending JSON Data+    , writeJSON+    ) where+    ++-------------------------------------------------------------------------------+import           Data.Aeson            as A+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy.Char8 as LB+import           Data.Int+import           Snap.Core+-------------------------------------------------------------------------------+import           Snap.Extras.CoreUtils+-------------------------------------------------------------------------------+++-------------------------------------------------------------------------------+-- | Demand the presence of JSON in the body assuming it is not larger+-- than 50000 bytes.+reqJSON :: (MonadSnap m, A.FromJSON b) => m b+reqJSON = reqBoundedJSON 50000+++-------------------------------------------------------------------------------+-- | Demand the presence of JSON in the body with a size up to N+-- bytes. If parsing fails for any reson, request is terminated early+-- and a server error is returned.+reqBoundedJSON +    :: (MonadSnap m, FromJSON a)+    => Int64+    -- ^ Maximum size in bytes+    -> m a+reqBoundedJSON n = do+  res <- getBoundedJSON n+  case res of+    Left e -> badReq $ B.pack e+    Right a -> return a+++-------------------------------------------------------------------------------+-- | Try to parse request body as JSON with a default max size of+-- 50000.+getJSON :: (MonadSnap m, A.FromJSON a) => m (Either String a)+getJSON = getBoundedJSON 50000+++-------------------------------------------------------------------------------+-- | Parse request body into JSON or return an error string.+getBoundedJSON +    :: (MonadSnap m, FromJSON a) +    => Int64 +    -- ^ Maximum size in bytes+    -> m (Either String a)+getBoundedJSON n = do+  bodyVal <- A.decode `fmap` readRequestBody n+  return $ case bodyVal of+    Nothing -> Left "Can't find JSON data in POST body"+    Just v -> case A.fromJSON v of+                A.Error e -> Left e+                A.Success a -> Right a+++-------------------------------------------------------------------------------+-- | Get JSON data from the given Param field+getJSONField +    :: (MonadSnap m, FromJSON a)+    => B.ByteString+    -> m (Either String a)+getJSONField fld = do+  val <- getParam fld+  return $ case val of+    Nothing -> Left $ "Cant find field " ++ B.unpack fld+    Just val' ->+      case A.decode (LB.fromChunks . return $ val') of+        Nothing -> Left $ "Can't decode JSON data in field " ++ B.unpack fld+        Just v -> +          case A.fromJSON v of+            A.Error e -> Left e+            A.Success a -> Right a+++-------------------------------------------------------------------------------+-- | Force the JSON value from field. Similar to 'getJSONField'+reqJSONField +    :: (MonadSnap m, FromJSON a)+    => B.ByteString+    -> m a+reqJSONField fld = do+  res <- getJSONField fld+  case res of+    Left e -> badReq $ B.pack e+    Right a -> return a+++-------------------------------------------------------------------------------+-- | Set MIME to 'application/json' and write given object into+-- 'Response' body.+writeJSON :: (MonadSnap m, ToJSON a) => a -> m ()+writeJSON a = do+  jsonResponse+  writeLBS . encode $ a
+ src/Snap/Extras/SpliceUtils.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoMonomorphismRestriction #-}++module Snap.Extras.SpliceUtils+    ( ifSplice+    , paramSplice+    , utilSplices+    , addUtilSplices+    , selectSplice+    , runTextAreas+    ) 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           Snap.Snaplet.Heist+import           Text.Templating.Heist+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, SnapletSplice b v)]+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 = +    case cond of+      False -> return []+      True -> runChildren++------------------------------------------------------------------------------+-- | Gets the value of a request parameter.  Example use:+--+-- <rqparam name="username"/>+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 are 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 <- getTS+     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", ifSplice $ maybe False (== val) defv)+        , ("ifNotSelected", ifSplice $ maybe True (/= val) defv) ]
+ src/Snap/Extras/Tabs.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE OverloadedStrings #-}+{-| ++    Purpose of this module is to provide a simple, functional way to+    define tabs in Snap applications.++-}++module Snap.Extras.Tabs+    ( +    -- * Define Tabs in DOM via Heist+      initTabs+    , tabsSplice+    +    -- * Define Tabs in Haskell+    , TabActiveMode (..)+    , Tab+    , mkTabs+    , tab+    ) where++-------------------------------------------------------------------------------+import           Control.Monad+import           Control.Monad.Trans.Class+import           Data.Text                 (Text)+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.XmlHtml+import qualified Text.XmlHtml              as X+-------------------------------------------------------------------------------++++-------------------------------------------------------------------------------+initTabs :: HasHeist b => Initializer b v ()+initTabs = do+  addSplices [ ("tabs", liftHeist tabsSplice) ]+++                              -------------------+                              -- Splice-Driven --+                              -------------------+++-------------------------------------------------------------------------------+tabsSplice :: MonadSnap m => Splice m+tabsSplice = do+  context <- lift $ (T.decodeUtf8 . rqContextPath) `liftM` getRequest+  let bind = bindSplices [("tab", tabSplice context)]+  n <- getParamNode+  case n of+    Element t attrs ch -> localTS bind $ runNodeList [X.Element "ul" attrs ch]+    _ -> error "tabs tag has to be an Element"++++-------------------------------------------------------------------------------+tabSplice :: MonadSnap m => Text -> Splice m+tabSplice context = do+  n@(Element t attrs ch) <- getParamNode+  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"+        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]]+++-------------------------------------------------------------------------------+wErr err m = maybe (Left err) Right m+++                             --------------------+                             -- Haskell-Driven --+                             --------------------++++++-------------------------------------------------------------------------------+-- | How do we decide "active" for tab state?+data TabActiveMode+  = TAMExactMatch+  -- ^ Current url has to match exactly+  | TAMPrefixMatch+  -- ^ Only the prefix needs to match current url+  | TAMInfixMatch+  -- ^ A sub-set of the current url has to match+  | TAMDontMatch+++-------------------------------------------------------------------------------+-- | A tab is a 'Node' generator upon receiving a current URL context.+type Tab = Text -> Node+++-------------------------------------------------------------------------------+-- | Make tabs from tab definitions. Use the 'tab' combinator to+-- define individual options.+mkTabs +    :: MonadSnap m +    => Text +    -- ^ A class to be given to the parent ul tag+    -> [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+-- 'mkTabs'.+--+-- If the tab is currently active, the li tag will get a class of+-- \'active\'.+--+-- 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 +    -- ^ Target URL for tab+    -> Text +    -- ^ A text/label for tab+    -> [(Text, Text)] +    -- ^ A list of attributes as key=val+    -> TabActiveMode +    -- ^ A 'TabActiveMode' for this tab+    -> Tab+tab url text attr md context = X.Element "li" attr' [tlink url text]+  where +    cur = case md of+            TAMExactMatch -> url == context+            TAMPrefixMatch -> url `T.isPrefixOf` context+            TAMInfixMatch -> url `T.isInfixOf` context+            TAMDontMatch -> False+    attr' = if cur+            then ("class", klass) : attr+            else attr+    klass = case lookup "class" attr of+              Just k -> T.concat [k, " ", "active"]+              Nothing -> "active"+++-------------------------------------------------------------------------------+tlink :: Text -> Text -> Node+tlink target text = X.Element "a" [("href", target)] [X.TextNode text]+++-------------------------------------------------------------------------------+link :: Text -> [Node] -> Node+link target ch = X.Element "a" [("href", target)] ch
+ src/Snap/Extras/TextUtils.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE NoMonomorphismRestriction #-}++module Snap.Extras.TextUtils+    ( readT+    , showT+    , readBS+    , showBS+    ) where++-------------------------------------------------------------------------------+import qualified Data.ByteString.Char8 as B+import           Data.ByteString.Char8+import qualified Data.Text             as T+import           Data.Text+import           Safe+-------------------------------------------------------------------------------+++showT :: (Show a) => a -> Text+showT = T.pack . show+++showBS :: (Show a) => a -> ByteString+showBS = B.pack . show+++readT :: (Read a) => Text -> a+readT = readNote "Can't read value in readT" . T.unpack++++readBS :: (Read a) => ByteString -> a+readBS = readNote "Can't read value in readBS" . B.unpack++maybeEither (Left e) = Nothing+maybeEither (Right x) = Just x