/* Regdb Server - DMS - nov 1998 by Patrice FAVRE */

typeof db=SqlDB;;
typeof NomDB=S;;
typeof LoginDB=S;;
typeof PasswDB=S;;
typeof LTable=S;;
typeof LColName=S;;
typeof LColEmail=S;;
typeof LColPasswd=S;;
typeof LColIP=S;;
typeof LColTime=S;;
typeof LColNum=S;;
typeof LgLColName=S;;
typeof LgLColEmail=S;;
typeof LgLColPasswd=S;;
typeof WTable=S;;
typeof WColName=S;;
typeof WColWord=S;;
typeof LgWColWord=S;;
typeof Wlist=S;;
typeof SavePwd=S;;
typeof Maxlog=I;;
typeof Policy=S;;
typeof CliAdm=[CLIENT r1];;
typeof LstMots=S;;

struct Uti=[Cli:I, Dest:DMI, Rep:S, Nom:S, Email:S, Mots:S, NewPasswd:S] mkUti;;
typeof LstUti=[Uti r1];;

defcom CRetInsertOK=RetInsertOK S;;
defcom CRetUpdateOK=RetUpdateOK S;;
defcom CRetUpdateP3OK=RetUpdateP3OK S I;;
defcom CRetInsertKO=RetInsertKO;;
defcom CRetUpdateKO=RetUpdateKO;;
defcom CRetSetOK=RetSetOK;;
defcom CRetDelOK=RetDelOK;;
defcom CRetDelKO=RetDelKO;;
defcom CRetFetchAdmOK=RetFetchAdmOK S S;;
defcom CRetFetchAdmKO=RetFetchAdmKO;;
defcom CRetFetchUpdOK=RetFetchUpdOK S S;;
defcom CRetFetchUpdP3OK=RetFetchUpdP3OK S S I;;
defcom CRetFetchUpdKO=RetFetchUpdKO;;
defcom CAffAdmin=AffAdmin;;
defcom CHideAdmin=HideAdmin;;
defcom CRetInitUpdate=RetInitUpdate S;;
defcom CRetInitFetchUpd=RetInitFetchUpd S;;

/*-----------------------*/
fun _finsrv()=
  _destroyE nil nil;;

/*-----------------------*/
fun _ConnectDB()=
  set db=SqlCreate _channel NomDB LoginDB PasswDB;
  let if db==nil then "impossible"
      else "effectuée" -> s in
  _fooS strcatn "Connexion à la base <"::NomDB::"> login <"::LoginDB::"> passwd <"::PasswDB::"> "::s::nil;
  if db==nil then _finsrv
  else nil;;

/*-----------------------*/
fun _DisconnectDB()=
  SqlDestroy db;
  _fooS strcatn "Déconnexion de la base <"::NomDB::"> effectuée"::nil;;

/*-----------------------*/
fun ConcMots(lstmots)=
  if lstmots == nil then ""
  else
    strcatn (let strbuild (hd lstmots)::nil -> lig in substr lig 0 (strlen lig)-1)::
            (let ConcMots tl lstmots -> conc in
             if (strlen conc) == 0 then nil
             else " "::conc::nil);;

/*-----------------------*/
fun findListUti(lst,id)=
  if lst==nil then nil
  else
    let lst -> [ uti nxt ] in
    if uti.Cli==id then uti
    else findListUti nxt id;;

/*-----------------------*/
fun removeFromListUti(lst,id)=
  if lst==nil then nil
  else
    let lst -> [ uti nxt ] in
    if uti.Cli==id then nxt
    else uti::(removeFromListUti nxt id);;

/*-----------------------*/
fun _TransMot(mot)=
  strlowercase mot;;

/*-----------------------*/
fun _InitHeure()=
  let ctime time -> heure in
  substr heure 0 (strlen heure)-1;;

/*-----------------------*/
fun _InitAdrIP(cli)=
  _channelIP cli.chnCLI;;

/*-----------------------*/
fun InsertWords(nom,lstmots)=
  if lstmots == nil then 0
  else (
    SqlRequest db strcatn "INSERT INTO "::WTable::"("::WColName::","::WColWord::") VALUES (?,?)"::nil
                  (SQL_CHAR nom)::(SQL_CHAR _TransMot hd lstmots)::nil;
    InsertWords nom tl lstmots
  );;

/*-----------------------*/
fun DeleteWords(nom)=
  SqlRequest db strcatn "DELETE FROM "::WTable::
                        " WHERE "::WTable::"."::WColName::"=?"::nil
                (SQL_CHAR nom)::nil;;

