Templating now runs in quiet mode

session ids are now  4 bignum number>string string>sha-256-string
add assoc-heaps
sessions are stored in an assoc-heap

core/heaps/heaps-tests.factor

@@ -1,7 +1,8 @@
 ! Copyright 2007 Ryan Murphy
 ! See http://factorcode.org/license.txt for BSD license.
 
-USING: kernel math tools.test heaps heaps.private ;
+USING: arrays kernel math namespaces tools.test
+heaps heaps.private ;
 IN: temporary
 
 [ <min-heap> heap-pop ] unit-test-fails
@@ -33,3 +34,16 @@ IN: temporary
 
 [ 0 ] [ <max-heap> heap-length ] unit-test
 [ 1 ] [ <max-heap> t 1 pick heap-push heap-length ] unit-test
+
+[ { { 1 2 } { 3 4 } { 5 6 } } ] [
+    T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
+    [ [ 10 < nip ] [ 2array , ] heap-pop-while ] { } make
+] unit-test
+[ { { 1 2 } } ] [
+    T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
+    [ [ 3 < nip ] [ 2array , ] heap-pop-while ] { } make
+] unit-test
+[ { } ] [
+    T{ min-heap T{ heap f V{ { 2 1 } { 4 3 } { 6 5 } } } }
+    [ [ 1 < nip ] [ 2array , ] heap-pop-while ] { } make
+] unit-test

core/heaps/heaps.factor

@@ -3,6 +3,19 @@
 USING: kernel math sequences arrays assocs ;
 IN: heaps
 
+MIXIN: priority-queue
+
+GENERIC: heap-push ( value key heap -- )
+GENERIC: heap-push-all ( assoc heap -- )
+GENERIC: heap-peek ( heap -- value key )
+GENERIC: heap-pop* ( heap -- )
+GENERIC: heap-pop ( heap -- value key )
+GENERIC: heap-delete ( key heap -- )
+GENERIC: heap-delete* ( key heap -- old ? )
+GENERIC: heap-empty? ( heap -- ? )
+GENERIC: heap-length ( heap -- n )
+GENERIC# heap-pop-while 2 ( heap pred quot -- )
+
 <PRIVATE
 TUPLE: heap data ;
 
@@ -19,6 +32,9 @@ TUPLE: max-heap ;
 
 : <max-heap> ( -- max-heap ) max-heap <heap> ;
 
+INSTANCE: min-heap priority-queue
+INSTANCE: max-heap priority-queue
+
 <PRIVATE
 : left ( n -- m ) 2 * 1+ ; inline
 : right ( n -- m ) 2 * 2 + ; inline
@@ -85,19 +101,19 @@ DEFER: down-heap
 
 PRIVATE>
 
-: heap-push ( value key heap -- )
+M: priority-queue heap-push ( value key heap -- )
     >r swap 2array r>
     [ heap-data push ] keep
     [ heap-data ] keep
     up-heap ;
 
-: heap-push-all ( assoc heap -- )
+M: priority-queue heap-push-all ( assoc heap -- )
     [ swapd heap-push ] curry assoc-each ;
 
-: heap-peek ( heap -- value key )
+M: priority-queue heap-peek ( heap -- value key )
     heap-data first first2 swap ;
 
-: heap-pop* ( heap -- )
+M: priority-queue heap-pop* ( heap -- )
     dup heap-data length 1 > [
         [ heap-data pop ] keep
         [ heap-data set-first ] keep
@@ -106,8 +122,19 @@ PRIVATE>
         heap-data pop*
     ] if ;
 
-: heap-pop ( heap -- value key ) dup heap-peek rot heap-pop* ;
+M: priority-queue heap-pop ( heap -- value key ) dup heap-peek rot heap-pop* ;
 
-: heap-empty? ( heap -- ? ) heap-data empty? ;
+M: priority-queue heap-empty? ( heap -- ? ) heap-data empty? ;
 
-: heap-length ( heap -- n ) heap-data length ;
+M: priority-queue heap-length ( heap -- n ) heap-data length ;
+
+: (heap-pop-while) ( heap pred quot -- )
+    pick heap-empty? [
+        3drop
+    ] [
+        [ >r >r dup heap-peek r> call r> [ drop f ] if ] 3keep
+        roll [ (heap-pop-while) ] [ 3drop ] if
+    ] if ;
+
+M: priority-queue heap-pop-while ( heap pred quot -- )
+    [ heap-pop ] swap [ t ] 3compose (heap-pop-while) ;

extra/assoc-heaps/assoc-heaps-tests.factor

@@ -0,0 +1,46 @@
+USING: assocs assoc-heaps heaps heaps.private kernel tools.test ;
+IN: temporary
+
+[
+T{
+    assoc-heap
+    f
+    H{ { 2 1 } }
+    T{ min-heap T{ heap f V{ { 1 2 } } } }
+}
+] [ H{ } clone <assoc-min-heap> 1 2 pick heap-push ] unit-test
+
+[
+T{
+    assoc-heap
+    f
+    H{ { 1 0 } { 2 1 } }
+    T{ min-heap T{ heap f V{ { 0 1 } { 1 2 } } } }
+}
+] [  H{ } clone <assoc-min-heap> 1 2 pick heap-push 0 1 pick heap-push ] unit-test
+
+[ T{ assoc-heap f H{ } T{ min-heap T{ heap f V{ } } } } ]
+[
+    H{ } clone <assoc-min-heap>
+    1 2 pick heap-push 0 1 pick heap-push
+    dup heap-pop 2drop dup heap-pop 2drop
+] unit-test
+
+
+[ 0 1 ] [
+T{
+    assoc-heap
+    f
+    H{ { 1 0 } { 2 1 } }
+    T{ min-heap T{ heap f V{ { 0 1 } { 1 2 } } } }
+} heap-pop
+] unit-test
+
+[ 1 2 ] [
+T{
+    assoc-heap
+    f
+    H{ { 1 0 } { 2 1 } }
+    T{ max-heap T{ heap f V{ { 1 2 } { 0 1 } } } }
+} heap-pop
+] unit-test

