1{-# LANGUAGE CPP, ForeignFunctionInterface #-}
2{-# OPTIONS_HADDOCK hide #-}
3{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
4-----------------------------------------------------------------------------
5-- |
6-- Module      :  Network.BSD
7-- Copyright   :  (c) The University of Glasgow 2001
8-- License     :  BSD-style (see the file libraries/network/LICENSE)
9--
10-- Maintainer  :  libraries@haskell.org
11-- Stability   :  experimental
12-- Portability :  non-portable
13--
14-- The "Network.BSD" module defines Haskell bindings to network
15-- programming functionality provided by BSD Unix derivatives.
16--
17-----------------------------------------------------------------------------
18
19#include "HsNet.h"
20##include "HsNetDef.h"
21
22module Network.BSD  {-# DEPRECATED "This platform dependent module is no longer supported." #-}
23    (
24    -- * Host names
25      HostName
26    , getHostName
27
28    , HostEntry(..)
29    , getHostByName
30    , getHostByAddr
31    , hostAddress
32
33#if defined(HAVE_GETHOSTENT) && !defined(mingw32_HOST_OS)
34    , getHostEntries
35
36    -- ** Low level functionality
37    , setHostEntry
38    , getHostEntry
39    , endHostEntry
40#endif
41
42    -- * Service names
43    , ServiceEntry(..)
44    , ServiceName
45    , getServiceByName
46    , getServiceByPort
47    , getServicePortNumber
48
49#if !defined(mingw32_HOST_OS)
50    , getServiceEntries
51
52    -- ** Low level functionality
53    , getServiceEntry
54    , setServiceEntry
55    , endServiceEntry
56#endif
57
58    -- * Protocol names
59    , ProtocolName
60    , ProtocolNumber
61    , ProtocolEntry(..)
62    , getProtocolByName
63    , getProtocolByNumber
64    , getProtocolNumber
65    , defaultProtocol
66
67#if !defined(mingw32_HOST_OS)
68    , getProtocolEntries
69    -- ** Low level functionality
70    , setProtocolEntry
71    , getProtocolEntry
72    , endProtocolEntry
73#endif
74
75    -- * Port numbers
76    , PortNumber
77
78    -- * Network names
79    , NetworkName
80    , NetworkAddr
81    , NetworkEntry(..)
82
83#if !defined(mingw32_HOST_OS)
84    , getNetworkByName
85    , getNetworkByAddr
86    , getNetworkEntries
87    -- ** Low level functionality
88    , setNetworkEntry
89    , getNetworkEntry
90    , endNetworkEntry
91#endif
92
93#if defined(HAVE_IF_NAMETOINDEX)
94    -- * Interface names
95    , ifNameToIndex
96#endif
97
98    ) where
99
100import Network.Socket
101
102import Control.Concurrent (MVar, newMVar, withMVar)
103import qualified Control.Exception as E
104import Foreign.C.String (CString, peekCString, withCString)
105#if defined(HAVE_WINSOCK2_H)
106import Foreign.C.Types ( CShort )
107#endif
108import Foreign.C.Types ( CInt(..), CULong(..), CSize(..) )
109import Foreign.Ptr (Ptr, nullPtr)
110import Foreign.Storable (Storable(..))
111import Foreign.Marshal.Array (allocaArray0, peekArray0)
112import Foreign.Marshal.Utils (with, fromBool)
113import Data.Typeable
114import System.IO.Error (ioeSetErrorString, mkIOError)
115import System.IO.Unsafe (unsafePerformIO)
116
117import GHC.IO.Exception
118
119import Control.Monad (liftM)
120
121import Network.Socket.Internal (throwSocketErrorIfMinus1_)
122
123-- ---------------------------------------------------------------------------
124-- Basic Types
125
126type ProtocolName = String
127
128-- ---------------------------------------------------------------------------
129-- Service Database Access
130
131-- Calling getServiceByName for a given service and protocol returns
132-- the systems service entry.  This should be used to find the port
133-- numbers for standard protocols such as SMTP and FTP.  The remaining
134-- three functions should be used for browsing the service database
135-- sequentially.
136
137-- Calling setServiceEntry with True indicates that the service
138-- database should be left open between calls to getServiceEntry.  To
139-- close the database a call to endServiceEntry is required.  This
140-- database file is usually stored in the file /etc/services.
141
142data ServiceEntry  =
143  ServiceEntry  {
144     serviceName     :: ServiceName,    -- Official Name
145     serviceAliases  :: [ServiceName],  -- aliases
146     servicePort     :: PortNumber,     -- Port Number  ( network byte order )
147     serviceProtocol :: ProtocolName    -- Protocol
148  } deriving (Show, Typeable)
149
150instance Storable ServiceEntry where
151   sizeOf    _ = #const sizeof(struct servent)
152   alignment _ = alignment (undefined :: CInt) -- ???
153
154   peek p = do
155        s_name    <- (#peek struct servent, s_name) p >>= peekCString
156        s_aliases <- (#peek struct servent, s_aliases) p
157                           >>= peekArray0 nullPtr
158                           >>= mapM peekCString
159        s_port    <- (#peek struct servent, s_port) p
160        s_proto   <- (#peek struct servent, s_proto) p >>= peekCString
161        return (ServiceEntry {
162                        serviceName     = s_name,
163                        serviceAliases  = s_aliases,
164#if defined(HAVE_WINSOCK2_H)
165                        servicePort     = (fromIntegral (s_port :: CShort)),
166#else
167                           -- s_port is already in network byte order, but it
168                           -- might be the wrong size.
169                        servicePort     = (fromIntegral (s_port :: CInt)),
170#endif
171                        serviceProtocol = s_proto
172                })
173
174   poke = throwUnsupportedOperationPoke "ServiceEntry"
175
176
177-- | Get service by name.
178getServiceByName :: ServiceName         -- Service Name
179                 -> ProtocolName        -- Protocol Name
180                 -> IO ServiceEntry     -- Service Entry
181getServiceByName name proto = withLock $ do
182 withCString name  $ \ cstr_name  -> do
183 withCString proto $ \ cstr_proto -> do
184 throwNoSuchThingIfNull "Network.BSD.getServiceByName" "no such service entry"
185   $ c_getservbyname cstr_name cstr_proto
186 >>= peek
187
188foreign import CALLCONV unsafe "getservbyname"
189  c_getservbyname :: CString -> CString -> IO (Ptr ServiceEntry)
190
191-- | Get the service given a 'PortNumber' and 'ProtocolName'.
192getServiceByPort :: PortNumber -> ProtocolName -> IO ServiceEntry
193getServiceByPort port proto = withLock $ do
194 withCString proto $ \ cstr_proto -> do
195 throwNoSuchThingIfNull "Network.BSD.getServiceByPort" "no such service entry"
196   $ c_getservbyport (fromIntegral port) cstr_proto
197 >>= peek
198
199foreign import CALLCONV unsafe "getservbyport"
200  c_getservbyport :: CInt -> CString -> IO (Ptr ServiceEntry)
201
202-- | Get the 'PortNumber' corresponding to the 'ServiceName'.
203getServicePortNumber :: ServiceName -> IO PortNumber
204getServicePortNumber name = do
205    (ServiceEntry _ _ port _) <- getServiceByName name "tcp"
206    return port
207
208#if !defined(mingw32_HOST_OS)
209getServiceEntry :: IO ServiceEntry
210getServiceEntry = withLock $ do
211 throwNoSuchThingIfNull "Network.BSD.getServiceEntry" "no such service entry"
212   $ c_getservent
213 >>= peek
214
215foreign import ccall unsafe "getservent" c_getservent :: IO (Ptr ServiceEntry)
216
217setServiceEntry :: Bool -> IO ()
218setServiceEntry flg = withLock $ c_setservent (fromBool flg)
219
220foreign import ccall unsafe  "setservent" c_setservent :: CInt -> IO ()
221
222endServiceEntry :: IO ()
223endServiceEntry = withLock $ c_endservent
224
225foreign import ccall unsafe  "endservent" c_endservent :: IO ()
226
227getServiceEntries :: Bool -> IO [ServiceEntry]
228getServiceEntries stayOpen = do
229  setServiceEntry stayOpen
230  getEntries (getServiceEntry) (endServiceEntry)
231#endif
232
233-- ---------------------------------------------------------------------------
234-- Protocol Entries
235
236-- The following relate directly to the corresponding UNIX C
237-- calls for returning the protocol entries. The protocol entry is
238-- represented by the Haskell type ProtocolEntry.
239
240-- As for setServiceEntry above, calling setProtocolEntry.
241-- determines whether or not the protocol database file, usually
242-- @/etc/protocols@, is to be kept open between calls of
243-- getProtocolEntry. Similarly,
244
245data ProtocolEntry =
246  ProtocolEntry  {
247     protoName    :: ProtocolName,      -- Official Name
248     protoAliases :: [ProtocolName],    -- aliases
249     protoNumber  :: ProtocolNumber     -- Protocol Number
250  } deriving (Read, Show, Typeable)
251
252instance Storable ProtocolEntry where
253   sizeOf    _ = #const sizeof(struct protoent)
254   alignment _ = alignment (undefined :: CInt) -- ???
255
256   peek p = do
257        p_name    <- (#peek struct protoent, p_name) p >>= peekCString
258        p_aliases <- (#peek struct protoent, p_aliases) p
259                           >>= peekArray0 nullPtr
260                           >>= mapM peekCString
261#if defined(HAVE_WINSOCK2_H)
262         -- With WinSock, the protocol number is only a short;
263         -- hoist it in as such, but represent it on the Haskell side
264         -- as a CInt.
265        p_proto_short  <- (#peek struct protoent, p_proto) p
266        let p_proto = fromIntegral (p_proto_short :: CShort)
267#else
268        p_proto        <- (#peek struct protoent, p_proto) p
269#endif
270        return (ProtocolEntry {
271                        protoName    = p_name,
272                        protoAliases = p_aliases,
273                        protoNumber  = p_proto
274                })
275
276   poke = throwUnsupportedOperationPoke "ProtocolEntry"
277
278
279getProtocolByName :: ProtocolName -> IO ProtocolEntry
280getProtocolByName name = withLock $ do
281 withCString name $ \ name_cstr -> do
282 throwNoSuchThingIfNull "Network.BSD.getProtocolByName" ("no such protocol name: " ++ name)
283   $ c_getprotobyname name_cstr
284 >>= peek
285
286foreign import  CALLCONV unsafe  "getprotobyname"
287   c_getprotobyname :: CString -> IO (Ptr ProtocolEntry)
288
289
290getProtocolByNumber :: ProtocolNumber -> IO ProtocolEntry
291getProtocolByNumber num = withLock $ do
292 throwNoSuchThingIfNull "Network.BSD.getProtocolByNumber" ("no such protocol number: " ++ show num)
293   $ c_getprotobynumber (fromIntegral num)
294 >>= peek
295
296foreign import CALLCONV unsafe  "getprotobynumber"
297   c_getprotobynumber :: CInt -> IO (Ptr ProtocolEntry)
298
299
300getProtocolNumber :: ProtocolName -> IO ProtocolNumber
301getProtocolNumber proto = do
302 (ProtocolEntry _ _ num) <- getProtocolByName proto
303 return num
304
305#if !defined(mingw32_HOST_OS)
306getProtocolEntry :: IO ProtocolEntry    -- Next Protocol Entry from DB
307getProtocolEntry = withLock $ do
308 ent <- throwNoSuchThingIfNull "Network.BSD.getProtocolEntry" "no such protocol entry"
309                $ c_getprotoent
310 peek ent
311
312foreign import ccall unsafe  "getprotoent" c_getprotoent :: IO (Ptr ProtocolEntry)
313
314setProtocolEntry :: Bool -> IO ()       -- Keep DB Open ?
315setProtocolEntry flg = withLock $ c_setprotoent (fromBool flg)
316
317foreign import ccall unsafe "setprotoent" c_setprotoent :: CInt -> IO ()
318
319endProtocolEntry :: IO ()
320endProtocolEntry = withLock $ c_endprotoent
321
322foreign import ccall unsafe "endprotoent" c_endprotoent :: IO ()
323
324getProtocolEntries :: Bool -> IO [ProtocolEntry]
325getProtocolEntries stayOpen = withLock $ do
326  setProtocolEntry stayOpen
327  getEntries (getProtocolEntry) (endProtocolEntry)
328#endif
329
330-- ---------------------------------------------------------------------------
331-- Host lookups
332
333data HostEntry =
334  HostEntry  {
335     hostName      :: HostName,         -- Official Name
336     hostAliases   :: [HostName],       -- aliases
337     hostFamily    :: Family,           -- Host Type (currently AF_INET)
338     hostAddresses :: [HostAddress]     -- Set of Network Addresses  (in network byte order)
339  } deriving (Read, Show, Typeable)
340
341instance Storable HostEntry where
342   sizeOf    _ = #const sizeof(struct hostent)
343   alignment _ = alignment (undefined :: CInt) -- ???
344
345   peek p = do
346        h_name       <- (#peek struct hostent, h_name) p >>= peekCString
347        h_aliases    <- (#peek struct hostent, h_aliases) p
348                                >>= peekArray0 nullPtr
349                                >>= mapM peekCString
350        h_addrtype   <- (#peek struct hostent, h_addrtype) p
351        -- h_length       <- (#peek struct hostent, h_length) p
352        h_addr_list  <- (#peek struct hostent, h_addr_list) p
353                                >>= peekArray0 nullPtr
354                                >>= mapM peek
355        return (HostEntry {
356                        hostName       = h_name,
357                        hostAliases    = h_aliases,
358#if defined(HAVE_WINSOCK2_H)
359                        hostFamily     = unpackFamily (fromIntegral (h_addrtype :: CShort)),
360#else
361                        hostFamily     = unpackFamily h_addrtype,
362#endif
363                        hostAddresses  = h_addr_list
364                })
365
366   poke = throwUnsupportedOperationPoke "HostEntry"
367
368
369-- convenience function:
370hostAddress :: HostEntry -> HostAddress
371hostAddress (HostEntry nm _ _ ls) =
372 case ls of
373   []    -> error $ "Network.BSD.hostAddress: empty network address list for " ++ nm
374   (x:_) -> x
375
376-- getHostByName must use the same lock as the *hostent functions
377-- may cause problems if called concurrently.
378
379-- | Resolve a 'HostName' to IPv4 address.
380getHostByName :: HostName -> IO HostEntry
381getHostByName name = withLock $ do
382  withCString name $ \ name_cstr -> do
383   ent <- throwNoSuchThingIfNull "Network.BSD.getHostByName" "no such host entry"
384                $ c_gethostbyname name_cstr
385   peek ent
386
387foreign import CALLCONV safe "gethostbyname"
388   c_gethostbyname :: CString -> IO (Ptr HostEntry)
389
390
391-- The locking of gethostbyaddr is similar to gethostbyname.
392-- | Get a 'HostEntry' corresponding to the given address and family.
393-- Note that only IPv4 is currently supported.
394getHostByAddr :: Family -> HostAddress -> IO HostEntry
395getHostByAddr family addr = do
396 with addr $ \ ptr_addr -> withLock $ do
397 throwNoSuchThingIfNull "Network.BSD.getHostByAddr" "no such host entry"
398   $ c_gethostbyaddr ptr_addr (fromIntegral (sizeOf addr)) (packFamily family)
399 >>= peek
400
401foreign import CALLCONV safe "gethostbyaddr"
402   c_gethostbyaddr :: Ptr HostAddress -> CInt -> CInt -> IO (Ptr HostEntry)
403
404#if defined(HAVE_GETHOSTENT) && !defined(mingw32_HOST_OS)
405getHostEntry :: IO HostEntry
406getHostEntry = withLock $ do
407 throwNoSuchThingIfNull "Network.BSD.getHostEntry" "unable to retrieve host entry"
408   $ c_gethostent
409 >>= peek
410
411foreign import ccall unsafe "gethostent" c_gethostent :: IO (Ptr HostEntry)
412
413setHostEntry :: Bool -> IO ()
414setHostEntry flg = withLock $ c_sethostent (fromBool flg)
415
416foreign import ccall unsafe "sethostent" c_sethostent :: CInt -> IO ()
417
418endHostEntry :: IO ()
419endHostEntry = withLock $ c_endhostent
420
421foreign import ccall unsafe "endhostent" c_endhostent :: IO ()
422
423getHostEntries :: Bool -> IO [HostEntry]
424getHostEntries stayOpen = do
425  setHostEntry stayOpen
426  getEntries (getHostEntry) (endHostEntry)
427#endif
428
429-- ---------------------------------------------------------------------------
430-- Accessing network information
431
432-- Same set of access functions as for accessing host,protocol and
433-- service system info, this time for the types of networks supported.
434
435-- network addresses are represented in host byte order.
436type NetworkAddr = CULong
437
438type NetworkName = String
439
440data NetworkEntry =
441  NetworkEntry {
442     networkName        :: NetworkName,   -- official name
443     networkAliases     :: [NetworkName], -- aliases
444     networkFamily      :: Family,         -- type
445     networkAddress     :: NetworkAddr
446   } deriving (Read, Show, Typeable)
447
448instance Storable NetworkEntry where
449   sizeOf    _ = #const sizeof(struct hostent)
450   alignment _ = alignment (undefined :: CInt) -- ???
451
452   peek p = do
453        n_name         <- (#peek struct netent, n_name) p >>= peekCString
454        n_aliases      <- (#peek struct netent, n_aliases) p
455                                >>= peekArray0 nullPtr
456                                >>= mapM peekCString
457        n_addrtype     <- (#peek struct netent, n_addrtype) p
458        n_net          <- (#peek struct netent, n_net) p
459        return (NetworkEntry {
460                        networkName      = n_name,
461                        networkAliases   = n_aliases,
462                        networkFamily    = unpackFamily (fromIntegral
463                                                        (n_addrtype :: CInt)),
464                        networkAddress   = n_net
465                })
466
467   poke = throwUnsupportedOperationPoke "NetworkEntry"
468
469
470#if !defined(mingw32_HOST_OS)
471getNetworkByName :: NetworkName -> IO NetworkEntry
472getNetworkByName name = withLock $ do
473 withCString name $ \ name_cstr -> do
474  throwNoSuchThingIfNull "Network.BSD.getNetworkByName" "no such network entry"
475    $ c_getnetbyname name_cstr
476  >>= peek
477
478foreign import ccall unsafe "getnetbyname"
479   c_getnetbyname  :: CString -> IO (Ptr NetworkEntry)
480
481getNetworkByAddr :: NetworkAddr -> Family -> IO NetworkEntry
482getNetworkByAddr addr family = withLock $ do
483 throwNoSuchThingIfNull "Network.BSD.getNetworkByAddr" "no such network entry"
484   $ c_getnetbyaddr addr (packFamily family)
485 >>= peek
486
487foreign import ccall unsafe "getnetbyaddr"
488   c_getnetbyaddr  :: NetworkAddr -> CInt -> IO (Ptr NetworkEntry)
489
490getNetworkEntry :: IO NetworkEntry
491getNetworkEntry = withLock $ do
492 throwNoSuchThingIfNull "Network.BSD.getNetworkEntry" "no more network entries"
493          $ c_getnetent
494 >>= peek
495
496foreign import ccall unsafe "getnetent" c_getnetent :: IO (Ptr NetworkEntry)
497
498-- | Open the network name database. The parameter specifies
499-- whether a connection is maintained open between various
500-- networkEntry calls
501setNetworkEntry :: Bool -> IO ()
502setNetworkEntry flg = withLock $ c_setnetent (fromBool flg)
503
504foreign import ccall unsafe "setnetent" c_setnetent :: CInt -> IO ()
505
506-- | Close the connection to the network name database.
507endNetworkEntry :: IO ()
508endNetworkEntry = withLock $ c_endnetent
509
510foreign import ccall unsafe "endnetent" c_endnetent :: IO ()
511
512-- | Get the list of network entries.
513getNetworkEntries :: Bool -> IO [NetworkEntry]
514getNetworkEntries stayOpen = do
515  setNetworkEntry stayOpen
516  getEntries (getNetworkEntry) (endNetworkEntry)
517#endif
518
519-- Mutex for name service lockdown
520
521{-# NOINLINE lock #-}
522lock :: MVar ()
523lock = unsafePerformIO $ withSocketsDo $ newMVar ()
524
525withLock :: IO a -> IO a
526withLock act = withMVar lock (\_ -> act)
527
528-- ---------------------------------------------------------------------------
529-- Miscellaneous Functions
530
531-- | Calling getHostName returns the standard host name for the current
532-- processor, as set at boot time.
533
534getHostName :: IO HostName
535getHostName = do
536  let size = 256
537  allocaArray0 size $ \ cstr -> do
538    throwSocketErrorIfMinus1_ "Network.BSD.getHostName" $ c_gethostname cstr (fromIntegral size)
539    peekCString cstr
540
541foreign import CALLCONV unsafe "gethostname"
542   c_gethostname :: CString -> CSize -> IO CInt
543
544-- Helper function used by the exported functions that provides a
545-- Haskellised view of the enumerator functions:
546
547getEntries :: IO a  -- read
548           -> IO () -- at end
549           -> IO [a]
550getEntries getOne atEnd = loop
551  where
552    loop = do
553      vv <- E.catch (liftM Just getOne)
554            (\ e -> let _types = e :: IOException in return Nothing)
555      case vv of
556        Nothing -> return []
557        Just v  -> loop >>= \ vs -> atEnd >> return (v:vs)
558
559
560throwNoSuchThingIfNull :: String -> String -> IO (Ptr a) -> IO (Ptr a)
561throwNoSuchThingIfNull loc desc act = do
562  ptr <- act
563  if (ptr == nullPtr)
564   then ioError (ioeSetErrorString (mkIOError NoSuchThing loc Nothing Nothing) desc)
565   else return ptr
566
567throwUnsupportedOperationPoke :: String -> Ptr a -> a -> IO ()
568throwUnsupportedOperationPoke typ _ _ =
569  ioError $ ioeSetErrorString ioe "Operation not implemented"
570  where
571    ioe = mkIOError UnsupportedOperation
572                    ("Network.BSD: instance Storable " ++ typ ++ ": poke")
573                    Nothing
574                    Nothing
575