packages feed

snaplet-scoped-session (empty) → 0.1.0.0

raw patch · 6 files changed

+356/−0 lines, 6 filesdep +asyncdep +basedep +classy-preludesetup-changed

Dependencies added: async, base, classy-prelude, configurator, data-default, lens, mtl, snap, time, unordered-containers

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import           Distribution.Simple+main = defaultMain
+ resources/devel.cfg view
@@ -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
+ snaplet-scoped-session.cabal view
@@ -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
+ src/Snap/Snaplet/Session/Scoped.hs view
@@ -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)
+ src/Snap/Snaplet/Session/Scoped/InMemory.hs view
@@ -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)