/******************************************************************************* Module mailinglist Server part Version: 1.0 Author: Catheline VEILLEUX, laurent PLUMAT Last update: 1/08/2001 Module mailinglist *******************************************************************************/ struct Tabonne = [ A_Pseudo : S, /* login of the subscriber */ A_Receive : I, /* =0 si ne peut pas recevoir, =1 sinon; par defaut = 1 si A_Post=1 */ A_Post : I, /* =0 si ne peut pas poster, =1 sinon */ A_Reception : S /* = reception des mails, au choix dans {NORMAL, NOMAIL} */ ] mkAbonne;; struct TmailingList = [ ML_Name : S, /* name of ht emailinglist */ ML_Theme : S, /* theme of the mailinglist */ ML_TypeReceive : S, /* au choix dans {public, private} */ ML_TypePost : S, /* au choix dans {public, private} */ ML_RListAutorises: [S r1], /* list of autorise login to receive mail */ ML_PListAutorises: [S r1], /* list of autorize login to post mail */ ML_ListeAbonnes : [Tabonne r1] /* list of subscriber */ ] mkMailingList;; struct TDataBase = [ DB_channel : SqlDB, DB_Source : S, /* name of the database */ DB_Table : S, /* name of the table use to find login and email */ DB_Login : S, /* name of the login field */ DB_Email : S /* name of the email field */ ] mkTDataBase;; /*******************************************************************************************/ /* variable global */ /*******************************************************************************************/ typeof CurrentMailingList = TmailingList;; /* mailinglist currently update */ typeof ListOfML = [TmailingList r1];; /* List of mailinglist */ typeof WinAdmin = CLIENT;; /* nil if no windows admin is open */ typeof Sender = S;; /* adresse in top of all mail send */ typeof dataDB = TDataBase;; /* all data of the database */ /********************************************************************************************/ /* defcom */ /********************************************************************************************/ defcom CResponseRequestID = ResponseRequestID S I;; /* sned the check result of the login */ defcom CListML = ListML S I S;; /* send list of mailinglist */ defcom Cerror = error I;; /* send error message */ defcom CsendML = sendML S S S S S S;; /* send a mailinglist */ defcom Creception = reception I;; /* send type of reception of a mailinglist */ defcom Cadmin = admin I;; /* Open admin windows */ proto cbBeforeClose = fun [] I;; /*************************************************************************** ****************************************************************************/ fun myDMSgetLogin (cli) = let _DMSgetLogin cli -> loginName in let strfind "@" loginName 0 -> pos in if pos == nil then loginName else substr loginName 0 pos ;; /*************************************************************************** Renvoie le login ou le password d'une base de donnees, on specifie l'alias dans odbcAlias, l'info que l'on souhaite reccueillir dans info ("login" ou "password") les valeurs sont recuperees dans usmress.ini format : odbc.odbcAlias.login odbc.odbcAlias.password attention : odbcAlias, infos ne doivent pas contenir les caracteres suivants : ".*?" ****************************************************************************/ fun GetODBCInfos(odbcAlias,info)= hd switchstr strextr _loadressini strcatn "odbc."::odbcAlias::"."::info::nil ;; /****************************************************************************** find a login in the list element -> S : element of the list login -> S : login to find ******************************************************************************/ fun cbSearchLogin (element, login) = !strcmpi element login ;; /***************************************************************************** check if the login is in the globallogin database userName -> S : login to check auth -> I : auth to receive or post ******************************************************************************/ fun __RequestID (userName, auth) = let strcatn "SELECT "::dataDB.DB_Login::" FROM "::dataDB.DB_Table::" WHERE "::dataDB.DB_Table::".":: dataDB.DB_Login::" = "::"?"::nil -> SQLstring in let SqlRequest dataDB.DB_channel SQLstring (SQL_CHAR userName)::nil -> result in if result == nil then _DMSsend this DMSsender CResponseRequestID [userName 3] else _DMSsend this DMSsender CResponseRequestID [userName auth] ;; /************************************************************************** find a subscriber in a milinglist element -> Tabonne : element of the list login -> S : name of the subcriber ***************************************************************************/ fun cbSearchSubscriber (element, login) = !strcmpi element.A_Pseudo login ;; /************************************************************************** find a pseudo in a mailinglist mailinglist -> TmailingList : mailinglist login -> S : login to find ***************************************************************************/ fun prauth(mailinglist, login) = if (!strcmpi mailinglist.ML_TypeReceive "private") && (!strcmpi mailinglist.ML_TypePost "private") then let search_in_list mailinglist.ML_RListAutorises @cbSearchLogin login -> f1 in let search_in_list mailinglist.ML_PListAutorises @cbSearchLogin login -> f2 in if (f1 == nil) && (f2 == nil) then 0 else 1 else 1 ;; /************************************************************************** construction de la liste des mailinglist list -> [TmailingList r1] : mailinglist a mettre en string type -> I : type of send **************************************************************************/ fun makeList (list, type, login) = if list == nil then nil else let (hd list) -> first in if type == 1 then (first.ML_Name::nil)::(first.ML_Theme::nil)::(makeList(tl list) type login) else let search_in_list first.ML_ListeAbonnes @cbSearchSubscriber login -> f in if (type == 2) && (f!=nil) then (first.ML_Name::nil)::(first.ML_Theme::nil)::(makeList(tl list) type login) else if (type == 3) && (f==nil) && (prauth first login) then (first.ML_Name::nil)::(first.ML_Theme::nil)::(makeList(tl list) type login) else (makeList(tl list) type login) ;; /************************************************************************** demande du client de la liste des mailinglist type -> I : type of send ***************************************************************************/ fun __ListML (type) = _DMSsend this DMSsender CListML [(strbuild (makeList ListOfML type myDMSgetLogin DMSsender)) type nil]; 0 ;; /************************************************************************** remplissage d'une structure de mailinglist avec des parametres envoyé par un client administrateur param -> S : parametre pour remplir la mailing list currentML -> TmailingList : mailinglist à rempir ****************************************************************************/ fun CreateOneML (param, currentML) = if param == nil then 0 else let hd param-> [key [val _]] in ( if !strcmpi key "Name" then ( set currentML.ML_Name = val; 0 ) else if !strcmpi key "Theme" then ( set currentML.ML_Theme = val; 0 ) else if !strcmpi key "TypeReceive" then ( set currentML.ML_TypeReceive = val; 0 ) else if !strcmpi key "ListUserReceive" then ( let lineextr val -> users in set currentML.ML_RListAutorises = users; 0 ) else if !strcmpi key "TypePost" then ( set currentML.ML_TypePost = val; 0 ) else if !strcmpi key "ListUserPost" then ( let lineextr val -> users in set currentML.ML_PListAutorises = users; 0 ) else 0; CreateOneML tl param currentML ) ;; /******************************************************************************* trouve une mailing liste dans la liste grace a son nom element -> Tmailinglist : element de la liste de mailing list name -> S : nom de la mailinglist a trouver ********************************************************************************/ fun cbFindML (element, name) = !strcmpi element.ML_Name name ;; /******************************************************************************* fonction recevant une nouvelle mailing list du client administrateur et l'ajoutant à la liste courrante newML -> S : nouvelle mailing list sous forme de texte param -> I : 1 add, 2 modify ********************************************************************************/ fun __AddML (newML, param) = let strextr newML -> addNewML in let search_in_list ListOfML @cbFindML (hd (tl (hd addNewML))) -> f in ( if (param == 1) && (f != nil) then _DMSsend this DMSsender Cerror [10] else ( if param == 1 then ( set CurrentMailingList = mkMailingList [nil nil nil nil nil nil nil]; 0 ) else ( set CurrentMailingList = f; 0 ); CreateOneML addNewML CurrentMailingList; if param == 1 then ( set ListOfML = listcat ListOfML (CurrentMailingList::nil); _DMSsend this DMSsender CListML [(strbuild (makeList ListOfML 3 myDMSgetLogin DMSsender)) 3 (hd (tl (hd addNewML)))]; ) else nil; 0 ); _DMSsend this DMSsender CListML [strbuild (makeList ListOfML 1 nil) 1 (hd (tl (hd addNewML)))] ); cbBeforeClose; 0 ;; /******************************************************************************** fonction recevant la demande d'effacement d'une mailinglist mailinglist -> S : mailinglist à effacer ********************************************************************************/ fun __deleteML (mailinglist) = let search_in_list ListOfML @cbFindML mailinglist -> f in if f == nil then _DMSsend this DMSsender Cerror [1] else ( set ListOfML = remove_from_list ListOfML f; 0 ); _DMSsend this DMSsender CListML [strbuild (makeList ListOfML 1 nil) 1 nil]; cbBeforeClose; 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 nil then _DMSeventTag this user "in" nil nil nil else nil ;; /******************************************************************************* the client part of the module has been deleted cli -> CLIENT : the client <- I : nothing special (always 0) *******************************************************************************/ fun cbDeleteClient (cli) = if cli == WinAdmin then set WinAdmin = nil else nil; _DMSeventTag this CtoU cli "out" nil nil nil; 0 ;; /******************************************************************************* destroy a client 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 cbDestroy (from, user, action, param, others, tag) = _fooS "Destroying"; let UtoC user -> cli in ( _DMSdelClientDMI this cli; cbDeleteClient cli; ) ;; /******************************************************************************* the client has been disconnected cli -> CLIENT : the client <- I : nothing special *******************************************************************************/ fun cbLogoutClient (cli) = if cli == WinAdmin then set WinAdmin = nil else nil; 0 ;; /******************************************************************************* change list in string for subscriber list -> [Tabonne r1] : subscriber *******************************************************************************/ fun SaveAbonneOfML (list) = if list == nil then nil else let hd list -> first in first.A_Pseudo:: (itoa first.A_Receive):: (itoa first.A_Post):: first.A_Reception:: (SaveAbonneOfML (tl list)) ;; /******************************************************************************* transforme la liste de mailinglist en liste de liste de string savelist -> [TmailingList r1] : liste de mailinglist a sauvegarder *******************************************************************************/ fun SaveListOfML (savelist) = if savelist == nil then nil else let hd savelist -> first in (first.ML_Name::nil):: (first.ML_Theme::nil):: (first.ML_TypeReceive::nil):: (first.ML_TypePost::nil):: (first.ML_RListAutorises):: (first.ML_PListAutorises):: (SaveAbonneOfML first.ML_ListeAbonnes):: (SaveListOfML (tl savelist)) ;; /******************************************************************************* the module instance will be closed (server and all client parts) <- I : always 0 (not used) *******************************************************************************/ fun cbBeforeClose () = /* sauver la liste des ML */ /*_DMSupdateDef this "List" ("ML"::(strbuild (SaveListOfML ListOfML))::nil)::nil; _DEFsave;*/ /*save modification in a file*/ let strcat "tmp/mailinglist/" (substr (_getlongname strcat DMSname (_DMSgetName this) "" "#") 1 16) -> name in _storepack (strbuild (SaveListOfML ListOfML)) name; 0 ;; /****************************************************************************** chargement des abonnés list -> [S r1] : list ******************************************************************************/ fun LoadAbonne (list) = if list == nil then nil else let list -> [pseudo [receive [post [reception q]]]] in (mkAbonne [pseudo (atoi receive) (atoi post) reception])::(LoadAbonne q) ;; /******************************************************************************* transforme une liste de string en list de mailing list string -> S : strig a transformer ********************************************************************************/ fun LoadListOfML (string) = if string == nil then nil else let string -> [name [theme [typereceive [typepost [receive [post [abonne q]]]]]]] in (mkMailingList [(hd name) (hd theme) (hd typereceive) (hd typepost) receive post (LoadAbonne abonne)])::(LoadListOfML q) ;; /****************************************************************************** envoie d'une mailing list a un client mailinglist -> S : nom de la mailiglist désirée *******************************************************************************/ fun __sendML (mailinglist) = let search_in_list ListOfML @cbFindML mailinglist -> f in if f == nil then nil else _DMSsend this DMSsender CsendML [f.ML_Name f.ML_Theme f.ML_TypeReceive f.ML_TypePost (linebuild f.ML_RListAutorises) (linebuild f.ML_PListAutorises)] ;; /******************************************************************************* user request to subscribe or unsubscribe to a mailinglist mailinglist -> S : the mailinglist type -> I : 1 subscribe, 2 unsubcribe ********************************************************************************/ fun __subscribe (mailinglist, type) = let search_in_list ListOfML @cbFindML mailinglist -> f in if f == nil then nil else if type == 1 then ( set f.ML_ListeAbonnes = (mkAbonne [(myDMSgetLogin DMSsender) 0 0 "NORMAL"])::f.ML_ListeAbonnes; _DMSsend this DMSsender CListML [(strbuild (makeList ListOfML 2 myDMSgetLogin DMSsender)) 2 mailinglist]; ) else ( let search_in_list f.ML_ListeAbonnes @cbSearchSubscriber (myDMSgetLogin DMSsender) -> fu in set f.ML_ListeAbonnes = remove_from_list f.ML_ListeAbonnes fu; _DMSsend this DMSsender CListML [(strbuild (makeList ListOfML 3 myDMSgetLogin DMSsender)) 3 mailinglist] ); cbBeforeClose; 0 ;; /******************************************************************************* change the type of reception mailinglist -> S : name of the change mailinglist type -> I : type of change *******************************************************************************/ fun __reception (mailinglist, type) = let search_in_list ListOfML @cbFindML mailinglist -> f in if f == nil then nil else let search_in_list f.ML_ListeAbonnes @cbSearchSubscriber (myDMSgetLogin DMSsender) -> fu in if fu == nil then nil else if type == 1 then (set fu.A_Reception = "NORMAL";0) else if type == 2 then (set fu.A_Reception = "NOMAIL";0) else if (!strcmpi f.ML_TypeReceive "private") then let search_in_list f.ML_RListAutorises @cbSearchLogin (myDMSgetLogin DMSsender) -> f1 in if (f1 == nil) then _DMSsend this DMSsender Creception [3] else _DMSsend this DMSsender Creception [if !strcmpi fu.A_Reception "NORMAL" then 1 else 2] else _DMSsend this DMSsender Creception [if !strcmpi fu.A_Reception "NORMAL" then 1 else 2]; cbBeforeClose; 0 ;; /****************************************************************************** find a mail by a login login -> S : login to find the mail <- S : the mail *******************************************************************************/ fun findMail (login) = let strcatn "SELECT "::dataDB.DB_Login::" , "::dataDB.DB_Email::" FROM "::dataDB.DB_Table::" WHERE ":: dataDB.DB_Table::"."::dataDB.DB_Login::" = "::"?"::nil -> SQLstring in let SqlRequest dataDB.DB_channel SQLstring (SQL_CHAR login)::nil -> result in ( if result == nil then nil else [(hd hd result) (hd tl hd result)] ) ;; /****************************************************************************** check if whe have the mail of the login *******************************************************************************/ fun __checkMail () = let findMail(myDMSgetLogin DMSsender) -> [login email] in if email == nil then if login == nil then _DMSsend this DMSsender Cerror [6] else _DMSsend this DMSsender Cerror [5] else nil ;; /****************************************************************************** sending mail element -> Tabonne : element of the list param -> [S S] : subject and body of the mail ******************************************************************************/ fun cbSendMail (element, param) = if !strcmpi element.A_Reception "NORMAL" then ( let param -> [subject body] in let findMail element.A_Pseudo -> [_ email] in _DMSevent this nil "sendMail" strbuild (("snd"::Sender::nil):: ("rcp"::email::nil):: ("sub"::subject::nil):: ("txt"::body::nil)::nil) nil ) else nil ;; /******************************************************************************* find the auth user to receive mail element -> Tabonne : element of the list param -> [[S r1] CLIENT S S : autorize login subject and body of the mail *********************************************************************************/ fun cbSendAuthMail (element, param) = let param -> [authlist cli subject body] in let search_in_list authlist @cbSearchLogin (myDMSgetLogin cli) -> fl in if fl == nil then nil else cbSendMail element [subject body] ;; /******************************************************************************* send the mail to all mailing list mailinglist -> S : mailing list to send the mail subject -> S : subject of the mail body -> S : body of the mail ********************************************************************************/ fun __sendMail (mailinglist, subject, body) = let search_in_list ListOfML @cbFindML mailinglist -> f in if f == nil then nil else let strcatn "["::DMSname::" "::(myDMSgetLogin DMSsender)::"]"::" "::subject::nil -> subject2 in if !strcmpi f.ML_TypePost "private" then let search_in_list f.ML_PListAutorises @cbSearchLogin (myDMSgetLogin DMSsender) -> fl in if fl == nil then _DMSsend this DMSsender Cerror [4] else ( _DMSsend this DMSsender Cerror [3]; if !strcmpi f.ML_TypeReceive "private" then (apply_on_list f.ML_ListeAbonnes @cbSendAuthMail [f.ML_RListAutorises DMSsender subject2 body];0) else (apply_on_list f.ML_ListeAbonnes @cbSendMail [subject2 body];0) ) else ( _DMSsend this DMSsender Cerror [3]; apply_on_list f.ML_ListeAbonnes @cbSendMail [subject2 body] ) ;; /******************************************************************************* 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 cbAdmin (from, user, action, param, others, tag) = let UtoC user -> cli in if (WinAdmin == nil) || (WinAdmin == cli) then ( set WinAdmin = cli; _DMSsend this cli Cadmin [1] ) else _DMSsend this cli Cadmin [2] ;; /******************************************************************************* the administrator close the adminbistration board ********************************************************************************/ fun __closeAdmin () = if DMSsender == WinAdmin then set WinAdmin = nil else nil ;; /******************************************************************************* main function, called when the server part of the module is initialized file -> S : not used <- I : nothing special *******************************************************************************/ fun IniDMI2 (file) = /*let _DMSgetDef this "List" -> dataDef in let strextr (getInfo dataDef "ML") -> param in*/ let strcat "tmp/mailinglist/" (substr (_getlongname strcat DMSname (_DMSgetName this) "" "#") 1 16) -> name in let strextr _getpack _checkpack name -> param in set ListOfML = (LoadListOfML param); let _DMSgetDef this "Data" -> dataDef in let getInfo dataDef "source" -> source in let getInfo dataDef "table" -> table in let getInfo dataDef "login" -> login in let getInfo dataDef "email" -> email in ( set Sender = (getInfo dataDef "sender"); set dataDB = mkTDataBase [nil source table login email] ); let GetODBCInfos dataDB.DB_Source "login" -> loginDB in let GetODBCInfos dataDB.DB_Source "password" -> pwdDB in let if dataDB.DB_Source == nil then "" else dataDB.DB_Source -> al in let if loginDB ==nil then "" else loginDB -> lo in let if pwdDB ==nil then "" else pwdDB -> pwd in let SqlCreate _channel al lo pwd -> dbtmp in set dataDB.DB_channel = dbtmp; if dataDB.DB_channel == nil then _adderror strcatn (_DMSgetName this)::" : unable to access to dataBase <"::dataDB.DB_Source::">"::nil else nil; _DMSregister this @cbLogoutClient @cbDeleteClient @cbBeforeClose; _DMSdefineActions this (["start" @cbStart ]):: (["destroy" @cbDestroy ]):: (["edit" @cbAdmin]):: nil; 0 ;; fun pro () = let BigToAsc BigInvn BigFromAsc _getpack _checkpack "dms/commtools/mailinglist/mailinglist.conf" BigFromAsc "ed537b937bee0c65" -> s in let if (strlen s)!=9 then nil else [htoi substr s 1 4 htoi substr s 5 4] -> [datedebut periode] in if periode==nil then (_adderror strcatn (_loc this "PRO_MODULE" nil)::" "::(_DMSgetName this)::" : "::(_loc this "PRO_INVALID_MSG" nil)::nil;0) else if periode==0 then 1 else let ((time>>1)&0x3fffffff)/43200-datedebut -> x in if x<0 then (_adderror strcatn (_loc this "PRO_MODULE" nil)::" "::(_DMSgetName this)::" : "::(_loc this "PRO_INVALID_MSG" nil)::nil;0) else if x<=periode then (_addwarning strcatn (_loc this "PRO_MODULE" nil)::" "::(_DMSgetName this)::" : "::(_loc this "PRO_LIMITED_MSG" (itoa (periode-x))::nil)::nil;1) else (_adderror strcatn (_loc this "PRO_MODULE" nil)::" "::(_DMSgetName this)::" : "::(_loc this "PRO_ENDLIMITED_MSG" nil)::nil;0) ;; /* Server initialisation */ fun IniDMI (f) = if pro then IniDMI2 f else nil ;;