/*-----------------------*/
fun __InitUpdate(nom)=
  let _DMSgetId DMSsender -> idcli in (
  set LstUti=removeFromListUti LstUti idcli;
  set LstUti=(mkUti [idcli nil nil nil nil nil nil])::LstUti;
  _DMSevent this DMSsender EVT_INIT_UPDATE nom ACT_RET_INIT_UPDATE);;

/*-----------------------*/
fun __InitFetchUpd(nom)=
  let _DMSgetId DMSsender -> idcli in (
  set LstUti=removeFromListUti LstUti idcli;
  set LstUti=(mkUti [idcli nil nil nil nil nil nil])::LstUti;
  _DMSevent this DMSsender EVT_INIT_UPDATE nom ACT_RET_INIT_FETCH_UPD);;

/*-----------------------*/
fun __EnregUtil(nom, email, mots, uti_passwd)=
  if (SqlRequest db strcatn "SELECT "::LColName::" FROM "::LTable::" WHERE "::LTable::"."::LColName::"=?"::nil
                    (SQL_CHAR nom)::nil) != nil then
    _DMSsend this DMSsender CRetInsertKO []
  else (
    if !strcmp Policy "P2" then
      SqlRequest db strcatn "INSERT INTO "::LTable::"("::LColName::","::LColEmail::","::LColIP::","::
                                                         LColTime::","::LColPasswd::") VALUES (?,?,?,?,?)"::nil
                    (SQL_CHAR nom)::(SQL_CHAR email)::(SQL_CHAR _InitAdrIP DMSsender)::
                    (SQL_CHAR _InitHeure)::(SQL_CHAR uti_passwd)::nil
    else
    if !strcmp Policy "P3" then
      SqlRequest db strcatn "INSERT INTO "::LTable::"("::LColName::","::LColEmail::","::LColIP::","::
                                                         LColTime::","::LColPasswd::","::LColNum::") VALUES (?,?,?,?,?,?)"::nil
                    (SQL_CHAR nom)::(SQL_CHAR email)::(SQL_CHAR _InitAdrIP DMSsender)::
                    (SQL_CHAR _InitHeure)::(SQL_CHAR uti_passwd)::(SQL_INTEGER itoa Maxlog-1)::nil
    else nil;
    InsertWords nom hd strextr mots;
    _DMSsend this DMSsender CRetInsertOK [SavePwd]
  );;

/*-----------------------*/
fun __ModifUtil(nom, email, mots, uti_passwd, uti_newpasswd)=
  let SqlRequest db strcatn "SELECT "::LColEmail::" FROM "::LTable::
                            " WHERE "::LTable::"."::LColName::"=?"::
                            "   AND "::LTable::"."::LColPasswd::"=?"::nil
                    (SQL_CHAR nom)::(SQL_CHAR uti_passwd)::nil -> tst in
  if tst == nil then
    _DMSsend this DMSsender CRetUpdateKO []
  else (
    SqlRequest db strcatn "UPDATE "::LTable::
                          " SET "::LTable::"."::LColEmail::"=?,"::
                                   LTable::"."::LColIP::"=?,"::LTable::"."::LColTime::"=?,"::
                                   LTable::"."::LColPasswd::"=?"::
                          " WHERE "::LTable::"."::LColName::"=?"::nil
                  (SQL_CHAR if strlen email then email else hd hd tst)::
                  (SQL_CHAR _InitAdrIP DMSsender)::(SQL_CHAR _InitHeure)::
                  (SQL_CHAR if strlen uti_newpasswd then uti_newpasswd else uti_passwd)::
                  (SQL_CHAR nom)::nil;
    if (strlen mots) > 0 then (
      DeleteWords nom;
      InsertWords nom hd strextr mots
    )
    else nil;
    _DMSsend this DMSsender CRetUpdateOK [SavePwd]
  );;

/*-----------------------*/
fun __ModifUtilP3(nom, email, mots, uti_passwd, uti_newpasswd)=
  let findListUti LstUti _DMSgetId DMSsender -> uti in
  if uti != nil then (
    set uti.Nom = nom;
    set uti.Email = email;
    set uti.Mots = mots;
    set uti.NewPasswd = uti_newpasswd;
    _DMSreply this DMSsender uti.Dest uti.Rep strcatn nom::" "::uti_passwd::nil ACT_RET_CHECK_UPDATE
  )
  else nil;;

/*-----------------------*/
fun __FetchUtilUpdP3(nom, uti_passwd)=
  let findListUti LstUti _DMSgetId DMSsender -> uti in
  if uti != nil then (
    set uti.Nom = nom;
    _DMSreply this DMSsender uti.Dest uti.Rep strcatn nom::" "::uti_passwd::nil ACT_RET_CHECK_FETCH_UPD;
  )
  else nil;;

