Get furnace to load again

extra/furnace/furnace.factor

@@ -57,17 +57,9 @@ SYMBOL: validation-errors
         ] if*
     ] with map ;
 
-: expire-sessions ( -- )
-    sessions get-global
-    [ nip session-last-seen 20 minutes ago <=> 0 > ]
-    [ 2drop ] heap-pop-while ;
-
 : lookup-session ( hash -- session )
-    "furnace-session-id" over at sessions get-global at [
+    "furnace-session-id" over at get-session
-        nip
+    [ ] [ new-session "furnace-session-id" roll set-at ] ?if ;
-    ] [
-        new-session rot "furnace-session-id" swap set-at
-    ] if* ;
 
 : quot>query ( seq action -- hash )
     >r >array r> "action-params" word-prop

extra/furnace/sessions/sessions.factor

@@ -1,37 +1,48 @@
-USING: assoc-heaps assocs calendar crypto.sha2 heaps
+USING: assocs calendar init kernel math.parser
-init kernel math.parser namespaces random ;
+namespaces random boxes alarms ;
 IN: furnace.sessions
 
 SYMBOL: sessions
 
+: timeout ( -- dt ) 20 minutes ;
+
 [
-    H{ } clone <min-heap> <assoc-heap>
+    H{ } clone sessions set-global
-    sessions set-global
 ] "furnace.sessions" add-init-hook
 
 : new-session-id ( -- str )
-    4 big-random number>string string>sha-256-string
+    4 big-random >hex
-    dup sessions get-global at [ drop new-session-id ] when ;
+    dup sessions get-global key?
+    [ drop new-session-id ] when ;
 
-TUPLE: session created last-seen user-agent namespace ;
+TUPLE: session id namespace alarm user-agent ;
 
-M: session <=> ( session1 session2 -- n )
+: cancel-timeout ( session -- )
-    [ session-last-seen ] 2apply <=> ;
+    session-alarm ?box [ cancel-alarm ] [ drop ] if ;
 
-: <session> ( -- obj )
+: delete-session ( session -- )
-    now dup H{ } clone
+    sessions get-global delete-at*
-    [ set-session-created set-session-last-seen set-session-namespace ]
+    [ cancel-timeout ] [ drop ] if ;
-    \ session construct ;
 
-: new-session ( -- obj id )
+: touch-session ( session -- )
-    <session> new-session-id [ sessions get-global set-at ] 2keep ;
+    dup cancel-timeout
+    dup [ session-id delete-session ] curry timeout later
+    swap session-alarm >box ;
 
-: get-session ( id -- obj/f )
+: <session> ( id -- session )
-    sessions get-global at* [ "no session found 1" throw ] unless ;
+    H{ } clone <box> f session construct-boa ;
 
-! Delete from the assoc only, the heap will timeout
+: new-session ( -- session id )
-: destroy-session ( id -- )
+    new-session-id [
-    sessions get-global assoc-heap-assoc delete-at ;
+        dup <session> [
+            [ sessions get-global set-at ] keep
+            touch-session
+        ] keep
+    ] keep ;
+
+: get-session ( id -- session/f )
+    sessions get-global at*
+    [ dup touch-session ] when ;
 
 : session> ( str -- obj )
     session get session-namespace at ;