![Joey Hess](/assets/img/avatar_default.png)
This will allow special remotes to eg, open a http connection and reuse it, while checking if chunks are present, or removing chunks. S3 and WebDAV both need this to support chunks with reasonable speed. Note that a special remote might want to cache a http connection across multiple requests. A simple case of this is that CheckPresent is typically called before Store or Remove. A remote using this interface can certianly use a Preparer that eg, uses a MVar to cache a http connection. However, it's up to the remote to then deal with things like stale or stalled http connections when eg, doing a series of downloads from a remote and other places. There could be long delays between calls to a remote, which could lead to eg, http connection stalls; the machine might even move to a new network, etc. It might be nice to improve this interface later to allow the simple case without needing to handle the full complex case. One way to do it would be to have a `Transaction SpecialRemote cache`, where SpecialRemote contains methods for Storer, Retriever, Remover, and CheckPresent, that all expect to be passed a `cache`.
196 lines
5.9 KiB
Haskell
196 lines
5.9 KiB
Haskell
{- 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.Map as M
|
|
import qualified Data.ByteString.Lazy as L
|
|
import System.IO.Error
|
|
|
|
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 Annex.Ssh
|
|
import Annex.UUID
|
|
|
|
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
|
|
return $ Just $ specialRemote' specialcfg c
|
|
(simplyPrepare $ store ddarrepo)
|
|
(simplyPrepare $ retrieve ddarrepo)
|
|
(simplyPrepare $ remove ddarrepo)
|
|
(simplyPrepare $ checkKey ddarrepo)
|
|
(this cst)
|
|
where
|
|
this cst = Remote
|
|
{ uuid = u
|
|
, cost = cst
|
|
, name = Git.repoDescribe r
|
|
, storeKey = storeKeyDummy
|
|
, retrieveKeyFile = retreiveKeyFileDummy
|
|
, retrieveKeyFileCheap = retrieveCheap
|
|
, removeKey = removeKeyDummy
|
|
, checkPresent = checkPresentDummy
|
|
, checkPresentCheap = 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
|
|
}
|
|
ddarrepo = fromMaybe (error "missing ddarrepo") $ remoteAnnexDdarRepo gc
|
|
specialcfg = (specialRemoteCfg c)
|
|
-- chunking would not improve ddar
|
|
{ chunkConfig = NoChunks
|
|
}
|
|
|
|
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)
|
|
|
|
store :: DdarRepo -> Storer
|
|
store ddarrepo = fileStorer $ \k src _p -> do
|
|
let params =
|
|
[ Param "c"
|
|
, Param "-N"
|
|
, Param $ key2file k
|
|
, Param ddarrepo
|
|
, File src
|
|
]
|
|
liftIO $ boolSystem "ddar" params
|
|
|
|
{- 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 -> Retriever
|
|
retrieve ddarrepo = byteRetriever $ \k sink -> do
|
|
(cmd, params) <- ddarExtractRemoteCall ddarrepo k
|
|
let p = (proc cmd $ toCommand params) { std_out = CreatePipe }
|
|
(_, Just h, _, pid) <- liftIO $ createProcess p
|
|
liftIO (hClose h >> forceSuccessProcess p pid)
|
|
`after` (sink =<< liftIO (L.hGetContents h))
|
|
|
|
retrieveCheap :: Key -> FilePath -> Annex Bool
|
|
retrieveCheap _ _ = return False
|
|
|
|
remove :: DdarRepo -> Remover
|
|
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
|
|
|
|
checkKey :: DdarRepo -> CheckPresent
|
|
checkKey ddarrepo key = do
|
|
directoryExists <- ddarDirectoryExists ddarrepo
|
|
case directoryExists of
|
|
Left e -> error e
|
|
Right True -> either error return
|
|
=<< inDdarManifest ddarrepo key
|
|
Right False -> return False
|
|
|
|
ddarLocal :: DdarRepo -> Bool
|
|
ddarLocal = notElem ':'
|