Merge branch 'release-0.1'

5 files changed, 58 insertions, 55 deletions

diff --git a/erebos.cabal b/erebos.cabal
index 27716fa..ba23d0b 100644
--- a/erebos.cabal
+++ b/erebos.cabal
@@ -40,11 +40,12 @@ Flag ci
 
 source-repository head
     type:       git
-    location:   git://erebosprotocol.net/erebos
+    location:   https://code.erebosprotocol.net/erebos
 
 common common
     ghc-options:
         -Wall
+        -Wno-x-partial
         -fdefer-typed-holes
 
     if flag(ci)
@@ -54,7 +55,7 @@ common common
             -Wno-error=unused-imports
 
     build-depends:
-        base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20 },
+        base ^>= { 4.15, 4.16, 4.17, 4.18, 4.19, 4.20, 4.21 },
 
     default-extensions:
         DefaultSignatures
@@ -149,21 +150,21 @@ library
         binary >=0.8 && <0.11,
         bytestring >=0.10 && <0.13,
         clock >=0.8 && < 0.9,
-        containers >= 0.6 && <0.8,
-        crypton ^>= { 1.0 },
+        containers ^>= { 0.6, 0.7, 0.8 },
+        crypton ^>= { 0.34, 1.0 },
         deepseq >= 1.4 && <1.6,
         directory >= 1.3 && <1.4,
         filepath >=1.4 && <1.6,
-        fsnotify ^>= { 0.4 },
-        hashable >=1.3 && <1.5,
-        hashtables >=1.2 && <1.4,
+        fsnotify ^>= { 0.3, 0.4 },
+        hashable ^>= { 1.3, 1.4, 1.5 },
+        hashtables ^>= { 1.2, 1.3, 1.4 },
         iproute >=1.7.12 && <1.8,
         memory >=0.14 && <0.19,
         mtl >=2.2 && <2.4,
-        network >= 3.1 && <3.2,
+        network ^>= { 3.1, 3.2 },
         stm >=2.5 && <2.6,
         text >= 1.2 && <2.2,
-        time >= 1.8 && <1.14,
+        time ^>= { 1.8, 1.9, 1.10, 1.11, 1.12, 1.13, 1.14 },
         uuid >=1.3 && <1.4,
         zlib >=0.6 && <0.8
 
@@ -204,7 +205,7 @@ executable erebos
         network,
         process >=1.6 && <1.7,
         stm,
-        template-haskell ^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22 },
+        template-haskell ^>= { 2.17, 2.18, 2.19, 2.20, 2.21, 2.22, 2.23 },
         text,
         time,
         transformers >= 0.5 && <0.7,
diff --git a/src/Erebos/Discovery.hs b/src/Erebos/Discovery.hs
index cbb12ca..d900363 100644
--- a/src/Erebos/Discovery.hs
+++ b/src/Erebos/Discovery.hs
@@ -60,6 +60,8 @@ data DiscoveryConnection = DiscoveryConnection
     , dconnAddress :: Maybe Text
 #ifdef ENABLE_ICE_SUPPORT
     , dconnIceInfo :: Maybe IceRemoteInfo
+#else
+    , dconnIceInfo :: Maybe (Stored Object)
 #endif
     }
 
@@ -67,9 +69,7 @@ emptyConnection :: Ref -> Ref -> DiscoveryConnection
 emptyConnection dconnSource dconnTarget = DiscoveryConnection {..}
   where
     dconnAddress = Nothing
-#ifdef ENABLE_ICE_SUPPORT
     dconnIceInfo = Nothing
-#endif
 
 instance Storable DiscoveryService where
     store' x = storeRec $ do
@@ -96,9 +96,7 @@ instance Storable DiscoveryService where
                   storeRawRef "source" $ dconnSource conn
                   storeRawRef "target" $ dconnTarget conn
                   storeMbText "address" $ dconnAddress conn
-#ifdef ENABLE_ICE_SUPPORT
                   storeMbRef "ice-info" $ dconnIceInfo conn
