git-annex/Remote/Directory.hs

228 lines
7.7 KiB
Haskell
Raw Normal View History

{- A "remote" that is just a filesystem directory.
2011-03-30 17:18:46 +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
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
import qualified Control.Exception as E
import Data.Int
2011-03-30 17:18:46 +00:00
2011-10-05 20:02:51 +00:00
import Common.Annex
import Types.Remote
import qualified Git
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
import Remote.Helper.Chunked
import Crypto
import Annex.Content
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
}
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote
gen r u c gc = do
cst <- remoteCost gc cheapRemoteCost
let chunksize = chunkSize c
2011-04-17 04:40:23 +00:00
return $ encryptableRemote c
(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,
retrieveKeyFile = retrieve dir chunksize,
retrieveKeyFileCheap = retrieveCheap dir chunksize,
removeKey = remove dir,
hasKey = checkPresent dir chunksize,
2011-04-17 01:41:14 +00:00
hasKeyCheap = True,
whereisKey = Nothing,
2012-11-30 04:55:59 +00:00
config = M.empty,
repo = r,
gitconfig = gc,
2012-08-26 18:26:43 +00:00
localpath = Just dir,
readonly = False,
remotetype = remote
2011-04-17 01:41:14 +00:00
}
where
dir = fromMaybe (error "missing directory") $ remoteAnnexDirectory gc
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
liftIO $ unlessM (doesDirectoryExist dir) $
error $ "Directory does not exist: " ++ dir
c' <- encryptionSetup c
2011-03-30 17:18:46 +00:00
-- The directory is stored in git config, not in this remote's
-- persistant state, so it can vary between hosts.
gitConfigSpecialRemote u c' "directory" dir
return $ M.delete "directory" c'
2011-03-30 17:18:46 +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. -}
locations :: FilePath -> Key -> [FilePath]
locations d k = map (d </>) (keyPaths k)
2011-03-30 17:18:46 +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
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 )
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
let chunkcount = f ++ chunkCount
2012-11-11 04:51:07 +00:00
ifM (check chunkcount)
( do
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
)
withStoredFiles :: ChunkSize -> FilePath -> Key -> ([FilePath] -> IO Bool) -> IO Bool
withStoredFiles = withCheckedFiles doesFileExist
2012-09-21 18:50:14 +00:00
store :: FilePath -> ChunkSize -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
store d chunksize k _f p = sendAnnex k $ \src ->
metered (Just p) k $ \meterupdate ->
storeHelper d chunksize k $ \dests ->
case chunksize of
Nothing -> do
let dest = Prelude.head dests
meteredWriteFile meterupdate dest
=<< L.readFile src
return [dest]
Just _ ->
storeSplit meterupdate chunksize dests
=<< L.readFile src
2012-09-21 18:50:14 +00:00
storeEncrypted :: FilePath -> ChunkSize -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
storeEncrypted d chunksize (cipher, enck) k p = sendAnnex k $ \src ->
metered (Just p) k $ \meterupdate ->
storeHelper d chunksize enck $ \dests ->
encrypt cipher (feedFile src) $ readBytes $ \b ->
case chunksize of
Nothing -> do
let dest = Prelude.head dests
meteredWriteFile meterupdate dest b
return [dest]
Just _ -> storeSplit meterupdate chunksize dests b
{- Splits a ByteString into chunks and writes to dests, obeying configured
- chunk size (not to be confused with the L.ByteString chunk size).
- Note: Must always write at least one file, even for empty ByteString. -}
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
-- must always write at least one file, even for empty
L.writeFile firstdest b
return [firstdest]
| 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
bs' <- E.bracket (openFile d WriteMode) hClose (feed chunksize bs)
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
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)
storeHelper :: FilePath -> ChunkSize -> Key -> ([FilePath] -> IO [FilePath]) -> Annex Bool
storeHelper d chunksize key storer = check <&&> go
2012-11-11 04:51:07 +00:00
where
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. -}
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
preventWrite dest
recorder f s = do
void $ tryIO $ allowWrite f
writeFile f s
preventWrite f
retrieve :: FilePath -> ChunkSize -> Key -> AssociatedFile -> FilePath -> Annex Bool
retrieve d chunksize k _ f = metered Nothing k $ \meterupdate ->
liftIO $ withStoredFiles chunksize d k $ \files ->
catchBoolIO $ do
2012-11-18 22:27:53 +00:00
meteredWriteFileChunks meterupdate f files $ L.readFile
return True
2011-04-17 01:41:14 +00:00
retrieveEncrypted :: FilePath -> ChunkSize -> (Cipher, Key) -> Key -> FilePath -> Annex Bool
retrieveEncrypted d chunksize (cipher, enck) k f = metered Nothing k $ \meterupdate ->
liftIO $ withStoredFiles chunksize d enck $ \files ->
catchBoolIO $ do
decrypt cipher (feeder files) $
readBytes $ meteredWriteFile meterupdate f
return True
where
feeder files h = forM_ files $ \file -> L.hPut h =<< L.readFile file
2011-03-30 17:18:46 +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
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
dir = storeDir d k
2011-03-30 17:18:46 +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