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