steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

HTTP authorization framework, first cut

db4
Slava Pestov 2008-03-06 03:00:10 -06:00
parent b3fcd179a0
commit 955387f5b7
13 changed files with 320 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
extra/http/server/auth/auth.factor Executable file
View File

@ -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* ;

41
extra/http/server/auth/basic/basic.factor Executable file
View File

@ -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 ;

69
extra/http/server/auth/login/login.factor Executable file
View File

@ -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> ;

25
extra/http/server/auth/login/login.fhtml Executable file
View File

@ -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>

18
extra/http/server/auth/providers/assoc/assoc-tests.factor Executable file
View File

@ -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

23
extra/http/server/auth/providers/assoc/assoc.factor Executable file
View File

@ -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 ;

24
extra/http/server/auth/providers/db/db-tests.factor Executable file
View File

@ -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

53
extra/http/server/auth/providers/db/db.factor Executable file
View File

@ -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 ;

14
extra/http/server/auth/providers/null/null.factor Executable file
View File

@ -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 ;

18
extra/http/server/auth/providers/providers.factor Executable file
View File

@ -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 ;

9
extra/http/server/sessions/sessions-tests.factor
View File

@ -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

2
extra/http/server/sessions/sessions.factor
View File

@ -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' )

2
extra/http/server/templating/fhtml/fhtml.factor
View File

@ -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