HTTP authorization framework, first cut
Slava Pestov
parent
b3fcd179a0
commit
955387f5b7
|
|
@ -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* ;
|
||||||
|
|
@ -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 ;
|
||||||
|
|
@ -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> ;
|
||||||
|
|
@ -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>
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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 ;
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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 ;
|
||||||
|
|
@ -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 ;
|
||||||
|
|
@ -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 ;
|
||||||
|
|
@ -4,6 +4,12 @@ kernel accessors ;
|
||||||
|
|
||||||
: with-session \ session swap with-variable ; inline
|
: with-session \ session swap with-variable ; inline
|
||||||
|
|
||||||
|
TUPLE: foo ;
|
||||||
|
|
||||||
|
C: <foo> foo
|
||||||
|
|
||||||
|
M: foo init-session drop 0 "x" sset ;
|
||||||
|
|
||||||
"1234" f <session> [
|
"1234" f <session> [
|
||||||
[ ] [ 3 "x" sset ] unit-test
|
[ ] [ 3 "x" sset ] unit-test
|
||||||
|
|
||||||
|
|
@ -18,8 +24,7 @@ kernel accessors ;
|
||||||
[ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test
|
[ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
f <url-sessions>
|
<foo> <url-sessions>
|
||||||
[ 0 "x" sset ] >>init
|
|
||||||
"manager" set
|
"manager" set
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -11,6 +11,8 @@ IN: http.server.sessions
|
||||||
|
|
||||||
GENERIC: init-session ( responder -- )
|
GENERIC: init-session ( responder -- )
|
||||||
|
|
||||||
|
M: dispatcher init-session drop ;
|
||||||
|
|
||||||
TUPLE: session-manager responder sessions ;
|
TUPLE: session-manager responder sessions ;
|
||||||
|
|
||||||
: <session-manager> ( responder class -- responder' )
|
: <session-manager> ( responder class -- responder' )
|
||||||
|
|
|
||||||
|
|
@ -9,7 +9,7 @@ assocs ;
|
||||||
|
|
||||||
IN: http.server.templating.fhtml
|
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
|
! See apps/http-server/test/ or libs/furnace/ for template usage
|
||||||
! examples
|
! examples
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue