summaryrefslogtreecommitdiff
path: root/Remote/Tahoe.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2014-01-08 19:17:18 -0400
committerGravatar Joey Hess <joey@kitenet.net>2014-01-08 19:17:18 -0400
commit5e515fc4a87bf40fc4cd09933f25d30447451c1a (patch)
tree78d944e7c020acf6b4ab47b5d7b9c88068a35548 /Remote/Tahoe.hs
parent05896113f7b5e21e8053e39b8851a9ed82a08565 (diff)
only run tahoe start once
Diffstat (limited to 'Remote/Tahoe.hs')
-rw-r--r--Remote/Tahoe.hs75
1 files changed, 49 insertions, 26 deletions
diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs
index 8c7b612f6..c5494939a 100644
--- a/Remote/Tahoe.hs
+++ b/Remote/Tahoe.hs
@@ -25,6 +25,7 @@ module Remote.Tahoe (remote) where
import qualified Data.Map as M
import Data.Aeson
import Data.ByteString.Lazy.UTF8 (fromString)
+import Control.Concurrent.STM
import Common.Annex
import Types.Remote
@@ -39,6 +40,9 @@ import Utility.UserInfo
import Utility.Metered
import Utility.Env
+{- The TMVar is left empty until tahoe has been verified to be running. -}
+data TahoeHandle = TahoeHandle TahoeConfigDir (TMVar ())
+
type TahoeConfigDir = FilePath
type SharedConvergenceSecret = String
type IntroducerFurl = String
@@ -55,16 +59,18 @@ remote = RemoteType {
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen r u c gc = do
cst <- remoteCost gc expensiveRemoteCost
- configdir <- liftIO $ maybe (defaultTahoeConfigDir u) return (remoteAnnexTahoe gc)
+ hdl <- liftIO $ TahoeHandle
+ <$> maybe (defaultTahoeConfigDir u) return (remoteAnnexTahoe gc)
+ <*> newEmptyTMVarIO
return $ Just $ Remote {
uuid = u,
cost = cst,
name = Git.repoDescribe r,
- storeKey = store u configdir,
- retrieveKeyFile = retrieve u configdir,
+ storeKey = store u hdl,
+ retrieveKeyFile = retrieve u hdl,
retrieveKeyFileCheap = \_ _ -> return False,
removeKey = remove,
- hasKey = checkPresent u configdir,
+ hasKey = checkPresent u hdl,
hasKeyCheap = False,
whereisKey = Nothing,
remoteFsck = Nothing,
@@ -98,36 +104,31 @@ tahoeSetup mu c = do
furlk = "introducer-furl"
missingfurl = error "Set TAHOE_FURL to the introducer furl to use."
-store :: UUID -> TahoeConfigDir -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
-store u configdir k _f _p = sendAnnex k noop $ \src -> do
- liftIO $ startTahoeDaemon configdir
- parsePut <$> liftIO (readTahoe configdir "put" [File src]) >>= maybe
+store :: UUID -> TahoeHandle -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
+store u hdl k _f _p = sendAnnex k noop $ \src ->
+ parsePut <$> liftIO (readTahoe hdl "put" [File src]) >>= maybe
(return False)
(\cap -> storeCapability u k cap >> return True)
-retrieve :: UUID -> TahoeConfigDir -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
-retrieve u configdir k _f d _p = go =<< getCapability u k
+retrieve :: UUID -> TahoeHandle -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
+retrieve u hdl k _f d _p = go =<< getCapability u k
where
go Nothing = return False
- go (Just cap) = liftIO $ do
- startTahoeDaemon configdir
- boolTahoe configdir "get" [Param cap, File d]
+ go (Just cap) = liftIO $ requestTahoe hdl "get" [Param cap, File d]
remove :: Key -> Annex Bool
remove _k = do
warning "content cannot be removed from tahoe remote"
return False
-checkPresent :: UUID -> TahoeConfigDir -> Key -> Annex (Either String Bool)
-checkPresent u configdir k = go =<< getCapability u k
+checkPresent :: UUID -> TahoeHandle -> Key -> Annex (Either String Bool)
+checkPresent u hdl k = go =<< getCapability u k
where
go Nothing = return (Right False)
- go (Just cap) = liftIO $ do
- startTahoeDaemon configdir
- parseCheck <$> readTahoe configdir "check"
- [ Param "--raw"
- , Param cap
- ]
+ go (Just cap) = liftIO $ parseCheck <$> readTahoe hdl "check"
+ [ Param "--raw"
+ , Param cap
+ ]
defaultTahoeConfigDir :: UUID -> IO TahoeConfigDir
defaultTahoeConfigDir u = do
@@ -174,18 +175,40 @@ getSharedConvergenceSecret configdir = go (60 :: Int)
convergenceFile :: TahoeConfigDir -> FilePath
convergenceFile configdir = configdir </> "private" </> "convergence"
-{- XXX Avoid starting tahoe if it is already running. -}
startTahoeDaemon :: TahoeConfigDir -> IO ()
startTahoeDaemon configdir = void $ boolTahoe configdir "start" []
+{- Ensures that tahoe has been started, before running an action
+ - that uses it. -}
+withTahoeConfigDir :: TahoeHandle -> (TahoeConfigDir -> IO a) -> IO a
+withTahoeConfigDir (TahoeHandle configdir v) a = go =<< atomically needsstart
+ where
+ go True = do
+ startTahoeDaemon configdir
+ a configdir
+ go False = a configdir
+ needsstart = ifM (isEmptyTMVar v)
+ ( do
+ putTMVar v ()
+ return True
+ , return False
+ )
+
boolTahoe :: TahoeConfigDir -> String -> [CommandParam] -> IO Bool
boolTahoe configdir command params = boolSystem "tahoe" $
tahoeParams configdir command params
-readTahoe :: TahoeConfigDir -> String -> [CommandParam] -> IO String
-readTahoe configdir command params = catchDefaultIO "" $
- readProcess "tahoe" $ toCommand $
- tahoeParams configdir command params
+{- Runs a tahoe command that requests the daemon do something. -}
+requestTahoe :: TahoeHandle -> String -> [CommandParam] -> IO Bool
+requestTahoe hdl command params = withTahoeConfigDir hdl $ \configdir ->
+ boolTahoe configdir command params
+
+{- Runs a tahoe command that requests the daemon output something. -}
+readTahoe :: TahoeHandle -> String -> [CommandParam] -> IO String
+readTahoe hdl command params = withTahoeConfigDir hdl $ \configdir ->
+ catchDefaultIO "" $
+ readProcess "tahoe" $ toCommand $
+ tahoeParams configdir command params
tahoeParams :: TahoeConfigDir -> String -> [CommandParam] -> [CommandParam]
tahoeParams configdir command params =