Split to library and executable parts

1 files changed, 0 insertions, 796 deletions

diff --git a/src/Network.hs b/src/Network.hs
deleted file mode 100644
index 58e9816..0000000
--- a/src/Network.hs
+++ /dev/null
@@ -1,796 +0,0 @@
-module Network (
-    Server,
-    startServer,
-    stopServer,
-    getNextPeerChange,
-    ServerOptions(..), serverIdentity, defaultServerOptions,
-
-    Peer, peerServer, peerStorage,
-    PeerAddress(..), peerAddress,
-    PeerIdentity(..), peerIdentity,
-    WaitingRef, wrDigest,
-    Service(..),
-    serverPeer, serverPeerIce,
-    sendToPeer, sendToPeerStored, sendToPeerWith,
-    runPeerService,
-
-    discoveryPort,
-) where
-
-import Control.Concurrent
-import Control.Concurrent.STM
-import Control.Exception
-import Control.Monad
-import Control.Monad.Except
-import Control.Monad.Reader
-import Control.Monad.State
-
-import qualified Data.ByteString.Char8 as BC
-import Data.Function
-import Data.IP qualified as IP
-import Data.List
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Maybe
-import Data.Typeable
-import Data.Word
-
-import Foreign.Ptr
-import Foreign.Storable
-
-import GHC.Conc.Sync (unsafeIOToSTM)
-
-import Network.Socket hiding (ControlMessage)
-import qualified Network.Socket.ByteString as S
-
-import Channel
-import ICE
-import Identity
-import Network.Protocol
-import PubKey
-import Service
-import State
-import Storage
-import Storage.Key
-import Storage.Merge
-
-
-discoveryPort :: PortNumber
-discoveryPort = 29665
-
-announceIntervalSeconds :: Int
-announceIntervalSeconds = 60
-
-
-data Server = Server
-    { serverStorage :: Storage
-    , serverOrigHead :: Head LocalState
-    , serverIdentity_ :: MVar UnifiedIdentity
-    , serverThreads :: MVar [ThreadId]
-    , serverSocket :: MVar Socket
-    , serverRawPath :: SymFlow (PeerAddress, BC.ByteString)
-    , serverControlFlow :: Flow (ControlMessage PeerAddress) (ControlRequest PeerAddress)
-    , serverDataResponse :: TQueue (Peer, Maybe PartialRef)
-    , serverIOActions :: TQueue (ExceptT String IO ())
-    , serverServices :: [SomeService]
-    , serverServiceStates :: TMVar (M.Map ServiceID SomeServiceGlobalState)
-    , serverPeers :: MVar (Map PeerAddress Peer)
-    , serverChanPeer :: TChan Peer
-    , serverErrorLog :: TQueue String
-    }
-
-serverIdentity :: Server -> IO UnifiedIdentity
-serverIdentity = readMVar . serverIdentity_
-
-getNextPeerChange :: Server -> IO Peer
-getNextPeerChange = atomically . readTChan . serverChanPeer
-
-data ServerOptions = ServerOptions
-    { serverPort :: PortNumber
-    , serverLocalDiscovery :: Bool
-    }
-
-defaultServerOptions :: ServerOptions
-defaultServerOptions = ServerOptions
-    { serverPort = discoveryPort
-    , serverLocalDiscovery = True
-    }
-
-
-data Peer = Peer
-    { peerAddress :: PeerAddress
-    , peerServer_ :: Server
-    , peerConnection :: TVar (Either [(Bool, TransportPacket Ref, [TransportHeaderItem])] (Connection PeerAddress))
-    , peerIdentityVar :: TVar PeerIdentity
-    , peerStorage_ :: Storage
-    , peerInStorage :: PartialStorage
-    , peerServiceState :: TMVar (M.Map ServiceID SomeServiceState)
-    , peerWaitingRefs :: TMVar [WaitingRef]
-    }
-
-peerServer :: Peer -> Server
-peerServer = peerServer_
-
-peerStorage :: Peer -> Storage
-peerStorage = peerStorage_
-
-getPeerChannel :: Peer -> STM ChannelState
-getPeerChannel Peer {..} = either (const $ return ChannelNone) connGetChannel =<< readTVar peerConnection
-
-setPeerChannel :: Peer -> ChannelState -> STM ()
-setPeerChannel Peer {..} ch = do
-    readTVar peerConnection >>= \case
-        Left _ -> retry
-        Right conn -> connSetChannel conn ch
-
-instance Eq Peer where
-    (==) = (==) `on` peerIdentityVar
-
-data PeerAddress = DatagramAddress SockAddr
-                 | PeerIceSession IceSession
-
-instance Show PeerAddress where
-    show (DatagramAddress saddr) = unwords $ case IP.fromSockAddr saddr of
-        Just (IP.IPv6 ipv6, port)
-            | (0, 0, 0xffff, ipv4) <- IP.fromIPv6w ipv6
-            -> [show (IP.toIPv4w ipv4), show port]
-        Just (addr, port)
-            -> [show addr, show port]
-        _ -> [show saddr]
-    show (PeerIceSession ice) = show ice
-
-instance Eq PeerAddress where
-    DatagramAddress addr == DatagramAddress addr' = addr == addr'
-    PeerIceSession ice   == PeerIceSession ice'   = ice == ice'
-    _                    == _                     = False
-
-instance Ord PeerAddress where
-    compare (DatagramAddress addr) (DatagramAddress addr') = compare addr addr'
-    compare (DatagramAddress _   ) _                       = LT
-    compare _                      (DatagramAddress _    ) = GT
-    compare (PeerIceSession ice  ) (PeerIceSession ice')   = compare ice ice'
-
-
-data PeerIdentity = PeerIdentityUnknown (TVar [UnifiedIdentity -> ExceptT String IO ()])
-                  | PeerIdentityRef WaitingRef (TVar [UnifiedIdentity -> ExceptT String IO ()])
-                  | PeerIdentityFull UnifiedIdentity
-
-peerIdentity :: MonadIO m => Peer -> m PeerIdentity
-peerIdentity = liftIO . atomically . readTVar . peerIdentityVar
-
-
-lookupServiceType :: [TransportHeaderItem] -> Maybe ServiceID
-lookupServiceType (ServiceType stype : _) = Just stype
-lookupServiceType (_ : hs) = lookupServiceType hs
-lookupServiceType [] = Nothing
-
-
-newWaitingRef :: RefDigest -> (Ref -> WaitingRefCallback) -> PacketHandler WaitingRef
-newWaitingRef dgst act = do
-    peer@Peer {..} <- gets phPeer
-    wref <- WaitingRef peerStorage_ (partialRefFromDigest peerInStorage dgst) act <$> liftSTM (newTVar (Left []))
-    modifyTMVarP peerWaitingRefs (wref:)
-    liftSTM $ writeTQueue (serverDataResponse $ peerServer peer) (peer, Nothing)
-    return wref
-
-
-forkServerThread :: Server -> IO () -> IO ()
-forkServerThread server act = modifyMVar_ (serverThreads server) $ \ts -> do
-    (:ts) <$> forkIO act
-
-startServer :: ServerOptions -> Head LocalState -> (String -> IO ()) -> [SomeService] -> IO Server
-startServer opt serverOrigHead logd' serverServices = do
-    let serverStorage = headStorage serverOrigHead
-    serverIdentity_ <- newMVar $ headLocalIdentity serverOrigHead
-    serverThreads <- newMVar []
-    serverSocket <- newEmptyMVar
-    (serverRawPath, protocolRawPath) <- newFlowIO
-    (serverControlFlow, protocolControlFlow) <- newFlowIO
-    serverDataResponse <- newTQueueIO
-    serverIOActions <- newTQueueIO
-    serverServiceStates <- newTMVarIO M.empty
-    serverPeers <- newMVar M.empty
-    serverChanPeer <- newTChanIO
-    serverErrorLog <- newTQueueIO
-    let server = Server {..}
-
-    chanSvc <- newTQueueIO
-
-    let logd = writeTQueue serverErrorLog
-    forkServerThread server $ forever $ do
-        logd' =<< atomically (readTQueue serverErrorLog)
-
-    forkServerThread server $ dataResponseWorker server
-    forkServerThread server $ forever $ do
-        either (atomically . logd) return =<< runExceptT =<<
-            atomically (readTQueue serverIOActions)
-
-    broadcastAddreses <- getBroadcastAddresses discoveryPort
-
-    let open addr = do
-            sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
-            putMVar serverSocket sock
-            setSocketOption sock ReuseAddr 1
-            setSocketOption sock Broadcast 1
-            withFdSocket sock setCloseOnExecIfNeeded
-            bind sock (addrAddress addr)
-            return sock
-
-        loop sock = do
-            when (serverLocalDiscovery opt) $ forkServerThread server $ forever $ do
-                atomically $ writeFlowBulk serverControlFlow $ map (SendAnnounce . DatagramAddress) broadcastAddreses
-                threadDelay $ announceIntervalSeconds * 1000 * 1000
-
-            let announceUpdate identity = do
-                    st <- derivePartialStorage serverStorage
-                    let selfRef = partialRef st $ storedRef $ idExtData identity
-                        updateRefs = map refDigest $ selfRef : map (partialRef st . storedRef) (idUpdates identity)
-                        ackedBy = concat [[ Acknowledged r, Rejected r, DataRequest r ] | r <- updateRefs ]
-                        hitems = map AnnounceUpdate updateRefs
-                        packet = TransportPacket (TransportHeader $  hitems) []
-
-                    ps <- readMVar serverPeers
-                    forM_ ps $ \peer -> atomically $ do
-                        ((,) <$> readTVar (peerIdentityVar peer) <*> getPeerChannel peer) >>= \case
-                            (PeerIdentityFull _, ChannelEstablished _) ->
-                                sendToPeerS peer ackedBy packet
-                            _  -> return ()
-
-            void $ watchHead serverOrigHead $ \h -> do
-                let idt = headLocalIdentity h
-                changedId <- modifyMVar serverIdentity_ $ \cur ->
-                    return (idt, cur /= idt)
-                when changedId $ do
-                    writeFlowIO serverControlFlow $ UpdateSelfIdentity idt
-                    announceUpdate idt
-
-            forM_ serverServices $ \(SomeService service _) -> do
-                forM_ (serviceStorageWatchers service) $ \(SomeStorageWatcher sel act) -> do
-                    watchHeadWith serverOrigHead (sel . headStoredObject) $ \x -> do
-                        withMVar serverPeers $ mapM_ $ \peer -> atomically $ do
-                            readTVar (peerIdentityVar peer) >>= \case
-                                PeerIdentityFull _ -> writeTQueue serverIOActions $ do
-                                    runPeerService peer $ act x
-                                _ -> return ()
-
-            forkServerThread server $ forever $ do
-                (msg, saddr) <- S.recvFrom sock 4096
-                writeFlowIO serverRawPath (DatagramAddress saddr, msg)
-
-            forkServerThread server $ forever $ do
-                (paddr, msg) <- readFlowIO serverRawPath
-                case paddr of
-                    DatagramAddress addr -> void $ S.sendTo sock msg addr
-                    PeerIceSession ice   -> iceSend ice msg
-
-            forkServerThread server $ forever $ do
-                readFlowIO serverControlFlow >>= \case
-                    NewConnection conn mbpid -> do
-                        let paddr = connAddress conn
-                        peer <- modifyMVar serverPeers $ \pvalue -> do
-                            case M.lookup paddr pvalue of
-                                Just peer -> return (pvalue, peer)
-                                Nothing -> do
-                                    peer <- mkPeer server paddr
-                                    return (M.insert paddr peer pvalue, peer)
-
-                        forkServerThread server $ do
-                            atomically $ do
-                                readTVar (peerConnection peer) >>= \case
-                                    Left packets -> writeFlowBulk (connData conn) $ reverse packets
-                                    Right _ -> return ()
-                                writeTVar (peerConnection peer) (Right conn)
-
-                            case mbpid of
-                                Just dgst -> do
-                                    identity <- readMVar serverIdentity_
-                                    atomically $ runPacketHandler False peer $ do
-                                        wref <- newWaitingRef dgst $ handleIdentityAnnounce identity peer
-                                        readTVarP (peerIdentityVar peer) >>= \case
-                                            PeerIdentityUnknown idwait -> do
-                                                addHeader $ AnnounceSelf $ refDigest $ storedRef $ idData identity
-                                                writeTVarP (peerIdentityVar peer) $ PeerIdentityRef wref idwait
-                                                liftSTM $ writeTChan serverChanPeer peer
-                                            _ -> return ()
-                                Nothing -> return ()
-
-                            forever $ do
-                                (secure, TransportPacket header objs) <- readFlowIO $ connData conn
-                                prefs <- forM objs $ storeObject $ peerInStorage peer
-                                identity <- readMVar serverIdentity_
-                                let svcs = map someServiceID serverServices
-                                handlePacket identity secure peer chanSvc svcs header prefs
-
-                    ReceivedAnnounce addr _ -> do
-                        void $ serverPeer' server addr
-
-            erebosNetworkProtocol (headLocalIdentity serverOrigHead) logd protocolRawPath protocolControlFlow
-
-    forkServerThread server $ withSocketsDo $ do
-        let hints = defaultHints
-              { addrFlags = [AI_PASSIVE]
-              , addrFamily = AF_INET6
-              , addrSocketType = Datagram
-              }
-        addr:_ <- getAddrInfo (Just hints) Nothing (Just $ show $ serverPort opt)
-        bracket (open addr) close loop
-
-    forkServerThread server $ forever $ do
-        (peer, svc, ref) <- atomically $ readTQueue chanSvc
-        case find ((svc ==) . someServiceID) serverServices of
-            Just service@(SomeService (_ :: Proxy s) attr) -> runPeerServiceOn (Just (service, attr)) peer (serviceHandler $ wrappedLoad @s ref)
-            _ -> atomically $ logd $ "unhandled service '" ++ show (toUUID svc) ++ "'"
-
-    return server
-
-stopServer :: Server -> IO ()
-stopServer Server {..} = do
-    mapM_ killThread =<< takeMVar serverThreads
-
-dataResponseWorker :: Server -> IO ()
-dataResponseWorker server = forever $ do
-    (peer, npref) <- atomically (readTQueue $ serverDataResponse server)
-
-    wait <- atomically $ takeTMVar (peerWaitingRefs peer)
-    list <- forM wait $ \wr@WaitingRef { wrefStatus = tvar } ->
-        atomically (readTVar tvar) >>= \case
-            Left ds -> case maybe id (filter . (/=) . refDigest) npref $ ds of
-                [] -> copyRef (wrefStorage wr) (wrefPartial wr) >>= \case
-                          Right ref -> do
-                              atomically (writeTVar tvar $ Right ref)
-                              forkServerThread server $ runExceptT (wrefAction wr ref) >>= \case
-                                  Left err -> atomically $ writeTQueue (serverErrorLog server) err
-                                  Right () -> return ()
-
-                              return (Nothing, [])
-                          Left dgst -> do
-                              atomically (writeTVar tvar $ Left [dgst])
-                              return (Just wr, [dgst])
-                ds' -> do
-                    atomically (writeTVar tvar $ Left ds')
-                    return (Just wr, [])
-            Right _ -> return (Nothing, [])
-    atomically $ putTMVar (peerWaitingRefs peer) $ catMaybes $ map fst list
-
-    let reqs = concat $ map snd list
-    when (not $ null reqs) $ do
-        let packet = TransportPacket (TransportHeader $ map DataRequest reqs) []
-            ackedBy = concat [[ Rejected r, DataResponse r ] | r <- reqs ]
-        atomically $ sendToPeerPlain peer ackedBy packet
-
-
-newtype PacketHandler a = PacketHandler { unPacketHandler :: StateT PacketHandlerState (ExceptT String STM) a }
-    deriving (Functor, Applicative, Monad, MonadState PacketHandlerState, MonadError String)
-
-instance MonadFail PacketHandler where
-    fail = throwError
-
-runPacketHandler :: Bool -> Peer -> PacketHandler () -> STM ()
-runPacketHandler secure peer@Peer {..} act = do
-    let logd = writeTQueue $ serverErrorLog peerServer_
-    runExceptT (flip execStateT (PacketHandlerState peer [] [] []) $ unPacketHandler act) >>= \case
-        Left err -> do
-            logd $ "Error in handling packet from " ++ show peerAddress ++ ": " ++ err
-        Right ph -> do
-            when (not $ null $ phHead ph) $ do
-                let packet = TransportPacket (TransportHeader $ phHead ph) (phBody ph)
-                sendToPeerS' secure peer (phAckedBy ph) packet
-
-liftSTM :: STM a -> PacketHandler a
-liftSTM = PacketHandler . lift . lift
-
-readTVarP :: TVar a -> PacketHandler a
-readTVarP = liftSTM . readTVar
-
-writeTVarP :: TVar a -> a -> PacketHandler ()
-writeTVarP v = liftSTM . writeTVar v
-
-modifyTMVarP :: TMVar a -> (a -> a) -> PacketHandler ()
-modifyTMVarP v f = liftSTM $ putTMVar v . f =<< takeTMVar v
-
-data PacketHandlerState = PacketHandlerState
-    { phPeer :: Peer
-    , phHead :: [TransportHeaderItem]
-    , phAckedBy :: [TransportHeaderItem]
-    , phBody :: [Ref]
-    }
-
-addHeader :: TransportHeaderItem -> PacketHandler ()
-addHeader h = modify $ \ph -> ph { phHead = h `appendDistinct` phHead ph }
-
-addAckedBy :: [TransportHeaderItem] -> PacketHandler ()
-addAckedBy hs = modify $ \ph -> ph { phAckedBy = foldr appendDistinct (phAckedBy ph) hs }
-
-addBody :: Ref -> PacketHandler ()
-addBody r = modify $ \ph -> ph { phBody = r `appendDistinct` phBody ph }
-
-appendDistinct :: Eq a => a -> [a] -> [a]
-appendDistinct x (y:ys) | x == y    = y : ys
-                        | otherwise = y : appendDistinct x ys
-appendDistinct x [] = [x]
-
-handlePacket :: UnifiedIdentity -> Bool
-    -> Peer -> TQueue (Peer, ServiceID, Ref) -> [ServiceID]
-    -> TransportHeader -> [PartialRef] -> IO ()
-handlePacket identity secure peer chanSvc svcs (TransportHeader headers) prefs = atomically $ do
-    let server = peerServer peer
-    ochannel <- getPeerChannel peer
-    let sidentity = idData identity
-        plaintextRefs = map (refDigest . storedRef) $ concatMap (collectStoredObjects . wrappedLoad) $ concat
-            [ [ storedRef sidentity ]
-            , map storedRef $ idUpdates identity
-            , case ochannel of
-                   ChannelOurRequest _ req  -> [ storedRef req ]
-                   ChannelOurAccept _ acc _ -> [ storedRef acc ]
-                   _                        -> []
-            ]
-
-    runPacketHandler secure peer $ do
-        let logd = liftSTM . writeTQueue (serverErrorLog server)
-        forM_ headers $ \case
-            Acknowledged dgst -> do
-                liftSTM (getPeerChannel peer) >>= \case
-                    ChannelOurAccept _ acc ch | refDigest (storedRef acc) == dgst -> do
-                        liftSTM $ finalizedChannel peer ch identity
-                    _ -> return ()
-
-            Rejected dgst -> do
-                logd $ "rejected by peer: " ++ show dgst
-
-            DataRequest dgst
-                | secure || dgst `elem` plaintextRefs -> do
-                    Right mref <- liftSTM $ unsafeIOToSTM $
-                        copyRef (peerStorage peer) $
-                        partialRefFromDigest (peerInStorage peer) dgst
-                    addHeader $ DataResponse dgst
-                    addAckedBy [ Acknowledged dgst, Rejected dgst ]
-                    addBody $ mref
-                | otherwise -> do
-                    logd $ "unauthorized data request for " ++ show dgst
-                    addHeader $ Rejected dgst
-
-            DataResponse dgst -> if
-                | Just pref <- find ((==dgst) . refDigest) prefs -> do
-                    when (not secure) $ do
-                        addHeader $ Acknowledged dgst
-                    liftSTM $ writeTQueue (serverDataResponse server) (peer, Just pref)
-                | otherwise -> throwError $ "mismatched data response " ++ show dgst
-
-            AnnounceSelf dgst
-                | dgst == refDigest (storedRef sidentity) -> return ()
-                | otherwise -> do
-                    wref <- newWaitingRef dgst $ handleIdentityAnnounce identity peer
-                    readTVarP (peerIdentityVar peer) >>= \case
-                        PeerIdentityUnknown idwait -> do
-                            addHeader $ AnnounceSelf $ refDigest $ storedRef $ idData identity
-                            writeTVarP (peerIdentityVar peer) $ PeerIdentityRef wref idwait
-                            liftSTM $ writeTChan (serverChanPeer $ peerServer peer) peer
-                        _ -> return ()
-
-            AnnounceUpdate dgst -> do
-                readTVarP (peerIdentityVar peer) >>= \case
-                    PeerIdentityFull _ -> do
-                        void $ newWaitingRef dgst $ handleIdentityUpdate peer
-                    _ -> return ()
-
-            TrChannelRequest dgst -> do
-                let process cookie = do
-                        addHeader $ Acknowledged dgst
-                        wref <- newWaitingRef dgst $ handleChannelRequest peer identity
-                        liftSTM $ setPeerChannel peer $ ChannelPeerRequest cookie wref
-                    reject = addHeader $ Rejected dgst
-
-                liftSTM (getPeerChannel peer) >>= \case
-                    ChannelNone {} -> return ()
-                    ChannelCookieWait {} -> return ()
-                    ChannelCookieReceived cookie -> process $ Just cookie
-                    ChannelCookieConfirmed cookie -> process $ Just cookie
-                    ChannelOurRequest mbcookie our | dgst < refDigest (storedRef our) -> process mbcookie
-                                                   | otherwise -> reject
-                    ChannelPeerRequest mbcookie _ -> process mbcookie
-                    ChannelOurAccept {} -> reject
-                    ChannelEstablished {} -> process Nothing
-
-            TrChannelAccept dgst -> do
-                let process = do
-                        handleChannelAccept identity $ partialRefFromDigest (peerInStorage peer) dgst
-                    reject = addHeader $ Rejected dgst
-                liftSTM (getPeerChannel peer) >>= \case
-                    ChannelNone {} -> reject
-                    ChannelCookieWait {} -> reject
-                    ChannelCookieReceived {} -> reject
-                    ChannelCookieConfirmed {} -> reject
-                    ChannelOurRequest {} -> process
-                    ChannelPeerRequest {} -> process
-                    ChannelOurAccept _ our _ | dgst < refDigest (storedRef our) -> process
-                                             | otherwise -> addHeader $ Rejected dgst
-                    ChannelEstablished {} -> process
-
-            ServiceType _ -> return ()
-            ServiceRef dgst
-                | not secure -> throwError $ "service packet without secure channel"
-                | Just svc <- lookupServiceType headers -> if
-                    | svc `elem` svcs -> do
-                        if dgst `elem` map refDigest prefs || True {- TODO: used by Message service to confirm receive -}
-                           then do
-                                void $ newWaitingRef dgst $ \ref ->
-                                    liftIO $ atomically $ writeTQueue chanSvc (peer, svc, ref)
-                           else throwError $ "missing service object " ++ show dgst
-                    | otherwise -> addHeader $ Rejected dgst
-                | otherwise -> throwError $ "service ref without type"
-
-            _ -> return ()
-
-
-withPeerIdentity :: MonadIO m => Peer -> (UnifiedIdentity -> ExceptT String IO ()) -> m ()
-withPeerIdentity peer act = liftIO $ atomically $ readTVar (peerIdentityVar peer) >>= \case
-    PeerIdentityUnknown tvar -> modifyTVar' tvar (act:)
-    PeerIdentityRef _ tvar -> modifyTVar' tvar (act:)
-    PeerIdentityFull idt -> writeTQueue (serverIOActions $ peerServer peer) (act idt)
-
-
-setupChannel :: UnifiedIdentity -> Peer -> UnifiedIdentity -> WaitingRefCallback
-setupChannel identity peer upid = do
-    req <- flip runReaderT (peerStorage peer) $ createChannelRequest identity upid
-    let reqref = refDigest $ storedRef req
-    let hitems =
-            [ TrChannelRequest reqref
-            , AnnounceSelf $ refDigest $ storedRef $ idData identity
-            ]
-    liftIO $ atomically $ do
-        getPeerChannel peer >>= \case
-            ChannelCookieConfirmed cookie -> do
-                sendToPeerPlain peer [ Acknowledged reqref, Rejected reqref ] $
-                    TransportPacket (TransportHeader hitems) [storedRef req]
-                setPeerChannel peer $ ChannelOurRequest (Just cookie) req
-            _ -> return ()
-
-handleChannelRequest :: Peer -> UnifiedIdentity -> Ref -> WaitingRefCallback
-handleChannelRequest peer identity req = do
-    withPeerIdentity peer $ \upid -> do
-        (acc, ch) <- flip runReaderT (peerStorage peer) $ acceptChannelRequest identity upid (wrappedLoad req)
-        liftIO $ atomically $ do
-            getPeerChannel peer >>= \case
-                ChannelPeerRequest mbcookie wr | wrDigest wr == refDigest req -> do
-                    setPeerChannel peer $ ChannelOurAccept mbcookie acc ch
-                    let accref = refDigest $ storedRef acc
-                        header = TrChannelAccept accref
-                        ackedBy = [ Acknowledged accref, Rejected accref ]
-                    sendToPeerPlain peer ackedBy $ TransportPacket (TransportHeader [header]) $ concat
-                        [ [ storedRef $ acc ]
-                        , [ storedRef $ signedData $ fromStored acc ]
-                        , [ storedRef $ caKey $ fromStored $ signedData $ fromStored acc ]
-                        , map storedRef $ signedSignature $ fromStored acc
-                        ]
-                _ -> writeTQueue (serverErrorLog $ peerServer peer) $ "unexpected channel request"
-
-handleChannelAccept :: UnifiedIdentity -> PartialRef -> PacketHandler ()
-handleChannelAccept identity accref = do
-    peer <- gets phPeer
-    liftSTM $ writeTQueue (serverIOActions $ peerServer peer) $ do
-        withPeerIdentity peer $ \upid -> do
-            copyRef (peerStorage peer) accref >>= \case
-                Right acc -> do
-                    ch <- acceptedChannel identity upid (wrappedLoad acc)
-                    liftIO $ atomically $ do
-                        sendToPeerS peer [] $ TransportPacket (TransportHeader [Acknowledged $ refDigest accref]) []
-                        finalizedChannel peer ch identity
-
-                Left dgst -> throwError $ "missing accept data " ++ BC.unpack (showRefDigest dgst)
-
-
-finalizedChannel :: Peer -> Channel -> UnifiedIdentity -> STM ()
-finalizedChannel peer@Peer {..} ch self = do
-    setPeerChannel peer $ ChannelEstablished ch
-
-    -- Identity update
-    writeTQueue (serverIOActions peerServer_) $ liftIO $ atomically $ do
-        let selfRef = refDigest $ storedRef $ idExtData $ self
-            updateRefs = selfRef : map (refDigest . storedRef) (idUpdates self)
-            ackedBy = concat [[ Acknowledged r, Rejected r, DataRequest r ] | r <- updateRefs ]
-        sendToPeerS peer ackedBy $ flip TransportPacket [] $ TransportHeader $ map AnnounceUpdate updateRefs
-
-    -- Notify services about new peer
-    readTVar peerIdentityVar >>= \case
-        PeerIdentityFull _ -> notifyServicesOfPeer peer
-        _ -> return ()
-
-
-handleIdentityAnnounce :: UnifiedIdentity -> Peer -> Ref -> WaitingRefCallback
-handleIdentityAnnounce self peer ref = liftIO $ atomically $ do
-    let validateAndUpdate upds act = case validateIdentity $ wrappedLoad ref of
-            Just pid' -> do
-                let pid = fromMaybe pid' $ toUnifiedIdentity (updateIdentity upds pid')
-                writeTVar (peerIdentityVar peer) $ PeerIdentityFull pid
-                writeTChan (serverChanPeer $ peerServer peer) peer
-                act pid
-                writeTQueue (serverIOActions $ peerServer peer) $ do
-                    setupChannel self peer pid
-            Nothing -> return ()
-
-    readTVar (peerIdentityVar peer) >>= \case
-        PeerIdentityRef wref wact
-            | wrDigest wref == refDigest ref
-            -> validateAndUpdate [] $ \pid -> do
-                mapM_ (writeTQueue (serverIOActions $ peerServer peer) . ($ pid)) .
-                    reverse =<< readTVar wact
-
-        PeerIdentityFull pid
-            | idData pid `precedes` wrappedLoad ref
-            -> validateAndUpdate (idUpdates pid) $ \_ -> do
-                notifyServicesOfPeer peer
-
-        _ -> return ()
-
-handleIdentityUpdate :: Peer -> Ref -> WaitingRefCallback
-handleIdentityUpdate peer ref = liftIO $ atomically $ do
-    pidentity <- readTVar (peerIdentityVar peer)
-    if  | PeerIdentityFull pid <- pidentity
-        , Just pid' <- toUnifiedIdentity $ updateIdentity [wrappedLoad ref] pid
-        -> do
-            writeTVar (peerIdentityVar peer) $ PeerIdentityFull pid'
-            writeTChan (serverChanPeer $ peerServer peer) peer
-            when (idData pid /= idData pid') $ notifyServicesOfPeer peer
-
-        | otherwise -> return ()
-
-notifyServicesOfPeer :: Peer -> STM ()
-notifyServicesOfPeer peer@Peer { peerServer_ = Server {..} } = do
-    writeTQueue serverIOActions $ do
-        forM_ serverServices $ \service@(SomeService _ attrs) ->
-            runPeerServiceOn (Just (service, attrs)) peer serviceNewPeer
-
-
-mkPeer :: Server -> PeerAddress -> IO Peer
-mkPeer peerServer_ peerAddress = do
-    peerConnection <- newTVarIO (Left [])
-    peerIdentityVar <- newTVarIO . PeerIdentityUnknown =<< newTVarIO []
-    peerStorage_ <- deriveEphemeralStorage $ serverStorage peerServer_
-    peerInStorage <- derivePartialStorage peerStorage_
-    peerServiceState <- newTMVarIO M.empty
-    peerWaitingRefs <- newTMVarIO []
-    return Peer {..}
-
-serverPeer :: Server -> SockAddr -> IO Peer
-serverPeer server paddr = do
-    serverPeer' server (DatagramAddress paddr)
-
-serverPeerIce :: Server -> IceSession -> IO Peer
-serverPeerIce server@Server {..} ice = do
-    let paddr = PeerIceSession ice
-    peer <- serverPeer' server paddr
-    iceSetChan ice $ mapFlow undefined (paddr,) serverRawPath
-    return peer
-
-serverPeer' :: Server -> PeerAddress -> IO Peer
-serverPeer' server paddr = do
-    (peer, hello) <- modifyMVar (serverPeers server) $ \pvalue -> do
-        case M.lookup paddr pvalue of
-             Just peer -> return (pvalue, (peer, False))
-             Nothing -> do
-                 peer <- mkPeer server paddr
-                 return (M.insert paddr peer pvalue, (peer, True))
-    when hello $ atomically $ do
-        writeFlow (serverControlFlow server) (RequestConnection paddr)
-    return peer
-
-
-sendToPeer :: (Service s, MonadIO m) => Peer -> s -> m ()
-sendToPeer peer packet = sendToPeerList peer [ServiceReply (Left packet) True]
-
-sendToPeerStored :: (Service s, MonadIO m) => Peer -> Stored s -> m ()
-sendToPeerStored peer spacket = sendToPeerList peer [ServiceReply (Right spacket) True]
-
-sendToPeerList :: (Service s, MonadIO m) => Peer -> [ServiceReply s] -> m ()
-sendToPeerList peer parts = do
-    let st = peerStorage peer
-    srefs <- liftIO $ fmap catMaybes $ forM parts $ \case
-        ServiceReply (Left x) use -> Just . (,use) <$> store st x
-        ServiceReply (Right sx) use -> return $ Just (storedRef sx, use)
-        ServiceFinally act -> act >> return Nothing
-    let dgsts = map (refDigest . fst) srefs
-    let content = map fst $ filter snd srefs
-        header = TransportHeader (ServiceType (serviceID $ head parts) : map ServiceRef dgsts)
-        packet = TransportPacket header content
-        ackedBy = concat [[ Acknowledged r, Rejected r, DataRequest r ] | r <- dgsts ]
-    liftIO $ atomically $ sendToPeerS peer ackedBy packet
-
-sendToPeerS' :: Bool -> Peer -> [TransportHeaderItem] -> TransportPacket Ref -> STM ()
-sendToPeerS' secure Peer {..} ackedBy packet = do
-    readTVar peerConnection >>= \case
-        Left xs -> writeTVar peerConnection $ Left $ (secure, packet, ackedBy) : xs
-        Right conn -> writeFlow (connData conn) (secure, packet, ackedBy)
-
-sendToPeerS :: Peer -> [TransportHeaderItem] -> TransportPacket Ref -> STM ()
-sendToPeerS = sendToPeerS' True
-
-sendToPeerPlain :: Peer -> [TransportHeaderItem] -> TransportPacket Ref -> STM ()
-sendToPeerPlain = sendToPeerS' False
-
-sendToPeerWith :: forall s m. (Service s, MonadIO m, MonadError String m) => Peer -> (ServiceState s -> ExceptT String IO (Maybe s, ServiceState s)) -> m ()
-sendToPeerWith peer fobj = do
-    let sproxy = Proxy @s
-        sid = serviceID sproxy
-    res <- liftIO $ do
-        svcs <- atomically $ takeTMVar (peerServiceState peer)
-        (svcs', res) <- runExceptT (fobj $ fromMaybe (emptyServiceState sproxy) $ fromServiceState sproxy =<< M.lookup sid svcs) >>= \case
-            Right (obj, s') -> return $ (M.insert sid (SomeServiceState sproxy s') svcs, Right obj)
-            Left err -> return $ (svcs, Left err)
-        atomically $ putTMVar (peerServiceState peer) svcs'
-        return res
-
-    case res of
-         Right (Just obj) -> sendToPeer peer obj
-         Right Nothing -> return ()
-         Left err -> throwError err
-
-
-lookupService :: forall s. Service s => Proxy s -> [SomeService] -> Maybe (SomeService, ServiceAttributes s)
-lookupService proxy (service@(SomeService (_ :: Proxy t) attr) : rest)
-    | Just (Refl :: s :~: t) <- eqT = Just (service, attr)
-    | otherwise = lookupService proxy rest
-lookupService _ [] = Nothing
-
-runPeerService :: forall s m. (Service s, MonadIO m) => Peer -> ServiceHandler s () -> m ()
-runPeerService = runPeerServiceOn Nothing
-
-runPeerServiceOn :: forall s m. (Service s, MonadIO m) => Maybe (SomeService, ServiceAttributes s) -> Peer -> ServiceHandler s () -> m ()
-runPeerServiceOn mbservice peer handler = liftIO $ do
-    let server = peerServer peer
-        proxy = Proxy @s
-        svc = serviceID proxy
-        logd = writeTQueue (serverErrorLog server)
-    case mbservice `mplus` lookupService proxy (serverServices server) of
-        Just (service, attr) ->
-            atomically (readTVar (peerIdentityVar peer)) >>= \case
-                PeerIdentityFull peerId -> do
-                    (global, svcs) <- atomically $ (,)
-                        <$> takeTMVar (serverServiceStates server)
-                        <*> takeTMVar (peerServiceState peer)
-                    case (fromMaybe (someServiceEmptyState service) $ M.lookup svc svcs,
-                            fromMaybe (someServiceEmptyGlobalState service) $ M.lookup svc global) of
-                        ((SomeServiceState (_ :: Proxy ps) ps),
-                                (SomeServiceGlobalState (_ :: Proxy gs) gs)) -> do
-                            Just (Refl :: s :~: ps) <- return $ eqT
-                            Just (Refl :: s :~: gs) <- return $ eqT
-
-                            let inp = ServiceInput
-                                    { svcAttributes = attr
-                                    , svcPeer = peer
-                                    , svcPeerIdentity = peerId
-                                    , svcServer = server
-                                    , svcPrintOp = atomically . logd
-                                    }
-                            reloadHead (serverOrigHead server) >>= \case
-                                Nothing -> atomically $ do
-                                    logd $ "current head deleted"
-                                    putTMVar (peerServiceState peer) svcs
-                                    putTMVar (serverServiceStates server) global
-                                Just h -> do
-                                    (rsp, (s', gs')) <- runServiceHandler h inp ps gs handler
-                                    moveKeys (peerStorage peer) (serverStorage server)
-                                    when (not (null rsp)) $ do
-                                        sendToPeerList peer rsp
-                                    atomically $ do
-                                        putTMVar (peerServiceState peer) $ M.insert svc (SomeServiceState proxy s') svcs
-                                        putTMVar (serverServiceStates server) $ M.insert svc (SomeServiceGlobalState proxy gs') global
-                _ -> do
-                    atomically $ logd $ "can't run service handler on peer with incomplete identity " ++ show (peerAddress peer)
-
-        _ -> atomically $ do
-            logd $ "unhandled service '" ++ show (toUUID svc) ++ "'"
-
-
-foreign import ccall unsafe "Network/ifaddrs.h broadcast_addresses" cBroadcastAddresses :: IO (Ptr Word32)
-foreign import ccall unsafe "stdlib.h free" cFree :: Ptr Word32 -> IO ()
-
-getBroadcastAddresses :: PortNumber -> IO [SockAddr]
-getBroadcastAddresses port = do
-    ptr <- cBroadcastAddresses
-    let parse i = do
-            w <- peekElemOff ptr i
-            if w == 0 then return []
-                      else (SockAddrInet port w:) <$> parse (i + 1)
-    addrs <- parse 0
-    cFree ptr
-    return addrs