From 955387f5b7e59292ac36166b7a4a15795b9d4515 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 6 Mar 2008 03:00:10 -0600
Subject: [PATCH 1/5] HTTP authorization framework, first cut
---
extra/http/server/auth/auth.factor | 25 +++++++
extra/http/server/auth/basic/basic.factor | 41 +++++++++++
extra/http/server/auth/login/login.factor | 69 +++++++++++++++++++
extra/http/server/auth/login/login.fhtml | 25 +++++++
.../auth/providers/assoc/assoc-tests.factor | 18 +++++
.../server/auth/providers/assoc/assoc.factor | 23 +++++++
.../server/auth/providers/db/db-tests.factor | 24 +++++++
extra/http/server/auth/providers/db/db.factor | 53 ++++++++++++++
.../server/auth/providers/null/null.factor | 14 ++++
.../server/auth/providers/providers.factor | 18 +++++
.../server/sessions/sessions-tests.factor | 9 ++-
extra/http/server/sessions/sessions.factor | 2 +
.../http/server/templating/fhtml/fhtml.factor | 2 +-
13 files changed, 320 insertions(+), 3 deletions(-)
create mode 100755 extra/http/server/auth/auth.factor
create mode 100755 extra/http/server/auth/basic/basic.factor
create mode 100755 extra/http/server/auth/login/login.factor
create mode 100755 extra/http/server/auth/login/login.fhtml
create mode 100755 extra/http/server/auth/providers/assoc/assoc-tests.factor
create mode 100755 extra/http/server/auth/providers/assoc/assoc.factor
create mode 100755 extra/http/server/auth/providers/db/db-tests.factor
create mode 100755 extra/http/server/auth/providers/db/db.factor
create mode 100755 extra/http/server/auth/providers/null/null.factor
create mode 100755 extra/http/server/auth/providers/providers.factor
diff --git a/extra/http/server/auth/auth.factor b/extra/http/server/auth/auth.factor
new file mode 100755
index 0000000000..a53905bce1
--- /dev/null
+++ b/extra/http/server/auth/auth.factor
@@ -0,0 +1,25 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: http.server.auth
+USING: new-slots accessors http.server.auth.providers.null
+http.server.auth.strategies.null ;
+
+TUPLE: authentication responder provider strategy ;
+
+: <authentication> ( responder -- authentication )
+ null-auth-provider null-auth-strategy
+ authentication construct-boa ;
+
+SYMBOL: current-user-id
+SYMBOL: auth-provider
+SYMBOL: auth-strategy
+
+M: authentication call-responder ( request path responder -- response )
+ dup provider>> auth-provider set
+ dup strategy>> auth-strategy set
+ pick auth-provider get logged-in? dup current-user-id set
+ [
+ responder>> call-responder
+ ] [
+ 2drop auth-provider get require-login
+ ] if* ;
diff --git a/extra/http/server/auth/basic/basic.factor b/extra/http/server/auth/basic/basic.factor
new file mode 100755
index 0000000000..2ea74febba
--- /dev/null
+++ 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 ;
diff --git a/extra/http/server/auth/login/login.factor b/extra/http/server/auth/login/login.factor
new file mode 100755
index 0000000000..e2f9a3608a
--- /dev/null
+++ 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> ;
diff --git a/extra/http/server/auth/login/login.fhtml b/extra/http/server/auth/login/login.fhtml
new file mode 100755
index 0000000000..9bb1438588
--- /dev/null
+++ 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>
diff --git a/extra/http/server/auth/providers/assoc/assoc-tests.factor b/extra/http/server/auth/providers/assoc/assoc-tests.factor
new file mode 100755
index 0000000000..3270fe06e3
--- /dev/null
+++ 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
diff --git a/extra/http/server/auth/providers/assoc/assoc.factor b/extra/http/server/auth/providers/assoc/assoc.factor
new file mode 100755
index 0000000000..d57be622c7
--- /dev/null
+++ 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 ;
diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor
new file mode 100755
index 0000000000..384e094f39
--- /dev/null
+++ b/extra/http/server/auth/providers/db/db-tests.factor
@@ -0,0 +1,24 @@
+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 ;
+
+db-auth-provider "provider" set
+
+"auth-test.db" 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
diff --git a/extra/http/server/auth/providers/db/db.factor b/extra/http/server/auth/providers/db/db.factor
new file mode 100755
index 0000000000..9583122875
--- /dev/null
+++ 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 ;
diff --git a/extra/http/server/auth/providers/null/null.factor b/extra/http/server/auth/providers/null/null.factor
new file mode 100755
index 0000000000..702111972e
--- /dev/null
+++ 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 ;
diff --git a/extra/http/server/auth/providers/providers.factor b/extra/http/server/auth/providers/providers.factor
new file mode 100755
index 0000000000..1e0fd33a67
--- /dev/null
+++ 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 ;
diff --git a/extra/http/server/sessions/sessions-tests.factor b/extra/http/server/sessions/sessions-tests.factor
index 4c21ba3c8d..d771737c73 100755
--- 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
diff --git a/extra/http/server/sessions/sessions.factor b/extra/http/server/sessions/sessions.factor
index 2977e5938d..d7fed6bb64 100755
--- 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' )
diff --git a/extra/http/server/templating/fhtml/fhtml.factor b/extra/http/server/templating/fhtml/fhtml.factor
index 37f4b85c51..e5770affc5 100755
--- 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
From 3c5a959ff4053997a9e4c5ee361a1f3f097f44be Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 6 Mar 2008 03:02:01 -0600
Subject: [PATCH 2/5] Remove obsolete file
---
extra/http/server/auth/auth.factor | 25 -------------------------
1 file changed, 25 deletions(-)
delete mode 100755 extra/http/server/auth/auth.factor
diff --git a/extra/http/server/auth/auth.factor b/extra/http/server/auth/auth.factor
deleted file mode 100755
index a53905bce1..0000000000
--- a/extra/http/server/auth/auth.factor
+++ /dev/null
@@ -1,25 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: http.server.auth
-USING: new-slots accessors http.server.auth.providers.null
-http.server.auth.strategies.null ;
-
-TUPLE: authentication responder provider strategy ;
-
-: <authentication> ( responder -- authentication )
- null-auth-provider null-auth-strategy
- authentication construct-boa ;
-
-SYMBOL: current-user-id
-SYMBOL: auth-provider
-SYMBOL: auth-strategy
-
-M: authentication call-responder ( request path responder -- response )
- dup provider>> auth-provider set
- dup strategy>> auth-strategy set
- pick auth-provider get logged-in? dup current-user-id set
- [
- responder>> call-responder
- ] [
- 2drop auth-provider get require-login
- ] if* ;
From 626334303c4d60501ffec5210aaebad7524f7dfb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Thu, 6 Mar 2008 03:03:07 -0600
Subject: [PATCH 3/5] Fix build dir pollution in unit tests
---
extra/db/sqlite/sqlite-tests.factor | 2 +-
extra/db/sqlite/test.db | Bin 2048 -> 0 bytes
extra/db/tuples/tuples-tests.factor | 2 +-
.../server/auth/providers/db/db-tests.factor | 5 +++--
4 files changed, 5 insertions(+), 4 deletions(-)
delete mode 100644 extra/db/sqlite/test.db
diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor
index 08139610a0..b30cb4ba80 100755
--- 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
diff --git a/extra/db/sqlite/test.db b/extra/db/sqlite/test.db
deleted file mode 100644
index e483c47cea528c95f10fcf66fcbb67ffa351ffd1..0000000000000000000000000000000000000000
GIT binary patch
literal 0
HcmV?d00001
literal 2048
zcmWFz^vNtqRY=P(%1ta$FlJz3U}R))P*7lCU|<DeWWWgIfG`XovteRbX<ncxBl9W-
zAQ}auAut*OWQ9NoBfGeyBx56UNn%n?YC&pIaef|zWO5F2bqsM;2yt}saaDkbDQM&+
z=B6r?B^D)TBo=8H8))h%B<Gjrl@wJX3u=P$CM)wg2IddUcbLyG?*%eP!DtAKhQOc<
z0bW*SQAw}-;#A+%ip=DEUKSKCA2YMKq*rEcZl!Z#USdk35EHYgvR7hWs$XikLR4yE
YPGVjPA0xA<v{!yco?~umQD$-?0FFaGg8%>k
diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor
index 3a1e2c4f25..7d72a644bf 100755
--- 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 ;
diff --git a/extra/http/server/auth/providers/db/db-tests.factor b/extra/http/server/auth/providers/db/db-tests.factor
index 384e094f39..c4682c2051 100755
--- a/extra/http/server/auth/providers/db/db-tests.factor
+++ b/extra/http/server/auth/providers/db/db-tests.factor
@@ -1,11 +1,12 @@
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 ;
+namespaces db db.sqlite db.tuples continuations
+io.files ;
db-auth-provider "provider" set
-"auth-test.db" sqlite-db [
+"auth-test.db" temp-file sqlite-db [
[ user drop-table ] ignore-errors
[ user create-table ] ignore-errors
From f2463f34aed3a30839b60c1e24982bf9a19ec9ba Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 6 Mar 2008 11:28:49 -0600
Subject: [PATCH 4/5] hashtables: simplify (key@)
---
core/hashtables/hashtables.factor | 21 +++++++++++----------
1 file changed, 11 insertions(+), 10 deletions(-)
diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor
index 359bedd041..7d8c6f0b5f 100755
--- 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
From bff5d2af6d4aab07668a84801ec6b6b6fcd2a7b1 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Thu, 6 Mar 2008 11:37:44 -0600
Subject: [PATCH 5/5] builder: fix stack effect
---
extra/builder/builder.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor
index 92cd5f5241..41096e863c 100644
--- 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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!