diff --git a/Spock.cabal b/Spock.cabal --- a/Spock.cabal +++ b/Spock.cabal @@ -1,7 +1,7 @@ name: Spock -version: 0.4.3.1 +version: 0.4.3.2 synopsis: Another Haskell web toolkit based on scotty -description: This toolbox provides everything you need to get a quick start into web hacking with haskell: sessions, cookies, database helper, global state and the power of scotty +description: This toolbox provides everything you need to get a quick start into web hacking with haskell: sessions, cookies, database helper, csrf-protection, global state and the power of scotty Homepage: https://github.com/agrafix/Spock Bug-reports: https://github.com/agrafix/Spock/issues license: BSD3 @@ -17,7 +17,8 @@ other-modules: Web.Spock.SessionManager, Web.Spock.Monad, Web.Spock.Cookie, - Web.Spock.Types + Web.Spock.Types, + Web.Spock.SafeActions build-depends: base >= 4 && < 5, scotty >= 0.6, wai >=2.0, @@ -42,7 +43,8 @@ random ==1.*, pool-conduit ==0.1.*, vault ==0.3.*, - path-pieces ==0.1.* + path-pieces ==0.1.*, + hashable ==1.2.* ghc-options: -Wall -fno-warn-orphans source-repository head diff --git a/Web/Spock.hs b/Web/Spock.hs --- a/Web/Spock.hs +++ b/Web/Spock.hs @@ -15,6 +15,9 @@ , readSession, writeSession, modifySession -- * Cookies , setCookie, setCookie', getCookie + -- * Safe actions + , SafeAction (..) + , safeActionPath -- * General Routing , get, post, put, delete, patch, addroute, Http.StdMethod (..) -- * Other reexports from scotty @@ -35,6 +38,7 @@ import Web.Spock.Monad import Web.Spock.Types import Web.Spock.Cookie +import Web.Spock.SafeActions import Control.Applicative import Control.Monad.Trans.Reader @@ -73,6 +77,7 @@ scottyT port runM runActionToIO $ do middleware (sm_middleware sessionMgr) + hookSafeActions defs -- | Write to the current session. Note that all data is stored on the server. diff --git a/Web/Spock/SafeActions.hs b/Web/Spock/SafeActions.hs new file mode 100644 --- /dev/null +++ b/Web/Spock/SafeActions.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +module Web.Spock.SafeActions where + +import Web.Scotty.Trans +import Web.Spock.Types +import Web.Spock.Monad + +import qualified Data.Text as T + +-- | Wire up a safe action: Safe actions are actions that are protected from +-- csrf attacks. Here's a usage example: +-- +-- > newtype DeleteUser = DeleteUser Int deriving (Hashable, Typeable, Eq) +-- > +-- > instance SafeAction DeleteUser where +-- > runSafeAction (DeleteUser i) = +-- > do runQuery $ deleteUserFromDb i +-- > redirect "/user-list" +-- > +-- > get "/user-details/:userId" $ +-- > do userId <- param "userId" +-- > deleteUrl <- safeActionPath (DeleteUser userId) +-- > html $ TL.concat [ "Click here to delete user!" ] +-- +-- Note that safeActions currently only support GET and POST requests. +-- +safeActionPath :: forall a conn sess st. SafeAction a + => a -> SpockAction conn sess st T.Text +safeActionPath safeAction = + do mgr <- getSessMgr + hash <- (sm_addSafeAction mgr) (PackedSafeAction safeAction) + return $ T.concat [ "/h/", hash ] + +hookSafeActions :: SpockM conn sess st () +hookSafeActions = + do get "/h/:spock-csurf-protection" run + post "/h/:spock-csurf-protection" run + where + run :: SpockAction conn sess st () + run = + do h <- param "spock-csurf-protection" + mgr <- getSessMgr + mAction <- (sm_lookupSafeAction mgr) h + case mAction of + Nothing -> + next + Just (PackedSafeAction action) -> + runSafeAction action diff --git a/Web/Spock/SessionManager.hs b/Web/Spock/SessionManager.hs --- a/Web/Spock/SessionManager.hs +++ b/Web/Spock/SessionManager.hs @@ -13,17 +13,17 @@ import Data.Time import System.Random import Web.Scotty.Trans -import qualified Data.Vault.Lazy as V -import qualified Data.ByteString.Char8 as BSC import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Network.Wai as Wai import qualified Data.Text.Lazy.Encoding as TL -import qualified Data.ByteString.Lazy as BSL +import qualified Data.Vault.Lazy as V +import qualified Network.Wai as Wai import qualified Network.Wai.Util as Wai - createSessionManager :: SessionCfg a -> IO (SessionManager a) createSessionManager cfg = do cacheHM <- atomically $ newTVar HM.empty @@ -33,13 +33,28 @@ , sm_writeSession = writeSessionImpl vaultKey cacheHM , sm_modifySession = modifySessionImpl vaultKey cacheHM , sm_middleware = sessionMiddleware cfg vaultKey cacheHM + , sm_addSafeAction = addSafeActionImpl vaultKey cacheHM + , sm_lookupSafeAction = lookupSafeActionImpl vaultKey cacheHM } -readSessionImpl :: (SpockError e, MonadIO m) +modifySessionBase :: (SpockError e, MonadIO m) + => V.Key SessionId + -> UserSessions a + -> (Session a -> Session a) + -> ActionT e m () +modifySessionBase vK sessionRef modFun = + do req <- request + case V.lookup vK (Wai.vault req) of + Nothing -> + error "(3) Internal Spock Session Error. Please report this bug!" + Just sid -> + liftIO $ atomically $ modifyTVar sessionRef (HM.adjust modFun sid) + +readSessionBase :: (SpockError e, MonadIO m) => V.Key SessionId -> UserSessions a - -> ActionT e m a -readSessionImpl vK sessionRef = + -> ActionT e m (Session a) +readSessionBase vK sessionRef = do req <- request case V.lookup vK (Wai.vault req) of Nothing -> @@ -50,8 +65,45 @@ Nothing -> error "(2) Internal Spock Session Error. Please report this bug!" Just session -> - return (sess_data session) + return session +addSafeActionImpl :: (SpockError e, MonadIO m) + => V.Key SessionId + -> UserSessions sess + -> PackedSafeAction + -> ActionT e m SafeActionHash +addSafeActionImpl vaultKey cacheHM safeAction = + do base <- readSessionBase vaultKey cacheHM + case HM.lookup safeAction (sas_reverse (sess_safeActions base)) of + Just safeActionHash -> + return safeActionHash + Nothing -> + do safeActionHash <- liftIO (randomHash 40) + let f sas = + sas + { sas_forward = HM.insert safeActionHash safeAction (sas_forward sas) + , sas_reverse = HM.insert safeAction safeActionHash (sas_reverse sas) + } + modifySessionBase vaultKey cacheHM (\s -> s { sess_safeActions = f (sess_safeActions s) }) + return safeActionHash + +lookupSafeActionImpl :: (SpockError e, MonadIO m) + => V.Key SessionId + -> UserSessions sess + -> SafeActionHash + -> ActionT e m (Maybe PackedSafeAction) +lookupSafeActionImpl vaultKey cacheHM hash = + do base <- readSessionBase vaultKey cacheHM + return $ HM.lookup hash (sas_forward (sess_safeActions base)) + +readSessionImpl :: (SpockError e, MonadIO m) + => V.Key SessionId + -> UserSessions a + -> ActionT e m a +readSessionImpl vK sessionRef = + do base <- readSessionBase vK sessionRef + return (sess_data base) + writeSessionImpl :: (SpockError e, MonadIO m) => V.Key SessionId -> UserSessions a @@ -66,15 +118,9 @@ -> (a -> a) -> ActionT e m () modifySessionImpl vK sessionRef f = - do req <- request - case V.lookup vK (Wai.vault req) of - Nothing -> - error "(3) Internal Spock Session Error. Please report this bug!" - Just sid -> - do let modFun session = + do let modFun session = session { sess_data = f (sess_data session) } - liftIO $ atomically $ modifyTVar sessionRef (HM.adjust modFun sid) - + modifySessionBase vK sessionRef modFun sessionMiddleware :: SessionCfg a -> V.Key SessionId @@ -140,11 +186,17 @@ createSession :: SessionCfg a -> a -> IO (Session a) createSession sessCfg content = - do gen <- g - let sid = T.decodeUtf8 $ B64.encode $ BSC.pack $ - take (sc_sessionIdEntropy sessCfg) $ randoms gen + do sid <- randomHash (sc_sessionIdEntropy sessCfg) now <- getCurrentTime let validUntil = addUTCTime (sc_sessionTTL sessCfg) now - return (Session sid validUntil content) + emptySafeActions = + SafeActionStore HM.empty HM.empty + return (Session sid validUntil content emptySafeActions) + +randomHash :: Int -> IO T.Text +randomHash len = + do gen <- g + return $ T.decodeUtf8 $ B64.encode $ BSC.pack $ + take len $ randoms gen where g = newStdGen :: IO StdGen diff --git a/Web/Spock/Types.hs b/Web/Spock/Types.hs --- a/Web/Spock/Types.hs +++ b/Web/Spock/Types.hs @@ -3,23 +3,26 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ExistentialQuantification #-} module Web.Spock.Types where import Web.Scotty.Trans import Control.Applicative import Control.Concurrent.STM +import Control.Monad.Base import Control.Monad.Reader +import Control.Monad.Trans.Control import Control.Monad.Trans.Resource +import Data.Hashable import Data.Pool +import Data.Text.Lazy (Text) import Data.Time.Clock ( UTCTime(..), NominalDiffTime ) +import Data.Typeable +import Network.Wai import qualified Data.Conduit.Pool as CP import qualified Data.HashMap.Strict as HM import qualified Data.Text as T -import Data.Text.Lazy (Text) -import Control.Monad.Trans.Control -import Control.Monad.Base -import Network.Wai type SpockError e = ScottyError e @@ -75,6 +78,28 @@ , web_state :: st } +-- | SafeActions are actions that need to be protected from csrf attacks +class (Hashable a, Eq a, Typeable a) => SafeAction a where + runSafeAction :: a -> SpockAction conn sess st () + +data PackedSafeAction + = forall a. (SafeAction a) => PackedSafeAction { unpackSafeAction :: a } + +instance Hashable PackedSafeAction where + hashWithSalt i (PackedSafeAction a) = hashWithSalt i a + +instance Eq PackedSafeAction where + (PackedSafeAction a) == (PackedSafeAction b) = + cast a == Just b + +data SafeActionStore + = SafeActionStore + { sas_forward :: HM.HashMap SafeActionHash PackedSafeAction + , sas_reverse :: HM.HashMap PackedSafeAction SafeActionHash + } + +type SafeActionHash = T.Text + newtype WebStateM conn sess st a = WebStateM { runWebStateM :: ReaderT (WebState conn sess st) (ResourceT IO) a } deriving (Monad, Functor, Applicative, MonadIO, MonadReader (WebState conn sess st)) @@ -92,6 +117,7 @@ { sess_id :: SessionId , sess_validUntil :: UTCTime , sess_data :: a + , sess_safeActions :: SafeActionStore } type UserSessions a = TVar (HM.HashMap SessionId (Session a)) @@ -101,4 +127,6 @@ , sm_writeSession :: (SpockError e, MonadIO m) => a -> ActionT e m () , sm_modifySession :: (SpockError e, MonadIO m) => (a -> a) -> ActionT e m () , sm_middleware :: Middleware + , sm_addSafeAction :: (SpockError e, MonadIO m) => PackedSafeAction -> ActionT e m SafeActionHash + , sm_lookupSafeAction :: (SpockError e, MonadIO m) => SafeActionHash -> ActionT e m (Maybe PackedSafeAction) }