ghc/lib/ghc/BSD.lhs

   1 `%
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1995
   3 %
   4 % Last Modified: Fri Jul 21 12:08:19 1995
   5 % Darren J Moffat <moffatd@dcs.gla.ac.uk>
   6 \section[BSD]{Misc BSD bindings}
   7
   8
   9 \begin{code}
  10 module BSD (
  11
  12     HostName(..),
  13     ProtocolName(..),
  14     ServiceName(..),
  15     PortNumber(..),
  16     ProtocolEntry(..),
  17     ServiceEntry(..),
  18     HostEntry(..),
  19 --    SelectData(..),
  20
  21     getHostName,            -- :: IO String
  22 --    select,               -- :: SelectData -> IO (Maybe SelectData)
  23
  24     getServiceByName,       -- :: ServiceName -> IO ServiceEntry
  25     getServicePortNumber,   -- :: ServiceName -> IO PortNumber
  26     getServiceEntry,        -- :: IO ServiceEntry
  27     setServiceEntry,        -- :: Bool -> IO ()
  28     endServiceEntry,        -- :: IO ()
  29
  30     getProtocolByName,      -- :: ProtocolName -> IO ProtocolEntry
  31     getProtocolByNumber,    -- :: ProtocolNumber -> IO ProtcolEntry
  32     getProtocolNumber,      -- :: ProtocolName -> ProtocolNumber
  33     getProtocolEntry,       -- :: IO ProtocolEntry
  34     setProtocolEntry,       -- :: Bool -> IO ()
  35     endProtocolEntry,       -- :: IO ()
  36
  37     getHostByName,          -- :: HostName -> IO HostEntry
  38     getHostByAddr,          -- :: Family -> HostAddress -> IO HostEntry
  39     getHostEntry,           -- :: IO HostEntry
  40     setHostEntry,           -- :: Bool -> IO ()
  41     endHostEntry,           -- :: IO ()
  42
  43     -- make interface self-sufficient:
  44     Family
  45 ) where
  46
  47 import LibPosixUtil
  48 import SocketPrim
  49 import PreludePrimIO
  50 import PreludeGlaMisc
  51 import PreludeGlaST
  52 \end{code}
  53
  54
  55 %***************************************************************************
  56 %*                                                                         *
  57 \subsection[BSD-DBTypes]{Service, Protocol \& Host Database Types}
  58 %*                                                                         *
  59 %***************************************************************************
  60
  61 \begin{code}
  62
  63 type HostName = String
  64 type ProtocolName = String
  65 type ProtocolNumber = Int
  66 type ServiceName = String
  67 type PortNumber = Int
  68 data ProtocolEntry = ProtocolEntry
  69                      ProtocolName       -- Official Name
  70                      [ProtocolName]     -- Set of Aliases
  71                      Int                -- Protocol Number
  72
  73 data ServiceEntry  = ServiceEntry
  74                      ServiceName        -- Official Name
  75                      [ServiceName]      -- Set of Aliases
  76                      PortNumber         -- Port Number
  77                      ProtocolName       -- Protocol
  78
  79 data HostEntry = HostEntry
  80                  HostName               -- Official Name
  81                  [HostName]             -- Set of Aliases
  82                  Family                 -- Host Type (currently AF_INET)
  83                  [HostAddress]          -- Set of Network Addresses
  84 \end{code}
  85
  86
  87
  88 %***************************************************************************
  89 %*                                                                         *
  90 \subsection[LibSocket-DBAccess]{Service, Protocol Host Database Access}
  91 %*                                                                         *
  92 %***************************************************************************
  93
  94
  95
  96 Calling $getServiceByName$ for a given service and protocol returns the
  97 systems service entry.  This should be used to find the port numbers
  98 for standard protocols such as smtp and FTP.  The remaining three
  99 functions should be used for browsing the service database
 100 sequentially.
 101
 102 Calling $setServiceEntry$ with $True$ indicates that the service
 103 database should be left open between calls to $getServiceEntry$.  To
 104 close the database a call to $endServiceEntry$ is required.  This
 105 database file is usually stored in the file /etc/services.
 106
 107
 108 \begin{code}
 109 getServiceByName :: ServiceName ->      -- Service Name
 110                     ProtocolName ->     -- Protocol Name
 111                     IO ServiceEntry     -- Service Entry
 112 getServiceByName name proto =
 113         _ccall_ getservbyname name proto        `thenPrimIO` \ ptr ->
 114         if ptr == ``NULL'' then
 115           failWith (NoSuchThing "no such service entry")
 116         else
 117           unpackServiceEntry ptr                `thenPrimIO` \ servent ->
 118           return servent
 119
 120 getServiceByPort :: PortNumber ->
 121                     ProtocolName ->
 122                     IO ServiceEntry
 123 getServiceByPort port proto =
 124         _ccall_ getservbyport port proto        `thenPrimIO` \ ptr ->
 125         if ptr == ``NULL'' then
 126           failWith (NoSuchThing "no such service entry")
 127         else
 128           unpackServiceEntry ptr                `thenPrimIO` \ servent ->
 129           return servent
 130
 131 getServicePortNumber :: ServiceName -> IO PortNumber
 132 getServicePortNumber name =
 133         getServiceByName name "tcp"     >>= \ (ServiceEntry _ _ port _) ->
 134         return port
 135
 136 getServiceEntry :: IO ServiceEntry
 137 getServiceEntry =
 138         _ccall_ getservent                      `thenPrimIO` \ ptr ->
 139         if ptr == ``NULL'' then
 140           failWith (NoSuchThing "no such service entry")
 141         else
 142           unpackServiceEntry ptr                `thenPrimIO` \ servent ->
 143           return servent
 144
 145 setServiceEntry :: Bool -> IO ()
 146 setServiceEntry True  = primIOToIO (_ccall_ setservent 1)
 147 setServiceEntry False = primIOToIO (_ccall_ setservent 0)
 148
 149 endServiceEntry :: IO ()
 150 endServiceEntry = primIOToIO (_ccall_ endservent)
 151
 152 \end{code}
 153
 154 The following relate directly to the corresponding UNIX C calls for
 155 returning the protocol entries. The protocol entry is represented by
 156 the Haskell type type ProtocolEntry = (String, [String], Int).
 157
 158 As for $setServiceEntry$ above, calling $setProtocolEntry$.
 159 determines whether or not the protocol database file, usually
 160 /etc/protocols, is to be kept open between calls of
 161 $getProtocolEntry$.
 162
 163 \begin{code}
 164 getProtocolByName :: ProtocolName ->    -- Protocol Name
 165                      IO ProtocolEntry   -- Protocol Entry
 166 getProtocolByName name =
 167         _ccall_ getprotobyname name             `thenPrimIO` \ ptr ->
 168         if ptr == ``NULL'' then
 169           failWith (NoSuchThing "no such protocol entry")
 170         else
 171           unpackProtocolEntry ptr                `thenPrimIO` \ protoent ->
 172           return protoent
 173
 174 getProtocolByNumber :: PortNumber ->    -- Protocol Number
 175                        IO ProtocolEntry -- Protocol Entry
 176 getProtocolByNumber num =
 177         _ccall_ getprotobynumber num            `thenPrimIO` \ ptr ->
 178         if ptr == ``NULL'' then
 179           failWith (NoSuchThing "no such protocol entry")
 180         else
 181           unpackProtocolEntry ptr                `thenPrimIO` \ protoent ->
 182           return protoent
 183
 184 getProtocolNumber :: ProtocolName -> IO ProtocolNumber
 185 getProtocolNumber proto =
 186         getProtocolByName proto         >>= \ (ProtocolEntry _ _ num) ->
 187         return num
 188
 189 getProtocolEntry :: IO ProtocolEntry    -- Next Protocol Entry from DB
 190 getProtocolEntry =
 191         _ccall_ getprotoent                     `thenPrimIO` \ ptr ->
 192         if ptr == ``NULL'' then
 193           failWith (NoSuchThing "no such protocol entry")
 194         else
 195           unpackProtocolEntry ptr               `thenPrimIO` \ protoent ->
 196           return protoent
 197
 198 setProtocolEntry :: Bool -> IO ()       -- Keep DB Open ?
 199 setProtocolEntry True  = primIOToIO (_ccall_ setprotoent 1)
 200 setProtocolEntry False = primIOToIO (_ccall_ setprotoent 0)
 201
 202 endProtocolEntry :: IO ()
 203 endProtocolEntry = primIOToIO (_ccall_ endprotoent)
 204
 205 \end{code}
 206
 207
 208
 209
 210 \begin{code}
 211 getHostByName :: HostName -> IO HostEntry
 212 getHostByName name =
 213         _ccall_ gethostbyname name              `thenPrimIO` \ ptr ->
 214         if ptr == ``NULL'' then
 215           failWith (NoSuchThing "no such host entry")
 216         else
 217           unpackHostEntry ptr                   `thenPrimIO` \ hostent ->
 218           return hostent
 219
 220 getHostByAddr :: Family -> HostAddress -> IO HostEntry
 221 getHostByAddr family addr =
 222         _casm_ ``%r = gethostbyaddr (%0, sizeof(%0), %1);''
 223                  addr (packFamily family)       `thenPrimIO` \ ptr ->
 224         if ptr == ``NULL'' then
 225           failWith (NoSuchThing "no such host entry")
 226         else
 227           unpackHostEntry ptr                   `thenPrimIO` \ hostent ->
 228           return hostent
 229
 230 getHostEntry :: IO HostEntry
 231 getHostEntry =
 232         _ccall_ gethostent                      `thenPrimIO` \ ptr ->
 233         if ptr == ``NULL'' then
 234           failWith (NoSuchThing "no such host entry")
 235         else
 236           unpackHostEntry ptr                   `thenPrimIO` \ hostent ->
 237           return hostent
 238
 239 setHostEntry :: Bool -> IO ()
 240 setHostEntry True = primIOToIO (_ccall_ sethostent 1)
 241 setHostEntry False = primIOToIO (_ccall_ sethostent 0)
 242
 243 endHostEntry :: IO ()
 244 endHostEntry = primIOToIO (_ccall_ endprotoent)
 245 \end{code}
 246
 247
 248 %***************************************************************************
 249 %*                                                                         *
 250 \subsection[BSD-Misc]{Miscellaneous Functions}
 251 %*                                                                         *
 252 %***************************************************************************
 253
 254
 255 The $select$ call is is used to make the process sleep until at least
 256 one of the given handles, is ready for reading, writing or has had an
 257 exception condition raised against it. The handles which are ready are
 258 returned in $SelectData$.
 259
 260 Select will also return after the given timeout, which is given in
 261 nanoseconds, has expired. In this case $Nothing$ is returned.
 262
 263 There is no provision of checking the amount of time remaining since
 264 the $select$ system call does not make this information available on
 265 all systems.  Some always return a zero timeout where others return
 266 the time remaining.
 267
 268 Possible return values from select are then:
 269 \begin{itemize}
 270 \item ([Handle], [Handle], [Handle], Nothing)
 271 \item Nothing
 272 \end{itemize}
 273
 274 \begin{code}
 275 {-
 276 type SelectData = ([Handle],            -- Read Handles
 277                    [Handle],            -- Write Handles
 278                    [Handle],            -- Exception Handles
 279                    Maybe Integer)       -- Timeout
 280 select :: SelectData -> IO (Maybe SelectData)
 281 -}
 282 \end{code}
 283
 284
 285 Calling $getHostName$ returns the standard host name for the current
 286 processor, as set at boot time.
 287
 288 \begin{code}
 289
 290 getHostName :: IO HostName
 291 getHostName =
 292     newCharArray (0,256)                        `thenPrimIO` \ ptr ->
 293     _casm_ ``%r = gethostname(%0, 256);'' ptr   `seqPrimIO`
 294     mutByteArr2Addr ptr                         `thenPrimIO` \ ptr' ->
 295     if ptr' == ``NULL'' then
 296         fail "getHostName: unable to determine hostname"
 297     else
 298         return (_unpackPS (_packCString ptr'))
 299 \end{code}
 300
 301
 302
 303 \begin{verbatim}
 304  struct    servent {
 305                char *s_name;  /* official name of service */
 306                char **s_aliases;   /* alias list */
 307                int  s_port;        /* port service resides at */
 308                char *s_proto; /* protocol to use */
 309           };
 310
 311      The members of this structure are:
 312           s_name              The official name of the service.
 313           s_aliases           A zero terminated list of alternate
 314                               names for the service.
 315           s_port              The port number at which  the  ser-
 316                               vice  resides.   Port  numbers  are
 317                               returned  in  network  short   byte
 318                               order.
 319           s_proto             The name of  the  protocol  to  use
 320                               when contacting the service.
 321 \end{verbatim}
 322
 323 \begin{code}
 324 unpackServiceEntry :: _Addr -> PrimIO ServiceEntry
 325 unpackServiceEntry ptr =
 326         _casm_ ``%r = ((struct servent*)%0)->s_name;'' ptr
 327                                                 `thenPrimIO` \ str ->
 328         strcpy str                              `thenPrimIO` \ name ->
 329         _casm_ ``%r = ((struct servent*)%0)->s_aliases;'' ptr
 330                                                 `thenPrimIO` \ alias ->
 331         unvectorize alias 0                     `thenStrictlyST` \ aliases ->
 332         _casm_ ``%r = ((struct servent*)%0)->s_port;'' ptr
 333                                                 `thenPrimIO` \ port ->
 334         _casm_ ``%r = ((struct servent*)%0)->s_proto;'' ptr
 335                                                 `thenPrimIO` \ str ->
 336         strcpy str                              `thenPrimIO` \ proto ->
 337
 338         returnPrimIO (ServiceEntry name aliases port proto)
 339
 340 -------------------------------------------------------------------------------
 341
 342 unpackProtocolEntry :: _Addr -> PrimIO ProtocolEntry
 343 unpackProtocolEntry ptr =
 344         _casm_ ``%r = ((struct protoent*)%0)->p_name;'' ptr
 345                                                 `thenPrimIO` \ str ->
 346         strcpy str                              `thenPrimIO` \ name ->
 347         _casm_ ``%r = ((struct protoent*)%0)->p_aliases;'' ptr
 348                                                 `thenPrimIO` \ alias ->
 349         unvectorize alias 0                     `thenStrictlyST` \ aliases ->
 350         _casm_ ``%r = ((struct protoent*)%0)->p_proto;'' ptr
 351                                                 `thenPrimIO` \ proto ->
 352
 353         returnPrimIO (ProtocolEntry name aliases proto)
 354
 355
 356 -------------------------------------------------------------------------------
 357
 358 unpackHostEntry :: _Addr -> PrimIO HostEntry
 359 unpackHostEntry ptr =
 360         _casm_ ``%r = ((struct hostent*)%0)->h_name;'' ptr
 361                                                 `thenPrimIO` \ str ->
 362         strcpy str                              `thenPrimIO` \ name ->
 363         _casm_ ``%r = ((struct hostent*)%0)->h_aliases;'' ptr
 364                                                 `thenPrimIO` \ alias ->
 365         unvectorize alias 0                     `thenStrictlyST` \ aliases ->
 366 {-      _casm_ ``%r = ((struct hostent*)%0)->h_addr_list;'' ptr
 367                                                 `thenPrimIO` \ addrs ->
 368         unvectorizeHostAddrs addrs 0            `thenStrictlyST` \ addrList ->
 369 -}      unvectorizeHostAddrs ptr 0              `thenStrictlyST` \ addrList ->
 370         returnPrimIO (HostEntry name aliases AF_INET addrList)
 371
 372 -------------------------------------------------------------------------------
 373
 374 unvectorizeHostAddrs :: _Addr -> Int -> PrimIO [_Word]
 375 unvectorizeHostAddrs ptr n
 376   | str == ``NULL'' = returnPrimIO []
 377   | otherwise =
 378         _casm_ ``%r = (W_)ntohl(((struct hostent*)%0)->h_addr_list[(int)%1]);''
 379                 ptr n                               `thenPrimIO` \ x ->
 380         unvectorizeHostAddrs ptr (n+1)              `thenPrimIO` \ xs ->
 381         returnPrimIO (x : xs)
 382   where str = indexAddrOffAddr ptr n
 383
 384 -------------------------------------------------------------------------------
 385
 386 mutByteArr2Addr :: _MutableByteArray _RealWorld Int -> PrimIO  _Addr
 387 mutByteArr2Addr arr  = _casm_ `` %r=(void *)%0; '' arr
 388
 389
 390 \end{code}