/*******************************************************************************
 Module FTP
 Server part
 Version: 1.0
 Authors: Laurent PLUMAT
 Last update: //2001
 FTP Module
*******************************************************************************/

/*gestion des utilisateurs au niveau du serveur*/
struct Tuser = 
[
  client  : CLIENT,       /* CLIENT of the user */
  admin   : I             /* user is it an administrator */
]mkUser;;

/*gestion des repertoires au niveau du serveur*/
struct Tfolder = 
[
  name      : S,            /* name of the folder */
  path      : S,            /* path on the server */
  authUser  : [[S I] r1],   /* all login and auth for user on this folder */
  subFolder : [Tfolder r1], /* subfolder of the folder */  
  listFile  : [[S I] r1]    /* file in this folder */
]mkFolder;;

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 */
] mkTDataBase;;

/******* defcom *************/
defcom CsendFolder = sendFolder S;;
defcom CsendFile = sendFile S;;
defcom CdownloadFile = downloadFile S I;;
defcom Cerror = error I;;
defcom CAdmin = Admin I;;
defcom Crefresh = refresh S;;
defcom Cdestroy = destroy;;
defcom CAddLogin = AddLogin S;;

typeof allUser = [Tuser r1];;      /* all user connected */
typeof allFolder = [Tfolder r1];;  /* list all the falder in the home directory */
typeof allAdmin = [S r1];;         /* list of all ladmin login */
typeof homeFolder = S;;            /* home directory */
typeof folderSize = I;;            /* size of all file in all tree */
typeof dataDB = TDataBase;;        /* all data of the database */

var maxSize = 200000;;
var fileSize = 10000;;

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
;;

/********************************************************************************
  recherche du nom d'un fichier dans un path
    path -> S           : path of the file
         <- S           : name
********************************************************************************/
fun findName (path) = 
  if path == nil then
    nil
  else
    let strfind "/" path 0 -> result in
      if result == nil then
        path
      else
        findName substr path (result +1) ((strlen path)-(result +1)) 
;;

/*******************************************************************************
  search a folder in the list
    list -> [Tfolder r1]: list
    param -> S          : path of the folder to find 
********************************************************************************/
fun searchFolder (list, param) = 
  if list == nil then 
    nil
  else
    let hd list -> first in
      if !strcmpi first.path param then
        first
      else
        let searchFolder (first.subFolder) param -> result in
          if result == nil then
            searchFolder (tl list) param
          else
            result
;;

/*****************************************************************************
  find a user in en aut list
    element -> [S I]    : an element of the list
    login -> S          : the login to find
******************************************************************************/
fun cbSearchAuth (element, login) = 
  let element -> [ login2 _] in
    !strcmpi login2 login
;;

/******************************************************************************
  send to allUser to refresh
    element -> Tuser      : an user
    param -> S            : folder to refresh
******************************************************************************/
fun cbRefresh (element, param) = 
  _DMSsend this element.client Crefresh [param] 
;;

/******************************************************************************
  change the subfolder auth
    lfolders -> Tfolder   : list of folder to change auth
    login -> S            : login to change 
    auth -> I             : new auth
    father -> S           : the father folder
*******************************************************************************/
fun changeFolderAuth (lfolder, login, auth, father) = 
  if lfolder == nil then
    (apply_on_list allUser @cbRefresh (father);0)
  else
    let (hd lfolder) -> folder in
    ( 
      let search_in_list folder.authUser @cbSearchAuth login -> fu in 
        if auth == (-1) then
          (set folder.authUser = remove_from_list folder.authUser fu;0)
        else
          if fu == nil then
            (set folder.authUser = [login auth]::folder.authUser; 0)
          else
            (mutate fu <- [_ auth]; 0);
            
      changeFolderAuth (tl lfolder) login auth father;
      changeFolderAuth folder.subFolder login auth folder.path;
      cbBeforeClose;
      0
    )
;;
/******************************************************************************
  a client change the auth of an user
    fpath -> S    : path of the change
    login -> S    : login to change
    auth -> I     : new auth
    father -> S   : the father folder
    follow -> I   : follow the auth to the son folder
*******************************************************************************/
fun __changeAuth (fpath, login, auth, father, follow) =
  let searchFolder allFolder fpath -> f in
    if f == nil then
      nil
    else
    (
      let search_in_list f.authUser @cbSearchAuth login -> fu in 
      if auth == (-1) then
        (set f.authUser = remove_from_list f.authUser fu;0)
      else
        if fu == nil then
          /*verification dan la base */
          if dataDB.DB_channel == nil then
            _DMSsend this DMSsender CAddLogin ["-1"]
          else 
            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 login)::nil -> result in
            (
              if (result == nil) && (strcmpi login "guest") then 
                _DMSsend this DMSsender CAddLogin [nil] 
              else
              (
                set f.authUser = [login auth]::f.authUser;
                _DMSsend this DMSsender CAddLogin [login] 
              ) 
            )
        else
          (mutate fu <- [_ auth]; 0);
      
      if follow == 1 then
        changeFolderAuth f.subFolder login auth f.path
      else
        nil
    );
  
  apply_on_list allUser @cbRefresh (father) 
;; 

/******************************************************************************
  tuple into list
******************************************************************************/
fun TauthToList (list) = 
  if list == nil then
    nil
  else
    let hd list -> [login a] in
      login::(itoa a)::(TauthToList (tl list))
;;

/******************************************************************************
  put struct in list
*******************************************************************************/
fun TfolderToList (list) = 
  if list == nil then
    nil
  else
    let hd list -> first in
      (first.name::first.path::(TauthToList first.authUser))::(TfolderToList (tl list)) 
;;

/*******************************************************************************
  send the folder to an admin client
    param -> S    : folder to explore
********************************************************************************/
fun __sendFolder (param) = 
  if param == nil then
    _DMSsend this DMSsender CsendFolder [(strbuild (TfolderToList allFolder))]
  else
    let searchFolder allFolder param -> f in
      _DMSsend this DMSsender CsendFolder [(strbuild (TfolderToList f.subFolder))]
;;

/*******************************************************************************
  send auth folder
    folder -> Tfolder   : folder to send
    cli -> CLIENT       : client to send
*******************************************************************************/
fun cbsendAuthFolder (folder, cli) = 
  if folder.authUser == nil then
    nil
  else
    _DMSsend this cli CsendFile [(linebuild folder.name::folder.path::"1"::nil)] 
;;

/*******************************************************************************
  send file
    element -> [S I]    : file to send
    param -> CLIENT S   : client to send and folder
*******************************************************************************/
fun cbsendFile (element, param) = 
  let element -> [name size] in
  let param -> [cli path] in
  let strcatn path::"/"::name::nil -> file in
    _DMSsend this cli CsendFile [(linebuild file::file::"2"::(itoa size)::nil)]
;;

/*******************************************************************************
  send folder and file to a client
    param -> S    : folder to explor
********************************************************************************/
fun __sendFile (param) = 
  _DMSsend this DMSsender CsendFile ["0"];
  if param == nil then
    apply_on_list allFolder @cbsendAuthFolder DMSsender
  else
    let searchFolder allFolder param -> f in
    (
      apply_on_list f.subFolder @cbsendAuthFolder DMSsender;
      apply_on_list  f.listFile @cbsendFile [DMSsender f.path] 
    ) 
;;

/*******************************************************************************
  find a client in the allUse list
    user -> Tuser   : an user
    cli -> CLIENT   : the client we looking for
********************************************************************************/
fun cbFindClient (user, cli) = 
  user.client == cli
;;

/*******************************************************************************
 the client has been disconnected
 cli -> CLIENT : the client
     <- I      : nothing special (always 0)
*******************************************************************************/
fun cbLogoutClient (cli) =
  let search_in_list allUser @cbFindClient cli -> f in
    set allUser = remove_from_list allUser f;
  0
;;

/*******************************************************************************
 the client part of the module has been deleted
 cli -> CLIENT : the client
     <- I      : nothing special (always 0)
*******************************************************************************/
fun cbDeleteClient (cli) =
  _DMSeventTag this CtoU cli "out" nil nil nil;
  let search_in_list allUser @cbFindClient cli -> f in
    set allUser = remove_from_list allUser f;
  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) =
  let UtoC user -> cli in
  if _DMScreateClientDMI this cli nil then
  (  
    set allUser = (mkUser [cli 0])::allUser;
    _DMSeventTag this user "in" nil nil nil
  )
  else
    nil
;;

