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