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