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