/*******************************************************************************
  administrator closed his window
********************************************************************************/
fun __closedAdmin () =
  let search_in_list allUser @cbFindClient DMSsender -> f in
    if f == nil then
      nil
    else
      set f.admin = 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) =
  let UtoC user -> cli in
  (
    _DMSsend this cli Cdestroy []; 
    _DMSdelClientDMI this cli;
    cbDeleteClient cli
  )
;;

/*************************************************************************************************************/
/********************************** load to dms **************************************************************/
/*************************************************************************************************************/

/*******************************************************************************
  fill the allFolder list
    folder -> S     : folder to append in list
    home -> S       : home directory
********************************************************************************/
fun fillFolder (home, list) =
  if list == nil then
    nil
  else
    let hd list -> folder in
      (mkFolder [(substr folder (strlen home) (strlen folder)) folder nil (fillFolder folder (_listofsubdir folder)) nil])::
      (fillFolder home (tl list))
;;

/******************************************************************************
  list into tuple
******************************************************************************/
fun TlistToauth (list) = 
  if list == nil then
    nil
  else
    let list -> [login [a q]] in
      [login (atoi a)]::(TlistToauth q)
;;

/*******************************************************************************
   list to tuple
    list -> [S r]
********************************************************************************/
fun fillFile (list) = 
  if list == nil then
    nil
  else
    let list -> [name [size q]] in
    (
      set folderSize = folderSize + (atoi size);
      [name (atoi size)]::(fillFile q)
    )
;;

/*******************************************************************************
  load the auth in the dms
    
********************************************************************************/
fun FillAuth (list) =
  if list == nil then
    nil
  else
    let list -> [lname [lpath [lfather [lauth [lfile q]]]]] in
      let (searchFolder allFolder (hd lfather)) -> f in
      ( 
        if f == nil then
          set allFolder = (mkFolder [(hd lname) (hd lpath) (TlistToauth (lauth)) nil (fillFile lfile)])::allFolder 
        else
          set f.subFolder = (mkFolder [(hd lname) (hd lpath) (TlistToauth (lauth)) nil (fillFile lfile)])::f.subFolder;
    
        FillAuth (q); 
        0
      )
;;

/*************************************************************************************************************/
/********************************** save to dms **************************************************************/
/*************************************************************************************************************/

/******************************************************************************
  save tuple to a dtring list
    list -> [[S I] r1]  : list of file
******************************************************************************/
fun TfileToSaveList (list) =
  if list == nil then
    nil
  else
    let hd list -> first in
    let first -> [name size] in
      name::(itoa size)::(TfileToSaveList (tl list))
;;

/******************************************************************************
  put struct in Save list
*******************************************************************************/
fun TfolderToSaveList (list, father) = 
  if list == nil then
    nil
  else
    let hd list -> first in
      listcat (first.name::nil)::
              (first.path::nil)::
              (father::nil)::
              (TauthToList first.authUser)::
              (TfileToSaveList first.listFile):: 
              (TfolderToSaveList first.subFolder first.path)
              (TfolderToSaveList (tl list) father)
;;

/*******************************************************************************
 the module instance will be closed (server and all client parts)
 cli -> CLIENT : the client
     <- I      : always 0 (not used)
*******************************************************************************/
fun cbBeforeClose () =
  /* Save modifications in the DMS file */
  /*_DMSupdateDef this "ftpAuth" ("allAuth"::(strbuild TfolderToSaveList allFolder nil)::nil)::nil;*/
  /*_DEFsave;*/
  
  /*save modification in a file*/
  let strcat "tmp/ftp/" (substr (_getlongname strcat DMSname (_DMSgetName this) "" "#") 1 16) -> name in 
    _storepack (strbuild TfolderToSaveList allFolder nil) name;
  0
;;

/*******************************************************************************
  find a folder from a path
    path -> S       : path to find the folder
         <- S       : folder
*******************************************************************************/
fun findFolder (path) = 
  if path == nil then
    nil
  else
    let strfind "/" path 0 -> result in
      if result == nil then
        nil
      else
        let (findFolder substr path (result +1) ((strlen path)-(result +1))) -> result2 in
          if result2 == nil then
            substr path 0 result
          else
            strcat (substr path 0 (result+1)) result2 
;;

/*******************************************************************************
  search a file in a folder
    element -> [S I]        : element of the list
    name -> S               : name of file to find
********************************************************************************/
fun cbsearchFile (element, name) = 
  let element -> [myname _] in
    !strcmpi myname name
;;

