mim/development/mim/vax/mimlib/network.mud

   1 <PACKAGE "NETWORK">
   2
   3 <ENTRY GET-HOST GET-SERVICE GET-PROTOCOL GET-ADDR
   4        NO-BLOCK? INTERRUPT? CONNECTION-LOST CONNECTION-READY
   5        CONNECTION-URGENT CHAN-SELECT SEND RECEIVE NET-SERVER
   6        SERVER-INIT SERVER-WAIT
   7        GET-ADDRESS LISTEN-ON-DATA CONNECT-DATA-CHANNEL
   8        GET-DATA-ADDRESS WRAP-SOCKET>
   9
  10 <USE "NETBASE">
  11
  12 <INCLUDE-WHEN <COMPILING? "NETWORK"> "NETDEFS">
  13
  14 <EXPORT "NETBASE">
  15
  16 <ADD-CHANNEL-OPS NETWORK
  17                  READ-SAFE-BUFFER NETWORK-READ-SAFE
  18                  GET-HOST NETWORK-GET ;"DONE"
  19                  GET-SERVICE NETWORK-GET        ;"DONE"
  20                  GET-PROTOCOL NETWORK-GET       ;"DONE"
  21                  GET-ADDR NETWORK-GET ;"DONE"
  22                  NO-BLOCK? NETWORK-SET
  23                  INTERRUPT? NETWORK-SET
  24                  SEND NETWORK-SEND
  25                  RECEIVE NETWORK-RECEIVE
  26                  GET-ADDRESS NET-GET-ADDRESS
  27                  LISTEN-ON-DATA NET-MAKE-ALT
  28                  CONNECT-DATA-CHANNEL NET-ACCEPT-CONN
  29                  GET-DATA-ADDRESS NET-GET-DADDR>
  30
  31 <DEFINE NETWORK-SEND (CHANNEL:<CHANNEL 'NETWORK> OPER BUF:<OR STRING UVECTOR>
  32                       "OPT" (LEN:FIX <COND (<TYPE? .BUF UVECTOR> <LENGTH .BUF>)
  33                                            (<LENGTH .BUF>)>)
  34                       "AUX" (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
  35                       (FLAG:FIX 0) RES:<OR FIX FALSE>)
  36    <COND (<N==? <LHW <C-SERVICE .DATA>> ,PROT-UDP>
  37           <SET FLAG 1>)>
  38    <COND
  39     (<SET RES
  40           <CALL SYSCALL SEND <C-SOCKET .DATA> .BUF
  41                 <COND (<TYPE? .BUF UVECTOR> <* 4 .LEN>) (T .LEN)> .FLAG>>
  42      <COND (<TYPE? .BUF UVECTOR> </ .RES 4>)
  43            (T .RES)>)>>
  44
  45 <DEFINE NETWORK-RECEIVE (CHANNEL:<CHANNEL 'NETWORK> OPER BUF:<OR UVECTOR STRING>
  46                          "OPT" (LEN:FIX <COND (<TYPE? .BUF STRING>
  47                                                <LENGTH .BUF>)
  48                                               (T <LENGTH .BUF>)>)
  49                          "AUX" (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
  50                          (FLAG:FIX 0) RES:<OR FIX FALSE>)
  51    <COND (<N==? <LHW <C-SERVICE .DATA>> ,PROT-UDP>
  52           <SET FLAG 1>)>
  53    <COND
  54     (<OR <NOT <C-TIMEOUT .DATA>>
  55          <DO-TIMEOUT .DATA>>
  56      <COND
  57       (<SET RES <ISYSCALL RECV <C-SOCKET .DATA> .BUF
  58                           <COND (<TYPE? .BUF UVECTOR> <* 4 .LEN>)(T .LEN)>
  59                           .FLAG>>
  60        <COND (<TYPE? .BUF UVECTOR> </ .RES 4>)
  61              (T .RES)>)>)>>
  62
  63 <DEFINE NETWORK-SET (CHANNEL:<CHANNEL 'NETWORK> OPER:ATOM "OPT" NEW:<OR ATOM FALSE>
  64                      "AUX" (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
  65                      FLAG:FIX)
  66    <COND (<==? .OPER INTERRUPT?>
  67           <SET FLAG ,FASYNC>)
  68          (<==? .OPER NO-BLOCK?>
  69           <SET FLAG ,FNDELAY>)>
  70    <COND
  71     (<NOT <ASSIGNED? NEW>>
  72      <NOT <0? <ANDB .FLAG <C-FLAGS .DATA>>>>)
  73     (T
  74      <C-FLAGS .DATA <ORB .FLAG <C-FLAGS .DATA>>>
  75      <PROG ((CURRENT-CONNECTION:<SPECIAL <CHANNEL 'NETWORK>> .CHANNEL))
  76         <COND
  77          (<CALL SYSCALL FCNTL <C-SOCKET .DATA> ,F-SETFL <C-FLAGS .DATA>>
  78           .NEW)>>)>>
  79
  80 <DEFINE WRAP-SOCKET (S:FIX
  81                      "AUX" (ADDR:NET-ADDRESS
  82                             <CHTYPE <STACK <IUVECTOR ,ADDR-WORD-LEN>>
  83                                     NET-ADDRESS>) (TUV <STACK <IUVECTOR 1>>))
  84    <COND (<CALL SYSCALL GETSOCKNAME .S .ADDR .TUV>
  85           <CHANNEL-OPEN NETWORK "RAND" 0 .ADDR .S>)>>
  86
  87 <DEFINE NETWORK-READ-SAFE (CHANNEL:<CHANNEL 'NETWORK> OPER
  88                            "TUPLE" STUFF
  89                            "AUX" (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
  90                            (BUF:UVECTOR <STACK <IUVECTOR 1>>)
  91                            RES:<OR FIX FALSE>
  92                            (CURRENT-CONNECTION:<SPECIAL <CHANNEL 'NETWORK>>
  93                             .CHANNEL))
  94    #DECL ((STUFF) <<PRIMTYPE VECTOR>
  95                                           [REST <OR STRING UVECTOR>
  96                                            <OR FIX FALES>]>)
  97    <COND (<OR <NETWORK-SET .CHANNEL NO-BLOCK?>
  98               <AND <SET RES <CALL SYSCALL IOCTL
  99                                   <C-SOCKET .DATA> ,FIONREAD .BUF>>
 100                    <G? <1 .BUF> 0>>>
 101           <NETWORK-READ .CHANNEL .OPER !.STUFF>)
 102          (.RES 0)>>
 103
 104 <DEFINE NETWORK-GET (CHANNEL:<CHANNEL 'NETWORK> OPER:ATOM
 105                      "AUX" (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>)
 106                      (ADDR <C-ADDR .DATA>))
 107   <COND (<==? .OPER GET-HOST>
 108          <NA-HOST .ADDR>)
 109         (<==? .OPER GET-SERVICE>
 110          <C-SERVICE .DATA>)
 111         (<==? .OPER GET-ADDR>
 112          .ADDR)
 113         (<==? .OPER GET-PROTOCOL>
 114          <LHW <C-SERVICE .DATA>>)>>
 115
 116 <DEFINE NET-PIPE-HANDLER (IGN "AUX" CHN)
 117    <COND (<AND <ASSIGNED? CURRENT-CONNECTION>
 118                <SET CHN .CURRENT-CONNECTION>>
 119           <KILL-CHANNEL .CHN>)>
 120    <COND (<NETWORK-SET .CHN INTERRUPT?>
 121           <INTERRUPT "NETWORK" .CHN CONNECTION-LOST>)>>
 122
 123 <DEFINE NET-SIGIO-HANDLER (IGN "AUX" (RBUF:UVECTOR <STACK <IUVECTOR 1>>)
 124                            (EBUF:UVECTOR <STACK <IUVECTOR 1>>) (RFL:FIX 0)
 125                            (EFL:FIX 0) (MAX:FIX -1) FOUND:<OR FALSE FIX>)
 126    <REPEAT ((L:<LIST [REST FIX CHANNEL]> ,NET-CHANNELS) S)
 127       <COND (<EMPTY? .L> <RETURN>)>
 128       <SET EFL <ORB .EFL <LSH 1 <SET S <1 .L>>>>>
 129       <SET RFL <ORB .RFL <LSH 1 .S>>>
 130       <SET MAX <MAX .MAX .S>>>
 131    <COND (<G=? .MAX 0>
 132           <1 .EBUF .EFL>
 133           <1 .RBUF .RFL>
 134           <COND
 135            (<SET FOUND <CALL SYSCALL SELECT <+ .MAX 1> .RBUF 0 .EBUF>>
 136             <POKE .EBUF CONNECTION-URGENT .MAX>
 137             <POKE .RBUF CONNECTION-READY .MAX>)>)>>
 138
 139 <DEFINE POKE (BUF:<UVECTOR [REST FIX]> WHICH MAX:FIX
 140               "AUX" (L:<LIST [REST FIX <CHANNEL 'NETWORK>]> ,NET-CHANNELS))
 141    <REPEAT ((CUR 0) (BITS <1 .BUF>) NL:<OR LIST FALSE>)
 142       <COND
 143        (<NOT <0? <ANDB .BITS <LSH 1 .CUR>>>>
 144         <COND
 145          (<SET NL <MEMQ .CUR ,NET-CHANNELS>>
 146           <INTERRUPT "NETWORK" <2 .NL> .WHICH>)>)>
 147       <COND (<G? <SET CUR <+ .CUR 1>> .MAX>
 148              <RETURN>)>>>
 149
 150 <DEFINE CHAN-SELECT (TIMEOUT:<OR FIX FLOAT FALSE>
 151                      "TUPLE" STUFF
 152                      "AUX" (RBUF <STACK <IUVECTOR 1>>)
 153                      (EBUF <STACK <IUVECTOR 1>>) (RFL 0)
 154                      (TIMEVAL <STACK <IUVECTOR 2>>)
 155                      (HANDLES <STACK <IUVECTOR </ <LENGTH .STUFF> 2> -1>>)
 156                      (MAX:FIX -1))
 157    #DECL ((STUFF) <<PRIMTYPE VECTOR>
 158                    [REST <CHANNEL 'NETWORK> <OR APPLICABLE FALSE>]>)
 159    <COND (.TIMEOUT
 160           <TIME-NUM .TIMEVAL .TIMEOUT>)>
 161    <REPEAT (CHN:<CHANNEL 'NETWORK> (TST .STUFF) H:FIX (HAND .HANDLES))
 162       <COND (<EMPTY? .TST> <RETURN>)>
 163       <COND (<SET H <CHANNEL-OP <1 .TST> FILE-HANDLE>>
 164              <1 .HAND .H>
 165              <SET MAX <MAX .H .MAX>>
 166              <SET RFL <ORB .RFL <LSH 1 .H>>>)>
 167       <SET TST <REST .TST 2>>
 168       <SET HAND <REST .HAND>>>
 169    <COND
 170     (<G=? .MAX 0>
 171      <REPEAT (RES)
 172         <1 .RBUF .RFL>
 173         <1 .EBUF .RFL>
 174         <COND (<SET RES <ISYSCALL SELECT <+ .MAX 1> .RBUF 0 .EBUF
 175                               <COND (.TIMEOUT .TIMEVAL) (T 0)>>>
 176                <COND (<INVOKE <ORB <1 .RBUF> <1 .EBUF>> .STUFF .HANDLES .MAX>
 177                       <RETURN>)>)
 178               (T
 179                <RETURN .RES>)>>)>>
 180
 181 <DEFINE INVOKE (BITS:FIX STUFF:<<PRIMTYPE VECTOR> [REST <CHANNEL 'NETWORK>
 182                                                    <OR APPLICABLE FALSE>]>
 183                 HANDLES:<UVECTOR [REST FIX]> MAX:FIX
 184                 "AUX" (CUR:FIX 0))
 185    <REPEAT (HH:UVECTOR TS:<PRIMTYPE VECTOR>)
 186       <COND (<NOT <0? <ANDB <LSH 1 .CUR> .BITS>>>
 187              <SET HH <MEMQ .CUR .HANDLES>>
 188              <SET TS <REST .STUFF <* 2 <- <LENGTH .HANDLES> <LENGTH .HH>>>>>
 189              <COND (<NOT <2 .TS>> <RETURN>)>
 190              <APPLY <2 .TS> <1 .TS>>)>
 191       <COND (<G? <SET CUR <+ .CUR 1>> .MAX> <RETURN <>>)>>>
 192
 193 <COND (<GASSIGNED? NET-PIPE-HANDLER>
 194        <ON <HANDLER "PIPE" ,NET-PIPE-HANDLER>>)>
 195
 196 <COND (<GASSIGNED? NET-SIGIO-HANDLER>
 197        <ON <HANDLER "IOINT" ,NET-SIGIO-HANDLER>>
 198        <ON <HANDLER "SOCKET" ,NET-SIGIO-HANDLER>>)>
 199
 200 \f
 201 <DEFINE SERVER-WAIT (S:FIX "OPT" (TIMEOUT:<OR FIX FLOAT FALSE> <>)
 202                      (ADDR:NET-ADDRESS <CHTYPE <STACK <IUVECTOR ,ADDR-WORD-LEN>>
 203                                                NET-ADDRESS>)
 204                      "AUX" NS (BUF <STACK <IUVECTOR 1>>) RS
 205                      (TO <STACK <IUVECTOR 2>>) RES
 206                      (PT <STACK <UVECTOR ,ADDR-LEN>>))
 207    <COND (.TIMEOUT
 208           <TIME-NUM .TO .TIMEOUT>)
 209          (T
 210           <SET TO 0>)>
 211    <SET RS <RHW .S>>
 212    <1 .BUF <LSH 1 .RS>>
 213    <COND (<SET RES
 214                <ISYSCALL SELECT <+ .RS 1> .BUF 0 0 .TO>:<OR FIX FALSE>>
 215           <COND (<0? .RES> ,TIMED-OUT)
 216                 (T
 217                  <COND (<==? <LHW .S> ,SOCK-STREAM>
 218                         <COND (<SET S <ISYSCALL ACCEPT .RS .ADDR .PT>>
 219                                <CHANNEL-OPEN NETWORK "SERVER" 0
 220                                              .ADDR .S>)>)
 221                        (T
 222                         <ERROR NOT-SUPPORTED .S SERVER-WAIT>)>)>)>>
 223
 224 <DEFINE SERVER-INIT (SERVICE:FIX "OPT" (HOST:FIX 0)
 225                      "AUX" (PROT <LHW .SERVICE>)
 226                      (SERVSOCK <RHW .SERVICE>) KIND S ERR
 227                      (ADDR <CHTYPE <STACK <IUVECTOR ,ADDR-WORD-LEN>>
 228                                    NET-ADDRESS>))
 229    <COND (<==? .PROT ,PROT-UDP> <SET KIND ,SOCK-DGRAM>)
 230          (T <SET KIND ,SOCK-STREAM>)>
 231    <COND (<SET S <CALL SYSCALL SOCKET ,AF-INET .KIND .PROT>>
 232           <BUILD-ADDRESS .SERVICE .HOST .ADDR>
 233           <COND
 234            (<==? .KIND ,SOCK-STREAM>
 235             <COND (<AND <SET ERR <CALL SYSCALL BIND .S .ADDR ,ADDR-LEN>>
 236                         <SET ERR <CALL SYSCALL LISTEN .S 5>>>
 237                    <PUTLHW .S .KIND>)
 238                   (T
 239                    <CALL SYSCALL CLOSE .S>
 240                    .ERR)>)
 241            (T
 242             <COND (<SET ERR <CALL SYSCALL BIND .S .ADDR ,ADDR-LEN>>
 243                    <PUTLHW .S .KIND>)
 244                   (T
 245                    <CALL SYSCALL CLOSE .S>
 246                    .ERR)>)>)>>
 247
 248 <DEFINE NET-SERVER (SERVICE:FIX ROUTINE:APPLICABLE "OPTIONAL" (H:FIX 0)
 249                     "AUX"
 250                     S NS
 251                     (NADDR <CHTYPE <STACK <IUVECTOR ,ADDR-WORD-LEN>>
 252                                    NET-ADDRESS>)
 253                     (PT <STACK <IUVECTOR 1>>))
 254    #DECL ((SERVICE H) FIX)
 255    <COND (<SET S <SERVER-INIT .SERVICE .H>>
 256           <COND (<==? <LHW .S> ,SOCK-STREAM>
 257                  <REPEAT (CH)
 258                     <COND (<SET CH <SERVER-WAIT .S <> .NADDR>>
 259                            <APPLY .ROUTINE .CH>)
 260                           (T
 261                            <CALL SYSCALL CLOSE .S>
 262                            <RETURN .CH>)>>)
 263                 (T
 264                  <COND (<NOT <GASSIGNED? MSG-BUF>>
 265                         <SETG MSG-BUF <ISTRING 512>>)>
 266                  <SET S <RHW .S>>
 267                  <REPEAT (LEN)
 268                     <COND (<SET LEN <ISYSCALL RECVFROM .S ,MSG-BUF 512
 269                                               0 .NADDR .PT>>
 270                            <APPLY .ROUTINE ,MSG-BUF .LEN .NADDR .PT>)
 271                           (T
 272                            <CALL SYSCALL CLOSE .S>
 273                            <RETURN .LEN>)>>)>)>>
 274
 275 <GDECL (MSG-BUF) STRING>
 276 \f
 277 <DEFINE NET-GET-ADDRESS (CHANNEL:<CHANNEL 'NETWORK> OPER
 278                          "OPT" (ADDR:<OR NET-ADDRESS FALSE> <>) "AUX"
 279                          (DATA:CONNECTION <CHANNEL-DATA .CHANNEL>))
 280    <GET-ADDRESS <C-SOCKET .DATA> .ADDR>>
 281
 282 <DEFINE GET-ADDRESS (SOCK:FIX "OPT" (ADDR:<OR NET-ADDRESS FALSE> <>)
 283                      "AUX" (TBUF <STACK <UVECTOR ,ADDR-LEN>>))
 284    <COND (<NOT .ADDR> <SET ADDR <CHTYPE <IUVECTOR ,ADDR-WORD-LEN 0>
 285                                         NET-ADDRESS>>)>
 286    <CALL SYSCALL GETSOCKNAME .SOCK .ADDR .TBUF>
 287    .ADDR>
 288
 289 <DEFINE NET-MAKE-ALT (C:<CHANNEL 'NETWORK> OPER
 290                       "OPT" (TYPE:FIX ,SOCK-STREAM) (PORT 0)
 291                       "AUX" S RES NC (DATA:CONNECTION <CHANNEL-DATA .C>)
 292                       (ADDR <CHTYPE <STACK <IUVECTOR ,ADDR-WORD-LEN 0>>
 293                                     NET-ADDRESS>))
 294    <COND (<C-ALTCHANNEL .DATA>)
 295          (<SET S <CALL SYSCALL SOCKET ,AF-INET
 296                        .TYPE
 297                        <COND (<==? .TYPE ,SOCK-STREAM> ,PROT-TCP)
 298                              (T ,PROT-UDP)>>>
 299           <CHANNEL-OP .C GET-ADDRESS .ADDR>
 300           <IN-ADDR-PORT .ADDR .PORT>
 301           <COND (<SET RES <CALL SYSCALL BIND .S .ADDR ,ADDR-LEN>>
 302                  <COND (<SET RES <CALL SYSCALL LISTEN .S 1>>
 303                         <C-ALTCHANNEL .DATA .S>
 304                         .C)
 305                        (T
 306                         <CALL SYSCALL CLOSE .S>
 307                         .RES)>)
 308                 (T
 309                  <CALL SYSCALL CLOSE .S>
 310                  .RES)>)>>
 311
 312 <DEFINE NET-GET-DADDR (C:<CHANNEL 'NETWORK> OPER
 313                        "OPT" (ADDR:<OR NET-ADDRESS FALSE> <>)
 314                        "AUX" (DATA:CONNECTION <CHANNEL-DATA .C>) NC)
 315    <COND (<SET NC <C-ALTCHANNEL .DATA>>
 316           <COND (<TYPE? .NC FIX>
 317                  <GET-ADDRESS .NC .ADDR>)
 318                 (T
 319                  <CHANNEL-OP .NC GET-ADDRESS .ADDR>)>)>>
 320
 321 <DEFINE NET-ACCEPT-CONN (C:<CHANNEL 'NETWORK> OPER "OPT" (SERVICE:FIX 0)
 322                          "AUX" (DATA:CONNECTION <CHANNEL-DATA .C>) NC
 323                          (NADDR:NET-ADDRESS
 324                           <CHTYPE <STACK <IUVECTOR ,ADDR-WORD-LEN 0>>
 325                                   NET-ADDRESS>) (BUF <STACK <IUVECTOR 1>>)
 326                          (PT:UVECTOR <STACK <IUVECTOR 1>>) RES:<OR FIX FALSE>
 327                          NS:<OR FIX FALSE> CH)
 328    <COND (<TYPE? <SET NC <C-ALTCHANNEL .DATA>> FIX>
 329           <COND (<OR <NOT <C-TIMEOUT .DATA>>
 330                      <AND <SET RES <ISYSCALL SELECT <+ .NC 1>
 331                                              <1 .BUF <LSH 1 .NC>> 0 0
 332                                              <C-TIMEOUT .DATA>>>
 333                           <NOT <0? .RES>>>>
 334                  <COND (<SET NS <ISYSCALL ACCEPT .NC .NADDR .PT>>
 335                         <SET CH <CHANNEL-OPEN NETWORK "DATA" .SERVICE .NADDR .NS>>
 336                         <C-ALTCHANNEL .DATA .CH>)>
 337                  <CALL SYSCALL CLOSE .NC>
 338                  <COND (.NS .CH)>)
 339                 (<0? .RES> ,TIMED-OUT)
 340                 (.RES)>)
 341          (.NC #FALSE ("ALREADY CONNECTED"))
 342          (T #FALSE ("NOT LISTENING"))>>
 343
 344 <ENDPACKAGE>