Silence error when calling discoverySearch without the service

5 files changed, 45 insertions, 17 deletions

diff --git a/src/Erebos/Discovery.hs b/src/Erebos/Discovery.hs
index 5590e4c..09ed22d 100644
--- a/src/Erebos/Discovery.hs
+++ b/src/Erebos/Discovery.hs
@@ -566,20 +566,29 @@ getIceConfig = do
 #endif
 
 
-discoverySearch :: (MonadIO m, MonadError e m, FromErebosError e) => Server -> RefDigest -> m ()
+-- | Start search for an identity identified by given ref using the discovery
+-- service.
+discoverySearch
+    :: forall m e. (MonadIO m, MonadError e m, FromErebosError e)
+    => Server -- ^ `Server' object to run the discovery
+    -> RefDigest -- ^ Reference identifying the intended peer
+    -> m ()
 discoverySearch server dgst = do
-    peers <- liftIO $ getCurrentPeerList server
-    match <- forM peers $ \peer -> do
-        getPeerIdentity peer >>= \case
-            PeerIdentityFull pid -> do
-                return $ dgst `elem` identityDigests pid
-            _ -> return False
-    when (not $ or match) $ do
-        modifyServiceGlobalState server (Proxy @DiscoveryService) $ \s -> (, ()) s
-            { dgsSearchingFor = S.insert dgst $ dgsSearchingFor s
-            }
-        forM_ peers $ \peer -> do
-            sendToPeer peer $ DiscoverySearch $ Right dgst
+    flip catchError (\e -> case toErebosError e of
+            Just (UnhandledService svc) | svc == serviceID (Proxy @DiscoveryService) -> return ()
+            _ -> throwError e) $ do
+        peers <- liftIO $ getCurrentPeerList server
+        match <- forM peers $ \peer -> do
+            getPeerIdentity peer >>= \case
+                PeerIdentityFull pid -> do
+                    return $ dgst `elem` identityDigests pid
+                _ -> return False
+        when (not $ or match) $ do
+            modifyServiceGlobalState server (Proxy @DiscoveryService) $ \s -> (, ()) s
+                { dgsSearchingFor = S.insert dgst $ dgsSearchingFor s
+                }
+            forM_ peers $ \peer -> do
+                sendToPeer peer $ DiscoverySearch $ Right dgst
 
 
 data TunnelAddress = TunnelAddress
diff --git a/src/Erebos/Error.hs b/src/Erebos/Error.hs
index 3bb8736..da9db75 100644
--- a/src/Erebos/Error.hs
+++ b/src/Erebos/Error.hs
@@ -3,19 +3,24 @@ module Erebos.Error (
     showErebosError,
 
     FromErebosError(..),
+    throwErebosError,
     throwOtherError,
 ) where
 
 import Control.Monad.Except
 
+import {-# SOURCE #-} Erebos.Network.Protocol
+
 
 data ErebosError
     = ManyErrors [ ErebosError ]
     | OtherError String
+    | UnhandledService ServiceID
 
 showErebosError :: ErebosError -> String
 showErebosError (ManyErrors errs) = unlines $ map showErebosError errs
 showErebosError (OtherError str) = str
+showErebosError (UnhandledService svc) = "unhandled service ‘" ++ show svc ++ "’"
 
 instance Semigroup ErebosError where
     ManyErrors [] <> b = b
@@ -23,7 +28,7 @@ instance Semigroup ErebosError where
     ManyErrors a <> ManyErrors b = ManyErrors (a ++ b)
     ManyErrors a <> b = ManyErrors (a ++ [ b ])
     a <> ManyErrors b = ManyErrors (a : b)
-    a@OtherError {} <> b@OtherError {} = ManyErrors [ a, b ]
+    a <> b = ManyErrors [ a, b ]
 
 instance Monoid ErebosError where
     mempty = ManyErrors []
@@ -31,9 +36,14 @@ instance Monoid ErebosError where
 
 class FromErebosError e where
     fromErebosError :: ErebosError -> e
+    toErebosError :: e -> Maybe ErebosError
 
 instance FromErebosError ErebosError where
     fromErebosError = id
+    toErebosError = Just
+
+throwErebosError :: (MonadError e m, FromErebosError e) => ErebosError -> m a
+throwErebosError = throwError . fromErebosError
 
 throwOtherError :: (MonadError e m, FromErebosError e) => String -> m a
-throwOtherError = throwError . fromErebosError . OtherError
+throwOtherError = throwErebosError . OtherError
diff --git a/src/Erebos/Network.hs b/src/Erebos/Network.hs
index 6265bbf..b5cfa6b 100644
--- a/src/Erebos/Network.hs
+++ b/src/Erebos/Network.hs
@@ -1060,7 +1060,7 @@ modifyServiceGlobalState server proxy f = do
                 putTMVar (serverServiceStates server) global'
                 return res
         Nothing -> do
-            throwOtherError $ "unhandled service '" ++ show (toUUID svc) ++ "'"
+            throwErebosError $ UnhandledService svc
 
 
 foreign import ccall unsafe "Network/ifaddrs.h erebos_join_multicast" cJoinMulticast :: CInt -> Ptr CSize -> IO (Ptr Word32)
diff --git a/src/Erebos/Network/Protocol.hs b/src/Erebos/Network/Protocol.hs
index f67e296..463bf40 100644
--- a/src/Erebos/Network/Protocol.hs
+++ b/src/Erebos/Network/Protocol.hs
@@ -111,7 +111,10 @@ data TransportHeaderItem
     deriving (Eq, Show)
 
 newtype ServiceID = ServiceID UUID
-    deriving (Eq, Ord, Show, StorableUUID)
+    deriving (Eq, Ord, StorableUUID)
+
+instance Show ServiceID where
+    show = show . toUUID
 
 newtype Cookie = Cookie ByteString
     deriving (Eq, Show)
diff --git a/src/Erebos/Network/Protocol.hs-boot b/src/Erebos/Network/Protocol.hs-boot
new file mode 100644
index 0000000..2ac46b5
--- /dev/null
+++ b/src/Erebos/Network/Protocol.hs-boot
@@ -0,0 +1,6 @@
+module Erebos.Network.Protocol where
+
+import Erebos.UUID (UUID)
+
+newtype ServiceID = ServiceID UUID
+instance Show ServiceID