Merge branch 'master' of git://factorcode.org/git/factor

core/combinators/combinators-docs.factor

@@ -95,7 +95,7 @@ HELP: case
     "If there is no case matching " { $snippet "obj" } ", the default case is taken. If the last element of " { $snippet "cases" } " is a quotation, the quotation is called with " { $snippet "obj" } " on the stack. Otherwise, a " { $link no-cond } " error is rasied."
     $nl
     "The following two phrases are equivalent:"
-    { $code "{ { X [ Y ] } { Y [ T ] } } case" }
+    { $code "{ { X [ Y ] } { Z [ T ] } } case" }
     { $code "dup X = [ drop Y ] [ dup Z = [ drop T ] [ no-case ] if ] if" }
 }
 { $examples

extra/csv/authors.txt

@@ -0,0 +1 @@
+Phil Dawes

extra/csv/csv-docs.factor

@@ -0,0 +1,21 @@
+USING: help.syntax help.markup kernel prettyprint sequences ;
+IN: csv
+
+HELP: csv
+{ $values { "stream" "a stream" }
+          { "rows" "an array of arrays of fields" } } 
+{ $description "parses a csv stream into an array of row arrays"
+} ;
+
+HELP: csv-row
+{ $values { "stream" "a stream" }
+          { "row" "an array of fields" } } 
+{ $description "parses a row from a csv stream"
+} ;
+
+
+HELP: with-delimiter
+{ $values { "char" "field delimiter (e.g. CHAR: \t)" }
+          { "quot" "a quotation" } }
+{ $description "Sets the field delimiter for csv or csv-row words "
+} ;

extra/csv/csv-tests.factor

@@ -0,0 +1,67 @@
+USING: io.streams.string csv tools.test shuffle ;
+IN: csv.tests
+
+! I like to name my unit tests
+: named-unit-test ( name output input -- ) 
+  nipd unit-test ; inline
+
+! tests nicked from the wikipedia csv article
+! http://en.wikipedia.org/wiki/Comma-separated_values
+
+"Fields are separated by commas"
+[ { { "1997" "Ford" "E350" } } ] 
+[ "1997,Ford,E350" <string-reader> csv ] named-unit-test
+
+"ignores whitespace before and after elements. n.b.specifically prohibited by RFC 4180, which states, 'Spaces are considered part of a field and should not be ignored.'"
+[ { { "1997" "Ford" "E350" } } ]
+[ "1997,   Ford   , E350" <string-reader> csv ] named-unit-test
+
+"keeps spaces in quotes"
+[ { { "1997" "Ford" "E350" "Super, luxurious truck" } } ]
+[ "1997,Ford,E350,\"Super, luxurious truck\"" <string-reader> csv ] named-unit-test
+
+"double quotes mean escaped in quotes"
+[ { { "1997" "Ford" "E350" "Super \"luxurious\" truck" } } ]
+[ "1997,Ford,E350,\"Super \"\"luxurious\"\" truck\"" 
+  <string-reader> csv ] named-unit-test
+
+"Fields with embedded line breaks must be delimited by double-quote characters."
+[ { { "1997" "Ford" "E350" "Go get one now\nthey are going fast" } } ]
+[ "1997,Ford,E350,\"Go get one now\nthey are going fast\""
+  <string-reader> csv ] named-unit-test
+
+"Fields with leading or trailing spaces must be delimited by double-quote characters. (See comment about leading and trailing spaces above)"
+[ { { "1997" "Ford" "E350" "  Super luxurious truck    " } } ]
+[ "1997,Ford,E350,\"  Super luxurious truck    \""
+  <string-reader> csv ] named-unit-test
+
+"Fields may always be delimited by double-quote characters, whether necessary or not."
+[ { { "1997" "Ford" "E350" } } ]
+[ "\"1997\",\"Ford\",\"E350\"" <string-reader> csv ] named-unit-test
+
+"The first record in a csv file may contain column names in each of the fields."
+[ { { "Year" "Make" "Model" } 
+    { "1997" "Ford" "E350" }
+    { "2000" "Mercury" "Cougar" } } ]
+[ "Year,Make,Model\n1997,Ford,E350\n2000,Mercury,Cougar" 
+   <string-reader> csv ] named-unit-test
+
+   
+
+   
+! !!!!!!!!  other tests
+   
+[ { { "Phil Dawes" } } ] 
+[ "\"Phil Dawes\"" <string-reader> csv ] unit-test
+
+[ { { "1" "2" "3" } { "4" "5" "6" } } ] 
+[ "1,2,3\n4,5,6\n" <string-reader> csv ] unit-test
+
+"trims leading and trailing whitespace - n.b. this isn't really conformant, but lots of csv seems to assume this"
+[ { { "foo yeah" "bah" "baz" } } ] 
+[ "  foo yeah  , bah ,baz\n" <string-reader> csv ] named-unit-test
+
+
+"allows setting of delimiting character"
+[ { { "foo" "bah" "baz" } } ] 
+[ "foo\tbah\tbaz\n" <string-reader> CHAR: \t [ csv ] with-delimiter ] named-unit-test

extra/csv/csv.factor

@@ -0,0 +1,70 @@
+! Copyright (C) 2007, 2008 Phil Dawes
+! See http://factorcode.org/license.txt for BSD license.
+
+! Simple CSV Parser
+! Phil Dawes phil@phildawes.net
+
+USING: kernel sequences io namespaces combinators unicode.categories vars ;
+IN: csv
+
+DEFER: quoted-field
+
+VAR: delimiter
+
+! trims whitespace from either end of string
+: trim-whitespace ( str -- str )
+  [ blank? ] trim ; inline
+
+: skip-to-field-end ( -- endchar )
+  "\n" delimiter> suffix read-until nip ; inline
+  
+: not-quoted-field ( -- endchar )
+  "\"\n" delimiter> suffix read-until   ! "
+  dup
+  { { CHAR: "     [ drop drop quoted-field ] }  ! " 
+    { delimiter> [ swap trim-whitespace % ] } 
+    { CHAR: \n    [ swap trim-whitespace % ] }    
+    { f           [ swap trim-whitespace % ] }       ! eof
+  } case ;
+  
+: maybe-escaped-quote ( -- endchar )
+  read1 dup 
+  { { CHAR: "    [ , quoted-field ] }  ! " is an escaped quote
+    { delimiter> [ ] }                 ! end of quoted field 
+    [ 2drop skip-to-field-end ]       ! end of quoted field + padding
+  } case ;
+  
+: quoted-field ( -- endchar )
+  "\"" read-until                                 ! "
+  drop % maybe-escaped-quote ;
+
+: field ( -- sep string )
+  [ not-quoted-field ] "" make  ; ! trim-whitespace
+
+: (row) ( -- sep )
+  field , 
+  dup delimiter> = [ drop (row) ] when ;
+
+: row ( -- eof? array[string] )
+  [ (row) ] { } make ;
+
+: append-if-row-not-empty ( row -- )
+  dup { "" } = [ drop ] [ , ] if ;
+
+: (csv) ( -- )
+  row append-if-row-not-empty
+  [ (csv) ] when ;
+
+: init-vars ( -- )
+  delimiter> [ CHAR: , >delimiter ] unless ; inline
+  
+: csv-row ( stream -- row )
+  init-vars
+  [ row nip ] with-stream ;
+
+: csv ( stream -- rows )
+  init-vars
+  [ [ (csv) ] { } make ] with-stream ;
+
+: with-delimiter ( char quot -- )
+  delimiter swap with-variable ; inline

extra/csv/summary.txt

@@ -0,0 +1 @@
+CSV parser

extra/db/queries/queries.factor

@@ -112,7 +112,7 @@ M: string where ( spec obj -- ) object-where ;
         ] interleave drop
     ] if ;
 
-M: db <delete-tuple-statement> ( tuple table -- sql )
+M: db <delete-tuples-statement> ( tuple table -- sql )
     [
         "delete from " 0% 0%
         where-clause

extra/db/tuples/tuples-tests.factor

@@ -68,7 +68,7 @@ SYMBOL: person4
     ] [ T{ person f f f 10 3.14 } select-tuples ] unit-test
 
 
-    [ ] [ person1 get delete-tuple ] unit-test
+    [ ] [ person1 get delete-tuples ] unit-test
     [ f ] [ T{ person f 1 } select-tuple ] unit-test
 
     [ ] [ person3 get insert-tuple ] unit-test
@@ -418,7 +418,7 @@ TUPLE: does-not-persist ;
 \ bind-tuple must-infer
 \ insert-tuple must-infer
 \ update-tuple must-infer
-\ delete-tuple must-infer
+\ delete-tuples must-infer
 \ select-tuple must-infer
 \ define-persistent must-infer
 \ ensure-table must-infer

extra/db/tuples/tuples.factor

@@ -40,7 +40,7 @@ HOOK: drop-sql-statement db ( class -- obj )
 HOOK: <insert-db-assigned-statement> db ( class -- obj )
 HOOK: <insert-user-assigned-statement> db ( class -- obj )
 HOOK: <update-tuple-statement> db ( class -- obj )
-HOOK: <delete-tuple-statement> db ( tuple class -- obj )
+HOOK: <delete-tuples-statement> db ( tuple class -- obj )
 HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
 
 HOOK: insert-tuple* db ( tuple statement -- )
@@ -136,8 +136,8 @@ M: retryable execute-statement* ( statement type -- )
     db get db-update-statements [ <update-tuple-statement> ] cache
     [ bind-tuple ] keep execute-statement ;
 
-: delete-tuple ( tuple -- )
+: delete-tuples ( tuple -- )
-    dup dup class <delete-tuple-statement> [
+    dup dup class <delete-tuples-statement> [
         [ bind-tuple ] keep execute-statement
     ] with-disposal ;
 

extra/http/http-tests.factor

@@ -134,8 +134,7 @@ read-response-test-1' 1array [
 
 ! Live-fire exercise
 USING: http.server http.server.static http.server.sessions
-http.server.sessions.storage.db http.server.actions
+http.server.actions http.server.auth.login http.server.db http.client
-http.server.auth.login http.server.db http.client
 io.server io.files io io.encodings.ascii
 accessors namespaces threads ;
 
@@ -195,7 +194,6 @@ test-db [
             <action> <protected>
             <login>
             <sessions>
-                sessions-in-db >>sessions
             "" add-responder
             add-quit-action
             <dispatcher>
@@ -226,7 +224,6 @@ test-db [
             <action> [ "text/plain" <content> [ "Hi" write ] >>body ] >>display
             <login>
             <sessions>
-                sessions-in-db >>sessions
             "" add-responder
             add-quit-action
         test-db <db-persistence>

extra/http/http.factor

@@ -329,7 +329,8 @@ SYMBOL: max-post-request
     [ host>> ] [ port>> ] bi <inet> ;
 
 : request-host ( request -- string )
-    [ host>> ] [ drop ":" ] [ port>> number>string ] tri 3append ;
+    [ host>> ] [ port>> ] bi
+    dup 80 = [ drop ] [ ":" swap number>string 3append ] if ;
 
 : write-request-header ( request -- request )
     dup header>> >hashtable

extra/http/server/auth/admin/admin.factor

@@ -0,0 +1,152 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences accessors namespaces combinators
+locals db.tuples
+http.server.templating.chloe
+http.server.boilerplate
+http.server.auth.providers
+http.server.auth.providers.db
+http.server.auth.login
+http.server.forms
+http.server.components.inspector
+http.server.components
+http.server.validators
+http.server.sessions
+http.server.actions
+http.server.crud
+http.server ;
+IN: http.server.auth.admin
+
+: admin-template ( name -- template )
+    "resource:extra/http/server/auth/admin/" swap ".xml" 3append <chloe> ;
+
+: <new-user-form> ( -- form )
+    "user" <form>
+        "new-user" admin-template >>edit-template
+        "username" <string> add-field
+        "realname" <string> add-field
+        "new-password" <password> t >>required add-field
+        "verify-password" <password> t >>required add-field
+        "email" <email> add-field ;
+
+: <edit-user-form> ( -- form )
+    "user" <form>
+        "edit-user" admin-template >>edit-template
+        "user-summary" admin-template >>summary-template
+        "username" <string> hidden >>renderer add-field
+        "realname" <string> add-field
+        "new-password" <password> add-field
+        "verify-password" <password> add-field
+        "email" <email> add-field
+        "profile" <inspector> add-field ;
+
+: <user-list-form> ( -- form )
+    "user-list" <form>
+        "user-list" admin-template >>view-template
+        "list" <edit-user-form> +unordered+ <list> add-field ;
+
+:: <new-user-action> ( form ctor next -- action )
+    <action>
+        [
+            blank-values
+
+            "username" get ctor call
+
+            {
+                [ username>> "username" set-value ]
+                [ realname>> "realname" set-value ]
+                [ email>> "email" set-value ]
+                [ profile>> "profile" set-value ]
+            } cleave
+        ] >>init
+
+        [ form edit-form ] >>display
+
+        [
+            blank-values
+
+            form validate-form
+
+            same-password-twice
+
+            user new "username" value >>username select-tuple [
+                user-exists? on
+                validation-failed
+            ] when
+
+            "username" value <user>
+                "realname" value >>realname
+                "email" value >>email
+                "new-password" value >>password
+                H{ } clone >>profile
+
+            insert-tuple
+
+            next f <standard-redirect>
+        ] >>submit ;
+    
+:: <edit-user-action> ( form ctor next -- action )
+    <action>
+        { { "username" [ v-required ] } } >>get-params
+
+        [
+            blank-values
+
+            "username" get ctor call select-tuple
+
+            {
+                [ username>> "username" set-value ]
+                [ realname>> "realname" set-value ]
+                [ email>> "email" set-value ]
+                [ profile>> "profile" set-value ]
+            } cleave
+        ] >>init
+
+        [ form edit-form ] >>display
+
+        [
+            blank-values
+
+            form validate-form
+
+            "username" value <user> select-tuple
+                "realname" value >>realname
+                "email" value >>email
+
+            { "new-password" "verify-password" }
+            [ value empty? ] all? [
+                same-password-twice
+                "new-password" value >>password
+            ] unless
+
+            update-tuple
+
+            next f <standard-redirect>
+        ] >>submit ;
+
+:: <delete-user-action> ( ctor next -- action )
+    <action>
+        { { "username" [ ] } } >>post-params
+
+        [
+            "username" get
+            [ <user> select-tuple 1 >>deleted update-tuple ]
+            [ logout-all-sessions ]
+            bi
+
+            next f <standard-redirect>
+        ] >>submit ;
+
+TUPLE: user-admin < dispatcher ;
+
+:: <user-admin> ( -- responder )
+    [let | ctor [ [ <user> ] ] |
+        user-admin new-dispatcher
+            <user-list-form> ctor <list-action> "" add-responder
+            <new-user-form> ctor "$user-admin" <new-user-action> "new" add-responder
+            <edit-user-form> ctor "$user-admin" <edit-user-action> "edit" add-responder
+            ctor "$user-admin" <delete-user-action> "delete" add-responder
+        <boilerplate>
+            "admin" admin-template >>template
+        <protected>
+    ] ;

extra/http/server/auth/admin/admin.xml

@@ -0,0 +1,24 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:style include="resource:extra/http/server/auth/admin/admin.css" />
+
+	<div class="navbar">
+		  <t:a t:href="$user-admin">List Users</t:a>
+		| <t:a t:href="$user-admin/new">Add User</t:a>
+
+		<t:if t:code="http.server.auth.login:allow-edit-profile?">
+			| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
+		</t:if>
+
+		<t:form t:action="$login/logout" t:flow="begin" class="inline">
+			| <button type="submit" class="link-button link">Logout</button>
+		</t:form>
+	</div>
+
+	<h1><t:write-title /></h1>
+
+	<t:call-next-template />
+
+</t:chloe>

extra/http/server/auth/admin/edit-user.xml

@@ -0,0 +1,60 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>Edit User</t:title>
+
+	<t:form t:action="$user-admin/edit">
+
+	<t:edit t:component="username" />
+
+	<table>
+	
+	<tr>
+		<th class="field-label">User name:</th>
+		<td><t:view t:component="username" /></td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">Real name:</th>
+		<td><t:edit t:component="realname" /></td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">New password:</th>
+		<td><t:edit t:component="new-password" /></td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">Verify:</th>
+		<td><t:edit t:component="verify-password" /></td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">E-mail:</th>
+		<td><t:edit t:component="email" /></td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">Profile:</th>
+		<td><t:view t:component="profile" /></td>
+	</tr>
+
+	</table>
+	
+	<p>
+		<button type="submit" class="link-button link">Update</button>
+
+		<t:if t:var="http.server.auth.login:password-mismatch?">
+			<t:error>passwords do not match</t:error>
+		</t:if>
+	</p>
+
+	</t:form>
+
+	<t:form t:action="$user-admin/delete">
+		<t:edit t:component="username" />
+
+		<button type="submit" class="link-button link">Delete</button>
+	</t:form>
+</t:chloe>

extra/http/server/auth/admin/new-user.xml

@@ -0,0 +1,51 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>New User</t:title>
+
+	<t:form t:action="$user-admin/new">
+
+	<table>
+	
+	<tr>
+		<th class="field-label">User name:</th>
+		<td><t:edit t:component="username" /></td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">Real name:</th>
+		<td><t:edit t:component="realname" /></td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">New password:</th>
+		<td><t:edit t:component="new-password" /></td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">Verify:</th>
+		<td><t:edit t:component="verify-password" /></td>
+	</tr>
+	
+	<tr>
+		<th class="field-label">E-mail:</th>
+		<td><t:edit t:component="email" /></td>
+	</tr>
+
+	</table>
+	
+	<p>
+		<button type="submit" class="link-button link">Create</button>
+
+		<t:if t:var="http.server.auth.login:user-exists?">
+				<t:error>username taken</t:error>
+		</t:if>
+
+		<t:if t:var="http.server.auth.login:password-mismatch?">
+			<t:error>passwords do not match</t:error>
+		</t:if>
+	</p>
+
+	</t:form>
+</t:chloe>

extra/http/server/auth/admin/user-list.xml

@@ -0,0 +1,9 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:title>Users</t:title>
+
+	<t:summary t:component="list" />
+
+</t:chloe>

extra/http/server/auth/admin/user-summary.xml

@@ -0,0 +1,9 @@
+<?xml version='1.0' ?>
+
+<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+
+	<t:a t:href="$user-admin/edit" t:query="username">
+		<t:view t:component="username" />
+	</t:a>
+
+</t:chloe>

extra/http/server/auth/auth.factor

@@ -7,7 +7,6 @@ http.server.auth.providers ;
 IN: http.server.auth
 
 SYMBOL: logged-in-user
-SYMBOL: user-profile-changed?
 
 GENERIC: init-user-profile ( responder -- )
 
@@ -19,16 +18,18 @@ M: dispatcher init-user-profile
 M: filter-responder init-user-profile
     responder>> init-user-profile ;
 
-: uid ( -- string ) logged-in-user sget username>> ;
+: profile ( -- assoc ) logged-in-user get profile>> ;
 
-: profile ( -- assoc ) logged-in-user sget profile>> ;
+: user-changed ( -- )
+    logged-in-user get t >>changed? drop ;
 
 : uget ( key -- value )
     profile at ;
 
 : uset ( value key -- )
-    profile set-at user-profile-changed? on ;
+    profile set-at
+    user-changed ;
 
 : uchange ( quot key -- )
     profile swap change-at
-    user-profile-changed? on ; inline
+    user-changed ; inline

extra/http/server/auth/login/edit-profile.xml

@@ -4,7 +4,7 @@
 
 	<t:title>Edit Profile</t:title>
 
-	<t:form t:action="edit-profile">
+	<t:form t:action="$login/edit-profile">
 
 	<table>
 	

extra/http/server/auth/login/login.factor

@@ -35,9 +35,7 @@ TUPLE: user-saver user ;
 C: <user-saver> user-saver
 
 M: user-saver dispose
-    user-profile-changed? get [
+    user>> dup changed?>> [ users update-user ] [ drop ] if ;
-        user>> users update-user
-    ] [ drop ] if ;
 
 : save-user-after ( user -- )
     <user-saver> add-always-destructor ;
@@ -59,7 +57,7 @@ M: user-saver dispose
             add-field ;
 
 : successful-login ( user -- response )
-    logged-in-user sset
+    username>> set-uid
     "$login" end-flow ;
 
 :: <login-action> ( -- action )
@@ -125,11 +123,11 @@ SYMBOL: user-exists?
 
                 same-password-twice
 
-                <user>
+                "username" value <user>
-                    "username" value >>username
                     "realname" value >>realname
                     "new-password" value >>password
                     "email" value >>email
+                    H{ } clone >>profile
 
                 users new-user [
                     user-exists? on
@@ -160,7 +158,7 @@ SYMBOL: user-exists?
             [
                 blank-values
 
-                logged-in-user sget
+                logged-in-user get
                 [ username>> "username" set-value ]
                 [ realname>> "realname" set-value ]
                 [ email>> "email" set-value ]
@@ -175,7 +173,7 @@ SYMBOL: user-exists?
 
                 form validate-form
 
-                logged-in-user sget
+                logged-in-user get
 
                 { "password" "new-password" "verify-password" }
                 [ value empty? ] all? [
@@ -190,9 +188,9 @@ SYMBOL: user-exists?
                 "realname" value >>realname
                 "email" value >>email
 
-                drop
+                t >>changed?
 
-                user-profile-changed? on
+                drop
 
                 "$login" end-flow
             ] >>submit
@@ -330,7 +328,7 @@ SYMBOL: lost-password-from
 : <logout-action> ( -- action )
     <action>
         [
-            f logged-in-user sset
+            f set-uid
             "$login/login" end-flow
         ] >>submit ;
 
@@ -345,8 +343,9 @@ C: <protected> protected
     "$login/login" f <standard-redirect> ;
 
 M: protected call-responder* ( path responder -- response )
-    logged-in-user sget dup [
+    uid dup [
-        save-user-after
+        users get-user
+        [ logged-in-user set ] [ save-user-after ] bi
         call-next-method
     ] [
         3drop show-login-page

extra/http/server/auth/providers/assoc/assoc-tests.factor

@@ -6,17 +6,17 @@ namespaces accessors kernel ;
 <users-in-memory> "provider" set
 
 [ t ] [
-    <user>
+    "slava" <user>
-        "slava" >>username
         "foobar" >>password
         "slava@factorcode.org" >>email
+        H{ } clone >>profile
     "provider" get new-user
     username>> "slava" =
 ] unit-test
 
 [ f ] [
-    <user>
+    "slava" <user>
-        "slava" >>username
+        H{ } clone >>profile
     "provider" get new-user
 ] unit-test
 

extra/http/server/auth/providers/db/db-tests.factor

@@ -6,22 +6,24 @@ io.files accessors kernel ;
 
 users-in-db "provider" set
 
+[ "auth-test.db" temp-file delete-file ] ignore-errors
+
 "auth-test.db" temp-file sqlite-db [
 
     init-users-table
 
     [ t ] [
-        <user>
+        "slava" <user>
-            "slava" >>username
             "foobar" >>password
             "slava@factorcode.org" >>email
+            H{ } clone >>profile
             "provider" get new-user
             username>> "slava" =
     ] unit-test
 
     [ f ] [
-        <user>
+        "slava" <user>
-            "slava" >>username
+            H{ } clone >>profile
         "provider" get new-user
     ] unit-test
 

extra/http/server/auth/providers/db/db.factor

@@ -13,25 +13,22 @@ user "USERS"
     { "email" "EMAIL" { VARCHAR 256 } }
     { "ticket" "TICKET" { VARCHAR 256 } }
     { "profile" "PROFILE" FACTOR-BLOB }
+    { "deleted" "DELETED" INTEGER +not-null+ }
 } define-persistent
 
 : init-users-table user ensure-table ;
 
 SINGLETON: users-in-db
 
-: find-user ( username -- user )
-    <user>
-        swap >>username
-    select-tuple ;
-
 M: users-in-db get-user
-    drop
+    drop <user> select-tuple ;
-    find-user ;
 
 M: users-in-db new-user
     drop
     [
-        dup username>> find-user [
+        user new
+            over username>> >>username
+        select-tuple [
             drop f
         ] [
             dup insert-tuple

extra/http/server/auth/providers/providers.factor

@@ -4,9 +4,12 @@ USING: kernel accessors random math.parser locals
 sequences math crypto.sha2 ;
 IN: http.server.auth.providers
 
-TUPLE: user username realname password email ticket profile ;
+TUPLE: user username realname password email ticket profile deleted changed? ;
 
-: <user> user new H{ } clone >>profile ;
+: <user> ( username -- user )
+    user new
+        swap >>username
+        0 >>deleted ;
 
 GENERIC: get-user ( username provider -- user/f )
 

extra/http/server/components/components.factor

@@ -30,8 +30,6 @@ TUPLE: hidden < field ;
 
 : hidden ( -- renderer ) T{ hidden f "hidden" } ; inline
 
-M: hidden render-view* 2drop ;
-
 ! Component protocol
 SYMBOL: components
 

extra/http/server/components/inspector/inspector.factor

@@ -0,0 +1,17 @@
+! Copyright (C) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: splitting kernel io sequences inspector accessors
+http.server.components ;
+IN: http.server.components.inspector
+
+SINGLETON: inspector-renderer
+
+M: inspector-renderer render-view*
+    drop describe ;
+
+TUPLE: inspector < component ;
+
+M: inspector component-string drop ;
+
+: <inspector> ( id -- component )
+    inspector inspector-renderer new-component ;

extra/http/server/crud/crud.factor

@@ -51,7 +51,7 @@ IN: http.server.crud
         { { "id" [ v-number ] } } >>post-params
 
         [
-            "id" get ctor call delete-tuple
+            "id" get ctor call delete-tuples
 
             next f <standard-redirect>
         ] >>submit ;

extra/http/server/sessions/sessions.factor

@@ -7,7 +7,7 @@ db db.tuples db.types
 http http.server html.elements ;
 IN: http.server.sessions
 
-TUPLE: session id expires namespace changed? ;
+TUPLE: session id expires uid namespace changed? ;
 
 : <session> ( id -- session )
     session new
@@ -16,7 +16,8 @@ TUPLE: session id expires namespace changed? ;
 session "SESSIONS"
 {
     { "id" "ID" +random-id+ system-random-generator }
-    { "expires" "EXPIRES" BIG-INTEGER +not-null+ }
+    { "expires" "EXPIRES" TIMESTAMP +not-null+ }
+    { "uid" "UID" { VARCHAR 255 } }
     { "namespace" "NAMESPACE" FACTOR-BLOB }
 } define-persistent
 
@@ -25,14 +26,13 @@ session "SESSIONS"
 
 : init-sessions-table session ensure-table ;
 
-: expired-sessions ( -- session )
-    f <session>
-        -1.0/0.0 now timestamp>millis [a,b] >>expires
-    select-tuples ;
-
 : start-expiring-sessions ( db seq -- )
     '[
-        , , [ expired-sessions [ delete-tuple ] each ] with-db
+        , , [
+            session new
+                -1.0/0.0 now [a,b] >>expires
+            delete-tuples
+        ] with-db
     ] 5 minutes every drop ;
 
 GENERIC: init-session* ( responder -- )
@@ -68,11 +68,17 @@ TUPLE: sessions < filter-responder timeout domain ;
     [ namespace>> swap change-at ] keep
     (session-changed) ; inline
 
+: uid ( -- uid )
+    session get uid>> ;
+
+: set-uid ( uid -- )
+    session get [ (>>uid) ] [ (session-changed) ] bi ;
+
 : init-session ( session -- )
     session [ sessions get init-session* ] with-variable ;
 
 : cutoff-time ( -- time )
-    sessions get timeout>> from-now timestamp>millis ;
+    sessions get timeout>> from-now ;
 
 : touch-session ( session -- )
     cutoff-time >>expires drop ;
@@ -142,3 +148,6 @@ M: sessions call-responder* ( path responder -- response )
     sessions set
     request-session [ begin-session ] unless*
     existing-session put-session-cookie ;
+
+: logout-all-sessions ( uid -- )
+    session new swap >>uid delete-tuples ;

extra/locals/locals.factor

@@ -81,16 +81,24 @@ C: <quote> quote
 UNION: special local quote local-word local-reader local-writer ;
 
 : load-locals-quot ( args -- quot )
-    dup [ local-reader? ] contains? [
+    dup empty? [
-        <reversed> [
+        drop [ ]
-            local-reader? [ 1array >r ] [ >r ] ?
-        ] map concat
     ] [
-        length [ load-locals ] curry >quotation
+        dup [ local-reader? ] contains? [
+            <reversed> [
+                local-reader? [ 1array >r ] [ >r ] ?
+            ] map concat
+        ] [
+            length [ load-locals ] curry >quotation
+        ] if
     ] if ;
 
 : drop-locals-quot ( args -- quot )
-    length [ drop-locals ] curry ;
+    dup empty? [
+        drop [ ]
+    ] [
+        length [ drop-locals ] curry
+    ] if ;
 
 : point-free-body ( quot args -- newquot )
     >r 1 head-slice* r> [ localize ] curry map concat ;

extra/semantic-db/semantic-db.factor

@@ -20,7 +20,7 @@ node "node"
     node create-table ;
 
 : delete-node ( node-id -- )
-    <id-node> delete-tuple ;
+    <id-node> delete-tuples ;
 
 : create-node* ( str -- node-id )
     <node> dup insert-tuple id>> ;
@@ -43,7 +43,7 @@ TUPLE: arc id relation subject object ;
     f <node> dup insert-tuple id>> >>id insert-tuple ;
 
 : delete-arc ( arc-id -- )
-    dup delete-node <id-arc> delete-tuple ;
+    dup delete-node <id-arc> delete-tuples ;
 
 : create-arc* ( relation subject object -- arc-id )
     <arc> dup insert-arc id>> ;

extra/symbols/symbols.factor

@@ -1,9 +1,14 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: parser sequences words kernel ;
+USING: parser sequences words kernel classes.singleton ;
 IN: symbols
 
 : SYMBOLS:
     ";" parse-tokens
     [ create-in dup reset-generic define-symbol ] each ;
     parsing
+
+: SINGLETONS:
+    ";" parse-tokens
+    [ create-class-in dup save-location define-singleton-class ] each ;
+    parsing

extra/tools/vocabs/monitor/monitor.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: threads io.files io.monitors init kernel
 vocabs vocabs.loader tools.vocabs namespaces continuations
-sequences splitting assocs command-line ;
+sequences splitting assocs command-line concurrency.messaging io.backend sets ;
 IN: tools.vocabs.monitor
 
 : vocab-dir>vocab-name ( path -- vocab )
@@ -22,17 +22,20 @@ IN: tools.vocabs.monitor
 : path>vocab ( path -- vocab )
     chop-vocab-root path>vocab-name vocab-dir>vocab-name ;
 
-: monitor-loop ( monitor -- )
+: monitor-loop ( -- )
     #! On OS X, monitors give us the full path, so we chop it
     #! off if its there.
-    dup next-change drop path>vocab changed-vocab
+    receive first path>vocab changed-vocab
     reset-cache
     monitor-loop ;
 
+: add-monitor-for-path ( path -- ) 
+    normalize-path dup exists? [ t my-mailbox (monitor) ] when drop ;
+    
 : monitor-thread ( -- )
     [
         [
-            "" resource-path t <monitor>
+            vocab-roots get prune [ add-monitor-for-path ] each
             
             H{ } clone changed-vocabs set-global
             vocabs [ changed-vocab ] each

extra/tools/walker/walker.factor

@@ -259,3 +259,8 @@ SYMBOL: +stopped+
     ] 3curry
     "Walker on " self thread-name append spawn
     [ associate-thread ] keep ;
+
+! For convenience
+IN: syntax
+
+: B break ;

extra/usa-cities/usa-cities.factor

@@ -0,0 +1,53 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.files io.encodings.ascii sequences sequences.lib
+math.parser combinators kernel memoize csv symbols inspector
+words accessors math.order sorting ;
+IN: usa-cities
+
+SINGLETONS: AK AL AR AS AZ CA CO CT DC DE FL GA HI IA ID IL IN
+KS KY LA MA MD ME MI MN MO MS MT NC ND NE NH NJ NM NV NY OH OK
+OR PA PR RI SC SD TN TX UT VA VI VT WA WI WV WY ;
+
+: states ( -- seq )
+    {
+        AK AL AR AS AZ CA CO CT DC DE FL GA HI IA ID IL IN KS KY
+        LA MA MD ME MI MN MO MS MT NC ND NE NH NJ NM NV NY OH OK
+        OR PA PR RI SC SD TN TX UT VA VI VT WA WI WV WY
+    } ; inline
+
+ERROR: no-such-state name ;
+
+M: no-such-state summary drop "No such state" ;
+
+MEMO: string>state ( string -- state )
+    dup states [ word-name = ] with find nip
+    [ ] [ no-such-state ] ?if ;
+
+TUPLE: city
+first-zip name state latitude longitude gmt-offset dst-offset ;
+
+MEMO: cities ( -- seq )
+    "resource:extra/usa-cities/zipcode.csv" ascii <file-reader>
+    csv rest-slice [
+        7 firstn {
+            [ string>number ]
+            [ ]
+            [ string>state ]
+            [ string>number ]
+            [ string>number ]
+            [ string>number ]
+            [ string>number ]
+        } spread city boa
+    ] map ;
+
+MEMO: cities-named ( name -- cities )
+    cities [ name>> = ] with filter ;
+
+MEMO: cities-named-in ( name state -- cities )
+    cities [
+        tuck [ name>> = ] [ state>> = ] 2bi* and
+    ] with with filter ;
+
+: find-zip-code ( code -- city )
+    cities [ first-zip>> <=> ] binsearch* ;

extra/webapps/factor-website/factor-website.factor

@@ -6,9 +6,9 @@ http.server
 http.server.db
 http.server.flows
 http.server.sessions
+http.server.auth.admin
 http.server.auth.login
 http.server.auth.providers.db
-http.server.sessions.storage.db
 http.server.boilerplate
 http.server.templating.chloe
 webapps.pastebin
@@ -16,7 +16,7 @@ webapps.planet
 webapps.todo ;
 IN: webapps.factor-website
 
-: test-db "test.db" resource-path sqlite-db ;
+: test-db "resource:test.db" sqlite-db ;
 
 : factor-template ( path -- template )
     "resource:extra/webapps/factor-website/" swap ".xml" 3append <chloe> ;
@@ -39,6 +39,7 @@ IN: webapps.factor-website
         <todo-list> "todo" add-responder
         <pastebin> "pastebin" add-responder
         <planet-factor> "planet" add-responder
+        <user-admin> "user-admin" add-responder
     <login>
         users-in-db >>users
         allow-registration
@@ -48,7 +49,6 @@ IN: webapps.factor-website
         "page" factor-template >>template
     <flows>
     <sessions>
-        sessions-in-db >>sessions
     test-db <db-persistence> ;
 
 : init-factor-website ( -- )

extra/webapps/pastebin/pastebin.factor

@@ -197,9 +197,9 @@ annotation "ANNOTATION"
         { { "id" [ v-number ] } } >>post-params
 
         [
-            "id" get ctor call delete-tuple
+            "id" get ctor call delete-tuples
 
-            "id" get f <annotation> select-tuples [ delete-tuple ] each
+            "id" get f <annotation> delete-tuples
 
             next f <permanent-redirect>
         ] >>submit ;
@@ -209,7 +209,7 @@ annotation "ANNOTATION"
         { { "id" [ v-number ] } { "aid" [ v-number ] } } >>post-params
 
         [
-            "id" get "aid" get ctor call delete-tuple
+            "id" get "aid" get ctor call delete-tuples
 
             "id" get next <id-redirect>
         ] >>submit ;

extra/webapps/pastebin/pastebin.xml

@@ -11,7 +11,7 @@
 		| <t:a t:href="$pastebin/new-paste">New Paste</t:a>
 		| <t:a t:href="$pastebin/feed.xml">Atom Feed</t:a>
 
-		<t:if t:svar="http.server.auth:logged-in-user">
+		<t:if t:var="http.server.auth:logged-in-user">
 
 			<t:if t:code="http.server.auth.login:allow-edit-profile?">
 				| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>

extra/webapps/planet/planet.xml

@@ -12,7 +12,7 @@
 		| <t:a t:href="$planet-factor/feed.xml">Atom Feed</t:a>
 		| <t:a t:href="$planet-factor/admin">Admin</t:a>
 
-		<t:if t:svar="http.server.auth:logged-in-user">
+		<t:if t:var="http.server.auth:logged-in-user">
 			<t:if t:code="http.server.auth.login:allow-edit-profile?">
 				| <t:a t:href="$login/edit-profile" t:flow="begin">Edit Profile</t:a>
 			</t:if>

extra/webapps/todo/todo.factor

@@ -2,10 +2,16 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel locals sequences namespaces
 db db.types db.tuples
-http.server.components http.server.components.farkup
+http.server.sessions
-http.server.forms http.server.templating.chloe
+http.server.components
-http.server.boilerplate http.server.crud http.server.auth
+http.server.components.farkup
-http.server.actions http.server.db
+http.server.forms
+http.server.templating.chloe
+http.server.boilerplate
+http.server.crud
+http.server.auth
+http.server.actions
+http.server.db
 http.server.auth.login
 http.server ;
 IN: webapps.todo