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