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 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 call-responder*\r
  29     [ name>> client-permit-id permit-id set ]\r
  30     [ call-next-method ]\r
  31     bi ;\r
  32 \r
  33 M: login-realm logged-in-username\r
  34     drop permit-id get dup [ get-permit-uid ] when ;\r
  35 \r
  36 M: login-realm modify-form ( responder -- )\r
  37     drop permit-id get realm get name>> permit-id-key hidden-form-field ;\r
  38 \r
  39 : <permit-cookie> ( -- cookie )\r
  40     permit-id get realm get name>> permit-id-key <cookie>\r
  41         "$login-realm" resolve-base-path >>path\r
  42         realm get\r
  43         [ domain>> >>domain ]\r
  44         [ secure>> >>secure ]\r
  45         bi ;\r
  46 \r
  47 : put-permit-cookie ( response -- response' )\r
  48     <permit-cookie> put-cookie ;\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 : logout ( -- )\r
  56     permit-id get [ delete-permit ] when*\r
  57     URL" $realm" end-aside ;\r
  58 \r
  59 SYMBOL: description\r
  60 SYMBOL: capabilities\r
  61 \r
  62 : flashed-variables { description capabilities } ;\r
  63 \r
  64 : login-failed ( -- * )\r
  65     "invalid username or password" validation-error\r
  66     validation-failed ;\r
  67 \r
  68 : <login-action> ( -- action )\r
  69     <page-action>\r
  70         [\r
  71             flashed-variables restore-flash\r
  72             description get "description" set-value\r
  73             capabilities get words>strings "capabilities" set-value\r
  74         ] >>init\r
  75 \r
  76         { login-realm "login" } >>template\r
  77 \r
  78         [\r
  79             {\r
  80                 { "username" [ v-required ] }\r
  81                 { "password" [ v-required ] }\r
  82             } validate-params\r
  83 \r
  84             "password" value\r
  85             "username" value check-login\r
  86             [ successful-login ] [ login-failed ] if*\r
  87         ] >>submit\r
  88     <auth-boilerplate>\r
  89     <secure-realm-only> ;\r
  90 \r
  91 : <logout-action> ( -- action )\r
  92     <action>\r
  93         [ logout ] >>submit\r
  94     <protected>\r
  95         "logout" >>description ;\r
  96 \r
  97 M: login-realm login-required*\r
  98     drop\r
  99     begin-aside\r
 100     protected get description>> description set\r
 101     protected get capabilities>> capabilities set\r
 102     URL" $realm/login" >secure-url flashed-variables <flash-redirect> ;\r
 103 \r
 104 : <login-realm> ( responder name -- auth )\r
 105     login-realm new-realm\r
 106         <login-action> "login" add-responder\r
 107         <logout-action> "logout" add-responder\r
 108         20 minutes >>timeout ;\r