basis/furnace/auth/auth.factor

   1 ! Copyright (c) 2008, 2010 Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs checksums checksums.sha combinators
   4 destructors endian furnace.actions furnace.auth.providers
   5 furnace.auth.providers.db furnace.boilerplate
   6 furnace.redirection furnace.utilities html.forms http.server
   7 http.server.dispatchers http.server.filters io.encodings.string
   8 io.encodings.utf8 io.sockets.secure kernel logging namespaces
   9 random sequences sets urls ;
  10 IN: furnace.auth
  11
  12 SYMBOL: logged-in-user
  13
  14 : logged-in? ( -- ? )
  15     logged-in-user get >boolean ;
  16
  17 : username ( -- string/f )
  18     logged-in-user get dup [ username>> ] when ;
  19
  20 GENERIC: init-user-profile ( responder -- )
  21
  22 M: object init-user-profile drop ;
  23
  24 M: dispatcher init-user-profile
  25     default>> init-user-profile ;
  26
  27 M: filter-responder init-user-profile
  28     responder>> init-user-profile ;
  29
  30 : current-profile ( -- assoc ) logged-in-user get profile>> ;
  31
  32 : user-changed ( -- )
  33     logged-in-user get t >>changed? drop ;
  34
  35 : uget ( key -- value )
  36     current-profile at ;
  37
  38 : uset ( value key -- )
  39     current-profile set-at
  40     user-changed ;
  41
  42 : uchange ( quot key -- )
  43     current-profile swap change-at
  44     user-changed ; inline
  45
  46 SYMBOL: capabilities
  47
  48 V{ } clone capabilities set-global
  49
  50 : define-capability ( word -- ) capabilities get adjoin ;
  51
  52 TUPLE: realm < dispatcher name users checksum secure ;
  53
  54 GENERIC: login-required* ( description capabilities realm -- response )
  55
  56 GENERIC: user-registered ( user realm -- response )
  57
  58 M: object user-registered 2drop URL" $realm" <redirect> ;
  59
  60 GENERIC: init-realm ( realm -- )
  61
  62 GENERIC: logged-in-username ( realm -- username )
  63
  64 : login-required ( description capabilities -- * )
  65     realm get login-required* exit-with ;
  66
  67 : new-realm ( responder name class -- realm )
  68     new-dispatcher
  69         swap >>name
  70         swap >>default
  71         users-in-db >>users
  72         sha-256 >>checksum
  73         ssl-supported? >>secure ; inline
  74
  75 : users ( -- provider )
  76     realm get users>> ;
  77
  78 TUPLE: user-saver user ;
  79
  80 C: <user-saver> user-saver
  81
  82 M: user-saver dispose
  83     user>> dup changed?>> [ users update-user ] [ drop ] if ;
  84
  85 : save-user-after ( user -- )
  86     <user-saver> &dispose drop ;
  87
  88 : init-user ( user -- )
  89     [ [ logged-in-user namespaces:set ] [ save-user-after ] bi ] when* ;
  90
  91 \ init-user DEBUG add-input-logging
  92
  93 M: realm call-responder*
  94     dup realm namespaces:set
  95     logged-in? [
  96         dup init-realm
  97         dup logged-in-username
  98         dup [ users get-user ] when
  99         init-user
 100     ] unless
 101     call-next-method ;
 102
 103 : encode-password ( string salt -- bytes )
 104     [ utf8 encode ] [ 4 >be ] bi* append
 105     realm get checksum>> checksum-bytes ;
 106
 107 : >>encoded-password ( user string -- user )
 108     32 random-bits [ encode-password ] keep
 109     [ >>password ] [ >>salt ] bi* ; inline
 110
 111 : valid-login? ( password user -- ? )
 112     [ salt>> encode-password ] [ password>> ] bi = ;
 113
 114 : check-login ( password username -- user/f )
 115     users get-user dup [ [ valid-login? ] keep and ] [ 2drop f ] if ;
 116
 117 : if-secure-realm ( quot -- )
 118     realm get secure>> [ if-secure ] [ call ] if ; inline
 119
 120 TUPLE: secure-realm-only < filter-responder ;
 121
 122 C: <secure-realm-only> secure-realm-only
 123
 124 M: secure-realm-only call-responder*
 125     '[ _ _ call-next-method ] if-secure-realm ;
 126
 127 TUPLE: protected < filter-responder description capabilities ;
 128
 129 : <protected> ( responder -- protected )
 130     protected new
 131         swap >>responder ;
 132
 133 : have-capabilities? ( capabilities -- ? )
 134     realm get secure>> secure-connection? not and [ drop f ] [
 135         logged-in-user get {
 136             { [ dup not ] [ 2drop f ] }
 137             { [ dup deleted>> 1 = ] [ 2drop f ] }
 138             [ capabilities>> subset? ]
 139         } cond
 140     ] if ;
 141
 142 M: protected call-responder*
 143     dup protected namespaces:set
 144     dup capabilities>> have-capabilities?
 145     [ call-next-method ] [
 146         [ drop ] [ [ description>> ] [ capabilities>> ] bi ] bi*
 147         realm get login-required*
 148     ] if ;
 149
 150 : <auth-boilerplate> ( responder -- responder' )
 151     <boilerplate> { realm "boilerplate" } >>template ;
 152
 153 : password-mismatch ( -- * )
 154     "passwords do not match" validation-error
 155     validation-failed ;
 156
 157 : same-password-twice ( -- )
 158     "new-password" value "verify-password" value =
 159     [ password-mismatch ] unless ;
 160
 161 : user-exists ( -- * )
 162     "username taken" validation-error
 163     validation-failed ;