snap-extras 0.2.2 → 0.3

raw patch · 7 files changed

+89/−36 lines, 7 filesdep +errorsdep +mtldep ~directory-treedep ~heistdep ~snapnew-uploader

Dependencies added: errors, mtl

Dependency ranges changed: directory-tree, heist, snap

Files

• snap-extras.cabal +8/−4
• src/Snap/Extras.hs +6/−4
• src/Snap/Extras/CoreUtils.hs +47/−2
• src/Snap/Extras/FlashNotice.hs +14/−13
• src/Snap/Extras/FormUtils.hs +1/−1
• src/Snap/Extras/SpliceUtils.hs +9/−8
• src/Snap/Extras/Tabs.hs +4/−4

@@ -1,5 +1,5 @@ Name:                snap-extras-Version:             0.2.2+Version:             0.3 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@@ -42,11 +42,13 @@     , data-lens >= 2.0     , digestive-functors >= 0.3     , digestive-functors-snap >= 0.3-    , directory-tree >= 0.10 && < 0.11+    , directory-tree >= 0.10 && < 0.12+    , errors >= 1.3.1 && < 1.4     , filepath-    , heist >= 0.7+    , heist >= 0.10+    , mtl >= 2.0 && < 2.2     , safe-    , snap >= 0.7+    , snap >= 0.10     , snap-core >= 0.7     , text     , transformers@@ -54,4 +56,6 @@     , configurator >= 0.2      -- Other-modules:       ++  ghc-options: -Wall -fwarn-tabs   

@@ -12,7 +12,6 @@     ) where  --------------------------------------------------------------------------------import Data.Lens.Common import Snap.Snaplet import Snap.Snaplet.Heist import Snap.Snaplet.Session@@ -33,13 +32,16 @@ ------------------------------------------------------------------------------- -- | 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 = +initExtras :: HasHeist b+           => Snaplet (Heist b)+           -> SnapletLens b SessionManager+           -> SnapletInit b ()+initExtras heistSnaplet session =    makeSnaplet      "Snap Extras"      "Collection of utilities for web applications"      (Just getDataDir) $ do-      addTemplatesAt "" . (</> "resources/templates") =<< getSnapletFilePath+      addTemplatesAt heistSnaplet "" . (</> "resources/templates") =<< getSnapletFilePath       initFlashNotice session       addUtilSplices       initTabs

@@ -14,14 +14,19 @@     , reqParam     , readParam     , readMayParam+    , redirectReferer+    , redirectRefererFunc+    , dirify+    , undirify     ) where  --------------------------------------------------------------------------------import Snap.Core+import Control.Monad import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B-import Control.Monad+import Data.Maybe import Safe+import Snap.Core -------------------------------------------------------------------------------  @@ -111,3 +116,43 @@ readMayParam k = do    p <- getParam k   return $ readMay . B.unpack =<< p+++------------------------------------------------------------------------------+-- | Redirects back to the refering page.  If there is no Referer header, then+-- redirect to /.+redirectReferer :: MonadSnap m => m b+redirectReferer = redirectRefererFunc (fromMaybe "/")+++------------------------------------------------------------------------------+-- | Redirects back to the refering page.  If there is no Referer header, then+-- redirect to /.+redirectRefererFunc :: MonadSnap m => (Maybe ByteString -> ByteString) -> m b+redirectRefererFunc f = do+    req <- getRequest+    let referer = getHeader "Referer" req +    redirect $ f referer+++------------------------------------------------------------------------------+-- | If the current rqURI does not have a trailing slash, then redirect to the+-- same page with a slash added.+dirify :: MonadSnap m => m ()+dirify = do+    uri <- withRequest (return . rqURI)+    if B.length uri > 1 && B.last uri /= '/'+      then redirect (uri `B.append` "/")+      else return ()+++------------------------------------------------------------------------------+-- | If the current rqURI has a trailing slash, then redirect to the same page+-- with no trailing slash.+undirify :: MonadSnap m => m ()+undirify = do+    uri <- withRequest (return . rqURI)+    if B.length uri > 1 && B.last uri == '/'+      then redirect (B.init uri)+      else return ()+