/*-----------------------*/
fun RetCheckUpdate(num)=
  let findListUti LstUti _DMSgetId DMSsender -> uti in
  if uti != nil then
    if num==nil then
      _DMSsend this _DMSbyId uti.Cli CRetUpdateKO []
    else (
      let SqlRequest db strcatn "SELECT "::LColEmail::","::LColPasswd::","::LColNum::
                                " FROM "::LTable::" WHERE "::LTable::"."::LColName::"=?"::nil
                        (SQL_CHAR uti.Nom)::nil -> tst in
      SqlRequest db strcatn "UPDATE "::LTable::
                            " SET "::LTable::"."::LColEmail::"=?,"::
                                     LTable::"."::LColIP::"=?,"::LTable::"."::LColTime::"=?,"::
                                     LTable::"."::LColPasswd::"=?,"::LTable::"."::LColNum::"=?"::
                            " WHERE "::LTable::"."::LColName::"=?"::nil
                    (SQL_CHAR if strlen uti.Email then uti.Email else hd hd tst)::
                    (SQL_CHAR _InitAdrIP _DMSbyId uti.Cli)::(SQL_CHAR _InitHeure)::
                    (SQL_CHAR if strlen uti.NewPasswd then uti.NewPasswd else nth_list hd tst 1)::
                    (SQL_INTEGER if strlen uti.NewPasswd then itoa Maxlog-1 else nth_list hd tst 2)::
                    (SQL_CHAR uti.Nom)::nil;
      if (strlen uti.Mots) > 0 then (
        DeleteWords uti.Nom;
        InsertWords uti.Nom hd strextr uti.Mots
      )
      else nil;
      _DMSsend this _DMSbyId uti.Cli CRetUpdateP3OK [SavePwd num];
      set LstUti=removeFromListUti LstUti _DMSgetId DMSsender;
      nil
    )
  else nil;;

/*-----------------------*/
fun _FetchMot(a,b,mot)=
  if (strlen LstMots) > 0 then
    set LstMots=strcat LstMots " "
  else nil;
  set LstMots=strcat LstMots hd mot;
  0;;

/*-----------------------*/
fun RetCheckFetchUpd(num)=
  let findListUti LstUti _DMSgetId DMSsender -> uti in
  if uti != nil then
    if num==nil then
      _DMSsend this _DMSbyId uti.Cli CRetFetchUpdKO []
    else (
      let SqlRequest db strcatn "SELECT "::LColEmail::" FROM "::LTable::
                                " WHERE "::LTable::"."::LColName::"=?"::nil
                        (SQL_CHAR uti.Nom)::nil -> tst in (
      set LstMots="";
      SqlFetch db @_FetchMot nil;
      SqlRequest db strcatn "SELECT "::WColWord::" FROM "::WTable::
                            " WHERE "::WTable::"."::WColName::"=?"::nil
                    (SQL_CHAR uti.Nom)::nil;
      _DMSsend this _DMSbyId uti.Cli CRetFetchUpdP3OK [ (hd hd tst) LstMots num ]);
      set LstUti=removeFromListUti LstUti _DMSgetId DMSsender;
      nil
    )
  else nil;;