/*******************************************************************************
  save a file in the vituel tree
    data -> S       : data to save
    name -> S       : name of the file
********************************************************************************/
fun  _storepack_virtual (data, name) = 
  let (findFolder name) -> path in
  let searchFolder allFolder path -> f in
    if f == nil then
      nil
    else
    (
      let  search_in_list f.listFile @cbsearchFile (substr name ((strlen path)+1) ((strlen name)-((strlen path)+1))) -> ff in
        if ff == nil then
        (
          set f.listFile = [(substr name ((strlen path)+1) ((strlen name)-((strlen path)+1))) (strlen data)]::f.listFile;
          set folderSize = folderSize + (strlen data)
        )
        else
        (
          let ff -> [_ size] in
            set folderSize = folderSize - size;
          mutate ff <- [_ (strlen data)];
          set folderSize = folderSize + (strlen data)
        );
        
      _storepack data (strcat homeFolder (substr (_getlongname name name "#") ((strlen name)+1) 16));
      cbBeforeClose;
    )  
;;

/*******************************************************************************
  receive a file from a client
    cli -> CLIENT         : client who send the file
    name -> S             : name of the file
    data -> S             : data of the file
*******************************************************************************/
fun cbReceive (cli, name, data) = 
  _storepack_virtual data name;
  let search_in_list allUser @cbFindClient cli -> f in
  let remove_from_list allUser f -> sendUser in
    apply_on_list sendUser @cbRefresh (findFolder name)
;;

/*******************************************************************************
  client want to download or upload a file
    path -> S   : path of the file
    way -> I    : upload or download
********************************************************************************/
fun __downloadFile (path, way, size) =
  let searchFolder allFolder (if way == 2 then path else (findFolder path)) -> f in
    if f == nil then
      nil
    else
      let search_in_list f.authUser @cbSearchAuth myDMSgetLogin DMSsender -> fu in 
        if fu == nil then
          let search_in_list f.authUser @cbSearchAuth "guest" -> gu in
            if gu == nil then
              _DMSsend this DMSsender Cerror [way]
            else
              let gu -> [_ gauth] in
                if (gauth & way) == way then 
                  if (way == 1) then
                  ( 
                    let substr (_getlongname path path "#") ((strlen path)+1) 16 -> sign in 
                      _RSregister this sign RScontrol+RSfile strcat homeFolder sign;
                    _DMSsend this DMSsender CdownloadFile [path way]
                  )
                  else
                    if (folderSize + size) > maxSize then 
                      _DMSsend this DMSsender Cerror [4]
                    else
                      if size > fileSize then
                        _DMSsend this DMSsender Cerror [5]
                      else
                        _DMSsend this DMSsender CdownloadFile [path way]
              
              else
                _DMSsend this DMSsender Cerror [way] 
        else
          let fu -> [_ auth] in
            if (auth & way) == way then 
                if (way == 1) then
                ( 
                  let substr (_getlongname path path "#") ((strlen path)+1) 16 -> sign in 
                      _RSregister this sign RScontrol+RSfile strcat homeFolder sign;
                  _DMSsend this DMSsender CdownloadFile [path way]
                )
                else
                  if (folderSize + size) > maxSize then 
                      _DMSsend this DMSsender Cerror [4]
                    else
                      if size > fileSize then
                        _DMSsend this DMSsender Cerror [5]
                      else
                        _DMSsend this DMSsender CdownloadFile [path way]
            else
              _DMSsend this DMSsender Cerror [way];
            
  0
;;

/******************************************************************************
  find if an admin windows is open
    element -> Tuser        : element of the user list
    param -> I              : value to find
*******************************************************************************/
fun cbFindWinAdmin (element, param) = 
  element.admin == param
;;

/*******************************************************************************
  client want to administrate the ftp
    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 cbAdmin(from, user, action, param, others, tag) =
  let UtoC user -> cli in
  let search_in_list allUser @cbFindWinAdmin 1 -> fa in
    if fa == nil then 
      let search_in_list allUser @cbFindClient cli -> fu in
        if fu == nil then
          nil
        else
        (
          set fu.admin = 1;  
          _DMSsend this cli CAdmin [1]
        )
    else
      if fa.client == cli then     
        _DMSsend this cli CAdmin [1]
      else
        _DMSsend this cli CAdmin [2]
;;

/******************************************************************************
  find a file in a file list
    element -> [S I]      : element of the list
    name -> S             : file to find
*******************************************************************************/
fun cbFindFile (element, name) = 
  let element -> [lname _] in
    !strcmpi lname name
