/*******************************************************************************
 Module Pager3
 Server part
 Version: 1.0
 Authors: Bob Le Gob
 Code based on Pager2 v3.0 - Authors: Laurent PLUMAT, Marc BARILLEY, Christophe LOREK
 Last update: 02/02/2003
 Pager Module
*******************************************************************************/

typeof BitmapList = [[S r1] r1];;       /* Liste des images que les clients von telecharger */

struct Clients =
[
  client : CLIENT,                   /*CLIENT*/
  login : S,                         /*Login de l'utilisateur*/
  online : I                         /*Statut du client Online/Offline*/
]mkClients;;

typeof allClients = [Clients r1];;

defcom  CaddUser = addUser S;;            /*add a login to client list [new login]*/
defcom  CdelUser = delUser S;;            /*del a login from client list [login to delete] */
defcom  CchangeLogin = changeLogin S S;;  /*an user change of login [old login, new login]*/
defcom  Cpage = page S S;;                /*a client page an otehr client [message's sender, message]*/
defcom  CSendMessage = SendMessage S;;    /*envoi d'un message [login]*/

/********************************************************************************
  recherche d'un lcient par le parametre CLIENT
    x -> Clients
    cli -> CLIENT
*********************************************************************************/
fun cbClientByClient (x, cli)=
  x.client == cli
;;

/********************************************************************************
  recherche d'un lcient par le parametre login
    x -> Clients
    login2 -> S
*********************************************************************************/
fun cbloginBylogin (x, login2)=
  !strcmp x.login login2
;;

/*********************************************************************************
  fonction envoyant la liste des utilisateurs aux utilisateurs
    sclient -> Clients    : le client à evnvoyer
    param -> [CLIENT S]   : Le client à qui on envoie la liste et son login
**********************************************************************************/
fun cbSendUsersList (sclient, param)=
  let param -> [cli login2] in
  (
    _DMSsend this cli CaddUser [sclient.login];
    _DMSsend this sclient.client CaddUser [login2]
  )
;;

/*********************************************************************************
  fonction pour pager un client
    login -> S      : Login du client à pager
    text -> S       : Texte à envoyer
**********************************************************************************/
fun __page (login2, text)=
  let substr text 0 1100 -> ntext in
  let search_in_list allClients @cbClientByClient DMSsender -> f1 in
  let search_in_list allClients @cbloginBylogin login2 -> f2 in
  if (f1 == nil) || (f2 == nil) then
    nil
  else
    _DMSsend this f2.client Cpage [f1.login ntext]
;;


/*********************************************************************************
  fonction envoyant le login de l'utilisateur deconnecté au autre utilisateur
    sclient -> Clients    : le client à qui evnvoyer
    login -> S            : Le client qui vien de ce deconnecter
**********************************************************************************/
fun cbSendDelClient (sclient, login2)=
  _DMSsend this sclient.client CdelUser [login2]
;;

/*******************************************************************************
 the client part of the module has been deleted
 cli -> CLIENT : the client
     <- I      : nothing special (always 0)
*******************************************************************************/
fun cbDeleteClient(cli) =
  let search_in_list allClients @cbClientByClient cli -> f in
    if f == nil then
      nil
    else
    (
      set allClients = remove_from_list allClients f;
      apply_on_list allClients @cbSendDelClient (_DMSgetLogin cli)
    );
  _DMSevent this cli "out" nil nil
;;


/*******************************************************************************
fonction envoyant le nouveau login aux clients
  nclient -> Clients    : client a qui on envoie
  param -> [S S]        : nouveau et ancien login
********************************************************************************/

fun cbSendNewLogin (sclient, param)=
  let param -> [ologin nlogin] in
    _DMSsend this sclient.client CchangeLogin[ologin nlogin]
;;

/*******************************************************************************
 the client has change his login
 from   -> DMI       : not used
 user   -> User      : the user that run the action
 action -> S         : not used
 param  -> S         : not used
 others -> [User r1] : not used
 tag    -> Tag       : not used
        <- I         : nothing special
*******************************************************************************/
fun cbchangeLogin (from, user, action, param, others, tag) =
  let search_in_list allClients @cbClientByClient UtoC user -> f in
  (
    apply_on_list allClients @cbSendNewLogin [param (_DMSgetLogin UtoC user)];
    set f.login = (_DMSgetLogin UtoC user); 
  ); 
  0
;;

/*******************************************************************************
 create a client
 from   -> DMI       : not used
 user   -> User      : the user that run the action
 action -> S         : not used
 param  -> S         : parameters of the action
 others -> [User r1] : not used
 tag    -> Tag       : not used
        <- I         : nothing special
*******************************************************************************/
fun cbStart (from, user, action, param, others, tag) =
  if _DMScreateClientDMI this UtoC user (strbuild BitmapList) then
  (
    let UtoC user -> cli in
    let search_in_list allClients @cbClientByClient cli -> f in
      if f != nil then
        nil
      else
      (
        apply_on_list allClients @cbSendUsersList [(UtoC user) (_DMSgetLogin cli)];
        set allClients = (mkClients [cli (_DMSgetLogin cli) 1])::allClients; 
        0
      );
    _DMSeventTag this user "entering" nil nil nil
  )
  else
    nil
;;

/*******************************************************************************
 destruction d'un client
 from   -> DMI       : not used
 user   -> User      : the user that run the action
 action -> S         : not used
 param  -> S         : parameters of the action
 others -> [User r1] : not used
 tag    -> Tag       : not used
        <- I         : nothing special
*******************************************************************************/
fun cbDestroy (from, user, action, param, others, tag) =
  let UtoC user -> cli in
  (
    _DMSdelClientDMI this cli;
    _DMSevent this cli "out" nil nil
  )
;;

/*******************************************************************************
 envoie d'un message ver un client
 from   -> DMI       : not used
 user   -> User      : the user that run the action
 action -> S         : not used
 param  -> S         : parameters of the action
 others -> [User r1] : not used
 tag    -> Tag       : not used
        <- I         : nothing special
*******************************************************************************/
fun cbPage (from, user, action, param, others, tag) =
  let UtoC user -> cli in
    _DMSsend this cli CSendMessage [_DMSgetLogin _DMSbyId atoi param] 
;;

/*******************************************************************************
 main function, called when the server part of the module is initialized
 file -> S : not used
      <- I : nothing special
*******************************************************************************/
fun IniDMI (file) =
  _DMSdefineActions this  (["start"        @cbStart      ])::                          
                          (["!changeLogin" @cbchangeLogin])::
                          (["page"         @cbPage       ])::
                          (["destroy"      @cbDestroy    ])::
                          nil;
                         
  _DMSregister this nil @cbDeleteClient nil;
  
  let _DMSgetDef this "dmi" -> dataDef in
    set BitmapList =  ("NoMsgBMP"::(getInfo dataDef "NoMsgBMP")::nil)::
                      ("IncomingMsgBMP"::(getInfo dataDef "IncomingMsgBMP")::nil)::
                      ("IncomingMsgGoneBMP"::(getInfo dataDef "IncomingMsgGoneBMP")::nil)::
                      ("BlinkUpBMP"::(getInfo dataDef "BlinkUpBMP")::nil)::
                      ("BlinkDownBMP"::(getInfo dataDef "BlinkDownBMP")::nil)::
                      ("KeepHistory"::(getInfo dataDef "KeepHistory")::nil)::
                      nil   
;;