basis/furnace/auth/login/login.factor

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