Fix session memory store

Author: paluh

src/WebRow/HTTP.purs

@@ -5,7 +5,7 @@ module WebRow.HTTP
   , module Response
   ) where
 
-import WebRow.HTTP.Cookies (Cookies, CookieStore, RequestCookies, ResponseCookies) as Cookies
+import WebRow.HTTP.Cookies (Cookies, CookieStore(..), RequestCookies, ResponseCookies) as Cookies
 import WebRow.HTTP.Response.Except (badGateway, badRequest, badRequest', badRequest'', forbidden, HTTPExcept, HTTPException(..), internalServerError, methodNotAllowed, methodNotAllowed', notFound, notImplemented, redirect, serviceUnavailable, unauthorized) as Response.Except
 import WebRow.HTTP.Request (Request, headers, method, body, fullPath) as Request
 import WebRow.HTTP.Response (HTTPResponse(..), setHeader, SetHeader) as Response

src/WebRow/HTTP/Cookies.purs

@@ -9,6 +9,7 @@ module WebRow.HTTP.Cookies
   , lookupJson
   , lookupJson'
   , run
+  , runOnStore
   , set
   , setJson
   ) where
@@ -26,7 +27,7 @@ import Type.Prelude (SProxy(..))
 import Type.Row (type (+))
 import WebRow.Contrib.Data.JSDate (epoch)
 import WebRow.Crypto (Crypto, secret)
-import WebRow.HTTP.Cookies.CookieStore (CookieStore) as Exports
+import WebRow.HTTP.Cookies.CookieStore (CookieStore(..)) as Exports
 import WebRow.HTTP.Cookies.CookieStore (CookieStore, cookieStore, toSetCookieHeaders)
 import WebRow.HTTP.Cookies.CookieStore (lookup, lookup', lookupJson, lookupJson', set, setJson) as CookieStore
 import WebRow.HTTP.Cookies.Types (Attributes, Name, SetValue, Value, Values, attributes)

src/WebRow/KeyValueStore/InMemory.purs

@@ -1,6 +1,7 @@
 module WebRow.KeyValueStore.InMemory where
 
 import Prelude
+
 import Data.Map (Map)
 import Data.Map (delete, insert, lookup) as Map
 import Effect (Effect)
@@ -24,7 +25,9 @@ forRef ref =
 
     delete k = (void $ Ref.modify (Map.delete k) ref) *> pure true
 
-    get k = Ref.read ref >>= (Map.lookup k >>> pure)
+    get k = do
+      m ← Ref.read ref
+      pure $ Map.lookup k m
 
     put k v = do
       void $ Ref.modify (Map.insert k v) ref

src/WebRow/Session.purs

@@ -1,19 +1,18 @@
 module WebRow.Session where
 
 import Prelude
+
 import Data.Argonaut (Json)
 import Data.Either (hush)
-import Data.Lazy (Lazy, defer)
 import Data.Lazy (force) as Lazy
 import Data.Map (Map)
 import Data.Maybe (fromMaybe)
 import Data.Validation.Semigroup (toEither)
 import Effect (Effect)
 import Effect.Ref (Ref)
-import Effect.Ref (new, read, write) as Ref
 import HTTPure (empty) as Headers
 import Polyform.Validator.Dual.Pure (Dual, runSerializer, runValidator) as Pure
-import Run (FProxy, Run, SProxy(..), liftEffect)
+import Run (FProxy, Run, SProxy(..))
 import Run (interpret, lift, liftEffect, on, send) as Run
 import Type.Row (type (+))
 import WebRow.Contrib.Run (EffRow)