@@ -12,13 +12,14 @@  ------------------------------------------------------------------------------- import           Control.Monad-import           Data.Lens.Common+import           Control.Monad.Trans 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           Heist+import           Heist.Interpreted import           Text.XmlHtml ------------------------------------------------------------------------------- @@ -29,32 +30,32 @@ -- for examples. initFlashNotice      :: HasHeist b -    => Lens b (Snaplet SessionManager) -> Initializer b v ()+    => SnapletLens b 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 :: SnapletLens b 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 :: SnapletLens b 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 :: SnapletLens b 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 :: SnapletLens b SessionManager -> Text -> Handler b b () flashError session msg = withSession session $ with session $ setInSession "_error" msg  @@ -63,16 +64,16 @@ -- -- Ex: <flash type='warning'/> -- Ex: <flash type='success'/>-flashSplice :: Lens b (Snaplet SessionManager) -> SnapletSplice b v+flashSplice :: SnapletLens b SessionManager -> SnapletISplice b flashSplice session = do-  typ <- liftHeist $ liftM (getAttribute "type") getParamNode+  typ <- liftM (getAttribute "type") getParamNode   let typ' = maybe "warning" id typ   let k = T.concat ["_", typ']-  msg <- liftHandler $ withTop session $ getFromSession k+  msg <- lift $ withTop session $ getFromSession k   case msg of -    Nothing -> liftHeist $ return []+    Nothing -> return []     Just msg' -> do-      liftHandler $ withTop session $ deleteFromSession k >> commitSession-      liftHeist $ callTemplateWithText "_flash"+      lift $ withTop session $ deleteFromSession k >> commitSession+      callTemplateWithText "_flash"            [ ("type", typ') , ("message", msg') ] 

@@ -32,7 +32,7 @@ import           Snap.Core import           Text.Digestive import           Text.Digestive.Snap-import           Text.Templating.Heist+import           Heist -------------------------------------------------------------------------------  

@@ -25,7 +25,8 @@ import           Snap.Snaplet.Heist import           System.Directory.Tree import           System.FilePath-import           Text.Templating.Heist+import           Heist+import           Heist.Interpreted import           Text.XmlHtml ------------------------------------------------------------------------------- @@ -38,9 +39,9 @@  ------------------------------------------------------------------------------- -- | A list of splices offered in this module-utilSplices :: [(Text, SnapletSplice b v)]+utilSplices :: [(Text, SnapletISplice b)] utilSplices =-  [ ("rqparam", liftHeist paramSplice)+  [ ("rqparam", paramSplice)   ]  @@ -78,7 +79,7 @@ runTextAreas = bindSplices [ ("textarea", ta)]  where    ta = do-     hs <- getTS+     hs <- getHS      n@(Element t ats _) <- getParamNode      let nm = nodeText n      case lookupSplice nm hs of@@ -157,11 +158,11 @@ -- This will look for an entry inside your .cfg file: -- -- > beta-functions-enabled = true-ifFlagSplice :: SnapletSplice b v+ifFlagSplice :: SnapletISplice b ifFlagSplice = do-  Element t ats es <- liftHeist getParamNode-  conf <- liftHandler getSnapletUserConfig-  liftHeist $ case lookup "ref" ats of+  Element t ats es <- getParamNode+  conf <- lift getSnapletUserConfig+  case lookup "ref" ats of     Nothing -> return []     Just flag -> do       res <- liftIO $ C.lookup conf flag

@@ -28,8 +28,8 @@ import           Snap.Core import           Snap.Snaplet import           Snap.Snaplet.Heist-import           Text.Templating.Heist-import           Text.Templating.Heist+import           Heist+import           Heist.Interpreted import           Text.XmlHtml import qualified Text.XmlHtml              as X -------------------------------------------------------------------------------@@ -39,7 +39,7 @@ ------------------------------------------------------------------------------- initTabs :: HasHeist b => Initializer b v () initTabs = do-  addSplices [ ("tabs", liftHeist tabsSplice) ]+  addSplices [ ("tabs", tabsSplice) ]                                 -------------------@@ -54,7 +54,7 @@   let bind = bindSplices [("tab", tabSplice context)]   n <- getParamNode   case n of-    Element t attrs ch -> localTS bind $ runNodeList [X.Element "ul" attrs ch]+    Element t attrs ch -> localHS bind $ runNodeList [X.Element "ul" attrs ch]     _ -> error "tabs tag has to be an Element"