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