@@ -23,7 +22,7 @@ import WebRow.HTTP.Cookies (defaultAttributes, delete, lookup, lookupJson, set,
 import WebRow.KeyValueStore.Types (Key)
 import WebRow.Session.SessionStore (SessionStore)
 import WebRow.Session.SessionStore (hoist) as SessionStore
-import WebRow.Session.SessionStore.InMemory (lazy) as SessionStore.InMemory
+import WebRow.Session.SessionStore.InMemory (new) as SessionStore.InMemory
 
 data SessionF session a
   = DeleteF (Boolean → a)
@@ -71,31 +70,39 @@ cookieName = "session"
 
 runInStore ∷
   ∀ eff session.
-  Lazy (Effect (SessionStore (Run (Cookies + EffRow + eff)) session)) →
+  Effect (SessionStore (Run (Cookies + EffRow + eff)) session) →
   Run (Cookies + EffRow + Session session + eff)
     ~> Run (Cookies + EffRow + eff)
-runInStore store action = Run.interpret (Run.on _session (handleSession store) Run.send) action
-  where
-  handleSession ∷
-    Lazy (Effect (SessionStore (Run (Cookies + EffRow + eff)) session)) →
-    SessionF session ~> Run (Cookies + EffRow + eff)
-  handleSession ss (DeleteF next) = do
-    void $ Cookies.delete cookieName
-    Run.liftEffect (Lazy.force ss) >>= _.delete >>= next >>> pure
-
-  handleSession ss (FetchF next) = do
-    ss' ← Run.liftEffect $ Lazy.force ss
-    -- | TODO:
-    -- | * Handle custom cookie attributes (expiration etc.).
-    -- | * Should we raise here internalServerError when `set` returns `false`?
-    -- | * Should we run testing cycle of test cookie setup?
-    void $ Cookies.set cookieName { value: ss'.key, attributes: Cookies.defaultAttributes }
-    ss'.fetch >>= next >>> pure
-
-  handleSession ss (SaveF v next) = do
-    ss' ← Run.liftEffect $ Lazy.force ss
-    void $ Cookies.set cookieName { value: ss'.key, attributes: Cookies.defaultAttributes }
-    ss'.save v >>= next >>> pure
+runInStore store = runInRunStore (Run.liftEffect store)
+
+runInRunStore ∷
+  ∀ eff session.
+  Run (Cookies + EffRow + eff) (SessionStore (Run (Cookies + EffRow + eff)) session) →
+  Run (Cookies + EffRow + Session session + eff)
+    ~> Run (Cookies + EffRow + eff)
+runInRunStore store action = do
+  s ← store
+  let
+    handleSession ∷
+      SessionF session ~> Run (Cookies + EffRow + eff)
+    handleSession (DeleteF next) = do
+      void $ Cookies.delete cookieName
+      s.delete >>= next >>> pure
+
+    handleSession (FetchF next) = do
+      -- | TODO:
+      -- | * Handle custom cookie attributes (expiration etc.).
+      -- | * Should we raise here internalServerError when `set` returns `false`?
+      -- | * Should we run testing cycle of test cookie setup?
+      void $ Cookies.set cookieName { value: s.key, attributes: Cookies.defaultAttributes }
+      s.fetch >>= next >>> pure
+
+    handleSession (SaveF v next) = do
+      void $ Cookies.set cookieName { value: s.key, attributes: Cookies.defaultAttributes }
+      a ← s.save v
+      pure (next a)
+
+  Run.interpret (Run.on _session handleSession Run.send) action
 
 runInMemoryStore ∷
   ∀ a eff session.
@@ -104,10 +111,11 @@ runInMemoryStore ∷
   Run (Cookies + EffRow + Session session + eff) a →
   Run (Cookies + EffRow + eff) a
 runInMemoryStore ref defaultSession action = do
+  -- | This laziness is a myth let's drop this all together
   lazySessionKey ← Cookies.lookup cookieName
   let
-    effSessionStore = SessionStore.InMemory.lazy ref defaultSession lazySessionKey
-  runInStore (map (SessionStore.hoist Run.liftEffect) <$> effSessionStore) action
+    effSessionStore = SessionStore.InMemory.new ref defaultSession (Lazy.force lazySessionKey)
+  runInStore (SessionStore.hoist Run.liftEffect <$> effSessionStore) action
 
 -- | The whole session is stored in a cookie value so visible in the browser.
 -- | We don't need any key-value session store.
@@ -117,41 +125,38 @@ runInCookieValue ∷
   Run (Cookies + EffRow + eff) session →
   Run (Cookies + EffRow + Session session + eff) a →
   Run (Cookies + EffRow + eff) a
-runInCookieValue dual defaultSession action = do
-  default ← defaultSession
+runInCookieValue dual defaultSession =
   let
-    decode maybeRepr =
-      fromMaybe default
-        $ (maybeRepr >>= Pure.runValidator dual >>> toEither >>> hush)
-  lazySession ← map decode <$> Cookies.lookupJson cookieName
-  ref ← liftEffect $ Ref.new lazySession
-  Run.interpret (Run.on _session (handleSession ref) Run.send) action
-  where
-  handleSession ∷
-    Ref (Lazy session) →
-    SessionF session ~> Run (Cookies + EffRow + eff)
-  handleSession ref (DeleteF next) = do
-    void $ Cookies.delete cookieName
-    default ← defaultSession
-    liftEffect $ Ref.write (defer \_ → default) ref
-    pure (next true)
-
-  handleSession ref (FetchF next) = do
-    lazySession ← liftEffect $ Ref.read ref
-    let
-      session = Lazy.force lazySession
-
-      json = Pure.runSerializer dual session
-    -- | TODO:
-    -- | * Handle custom cookie attributes (expiration etc.).
-    -- | * Should we raise here internalServerError when `set` returns `false`?
-    -- | * Should we run testing cycle of test cookie setup?
-    void $ Cookies.setJson cookieName { json, attributes: Cookies.defaultAttributes }
-    pure $ next session
-
-  handleSession ref (SaveF v next) = do
-    lazySession ← liftEffect $ Ref.read ref
-    let
-      json = Pure.runSerializer dual v
-    void $ Cookies.setJson cookieName { json, attributes: Cookies.defaultAttributes }
-    pure (next true)
+    fetchFromCookie = do
+      default ← defaultSession
+      map (decode default) <$> Cookies.lookupJson cookieName
+      where
+        decode default maybeRepr =
+          fromMaybe default
+            $ (maybeRepr >>= Pure.runValidator dual >>> toEither >>> hush)
+
+    handleSession ∷ SessionF session ~> Run (Cookies + EffRow + eff)
+    handleSession (DeleteF next) = do
+      void $ Cookies.delete cookieName
+      pure (next true)
+
+    handleSession (FetchF next) = do
+      session ← Lazy.force <$> fetchFromCookie
+      let
+        json = Pure.runSerializer dual session
+      -- | TODO:
+      -- | * Handle custom cookie attributes (expiration etc.).
+      -- | * Should we raise here internalServerError when `set` returns `false`?
+      -- | * Should we run testing cycle of test cookie setup?
+      void $ Cookies.setJson cookieName { json, attributes: Cookies.defaultAttributes }
+      pure $ next session
+
+    handleSession (SaveF v next) = do
+      lazySession ← fetchFromCookie
+      let
+        json = Pure.runSerializer dual v
+      void $ Cookies.setJson cookieName { json, attributes: Cookies.defaultAttributes }
+      pure (next true)
+  in
+    Run.interpret (Run.on _session handleSession Run.send)
+

src/WebRow/Session/SessionStore/InMemory.purs

@@ -1,11 +1,8 @@
 module WebRow.Session.SessionStore.InMemory where
 
 import Prelude
-import Data.Lazy (Lazy)
-import Data.Lazy (defer, force) as Lazy
 import Data.Map (Map)
 import Data.Maybe (Maybe(..))
-import Debug.Trace (traceM)
 import Effect (Effect)
 import Effect.Ref (Ref)
 import WebRow.KeyValueStore (Key)
@@ -22,13 +19,3 @@ new ref defaultSession =
       Just key → pure $ SessionStore.forKey defaultSession key kv
       Nothing → SessionStore.new defaultSession kv
 
--- | We can't be sure if Effect thunk is not run sequentially.
--- | Because it seems that this is the case.
-lazy ∷ ∀ session. Ref (Map String session) → session → Lazy (Maybe Key) → Lazy (Effect (SessionStore Effect session))
-lazy ref defaultSession mk =
-  Lazy.defer \_ → do
-    let
-      kv = KeyValueStore.InMemory.forRef ref
-    case Lazy.force mk of
-      Just key → pure $ SessionStore.forKey defaultSession key kv
-      Nothing → SessionStore.new defaultSession kv

src/WebRow/Testing/HTTP.purs

@@ -1,7 +1,9 @@
 module WebRow.Testing.HTTP where
 
 import Prelude
+
 import Data.Array (singleton) as Array
+import Data.Either (Either(..))
 import Data.Lazy (defer) as Lazy
 import Data.List (List(..), reverse) as List
 import Data.List (List)
@@ -40,12 +42,13 @@ import WebRow.HTTP.Cookies.Types (RequestCookies)
 import WebRow.HTTP.Request (Request)
 import WebRow.Routing (Routing, runRouting)
 import WebRow.Session (Session)
+import WebRow.Session (runInCookieValue) as Session
 import WebRow.Testing.HTTP.Cookies (toRequestCookies)
 import WebRow.Testing.HTTP.Response (Render) as Response
 import WebRow.Testing.HTTP.Response (Response) as Testing.HTTP
 import WebRow.Testing.HTTP.Response (runHTTPExcept, runRender, runSetHeader) as Testing.Response
 import WebRow.Testing.HTTP.Types (ClientCookies)
-import WebRow.Testing.Session (SessionStoreConfig)
+import WebRow.Testing.Session (SessionStoreConfig, SessionCookieConfig)
 import WebRow.Testing.Session (runInMemory) as Testing.Session
 
 -- | TODO: Upgrdae to polymorphic `body` type here when
@@ -179,25 +182,29 @@ run ∷
     eff
     eff_
     (S.Producer (Exchange res) + eff) ⇒
-  SessionStoreConfig session →
+  -- (Either (SessionStoreConfig session) (SessionCookieConfig session)) →
+  (SessionStoreConfig session) →
   RouteDuplex' routes →
   Response.Render (Server session routes res + eff) String res →
   Run (Server session routes res + eff) res →
   Run (AffRow + Client session res + EffRow + eff) Unit →
   Run (AffRow + EffRow + eff) (History res)
 run sessionStoreConfig routeDuplex render server client = do
-  Testing.Session.runInMemory sessionStoreConfig
+  let
+    runSession = Testing.Session.runInMemory sessionStoreConfig
+
+  runSession
     $ evalStateAt _httpSession (mempty ∷ ClientCookies)
-    $ httpSession
+    $ httpExchange
   where
   -- | This can be a bit unintuitive but we have to expand
   -- | row with another yield so the consumer `take' 100`
   -- | can swallow it.
-  -- go' = Run.expand go
-  httpSession = go # Pull.feed (S.P.take 100) # S.P.fold (flip List.Cons) List.Nil List.reverse
+  httpExchange ∷ Run (AffRow + EffRow + HTTPSession + Session session + eff) (List (Exchange res))
+  httpExchange = go # Pull.feed (S.P.take 100) # S.P.fold (flip List.Cons) List.Nil List.reverse
 
   -- | I don't really need this signature here but
-  -- | maybe it can be a small hint what is going on here.
+  -- | maybe it can be a small hint what is going on.
   go ∷
     Run
       ( AffRow

src/WebRow/Testing/HTTP/Response.purs

@@ -1,10 +1,12 @@
 module WebRow.Testing.HTTP.Response where
 
 import Prelude
+
+import Data.Maybe (Maybe(..))
 import HTTPure (Headers, header) as HTTPure
+import HTTPure (Status)
 import HTTPure.Body (class Body) as HTTPure
 import HTTPure.Headers (empty) as HTTPure.Headers
-import Prim.Row (class Union) as Row
 import Run (Run)
 import Run (on, run, send) as Run
 import Run.Except (catchAt)
@@ -21,6 +23,14 @@ data Response body res
 
 derive instance functorResponse ∷ Functor (Response body)
 
+status ∷ ∀ body res. Response body res → Maybe Status
+status (HTTPResponse { parts: { status: s }}) = Just s
+status _ = Nothing
+
+body ∷ ∀ body res. Response body res → Maybe body
+body (HTTPResponse { parts: { body: b }}) = Just b
+body _ = Nothing
+
 -- type Response' body res = Response body (Variant res)
 type Render eff body res
   = res → Run eff (HTTPResponse body)

src/WebRow/Testing/Session.purs

@@ -1,12 +1,13 @@
 module WebRow.Testing.Session where
 
 import Prelude
-import Data.Lazy (defer)
-import Data.Lazy (force) as Lazy
+
+import Data.Argonaut (Json)
 import Data.Map (Map)
 import Data.Maybe (Maybe)
 import Effect (Effect)
 import Effect.Ref (Ref)
+import Polyform.Validator.Dual.Pure (Dual) as Pure
 import Run (Run)
 import Run (interpret, liftEffect, on, send) as Run
 import Type.Row (type (+))
@@ -15,7 +16,7 @@ import WebRow.Forms.Payload (Key)
 import WebRow.Session (Session, SessionF(..), _session)
 import WebRow.Session.SessionStore (SessionStore)
 import WebRow.Session.SessionStore (hoist) as SessionStore
-import WebRow.Session.SessionStore.InMemory (lazy) as SessionStore.InMemory
+import WebRow.Session.SessionStore.InMemory (new) as SessionStore.InMemory
 
 type SessionStoreConfig session
   = { default ∷ session
@@ -48,7 +49,12 @@ runInMemory ∷
   Run (EffRow + eff) a
 runInMemory { default, key, ref } action = do
   let
-    ss = SessionStore.InMemory.lazy ref default (defer \_ → key)
+    ss = SessionStore.InMemory.new ref default key
 
-    ss' = map (SessionStore.hoist Run.liftEffect) $ Lazy.force ss
+    ss' = map (SessionStore.hoist Run.liftEffect) $ ss
   run ss' action
+
+type SessionCookieConfig session
+  = { default ∷ session
+    , dual ∷ ∀ err. Pure.Dual err Json session
+    }

test/Main.purs

@@ -9,9 +9,11 @@ import Test.Spec.Runner (runSpec)
 import Test.WebRow.Applets (spec) as Applets
 import Test.WebRow.HTTP (spec) as HTTP
 import Test.WebRow.I18N (spec) as I18N
+import Test.WebRow.Session (spec) as Session
 
 main :: Effect Unit
 main = launchAff_ $ runSpec [consoleReporter] do
   I18N.spec
   Applets.spec
   HTTP.spec
+  Session.spec