diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/resources/templates/_flash.tpl b/resources/templates/_flash.tpl new file mode 100644 --- /dev/null +++ b/resources/templates/_flash.tpl @@ -0,0 +1,4 @@ +
+ × + +
diff --git a/resources/templates/_select.tpl b/resources/templates/_select.tpl new file mode 100644 --- /dev/null +++ b/resources/templates/_select.tpl @@ -0,0 +1,10 @@ + diff --git a/snap-extras.cabal b/snap-extras.cabal new file mode 100644 --- /dev/null +++ b/snap-extras.cabal @@ -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: + diff --git a/src/Snap/Extras.hs b/src/Snap/Extras.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Extras.hs @@ -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 diff --git a/src/Snap/Extras/CoreUtils.hs b/src/Snap/Extras/CoreUtils.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Extras/CoreUtils.hs @@ -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 diff --git a/src/Snap/Extras/FlashNotice.hs b/src/Snap/Extras/FlashNotice.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Extras/FlashNotice.hs @@ -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: +-- Ex: +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') ] + diff --git a/src/Snap/Extras/FormUtils.hs b/src/Snap/Extras/FormUtils.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Extras/FormUtils.hs @@ -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) diff --git a/src/Snap/Extras/JSON.hs b/src/Snap/Extras/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Extras/JSON.hs @@ -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 diff --git a/src/Snap/Extras/SpliceUtils.hs b/src/Snap/Extras/SpliceUtils.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Extras/SpliceUtils.hs @@ -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: +-- +-- +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) ] diff --git a/src/Snap/Extras/Tabs.hs b/src/Snap/Extras/Tabs.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Extras/Tabs.hs @@ -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 diff --git a/src/Snap/Extras/TextUtils.hs b/src/Snap/Extras/TextUtils.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Extras/TextUtils.hs @@ -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