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

2008-03-06 11:40:52 -06:00 · 2008-03-06 11:40:52 -06:00 · 41e4d59e63
parent ca6fc5edc6 bff5d2af6d
commit 41e4d59e63
17 changed files with 310 additions and 16 deletions
--- a/core/hashtables/hashtables.factor
+++ b/core/hashtables/hashtables.factor
@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel kernel.private slots.private math assocs
-math.private sequences sequences.private vectors ;
+       math.private sequences sequences.private vectors ;
 IN: hashtables

 <PRIVATE
@ -16,15 +16,16 @@ IN: hashtables
    2 fixnum+fast over wrap ; inline

 : (key@) ( key keys i -- array n ? )
-    3dup swap array-nth dup ((tombstone)) eq? [
-        2drop probe (key@)
-    ] [
-        dup ((empty)) eq? [
-            3drop nip f f
-        ] [
-            = [ rot drop t ] [ probe (key@) ] if
-        ] if
-    ] if ; inline
+    3dup swap array-nth
+    dup ((empty)) eq?
+      [ 3drop nip f f ]
+      [
+        =
+          [ rot drop t ]
+          [ probe (key@) ]
+        if
+      ]
+    if ; inline

 : key@ ( key hash -- array n ? )
    hash-array 2dup hash@ (key@) ; inline
--- a/extra/builder/builder.factor
+++ b/extra/builder/builder.factor
@ -39,7 +39,7 @@ IN: builder

 : record-git-id ( -- ) git-id "../git-id" [ . ] with-file-writer ;

-: do-make-clean ( -- desc ) { "make" "clean" } try-process ;
+: do-make-clean ( -- ) { "make" "clean" } try-process ;

 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

--- a/extra/db/sqlite/sqlite-tests.factor
+++ b/extra/db/sqlite/sqlite-tests.factor
@ -3,7 +3,7 @@ prettyprint tools.test db.sqlite db sequences
 continuations db.types db.tuples unicode.case ;
 IN: db.sqlite.tests

-: db-path "extra/db/sqlite/test.db" resource-path ;
+: db-path "test.db" temp-file ;
 : test.db db-path sqlite-db ;

 [ ] [ [ db-path delete-file ] ignore-errors ] unit-test
--- a/extra/db/sqlite/test.db
+++ b/extra/db/sqlite/test.db
--- a/extra/db/tuples/tuples-tests.factor
+++ b/extra/db/tuples/tuples-tests.factor
@ -159,7 +159,7 @@ TUPLE: annotation n paste-id summary author mode contents ;
 ! ] with-db

 : test-sqlite ( quot -- )
-    >r "tuples-test.db" resource-path sqlite-db r> with-db ;
+    >r "tuples-test.db" temp-file sqlite-db r> with-db ;

 : test-postgresql ( -- )
    >r { "localhost" "postgres" "" "factor-test" } postgresql-db r> with-db ;
