snap-extras 0.4 → 0.6
raw patch · 11 files changed
+247/−87 lines, 11 filesdep +data-defaultdep +readabledep ~aesondep ~blaze-builderdep ~blaze-html
Dependencies added: data-default, readable
Dependency ranges changed: aeson, blaze-builder, blaze-html, bytestring, configurator, containers, digestive-functors, digestive-functors-heist, digestive-functors-snap, filepath, heist, safe, snap, snap-core, text, transformers, xmlhtml
Files
- snap-extras.cabal +32/−29
- src/Snap/Extras.hs +11/−4
- src/Snap/Extras/CSRF.hs +103/−0
- src/Snap/Extras/CoreUtils.hs +13/−0
- src/Snap/Extras/FlashNotice.hs +6/−4
- src/Snap/Extras/FormUtils.hs +0/−6
- src/Snap/Extras/NavTrails.hs +10/−8
- src/Snap/Extras/SpliceUtils/Compiled.hs +12/−0
- src/Snap/Extras/SpliceUtils/Interpreted.hs +7/−7
- src/Snap/Extras/Tabs.hs +44/−25
- src/Snap/Extras/TextUtils.hs +9/−4
snap-extras.cabal view
@@ -1,15 +1,15 @@ Name: snap-extras-Version: 0.4+Version: 0.6 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.+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+Author: Ozgun Ataman, Doug Beardsley+Maintainer: oz@soostone.com Category: Web, Snap Build-type: Simple Cabal-version: >= 1.6@@ -23,6 +23,7 @@ Exposed-modules: Snap.Extras Snap.Extras.CoreUtils+ Snap.Extras.CSRF Snap.Extras.TextUtils Snap.Extras.JSON Snap.Extras.FlashNotice@@ -37,27 +38,29 @@ hs-source-dirs: src Build-depends:- aeson >= 0.6- , base >= 4 && < 5- , blaze-builder- , blaze-html- , bytestring- , containers- , digestive-functors >= 0.3- , digestive-functors-heist >= 0.5.2- , digestive-functors-snap >= 0.3- , directory-tree >= 0.10 && < 0.12- , errors >= 1.4 && < 1.5- , filepath- , heist >= 0.11- , mtl >= 2.0 && < 2.2- , safe- , snap >= 0.10- , snap-core >= 0.7- , text- , transformers- , xmlhtml >= 0.1.6- , configurator >= 0.2+ aeson >= 0.6 && < 0.7+ , base >= 4 && < 5+ , blaze-builder >= 0.3 && < 0.4+ , blaze-html >= 0.6 && < 0.7+ , bytestring >= 0.9.1 && < 0.11+ , configurator >= 0.2 && < 0.3+ , containers >= 0.3 && < 0.6+ , data-default >= 0.5 && < 0.6+ , digestive-functors >= 0.3 && < 0.7+ , digestive-functors-heist >= 0.5.2 && < 0.8+ , digestive-functors-snap >= 0.3 && < 0.7+ , directory-tree >= 0.10 && < 0.12+ , errors >= 1.4 && < 1.5+ , filepath >= 1.1 && < 1.4+ , heist >= 0.12 && < 0.13+ , mtl >= 2.0 && < 2.2+ , readable >= 0.1 && < 0.2+ , safe >= 0.3 && < 0.4+ , snap >= 0.10 && < 0.13+ , snap-core >= 0.7 && < 0.10+ , text >= 0.11 && < 0.12+ , transformers >= 0.2 && < 0.4+ , xmlhtml >= 0.1.6 && < 0.3 -- Other-modules:
src/Snap/Extras.hs view
@@ -11,6 +11,8 @@ ) where -------------------------------------------------------------------------------+import Data.Monoid+import Heist import Snap.Snaplet import Snap.Snaplet.Heist import Snap.Snaplet.Session@@ -20,6 +22,7 @@ import Snap.Extras.FlashNotice import Snap.Extras.FormUtils import Snap.Extras.JSON+import qualified Snap.Extras.SpliceUtils.Compiled as C import qualified Snap.Extras.SpliceUtils.Interpreted as I import Snap.Extras.Tabs import Snap.Extras.TextUtils@@ -40,7 +43,11 @@ "Snap Extras" "Collection of utilities for web applications" (Just getDataDir) $ do- addTemplatesAt heistSnaplet "" . (</> "resources/templates") =<< getSnapletFilePath- initFlashNotice session- I.addUtilSplices- initTabs+ addTemplatesAt heistSnaplet "" . (</> "resources/templates")+ =<< getSnapletFilePath+ initFlashNotice heistSnaplet session+ addConfig heistSnaplet $ mempty+ { hcInterpretedSplices = I.utilSplices+ , hcCompiledSplices = C.utilSplices+ }+ initTabs heistSnaplet
+ src/Snap/Extras/CSRF.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE OverloadedStrings #-}++module Snap.Extras.CSRF where++------------------------------------------------------------------------------+import qualified Data.ByteString.Char8 as B+import Data.Text (Text)+import qualified Data.Text.Encoding as T+import Snap+import Snap.Snaplet.Session+import Heist+import Heist.Interpreted+import qualified Text.XmlHtml as X+------------------------------------------------------------------------------++++------------------------------------------------------------------------------+-- | A splice that makes the CSRF token available to templates. Typically we+-- use it by binding a splice and using the CSRF token provided by the session+-- snaplet as follows:+--+-- @(\"csrfToken\", csrfTokenSplice $ with session 'csrfToken')@+--+-- Where @session@ is a lens to the session snaplet. Then you can make it+-- available to javascript code by putting a meta tag at the top of every+-- page like this:+--+-- > <meta name="csrf-token" content="${csrfToken}">+csrfTokenSplice :: Monad m+ => m Text+ -- ^ A computation in the runtime monad that gets the+ -- CSRF protection token.+ -> Splice m+csrfTokenSplice f = do+ token <- lift f+ textSplice token+++------------------------------------------------------------------------------+-- | Adds a hidden _csrf input field as the first child of the bound tag. For+-- full site protection against CSRF, you should bind this splice to the form+-- tag, and then make sure your app checks all POST requests for the presence+-- of this CSRF token and that the token is randomly generated and secure on a+-- per session basis.+secureForm :: MonadIO m+ => m Text+ -- ^ A computation in the runtime monad that gets the CSRF+ -- protection token.+ -> Splice m+secureForm mToken = do+ n <- getParamNode+ token <- lift mToken+ let input = X.Element "input"+ [("type", "hidden"), ("name", "_csrf"), ("value", token)] []+ case n of+ X.Element nm as cs -> do+ cs' <- runNodeList cs+ let newCs = if take 1 cs' == [input] then cs' else (input : cs')+ stopRecursion+ return [X.Element nm as newCs]+ _ -> return [n] -- "impossible"+++------------------------------------------------------------------------------+-- | Use this function to wrap your whole site with CSRF protection. Due to+-- security considerations, the way Snap parses file uploads+-- means that the CSRF token cannot be checked before the file uploads have+-- been handled. This function protects your whole site except for handlers+-- of multipart/form-data forms (forms with file uploads). To protect those+-- handlers, you have to call handleCSRF explicitly after the file has been+-- processed.+blanketCSRF :: SnapletLens v SessionManager+ -- ^ Lens to the session snaplet+ -> Handler b v ()+ -- ^ Handler to run if the CSRF check fails+ -> Handler b v ()+blanketCSRF session onFailure = do+ h <- getHeader "Content-type" `fmap` getRequest+ case maybe False (B.isInfixOf "multipart/form-data") h of+ True -> return ()+ False -> handleCSRF session onFailure+++------------------------------------------------------------------------------+-- | If a request is a POST, check the CSRF token and fail with the specified+-- handler if the check fails. If if the token is correct or if it's not a+-- POST request, then control passes through as a no-op.+handleCSRF :: SnapletLens v SessionManager+ -- ^ Lens to the session snaplet+ -> Handler b v ()+ -- ^ Handler to run on failure+ -> Handler b v ()+handleCSRF session onFailure = do+ m <- getsRequest rqMethod+ if m /= POST+ then return ()+ else do tok <- getParam "_csrf"+ realTok <- with session csrfToken+ if tok == Just (T.encodeUtf8 realTok)+ then return ()+ else onFailure >> getResponse >>= finishWith+
src/Snap/Extras/CoreUtils.hs view
@@ -20,6 +20,7 @@ , undirify , maybeBadReq , fromMaybeM+ , (-/-) ) where -------------------------------------------------------------------------------@@ -168,4 +169,16 @@ -- | Evaluates an action that returns a Maybe and fromMaybeM :: Monad m => m a -> m (Maybe a) -> m a fromMaybeM e f = maybe e return =<< f+++------------------------------------------------------------------------------+-- | Concatenates two URL segments with a '/' between them. To prevent double+-- slashes, all trailing slashes are removed from the first path and all+-- leading slashes are removed from the second path.+(-/-) :: ByteString -> ByteString -> ByteString+(-/-) a b = B.concat [revDrop a, "/", dropSlash b]+ where+ dropSlash = B.dropWhile (=='/')+ revDrop = B.reverse . dropSlash . B.reverse+
src/Snap/Extras/FlashNotice.hs view
@@ -34,10 +34,12 @@ -- for examples. initFlashNotice :: HasHeist b - => SnapletLens b SessionManager -> Initializer b v ()-initFlashNotice session = do- addSplices [("flash", flashSplice session)]-+ => Snaplet (Heist b) -> SnapletLens b SessionManager -> Initializer b v ()+initFlashNotice h session = do+ let splices = [ ("flash", flashSplice session) ]+ csplices = [ ("flash", flashCSplice session) ]+ addConfig h $ mempty { hcCompiledSplices = csplices+ , hcInterpretedSplices = splices } ------------------------------------------------------------------------------- -- | Display an info message on next load of a page
src/Snap/Extras/FormUtils.hs view
@@ -24,20 +24,14 @@ ------------------------------------------------------------------------------- import Control.Error-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 Data.Text.Encoding import qualified Data.Text as T import Heist-import Safe import Snap.Core import Text.Digestive-import Text.Digestive.Snap import qualified Text.XmlHtml as X -------------------------------------------------------------------------------
@@ -7,10 +7,8 @@ import Blaze.ByteString.Builder.ByteString import Control.Monad.State.Strict import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as B import Data.Maybe import Data.Monoid-import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text.Encoding as T import Snap.Core@@ -31,12 +29,6 @@ ----------------------------------------------------------------------------------initNavTrail--- :: HasHeist b--- => SnapletLens b SessionManager--- -> Bool--- -- ^ Auto-add all splices?--- -> SnapletInit b (NavTrail b) initNavTrail :: SnapletLens b SessionManager -- ^ Lens to the session snaplet -> Maybe (Snaplet (Heist b))@@ -53,12 +45,14 @@ ------------------------------------------------------------------------------- -- |+setFocus :: Handler b (NavTrail b) () setFocus = do setFocus' =<< rqURI `fmap` getRequest ------------------------------------------------------------------------------- -- |+setFocus' :: ByteString -> Handler b (NavTrail b) () setFocus' uri = do sl <- gets ntSes withSession sl $ withTop sl $ do@@ -67,6 +61,7 @@ ------------------------------------------------------------------------------- -- |+setFocusToRef :: Handler b (NavTrail b) () setFocusToRef = do sl <- gets ntSes (maybe "/" id . getHeader "Referer") `fmap` getRequest >>=@@ -75,22 +70,26 @@ ------------------------------------------------------------------------------- -- |+getFocus :: Handler b (NavTrail b) (Maybe Text) getFocus = do sl <- gets ntSes withTop sl (getFromSession "_nt_focus") +getFocusDef :: Text -> Handler b (NavTrail b) Text getFocusDef def = (fromJust . (`mplus` Just def)) `fmap` getFocus ------------------------------------------------------------------------------- -- |+redirBack :: MonadSnap m => m a redirBack = redirect =<< (maybe "/" id . getHeader "Referer") `fmap` getRequest ------------------------------------------------------------------------------- -- |+redirFocus :: ByteString -> Handler b (NavTrail b) a redirFocus def = do f <- (`mplus` Just def) `fmap` (fmap T.encodeUtf8 `fmap` getFocus) redirect $ fromJust f@@ -107,6 +106,7 @@ backCSplice = return $ C.yieldRuntime $ do lift $ (fromByteString . rqURI) `fmap` getRequest + ------------------------------------------------------------------------------- -- | focusSplice :: SnapletLens (Snaplet v) (NavTrail b)@@ -121,8 +121,10 @@ uri <- lift $ with' lens getFocus return $ fromMaybe "" uri + ------------------------------------------------------------------------------- -- |+addNavTrailSplices :: Snaplet (Heist b) -> Initializer b (NavTrail b) () addNavTrailSplices heist = do lens <- getLens addConfig heist $
src/Snap/Extras/SpliceUtils/Compiled.hs view
@@ -6,6 +6,7 @@ import Blaze.ByteString.Builder.ByteString import Control.Monad.Trans import Data.Monoid+import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Snap.Core@@ -14,6 +15,17 @@ import Heist.Compiled import Text.XmlHtml -------------------------------------------------------------------------------+++utilSplices :: MonadSnap m => [(Text, Splice m)]+utilSplices = [ ("rqparam", paramSplice)+ , ("refererLink", refererCSplice)+ ]+++refererCSplice :: MonadSnap m => Splice m+refererCSplice = return $ yieldRuntimeText $ return .+ maybe "/" T.decodeUtf8 =<< lift (getsRequest (getHeader "Referer")) ------------------------------------------------------------------------------
src/Snap/Extras/SpliceUtils/Interpreted.hs view
@@ -4,11 +4,11 @@ module Snap.Extras.SpliceUtils.Interpreted ( paramSplice , utilSplices- , addUtilSplices , selectSplice , runTextAreas , scriptsSplice , ifFlagSplice+ , refererSplice ) where -------------------------------------------------------------------------------@@ -29,17 +29,17 @@ ---------------------------------------------------------------------------------- | 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, SnapletISplice b)] utilSplices = [ ("rqparam", paramSplice)+ , ("refererLink", refererSplice) ]+++refererSplice :: MonadSnap m => Splice m+refererSplice =+ textSplice . maybe "/" T.decodeUtf8 =<< lift (getsRequest (getHeader "Referer")) ------------------------------------------------------------------------------
src/Snap/Extras/Tabs.hs view
@@ -21,8 +21,10 @@ ) where -------------------------------------------------------------------------------+import Control.Error import Control.Monad-import Control.Monad.Trans.Class+import Control.Monad.Trans+import Data.Monoid import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -39,9 +41,12 @@ --------------------------------------------------------------------------------initTabs :: HasHeist b => Initializer b v ()-initTabs = do- addSplices [ ("tabs", tabsSplice) ]+initTabs :: HasHeist b => Snaplet (Heist b) -> Initializer b v ()+initTabs h = do+ let splices = [ ("tabs", tabsSplice) ]+ csplices = [ ("tabs", tabsCSplice) ]+ addConfig h $ mempty { hcCompiledSplices = csplices+ , hcInterpretedSplices = splices } -------------------@@ -50,38 +55,59 @@ ---------------------------------------------------------------------------------- | Compiled splice for tabs. This is not automatically bound by initTabs.--- You have to bind it yourself.+-- | Compiled splice for tabs. tabsCSplice :: MonadSnap m => C.Splice m tabsCSplice = do n <- getParamNode- let getContext = lift $ (T.decodeUtf8 . rqURI) `liftM` getRequest- splices = [("tab", C.defer tabCSplice getContext)]+ let getCtx = lift $ (T.decodeUtf8 . rqURI) `liftM` getRequest+ splices = [("tab", C.defer tabCSplice getCtx)] case n of- Element t attrs ch -> C.withLocalSplices splices [] $+ Element _ attrs ch -> C.withLocalSplices splices [] $ C.runNode $ X.Element "ul" attrs ch _ -> error "tabs tag has to be an Element" --------------------------------------------------------------------------------+------------------------------------------------------------------------------+-- | Can't use tabSpliceWorker because we have to explicitly run the+-- attributes in order to get ${} splice substitution. tabCSplice :: Monad m => C.Promise Text -> C.Splice m tabCSplice promise = do- n <- getParamNode- C.pureSplice (C.nodeSplice $ tabSpliceWorker n) promise+ (Element _ attrs ch) <- getParamNode+ attrsAction <- C.runAttributesRaw attrs+ let ps as context = do+ m <- note "tab must specify a 'match' attribute" $ lookup "match" as+ url <- note "tabs must specify a 'url' attribute" $ lookup "url" as+ 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"+ return (url, ch, m')+ return $ C.yieldRuntime $ do+ ctx <- C.getPromise promise+ as <- attrsAction+ let res = case ps as ctx of+ Left e -> error $ "Tab error: " ++ e+ Right (url, c, match) ->+ let attr' = if match then ("class", "active") : as else as+ a = X.Element "a" (("href", url) : as) c+ in X.renderHtmlFragment X.UTF8 [X.Element "li" attr' [a]]+ return res tabSpliceWorker :: Node -> Text -> [Node] tabSpliceWorker n@(Element _ attrs ch) context = case ps of Left e -> error $ "Tab error: " ++ e- Right (url, ch, match) ->+ Right (url, c, match) -> let attr' = if match then ("class", "active") : attrs else attrs- a = X.Element "a" (("href", url) : attrs) ch+ a = X.Element "a" (("href", url) : attrs) c in [X.Element "li" attr' [a]] where 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 <- note "tab must specify a 'match' attribute" $ lookup "match" attrs+ url <- note "tabs must specify a 'url' attribute" $ getAttribute "url" n m' <- case m of "Exact" -> Right $ url == context "Prefix" -> Right $ url `T.isPrefixOf` context@@ -89,6 +115,7 @@ "None" -> Right $ False _ -> Left "Unknown match type" return (url, ch, m')+tabSpliceWorker _ _ = [] -------------------------------------------------------------------------------@@ -98,7 +125,7 @@ let bind = bindSplices [("tab", tabSplice context)] n <- getParamNode case n of- Element t attrs ch -> localHS bind $ runNodeList [X.Element "ul" attrs ch]+ Element _ attrs ch -> localHS bind $ runNodeList [X.Element "ul" attrs ch] _ -> error "tabs tag has to be an Element" @@ -110,10 +137,7 @@ return $ tabSpliceWorker n context ---------------------------------------------------------------------------------wErr err m = maybe (Left err) Right m - -------------------- -- Haskell-Driven -- --------------------@@ -193,8 +217,3 @@ ------------------------------------------------------------------------------- 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
@@ -5,13 +5,15 @@ , showT , readBS , showBS+ , titleCase ) where ------------------------------------------------------------------------------- import qualified Data.ByteString.Char8 as B-import Data.ByteString.Char8+import Data.ByteString.Char8 (ByteString)+import Data.Char import qualified Data.Text as T-import Data.Text+import Data.Text (Text) import Safe ------------------------------------------------------------------------------- @@ -32,5 +34,8 @@ readBS :: (Read a) => ByteString -> a readBS = readNote "Can't read value in readBS" . B.unpack -maybeEither (Left e) = Nothing-maybeEither (Right x) = Just x++titleCase :: Text -> Text+titleCase = T.unwords . map upFirst . T.words+ where+ upFirst str = T.cons (toUpper $ T.head str) (T.tail str)