basis/furnace/auth/login/login.factor

   1 ! Copyright (c) 2008 Slava Pestov\r
   2 ! See http://factorcode.org/license.txt for BSD license.\r
   3 USING: kernel accessors namespaces sequences math.parser\r
   4 calendar checksums validators urls logging html.forms\r
   5 http http.server http.server.dispatchers\r
   6 furnace.auth\r
   7 furnace.asides\r
   8 furnace.actions\r
   9 furnace.sessions\r
  10 furnace.utilities\r
  11 furnace.redirection\r
  12 furnace.conversations\r
  13 furnace.auth.login.permits ;\r
  14 IN: furnace.auth.login\r
  15 \r
  16 SYMBOL: permit-id\r
  17 \r
  18 : permit-id-key ( realm -- string )\r
  19     hex-string "__p_" prepend ;\r
  20 \r
  21 : client-permit-id ( realm -- id/f )\r
  22     permit-id-key client-state dup [ string>number ] when ;\r
  23 \r
  24 TUPLE: login-realm < realm timeout domain ;\r
  25 \r
  26 M: login-realm init-realm\r
  27     name>> client-permit-id permit-id set ;\r
  28 \r
  29 M: login-realm logged-in-username\r
  30     drop permit-id get dup [ get-permit-uid ] when ;\r
  31 \r
  32 M: login-realm modify-form ( responder -- xml/f )\r
  33     drop permit-id get realm get name>> permit-id-key hidden-form-field ;\r
  34 \r
  35 : <permit-cookie> ( -- cookie )\r
  36     permit-id get realm get name>> permit-id-key <cookie>\r
  37         "$login-realm" resolve-base-path >>path\r
  38         realm get\r
  39         [ domain>> >>domain ]\r
  40         [ secure>> >>secure ]\r
  41         bi ;\r
  42 \r
  43 : put-permit-cookie ( response -- response' )\r
  44     <permit-cookie> put-cookie ;\r
  45 \r
  46 \ put-permit-cookie DEBUG add-input-logging\r
  47 \r
  48 : successful-login ( user -- response )\r
  49     [ username>> make-permit permit-id set ] [ init-user ] bi\r
  50     URL" $realm" end-aside\r
  51     put-permit-cookie ;\r
  52 \r
  53 \ successful-login DEBUG add-input-logging\r
  54 \r
  55 : logout ( -- response )\r
  56     permit-id get [ delete-permit ] when*\r
  57     URL" $realm" end-aside ;\r
  58 \r
  59 <PRIVATE\r
  60 \r
  61 SYMBOL: description\r
  62 SYMBOL: capabilities\r
  63 \r
  64 PRIVATE>\r
  65 \r
  66 CONSTANT: flashed-variables { description capabilities }\r
  67 \r
  68 : login-failed ( -- * )\r
  69     "invalid username or password" validation-error\r
  70     validation-failed ;\r
  71 \r
  72 : <login-action> ( -- action )\r
  73     <page-action>\r
  74         [\r
  75             description cget "description" set-value\r
  76             capabilities cget words>strings "capabilities" set-value\r
  77         ] >>init\r
  78 \r
  79         { login-realm "login" } >>template\r
  80 \r
  81         [\r
  82             {\r
  83                 { "username" [ v-required ] }\r
  84                 { "password" [ v-required ] }\r
  85             } validate-params\r
  86 \r
  87             "password" value\r
  88             "username" value check-login\r
  89             [ successful-login ] [ login-failed ] if*\r
  90         ] >>submit\r
  91     <auth-boilerplate>\r
  92     <secure-realm-only> ;\r
  93 \r
  94 : <logout-action> ( -- action )\r
  95     <action>\r
  96         [ logout ] >>submit ;\r
  97 \r
  98 M: login-realm login-required* ( description capabilities login -- response )\r
  99     begin-conversation\r
 100     [ description cset ] [ capabilities cset ] [ secure>> ] tri*\r
 101     [\r
 102         url get >secure-url begin-aside\r
 103         URL" $realm/login" >secure-url <continue-conversation>\r
 104     ] [\r
 105         url get begin-aside\r
 106         URL" $realm/login" <continue-conversation>\r
 107     ] if ;\r
 108 \r
 109 M: login-realm user-registered ( user realm -- response )\r
 110     drop successful-login ;\r
 111 \r
 112 : <login-realm> ( responder name -- realm )\r
 113     login-realm new-realm\r
 114         <login-action> "login" add-responder\r
 115         <logout-action> "logout" add-responder\r
 116         20 minutes >>timeout ;\r