--- a/extra/http/server/auth/basic/basic.factor
+++ b/extra/http/server/auth/basic/basic.factor
@ -0,0 +1,41 @@
+! Copyright (c) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors new-slots quotations assocs kernel splitting
+base64 html.elements io combinators http.server
+http.server.auth.providers http.server.auth.providers.null
+http sequences ;
+IN: http.server.auth.basic
+
+TUPLE: basic-auth responder realm provider ;
+
+C: <basic-auth> basic-auth
+
+: authorization-ok? ( provider header -- ? )
+    #! Given the realm and the 'Authorization' header,
+    #! authenticate the user.
+    dup [
+        " " split1 swap "Basic" = [
+            base64> ":" split1 spin check-login
+        ] [
+            2drop f
+        ] if
+    ] [
+        2drop f
+    ] if ;
+
+: <401> ( realm -- response )
+    401 "Unauthorized" <trivial-response>
+    "Basic realm=\"" rot "\"" 3append
+    "WWW-Authenticate" set-header
+    [
+        <html> <body>
+            "Username or Password is invalid" write
+        </body> </html>
+    ] >>body ;
+
+: logged-in? ( request responder -- ? )
+    provider>> swap "authorization" header authorization-ok? ;
+
+M: basic-auth call-responder ( request path responder -- response )
+    pick over logged-in?
+    [ responder>> call-responder ] [ 2nip realm>> <401> ] if ;
--- a/extra/http/server/auth/login/login.factor
+++ b/extra/http/server/auth/login/login.factor
@ -0,0 +1,69 @@
+! Copyright (c) 2008 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors new-slots quotations assocs kernel splitting
+base64 html.elements io combinators http.server
+http.server.auth.providers http.server.actions
+http.server.sessions http.server.templating.fhtml http sequences
+io.files namespaces ;
+IN: http.server.auth.login
+
+TUPLE: login-auth responder provider ;
+
+C: (login-auth) login-auth
+
+SYMBOL: logged-in?
+SYMBOL: provider
+SYMBOL: post-login-url
+
+: login-page ( -- response )
+    "text/html" <content> [
+        "extra/http/server/auth/login/login.fhtml"
+        resource-path run-template-file
+    ] >>body ;
+
+: <login-action>
+    <action>
+        [ login-page ] >>get
+
+        {
+            { "name" [ ] }
+            { "password" [ ] }
+        } >>post-params
+        [
+            "password" get
+            "name" get
+            provider sget check-login [
+                t logged-in? sset
+                post-login-url sget <permanent-redirect>
+            ] [
+                login-page
+            ] if
+        ] >>post ;
+
+: <logout-action>
+    <action>
+        [
+            f logged-in? sset
+            request get "login" <permanent-redirect>
+        ] >>post ;
+
+M: login-auth call-responder ( request path responder -- response )
+    logged-in? sget
+    [ responder>> call-responder ] [
+        pick method>> "GET" = [
+            nip
+            provider>> provider sset
+            dup request-url post-login-url sset
+            "login" f session-link <permanent-redirect>
+        ] [
+            3drop <400>
+        ] if
+    ] if ;
+
+: <login-auth> ( responder provider -- auth )
+        (login-auth)
+        <dispatcher>
+            swap >>default
+            <login-action> "login" add-responder
+            <logout-action> "logout" add-responder
+    <cookie-sessions> ;
--- a/extra/http/server/auth/login/login.fhtml
+++ b/extra/http/server/auth/login/login.fhtml
@ -0,0 +1,25 @@
+<html>
+<body>
+<h1>Login required</h1>
+
+<form method="POST" action="login">
+<table>
+
+<tr>
+<td>User name:</td>
+<td><input name="name" /></td>
+</tr>
+
+<tr>
+<td>Password:</td>
+<td><input type="password" name="password" /></td>
+</tr>
+
+</table>
+
+<input type="submit" value="Log in" />
+
+</form>
+
+</body>
+</html>
--- a/extra/http/server/auth/providers/assoc/assoc-tests.factor
+++ b/extra/http/server/auth/providers/assoc/assoc-tests.factor
@ -0,0 +1,18 @@
+IN: http.server.auth.providers.assoc.tests
+USING: http.server.auth.providers 
+http.server.auth.providers.assoc tools.test
+namespaces ;
+
+<assoc-auth-provider> "provider" set
+
+"slava" "provider" get new-user
+
+[ "slava" "provider" get new-user ] [ user-exists? ] must-fail-with
+
+[ f ] [ "fdasf" "slava" "provider" get check-login ] unit-test
+
+[ "xx" "blah" "provider" get set-password ] [ no-such-user? ] must-fail-with
+
+"fdasf" "slava" "provider" get set-password
+
+[ t ] [ "fdasf" "slava" "provider" get check-login ] unit-test
--- a/extra/http/server/auth/providers/assoc/assoc.factor
+++ b/extra/http/server/auth/providers/assoc/assoc.factor
@ -0,0 +1,23 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: http.server.auth.providers.assoc
+USING: new-slots accessors assocs kernel
+http.server.auth.providers ;
+
+TUPLE: assoc-auth-provider assoc ;
+
+: <assoc-auth-provider> ( -- provider )
+    H{ } clone assoc-auth-provider construct-boa ;
+
+M: assoc-auth-provider check-login
+    assoc>> at = ;
+
+M: assoc-auth-provider new-user
+    assoc>>
+    2dup key? [ drop user-exists ] when
+    t -rot set-at ;
+
+M: assoc-auth-provider set-password
+    assoc>>
+    2dup key? [ drop no-such-user ] unless
+    set-at ;
--- a/extra/http/server/auth/providers/db/db-tests.factor
+++ b/extra/http/server/auth/providers/db/db-tests.factor
@ -0,0 +1,25 @@
+IN: http.server.auth.providers.db.tests
+USING: http.server.auth.providers
+http.server.auth.providers.db tools.test
+namespaces db db.sqlite db.tuples continuations
+io.files ;
+
+db-auth-provider "provider" set
+
+"auth-test.db" temp-file sqlite-db [
+    
+    [ user drop-table ] ignore-errors
+    [ user create-table ] ignore-errors
+
+    "slava" "provider" get new-user
+
+    [ "slava" "provider" get new-user ] [ user-exists? ] must-fail-with
+
+    [ f ] [ "fdasf" "slava" "provider" get check-login ] unit-test
+
+    [ "xx" "blah" "provider" get set-password ] [ no-such-user? ] must-fail-with
+
+    "fdasf" "slava" "provider" get set-password
+
+    [ t ] [ "fdasf" "slava" "provider" get check-login ] unit-test
+] with-db
--- a/extra/http/server/auth/providers/db/db.factor
+++ b/extra/http/server/auth/providers/db/db.factor
@ -0,0 +1,53 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: db db.tuples db.types new-slots accessors
+http.server.auth.providers kernel ;
+IN: http.server.auth.providers.db
+
+TUPLE: user name password ;
+
+: <user> user construct-empty ;
+
+user "USERS"
+{
+    { "name" "NAME" { VARCHAR 256 } +assigned-id+ }
+    { "password" "PASSWORD" { VARCHAR 256 } +not-null+ }
+} define-persistent
+
+: init-users-table ( -- )
+    user create-table ;
+
+TUPLE: db-auth-provider ;
+
+: db-auth-provider T{ db-auth-provider } ;
+
+M: db-auth-provider check-login
+    drop
+    <user>
+    swap >>name
+    swap >>password
+    select-tuple >boolean ;
+
+M: db-auth-provider new-user
+    drop
+    [
+        <user>
+        swap >>name
+
+        dup select-tuple [ name>> user-exists ] when
+
+        "unassigned" >>password
+
+        insert-tuple
+    ] with-transaction ;
+
+M: db-auth-provider set-password
+    drop
+    [
+        <user>
+        swap >>name
+
+        dup select-tuple [ ] [ no-such-user ] ?if
+
+        swap >>password update-tuple
+    ] with-transaction ;
--- a/extra/http/server/auth/providers/null/null.factor
+++ b/extra/http/server/auth/providers/null/null.factor
@ -0,0 +1,14 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: http.server.auth.providers kernel ;
+IN: http.server.auth.providers.null
+
+TUPLE: null-auth-provider ;
+
+: null-auth-provider T{ null-auth-provider } ;
+
+M: null-auth-provider check-login 3drop f ;
+
+M: null-auth-provider new-user 3drop f ;
+
+M: null-auth-provider set-password 3drop f ;
--- a/extra/http/server/auth/providers/providers.factor
+++ b/extra/http/server/auth/providers/providers.factor
@ -0,0 +1,18 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel ;
+IN: http.server.auth.providers
+
+GENERIC: check-login ( password user provider -- ? )
+
+GENERIC: new-user ( user provider -- )
+
+GENERIC: set-password ( password user provider -- )
+
+TUPLE: user-exists name ;
+
+: user-exists ( name -- * ) \ user-exists construct-boa throw ;
+
+TUPLE: no-such-user name ;
+
+: no-such-user ( name -- * ) \ no-such-user construct-boa throw ;
--- a/extra/http/server/sessions/sessions-tests.factor
+++ b/extra/http/server/sessions/sessions-tests.factor
@ -4,6 +4,12 @@ kernel accessors ;

 : with-session \ session swap with-variable ; inline

