2011-03-30 18:56:31 +00:00
|
|
|
|
{- A "remote" that is just a filesystem directory.
|
2011-03-30 17:18:46 +00:00
|
|
|
|
-
|
2012-03-03 22:05:55 +00:00
|
|
|
|
- Copyright 2011-2012 Joey Hess <joey@kitenet.net>
|
2011-03-30 17:18:46 +00:00
|
|
|
|
-
|
|
|
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
|
|
|
-}
|
|
|
|
|
|
|
|
|
|
module Remote.Directory (remote) where
|
|
|
|
|
|
2012-06-20 17:13:40 +00:00
|
|
|
|
import qualified Data.ByteString.Lazy as L
|
|
|
|
|
import qualified Data.ByteString as S
|
2011-03-30 17:18:46 +00:00
|
|
|
|
import qualified Data.Map as M
|
2012-04-20 20:24:44 +00:00
|
|
|
|
import qualified Control.Exception as E
|
2012-11-19 02:49:07 +00:00
|
|
|
|
import Data.Int
|
2011-03-30 17:18:46 +00:00
|
|
|
|
|
2011-10-05 20:02:51 +00:00
|
|
|
|
import Common.Annex
|
2011-06-02 01:56:04 +00:00
|
|
|
|
import Types.Remote
|
2011-06-30 17:16:57 +00:00
|
|
|
|
import qualified Git
|
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
|
|
|
|
|
import Remote.Helper.Encryptable
|
2012-11-16 21:58:08 +00:00
|
|
|
|
import Remote.Helper.Chunked
|
2011-04-16 22:22:52 +00:00
|
|
|
|
import Crypto
|
2012-04-20 20:24:44 +00:00
|
|
|
|
import Annex.Content
|
2012-11-19 02:49:07 +00:00
|
|
|
|
import Meters
|
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",
|
2011-03-30 18:00:54 +00:00
|
|
|
|
enumerate = 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-01-01 17:52:47 +00:00
|
|
|
|
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
|
|
|
|
|
gen r u c gc = do
|
|
|
|
|
cst <- remoteCost gc cheapRemoteCost
|
2012-03-03 22:05:55 +00:00
|
|
|
|
let chunksize = chunkSize c
|
2011-04-17 04:40:23 +00:00
|
|
|
|
return $ encryptableRemote c
|
2012-03-03 22:05:55 +00:00
|
|
|
|
(storeEncrypted dir chunksize)
|
|
|
|
|
(retrieveEncrypted dir chunksize)
|
2011-04-17 01:41:14 +00:00
|
|
|
|
Remote {
|
|
|
|
|
uuid = u,
|
|
|
|
|
cost = cst,
|
|
|
|
|
name = Git.repoDescribe r,
|
2012-12-13 04:45:27 +00:00
|
|
|
|
storeKey = store dir chunksize,
|
2012-03-03 22:05:55 +00:00
|
|
|
|
retrieveKeyFile = retrieve dir chunksize,
|
|
|
|
|
retrieveKeyFileCheap = retrieveCheap dir chunksize,
|
2012-11-19 17:18:23 +00:00
|
|
|
|
removeKey = remove dir,
|
2012-03-03 22:05:55 +00:00
|
|
|
|
hasKey = checkPresent dir chunksize,
|
2011-04-17 01:41:14 +00:00
|
|
|
|
hasKeyCheap = True,
|
2012-02-14 07:49:48 +00:00
|
|
|
|
whereisKey = Nothing,
|
2012-11-30 04:55:59 +00:00
|
|
|
|
config = M.empty,
|
2011-12-31 07:27:37 +00:00
|
|
|
|
repo = r,
|
2013-01-01 17:52:47 +00:00
|
|
|
|
gitconfig = gc,
|
2012-08-26 18:26:43 +00:00
|
|
|
|
localpath = Just dir,
|
2012-08-26 19:39:02 +00:00
|
|
|
|
readonly = False,
|
2011-12-31 07:27:37 +00:00
|
|
|
|
remotetype = remote
|
2011-04-17 01:41:14 +00:00
|
|
|
|
}
|
2013-01-01 17:52:47 +00:00
|
|
|
|
where
|
|
|
|
|
dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc
|
2012-03-03 22:05:55 +00:00
|
|
|
|
|
2011-04-15 19:09:36 +00:00
|
|
|
|
directorySetup :: UUID -> RemoteConfig -> Annex RemoteConfig
|
2011-03-30 18:00:54 +00:00
|
|
|
|
directorySetup u c = do
|
2011-03-30 17:18:46 +00:00
|
|
|
|
-- verify configuration is sane
|
2011-07-15 16:47:14 +00:00
|
|
|
|
let dir = fromMaybe (error "Specify directory=") $
|
2011-05-15 06:49:43 +00:00
|
|
|
|
M.lookup "directory" c
|
2012-01-24 19:28:13 +00:00
|
|
|
|
liftIO $ unlessM (doesDirectoryExist dir) $
|
|
|
|
|
error $ "Directory does not exist: " ++ dir
|
2011-04-16 20:29:28 +00:00
|
|
|
|
c' <- encryptionSetup c
|
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.
|
2011-04-16 20:29:28 +00:00
|
|
|
|
gitConfigSpecialRemote u c' "directory" dir
|
|
|
|
|
return $ M.delete "directory" c'
|
2011-03-30 17:18:46 +00:00
|
|
|
|
|
2012-11-19 17:18:23 +00:00
|
|
|
|
{- Locations to try to access a given Key in the Directory.
|
|
|
|
|
- We try more than 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
|
|
|
|
|
2012-11-19 17:18:23 +00:00
|
|
|
|
{- Directory where the file(s) for a key are stored. -}
|
|
|
|
|
storeDir :: FilePath -> Key -> FilePath
|
|
|
|
|
storeDir d k = addTrailingPathSeparator $ d </> hashDirLower k </> keyFile k
|
|
|
|
|
|
|
|
|
|
{- Where we store temporary data for a key as it's being uploaded. -}
|
|
|
|
|
tmpDir :: FilePath -> Key -> FilePath
|
|
|
|
|
tmpDir d k = addTrailingPathSeparator $ d </> "tmp" </> keyFile k
|
|
|
|
|
|
2012-03-03 22:05:55 +00:00
|
|
|
|
withCheckedFiles :: (FilePath -> IO Bool) -> ChunkSize -> FilePath -> Key -> ([FilePath] -> IO Bool) -> IO Bool
|
|
|
|
|
withCheckedFiles _ _ [] _ _ = return False
|
|
|
|
|
withCheckedFiles check Nothing d k a = go $ locations d k
|
2012-11-11 04:51:07 +00:00
|
|
|
|
where
|
|
|
|
|
go [] = return False
|
|
|
|
|
go (f:fs) = ifM (check f) ( a [f] , go fs )
|
2012-03-03 22:05:55 +00:00
|
|
|
|
withCheckedFiles check (Just _) d k a = go $ locations d k
|
2012-11-11 04:51:07 +00:00
|
|
|
|
where
|
|
|
|
|
go [] = return False
|
|
|
|
|
go (f:fs) = do
|
2012-11-16 21:58:08 +00:00
|
|
|
|
let chunkcount = f ++ chunkCount
|
2012-11-11 04:51:07 +00:00
|
|
|
|
ifM (check chunkcount)
|
|
|
|
|
( do
|
2012-11-17 03:16:18 +00:00
|
|
|
|
chunks <- listChunks f <$> readFile chunkcount
|
2012-11-11 04:51:07 +00:00
|
|
|
|
ifM (all id <$> mapM check chunks)
|
|
|
|
|
( a chunks , return False )
|
|
|
|
|
, go fs
|
|
|
|
|
)
|
2011-11-22 22:20:55 +00:00
|
|
|
|
|
2012-03-03 22:05:55 +00:00
|
|
|
|
withStoredFiles :: ChunkSize -> FilePath -> Key -> ([FilePath] -> IO Bool) -> IO Bool
|
|
|
|
|
withStoredFiles = withCheckedFiles doesFileExist
|
2011-11-22 22:20:55 +00:00
|
|
|
|
|
2012-09-21 18:50:14 +00:00
|
|
|
|
store :: FilePath -> ChunkSize -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
|
2013-01-06 18:29:01 +00:00
|
|
|
|
store d chunksize k _f p = sendAnnex k $ \src ->
|
2012-09-21 18:54:24 +00:00
|
|
|
|
metered (Just p) k $ \meterupdate ->
|
2012-04-20 20:24:44 +00:00
|
|
|
|
storeHelper d chunksize k $ \dests ->
|
2012-03-03 22:05:55 +00:00
|
|
|
|
case chunksize of
|
|
|
|
|
Nothing -> do
|
|
|
|
|
let dest = Prelude.head dests
|
2012-03-04 07:17:03 +00:00
|
|
|
|
meteredWriteFile meterupdate dest
|
|
|
|
|
=<< L.readFile src
|
2012-03-03 22:05:55 +00:00
|
|
|
|
return [dest]
|
2012-03-04 07:17:03 +00:00
|
|
|
|
Just _ ->
|
|
|
|
|
storeSplit meterupdate chunksize dests
|
|
|
|
|
=<< L.readFile src
|
2012-03-03 22:05:55 +00:00
|
|
|
|
|
2012-09-21 18:50:14 +00:00
|
|
|
|
storeEncrypted :: FilePath -> ChunkSize -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
|
2013-01-06 18:29:01 +00:00
|
|
|
|
storeEncrypted d chunksize (cipher, enck) k p = sendAnnex k $ \src ->
|
2012-09-21 18:54:24 +00:00
|
|
|
|
metered (Just p) k $ \meterupdate ->
|
2012-04-20 20:24:44 +00:00
|
|
|
|
storeHelper d chunksize enck $ \dests ->
|
2012-11-18 19:27:44 +00:00
|
|
|
|
encrypt cipher (feedFile src) $ readBytes $ \b ->
|
2012-03-04 07:17:03 +00:00
|
|
|
|
case chunksize of
|
|
|
|
|
Nothing -> do
|
|
|
|
|
let dest = Prelude.head dests
|
2012-11-18 19:27:44 +00:00
|
|
|
|
meteredWriteFile meterupdate dest b
|
2012-03-04 07:17:03 +00:00
|
|
|
|
return [dest]
|
2012-11-18 19:27:44 +00:00
|
|
|
|
Just _ -> storeSplit meterupdate chunksize dests b
|
2012-03-04 07:17:03 +00:00
|
|
|
|
|
|
|
|
|
{- Splits a ByteString into chunks and writes to dests, obeying configured
|
|
|
|
|
- chunk size (not to be confused with the L.ByteString chunk size).
|
2012-03-03 22:05:55 +00:00
|
|
|
|
- Note: Must always write at least one file, even for empty ByteString. -}
|
2012-03-04 07:17:03 +00:00
|
|
|
|
storeSplit :: MeterUpdate -> ChunkSize -> [FilePath] -> L.ByteString -> IO [FilePath]
|
|
|
|
|
storeSplit _ Nothing _ _ = error "bad storeSplit call"
|
|
|
|
|
storeSplit _ _ [] _ = error "bad storeSplit call"
|
|
|
|
|
storeSplit meterupdate (Just chunksize) alldests@(firstdest:_) b
|
|
|
|
|
| L.null b = do
|
2012-03-03 22:05:55 +00:00
|
|
|
|
-- must always write at least one file, even for empty
|
2012-03-04 07:17:03 +00:00
|
|
|
|
L.writeFile firstdest b
|
2012-03-03 22:05:55 +00:00
|
|
|
|
return [firstdest]
|
2012-03-04 07:17:03 +00:00
|
|
|
|
| otherwise = storeSplit' meterupdate chunksize alldests (L.toChunks b) []
|
|
|
|
|
storeSplit' :: MeterUpdate -> Int64 -> [FilePath] -> [S.ByteString] -> [FilePath] -> IO [FilePath]
|
|
|
|
|
storeSplit' _ _ [] _ _ = error "ran out of dests"
|
|
|
|
|
storeSplit' _ _ _ [] c = return $ reverse c
|
|
|
|
|
storeSplit' meterupdate chunksize (d:dests) bs c = do
|
2012-04-20 20:24:44 +00:00
|
|
|
|
bs' <- E.bracket (openFile d WriteMode) hClose (feed chunksize bs)
|
2012-03-04 07:17:03 +00:00
|
|
|
|
storeSplit' meterupdate chunksize dests bs' (d:c)
|
2012-11-11 04:51:07 +00:00
|
|
|
|
where
|
|
|
|
|
feed _ [] _ = return []
|
|
|
|
|
feed sz (l:ls) h = do
|
|
|
|
|
let s = fromIntegral $ S.length l
|
2012-11-19 17:30:58 +00:00
|
|
|
|
if s <= sz || sz == chunksize
|
2012-11-11 04:51:07 +00:00
|
|
|
|
then do
|
|
|
|
|
S.hPut h l
|
|
|
|
|
meterupdate $ toInteger s
|
|
|
|
|
feed (sz - s) ls h
|
|
|
|
|
else return (l:ls)
|
2012-03-04 07:17:03 +00:00
|
|
|
|
|
2012-04-20 20:24:44 +00:00
|
|
|
|
storeHelper :: FilePath -> ChunkSize -> Key -> ([FilePath] -> IO [FilePath]) -> Annex Bool
|
2012-11-16 21:58:08 +00:00
|
|
|
|
storeHelper d chunksize key storer = check <&&> go
|
2012-11-11 04:51:07 +00:00
|
|
|
|
where
|
2012-11-19 17:18:23 +00:00
|
|
|
|
tmpdir = tmpDir d key
|
|
|
|
|
destdir = storeDir d key
|
2012-11-11 04:51:07 +00:00
|
|
|
|
{- The size is not exactly known when encrypting the key;
|
|
|
|
|
- this assumes that at least the size of the key is
|
|
|
|
|
- needed as free space. -}
|
2012-11-19 17:18:23 +00:00
|
|
|
|
check = do
|
|
|
|
|
liftIO $ createDirectoryIfMissing True tmpdir
|
|
|
|
|
checkDiskSpace (Just tmpdir) key 0
|
|
|
|
|
go = liftIO $ catchBoolIO $
|
|
|
|
|
storeChunks key tmpdir destdir chunksize storer recorder finalizer
|
|
|
|
|
finalizer tmp dest = do
|
|
|
|
|
void $ tryIO $ allowWrite dest -- may already exist
|
|
|
|
|
void $ tryIO $ removeDirectoryRecursive dest -- or not exist
|
|
|
|
|
createDirectoryIfMissing True (parentDir dest)
|
|
|
|
|
renameDirectory tmp dest
|
|
|
|
|
mapM_ preventWrite =<< dirContents dest
|
2012-11-16 21:58:08 +00:00
|
|
|
|
preventWrite dest
|
|
|
|
|
recorder f s = do
|
|
|
|
|
void $ tryIO $ allowWrite f
|
|
|
|
|
writeFile f s
|
|
|
|
|
preventWrite f
|
2012-03-03 22:05:55 +00:00
|
|
|
|
|
2012-07-01 20:59:54 +00:00
|
|
|
|
retrieve :: FilePath -> ChunkSize -> Key -> AssociatedFile -> FilePath -> Annex Bool
|
2012-09-21 18:54:24 +00:00
|
|
|
|
retrieve d chunksize k _ f = metered Nothing k $ \meterupdate ->
|
2012-03-04 07:25:41 +00:00
|
|
|
|
liftIO $ withStoredFiles chunksize d k $ \files ->
|
|
|
|
|
catchBoolIO $ do
|
2012-11-18 22:27:53 +00:00
|
|
|
|
meteredWriteFileChunks meterupdate f files $ L.readFile
|
2012-03-03 22:05:55 +00:00
|
|
|
|
return True
|
2011-04-17 01:41:14 +00:00
|
|
|
|
|
2012-03-04 07:36:39 +00:00
|
|
|
|
retrieveEncrypted :: FilePath -> ChunkSize -> (Cipher, Key) -> Key -> FilePath -> Annex Bool
|
2012-09-21 18:54:24 +00:00
|
|
|
|
retrieveEncrypted d chunksize (cipher, enck) k f = metered Nothing k $ \meterupdate ->
|
2012-03-04 07:36:39 +00:00
|
|
|
|
liftIO $ withStoredFiles chunksize d enck $ \files ->
|
|
|
|
|
catchBoolIO $ do
|
2012-11-18 19:27:44 +00:00
|
|
|
|
decrypt cipher (feeder files) $
|
|
|
|
|
readBytes $ meteredWriteFile meterupdate f
|
2012-03-04 07:36:39 +00:00
|
|
|
|
return True
|
2012-11-18 19:27:44 +00:00
|
|
|
|
where
|
|
|
|
|
feeder files h = forM_ files $ \file -> L.hPut h =<< L.readFile file
|
2011-03-30 17:18:46 +00:00
|
|
|
|
|
2012-03-03 22:05:55 +00:00
|
|
|
|
retrieveCheap :: FilePath -> ChunkSize -> Key -> FilePath -> Annex Bool
|
|
|
|
|
retrieveCheap _ (Just _) _ _ = return False -- no cheap retrieval for chunks
|
|
|
|
|
retrieveCheap d _ k f = liftIO $ withStoredFiles Nothing d k go
|
2012-11-11 04:51:07 +00:00
|
|
|
|
where
|
|
|
|
|
go [file] = catchBoolIO $ createSymbolicLink file f >> return True
|
|
|
|
|
go _files = return False
|
2012-03-03 22:05:55 +00:00
|
|
|
|
|
2012-11-19 17:18:23 +00:00
|
|
|
|
remove :: FilePath -> Key -> Annex Bool
|
|
|
|
|
remove d k = liftIO $ catchBoolIO $ do
|
|
|
|
|
allowWrite dir
|
|
|
|
|
removeDirectoryRecursive dir
|
|
|
|
|
return True
|
2012-11-11 04:51:07 +00:00
|
|
|
|
where
|
2012-11-19 17:18:23 +00:00
|
|
|
|
dir = storeDir d k
|
2011-03-30 17:18:46 +00:00
|
|
|
|
|
2012-03-03 22:05:55 +00:00
|
|
|
|
checkPresent :: FilePath -> ChunkSize -> Key -> Annex (Either String Bool)
|
|
|
|
|
checkPresent d chunksize k = liftIO $ catchMsgIO $ withStoredFiles chunksize d k $
|
|
|
|
|
const $ return True -- withStoredFiles checked that it exists
|