/*-----------------------*/
fun __SetUtil(nom, email, mots, uti_passwd)=
  if findList CliAdm DMSsender then (
    let if !strcmp Policy "P2" then
          SqlRequest db strcatn "SELECT "::LColEmail::","::LColPasswd::
                                " FROM "::LTable::" WHERE "::LTable::"."::LColName::"=?"::nil
                        (SQL_CHAR nom)::nil
        else
        if !strcmp Policy "P3" then
          SqlRequest db strcatn "SELECT "::LColEmail::","::LColPasswd::","::LColNum::
                                " FROM "::LTable::" WHERE "::LTable::"."::LColName::"=?"::nil
                        (SQL_CHAR nom)::nil
        else nil
        -> tst in
    if (tst == nil) then
      if !strcmp Policy "P2" then
        SqlRequest db strcatn "INSERT INTO "::LTable::"("::LColName::","::LColEmail::","::LColIP::","::
                                                           LColTime::","::LColPasswd::") VALUES (?,?,?,?,?)"::nil
                      (SQL_CHAR nom)::(SQL_CHAR email)::(SQL_CHAR _InitAdrIP DMSsender)::
                      (SQL_CHAR _InitHeure)::(SQL_CHAR uti_passwd)::nil
      else
      if !strcmp Policy "P3" then
        SqlRequest db strcatn "INSERT INTO "::LTable::"("::LColName::","::LColEmail::","::LColIP::","::
                                                           LColTime::","::LColPasswd::","::LColNum::") VALUES (?,?,?,?,?,?)"::nil
                      (SQL_CHAR nom)::(SQL_CHAR email)::(SQL_CHAR _InitAdrIP DMSsender)::
                      (SQL_CHAR _InitHeure)::(SQL_CHAR uti_passwd)::(SQL_INTEGER itoa Maxlog-1)::nil
      else nil
    else (
      if !strcmp Policy "P2" then
        SqlRequest db strcatn "UPDATE "::LTable::
                              " SET "::LTable::"."::LColEmail::"=?,"::
                                       LTable::"."::LColIP::"=?,"::LTable::"."::LColTime::"=?,"::
                                       LTable::"."::LColPasswd::"=?"::
                              " WHERE "::LTable::"."::LColName::"=?"::nil
                      (SQL_CHAR if strlen email then email else hd hd tst)::
                      (SQL_CHAR _InitAdrIP DMSsender)::(SQL_CHAR _InitHeure)::
                      (SQL_CHAR if strlen uti_passwd then uti_passwd else nth_list hd tst 1)::
                      (SQL_CHAR nom)::nil
      else
      if !strcmp Policy "P3" then
        SqlRequest db strcatn "UPDATE "::LTable::
                              " SET "::LTable::"."::LColEmail::"=?,"::
                                       LTable::"."::LColIP::"=?,"::LTable::"."::LColTime::"=?,"::
                                       LTable::"."::LColPasswd::"=?,"::LTable::"."::LColNum::"=?"::
                              " WHERE "::LTable::"."::LColName::"=?"::nil
                      (SQL_CHAR _fooS if strlen email then email else hd hd tst)::
                      (SQL_CHAR _InitAdrIP DMSsender)::(SQL_CHAR _InitHeure)::
                      (SQL_CHAR if strlen uti_passwd then uti_passwd else nth_list hd tst 1)::
                      (SQL_INTEGER if strlen uti_passwd then itoa Maxlog-1 else nth_list hd tst 2)::
                      (SQL_CHAR _fooS nom)::nil
      else nil;
      if (strlen mots) > 0 then (
        DeleteWords nom;
        InsertWords nom hd strextr mots
      )
      else nil;
      nil
    );
    _DMSevent this DMSsender EVT_ADMIN_UPDATED nil nil;
    _DMSsend this DMSsender CRetSetOK []
  )
  else nil;;

/*-----------------------*/
fun __FetchUtilUpd(nom,passwd)=
  let SqlRequest db strcatn "SELECT "::LColEmail::" FROM "::LTable::
                            " WHERE "::LTable::"."::LColName::"=?"::
                            "   AND "::LTable::"."::LColPasswd::"=?"::nil
                    (SQL_CHAR nom)::(SQL_CHAR passwd)::nil -> tst in
  if tst==nil then
    _DMSsend this DMSsender CRetFetchUpdKO []
  else (
    set LstMots="";
    SqlFetch db @_FetchMot nil;
    SqlRequest db strcatn "SELECT "::WColWord::" FROM "::WTable::
                          " WHERE "::WTable::"."::WColName::"=?"::nil
                  (SQL_CHAR nom)::nil;
    _DMSsend this DMSsender CRetFetchUpdOK [ (hd hd tst) LstMots ]
  );;

/*-----------------------*/
fun __FetchUtilAdm(nom)=
  if findList CliAdm DMSsender then
    let SqlRequest db strcatn "SELECT "::LColEmail::" FROM "::LTable::
                              " WHERE "::LTable::"."::LColName::"=?"::nil
                      (SQL_CHAR nom)::nil -> tst in
    if tst==nil then
      _DMSsend this DMSsender CRetFetchAdmKO []
    else (
      set LstMots="";
      SqlFetch db @_FetchMot nil;
      SqlRequest db strcatn "SELECT "::WColWord::" FROM "::WTable::
                            " WHERE "::WTable::"."::WColName::"=?"::nil
                    (SQL_CHAR nom)::nil;
      _DMSsend this DMSsender CRetFetchAdmOK [ (hd hd tst) LstMots ]
    )
  else nil;;

