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