Merge from upstream

snap-extras.cabal

@@ -1,15 +1,15 @@
 Name:                snap-extras
-Version:             0.3
+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 @@ Library
   Exposed-modules:     
     Snap.Extras
     Snap.Extras.CoreUtils
+    Snap.Extras.CSRF
     Snap.Extras.TextUtils
     Snap.Extras.JSON
     Snap.Extras.FlashNotice
@@ -37,28 +38,30 @@ Library
 
   hs-source-dirs: src
   Build-depends:
-      aeson >= 0.6
-    , attoparsec >= 0.10
-    , 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.3.1 && < 1.4
-    , 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
+    , attoparsec               >= 0.10  && < 0.11
+    , 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

@@ -11,6 +11,8 @@ module Snap.Extras
     ) where
 
 -------------------------------------------------------------------------------
+import           Data.Monoid
+import           Heist
 import           Snap.Snaplet
 import           Snap.Snaplet.Heist
 import           Snap.Snaplet.Session
@@ -20,6 +22,7 @@ import           Snap.Extras.CoreUtils
 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 @@ initExtras heistSnaplet session =
     "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

@@ -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

@@ -21,6 +21,7 @@ module Snap.Extras.CoreUtils
     , undirify
     , maybeBadReq
     , fromMaybeM
+    , (-/-)
     ) where
 
 -------------------------------------------------------------------------------
@@ -186,3 +187,15 @@ maybeBadReq e f = fromMaybeM (badReq e) f
 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

@@ -34,10 +34,12 @@ import           Text.XmlHtml
 -- 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

@@ -24,20 +24,14 @@ module Snap.Extras.FormUtils
 
 -------------------------------------------------------------------------------
 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
 -------------------------------------------------------------------------------