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