git-annex-5.20140517: Remote/Ddar.hs

{- Using ddar as a remote. Based on bup and rsync remotes.
 -
 - Copyright 2011 Joey Hess <joey@kitenet.net>
 - Copyright 2014 Robie Basak <robie@justgohome.co.uk>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Remote.Ddar (remote) where

import Control.Exception
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as M
import System.IO.Error
import System.Process

import Data.String.Utils
import Common.Annex
import Types.Remote
import Types.Key
import Types.Creds
import qualified Git
import Config
import Config.Cost
import Remote.Helper.Special
import Remote.Helper.Encryptable
import Crypto
import Annex.Content
import Annex.Ssh
import Annex.UUID
import Utility.Metered

type DdarRepo = String

remote :: RemoteType
remote = RemoteType {
	typename = "ddar",
	enumerate = findSpecialRemotes "ddarrepo",
	generate = gen,
	setup = ddarSetup
}

gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
gen r u c gc = do
	cst <- remoteCost gc $
		if ddarLocal ddarrepo
			then nearlyCheapRemoteCost
			else expensiveRemoteCost

	let new = Remote
		{ uuid = u
		, cost = cst
		, name = Git.repoDescribe r
		, storeKey = store ddarrepo
		, retrieveKeyFile = retrieve ddarrepo
		, retrieveKeyFileCheap = retrieveCheap
		, removeKey = remove ddarrepo
		, hasKey = checkPresent ddarrepo
		, hasKeyCheap = ddarLocal ddarrepo
		, whereisKey = Nothing
		, remoteFsck = Nothing
		, repairRepo = Nothing
		, config = c
		, repo = r
		, gitconfig = gc
		, localpath = if ddarLocal ddarrepo && not (null ddarrepo)
			then Just ddarrepo
			else Nothing
		, remotetype = remote
		, availability = if ddarLocal ddarrepo then LocallyAvailable else GloballyAvailable
		, readonly = False
		}
	return $ Just $ encryptableRemote c
		(storeEncrypted new ddarrepo)
		(retrieveEncrypted ddarrepo)
		new
  where
	ddarrepo = fromMaybe (error "missing ddarrepo") $ remoteAnnexDdarRepo gc

ddarSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID)
ddarSetup mu _ c = do
	u <- maybe (liftIO genUUID) return mu

	-- verify configuration is sane
	let ddarrepo = fromMaybe (error "Specify ddarrepo=") $
		M.lookup "ddarrepo" c
	c' <- encryptionSetup c

	-- The ddarrepo is stored in git config, as well as this repo's
	-- persistant state, so it can vary between hosts.
	gitConfigSpecialRemote u c' "ddarrepo" ddarrepo

	return (c', u)

pipeDdar :: [CommandParam] -> Maybe Handle -> Maybe Handle -> IO Bool
pipeDdar params inh outh = do
	p <- runProcess "ddar" (toCommand params)
		Nothing Nothing inh outh Nothing
	ok <- waitForProcess p
	case ok of
		ExitSuccess -> return True
		_ -> return False

store :: DdarRepo -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store ddarrepo k _f _p = sendAnnex k (void $ remove ddarrepo k) $ \src -> do
	let params =
		[ Param "c"
		, Param "-N"
		, Param $ key2file k
		, Param ddarrepo
		, File src
		]
	liftIO $ boolSystem "ddar" params

storeEncrypted :: Remote -> DdarRepo -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
storeEncrypted r ddarrepo (cipher, enck) k _p =
	sendAnnex k (void $ remove ddarrepo k) $ \src ->
		liftIO $ catchBoolIO $
			encrypt (getGpgEncParams r) cipher (feedFile src) $ \h ->
				pipeDdar params (Just h) Nothing
  where
	params =
		[ Param "c"
		, Param "-N"
		, Param $ key2file enck
		, Param ddarrepo
		, Param "-"
		]

{- Convert remote DdarRepo to host and path on remote end -}
splitRemoteDdarRepo :: DdarRepo -> (String, String)
splitRemoteDdarRepo ddarrepo =
	(host, ddarrepo')
  where
	(host, remainder) = span (/= ':') ddarrepo
	ddarrepo' = drop 1 remainder

{- Return the command and parameters to use for a ddar call that may need to be
 - made on a remote repository. This will call ssh if needed. -}

ddarRemoteCall :: DdarRepo -> Char -> [CommandParam] -> Annex (String, [CommandParam])
ddarRemoteCall ddarrepo cmd params
	| ddarLocal ddarrepo = return ("ddar", localParams)
	| otherwise = do
		remoteCachingParams <- sshCachingOptions (host, Nothing) []
		return ("ssh", remoteCachingParams ++ remoteParams)
  where
	(host, ddarrepo') = splitRemoteDdarRepo ddarrepo
	localParams = Param [cmd] : Param ddarrepo : params
	remoteParams = Param host : Param "ddar" : Param [cmd] : Param ddarrepo' : params

{- Specialized ddarRemoteCall that includes extraction command and flags -}

ddarExtractRemoteCall :: DdarRepo -> Key -> Annex (String, [CommandParam])
ddarExtractRemoteCall ddarrepo k =
	ddarRemoteCall ddarrepo 'x' [Param "--force-stdout", Param $ key2file k]

retrieve :: DdarRepo -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
retrieve ddarrepo k _f d _p = do
	(cmd, params) <- ddarExtractRemoteCall ddarrepo k
	liftIO $ catchBoolIO $ withFile d WriteMode $ \h -> do
		let p = (proc cmd $ toCommand params){ std_out = UseHandle h }
		(_, _, _, pid) <- Common.Annex.createProcess p
		forceSuccessProcess p pid
		return True

retrieveCheap :: Key -> FilePath -> Annex Bool
retrieveCheap _ _ = return False

retrieveEncrypted :: DdarRepo -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool
retrieveEncrypted ddarrepo (cipher, enck) _ f _p = do
	(cmd, params) <- ddarExtractRemoteCall ddarrepo enck
	let p = proc cmd $ toCommand params
	liftIO $ catchBoolIO $ withHandle StdoutHandle createProcessSuccess p $ \h -> do
		decrypt cipher (\toh -> L.hPut toh =<< L.hGetContents h) $
			readBytes $ L.writeFile f
		return True

remove :: DdarRepo -> Key -> Annex Bool
remove ddarrepo key = do
	(cmd, params) <- ddarRemoteCall ddarrepo 'd' [Param $ key2file key]
	liftIO $ boolSystem cmd params

ddarDirectoryExists :: DdarRepo -> Annex (Either String Bool)
ddarDirectoryExists ddarrepo
	| ddarLocal ddarrepo = do
		maybeStatus <- liftIO $ tryJust (guard . isDoesNotExistError) $ getFileStatus ddarrepo
		return $ case maybeStatus of
			Left _ -> Right False
			Right status -> Right $ isDirectory status
	| otherwise = do
		sshCachingParams <- sshCachingOptions (host, Nothing) []
		exitCode <- liftIO $ safeSystem "ssh" $ sshCachingParams ++ params
		case exitCode of
			ExitSuccess -> return $ Right True
			ExitFailure 1 -> return $ Right False
			ExitFailure code -> return $ Left $ "ssh call " ++
				show (Data.String.Utils.join " " $ toCommand params) ++
				" failed with status " ++ show code
  where
	(host, ddarrepo') = splitRemoteDdarRepo ddarrepo
	params =
		[ Param host
		, Param "test"
		, Param "-d"
		, Param ddarrepo'
		]

{- Use "ddar t" to determine if a given key is present in a ddar archive -}
inDdarManifest :: DdarRepo -> Key -> Annex (Either String Bool)
inDdarManifest ddarrepo k = do
	(cmd, params) <- ddarRemoteCall ddarrepo 't' []
	let p = proc cmd $ toCommand params
	liftIO $ catchMsgIO $ withHandle StdoutHandle createProcessSuccess p $ \h -> do
		contents <- hGetContents h
		return $ elem k' $ lines contents
  where
	k' = key2file k

checkPresent :: DdarRepo -> Key -> Annex (Either String Bool)
checkPresent ddarrepo key = do
	directoryExists <- ddarDirectoryExists ddarrepo
	case directoryExists of
		Left e -> return $ Left e
		Right True -> inDdarManifest ddarrepo key
		Right False -> return $ Right False

ddarLocal :: DdarRepo -> Bool
ddarLocal = notElem ':'