diff --git a/snap-extras.cabal b/snap-extras.cabal --- a/snap-extras.cabal +++ b/snap-extras.cabal @@ -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: diff --git a/src/Snap/Extras.hs b/src/Snap/Extras.hs --- a/src/Snap/Extras.hs +++ b/src/Snap/Extras.hs @@ -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 diff --git a/src/Snap/Extras/CSRF.hs b/src/Snap/Extras/CSRF.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Extras/CSRF.hs @@ -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: +-- +-- > +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 + diff --git a/src/Snap/Extras/CoreUtils.hs b/src/Snap/Extras/CoreUtils.hs --- a/src/Snap/Extras/CoreUtils.hs +++ b/src/Snap/Extras/CoreUtils.hs @@ -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 + diff --git a/src/Snap/Extras/FlashNotice.hs b/src/Snap/Extras/FlashNotice.hs --- a/src/Snap/Extras/FlashNotice.hs +++ b/src/Snap/Extras/FlashNotice.hs @@ -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 diff --git a/src/Snap/Extras/FormUtils.hs b/src/Snap/Extras/FormUtils.hs --- a/src/Snap/Extras/FormUtils.hs +++ b/src/Snap/Extras/FormUtils.hs @@ -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 ------------------------------------------------------------------------------- diff --git a/src/Snap/Extras/NavTrails.hs b/src/Snap/Extras/NavTrails.hs --- a/src/Snap/Extras/NavTrails.hs +++ b/src/Snap/Extras/NavTrails.hs @@ -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 $ diff --git a/src/Snap/Extras/SpliceUtils/Compiled.hs b/src/Snap/Extras/SpliceUtils/Compiled.hs --- a/src/Snap/Extras/SpliceUtils/Compiled.hs +++ b/src/Snap/Extras/SpliceUtils/Compiled.hs @@ -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")) ------------------------------------------------------------------------------ diff --git a/src/Snap/Extras/SpliceUtils/Interpreted.hs b/src/Snap/Extras/SpliceUtils/Interpreted.hs --- a/src/Snap/Extras/SpliceUtils/Interpreted.hs +++ b/src/Snap/Extras/SpliceUtils/Interpreted.hs @@ -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")) ------------------------------------------------------------------------------ diff --git a/src/Snap/Extras/Tabs.hs b/src/Snap/Extras/Tabs.hs --- a/src/Snap/Extras/Tabs.hs +++ b/src/Snap/Extras/Tabs.hs @@ -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 diff --git a/src/Snap/Extras/TextUtils.hs b/src/Snap/Extras/TextUtils.hs --- a/src/Snap/Extras/TextUtils.hs +++ b/src/Snap/Extras/TextUtils.hs @@ -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)