ghc/lib/misc/BSD.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1995-1997
   3 %
   4 \section[BSD]{Misc BSD bindings}
   5
   6 The @BSD@ module defines Haskell bindings to network programming
   7 functionality that is only provided by BSD-style APIs.
   8
   9 \begin{code}
  10 {-# OPTIONS -#include "cbits/ghcSockets.h" #-}
  11
  12 module BSD (
  13
  14     HostName,
  15     getHostName,            -- :: IO HostName
  16
  17     ServiceName,
  18     getServiceByName,       -- :: ServiceName -> IO ServiceEntry
  19     getServicePortNumber,   -- :: ServiceName -> IO PortNumber
  20
  21     ServiceEntry(..),
  22     getServiceEntry,        -- :: IO ServiceEntry
  23     setServiceEntry,        -- :: Bool -> IO ()
  24     endServiceEntry,        -- :: IO ()
  25     getServiceEntries,      -- :: Bool -> IO [ServiceEntry]
  26
  27     ProtocolName,
  28     ProtocolEntry(..),
  29     getProtocolByName,      -- :: ProtocolName   -> IO ProtocolEntry
  30     getProtocolByNumber,    -- :: ProtocolNumber -> IO ProtcolEntry
  31
  32     setProtocolEntry,       -- :: Bool -> IO ()
  33     getProtocolEntry,       -- :: IO ProtocolEntry
  34     endProtocolEntry,       -- :: IO ()
  35     getProtocolEntries,     -- :: Bool -> IO [ProtocolEntry]
  36
  37     PortNumber,
  38     getProtocolNumber,      -- :: ProtocolName -> ProtocolNumber
  39
  40     HostEntry(..),
  41     getHostByName,          -- :: HostName -> IO HostEntry
  42     getHostByAddr,          -- :: HostAddress -> Family -> IO HostEntry
  43
  44     setHostEntry,           -- :: Bool -> IO ()
  45     getHostEntry,           -- :: IO HostEntry
  46     endHostEntry,           -- :: IO ()
  47     getHostEntries,         -- :: Bool -> IO [HostEntry]
  48
  49     NetworkName,
  50     NetworkAddr,
  51     NetworkEntry(..),
  52     getNetworkByName,       -- :: NetworkName -> IO NetworkEntry
  53     getNetworkByAddr,       -- :: NetworkAddr -> Family -> IO NetworkEntry
  54     setNetworkEntry,        -- :: Bool -> IO ()
  55     getNetworkEntry,        -- :: IO NetworkEntry
  56     endNetworkEntry,        -- :: IO ()
  57     getNetworkEntries       -- :: Bool -> IO [NetworkEntry]
  58
  59 ) where
  60
  61
  62 import GlaExts
  63
  64 import PrelIOBase
  65
  66 import Foreign  -- Addr..
  67 import PackedString ( byteArrayToPS, unpackPS )
  68
  69 import PosixUtil  ( strcpy, unvectorize )
  70 import SocketPrim
  71
  72 \end{code}
  73
  74
  75 %***************************************************************************
  76 %*                                                                         *
  77 \subsection[BSD-DBTypes]{Service, Protocol \& Host Database Types}
  78 %*                                                                         *
  79 %***************************************************************************
  80
  81 \begin{code}
  82 type HostName = String
  83 type ProtocolName = String
  84 type ProtocolNumber = Int
  85 type ServiceName = String
  86 type PortNumber = Int
  87
  88 data ProtocolEntry =
  89   ProtocolEntry
  90      ProtocolName       -- Official Name
  91      [ProtocolName]     -- aliases
  92      Int                -- Protocol Number
  93
  94 data ServiceEntry  =
  95   ServiceEntry
  96      ServiceName        -- Official Name
  97      [ServiceName]      -- aliases
  98      PortNumber         -- Port Number
  99      ProtocolName       -- Protocol
 100
 101 data HostEntry =
 102   HostEntry
 103      HostName           -- Official Name
 104      [HostName]         -- aliases
 105      Family             -- Host Type (currently AF_INET)
 106      [HostAddress]      -- Set of Network Addresses
 107
 108 \end{code}
 109
 110 %***************************************************************************
 111 %*                                                                         *
 112 \subsection[BSD-DBAccess]{Service, Protocol Host Database Access}
 113 %*                                                                         *
 114 %***************************************************************************
 115
 116 Calling @getServiceByName@ for a given service and protocol returns the
 117 systems service entry.  This should be used to find the port numbers
 118 for standard protocols such as SMTP and FTP.  The remaining three
 119 functions should be used for browsing the service database
 120 sequentially.
 121
 122 Calling @setServiceEntry@ with \tr{True} indicates that the service
 123 database should be left open between calls to @getServiceEntry@.  To
 124 close the database a call to @endServiceEntry@ is required.  This
 125 database file is usually stored in the file /etc/services.
 126
 127 \begin{code}
 128 getServiceByName :: ServiceName         -- Service Name
 129                  -> ProtocolName        -- Protocol Name
 130                  -> IO ServiceEntry     -- Service Entry
 131 getServiceByName name proto = do
 132  ptr <- _ccall_ getservbyname name proto
 133  if ptr == ``NULL''
 134     then fail (IOError Nothing NoSuchThing "no such service entry")
 135     else unpackServiceEntry ptr
 136
 137 getServiceByPort :: PortNumber ->
 138                     ProtocolName ->
 139                     IO ServiceEntry
 140 getServiceByPort port proto = do
 141     ptr <- _ccall_ getservbyport port proto
 142     if ptr == ``NULL''
 143        then fail (IOError Nothing NoSuchThing "no such service entry")
 144        else unpackServiceEntry ptr
 145
 146 getServicePortNumber :: ServiceName -> IO PortNumber
 147 getServicePortNumber name = do
 148     (ServiceEntry _ _ port _) <- getServiceByName name "tcp"
 149     return port
 150
 151 getServiceEntry :: IO ServiceEntry
 152 getServiceEntry = do
 153     ptr <- _ccall_ getservent
 154     if ptr == ``NULL''
 155        then fail (IOError Nothing NoSuchThing "no such service entry")
 156        else unpackServiceEntry ptr
 157
 158 setServiceEntry :: Bool -> IO ()
 159 setServiceEntry flg = _ccall_ setservent stayOpen
 160  where stayOpen = if flg then 1 else 0
 161
 162 endServiceEntry :: IO ()
 163 endServiceEntry = _ccall_ endservent
 164
 165 getServiceEntries :: Bool -> IO [ServiceEntry]
 166 getServiceEntries stayOpen = do
 167   setServiceEntry stayOpen
 168   getEntries (getServiceEntry) (endServiceEntry)
 169
 170 \end{code}
 171
 172 The following relate directly to the corresponding \tr{UNIX} {C} calls for
 173 returning the protocol entries. The protocol entry is represented by
 174 the Haskell type @ProtocolEntry@.
 175
 176 As for @setServiceEntry@ above, calling @setProtocolEntry@.
 177 determines whether or not the protocol database file, usually
 178 \tr{/etc/protocols}, is to be kept open between calls of
 179 @getProtocolEntry@. Similarly,
 180
 181 \begin{code}
 182 getProtocolByName   :: ProtocolName -> IO ProtocolEntry
 183 getProtocolByNumber :: PortNumber   -> IO ProtocolEntry
 184 getProtocolNumber   :: ProtocolName -> IO ProtocolNumber
 185
 186 setProtocolEntry    :: Bool -> IO ()    -- Keep DB Open ?
 187 getProtocolEntry    :: IO ProtocolEntry -- Next Protocol Entry from DB
 188 endProtocolEntry    :: IO ()
 189 getProtocolEntries  :: Bool -> IO [ProtocolEntry]
 190 \end{code}
 191
 192 \begin{code}
 193 --getProtocolByName :: ProtocolName -> IO ProtocolEntry
 194 getProtocolByName name = do
 195  ptr <- _ccall_ getprotobyname name
 196  if (ptr == ``NULL'' )
 197     then fail (IOError Nothing NoSuchThing "no such protocol entry")
 198     else unpackProtocolEntry ptr
 199
 200 --getProtocolByNumber :: PortNumber -> IO ProtocolEntry
 201 getProtocolByNumber num = do
 202  ptr <- _ccall_ getprotobynumber num
 203  if ptr == ``NULL''
 204     then fail (IOError Nothing NoSuchThing "no such protocol entry")
 205     else unpackProtocolEntry ptr
 206
 207 --getProtocolNumber :: ProtocolName -> IO ProtocolNumber
 208 getProtocolNumber proto = do
 209  (ProtocolEntry _ _ num) <- getProtocolByName proto
 210  return num
 211
 212 --getProtocolEntry :: IO ProtocolEntry  -- Next Protocol Entry from DB
 213 getProtocolEntry = do
 214  ptr <- _ccall_ getprotoent
 215  if ptr == ``NULL''
 216     then fail (IOError Nothing NoSuchThing "no such protocol entry")
 217     else unpackProtocolEntry ptr
 218
 219 --setProtocolEntry :: Bool -> IO ()     -- Keep DB Open ?
 220 setProtocolEntry flg = _ccall_ setprotoent v
 221  where v = if flg then 1 else 0
 222
 223 --endProtocolEntry :: IO ()
 224 endProtocolEntry = _ccall_ endprotoent
 225
 226 --getProtocolEntries :: Bool -> IO [ProtocolEntry]
 227 getProtocolEntries stayOpen = do
 228   setProtocolEntry stayOpen
 229   getEntries (getProtocolEntry) (endProtocolEntry)
 230
 231 \end{code}
 232
 233 \begin{code}
 234 getHostByName :: HostName -> IO HostEntry
 235 getHostByName name = do
 236     ptr <- _ccall_ gethostbyname name
 237     if ptr == ``NULL''
 238        then fail (IOError Nothing NoSuchThing "no such host entry")
 239        else unpackHostEntry ptr
 240
 241 getHostByAddr :: Family -> HostAddress -> IO HostEntry
 242 getHostByAddr family addr = do
 243  ptr <- _casm_ ``struct in_addr addr;
 244                  addr.s_addr = htonl(%0);
 245                  %r = gethostbyaddr ((char*)&addr, sizeof(struct in_addr), %1);''
 246                addr
 247                (packFamily family)
 248  if ptr == ``NULL''
 249     then fail (IOError Nothing NoSuchThing "no such host entry")
 250     else unpackHostEntry ptr
 251
 252 getHostEntry :: IO HostEntry
 253 getHostEntry = do
 254  ptr <- _ccall_ gethostent
 255  if ptr == ``NULL''
 256     then fail (IOError Nothing NoSuchThing "unable to retrieve host entry")
 257     else unpackHostEntry ptr
 258
 259 setHostEntry :: Bool -> IO ()
 260 setHostEntry flg = _ccall_ sethostent v
 261  where v = if flg then 1 else 0
 262
 263 endHostEntry :: IO ()
 264 endHostEntry = _ccall_ endhostent
 265
 266 getHostEntries :: Bool -> IO [HostEntry]
 267 getHostEntries stayOpen = do
 268   setHostEntry stayOpen
 269   getEntries (getHostEntry) (endHostEntry)
 270
 271 \end{code}
 272
 273 %***************************************************************************
 274 %*                                                                         *
 275 \subsection[BSD-Network]{Accessing network information}
 276 %*                                                                         *
 277 %***************************************************************************
 278
 279 Same set of access functions as for accessing host,protocol and service
 280 system info, this time for the types of networks supported.
 281
 282 \begin{code}
 283 type NetworkAddr = Word
 284 type NetworkName = String
 285
 286 data NetworkEntry =
 287   NetworkEntry
 288      NetworkName   -- official name
 289      [NetworkName] -- aliases
 290      Family        -- type
 291      NetworkAddr
 292
 293 getNetworkByName :: NetworkName -> IO NetworkEntry
 294 getNetworkByName name = do
 295  ptr <- _ccall_ getnetbyname name
 296  if ptr == ``NULL''
 297     then fail (IOError Nothing NoSuchThing "no such network entry")
 298     else unpackNetworkEntry ptr
 299
 300 getNetworkByAddr :: NetworkAddr -> Family -> IO NetworkEntry
 301 getNetworkByAddr addr family = do
 302  ptr <-  _casm_ ``long naddr = htonl(%0);
 303                   %r = getnetbyaddr (naddr, (int)%1);''
 304                 addr
 305                 (packFamily family)
 306  if ptr == ``NULL''
 307     then fail (IOError Nothing NoSuchThing "no such network entry")
 308     else unpackNetworkEntry ptr
 309
 310 getNetworkEntry :: IO NetworkEntry
 311 getNetworkEntry = do
 312  ptr <- _ccall_ getnetent
 313  if ptr == ``NULL''
 314    then fail (IOError Nothing NoSuchThing "no more network entries")
 315    else unpackNetworkEntry ptr
 316
 317 setNetworkEntry :: Bool -> IO ()
 318 setNetworkEntry flg = _ccall_ setnetent v
 319  where v = if flg then 1 else 0
 320
 321 endNetworkEntry :: IO ()
 322 endNetworkEntry = _ccall_ endnetent
 323
 324 getNetworkEntries :: Bool -> IO [NetworkEntry]
 325 getNetworkEntries stayOpen = do
 326   setNetworkEntry stayOpen
 327   getEntries (getNetworkEntry) (endNetworkEntry)
 328
 329 \end{code}
 330
 331 %***************************************************************************
 332 %*                                                                         *
 333 \subsection[BSD-Misc]{Miscellaneous Functions}
 334 %*                                                                         *
 335 %***************************************************************************
 336
 337 Calling @getHostName@ returns the standard host name for the current
 338 processor, as set at boot time.
 339
 340 \begin{code}
 341 getHostName :: IO HostName
 342 getHostName = do
 343   ptr <- stToIO (newCharArray (0,256))
 344   rc  <- _casm_ ``%r=gethostname(%0, 256);'' ptr
 345   ba  <- stToIO (unsafeFreezeByteArray ptr)
 346   if rc == -1
 347      then fail (userError "getHostName: unable to determine host name")
 348      else return (unpackPS (byteArrayToPS ba))
 349 \end{code}
 350
 351 Helper function used by the exported functions that provides a
 352 Haskellised view of the enumerator functions:
 353
 354 \begin{code}
 355 getEntries :: IO a  -- read
 356            -> IO () -- at end
 357            -> IO [a]
 358 getEntries getOne atEnd = loop
 359   where
 360    loop =
 361      catch (do { v <- getOne; vs <- loop ; return (v:vs) })
 362            (\ _ -> do { atEnd; return [] } )
 363 \end{code}
 364
 365
 366 \begin{verbatim}
 367  struct    servent {
 368                char *s_name;  /* official name of service */
 369                char **s_aliases;   /* alias list */
 370                int  s_port;        /* port service resides at */
 371                char *s_proto; /* protocol to use */
 372           };
 373
 374      The members of this structure are:
 375           s_name              The official name of the service.
 376           s_aliases           A zero terminated list of alternate
 377                               names for the service.
 378           s_port              The port number at which  the  ser-
 379                               vice  resides.   Port  numbers  are
 380                               returned  in  network  short   byte
 381                               order.
 382           s_proto             The name of  the  protocol  to  use
 383                               when contacting the service.
 384 \end{verbatim}
 385
 386 \begin{code}
 387 unpackServiceEntry :: Addr -> PrimIO ServiceEntry
 388 unpackServiceEntry ptr = do
 389  str     <- _casm_ ``%r = ((struct servent*)%0)->s_name;'' ptr
 390  name    <- strcpy str
 391  alias   <- _casm_ ``%r = ((struct servent*)%0)->s_aliases;'' ptr
 392  aliases <- unvectorize alias 0
 393   -- Note: port numbers are represented as ints in (struct servent), but
 394   -- inet port numbers are 16-bit, hence the use of ntohs() rather than ntohl()
 395  port    <- _casm_ ``%r = (int)ntohs((int)(((struct servent*)%0)->s_port));'' ptr
 396  str     <- _casm_ ``%r = (char *)((struct servent*)%0)->s_proto;'' ptr
 397  proto   <- strcpy str
 398  return (ServiceEntry name aliases port proto)
 399
 400 -------------------------------------------------------------------------------
 401
 402 unpackProtocolEntry :: Addr -> IO ProtocolEntry
 403 unpackProtocolEntry ptr = do
 404  str     <- _casm_ ``%r = ((struct protoent*)%0)->p_name;'' ptr
 405  name    <- strcpy str
 406  alias   <- _casm_ ``%r = ((struct protoent*)%0)->p_aliases;'' ptr
 407  aliases <- unvectorize alias 0
 408  proto   <- _casm_ ``%r = ((struct protoent*)%0)->p_proto;'' ptr
 409  return (ProtocolEntry name aliases proto)
 410
 411 -------------------------------------------------------------------------------
 412
 413 unpackHostEntry :: Addr -> IO HostEntry
 414 unpackHostEntry ptr = do
 415   str      <- _casm_ ``%r = ((struct hostent*)%0)->h_name;'' ptr
 416   name     <- strcpy str
 417   alias    <- _casm_ ``%r = ((struct hostent*)%0)->h_aliases;'' ptr
 418   aliases  <- unvectorize alias 0
 419   addrList <- unvectorizeHostAddrs ptr 0
 420   return (HostEntry name aliases AF_INET addrList)
 421
 422 -------------------------------------------------------------------------------
 423
 424 unpackNetworkEntry :: Addr -> IO NetworkEntry
 425 unpackNetworkEntry ptr = do
 426   str     <- _casm_ ``%r = ((struct netent*)%0)->n_name;'' ptr
 427   name    <- strcpy str
 428   alias   <- _casm_ ``%r = ((struct netent*)%0)->n_aliases;'' ptr
 429   aliases <- unvectorize alias 0
 430   fam     <- _casm_ ``%r = ((struct netent*)%0)->n_addrtype;'' ptr
 431   na      <- _casm_ ``%r = ((struct netent*)%0)->n_net;'' ptr
 432   return (NetworkEntry name aliases (unpackFamily fam) na)
 433
 434 -------------------------------------------------------------------------------
 435
 436 unvectorizeHostAddrs :: Addr -> Int -> IO [Word]
 437 unvectorizeHostAddrs ptr n
 438   | str == ``NULL'' = return []
 439   | otherwise = do
 440         x <- _casm_ ``{ unsigned long tmp;
 441                    if ((((struct hostent*)%0)->h_addr_list[(int)%1]) == NULL)
 442                       tmp=(W_)0;
 443                    else
 444                       tmp = (W_)ntohl(((struct in_addr *)(((struct hostent*)%0)->h_addr_list[(int)%1]))->s_addr);
 445                    %r=(W_)tmp;} ''
 446                 ptr n
 447         xs <- unvectorizeHostAddrs ptr (n+1)
 448         return (x : xs)
 449   where str = indexAddrOffAddr ptr n
 450
 451 \end{code}