+TUPLE: foo ;
+
+C: <foo> foo
+
+M: foo init-session drop 0 "x" sset ;
+
 "1234" f <session> [
    [ ] [ 3 "x" sset ] unit-test
    
@ -18,8 +24,7 @@ kernel accessors ;
 [ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test

 [ ] [
-    f <url-sessions>
-        [ 0 "x" sset ] >>init
+    <foo> <url-sessions>
    "manager" set
 ] unit-test

--- a/extra/http/server/sessions/sessions.factor
+++ b/extra/http/server/sessions/sessions.factor
@ -11,6 +11,8 @@ IN: http.server.sessions

 GENERIC: init-session ( responder -- )

+M: dispatcher init-session drop ;
+
 TUPLE: session-manager responder sessions ;

 : <session-manager> ( responder class -- responder' )
--- a/extra/http/server/templating/fhtml/fhtml.factor
+++ b/extra/http/server/templating/fhtml/fhtml.factor
@ -9,7 +9,7 @@ assocs ;

 IN: http.server.templating.fhtml

-: templating-vocab ( -- vocab-name ) "http.server.templating" ;
+: templating-vocab ( -- vocab-name ) "http.server.templating.fhtml" ;

 ! See apps/http-server/test/ or libs/furnace/ for template usage
 ! examples