basis/furnace/auth/login/login.factor

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