Spock 0.4.3.1 → 0.4.3.2
raw patch · 5 files changed
+165/−29 lines, 5 filesdep +hashable
Dependencies added: hashable
Files
- Spock.cabal +6/−4
- Web/Spock.hs +5/−0
- Web/Spock/SafeActions.hs +49/−0
- Web/Spock/SessionManager.hs +73/−21
- Web/Spock/Types.hs +32/−4
Spock.cabal view
@@ -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
Web/Spock.hs view
@@ -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.
+ Web/Spock/SafeActions.hs view
@@ -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 <a href='", TL.fromStrict deleteUrl, "'>here</a> 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
Web/Spock/SessionManager.hs view
@@ -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
Web/Spock/Types.hs view
@@ -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) }