From 955387f5b7e59292ac36166b7a4a15795b9d4515 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 6 Mar 2008 03:00:10 -0600 Subject: [PATCH] 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 ; + +: ( 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 + +: 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" + "Basic realm=\"" rot "\"" 3append + "WWW-Authenticate" set-header + [ + + "Username or Password is invalid" write + + ] >>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" [ + "extra/http/server/auth/login/login.fhtml" + resource-path run-template-file + ] >>body ; + +: + + [ login-page ] >>get + + { + { "name" [ ] } + { "password" [ ] } + } >>post-params + [ + "password" get + "name" get + provider sget check-login [ + t logged-in? sset + post-login-url sget + ] [ + login-page + ] if + ] >>post ; + +: + + [ + f logged-in? sset + request get "login" + ] >>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 + ] [ + 3drop <400> + ] if + ] if ; + +: ( responder provider -- auth ) + (login-auth) + + swap >>default + "login" add-responder + "logout" add-responder + ; 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 @@ + + +

Login required

+ +
+ + + + + + + + + + + + +
User name:
Password:
+ + + +
+ + + 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 ; + + "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 ; + +: ( -- 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 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 + + swap >>name + swap >>password + select-tuple >boolean ; + +M: db-auth-provider new-user + drop + [ + + swap >>name + + dup select-tuple [ name>> user-exists ] when + + "unassigned" >>password + + insert-tuple + ] with-transaction ; + +M: db-auth-provider set-password + drop + [ + + 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 + +M: foo init-session drop 0 "x" sset ; + "1234" f [ [ ] [ 3 "x" sset ] unit-test @@ -18,8 +24,7 @@ kernel accessors ; [ t ] [ f cookie-sessions? ] unit-test [ ] [ - f - [ 0 "x" sset ] >>init + "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 ; : ( 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