2011-03-30 18:56:31 +00:00
|
|
|
{- A "remote" that is just a filesystem directory.
|
2011-03-30 17:18:46 +00:00
|
|
|
-
|
2015-01-21 16:50:09 +00:00
|
|
|
- Copyright 2011-2014 Joey Hess <id@joeyh.name>
|
2011-03-30 17:18:46 +00:00
|
|
|
-
|
|
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
|
|
-}
|
|
|
|
|
2013-05-11 20:03:00 +00:00
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
|
2014-08-04 13:35:57 +00:00
|
|
|
module Remote.Directory (
|
|
|
|
remote,
|
|
|
|
finalizeStoreGeneric,
|
|
|
|
removeDirGeneric,
|
|
|
|
) where
|
2011-03-30 17:18:46 +00:00
|
|
|
|
2012-06-20 17:13:40 +00:00
|
|
|
import qualified Data.ByteString.Lazy as L
|
2011-03-30 17:18:46 +00:00
|
|
|
import qualified Data.Map as M
|
2015-01-28 19:55:17 +00:00
|
|
|
import Data.Default
|
2011-03-30 17:18:46 +00:00
|
|
|
|
2016-01-20 20:36:33 +00:00
|
|
|
import Annex.Common
|
2011-06-02 01:56:04 +00:00
|
|
|
import Types.Remote
|
2014-02-11 18:06:50 +00:00
|
|
|
import Types.Creds
|
2011-06-30 17:16:57 +00:00
|
|
|
import qualified Git
|
2013-03-13 20:16:01 +00:00
|
|
|
import Config.Cost
|
2011-03-30 18:32:08 +00:00
|
|
|
import Config
|
2011-09-23 22:13:24 +00:00
|
|
|
import Utility.FileMode
|
2011-08-17 00:49:54 +00:00
|
|
|
import Remote.Helper.Special
|
2014-07-27 00:19:24 +00:00
|
|
|
import qualified Remote.Directory.LegacyChunked as Legacy
|
2012-04-20 20:24:44 +00:00
|
|
|
import Annex.Content
|
2013-09-07 22:38:00 +00:00
|
|
|
import Annex.UUID
|
2013-03-28 21:03:04 +00:00
|
|
|
import Utility.Metered
|
2011-03-30 17:18:46 +00:00
|
|
|
|
2011-12-31 08:11:39 +00:00
|
|
|
remote :: RemoteType
|
2011-03-30 17:18:46 +00:00
|
|
|
remote = RemoteType {
|
|
|
|
typename = "directory",
|
2015-08-05 17:49:54 +00:00
|
|
|
enumerate = const (findSpecialRemotes "directory"),
|
2011-03-30 17:18:46 +00:00
|
|
|
generate = gen,
|
2011-03-30 18:00:54 +00:00
|
|
|
setup = directorySetup
|
2011-03-30 17:18:46 +00:00
|
|
|
}
|
|
|
|
|
2013-09-12 19:54:35 +00:00
|
|
|
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
|
2013-01-01 17:52:47 +00:00
|
|
|
gen r u c gc = do
|
|
|
|
cst <- remoteCost gc cheapRemoteCost
|
2014-08-03 19:35:23 +00:00
|
|
|
let chunkconfig = getChunkConfig c
|
|
|
|
return $ Just $ specialRemote c
|
2014-07-27 00:19:24 +00:00
|
|
|
(prepareStore dir chunkconfig)
|
|
|
|
(retrieve dir chunkconfig)
|
run Preparer to get Remover and CheckPresent actions
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`.
2014-08-06 18:28:36 +00:00
|
|
|
(simplyPrepare $ remove dir)
|
|
|
|
(simplyPrepare $ checkKey dir chunkconfig)
|
2014-12-16 19:26:13 +00:00
|
|
|
Remote
|
|
|
|
{ uuid = u
|
|
|
|
, cost = cst
|
|
|
|
, name = Git.repoDescribe r
|
|
|
|
, storeKey = storeKeyDummy
|
|
|
|
, retrieveKeyFile = retreiveKeyFileDummy
|
|
|
|
, retrieveKeyFileCheap = retrieveCheap dir chunkconfig
|
|
|
|
, removeKey = removeKeyDummy
|
2015-10-08 19:01:38 +00:00
|
|
|
, lockContent = Nothing
|
2014-12-16 19:26:13 +00:00
|
|
|
, checkPresent = checkPresentDummy
|
|
|
|
, checkPresentCheap = True
|
|
|
|
, whereisKey = Nothing
|
|
|
|
, remoteFsck = Nothing
|
|
|
|
, repairRepo = Nothing
|
|
|
|
, config = c
|
|
|
|
, repo = r
|
|
|
|
, gitconfig = gc
|
|
|
|
, localpath = Just dir
|
|
|
|
, readonly = False
|
|
|
|
, availability = LocallyAvailable
|
|
|
|
, remotetype = remote
|
|
|
|
, mkUnavailable = gen r u c $
|
|
|
|
gc { remoteAnnexDirectory = Just "/dev/null" }
|
|
|
|
, getInfo = return [("directory", dir)]
|
|
|
|
, claimUrl = Nothing
|
|
|
|
, checkUrl = Nothing
|
|
|
|
}
|
2013-01-01 17:52:47 +00:00
|
|
|
where
|
2016-11-16 01:29:54 +00:00
|
|
|
dir = fromMaybe (giveup "missing directory") $ remoteAnnexDirectory gc
|
2012-03-03 22:05:55 +00:00
|
|
|
|
2016-05-23 21:03:20 +00:00
|
|
|
directorySetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
2016-05-23 21:27:15 +00:00
|
|
|
directorySetup mu _ c gc = do
|
2013-09-07 22:38:00 +00:00
|
|
|
u <- maybe (liftIO genUUID) return mu
|
2011-03-30 17:18:46 +00:00
|
|
|
-- verify configuration is sane
|
2016-11-16 01:29:54 +00:00
|
|
|
let dir = fromMaybe (giveup "Specify directory=") $
|
2011-05-15 06:49:43 +00:00
|
|
|
M.lookup "directory" c
|
2013-05-06 21:15:36 +00:00
|
|
|
absdir <- liftIO $ absPath dir
|
|
|
|
liftIO $ unlessM (doesDirectoryExist absdir) $
|
2016-11-16 01:29:54 +00:00
|
|
|
giveup $ "Directory does not exist: " ++ absdir
|
2016-05-23 21:27:15 +00:00
|
|
|
(c', _encsetup) <- encryptionSetup c gc
|
2011-03-30 17:18:46 +00:00
|
|
|
|
2011-03-30 18:32:08 +00:00
|
|
|
-- The directory is stored in git config, not in this remote's
|
|
|
|
-- persistant state, so it can vary between hosts.
|
2013-05-06 21:15:36 +00:00
|
|
|
gitConfigSpecialRemote u c' "directory" absdir
|
2013-09-07 22:38:00 +00:00
|
|
|
return (M.delete "directory" c', u)
|
2011-03-30 17:18:46 +00:00
|
|
|
|
2014-07-27 00:19:24 +00:00
|
|
|
{- Locations to try to access a given Key in the directory.
|
|
|
|
- We try more than one since we used to write to different hash
|
|
|
|
- directories. -}
|
2011-11-22 22:20:55 +00:00
|
|
|
locations :: FilePath -> Key -> [FilePath]
|
2011-12-02 18:56:48 +00:00
|
|
|
locations d k = map (d </>) (keyPaths k)
|
2011-03-30 17:18:46 +00:00
|
|
|
|
2014-07-27 00:19:24 +00:00
|
|
|
{- Returns the location off a Key in the directory. If the key is
|
|
|
|
- present, returns the location that is actually used, otherwise
|
|
|
|
- returns the first, default location. -}
|
|
|
|
getLocation :: FilePath -> Key -> IO FilePath
|
|
|
|
getLocation d k = do
|
|
|
|
let locs = locations d k
|
|
|
|
fromMaybe (Prelude.head locs) <$> firstM doesFileExist locs
|
|
|
|
|
2012-11-19 17:18:23 +00:00
|
|
|
{- Directory where the file(s) for a key are stored. -}
|
|
|
|
storeDir :: FilePath -> Key -> FilePath
|
2015-01-28 19:55:17 +00:00
|
|
|
storeDir d k = addTrailingPathSeparator $ d </> hashDirLower def k </> keyFile k
|
2012-11-19 17:18:23 +00:00
|
|
|
|
2014-07-27 00:19:24 +00:00
|
|
|
{- Where we store temporary data for a key, in the directory, as it's being
|
|
|
|
- written. -}
|
2012-11-19 17:18:23 +00:00
|
|
|
tmpDir :: FilePath -> Key -> FilePath
|
|
|
|
tmpDir d k = addTrailingPathSeparator $ d </> "tmp" </> keyFile k
|
|
|
|
|
2014-07-27 00:19:24 +00:00
|
|
|
{- Check if there is enough free disk space in the remote's directory to
|
|
|
|
- store the key. Note that the unencrypted key size is checked. -}
|
2014-07-27 04:30:04 +00:00
|
|
|
prepareStore :: FilePath -> ChunkConfig -> Preparer Storer
|
2015-05-12 19:19:08 +00:00
|
|
|
prepareStore d chunkconfig = checkPrepare checker
|
2014-07-29 18:53:17 +00:00
|
|
|
(byteStorer $ store d chunkconfig)
|
2015-05-12 19:19:08 +00:00
|
|
|
where
|
|
|
|
checker k = do
|
|
|
|
annexdir <- fromRepo gitAnnexObjectDir
|
|
|
|
samefilesystem <- liftIO $ catchDefaultIO False $
|
|
|
|
(\a b -> deviceID a == deviceID b)
|
|
|
|
<$> getFileStatus d
|
|
|
|
<*> getFileStatus annexdir
|
|
|
|
checkDiskSpace (Just d) k 0 samefilesystem
|
2014-07-24 18:49:22 +00:00
|
|
|
|
2014-07-29 20:22:19 +00:00
|
|
|
store :: FilePath -> ChunkConfig -> Key -> L.ByteString -> MeterUpdate -> Annex Bool
|
|
|
|
store d chunkconfig k b p = liftIO $ do
|
2014-07-27 03:01:44 +00:00
|
|
|
void $ tryIO $ createDirectoryIfMissing True tmpdir
|
2014-07-25 20:21:01 +00:00
|
|
|
case chunkconfig of
|
2014-08-04 13:35:57 +00:00
|
|
|
LegacyChunks chunksize -> Legacy.store chunksize finalizeStoreGeneric k b p tmpdir destdir
|
2014-07-27 03:26:10 +00:00
|
|
|
_ -> do
|
2014-07-27 00:19:24 +00:00
|
|
|
let tmpf = tmpdir </> keyFile k
|
|
|
|
meteredWriteFile p tmpf b
|
2014-08-04 13:35:57 +00:00
|
|
|
finalizeStoreGeneric tmpdir destdir
|
2014-07-24 18:49:22 +00:00
|
|
|
return True
|
2014-07-25 20:21:01 +00:00
|
|
|
where
|
2014-07-27 00:19:24 +00:00
|
|
|
tmpdir = tmpDir d k
|
|
|
|
destdir = storeDir d k
|
2014-08-04 13:35:57 +00:00
|
|
|
|
|
|
|
{- Passed a temp directory that contains the files that should be placed
|
|
|
|
- in the dest directory, moves it into place. Anything already existing
|
|
|
|
- in the dest directory will be deleted. File permissions will be locked
|
|
|
|
- down. -}
|
|
|
|
finalizeStoreGeneric :: FilePath -> FilePath -> IO ()
|
|
|
|
finalizeStoreGeneric tmp dest = do
|
|
|
|
void $ tryIO $ allowWrite dest -- may already exist
|
|
|
|
void $ tryIO $ removeDirectoryRecursive dest -- or not exist
|
2015-01-09 17:11:56 +00:00
|
|
|
createDirectoryIfMissing True (parentDir dest)
|
2014-08-04 13:35:57 +00:00
|
|
|
renameDirectory tmp dest
|
|
|
|
-- may fail on some filesystems
|
|
|
|
void $ tryIO $ do
|
|
|
|
mapM_ preventWrite =<< dirContents dest
|
|
|
|
preventWrite dest
|
2012-03-03 22:05:55 +00:00
|
|
|
|
2014-07-27 04:30:04 +00:00
|
|
|
retrieve :: FilePath -> ChunkConfig -> Preparer Retriever
|
|
|
|
retrieve d (LegacyChunks _) = Legacy.retrieve locations d
|
2014-08-03 05:12:24 +00:00
|
|
|
retrieve d _ = simplyPrepare $ byteRetriever $ \k sink ->
|
|
|
|
sink =<< liftIO (L.readFile =<< getLocation d k)
|
2011-04-17 01:41:14 +00:00
|
|
|
|
2015-04-14 20:35:10 +00:00
|
|
|
retrieveCheap :: FilePath -> ChunkConfig -> Key -> AssociatedFile -> FilePath -> Annex Bool
|
2014-07-27 00:19:24 +00:00
|
|
|
-- no cheap retrieval possible for chunks
|
2015-04-14 20:35:10 +00:00
|
|
|
retrieveCheap _ (UnpaddedChunks _) _ _ _ = return False
|
|
|
|
retrieveCheap _ (LegacyChunks _) _ _ _ = return False
|
2013-08-02 16:27:32 +00:00
|
|
|
#ifndef mingw32_HOST_OS
|
2015-04-14 20:35:10 +00:00
|
|
|
retrieveCheap d NoChunks k _af f = liftIO $ catchBoolIO $ do
|
2015-04-18 17:36:12 +00:00
|
|
|
file <- absPath =<< getLocation d k
|
|
|
|
ifM (doesFileExist file)
|
|
|
|
( do
|
|
|
|
createSymbolicLink file f
|
|
|
|
return True
|
|
|
|
, return False
|
|
|
|
)
|
2013-05-11 20:03:00 +00:00
|
|
|
#else
|
2015-04-14 20:35:10 +00:00
|
|
|
retrieveCheap _ _ _ _ _ = return False
|
2013-05-11 20:03:00 +00:00
|
|
|
#endif
|
2012-03-03 22:05:55 +00:00
|
|
|
|
run Preparer to get Remover and CheckPresent actions
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`.
2014-08-06 18:28:36 +00:00
|
|
|
remove :: FilePath -> Remover
|
2014-08-04 13:00:57 +00:00
|
|
|
remove d k = liftIO $ removeDirGeneric d (storeDir d k)
|
|
|
|
|
|
|
|
{- Removes the directory, which must be located under the topdir.
|
|
|
|
-
|
|
|
|
- Succeeds even on directories and contents that do not have write
|
|
|
|
- permission.
|
|
|
|
-
|
|
|
|
- If the directory does not exist, succeeds as long as the topdir does
|
|
|
|
- exist. If the topdir does not exist, fails, because in this case the
|
|
|
|
- remote is not currently accessible and probably still has the content
|
|
|
|
- we were supposed to remove from it.
|
|
|
|
-}
|
|
|
|
removeDirGeneric :: FilePath -> FilePath -> IO Bool
|
|
|
|
removeDirGeneric topdir dir = do
|
2013-02-14 18:10:36 +00:00
|
|
|
void $ tryIO $ allowWrite dir
|
2013-08-04 17:39:31 +00:00
|
|
|
#ifdef mingw32_HOST_OS
|
|
|
|
{- Windows needs the files inside the directory to be writable
|
|
|
|
- before it can delete them. -}
|
|
|
|
void $ tryIO $ mapM_ allowWrite =<< dirContents dir
|
|
|
|
#endif
|
2014-07-28 18:14:01 +00:00
|
|
|
ok <- catchBoolIO $ do
|
2013-02-14 18:10:36 +00:00
|
|
|
removeDirectoryRecursive dir
|
|
|
|
return True
|
2014-07-28 18:14:01 +00:00
|
|
|
if ok
|
|
|
|
then return ok
|
2014-08-04 13:00:57 +00:00
|
|
|
else doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)
|
2011-03-30 17:18:46 +00:00
|
|
|
|
run Preparer to get Remover and CheckPresent actions
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`.
2014-08-06 18:28:36 +00:00
|
|
|
checkKey :: FilePath -> ChunkConfig -> CheckPresent
|
2014-08-06 17:45:19 +00:00
|
|
|
checkKey d (LegacyChunks _) k = Legacy.checkKey d locations k
|
|
|
|
checkKey d _ k = liftIO $
|
|
|
|
ifM (anyM doesFileExist (locations d k))
|
|
|
|
( return True
|
2014-08-10 18:52:58 +00:00
|
|
|
, ifM (doesDirectoryExist d)
|
|
|
|
( return False
|
2016-11-16 01:29:54 +00:00
|
|
|
, giveup $ "directory " ++ d ++ " is not accessible"
|
2014-08-10 18:52:58 +00:00
|
|
|
)
|
2014-08-06 17:45:19 +00:00
|
|
|
)
|