256d8f07e8Switch to Data.Map.Strict everywhere that used it. There are still lots of lazy maps in git-annex. I think switching these is safe. The risk is that there might be a map that is used in a way that relies on the values not being evaluated to WHNF, and switching to strict might result in bad performance or memory use. So, I have not switched everything.
79 lines
3 KiB
Haskell
79 lines
3 KiB
Haskell
{- git-annex assistant pairing
|
|
-
|
|
- Copyright 2016 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Assistant.WebApp.Pairing where
|
|
|
|
import Assistant.Common
|
|
import qualified Utility.MagicWormhole as Wormhole
|
|
import Command.P2P (wormholePairing, PairingResult(..))
|
|
import P2P.Address
|
|
import Annex.Concurrent
|
|
import Git.Types
|
|
|
|
import Control.Concurrent
|
|
import Control.Concurrent.Async
|
|
import Control.Concurrent.STM
|
|
import qualified Data.Map.Strict as M
|
|
|
|
data PairingWith = PairingWithSelf | PairingWithFriend
|
|
deriving (Eq, Show, Read)
|
|
|
|
type WormholePairingState = TVar (M.Map WormholePairingId WormholePairingHandle)
|
|
|
|
type WormholePairingHandle = (PairingWith, RemoteName, MVar Wormhole.CodeObserver, MVar Wormhole.Code, Async (Annex PairingResult))
|
|
|
|
newtype WormholePairingId = WormholePairingId Int
|
|
deriving (Ord, Eq, Show, Read)
|
|
|
|
newWormholePairingState :: IO WormholePairingState
|
|
newWormholePairingState = newTVarIO M.empty
|
|
|
|
addWormholePairingState :: WormholePairingHandle -> WormholePairingState -> IO WormholePairingId
|
|
addWormholePairingState h tv = atomically $ do
|
|
m <- readTVar tv
|
|
-- use of head is safe because allids is infinite
|
|
let i = Prelude.head $ filter (`notElem` M.keys m) allids
|
|
writeTVar tv (M.insert i h m)
|
|
return i
|
|
where
|
|
allids = map WormholePairingId [1..]
|
|
|
|
-- | Starts the wormhole pairing processes.
|
|
startWormholePairing :: PairingWith -> RemoteName -> [P2PAddress] -> Assistant WormholePairingHandle
|
|
startWormholePairing pairingwith remotename ouraddrs = do
|
|
observerrelay <- liftIO newEmptyMVar
|
|
producerrelay <- liftIO newEmptyMVar
|
|
-- wormholePairing needs to run in the Annex monad, and is a
|
|
-- long-duration action. So, don't just liftAnnex to run it;
|
|
-- fork the Annex state.
|
|
runner <- liftAnnex $ forkState $
|
|
wormholePairing remotename ouraddrs $ \observer producer -> do
|
|
putMVar observerrelay observer
|
|
theircode <- takeMVar producerrelay
|
|
Wormhole.sendCode producer theircode
|
|
tid <- liftIO $ async runner
|
|
return (pairingwith, remotename, observerrelay, producerrelay, tid)
|
|
|
|
-- | Call after sendTheirWormholeCode. This can take some time to return.
|
|
finishWormholePairing :: WormholePairingHandle -> Assistant PairingResult
|
|
finishWormholePairing (_, _, _, _, tid) = liftAnnex =<< liftIO (wait tid)
|
|
|
|
-- | Waits for wormhole to produce our code. Can be called repeatedly, safely.
|
|
getOurWormholeCode :: WormholePairingHandle -> IO Wormhole.Code
|
|
getOurWormholeCode (_, _, observerrelay, _, _) =
|
|
readMVar observerrelay >>= Wormhole.waitCode
|
|
|
|
-- | Sends their code to wormhole. If their code has already been sent,
|
|
-- avoids blocking and returns False.
|
|
sendTheirWormholeCode :: WormholePairingHandle -> Wormhole.Code -> IO Bool
|
|
sendTheirWormholeCode (_, _, _, producerrelay, _) = tryPutMVar producerrelay
|
|
|
|
withPairingWith :: WormholePairingHandle -> (PairingWith -> a) -> a
|
|
withPairingWith (pairingwith, _, _, _, _) a = a pairingwith
|
|
|
|
withRemoteName :: WormholePairingHandle -> (RemoteName -> a) -> a
|
|
withRemoteName (_, remotename, _, _, _) a = a remotename
|