extra/assoc-heaps/assoc-heaps.factor

@@ -0,0 +1,48 @@
+USING: assocs heaps kernel sequences ;
+IN: assoc-heaps
+
+TUPLE: assoc-heap assoc heap ;
+
+INSTANCE: assoc-heap assoc
+INSTANCE: assoc-heap priority-queue
+
+C: <assoc-heap> assoc-heap
+
+: <assoc-min-heap> ( assoc -- obj ) <min-heap> <assoc-heap> ;
+: <assoc-max-heap> ( assoc -- obj ) <max-heap> <assoc-heap> ;
+
+M: assoc-heap at* ( key assoc-heap -- value ? )
+    assoc-heap-assoc at* ;
+
+M: assoc-heap assoc-size ( assoc-heap -- n )
+    assoc-heap-assoc assoc-size ;
+
+TUPLE: assoc-heap-key-exists ;
+
+: check-key-exists ( key assoc-heap -- )
+    assoc-heap-assoc key?
+    [ \ assoc-heap-key-exists construct-empty throw ] when ;
+
+M: assoc-heap set-at ( value key assoc-heap -- )
+    [ check-key-exists ] 2keep
+    [ assoc-heap-assoc set-at ] 3keep
+    assoc-heap-heap swapd heap-push ;
+
+M: assoc-heap heap-empty? ( assoc-heap -- ? )
+    assoc-heap-assoc assoc-empty? ;
+
+M: assoc-heap heap-length ( assoc-heap -- n )
+    assoc-heap-assoc assoc-size ; 
+
+M: assoc-heap heap-peek ( assoc-heap -- value key )
+    assoc-heap-heap heap-peek ;
+
+M: assoc-heap heap-push ( value key assoc-heap -- )
+    set-at ;
+
+M: assoc-heap heap-push-all ( assoc assoc-heap -- )
+    swap [ rot set-at ] curry* each ;
+
+M: assoc-heap heap-pop ( assoc-heap -- value key )
+    dup assoc-heap-heap heap-pop swap
+    rot dupd assoc-heap-assoc delete-at ;

extra/furnace/furnace.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2006 Slava Pestov, Doug Coleman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs debugger furnace.sessions furnace.validator
-hashtables html.elements http http.server.responders
-http.server.templating
-io.files kernel namespaces quotations sequences splitting words
-strings vectors webapps.callback ;
+USING: arrays assocs calendar debugger furnace.sessions furnace.validator
+hashtables heaps html.elements http http.server.responders
+http.server.templating io.files kernel math namespaces
+quotations sequences splitting words strings vectors
+webapps.callback ;
 USING: continuations io prettyprint ;
 IN: furnace
 
@@ -57,13 +57,17 @@ SYMBOL: validation-errors
         ] if*
     ] curry* 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
-        [ nip ] [ "furnace-session-id" over delete-at lookup-session ] if*
+    "furnace-session-id" over at sessions get-global at [
+        nip
     ] [
-        drop new-session rot "furnace-session-id" swap 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,15 +1,23 @@
-USING: assocs calendar init kernel math.parser namespaces random ;
+USING: assoc-heaps assocs calendar crypto.sha2 heaps
+init kernel math.parser namespaces random ;
 IN: furnace.sessions
 
 SYMBOL: sessions
 
-[ H{ } clone sessions set-global ] "furnace.sessions" add-init-hook
+[
+    H{ } clone <min-heap> <assoc-heap>
+    sessions set-global
+] "furnace.sessions" add-init-hook
 
 : new-session-id ( -- str )
-    1 big-random number>string ;
+    4 big-random number>string string>sha-256-string
+    dup sessions get-global at [ drop new-session-id ] when ;
 
 TUPLE: session created last-seen user-agent namespace ;
 
+M: session <=> ( session1 session2 -- n )
+    [ session-last-seen ] 2apply <=> ;
+
 : <session> ( -- obj )
     now dup H{ } clone
     [ set-session-created set-session-last-seen set-session-namespace ]
@@ -21,8 +29,9 @@ TUPLE: session created last-seen user-agent namespace ;
 : get-session ( id -- obj/f )
     sessions get-global at* [ "no session found 1" throw ] unless ;
 
+! Delete from the assoc only, the heap will timeout
 : destroy-session ( id -- )
-    sessions get-global delete-at ;
+    sessions get-global assoc-heap-assoc delete-at ;
 
 : session> ( str -- obj )
     session get session-namespace at ;

extra/http/server/templating/templating.factor

@@ -76,6 +76,7 @@ DEFER: <% delimiter
 : run-template-file ( filename -- )
     [
         [
+            "quiet" on
             file-vocabs
             parser-notes off
             templating-vocab use+

extra/webapps/pastebin/pastebin.factor

@@ -1,6 +1,6 @@
 USING: calendar furnace furnace.validator io.files kernel
 namespaces sequences store http.server.responders html
-math.parser rss xml.writer ;
+math.parser rss xml.writer xmode.code2html ;
 IN: webapps.pastebin
 
 TUPLE: pastebin pastes ;