extra/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.flash\r
   9 furnace.asides\r
  10 furnace.actions\r
  11 furnace.sessions\r
  12 furnace.utilities\r
  13 furnace.redirection\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             flashed-variables restore-flash\r
  74             description get "description" set-value\r
  75             capabilities get words>strings "capabilities" set-value\r
  76         ] >>init\r
  77 \r
  78         { login-realm "login" } >>template\r
  79 \r
  80         [\r
  81             {\r
  82                 { "username" [ v-required ] }\r
  83                 { "password" [ v-required ] }\r
  84             } validate-params\r
  85 \r
  86             "password" value\r
  87             "username" value check-login\r
  88             [ successful-login ] [ login-failed ] if*\r
  89         ] >>submit\r
  90     <auth-boilerplate>\r
  91     <secure-realm-only> ;\r
  92 \r
  93 : <logout-action> ( -- action )\r
  94     <action>\r
  95         [ logout ] >>submit\r
  96     <protected>\r
  97         "logout" >>description ;\r
  98 \r
  99 M: login-realm login-required*\r
 100     drop\r
 101     begin-aside\r
 102     protected get description>> description set\r
 103     protected get capabilities>> capabilities set\r
 104     URL" $realm/login" >secure-url flashed-variables <flash-redirect> ;\r
 105 \r
 106 : <login-realm> ( responder name -- auth )\r
 107     login-realm new-realm\r
 108         <login-action> "login" add-responder\r
 109         <logout-action> "logout" add-responder\r
 110         20 minutes >>timeout ;\r