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