summaryrefslogtreecommitdiff
path: root/src/Erebos/Network.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Erebos/Network.hs')
-rw-r--r--src/Erebos/Network.hs84
1 files changed, 63 insertions, 21 deletions
diff --git a/src/Erebos/Network.hs b/src/Erebos/Network.hs
index 364597f..54658de 100644
--- a/src/Erebos/Network.hs
+++ b/src/Erebos/Network.hs
@@ -6,6 +6,7 @@ module Erebos.Network (
stopServer,
getCurrentPeerList,
getNextPeerChange,
+ getServerAddresses,
ServerOptions(..), serverIdentity, defaultServerOptions,
Peer, peerServer, peerStorage,
@@ -46,17 +47,18 @@ import Data.Maybe
import Data.Typeable
import Data.Word
+import Foreign.C.Types
+import Foreign.Marshal.Alloc
+import Foreign.Marshal.Array
import Foreign.Ptr
-import Foreign.Storable
+import Foreign.Storable as F
import GHC.Conc.Sync (unsafeIOToSTM)
import Network.Socket hiding (ControlMessage)
import qualified Network.Socket.ByteString as S
-import Foreign.C.Types
-import Foreign.Marshal.Alloc
-
+import Erebos.Error
#ifdef ENABLE_ICE_SUPPORT
import Erebos.ICE
#endif
@@ -84,6 +86,7 @@ announceIntervalSeconds = 60
data Server = Server
{ serverStorage :: Storage
+ , serverOptions :: ServerOptions
, serverOrigHead :: Head LocalState
, serverIdentity_ :: MVar UnifiedIdentity
, serverThreads :: MVar [ThreadId]
@@ -91,7 +94,7 @@ data Server = Server
, serverRawPath :: SymFlow (PeerAddress, BC.ByteString)
, serverControlFlow :: Flow (ControlMessage PeerAddress) (ControlRequest PeerAddress)
, serverDataResponse :: TQueue (Peer, Maybe PartialRef)
- , serverIOActions :: TQueue (ExceptT String IO ())
+ , serverIOActions :: TQueue (ExceptT ErebosError IO ())
, serverServices :: [SomeService]
, serverServiceStates :: TMVar (M.Map ServiceID SomeServiceGlobalState)
, serverPeers :: MVar (Map PeerAddress Peer)
@@ -187,8 +190,8 @@ instance Ord PeerAddress where
#endif
-data PeerIdentity = PeerIdentityUnknown (TVar [UnifiedIdentity -> ExceptT String IO ()])
- | PeerIdentityRef WaitingRef (TVar [UnifiedIdentity -> ExceptT String IO ()])
+data PeerIdentity = PeerIdentityUnknown (TVar [UnifiedIdentity -> ExceptT ErebosError IO ()])
+ | PeerIdentityRef WaitingRef (TVar [UnifiedIdentity -> ExceptT ErebosError IO ()])
| PeerIdentityFull UnifiedIdentity
peerIdentity :: MonadIO m => Peer -> m PeerIdentity
@@ -230,7 +233,7 @@ forkServerThread server act = do
return (t:ts)
startServer :: ServerOptions -> Head LocalState -> (String -> IO ()) -> [SomeService] -> IO Server
-startServer opt serverOrigHead logd' serverServices = do
+startServer serverOptions serverOrigHead logd' serverServices = do
let serverStorage = headStorage serverOrigHead
serverIdentity_ <- newMVar $ headLocalIdentity serverOrigHead
serverThreads <- newMVar []
@@ -253,7 +256,7 @@ startServer opt serverOrigHead logd' serverServices = do
forkServerThread server $ dataResponseWorker server
forkServerThread server $ forever $ do
- either (atomically . logd) return =<< runExceptT =<<
+ either (atomically . logd . showErebosError) return =<< runExceptT =<<
atomically (readTQueue serverIOActions)
let open addr = do
@@ -266,7 +269,7 @@ startServer opt serverOrigHead logd' serverServices = do
return sock
loop sock = do
- when (serverLocalDiscovery opt) $ forkServerThread server $ do
+ when (serverLocalDiscovery serverOptions) $ forkServerThread server $ do
announceAddreses <- fmap concat $ sequence $
[ map (SockAddrInet6 discoveryPort 0 discoveryMulticastGroup) <$> joinMulticast sock
, getBroadcastAddresses discoveryPort
@@ -378,7 +381,7 @@ startServer opt serverOrigHead logd' serverServices = do
, addrFamily = AF_INET6
, addrSocketType = Datagram
}
- addr:_ <- getAddrInfo (Just hints) Nothing (Just $ show $ serverPort opt)
+ addr:_ <- getAddrInfo (Just hints) Nothing (Just $ show $ serverPort serverOptions)
bracket (open addr) close loop
forkServerThread server $ forever $ do
@@ -405,7 +408,7 @@ dataResponseWorker server = forever $ do
Right ref -> do
atomically (writeTVar tvar $ Right ref)
forkServerThread server $ runExceptT (wrefAction wr ref) >>= \case
- Left err -> atomically $ writeTQueue (serverErrorLog server) err
+ Left err -> atomically $ writeTQueue (serverErrorLog server) (showErebosError err)
Right () -> return ()
return (Nothing, [])
@@ -584,7 +587,7 @@ handlePacket identity secure peer chanSvc svcs (TransportHeader headers) prefs =
liftSTM $ writeTQueue (serverIOActions server) $ void $ liftIO $ forkIO $ do
(runExcept <$> readObjectsFromStream (peerInStorage peer) streamReader) >>= \case
Left err -> atomically $ writeTQueue (serverErrorLog server) $
- "failed to receive object from stream: " <> err
+ "failed to receive object from stream: " <> showErebosError err
Right objs -> do
forM_ objs $ \obj -> do
pref <- storeObject (peerInStorage peer) obj
@@ -666,7 +669,7 @@ handlePacket identity secure peer chanSvc svcs (TransportHeader headers) prefs =
_ -> return ()
-withPeerIdentity :: MonadIO m => Peer -> (UnifiedIdentity -> ExceptT String IO ()) -> m ()
+withPeerIdentity :: MonadIO m => Peer -> (UnifiedIdentity -> ExceptT ErebosError IO ()) -> m ()
withPeerIdentity peer act = liftIO $ atomically $ readTVar (peerIdentityVar peer) >>= \case
PeerIdentityUnknown tvar -> modifyTVar' tvar (act:)
PeerIdentityRef _ tvar -> modifyTVar' tvar (act:)
@@ -722,7 +725,7 @@ handleChannelAccept identity accref = do
sendToPeerS peer [] $ TransportPacket (TransportHeader [Acknowledged $ refDigest accref]) []
finalizedChannel peer ch identity
- Left dgst -> throwError $ "missing accept data " ++ BC.unpack (showRefDigest dgst)
+ Left dgst -> throwOtherError $ "missing accept data " ++ BC.unpack (showRefDigest dgst)
finalizedChannel :: Peer -> Channel -> UnifiedIdentity -> STM ()
@@ -880,7 +883,7 @@ sendToPeerS = sendToPeerS' EncryptedOnly
sendToPeerPlain :: Peer -> [TransportHeaderItem] -> TransportPacket Ref -> STM ()
sendToPeerPlain = sendToPeerS' PlaintextAllowed
-sendToPeerWith :: forall s m. (Service s, MonadIO m, MonadError String m) => Peer -> (ServiceState s -> ExceptT String IO (Maybe s, ServiceState s)) -> m ()
+sendToPeerWith :: forall s m e. (Service s, MonadIO m, MonadError e m, FromErebosError e) => Peer -> (ServiceState s -> ExceptT ErebosError IO (Maybe s, ServiceState s)) -> m ()
sendToPeerWith peer fobj = do
let sproxy = Proxy @s
sid = serviceID sproxy
@@ -895,7 +898,7 @@ sendToPeerWith peer fobj = do
case res of
Right (Just obj) -> sendToPeer peer obj
Right Nothing -> return ()
- Left err -> throwError err
+ Left err -> throwError $ fromErebosError err
lookupService :: forall s. Service s => Proxy s -> [SomeService] -> Maybe (SomeService, ServiceAttributes s)
@@ -955,17 +958,56 @@ runPeerServiceOn mbservice peer handler = liftIO $ do
foreign import ccall unsafe "Network/ifaddrs.h join_multicast" cJoinMulticast :: CInt -> Ptr CSize -> IO (Ptr Word32)
+foreign import ccall unsafe "Network/ifaddrs.h local_addresses" cLocalAddresses :: Ptr CSize -> IO (Ptr InetAddress)
foreign import ccall unsafe "Network/ifaddrs.h broadcast_addresses" cBroadcastAddresses :: IO (Ptr Word32)
-foreign import ccall unsafe "stdlib.h free" cFree :: Ptr Word32 -> IO ()
+foreign import ccall unsafe "stdlib.h free" cFree :: Ptr a -> IO ()
+
+data InetAddress = InetAddress { fromInetAddress :: IP.IP }
+
+instance F.Storable InetAddress where
+ sizeOf _ = sizeOf (undefined :: CInt) + 16
+ alignment _ = 8
+
+ peek ptr = (unpackFamily <$> peekByteOff ptr 0) >>= \case
+ AF_INET -> InetAddress . IP.IPv4 . IP.fromHostAddress <$> peekByteOff ptr (sizeOf (undefined :: CInt))
+ AF_INET6 -> InetAddress . IP.IPv6 . IP.toIPv6b . map fromIntegral <$> peekArray 16 (ptr `plusPtr` sizeOf (undefined :: CInt) :: Ptr Word8)
+ _ -> fail "InetAddress: unknown family"
+
+ poke ptr (InetAddress addr) = case addr of
+ IP.IPv4 ip -> do
+ pokeByteOff ptr 0 (packFamily AF_INET)
+ pokeByteOff ptr (sizeOf (undefined :: CInt)) (IP.toHostAddress ip)
+ IP.IPv6 ip -> do
+ pokeByteOff ptr 0 (packFamily AF_INET6)
+ pokeArray (ptr `plusPtr` sizeOf (undefined :: CInt) :: Ptr Word8) (map fromIntegral $ IP.fromIPv6b ip)
joinMulticast :: Socket -> IO [ Word32 ]
joinMulticast sock =
withFdSocket sock $ \fd ->
alloca $ \pcount -> do
ptr <- cJoinMulticast fd pcount
- count <- fromIntegral <$> peek pcount
- forM [ 0 .. count - 1 ] $ \i ->
- peekElemOff ptr i
+ if ptr == nullPtr
+ then do
+ return []
+ else do
+ count <- fromIntegral <$> peek pcount
+ res <- forM [ 0 .. count - 1 ] $ \i ->
+ peekElemOff ptr i
+ cFree ptr
+ return res
+
+getServerAddresses :: Server -> IO [ SockAddr ]
+getServerAddresses Server {..} = do
+ alloca $ \pcount -> do
+ ptr <- cLocalAddresses pcount
+ if ptr == nullPtr
+ then do
+ return []
+ else do
+ count <- fromIntegral <$> peek pcount
+ res <- peekArray count ptr
+ cFree ptr
+ return $ map (IP.toSockAddr . (, serverPort serverOptions ) . fromInetAddress) res
getBroadcastAddresses :: PortNumber -> IO [SockAddr]
getBroadcastAddresses port = do
generated by cgit v1.2.3 (git 2.25.1) at 2025-07-04 18:36:44 +0000