diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright JustusAdam (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of JustusAdam nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/resources/devel.cfg b/resources/devel.cfg new file mode 100644 --- /dev/null +++ b/resources/devel.cfg @@ -0,0 +1,13 @@ +# All values are optional + +# interval for session clearing worker (in minutes) +# 60 * 24 / 2 +worker-delay = 720 + +# Duration of a session (in minutes) +# 60 * 24 +session-duration = 1440 + +cookie-name = "sess" + +token-length = 20 diff --git a/snaplet-scoped-session.cabal b/snaplet-scoped-session.cabal new file mode 100644 --- /dev/null +++ b/snaplet-scoped-session.cabal @@ -0,0 +1,42 @@ +name: snaplet-scoped-session +version: 0.1.0.0 +synopsis: Initial project template from stack +description: Please see README.md +homepage: https://github.com/JustusAdam/snaplet-scoped-session#readme +license: BSD3 +license-file: LICENSE +author: JustusAdam +maintainer: dev@justus.science +copyright: Copyright: (c) 2016 Justus Adam +category: Development +build-type: Simple +extra-source-files: resources/devel.cfg +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Snap.Snaplet.Session.Scoped + , Snap.Snaplet.Session.Scoped.InMemory + build-depends: base >= 4.7 && < 5 + , snap + , classy-prelude + , data-default + , lens + , mtl + , async + , time + , unordered-containers + , configurator + default-language: Haskell2010 + ghc-options: -Wall + default-extensions: NoImplicitPrelude + , OverloadedStrings + , MultiParamTypeClasses + , GADTs + , TypeFamilies + , TupleSections + + +source-repository head + type: git + location: https://github.com/JustusAdam/snaplet-scoped-session diff --git a/src/Snap/Snaplet/Session/Scoped.hs b/src/Snap/Snaplet/Session/Scoped.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Session/Scoped.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Snap.Snaplet.Session.Scoped + ( HasManager, TheManager, toManager, Manages + , Manager, managerGetSession, managerSetSession, managerModifySession, managerCommit, managerLoad + , AccessSession, LocalSession, accessSession, AccessSessionLens, mkAccessSessionLens + , CanAccessSubsession + , initSessionSnaplet + , getSession, setSession, modifySession, loadSession, commitSession + ) where + + +import ClassyPrelude +import Control.Lens +import Snap + + +-- | An abstract type for a session manager +-- +-- Managers are responsible for storing the session state across requests and +-- optionally persistent +-- +-- It should be noted that although an implementation for 'managerCommit' and +-- 'managerLoad' is not required it is useful for efficiancy reasons. +-- +-- The state of the manager is mutable within one request but reset for new requests. +-- Therefore managers whould use mutable or persistent data structures like 'IORef' internally. +class Manager manager where + type Manages manager + managerGetSession :: Handler v manager (Manages manager) + managerGetSession = managerModifySession id + managerSetSession :: Manages manager -> Handler v manager () + managerSetSession = managerModifySession . const >=> const (return ()) + managerCommit :: Handler v manager () + managerCommit = return () + managerLoad :: Handler v manager () + managerLoad = return () + + managerModifySession :: (Manages manager -> Manages manager) -> Handler v manager (Manages manager) + managerModifySession f = managerGetSession >>= \sess -> managerSetSession (f sess) >> return sess + + {-# MINIMAL managerGetSession, managerSetSession | managerModifySession #-} + + +-- | Class providing access to a Snaplet managing session state +class Manager (TheManager a) => HasManager a where + type TheManager a + toManager :: SnapletLens (Snaplet a) (TheManager a) + + +type CanAccessSubsession a b = (HasManager a, AccessSession (Manages (TheManager a)) b) + + +-- | Type magic +type AccessSessionLens t a b = t -> Lens' a b + + +-- | You should use this function to create a 'AccessSessionLens'. It ignores +-- the 't' argument. The 't' ergument is only used to line up types. +mkAccessSessionLens :: Lens' a b -> AccessSessionLens t a b +mkAccessSessionLens = const + + +-- | A reference to a LocalSession session state from the GlobalSession session state +-- You have to implement this class for your subsnaplet to get access to a part of the GlobalSession session state. +class AccessSession base t where + type LocalSession t + accessSession :: AccessSessionLens t base (LocalSession t) + + +-- | Initialize a session managing Snaplet from a manager. For an example manager see +-- 'Snap.Snaplet.Session.Scoped.InMemory' +initSessionSnaplet :: Manager a => a -> SnapletInit b a +initSessionSnaplet man = makeSnaplet "session-manager" "manages typed sessions" Nothing $ return man + + +getFullSession :: forall s v. HasManager s => Handler s v (Manages (TheManager s)) +getFullSession = withTop' (toManager :: SnapletLens (Snaplet s) (TheManager s)) managerGetSession + + +-- | Tells the session state manager to load the session. +-- Users should not have to call this function +loadSession :: forall s v. HasManager s => Handler s v () +loadSession = withTop' (toManager :: SnapletLens (Snaplet s) (TheManager s)) managerLoad + + +-- | Tells the session manager to persist any changes. +-- Should be called at the end of a request cycle. +commitSession :: forall s v. HasManager s => Handler s v () +commitSession = withTop' (toManager :: SnapletLens (Snaplet s) (TheManager s)) managerCommit + + +-- | Obtain the LocalSession session for the current snaplet. +getSession :: forall s t. (HasManager s, AccessSession (Manages (TheManager s)) t) => Handler s t (LocalSession t) +getSession = do + fs <- getFullSession + return $ fs^.accessSession (error "Do not evaluate!" :: t) + + +modifyFullSession :: forall s v. HasManager s => (Manages (TheManager s) -> Manages (TheManager s)) -> Handler s v (Manages (TheManager s)) +modifyFullSession f = withTop' (toManager :: SnapletLens (Snaplet s) (TheManager s)) $ managerModifySession f + + +-- | Set the LocalSession part of the session state to a new value +setSession :: forall s t. (HasManager s, AccessSession (Manages (TheManager s)) t) => LocalSession t -> Handler s t () +setSession inner = void $ modifyFullSession (accessSession (error "Do not evaluate!" :: t) .~ inner) + + +-- | Modify the LocalSession session state with a function, returns the altered LocalSession state +-- +-- @ +-- setSession v = modifySession (const v) +-- getSession = modifySession id +-- @ +modifySession :: forall s t. (HasManager s, AccessSession (Manages (TheManager s)) t) => (LocalSession t -> LocalSession t) -> Handler s t (Manages (TheManager s)) +modifySession f = modifyFullSession (accessSession (error "Do not evaluate!" :: t) %~ f) diff --git a/src/Snap/Snaplet/Session/Scoped/InMemory.hs b/src/Snap/Snaplet/Session/Scoped/InMemory.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/Session/Scoped/InMemory.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +module Snap.Snaplet.Session.Scoped.InMemory + ( initMemoryManager, initMemoryManager', MemoryManager + ) where + + +import ClassyPrelude +import Control.Concurrent.Async +import Control.Concurrent.MVar as MVar +import Control.Lens +import Control.Monad.State.Class +import qualified Data.Configurator as C +import Data.Default +import qualified Data.HashMap.Strict as HashMap +import Data.IORef as IORef +import Data.Time.Clock +import Snap +import Snap.Snaplet.Session.Common +import Snap.Snaplet.Session.Scoped hiding (loadSession) + + +data SessionState a + = NotLoaded + | Loaded ByteString a + | Changed Bool Bool ByteString a + + +-- | A Manager for your session using a cookie + token on the client +-- and storing the session data serverside in memory +data MemoryManager a = MkMemoryManager + { _globalState :: MVar (HashMap ByteString (UTCTime, a)) + , _currentSession :: SessionState a + , _initialSession :: a + , _rng :: RNG + , _janitorWorker :: IORef (Async ()) + } + + +runJanitor :: MVar (HashMap ByteString (UTCTime, a)) -> Int -> IO () +runJanitor ref delay = forever $ do + threadDelay $ 60000000 * delay + t <- getCurrentTime + MVar.modifyMVar_ ref $ return . HashMap.filter ((< t) . fst) + + +-- | Convenience function for creating managers for values with defined defaults +initMemoryManager :: (Default a, MonadIO (m v b), MonadSnaplet m) => m v b (MemoryManager a) +initMemoryManager = initMemoryManager' def + + +-- | Uses this function to create a new 'MemoryManager' in your snaplet initializer +initMemoryManager' :: (MonadIO (m v b), MonadSnaplet m) + => a -- ^ initial state value for a new session + -> m v b (MemoryManager a) +initMemoryManager' initial = do + ref <- liftIO $ MVar.newMVar mempty + gen <- liftIO mkRNG + conf <- getSnapletUserConfig + delay <- liftIO $ fromMaybe (60*12) <$> C.lookup conf "worker-delay" + janitor <- liftIO $ async $ runJanitor ref delay + janRef <- liftIO $ IORef.newIORef janitor + return $ MkMemoryManager ref NotLoaded initial gen janRef + + +makeLenses ''MemoryManager + + +loadSession :: Handler b (MemoryManager a) (ByteString, a) +loadSession = do + man <- get + + case man^.currentSession of + Loaded token data_ -> return (token, data_) + Changed _ _ token data_ -> return (token, data_) + NotLoaded -> do + conf <- getSnapletUserConfig + cookieName <- liftIO $ fromMaybe "sess" <$> C.lookup conf "cookie-name" + cookie <- getCookie cookieName + pl <- liftIO $ MVar.readMVar ref + maybe + genNew + (\Cookie{ cookieValue = oldCookie } -> do + logError $ "Cookie is " ++ oldCookie + maybe + genNew + (\(_, oldVal) -> do + currentSession .= Loaded oldCookie oldVal + return (oldCookie, oldVal)) + $ pl^?ix oldCookie) + cookie + where + ref = man^.globalState + mkNewToken len = do + newToken <- randomToken len (man^.rng) + pl <- MVar.readMVar ref + if newToken `member` pl + then mkNewToken len + else return newToken + genNew = do + conf <- getSnapletUserConfig + len <- liftIO $ fromMaybe 20 <$> C.lookup conf "token-length" + newCookie <- liftIO $ mkNewToken len + currentSession .= Changed True True newCookie (man^.initialSession) + return (newCookie, man^.initialSession) + + +getSessionDuration :: Handler v b NominalDiffTime +getSessionDuration = do + conf <- getSnapletUserConfig + liftIO $ fromInteger . (*60) . fromMaybe (60*24) <$> C.lookup conf "session-duration" + + +newExpirationDate :: Handler v b UTCTime +newExpirationDate = addUTCTime <$> getSessionDuration <*> liftIO getCurrentTime + + +instance Manager (MemoryManager a) where + type Manages (MemoryManager a) = a + + managerLoad = void loadSession + managerGetSession = snd <$> loadSession + + managerModifySession f = do + (token, data_) <- loadSession + let changed = f data_ + man <- get + let tokenHasChanged = case man^.currentSession of + Changed True _ _ _ -> True + _ -> False + currentSession .= Changed tokenHasChanged True token changed + return changed + + managerCommit = do + man <- get + case man^.currentSession of + Changed tokenChanged _ token data_ -> do + when tokenChanged $ do + conf <- getSnapletUserConfig + cookieName <- liftIO $ fromMaybe "sess" <$> C.lookup conf "cookie-name" + modifyResponse (addResponseCookie $ Cookie cookieName token Nothing Nothing (Just "/") False False) + d <- newExpirationDate + liftIO $ MVar.modifyMVar_ (man^.globalState) $ return . (at token .~ Just (d, data_)) + currentSession .= NotLoaded + NotLoaded -> return () + Loaded token _ -> do + d <- newExpirationDate + liftIO $ MVar.modifyMVar_ (man^.globalState) $ return . (ix token . _1 .~ d)