Patch title: Release 95 bulk changes
Abstract:
File: /pliant/protocol/http/svar.pli
Key:
    Removed line
    Added line
# Code written by Boris Reitman in 2005
# Copyright  Elbokar Consulting Inc.
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License version 2
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# version 2 along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

module "/pliant/language/compiler.pli"
module "/pliant/fullpliant/user.pli"
module "/pliant/protocol/http/server.pli"
submodule "/pliant/appli/database.pli"
module "/pliant/appli/database/prototype.pli"
module "/pliant/language/data/string_cast.pli"
module "cookie.pli"
module "/pliant/util/crypto/intn.pli"
module "/pliant/language/stream.pli"

type DataConstant
  field Arrow value

DataInterface_ maybe DataConstant

method dd type d -> t
  oarg DataConstant dd ; arg Data_ d ; arg_R Type t
  t :> entry_type dd:value

method dc get d adr type -> status
  oarg DataConstant dc ; arg Data_ d ; arg Address adr ; arg Type type ; arg Status status
  var Pointer:Type t :> entry_type dc:value
  if type=t
    type copy_instance dc:value adr
    status := success
  else
    var Str s := to_string dc:value t "db"
    status := from_string adr type s "db"

type UserVariable
  field Str module
  field Str variable
  field Link:Type type
  field Link:DataConstant default

(gvar Database:UserDatabase2 session_database) load "security:/session.pdb" mount "/pliant2/session"

function is_too_old age -> bool
  arg DateTime age ; arg Bool bool
  bool := age:seconds < datetime:seconds - 24*3600

function delete_session uname 
  arg Str uname
  session_database:data:user delete uname

function create_session uname -> session
  arg Str uname ; arg Data:(Set Set:Anything) session
  session_database:data:user create uname
  session_database:data:user:uname:to := datetime
  session :> session_database:data:user:uname:session

function gen_new_session_id -> new_id
  arg Str new_id
  constant MAX_SESSIONS 10000
  var Int rand_int := random (MAX_SESSIONS-1)
  var Int count := 0
  new_id := "guest" + string:rand_int
  while (exists session_database:data:user:new_id)
    if count = MAX_SESSIONS 
      return ""
    if is_too_old:(session_database:data:user:new_id:to)
      delete_session new_id
    else
      count := count + 1
      rand_int := (rand_int + 1) % MAX_SESSIONS
      new_id := "guest" + string:rand_int

function rfc1123_date dt -> s
  arg DateTime dt ; arg Str s
  var Int year month day hour minute second ; var Float fraction
  dt split year month day hour minute second fraction 
  var Str dow := day_name dt:day_of_week
  s := upper:(dow 0 1)+(dow 1 (dow len))
  s += ", "+(right string:day 2 "0")
  s += "-"+("Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec" (month-1)*4 3)
  s += "-"+string:year
  s += " "+(right string:hour 2 "0")
  s += ":"+(right string:minute 2 "0")
  s += ":"+(right string:second 2 "0")
  s += " GMT"      
      
method page issue_session -> session
  arg_rw HtmlPage page 
  arg Data:(Set Set:Anything) session
  var Str uname := gen_new_session_id
  session :> create_session uname
  var DateTime dt := datetime + (time 23 59 59 01)
  page set_cookie "SID" uname "/" (rfc1123_date dt)

method p get_new_cookie cookie_name -> cookie_value
  arg_r HtmlPage p ; arg Str cookie_name cookie_value 
  var Pointer:Stream stream :> p:http_request stream
  var Address start := stream stream_write_buf
  var Address cur := stream stream_write_cur
  var Address stop := stream stream_write_stop
  var Str find_str := "[lf]Set-Cookie: " + cookie_name + "=" 
  var Str buffer := "               "
  var Int len := find_str:len + buffer:len 
  var Address a := memory_search start (cast cur Int).-.(cast start Int) find_str:characters find_str:len
  if a<>null
    memory_copy (a translate Byte find_str:len) buffer:characters buffer:len
    buffer parse any:cookie_value ";"
  else 
    cookie_value := ""
    
method page get_cookie -> getting_cook 
  arg HtmlPage page ; arg Str getting_cook
  implicit page
    var Pointer:Arrow a :> http_request:query_log first
    var Str string := "Cookie: SID="
    getting_cook := ""
    while a<>null 
      if ((a map Str) 0 7) = "Cookie:" 
        getting_cook := (a map Str) 
        getting_cook := (getting_cook string:len getting_cook:len - string:len)
      a :> http_request:query_log next a
      
method page find_session -> session
  arg_rw HtmlPage page 
  arg Data:(Set Set:Anything) session
  var Str uname := page:get_cookie
  if uname=""
    uname := page get_new_cookie "SID"
  if uname=""
    session :> page issue_session 
  else
    session :> session_database:data:user:uname:session
    if not (exists session)
      session :> page issue_session
    if is_too_old:(session_database:data:user:uname:to)
      delete_session uname
      session :> page issue_session

function svar_map page uv d
  arg_rw HtmlPage page ; arg UserVariable uv ; arg_rw Data_ d
  var Data:(Set Set:Anything) session :> page:find_session
  var (Pointer Data:Anything) data :>> addressof:d map Data:Anything
  data :> (session uv:module) uv:variable
  if d:adr=null # FIXME: should be: not exists:data
    session create uv:module
    (session uv:module) create uv:variable
    data :> (session uv:module) uv:variable
    if (exists uv:default)
      d:base:sem request
      d:interface set d uv:default:value (entry_type uv:default:value)
      d:base:sem release

function active_type uv access e
  arg UserVariable uv ; arg Int access ; arg_rw Expression e
  if e:size<>1 or not (e:0 cast HtmlPage)
    return
  e suckup e:0
  var Link:Argument a :> argument local (Data uv:type)
  e add (instruction (the_function svar_map HtmlPage UserVariable Data_) e:0:result (argument mapped_constant UserVariable uv) a)
  e set_result a access_read+access_write

meta svar e
  if e:size<2 or (e:0 constant Type)=null
    return
  var Pointer:Type t :> (e:0 constant Type) map Type
  var Link:DataConstant default :> null map DataConstant
  var Int stop := e:size
  if e:size>=4 and e:(e:size-2):ident="<-" and (e:(e:size-1) constant t)<>null
    default :> new DataConstant
    default value := e:(e:size-1) constant t
    stop -= 2
  for (var Int i) 1 stop-1
    if not e:i:is_pure_ident
      return
  for (var Int i) 1 stop-1
    var Link:UserVariable uv :> new UserVariable
    uv module := e:external_module:name
    uv variable := e:i ident
    uv type :> t
    uv default :> default
    e define ". "+e:i:ident addressof:uv e:module:actual
  e set_void_result

export svar