basis/furnace/auth/auth.factor

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