/*-----------------------*/
fun __DelUtil(nom)=
  if findList CliAdm DMSsender then (
    let SqlRequest db strcatn "SELECT "::LColName::" FROM "::LTable::
                              " WHERE "::LTable::"."::LColName::"=?"::nil
                      (SQL_CHAR nom)::nil -> tst in
    if (tst == nil) then
      _DMSsend this DMSsender CRetDelKO []
    else (
      SqlRequest db strcatn "DELETE FROM "::LTable::
                            " WHERE "::LTable::"."::LColName::"=?"::nil
                    (SQL_CHAR nom)::nil;
      SqlRequest db strcatn "DELETE FROM "::WTable::
                            " WHERE "::WTable::"."::WColName::"=?"::nil
                    (SQL_CHAR nom)::nil;
      _DMSevent this DMSsender EVT_ADMIN_DELETED nil nil;
      _DMSsend this DMSsender CRetDelOK []
    )
  )
  else nil;;

/*-----------------------*/
fun startcli(cli)=
  _DMScreateClientDMI this cli strbuild (KW_LGLCOLNAME::LgLColName::nil)::(KW_LGLCOLEMAIL::LgLColEmail::nil)::
                                        (KW_LGLCOLPASSWD::LgLColPasswd::nil)::(KW_LGWCOLWORD::LgWColWord::nil)::
                                        (KW_WLIST::Wlist::nil)::
                                        if !strcmp Policy "P3" then (KW_MAXLOG::(itoa Maxlog)::nil)::nil else nil;;

/*-----------------------*/
fun clidestroyed(cli)=
  set CliAdm=remove_from_list CliAdm cli;
  _DMSevent this cli EVT_DESTROYED nil nil;;

/*-----------------------*/
fun action(from,cli,act,param,rep)=
  if !strcmp act ACT_START then
    startcli cli
  else
  if !strcmp act ACT_DESTROY then (
    _DMSdelClientDMI this cli;
    clidestroyed cli
  )
  else
  if !strcmp act ACT_SHOW_ADMIN then (
    startcli cli;
    if !findList CliAdm cli then
      set CliAdm=cli::CliAdm
    else nil;
    _DMSsend this cli CAffAdmin []
  )
  else
  if !strcmp act ACT_HIDE_ADMIN then (
    set CliAdm=remove_from_list CliAdm cli;
    _DMSsend this cli CHideAdmin []
  )
  else
  if !strcmp act ACT_RET_INIT_UPDATE then
    let findListUti LstUti _DMSgetId cli -> uti in
    if uti != nil then (
      set uti.Dest = from;
      set uti.Rep = rep;
      _DMSsend this cli CRetInitUpdate [ param ]
    )
    else nil
  else
  if !strcmp act ACT_RET_INIT_FETCH_UPD then
    let findListUti LstUti _DMSgetId cli -> uti in
    if uti != nil then (
      set uti.Dest = from;
      set uti.Rep = rep;
      _DMSsend this cli CRetInitFetchUpd [ param ]
    )
    else nil
  else
  if !strcmp act ACT_RET_CHECK_UPDATE then (
    RetCheckUpdate atoi param;
    0
  )
  else
  if !strcmp act ACT_RET_CHECK_FETCH_UPD then (
    RetCheckFetchUpd atoi param;
    0
  )
  else nil;;

/*-----------------------*/
fun beforeclose()=
  _DisconnectDB;
  0;;
  
/*-----------------------*/
fun IniDMI(s)=
  _DMSregisterDMI this @action @clidestroyed @clidestroyed @beforeclose;
  let strextr _getpack _checkpack s -> l in
  ( set NomDB=getInfo l KW_DBNAME;
    set LoginDB=let (getInfo l KW_DBLOGIN) -> val in
              if val==nil then "" else val;
    set PasswDB=let (getInfo l KW_DBPASSW) -> val in
               if val==nil then "" else val;
    set LTable=getInfo l KW_LTABLE;
    set SavePwd=getInfo l KW_SAVEPWD;
    set LColName=getInfo l KW_LCOLNAME;
    set LColEmail=getInfo l KW_LCOLEMAIL;
    set LColPasswd=getInfo l KW_LCOLPASSWD;
    set LColIP=getInfo l KW_LCOLIP;
    set LColTime=getInfo l KW_LCOLTIME;
    set LgLColName=getInfo l KW_LGLCOLNAME;
    set LgLColEmail=getInfo l KW_LGLCOLEMAIL;
    set LgLColPasswd=getInfo l KW_LGLCOLPASSWD;
    set WTable=getInfo l KW_WTABLE;
    set WColName=getInfo l KW_WCOLNAME;
    set WColWord=getInfo l KW_WCOLWORD;
    set LgWColWord=getInfo l KW_LGWCOLWORD;
    set Wlist=ConcMots strextr getInfo l KW_WLIST;
    set Policy=getInfo l KW_POLICY;
    set Maxlog=atoi getInfo l KW_MAXLOG;
    set LColNum=getInfo l KW_LCOLNUM
  );
  _ConnectDB;;