-#endif
 
     load' = loadRec $ msum
             [ do
@@ -130,9 +128,7 @@ instance Storable DiscoveryService where
                       <$> loadRawRef "source"
                       <*> loadRawRef "target"
                       <*> loadMbText "address"
-#ifdef ENABLE_ICE_SUPPORT
                       <*> loadMbRef "ice-info"
-#endif
 
 data DiscoveryPeer = DiscoveryPeer
     { dpPriority :: Int
@@ -163,13 +159,19 @@ instance Service DiscoveryService where
             peer <- asks svcPeer
             let insertHelper new old | dpPriority new > dpPriority old = new
                                      | otherwise                       = old
-            matchedAddrs <- fmap catMaybes $ forM addrs $ \addr -> case words (T.unpack addr) of
-                [ipaddr, port] | DatagramAddress paddr <- peerAddress peer -> do
+            matchedAddrs <- fmap catMaybes $ forM addrs $ \addr -> if
+                | addr == T.pack "ICE" -> do
+                    return $ Just addr
+
+                | [ ipaddr, port ] <- words (T.unpack addr)
+                , DatagramAddress paddr <- peerAddress peer -> do
                     saddr <- liftIO $ head <$> getAddrInfo (Just $ defaultHints { addrSocketType = Datagram }) (Just ipaddr) (Just port)
                     return $ if paddr == addrAddress saddr
                                 then Just addr
                                 else Nothing
-                _ -> return Nothing
+
+                | otherwise -> return Nothing
+
             forM_ (idDataF =<< unfoldOwners pid) $ \s ->
                 svcModifyGlobal $ M.insertWith insertHelper (refDigest $ storedRef s) DiscoveryPeer
                     { dpPriority = fromMaybe 0 priority
@@ -179,39 +181,34 @@ instance Service DiscoveryService where
                     , dpIceSession = Nothing
 #endif
                     }
-            let matchedAddrs' = matchedAddrs
-#ifdef ENABLE_ICE_SUPPORT
-                    ++ filter (== T.pack "ICE") addrs
-#endif
             attrs <- asks svcAttributes
-            replyPacket $ DiscoveryAcknowledged matchedAddrs'
+            replyPacket $ DiscoveryAcknowledged matchedAddrs
                 (discoveryStunServer attrs)
                 (discoveryStunPort attrs)
                 (discoveryTurnServer attrs)
                 (discoveryTurnPort attrs)
 
-        DiscoveryAcknowledged addrs stunServer stunPort turnServer turnPort -> do
+        DiscoveryAcknowledged _ stunServer stunPort turnServer turnPort -> do
 #ifdef ENABLE_ICE_SUPPORT
-            when (T.pack "ICE" `elem` addrs) $ do
-                paddr <- asks (peerAddress . svcPeer) >>= return . \case
-                    (DatagramAddress saddr) -> case IP.fromSockAddr saddr of
-                        Just (IP.IPv6 ipv6, _)
-                            | (0, 0, 0xffff, ipv4) <- IP.fromIPv6w ipv6
-                            -> Just $ T.pack $ show (IP.toIPv4w ipv4)
-                        Just (addr, _)
-                            -> Just $ T.pack $ show addr
-                        _ -> Nothing
+            paddr <- asks (peerAddress . svcPeer) >>= return . \case
+                (DatagramAddress saddr) -> case IP.fromSockAddr saddr of
+                    Just (IP.IPv6 ipv6, _)
+                        | (0, 0, 0xffff, ipv4) <- IP.fromIPv6w ipv6
+                        -> Just $ T.pack $ show (IP.toIPv4w ipv4)
+                    Just (addr, _)
+                        -> Just $ T.pack $ show addr
                     _ -> Nothing
+                _ -> Nothing
 
-                let toIceServer Nothing Nothing = Nothing
-                    toIceServer Nothing (Just port) = ( , port) <$> paddr
-                    toIceServer (Just server) Nothing = Just ( server, 0 )
-                    toIceServer (Just server) (Just port) = Just ( server, port )
+            let toIceServer Nothing Nothing = Nothing
+                toIceServer Nothing (Just port) = ( , port) <$> paddr
+                toIceServer (Just server) Nothing = Just ( server, 0 )
+                toIceServer (Just server) (Just port) = Just ( server, port )
 
-                cfg <- liftIO $ iceCreateConfig
-                    (toIceServer stunServer stunPort)
-                    (toIceServer turnServer turnPort)
-                svcSet cfg
+            cfg <- liftIO $ iceCreateConfig
+                (toIceServer stunServer stunPort)
+                (toIceServer turnServer turnPort)
+            svcSet cfg
 #endif
             return ()
 
@@ -274,11 +271,11 @@ instance Service DiscoveryService where
                         svcPrint $ "Discovery: invalid address in result: " ++ T.unpack addr
 
         DiscoveryConnectionRequest conn -> do
-#ifdef ENABLE_ICE_SUPPORT
             self <- svcSelf
             let rconn = emptyConnection (dconnSource conn) (dconnTarget conn)
             if refDigest (dconnTarget conn) `elem` (map (refDigest . storedRef) $ idDataF =<< unfoldOwners self)
                then do
+#ifdef ENABLE_ICE_SUPPORT
                     -- request for us, create ICE sesssion
                     server <- asks svcServer
                     peer <- asks svcPeer
@@ -295,6 +292,9 @@ instance Service DiscoveryService where
                                     Left err -> putStrLn $ "Discovery: failed to send connection response: " ++ err
                         Nothing -> do
                             svcPrint $ "Discovery: ICE request from peer without ICE configuration"
+#else
+                    return ()
+#endif
 
                else do
                     -- request to some of our peers, relay
@@ -306,17 +306,14 @@ instance Service DiscoveryService where
                                 | Just dpeer <- dpPeer dp -> do
                                     sendToPeer dpeer $ DiscoveryConnectionRequest conn
                                 | otherwise -> svcPrint $ "Discovery: failed to relay connection request"
-#else
-            return ()
-#endif
 
         DiscoveryConnectionResponse conn -> do
-#ifdef ENABLE_ICE_SUPPORT
             self <- svcSelf
             dpeers <- svcGetGlobal
             if refDigest (dconnSource conn) `elem` (map (refDigest . storedRef) $ idDataF =<< unfoldOwners self)
                then do
                     -- response to our request, try to connect to the peer
+#ifdef ENABLE_ICE_SUPPORT
                     server <- asks svcServer
                     if  | Just addr <- dconnAddress conn
                         , [ipaddr, port] <- words (T.unpack addr) -> do
@@ -332,15 +329,15 @@ instance Service DiscoveryService where
                             liftIO $ iceConnect ice rinfo $ void $ serverPeerIce server ice
 
                         | otherwise -> svcPrint $ "Discovery: connection request failed"
+#else
+                    return ()
+#endif
                else do
                     -- response to relayed request
                     case M.lookup (refDigest $ dconnSource conn) dpeers of
                         Just dp | Just dpeer <- dpPeer dp -> do
                             sendToPeer dpeer $ DiscoveryConnectionResponse conn
                         _ -> svcPrint $ "Discovery: failed to relay connection response"
-#else
-            return ()
-#endif
 
     serviceNewPeer = do
         server <- asks svcServer
@@ -356,4 +353,5 @@ instance Service DiscoveryService where
 #endif
             ]
 
-        sendToPeer peer $ DiscoverySelf addrs Nothing
+        when (not $ null addrs) $ do
+            sendToPeer peer $ DiscoverySelf addrs Nothing
diff --git a/src/Erebos/ICE.chs b/src/Erebos/ICE.chs
index 06edecf..2c6f500 100644
--- a/src/Erebos/ICE.chs
+++ b/src/Erebos/ICE.chs
@@ -19,7 +19,7 @@ module Erebos.ICE (
 ) where
 
 import Control.Arrow
-import Control.Concurrent.MVar
+import Control.Concurrent
 import Control.Monad
 import Control.Monad.Identity
 
@@ -144,7 +144,11 @@ iceCreateConfig stun turn =
 iceCreateSession :: IceConfig -> IceSessionRole -> (IceSession -> IO ()) -> IO IceSession
 iceCreateSession icfg@(IceConfig fcfg) role cb = do
     rec sptr <- newStablePtr sess
-        cbptr <- newStablePtr $ cb sess
+        cbptr <- newStablePtr $ do
+            -- The callback may be called directly from pj_ice_strans_create or later
+            -- from a different thread; make sure we use a different thread here 
+            -- to avoid deadlock on accessing 'sess'.
+            forkIO $ cb sess
         sess <- IceSession
             <$> (withForeignPtr fcfg $ \cfg ->
                     {#call ice_create #} (castPtr cfg) (fromIntegral $ fromEnum role) (castStablePtrToPtr sptr) (castStablePtrToPtr cbptr)
diff --git a/src/Erebos/ICE/pjproject.c b/src/Erebos/ICE/pjproject.c
index 2374340..e79fb9d 100644
--- a/src/Erebos/ICE/pjproject.c
+++ b/src/Erebos/ICE/pjproject.c
@@ -397,7 +397,7 @@ void ice_send(pj_ice_strans * strans, const char * data, size_t len)
 		return;
 	}
 
-	pj_status_t status = pj_ice_strans_sendto(strans, 1, data, len,
+	pj_status_t status = pj_ice_strans_sendto2(strans, 1, data, len,
 			&ice.def_addr, pj_sockaddr_get_len(&ice.def_addr));
 	if (status != PJ_SUCCESS && status != PJ_EPENDING)
 		ice_perror("error sending data", status);
diff --git a/src/Erebos/Storage/Disk.hs b/src/Erebos/Storage/Disk.hs
index 01821f7..370c584 100644
--- a/src/Erebos/Storage/Disk.hs
+++ b/src/Erebos/Storage/Disk.hs
@@ -94,7 +94,7 @@ instance StorageBackend DiskStorage where
                 True -> return ilist
                 False -> do
                     void $ watchDir manager (headTypePath dirPath tid) (const True) $ \case
-                        Added { eventPath = fpath } | Just ihid <- HeadID <$> U.fromString (takeFileName fpath) -> do
+                        ev@Added {} | Just ihid <- HeadID <$> U.fromString (takeFileName (eventPath ev)) -> do
                             backendLoadHead st tid ihid >>= \case
                                 Just dgst -> do
                                     (_, _, iwl) <- readMVar dirWatchers