git-annex/Remote/Tahoe.hs

{- Tahoe-LAFS special remotes.
 -
 - Tahoe capabilities for accessing objects stored in the remote
 - are preserved in the remote state log.
 -
 - In order to allow multiple clones of a repository to access the same
 - tahoe repository, git-annex needs to store the introducer furl,
 - and the shared-convergence-secret. These are stored in the remote
 - configuration, when embedcreds is enabled.
 -
 - Using those creds, git-annex sets up a tahoe configuration directory in
 - ~/.tahoe/git-annex/UUID/
 -
 - Tahoe has its own encryption, so git-annex's encryption is not used.
 -
 - Copyright 2014 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

{-# LANGUAGE OverloadedStrings #-}

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
import Types.Creds
import qualified Git
import Config
import Config.Cost
import Remote.Helper.Special
import Annex.UUID
import Annex.Content
import Logs.RemoteState
import Utility.UserInfo
import Utility.Metered
import Utility.Env
import Utility.ThreadScheduler

{- 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
type Capability = String

remote :: RemoteType
remote = RemoteType {
	typename = "tahoe",
	enumerate = findSpecialRemotes "tahoe",
	generate = gen,
	setup = tahoeSetup
}

gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen r u c gc = do
	cst <- remoteCost gc expensiveRemoteCost
	hdl <- liftIO $ TahoeHandle
		<$> maybe (defaultTahoeConfigDir u) return (remoteAnnexTahoe gc)
		<*> newEmptyTMVarIO
	return $ Just $ Remote {
		uuid = u,
		cost = cst,
		name = Git.repoDescribe r,
		storeKey = store u hdl,
		retrieveKeyFile = retrieve u hdl,
		retrieveKeyFileCheap = \_ _ -> return False,
		removeKey = remove,
		hasKey = checkPresent u hdl,
		hasKeyCheap = False,
		whereisKey = Nothing,
		remoteFsck = Nothing,
		repairRepo = Nothing,
		config = c,
		repo = r,
		gitconfig = gc,
		localpath = Nothing,
		readonly = False,
		availability = GloballyAvailable,
		remotetype = remote
	}

tahoeSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
tahoeSetup mu _ c = do
	furl <- fromMaybe (fromMaybe missingfurl $ M.lookup furlk c)
		<$> liftIO (getEnv "TAHOE_FURL")
	u <- maybe (liftIO genUUID) return mu
	configdir <- liftIO $ defaultTahoeConfigDir u
	scs <- liftIO $ tahoeConfigure configdir furl (M.lookup scsk c)
	let c' = if M.lookup "embedcreds" c == Just "yes"
		then flip M.union c $ M.fromList
			[ (furlk, furl)
			, (scsk, scs)
			]
		else c
	gitConfigSpecialRemote u c' "tahoe" configdir
	return (c', u)
  where
	scsk = "shared-convergence-secret"
	furlk = "introducer-furl"
	missingfurl = error "Set TAHOE_FURL to the introducer furl to use."

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 -> 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 $ 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 -> TahoeHandle -> Key -> Annex (Either String Bool)
checkPresent u hdl k = go =<< getCapability u k
  where
	go Nothing = return (Right False)
	go (Just cap) = liftIO $ parseCheck <$> readTahoe hdl "check"
		[ Param "--raw"
		, Param cap
		]

defaultTahoeConfigDir :: UUID -> IO TahoeConfigDir
defaultTahoeConfigDir u = do
	h <- myHomeDir 
	return $ h </> ".tahoe" </> "git-annex" </> fromUUID u

tahoeConfigure :: TahoeConfigDir -> IntroducerFurl -> Maybe SharedConvergenceSecret -> IO SharedConvergenceSecret
tahoeConfigure configdir furl mscs = do
	unlessM (createClient configdir furl) $
		error "tahoe create-client failed"
	maybe noop (writeSharedConvergenceSecret configdir) mscs
	startTahoeDaemon configdir
	getSharedConvergenceSecret configdir

createClient :: TahoeConfigDir -> IntroducerFurl -> IO Bool
createClient configdir furl = do
	createDirectoryIfMissing True (parentDir configdir)
	boolTahoe configdir "create-client"
		[ Param "--nickname", Param "git-annex"
		, Param "--introducer", Param furl
		]

writeSharedConvergenceSecret :: TahoeConfigDir -> SharedConvergenceSecret -> IO ()
writeSharedConvergenceSecret configdir scs = 
	writeFile (convergenceFile configdir) (unlines [scs])

{- The tahoe daemon writes the convergenceFile shortly after it starts
 - (it does not need to connect to the network). So, try repeatedly to read
 - the file, for up to 1 minute. To avoid reading a partially written
 - file, look for the newline after the value. -}
getSharedConvergenceSecret :: TahoeConfigDir -> IO SharedConvergenceSecret
getSharedConvergenceSecret configdir = go (60 :: Int)
  where
  	f = convergenceFile configdir
	go n
		| n == 0 = error $ "tahoe did not write " ++ f ++ " after 1 minute. Perhaps the daemon failed to start?"
		| otherwise = do
			v <- catchMaybeIO (readFile f)
			case v of
				Just s | "\n" `isSuffixOf` s || "\r" `isSuffixOf` s ->
					return $ takeWhile (`notElem` "\n\r") s
				_ -> do
					threadDelaySeconds (Seconds 1)
					go (n - 1)

convergenceFile :: TahoeConfigDir -> FilePath
convergenceFile configdir = configdir </> "private" </> "convergence"

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

{- 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 = 
	Param command : Param "-d" : File configdir : params

storeCapability :: UUID -> Key -> Capability -> Annex ()
storeCapability u k cap = setRemoteState u k cap

getCapability :: UUID -> Key -> Annex (Maybe Capability)
getCapability u k = getRemoteState u k

{- tahoe put outputs a single line, containing the capability. -}
parsePut :: String -> Maybe Capability
parsePut s = case lines s of
	[cap] | "URI" `isPrefixOf` cap -> Just cap
	_ -> Nothing

{- tahoe check --raw outputs a json document.
 - Its contents will vary (for LIT capabilities, it lacks most info),
 - but should always contain a results object with a healthy value
 - that's true or false.
 -}
parseCheck :: String -> Either String Bool
parseCheck s = maybe parseerror (Right . healthy . results) (decode $ fromString s)
  where
	parseerror
		| null s = Left "tahoe check failed to run"
		| otherwise = Left "unable to parse tahoe check output"

data CheckRet = CheckRet { results :: Results }
data Results = Results { healthy :: Bool }

instance FromJSON CheckRet where
	parseJSON (Object v) = CheckRet
		<$> v .: "results"
	parseJSON _ = mzero

instance FromJSON Results where
	parseJSON (Object v) = Results
		<$> v .: "healthy"
	parseJSON _ = mzero