/pliant/fullpliant/login.pli
 
 1  module "/pliant/language/unsafe.pli" 
 2  module "/pliant/language/stream.pli" 
 3  module "/pliant/fullpliant/user.pli" 
 4   
 5  module "/pliant/language/context.pli" 
 6  module "/pliant/fullpliant/this_computer.pli" 
 7  module "/pliant/util/remote/client.pli" 
 8  module "/pliant/admin/md5.pli" 
 9   
 10  type LoginSlice 
 11    field DateTime from to 
 12    field Str ip comment 
 13   
 14  gvar (Dictionary Str LoginSlice) slice 
 15  gvar Sem slice_sem 
 16  gvar DateTime purged_on := datetime 
 17   
 18   
 19  function write_down u 
 20    arg_rw Data:User2 u 
 21    (var Stream s) open "data:/pliant/login/"+keyof:append+mkdir+safe 
 22    writeline (string u:from)+" "+(string u:to)+" "+u:ip+" "+u:comment 
 23    close 
 24   
 25  function login_record user ip comment -> accepted 
 26    arg Str user ip comment ; arg CBool accepted 
 27    accepted := true 
 28    plugin login 
 29    var DateTime now := datetime 
 30    # first try with read only lock, even if we might update the data 
 31    slice_sem rd_request 
 32    var Pointer:LoginSlice :> slice first user 
 33    if exists:and s:ip=ip and s:comment=comment 
 34      if now:seconds-s:to:seconds<60 
 35        # less than one minute, do nothing 
 36        slice_sem rd_release 
 37        return 
 38      if now:seconds-s:to:seconds<3600 and s:to:date=now:date 
 39        # more than one minute, just update the 'to' field 
 40        to := now 
 41        var Data:User2 :> user_database2:data:user user 
 42        to := now 
 43        slice_sem rd_release 
 44        return 
 45    slice_sem rd_release 
 46    # start a new slice 
 47    var Data:User2 :> user_database2:data:user user 
 48    if not exists:u 
 49      user_database2:data:user create user 
 50      :> user_database2:data:user user 
 51    slice_sem request 
 52    var Pointer:LoginSlice :> slice first user 
 53    if exists:s 
 54      if s:ip=ip and s:comment=comment and now:seconds-s:to:seconds<60 
 55        # another thread got in between semaphore rd_release and request 
 56        slice_sem release 
 57        return   
 58      write_down u 
 59    else   
 60      slice insert user (var LoginSlice empty_slice) 
 61      :> slice first user 
 62    from := now 
 63    to := now 
 64    ip := ip 
 65    comment := comment 
 66    from := now 
 67    to := now 
 68    ip := ip 
 69    comment := comment 
 70    if now:seconds-purged_on:seconds>3600 
 71      var Pointer:LoginSlice :> slice first 
 72      while exists:s 
 73        if now:seconds-s:to:seconds<3600 
 74          :> slice next s 
 75        else 
 76          write_down (user_database2:data:user (slice key s)) 
 77          var Data:User2 :> user_database2:data:user (slice key s) 
 78          from := undefined 
 79          :> slice remove s 
 80      purged_on := datetime 
 81    slice_sem release 
 82   
 83   
 84  function startup 
 85    each user_database2:data:user 
 86      if u:from=defined 
 87        write_down u 
 88        from := undefined 
 89  startup 
 90   
 91   
 92  function is_administrator user -> admin 
 93    arg Str user ; arg CBool admin 
 94    var Data:User :> user_database:data:user user 
 95    each u:right 
 96      if r:right="administrator" 
 97        return true 
 98    each u:template 
 99      each user_database:data:user:t:right 
 100        if r:right="administrator" 
 101          return true 
 102    admin := false 
 103   
 104  function is_password_server host -> pp 
 105    arg Str host ; arg CBool pp 
 106    each server this_computer:env:"pliant":"password" 
 107      if (keyof:server parse "server" any) 
 108        if server=host 
 109          return true 
 110    pp := false 
 111   
 112  function user_update user first_name name email abstract password_md5 public_key language options style_options server -> status 
 113    arg Str user first_name name email abstract password_md5 public_key language options style_options server ; arg Status status 
 114    remote server 
 115      control c is_password_server:c 
 116      control c not is_administrator:user 
 117      share status 
 118      user_database:data:user create user 
 119      user_database2:data:user create user 
 120      user_secret_database:data:user create user 
 121      var Data:User :> user_database:data:user user 
 122      first_name := first_name 
 123      name := name 
 124      email := email 
 125      abstract := abstract 
 126      user_secret_database:data:user:user password_md5 := password_md5 
 127      public_key := public_key 
 128      language := language 
 129      options := options 
 130      style_options := style_options 
 131    local_streaming s 
 132      each user_database:data:user:user:right 
 133        writeline "right "+(string keyof:r)+" "+(string r:auth)+" "+(string r:ip)+" "+(string r:server)+" "+(string r:right) 
 134      each user_database:data:user:user:template 
 135        writeline "template "+(string keyof:t)+" "+string:t 
 136    remote_streaming s 
 137      var Data:User :> user_database:data:user user 
 138      var (Dictionary Str Void) lines templates 
 139      while not s:atend 
 140        var Str := readline 
 141        if (parse "right" (var Str id) (var Str auth) (var Str ip) (var Str server) (var Str right)) 
 142          if right<>"administrator" 
 143            u:right create id 
 144            var Data:UserRight :> u:right id 
 145            auth := auth+"3" 0 ; ip := ip ; server := server ; right := right 
 146          lines insert id void 
 147        eif (parse "template" (var Str id) (var Str template)) 
 148          if not is_administrator:template 
 149            u:template create id 
 150            u:template id := template 
 151          templates insert id void 
 152      each u:right 
 153        if not exists:(lines first keyof:r) 
 154          u:right delete keyof:r 
 155      each u:template 
 156        if not exists:(templates first keyof:t) 
 157          u:template delete keyof:t 
 158    success 
 159      status := success 
 160    failure 
 161      status := failure 
 162   
 163  function user_change_password user password_md5 server -> status 
 164    arg Str user password_md5 server ; arg Status status 
 165    remote server 
 166      control c is_password_server:c 
 167      control c not is_administrator:user 
 168      share status 
 169      user_secret_database:data:user:user password_md5 := password_md5 
 170    success 
 171      status := success 
 172    failure 
 173      status := failure 
 174   
 175  function user_delete user server -> status 
 176    arg Str user server ; arg Status status 
 177    remote server 
 178      control c is_password_server:c 
 179      control c not is_administrator:user 
 180      share status 
 181      user_database:data:user delete user 
 182      user_database2:data:user delete user 
 183      user_secret_database:data:user delete user 
 184    success 
 185      status := success 
 186    failure 
 187      status := failure 
 188   
 189   
 190  function user_update user -> status 
 191    arg Str user ; arg ExtendedStatus status 
 192    status := success 
 193    each this_computer:env:"pliant":"password" 
 194      if (keyof:parse "client" any) and c<>computer_fullname 
 195        var Data:User :> user_database:data:user user 
 196        if (user_update user u:first_name u:name u:email u:abstract user_secret_database:data:user:user:password_md5 u:public_key u:language u:options u:style_options c)=failure 
 197          status := failure "Failed to forward changes to server "+c 
 198   
 199   
 200  export login_record 
 201  export user_update user_change_password user_delete