;;

/*******************************************************************************
  delete a file
    path -> S   : path of the file to delete
********************************************************************************/
fun __deleteFile (path) = 
  let searchFolder allFolder (findFolder path) -> f in
    if f == nil then
      nil
    else
      let search_in_list f.authUser @cbSearchAuth myDMSgetLogin DMSsender -> fu in 
        if fu == nil then
          nil 
        else
          let fu -> [_ auth] in
            if (auth & 2) == 2 then
            (
              let search_in_list f.listFile @cbFindFile (findName path) -> fn in
              if fn == nil then
                nil
              else
              (
                let fn -> [_ size] in
                  set folderSize = folderSize - size; 
                set f.listFile = remove_from_list f.listFile fn;
              );
 
              _deletepack _checkpack (strcat homeFolder (substr (_getlongname path path "#") ((strlen path)+1) 16));
              cbBeforeClose;
              0
            )
            else
              _DMSsend this DMSsender Cerror [3];
            
  apply_on_list allUser @cbRefresh (findFolder path);
  0
;;

/******************************************************************************
  remove a folder
    path -> S         : path of the folder to remove
    father -> S       : path of his father
*******************************************************************************/
fun __removeFolder (path, father) = 
  let searchFolder allFolder path -> f in
    if f == nil then
      nil
    else
      let searchFolder allFolder father -> ff in
        if (f.subFolder == nil) && (f.listFile == nil) then
          if ff == nil then
          (         
            set allFolder = remove_from_list allFolder f;
            _DMSsend this DMSsender CsendFolder [(strbuild (TfolderToList allFolder))]
          )
          else
          (
            set ff.subFolder = remove_from_list ff.subFolder f;
            _DMSsend this DMSsender CsendFolder [(strbuild (TfolderToList ff.subFolder))]
          )
        else
          _DMSsend this DMSsender Cerror [10];     
  cbBeforeClose;
  0
;;

/******************************************************************************
  make a new folder
    name -> S         : name of the new folder
    father  ->        : father folder
*******************************************************************************/
fun __makeFolder (name, father) = 
  let searchFolder allFolder (strcatn father::"/"::name::nil) -> f in
    if f == nil then
      let searchFolder allFolder father -> ff in
        if ff == nil then 
        (
          set allFolder = (mkFolder [name (strcatn father::"/"::name::nil) nil nil nil])::allFolder;
          _DMSsend this DMSsender CsendFolder [(strbuild (TfolderToList allFolder))]
        ) 
        else
        (
          set ff.subFolder = (mkFolder [name (strcatn father::"/"::name::nil) nil nil nil])::ff.subFolder;
          _DMSsend this DMSsender CsendFolder [(strbuild (TfolderToList ff.subFolder))]
        )
    else
      nil;
  cbBeforeClose;
  0
;;

/*******************************************************************************
  main function, called when the server part of the module is initialized
    file -> S : not used
        <- I : nothing special
*******************************************************************************/
fun IniDMI (file) =
  let _DMSgetDef this "Data" -> dataDef in
  let getInfo dataDef "homeFolder" -> home in
  let getInfo dataDef "maxSize" -> size in
  let getInfo dataDef "FileSize" -> file in
  let getInfo dataDef "source" -> source in
  let getInfo dataDef "table" -> table in
  let getInfo dataDef "login" -> login in
  (
    if size == nil then
      nil
    else
      set maxSize = (atoi size);
    
    if file == nil then
      nil
    else
      set fileSize = (atoi file);
    
    set homeFolder = home;
    
    let _DMSgetDef this "Data" -> dataDef in 
  
    set dataDB = mkTDataBase [nil source table login];
  
    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
  );
  
  _DMScbUpload this @cbReceive;
  set folderSize = 0;
  
  /*let _DMSgetDef this "ftpAuth" -> dataDef in
  let getInfo dataDef "allAuth" -> allauth in*/
  
  let strcat "tmp/ftp/" (substr (_getlongname strcat DMSname (_DMSgetName this) "" "#") 1 16) -> name in 
  let _getpack _checkpack name -> allauth in
    if allauth == nil then
      nil
    else
      FillAuth (strextr allauth)
 
;;