mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

more OsPath conversion (475/749)

Browse source 
Sponsored-by: Nicholas Golder-Manning
This commit is contained in:
Joey Hess 2025-02-05 12:14:56 -04:00
parent 7805cd89ad
commit b28433072c
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
5 changed files with 153 additions and 154 deletions
Download patch file Download diff file Expand all files Collapse all files

75
Annex/AutoMerge.hs
View file

@ -133,7 +133,7 @@ autoMergeFrom' branch currbranch mergeconfig commitmode willresolvemerge toresol
resolveMerge :: Maybe Git.Ref -> Git.Ref -> Bool -> Annex Bool resolveMerge :: Maybe Git.Ref -> Git.Ref -> Bool -> Annex Bool
resolveMerge us them inoverlay = do resolveMerge us them inoverlay = do
top <- if inoverlay top <- if inoverlay
then pure "." then pure (literalOsPath ".")
else fromRepo Git.repoPath else fromRepo Git.repoPath
(fs, cleanup) <- inRepo (LsFiles.unmerged [top]) (fs, cleanup) <- inRepo (LsFiles.unmerged [top])
srcmap <- if inoverlay srcmap <- if inoverlay
@ -150,7 +150,7 @@ resolveMerge us them inoverlay = do
unless (null deleted) $ unless (null deleted) $
Annex.Queue.addCommand [] "rm" Annex.Queue.addCommand [] "rm"
[Param "--quiet", Param "-f", Param "--"] [Param "--quiet", Param "-f", Param "--"]
(map fromRawFilePath deleted) (map fromOsPath deleted)
void $ liftIO cleanup2 void $ liftIO cleanup2
when merged $ do when merged $ do
@ -167,7 +167,7 @@ resolveMerge us them inoverlay = do
, LsFiles.unmergedSiblingFile u , LsFiles.unmergedSiblingFile u
] ]
resolveMerge' :: InodeMap -> Maybe Git.Ref -> Git.Ref -> Bool -> LsFiles.Unmerged -> Annex ([Key], Maybe FilePath) resolveMerge' :: InodeMap -> Maybe Git.Ref -> Git.Ref -> Bool -> LsFiles.Unmerged -> Annex ([Key], Maybe OsPath)
resolveMerge' _ Nothing _ _ _ = return ([], Nothing) resolveMerge' _ Nothing _ _ _ = return ([], Nothing)
resolveMerge' unstagedmap (Just us) them inoverlay u = do resolveMerge' unstagedmap (Just us) them inoverlay u = do
kus <- getkey LsFiles.valUs kus <- getkey LsFiles.valUs
@ -182,7 +182,7 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
-- files, so delete here. -- files, so delete here.
unless inoverlay $ unless inoverlay $
unless (islocked LsFiles.valUs) $ unless (islocked LsFiles.valUs) $
liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath file) liftIO $ removeWhenExistsWith removeFile file
| otherwise -> resolveby [keyUs, keyThem] $ | otherwise -> resolveby [keyUs, keyThem] $
-- Only resolve using symlink when both -- Only resolve using symlink when both
-- were locked, otherwise use unlocked -- were locked, otherwise use unlocked
@ -204,8 +204,8 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
-- Neither side is annexed file; cannot resolve. -- Neither side is annexed file; cannot resolve.
(Nothing, Nothing) -> return ([], Nothing) (Nothing, Nothing) -> return ([], Nothing)
where where
file = fromRawFilePath $ LsFiles.unmergedFile u file = LsFiles.unmergedFile u
sibfile = fromRawFilePath <$> LsFiles.unmergedSiblingFile u sibfile = LsFiles.unmergedSiblingFile u
getkey select = getkey select =
case select (LsFiles.unmergedSha u) of case select (LsFiles.unmergedSha u) of
@ -230,16 +230,15 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
dest = variantFile file key dest = variantFile file key
destmode = fromTreeItemType <$> select (LsFiles.unmergedTreeItemType u) destmode = fromTreeItemType <$> select (LsFiles.unmergedTreeItemType u)
stagefile :: FilePath -> Annex FilePath stagefile :: OsPath -> Annex OsPath
stagefile f stagefile f
| inoverlay = (</> f) . fromRawFilePath <$> fromRepo Git.repoPath | inoverlay = (</> f) <$> fromRepo Git.repoPath
| otherwise = pure f | otherwise = pure f
makesymlink key dest = do makesymlink key dest = do
let rdest = toRawFilePath dest l <- fromOsPath <$> calcRepo (gitAnnexLink dest key)
l <- calcRepo $ gitAnnexLink rdest key unless inoverlay $ replacewithsymlink dest l
unless inoverlay $ replacewithsymlink rdest l dest' <- stagefile dest
dest' <- toRawFilePath <$> stagefile dest
stageSymlink dest' =<< hashSymlink l stageSymlink dest' =<< hashSymlink l
replacewithsymlink dest link = replaceWorkTreeFile dest $ replacewithsymlink dest link = replaceWorkTreeFile dest $
@ -248,27 +247,27 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
makepointer key dest destmode = do makepointer key dest destmode = do
unless inoverlay $ unless inoverlay $
unlessM (reuseOldFile unstagedmap key file dest) $ unlessM (reuseOldFile unstagedmap key file dest) $
linkFromAnnex key (toRawFilePath dest) destmode >>= \case linkFromAnnex key dest destmode >>= \case
LinkAnnexFailed -> liftIO $ LinkAnnexFailed -> liftIO $
writePointerFile (toRawFilePath dest) key destmode writePointerFile dest key destmode
_ -> noop _ -> noop
dest' <- toRawFilePath <$> stagefile dest dest' <- stagefile dest
stagePointerFile dest' destmode =<< hashPointerFile key stagePointerFile dest' destmode =<< hashPointerFile key
unless inoverlay $ unless inoverlay $
Database.Keys.addAssociatedFile key Database.Keys.addAssociatedFile key
=<< inRepo (toTopFilePath (toRawFilePath dest)) =<< inRepo (toTopFilePath dest)
{- Stage a graft of a directory or file from a branch {- Stage a graft of a directory or file from a branch
- and update the work tree. -} - and update the work tree. -}
graftin b item selectwant selectwant' selectunwant = do graftin b item selectwant selectwant' selectunwant = do
Annex.Queue.addUpdateIndex Annex.Queue.addUpdateIndex
=<< fromRepo (UpdateIndex.lsSubTree b item) =<< fromRepo (UpdateIndex.lsSubTree b (fromOsPath item))
let replacefile isexecutable = case selectwant' (LsFiles.unmergedSha u) of let replacefile isexecutable = case selectwant' (LsFiles.unmergedSha u) of
Nothing -> noop Nothing -> noop
Just sha -> replaceWorkTreeFile (toRawFilePath item) $ \tmp -> do Just sha -> replaceWorkTreeFile item $ \tmp -> do
c <- catObject sha c <- catObject sha
liftIO $ F.writeFile (toOsPath tmp) c liftIO $ F.writeFile tmp c
when isexecutable $ when isexecutable $
liftIO $ void $ tryIO $ liftIO $ void $ tryIO $
modifyFileMode tmp $ modifyFileMode tmp $
@ -281,7 +280,7 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
Nothing -> noop Nothing -> noop
Just sha -> do Just sha -> do
link <- catSymLinkTarget sha link <- catSymLinkTarget sha
replacewithsymlink (toRawFilePath item) link replacewithsymlink item (fromOsPath link)
(Just TreeFile, Just TreeSymlink) -> replacefile False (Just TreeFile, Just TreeSymlink) -> replacefile False
(Just TreeExecutable, Just TreeSymlink) -> replacefile True (Just TreeExecutable, Just TreeSymlink) -> replacefile True
_ -> ifM (liftIO $ doesDirectoryExist item) _ -> ifM (liftIO $ doesDirectoryExist item)
@ -305,9 +304,9 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
, Param "--cached" , Param "--cached"
, Param "--" , Param "--"
] ]
(catMaybes [Just file, sibfile]) (map fromOsPath $ catMaybes [Just file, sibfile])
liftIO $ maybe noop liftIO $ maybe noop
(removeWhenExistsWith R.removeLink . toRawFilePath) (removeWhenExistsWith removeFile)
sibfile sibfile
void a void a
return (ks, Just file) return (ks, Just file)
@ -322,13 +321,13 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
- C) are pointers to or have the content of keys that were involved - C) are pointers to or have the content of keys that were involved
- in the merge. - in the merge.
-} -}
cleanConflictCruft :: [Key] -> [FilePath] -> InodeMap -> Annex () cleanConflictCruft :: [Key] -> [OsPath] -> InodeMap -> Annex ()
cleanConflictCruft resolvedks resolvedfs unstagedmap = do cleanConflictCruft resolvedks resolvedfs unstagedmap = do
is <- S.fromList . map (inodeCacheToKey Strongly) . concat is <- S.fromList . map (inodeCacheToKey Strongly) . concat
<$> mapM Database.Keys.getInodeCaches resolvedks <$> mapM Database.Keys.getInodeCaches resolvedks
forM_ (M.toList unstagedmap) $ \(i, f) -> forM_ (M.toList unstagedmap) $ \(i, f) ->
whenM (matchesresolved is i f) $ whenM (matchesresolved is i f) $
liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) liftIO $ removeWhenExistsWith removeFile f
where where
fs = S.fromList resolvedfs fs = S.fromList resolvedfs
ks = S.fromList resolvedks ks = S.fromList resolvedks
@ -336,19 +335,24 @@ cleanConflictCruft resolvedks resolvedfs unstagedmap = do
matchesresolved is i f matchesresolved is i f
| S.member f fs || S.member (conflictCruftBase f) fs = anyM id | S.member f fs || S.member (conflictCruftBase f) fs = anyM id
[ pure $ either (const False) (`S.member` is) i [ pure $ either (const False) (`S.member` is) i
, inks <$> isAnnexLink (toRawFilePath f) , inks <$> isAnnexLink f
, inks <$> liftIO (isPointerFile (toRawFilePath f)) , inks <$> liftIO (isPointerFile f)
] ]
| otherwise = return False | otherwise = return False
conflictCruftBase :: FilePath -> FilePath conflictCruftBase :: OsPath -> OsPath
conflictCruftBase f = reverse $ drop 1 $ dropWhile (/= '~') $ reverse f conflictCruftBase = toOsPath
. reverse
. drop 1
. dropWhile (/= '~')
. reverse
. fromOsPath
{- When possible, reuse an existing file from the srcmap as the {- When possible, reuse an existing file from the srcmap as the
- content of a worktree file in the resolved merge. It must have the - content of a worktree file in the resolved merge. It must have the
- same name as the origfile, or a name that git would use for conflict - same name as the origfile, or a name that git would use for conflict
- cruft. And, its inode cache must be a known one for the key. -} - cruft. And, its inode cache must be a known one for the key. -}
reuseOldFile :: InodeMap -> Key -> FilePath -> FilePath -> Annex Bool reuseOldFile :: InodeMap -> Key -> OsPath -> OsPath -> Annex Bool
reuseOldFile srcmap key origfile destfile = do reuseOldFile srcmap key origfile destfile = do
is <- map (inodeCacheToKey Strongly) is <- map (inodeCacheToKey Strongly)
<$> Database.Keys.getInodeCaches key <$> Database.Keys.getInodeCaches key
@ -374,19 +378,18 @@ commitResolvedMerge commitmode = do
, Param "git-annex automatic merge conflict fix" , Param "git-annex automatic merge conflict fix"
] ]
type InodeMap = M.Map (Either FilePath InodeCacheKey) FilePath type InodeMap = M.Map (Either OsPath InodeCacheKey) OsPath
inodeMap :: Annex ([RawFilePath], IO Bool) -> Annex InodeMap inodeMap :: Annex ([OsPath], IO Bool) -> Annex InodeMap
inodeMap getfiles = do inodeMap getfiles = do
(fs, cleanup) <- getfiles (fs, cleanup) <- getfiles
fsis <- forM fs $ \f -> do fsis <- forM fs $ \f -> do
s <- liftIO $ R.getSymbolicLinkStatus f s <- liftIO $ R.getSymbolicLinkStatus (fromOsPath f)
let f' = fromRawFilePath f
if isSymbolicLink s if isSymbolicLink s
then pure $ Just (Left f', f') then pure $ Just (Left f, f)
else withTSDelta (\d -> liftIO $ toInodeCache d f s) else withTSDelta (\d -> liftIO $ toInodeCache d f s)
>>= return . \case >>= return . \case
Just i -> Just (Right (inodeCacheToKey Strongly i), f') Just i -> Just (Right (inodeCacheToKey Strongly i), f)
Nothing -> Nothing Nothing -> Nothing
void $ liftIO cleanup void $ liftIO cleanup
return $ M.fromList $ catMaybes fsis return $ M.fromList $ catMaybes fsis

1
Git/UpdateIndex.hs
View file

@ -81,6 +81,7 @@ lsTree (Ref x) repo streamer = do
void $ cleanup void $ cleanup
where where
params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS x] params = map Param ["ls-tree", "-z", "-r", "--full-tree", decodeBS x]
lsSubTree :: Ref -> FilePath -> Repo -> Streamer lsSubTree :: Ref -> FilePath -> Repo -> Streamer
lsSubTree (Ref x) p repo streamer = do lsSubTree (Ref x) p repo streamer = do
(s, cleanup) <- pipeNullSplit params repo (s, cleanup) <- pipeNullSplit params repo

194
Remote/Directory.hs
View file

@ -17,7 +17,6 @@ module Remote.Directory (
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import qualified System.FilePath.ByteString as P
import Data.Default import Data.Default
import System.PosixCompat.Files (isRegularFile, deviceID) import System.PosixCompat.Files (isRegularFile, deviceID)
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
@ -132,11 +131,11 @@ gen r u rc gc rs = do
, config = c , config = c
, getRepo = return r , getRepo = return r
, gitconfig = gc , gitconfig = gc
, localpath = Just dir' , localpath = Just dir
, readonly = False , readonly = False
, appendonly = False , appendonly = False
, untrustworthy = False , untrustworthy = False
, availability = checkPathAvailability True dir' , availability = checkPathAvailability True dir
, remotetype = remote , remotetype = remote
, mkUnavailable = gen r u rc , mkUnavailable = gen r u rc
(gc { remoteAnnexDirectory = Just "/dev/null" }) rs (gc { remoteAnnexDirectory = Just "/dev/null" }) rs
@ -146,8 +145,9 @@ gen r u rc gc rs = do
, remoteStateHandle = rs , remoteStateHandle = rs
} }
where where
dir = toRawFilePath dir' dir = toOsPath dir'
dir' = fromMaybe (giveup "missing directory") (remoteAnnexDirectory gc) dir' = fromMaybe (giveup "missing directory")
(remoteAnnexDirectory gc)
directorySetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) directorySetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
directorySetup _ mu _ c gc = do directorySetup _ mu _ c gc = do
@ -155,43 +155,41 @@ directorySetup _ mu _ c gc = do
-- verify configuration is sane -- verify configuration is sane
let dir = maybe (giveup "Specify directory=") fromProposedAccepted $ let dir = maybe (giveup "Specify directory=") fromProposedAccepted $
M.lookup directoryField c M.lookup directoryField c
absdir <- liftIO $ fromRawFilePath <$> absPath (toRawFilePath dir) absdir <- liftIO $ absPath (toOsPath dir)
liftIO $ unlessM (doesDirectoryExist absdir) $ liftIO $ unlessM (doesDirectoryExist absdir) $
giveup $ "Directory does not exist: " ++ absdir giveup $ "Directory does not exist: " ++ fromOsPath absdir
(c', _encsetup) <- encryptionSetup c gc (c', _encsetup) <- encryptionSetup c gc
-- The directory is stored in git config, not in this remote's -- The directory is stored in git config, not in this remote's
-- persistent state, so it can vary between hosts. -- persistent state, so it can vary between hosts.
gitConfigSpecialRemote u c' [("directory", absdir)] gitConfigSpecialRemote u c' [("directory", fromOsPath absdir)]
return (M.delete directoryField c', u) return (M.delete directoryField c', u)
{- Locations to try to access a given Key in the directory. {- Locations to try to access a given Key in the directory.
- We try more than one since we used to write to different hash - We try more than one since we used to write to different hash
- directories. -} - directories. -}
locations :: RawFilePath -> Key -> NE.NonEmpty RawFilePath locations :: OsPath -> Key -> NE.NonEmpty OsPath
locations d k = NE.map (d P.</>) (keyPaths k) locations d k = NE.map (d </>) (keyPaths k)
locations' :: RawFilePath -> Key -> [RawFilePath] locations' :: OsPath -> Key -> [OsPath]
locations' d k = NE.toList (locations d k) locations' d k = NE.toList (locations d k)
{- Returns the location of a Key in the directory. If the key is {- Returns the location of a Key in the directory. If the key is
- present, returns the location that is actually used, otherwise - present, returns the location that is actually used, otherwise
- returns the first, default location. -} - returns the first, default location. -}
getLocation :: RawFilePath -> Key -> IO RawFilePath getLocation :: OsPath -> Key -> IO OsPath
getLocation d k = do getLocation d k = do
let locs = locations d k let locs = locations d k
fromMaybe (NE.head locs) fromMaybe (NE.head locs) <$> firstM doesFileExist (NE.toList locs)
<$> firstM (doesFileExist . fromRawFilePath)
(NE.toList locs)
{- Directory where the file(s) for a key are stored. -} {- Directory where the file(s) for a key are stored. -}
storeDir :: RawFilePath -> Key -> RawFilePath storeDir :: OsPath -> Key -> OsPath
storeDir d k = P.addTrailingPathSeparator $ storeDir d k = addTrailingPathSeparator $
d P.</> hashDirLower def k P.</> keyFile k d </> hashDirLower def k </> keyFile k
{- Check if there is enough free disk space in the remote's directory to {- 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. -} - store the key. Note that the unencrypted key size is checked. -}
storeKeyM :: RawFilePath -> ChunkConfig -> CopyCoWTried -> Storer storeKeyM :: OsPath -> ChunkConfig -> CopyCoWTried -> Storer
storeKeyM d chunkconfig cow k c m = storeKeyM d chunkconfig cow k c m =
ifM (checkDiskSpaceDirectory d k) ifM (checkDiskSpaceDirectory d k)
( do ( do
@ -203,16 +201,16 @@ storeKeyM d chunkconfig cow k c m =
store = case chunkconfig of store = case chunkconfig of
LegacyChunks chunksize -> LegacyChunks chunksize ->
let go _k b p = liftIO $ Legacy.store let go _k b p = liftIO $ Legacy.store
(fromRawFilePath d) (fromOsPath d)
chunksize chunksize
(finalizeStoreGeneric d) (finalizeStoreGeneric d)
k b p k b p
(fromRawFilePath tmpdir) (fromOsPath tmpdir)
(fromRawFilePath destdir) (fromOsPath destdir)
in byteStorer go k c m in byteStorer go k c m
NoChunks -> NoChunks ->
let go _k src p = liftIO $ do let go _k src p = liftIO $ do
void $ fileCopier cow src tmpf p Nothing void $ fileCopier cow (fromOsPath src) (fromOsPath tmpf) p Nothing
finalizeStoreGeneric d tmpdir destdir finalizeStoreGeneric d tmpdir destdir
in fileStorer go k c m in fileStorer go k c m
_ -> _ ->
@ -221,60 +219,58 @@ storeKeyM d chunkconfig cow k c m =
finalizeStoreGeneric d tmpdir destdir finalizeStoreGeneric d tmpdir destdir
in byteStorer go k c m in byteStorer go k c m
tmpdir = P.addTrailingPathSeparator $ d P.</> "tmp" P.</> kf tmpdir = addTrailingPathSeparator $ d </> literalOsPath "tmp" </> kf
tmpf = fromRawFilePath tmpdir </> fromRawFilePath kf tmpf = tmpdir </> kf
kf = keyFile k kf = keyFile k
destdir = storeDir d k destdir = storeDir d k
checkDiskSpaceDirectory :: RawFilePath -> Key -> Annex Bool checkDiskSpaceDirectory :: OsPath -> Key -> Annex Bool
checkDiskSpaceDirectory d k = do checkDiskSpaceDirectory d k = do
annexdir <- fromRepo gitAnnexObjectDir annexdir <- fromRepo gitAnnexObjectDir
samefilesystem <- liftIO $ catchDefaultIO False $ samefilesystem <- liftIO $ catchDefaultIO False $
(\a b -> deviceID a == deviceID b) (\a b -> deviceID a == deviceID b)
<$> R.getSymbolicLinkStatus d <$> R.getSymbolicLinkStatus (fromOsPath d)
<*> R.getSymbolicLinkStatus annexdir <*> R.getSymbolicLinkStatus (fromOsPath annexdir)
checkDiskSpace Nothing (Just d) k 0 samefilesystem checkDiskSpace Nothing (Just d) k 0 samefilesystem
{- Passed a temp directory that contains the files that should be placed {- 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, moves it into place. Anything already existing
- in the dest directory will be deleted. File permissions will be locked - in the dest directory will be deleted. File permissions will be locked
- down. -} - down. -}
finalizeStoreGeneric :: RawFilePath -> RawFilePath -> RawFilePath -> IO () finalizeStoreGeneric :: OsPath -> OsPath -> OsPath -> IO ()
finalizeStoreGeneric d tmp dest = do finalizeStoreGeneric d tmp dest = do
removeDirGeneric False d dest removeDirGeneric False d dest
createDirectoryUnder [d] (parentDir dest) createDirectoryUnder [d] (parentDir dest)
renameDirectory (fromRawFilePath tmp) dest' renameDirectory tmp dest
-- may fail on some filesystems -- may fail on some filesystems
void $ tryIO $ do void $ tryIO $ do
mapM_ preventWrite =<< dirContents dest mapM_ preventWrite =<< dirContents dest
preventWrite dest preventWrite dest
where
dest' = fromRawFilePath dest
retrieveKeyFileM :: RawFilePath -> ChunkConfig -> CopyCoWTried -> Retriever retrieveKeyFileM :: OsPath -> ChunkConfig -> CopyCoWTried -> Retriever
retrieveKeyFileM d (LegacyChunks _) _ = Legacy.retrieve locations' d retrieveKeyFileM d (LegacyChunks _) _ = Legacy.retrieve locations' d
retrieveKeyFileM d NoChunks cow = fileRetriever' $ \dest k p iv -> do retrieveKeyFileM d NoChunks cow = fileRetriever' $ \dest k p iv -> do
src <- liftIO $ fromRawFilePath <$> getLocation d k src <- liftIO $ getLocation d k
void $ liftIO $ fileCopier cow src (fromRawFilePath dest) p iv void $ liftIO $ fileCopier cow (fromOsPath src) (fromOsPath dest) p iv
retrieveKeyFileM d _ _ = byteRetriever $ \k sink -> retrieveKeyFileM d _ _ = byteRetriever $ \k sink ->
sink =<< liftIO (F.readFile . toOsPath =<< getLocation d k) sink =<< liftIO (F.readFile =<< getLocation d k)
retrieveKeyFileCheapM :: RawFilePath -> ChunkConfig -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ()) retrieveKeyFileCheapM :: OsPath -> ChunkConfig -> Maybe (Key -> AssociatedFile -> OsPath -> Annex ())
-- no cheap retrieval possible for chunks -- no cheap retrieval possible for chunks
retrieveKeyFileCheapM _ (UnpaddedChunks _) = Nothing retrieveKeyFileCheapM _ (UnpaddedChunks _) = Nothing
retrieveKeyFileCheapM _ (LegacyChunks _) = Nothing retrieveKeyFileCheapM _ (LegacyChunks _) = Nothing
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
retrieveKeyFileCheapM d NoChunks = Just $ \k _af f -> liftIO $ do retrieveKeyFileCheapM d NoChunks = Just $ \k _af f -> liftIO $ do
file <- fromRawFilePath <$> (absPath =<< getLocation d k) file <- absPath =<< getLocation d k
ifM (doesFileExist file) ifM (doesFileExist file)
( R.createSymbolicLink (toRawFilePath file) (toRawFilePath f) ( R.createSymbolicLink (fromOsPath file) (fromOsPath f)
, giveup "content file not present in remote" , giveup "content file not present in remote"
) )
#else #else
retrieveKeyFileCheapM _ _ = Nothing retrieveKeyFileCheapM _ _ = Nothing
#endif #endif
removeKeyM :: RawFilePath -> Remover removeKeyM :: OsPath -> Remover
removeKeyM d _proof k = liftIO $ removeDirGeneric True d (storeDir d k) removeKeyM d _proof k = liftIO $ removeDirGeneric True d (storeDir d k)
{- Removes the directory, which must be located under the topdir. {- Removes the directory, which must be located under the topdir.
@ -291,7 +287,7 @@ removeKeyM d _proof k = liftIO $ removeDirGeneric True d (storeDir d k)
- can also be removed. Failure to remove such a directory is not treated - can also be removed. Failure to remove such a directory is not treated
- as an error. - as an error.
-} -}
removeDirGeneric :: Bool -> RawFilePath -> RawFilePath -> IO () removeDirGeneric :: Bool -> OsPath -> OsPath -> IO ()
removeDirGeneric removeemptyparents topdir dir = do removeDirGeneric removeemptyparents topdir dir = do
void $ tryIO $ allowWrite dir void $ tryIO $ allowWrite dir
#ifdef mingw32_HOST_OS #ifdef mingw32_HOST_OS
@ -299,102 +295,100 @@ removeDirGeneric removeemptyparents topdir dir = do
- before it can delete them. -} - before it can delete them. -}
void $ tryIO $ mapM_ allowWrite =<< dirContents dir void $ tryIO $ mapM_ allowWrite =<< dirContents dir
#endif #endif
tryNonAsync (removeDirectoryRecursive dir') >>= \case tryNonAsync (removeDirectoryRecursive dir) >>= \case
Right () -> return () Right () -> return ()
Left e -> Left e ->
unlessM (doesDirectoryExist topdir' <&&> (not <$> doesDirectoryExist dir')) $ unlessM (doesDirectoryExist topdir <&&> (not <$> doesDirectoryExist dir)) $
throwM e throwM e
when removeemptyparents $ do when removeemptyparents $ do
subdir <- relPathDirToFile topdir (P.takeDirectory dir) subdir <- relPathDirToFile topdir (takeDirectory dir)
goparents (Just (P.takeDirectory subdir)) (Right ()) goparents (Just (takeDirectory subdir)) (Right ())
where where
goparents _ (Left _e) = return () goparents _ (Left _e) = return ()
goparents Nothing _ = return () goparents Nothing _ = return ()
goparents (Just subdir) _ = do goparents (Just subdir) _ = do
let d = topdir' </> fromRawFilePath subdir let d = topdir </> subdir
goparents (upFrom subdir) =<< tryIO (removeDirectory d) goparents (upFrom subdir) =<< tryIO (removeDirectory d)
dir' = fromRawFilePath dir
topdir' = fromRawFilePath topdir
checkPresentM :: RawFilePath -> ChunkConfig -> CheckPresent checkPresentM :: OsPath -> ChunkConfig -> CheckPresent
checkPresentM d (LegacyChunks _) k = Legacy.checkKey d locations' k checkPresentM d (LegacyChunks _) k = Legacy.checkKey d locations' k
checkPresentM d _ k = checkPresentGeneric d (locations' d k) checkPresentM d _ k = checkPresentGeneric d (locations' d k)
checkPresentGeneric :: RawFilePath -> [RawFilePath] -> Annex Bool checkPresentGeneric :: OsPath -> [OsPath] -> Annex Bool
checkPresentGeneric d ps = checkPresentGeneric' d $ checkPresentGeneric d ps = checkPresentGeneric' d $
liftIO $ anyM (doesFileExist . fromRawFilePath) ps liftIO $ anyM doesFileExist ps
checkPresentGeneric' :: RawFilePath -> Annex Bool -> Annex Bool checkPresentGeneric' :: OsPath -> Annex Bool -> Annex Bool
checkPresentGeneric' d check = ifM check checkPresentGeneric' d check = ifM check
( return True ( return True
, ifM (liftIO $ doesDirectoryExist (fromRawFilePath d)) , ifM (liftIO $ doesDirectoryExist d)
( return False ( return False
, giveup $ "directory " ++ fromRawFilePath d ++ " is not accessible" , giveup $ "directory " ++ fromOsPath d ++ " is not accessible"
) )
) )
storeExportM :: RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () storeExportM :: OsPath -> CopyCoWTried -> OsPath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
storeExportM d cow src _k loc p = do storeExportM d cow src _k loc p = do
liftIO $ createDirectoryUnder [d] (P.takeDirectory dest) liftIO $ createDirectoryUnder [d] (takeDirectory dest)
-- Write via temp file so that checkPresentGeneric will not -- Write via temp file so that checkPresentGeneric will not
-- see it until it's fully stored. -- see it until it's fully stored.
viaTmp go (toOsPath dest) () viaTmp go dest ()
where where
dest = exportPath d loc dest = exportPath d loc
go tmp () = void $ liftIO $ fileCopier cow src (fromRawFilePath (fromOsPath tmp)) p Nothing go tmp () = void $ liftIO $
fileCopier cow (fromOsPath src) (fromOsPath tmp) p Nothing
retrieveExportM :: RawFilePath -> CopyCoWTried -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification retrieveExportM :: OsPath -> CopyCoWTried -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification
retrieveExportM d cow k loc dest p = retrieveExportM d cow k loc dest p =
verifyKeyContentIncrementally AlwaysVerify k $ \iv -> verifyKeyContentIncrementally AlwaysVerify k $ \iv ->
void $ liftIO $ fileCopier cow src dest p iv void $ liftIO $ fileCopier cow src (fromOsPath dest) p iv
where where
src = fromRawFilePath $ exportPath d loc src = fromOsPath $ exportPath d loc
removeExportM :: RawFilePath -> Key -> ExportLocation -> Annex () removeExportM :: OsPath -> Key -> ExportLocation -> Annex ()
removeExportM d _k loc = liftIO $ do removeExportM d _k loc = liftIO $ do
removeWhenExistsWith R.removeLink src removeWhenExistsWith removeFile src
removeExportLocation d loc removeExportLocation d loc
where where
src = exportPath d loc src = exportPath d loc
checkPresentExportM :: RawFilePath -> Key -> ExportLocation -> Annex Bool checkPresentExportM :: OsPath -> Key -> ExportLocation -> Annex Bool
checkPresentExportM d _k loc = checkPresentExportM d _k loc =
checkPresentGeneric d [exportPath d loc] checkPresentGeneric d [exportPath d loc]
renameExportM :: RawFilePath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ()) renameExportM :: OsPath -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ())
renameExportM d _k oldloc newloc = liftIO $ do renameExportM d _k oldloc newloc = liftIO $ do
createDirectoryUnder [d] (P.takeDirectory dest) createDirectoryUnder [d] (takeDirectory dest)
renameFile (fromRawFilePath src) (fromRawFilePath dest) renameFile src dest
removeExportLocation d oldloc removeExportLocation d oldloc
return (Just ()) return (Just ())
where where
src = exportPath d oldloc src = exportPath d oldloc
dest = exportPath d newloc dest = exportPath d newloc
exportPath :: RawFilePath -> ExportLocation -> RawFilePath exportPath :: OsPath -> ExportLocation -> OsPath
exportPath d loc = d P.</> fromExportLocation loc exportPath d loc = d </> fromExportLocation loc
{- Removes the ExportLocation's parent directory and its parents, so long as {- Removes the ExportLocation's parent directory and its parents, so long as
- they're empty, up to but not including the topdir. -} - they're empty, up to but not including the topdir. -}
removeExportLocation :: RawFilePath -> ExportLocation -> IO () removeExportLocation :: OsPath -> ExportLocation -> IO ()
removeExportLocation topdir loc = removeExportLocation topdir loc =
go (Just $ P.takeDirectory $ fromExportLocation loc) (Right ()) go (Just $ takeDirectory $ fromExportLocation loc) (Right ())
where where
go _ (Left _e) = return () go _ (Left _e) = return ()
go Nothing _ = return () go Nothing _ = return ()
go (Just loc') _ = go (Just loc') _ =
let p = fromRawFilePath $ exportPath topdir $ let p = exportPath topdir $ mkExportLocation loc'
mkExportLocation loc'
in go (upFrom loc') =<< tryIO (removeDirectory p) in go (upFrom loc') =<< tryIO (removeDirectory p)
listImportableContentsM :: IgnoreInodes -> RawFilePath -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) listImportableContentsM :: IgnoreInodes -> OsPath -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize)))
listImportableContentsM ii dir = liftIO $ do listImportableContentsM ii dir = liftIO $ do
l' <- mapM go =<< dirContentsRecursiveSkipping (const False) False dir l' <- mapM go =<< dirContentsRecursiveSkipping (const False) False dir
return $ Just $ ImportableContentsComplete $ return $ Just $ ImportableContentsComplete $
ImportableContents (catMaybes l') [] ImportableContents (catMaybes l') []
where where
go f = do go f = do
st <- R.getSymbolicLinkStatus f st <- R.getSymbolicLinkStatus (fromOsPath f)
mkContentIdentifier ii f st >>= \case mkContentIdentifier ii f st >>= \case
Nothing -> return Nothing Nothing -> return Nothing
Just cid -> do Just cid -> do
@ -408,7 +402,7 @@ newtype IgnoreInodes = IgnoreInodes Bool
-- and also normally the inode, unless ignoreinodes=yes. -- and also normally the inode, unless ignoreinodes=yes.
-- --
-- If the file is not a regular file, this will return Nothing. -- If the file is not a regular file, this will return Nothing.
mkContentIdentifier :: IgnoreInodes -> RawFilePath -> FileStatus -> IO (Maybe ContentIdentifier) mkContentIdentifier :: IgnoreInodes -> OsPath -> FileStatus -> IO (Maybe ContentIdentifier)
mkContentIdentifier (IgnoreInodes ii) f st = mkContentIdentifier (IgnoreInodes ii) f st =
liftIO $ fmap (ContentIdentifier . encodeBS . showInodeCache) liftIO $ fmap (ContentIdentifier . encodeBS . showInodeCache)
<$> if ii <$> if ii
@ -434,25 +428,25 @@ guardSameContentIdentifiers cont olds (Just new)
let ic' = replaceInode 0 ic let ic' = replaceInode 0 ic
in ContentIdentifier (encodeBS (showInodeCache ic')) in ContentIdentifier (encodeBS (showInodeCache ic'))
importKeyM :: IgnoreInodes -> RawFilePath -> ExportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> Annex (Maybe Key) importKeyM :: IgnoreInodes -> OsPath -> ExportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> Annex (Maybe Key)
importKeyM ii dir loc cid sz p = do importKeyM ii dir loc cid sz p = do
backend <- chooseBackend f backend <- chooseBackend f
unsizedk <- fst <$> genKey ks p backend unsizedk <- fst <$> genKey ks p backend
let k = alterKey unsizedk $ \kd -> kd let k = alterKey unsizedk $ \kd -> kd
{ keySize = keySize kd <|> Just sz } { keySize = keySize kd <|> Just sz }
currcid <- liftIO $ mkContentIdentifier ii absf currcid <- liftIO $ mkContentIdentifier ii absf
=<< R.getSymbolicLinkStatus absf =<< R.getSymbolicLinkStatus (fromOsPath absf)
guardSameContentIdentifiers (return (Just k)) [cid] currcid guardSameContentIdentifiers (return (Just k)) [cid] currcid
where where
f = fromExportLocation loc f = fromExportLocation loc
absf = dir P.</> f absf = dir </> f
ks = KeySource ks = KeySource
{ keyFilename = f { keyFilename = f
, contentLocation = absf , contentLocation = absf
, inodeCache = Nothing , inodeCache = Nothing
} }
retrieveExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> CopyCoWTried -> ExportLocation -> [ContentIdentifier] -> FilePath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification) retrieveExportWithContentIdentifierM :: IgnoreInodes -> OsPath -> CopyCoWTried -> ExportLocation -> [ContentIdentifier] -> OsPath -> Either Key (Annex Key) -> MeterUpdate -> Annex (Key, Verification)
retrieveExportWithContentIdentifierM ii dir cow loc cids dest gk p = retrieveExportWithContentIdentifierM ii dir cow loc cids dest gk p =
case gk of case gk of
Right mkkey -> do Right mkkey -> do
@ -464,11 +458,11 @@ retrieveExportWithContentIdentifierM ii dir cow loc cids dest gk p =
return (k, v) return (k, v)
where where
f = exportPath dir loc f = exportPath dir loc
f' = fromRawFilePath f f' = fromOsPath f
go iv = precheck (docopy iv) go iv = precheck (docopy iv)
docopy iv = ifM (liftIO $ tryCopyCoW cow f' dest p) docopy iv = ifM (liftIO $ tryCopyCoW cow (fromOsPath f) (fromOsPath dest) p)
( postcheckcow (liftIO $ maybe noop unableIncrementalVerifier iv) ( postcheckcow (liftIO $ maybe noop unableIncrementalVerifier iv)
, docopynoncow iv , docopynoncow iv
) )
@ -477,7 +471,7 @@ retrieveExportWithContentIdentifierM ii dir cow loc cids dest gk p =
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
let open = do let open = do
-- Need a duplicate fd for the post check. -- Need a duplicate fd for the post check.
fd <- openFdWithMode f ReadOnly Nothing defaultFileFlags fd <- openFdWithMode f' ReadOnly Nothing defaultFileFlags
dupfd <- dup fd dupfd <- dup fd
h <- fdToHandle fd h <- fdToHandle fd
return (h, dupfd) return (h, dupfd)
@ -490,7 +484,7 @@ retrieveExportWithContentIdentifierM ii dir cow loc cids dest gk p =
let close = hClose let close = hClose
bracketIO open close $ \h -> do bracketIO open close $ \h -> do
#endif #endif
liftIO $ fileContentCopier h dest p iv liftIO $ fileContentCopier h (fromOsPath dest) p iv
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
postchecknoncow dupfd (return ()) postchecknoncow dupfd (return ())
#else #else
@ -501,7 +495,7 @@ retrieveExportWithContentIdentifierM ii dir cow loc cids dest gk p =
-- content. -- content.
precheck cont = guardSameContentIdentifiers cont cids precheck cont = guardSameContentIdentifiers cont cids
=<< liftIO . mkContentIdentifier ii f =<< liftIO . mkContentIdentifier ii f
=<< liftIO (R.getSymbolicLinkStatus f) =<< liftIO (R.getSymbolicLinkStatus f')
-- Check after copy, in case the file was changed while it was -- Check after copy, in case the file was changed while it was
-- being copied. -- being copied.
@ -525,7 +519,7 @@ retrieveExportWithContentIdentifierM ii dir cow loc cids dest gk p =
#ifndef mingw32_HOST_OS #ifndef mingw32_HOST_OS
=<< getFdStatus fd =<< getFdStatus fd
#else #else
=<< R.getSymbolicLinkStatus f =<< R.getSymbolicLinkStatus f'
#endif #endif
guardSameContentIdentifiers cont cids currcid guardSameContentIdentifiers cont cids currcid
@ -536,37 +530,37 @@ retrieveExportWithContentIdentifierM ii dir cow loc cids dest gk p =
-- restored to the original content before this check. -- restored to the original content before this check.
postcheckcow cont = do postcheckcow cont = do
currcid <- liftIO $ mkContentIdentifier ii f currcid <- liftIO $ mkContentIdentifier ii f
=<< R.getSymbolicLinkStatus f =<< R.getSymbolicLinkStatus f'
guardSameContentIdentifiers cont cids currcid guardSameContentIdentifiers cont cids currcid
storeExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier storeExportWithContentIdentifierM :: IgnoreInodes -> OsPath -> CopyCoWTried -> OsPath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier
storeExportWithContentIdentifierM ii dir cow src _k loc overwritablecids p = do storeExportWithContentIdentifierM ii dir cow src _k loc overwritablecids p = do
liftIO $ createDirectoryUnder [dir] destdir liftIO $ createDirectoryUnder [dir] destdir
withTmpFileIn (toOsPath destdir) template $ \tmpf tmph -> do withTmpFileIn destdir template $ \tmpf tmph -> do
let tmpf' = fromOsPath tmpf let tmpf' = fromOsPath tmpf
liftIO $ hClose tmph liftIO $ hClose tmph
void $ liftIO $ fileCopier cow src (fromRawFilePath tmpf') p Nothing void $ liftIO $ fileCopier cow (fromOsPath src) (fromOsPath tmpf) p Nothing
resetAnnexFilePerm tmpf' resetAnnexFilePerm tmpf
liftIO (R.getSymbolicLinkStatus tmpf') >>= liftIO . mkContentIdentifier ii tmpf' >>= \case liftIO (R.getSymbolicLinkStatus tmpf') >>= liftIO . mkContentIdentifier ii tmpf >>= \case
Nothing -> giveup "unable to generate content identifier" Nothing -> giveup "unable to generate content identifier"
Just newcid -> do Just newcid -> do
checkExportContent ii dir loc checkExportContent ii dir loc
overwritablecids overwritablecids
(giveup "unsafe to overwrite file") (giveup "unsafe to overwrite file")
(const $ liftIO $ R.rename tmpf' dest) (const $ liftIO $ R.rename tmpf' (fromOsPath dest))
return newcid return newcid
where where
dest = exportPath dir loc dest = exportPath dir loc
(destdir, base) = P.splitFileName dest (destdir, base) = splitFileName dest
template = relatedTemplate (base <> ".tmp") template = relatedTemplate (fromOsPath base <> ".tmp")
removeExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex () removeExportWithContentIdentifierM :: IgnoreInodes -> OsPath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex ()
removeExportWithContentIdentifierM ii dir k loc removeablecids = removeExportWithContentIdentifierM ii dir k loc removeablecids =
checkExportContent ii dir loc removeablecids (giveup "unsafe to remove modified file") $ \case checkExportContent ii dir loc removeablecids (giveup "unsafe to remove modified file") $ \case
DoesNotExist -> return () DoesNotExist -> return ()
KnownContentIdentifier -> removeExportM dir k loc KnownContentIdentifier -> removeExportM dir k loc
checkPresentExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool checkPresentExportWithContentIdentifierM :: IgnoreInodes -> OsPath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool
checkPresentExportWithContentIdentifierM ii dir _k loc knowncids = checkPresentExportWithContentIdentifierM ii dir _k loc knowncids =
checkPresentGeneric' dir $ checkPresentGeneric' dir $
checkExportContent ii dir loc knowncids (return False) $ \case checkExportContent ii dir loc knowncids (return False) $ \case
@ -590,9 +584,9 @@ data CheckResult = DoesNotExist | KnownContentIdentifier
-- --
-- So, it suffices to check if the destination file's current -- So, it suffices to check if the destination file's current
-- content is known, and immediately run the callback. -- content is known, and immediately run the callback.
checkExportContent :: IgnoreInodes -> RawFilePath -> ExportLocation -> [ContentIdentifier] -> Annex a -> (CheckResult -> Annex a) -> Annex a checkExportContent :: IgnoreInodes -> OsPath -> ExportLocation -> [ContentIdentifier] -> Annex a -> (CheckResult -> Annex a) -> Annex a
checkExportContent ii dir loc knowncids unsafe callback = checkExportContent ii dir loc knowncids unsafe callback =
tryWhenExists (liftIO $ R.getSymbolicLinkStatus dest) >>= \case tryWhenExists (liftIO $ R.getSymbolicLinkStatus (fromOsPath dest)) >>= \case
Just destst Just destst
| not (isRegularFile destst) -> unsafe | not (isRegularFile destst) -> unsafe
| otherwise -> catchDefaultIO Nothing (liftIO $ mkContentIdentifier ii dest destst) >>= \case | otherwise -> catchDefaultIO Nothing (liftIO $ mkContentIdentifier ii dest destst) >>= \case

31
Remote/External.hs
View file

@ -237,9 +237,10 @@ checkExportSupported' external = go `catchNonAsync` (const (return False))
storeKeyM :: External -> Storer storeKeyM :: External -> Storer
storeKeyM external = fileStorer $ \k f p -> storeKeyM external = fileStorer $ \k f p ->
either giveup return =<< go k f p either giveup return =<< go k p
(\sk -> TRANSFER Upload sk (fromOsPath f))
where where
go k f p = handleRequestKey external (\sk -> TRANSFER Upload sk f) k (Just p) $ \resp -> go k p mkreq = handleRequestKey external mkreq k (Just p) $ \resp ->
case resp of case resp of
TRANSFER_SUCCESS Upload k' | k == k' -> TRANSFER_SUCCESS Upload k' | k == k' ->
result (Right ()) result (Right ())
@ -251,7 +252,7 @@ retrieveKeyFileM :: External -> Retriever
retrieveKeyFileM external = fileRetriever $ \d k p -> retrieveKeyFileM external = fileRetriever $ \d k p ->
either giveup return =<< watchFileSize d p (go d k) either giveup return =<< watchFileSize d p (go d k)
where where
go d k p = handleRequestKey external (\sk -> TRANSFER Download sk (fromRawFilePath d)) k (Just p) $ \resp -> go d k p = handleRequestKey external (\sk -> TRANSFER Download sk (fromOsPath d)) k (Just p) $ \resp ->
case resp of case resp of
TRANSFER_SUCCESS Download k' TRANSFER_SUCCESS Download k'
| k == k' -> result $ Right () | k == k' -> result $ Right ()
@ -293,7 +294,7 @@ whereisKeyM external k = handleRequestKey external WHEREIS k Nothing $ \resp ->
UNSUPPORTED_REQUEST -> result [] UNSUPPORTED_REQUEST -> result []
_ -> Nothing _ -> Nothing
storeExportM :: External -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex () storeExportM :: External -> OsPath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
storeExportM external f k loc p = either giveup return =<< go storeExportM external f k loc p = either giveup return =<< go
where where
go = handleRequestExport external loc req k (Just p) $ \resp -> case resp of go = handleRequestExport external loc req k (Just p) $ \resp -> case resp of
@ -303,12 +304,12 @@ storeExportM external f k loc p = either giveup return =<< go
UNSUPPORTED_REQUEST -> UNSUPPORTED_REQUEST ->
result $ Left "TRANSFEREXPORT not implemented by external special remote" result $ Left "TRANSFEREXPORT not implemented by external special remote"
_ -> Nothing _ -> Nothing
req sk = TRANSFEREXPORT Upload sk f req sk = TRANSFEREXPORT Upload sk (fromOsPath f)
retrieveExportM :: External -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification retrieveExportM :: External -> Key -> ExportLocation -> OsPath -> MeterUpdate -> Annex Verification
retrieveExportM external k loc dest p = do retrieveExportM external k loc dest p = do
verifyKeyContentIncrementally AlwaysVerify k $ \iv -> verifyKeyContentIncrementally AlwaysVerify k $ \iv ->
tailVerify iv (toRawFilePath dest) $ tailVerify iv dest $
either giveup return =<< go either giveup return =<< go
where where
go = handleRequestExport external loc req k (Just p) $ \resp -> case resp of go = handleRequestExport external loc req k (Just p) $ \resp -> case resp of
@ -319,7 +320,7 @@ retrieveExportM external k loc dest p = do
UNSUPPORTED_REQUEST -> UNSUPPORTED_REQUEST ->
result $ Left "TRANSFEREXPORT not implemented by external special remote" result $ Left "TRANSFEREXPORT not implemented by external special remote"
_ -> Nothing _ -> Nothing
req sk = TRANSFEREXPORT Download sk dest req sk = TRANSFEREXPORT Download sk (fromOsPath dest)
checkPresentExportM :: External -> Key -> ExportLocation -> Annex Bool checkPresentExportM :: External -> Key -> ExportLocation -> Annex Bool
checkPresentExportM external k loc = either giveup id <$> go checkPresentExportM external k loc = either giveup id <$> go
@ -429,9 +430,9 @@ handleRequest' st external req mp responsehandler
handleRemoteRequest (PROGRESS bytesprocessed) = handleRemoteRequest (PROGRESS bytesprocessed) =
maybe noop (\a -> liftIO $ a bytesprocessed) mp maybe noop (\a -> liftIO $ a bytesprocessed) mp
handleRemoteRequest (DIRHASH k) = handleRemoteRequest (DIRHASH k) =
send $ VALUE $ fromRawFilePath $ hashDirMixed def k send $ VALUE $ fromOsPath $ hashDirMixed def k
handleRemoteRequest (DIRHASH_LOWER k) = handleRemoteRequest (DIRHASH_LOWER k) =
send $ VALUE $ fromRawFilePath $ hashDirLower def k send $ VALUE $ fromOsPath $ hashDirLower def k
handleRemoteRequest (SETCONFIG setting value) = handleRemoteRequest (SETCONFIG setting value) =
liftIO $ atomically $ do liftIO $ atomically $ do
ParsedRemoteConfig m c <- takeTMVar (externalConfig st) ParsedRemoteConfig m c <- takeTMVar (externalConfig st)
@ -480,7 +481,7 @@ handleRequest' st external req mp responsehandler
Just u -> send $ VALUE $ fromUUID u Just u -> send $ VALUE $ fromUUID u
Nothing -> senderror "cannot send GETUUID here" Nothing -> senderror "cannot send GETUUID here"
handleRemoteRequest GETGITDIR = handleRemoteRequest GETGITDIR =
send . VALUE . fromRawFilePath =<< fromRepo Git.localGitDir send . VALUE . fromOsPath =<< fromRepo Git.localGitDir
handleRemoteRequest GETGITREMOTENAME = handleRemoteRequest GETGITREMOTENAME =
case externalRemoteName external of case externalRemoteName external of
Just n -> send $ VALUE n Just n -> send $ VALUE n
@ -526,7 +527,7 @@ handleRequest' st external req mp responsehandler
senderror = sendMessage st . ERROR senderror = sendMessage st . ERROR
credstorage setting u = CredPairStorage credstorage setting u = CredPairStorage
{ credPairFile = base { credPairFile = toOsPath base
, credPairEnvironment = (base ++ "login", base ++ "password") , credPairEnvironment = (base ++ "login", base ++ "password")
, credPairRemoteField = Accepted setting , credPairRemoteField = Accepted setting
} }
@ -824,19 +825,19 @@ checkUrlM :: External -> URLString -> Annex UrlContents
checkUrlM external url = checkUrlM external url =
handleRequest external (CHECKURL url) Nothing $ \req -> case req of handleRequest external (CHECKURL url) Nothing $ \req -> case req of
CHECKURL_CONTENTS sz f -> result $ UrlContents sz $ CHECKURL_CONTENTS sz f -> result $ UrlContents sz $
if null f then Nothing else Just f if null f then Nothing else Just (toOsPath f)
CHECKURL_MULTI l -> result $ UrlMulti $ map mkmulti l CHECKURL_MULTI l -> result $ UrlMulti $ map mkmulti l
CHECKURL_FAILURE errmsg -> Just $ giveup $ CHECKURL_FAILURE errmsg -> Just $ giveup $
respErrorMessage "CHECKURL" errmsg respErrorMessage "CHECKURL" errmsg
UNSUPPORTED_REQUEST -> giveup "CHECKURL not implemented by external special remote" UNSUPPORTED_REQUEST -> giveup "CHECKURL not implemented by external special remote"
_ -> Nothing _ -> Nothing
where where
mkmulti (u, s, f) = (u, s, f) mkmulti (u, s, f) = (u, s, toOsPath f)
retrieveUrl :: Retriever retrieveUrl :: Retriever
retrieveUrl = fileRetriever' $ \f k p iv -> do retrieveUrl = fileRetriever' $ \f k p iv -> do
us <- getWebUrls k us <- getWebUrls k
unlessM (withUrlOptions $ downloadUrl True k p iv us (fromRawFilePath f)) $ unlessM (withUrlOptions $ downloadUrl True k p iv us f) $
giveup "failed to download content" giveup "failed to download content"
checkKeyUrl :: CheckPresent checkKeyUrl :: CheckPresent

6
Remote/Web.hs
View file

@ -116,7 +116,7 @@ setupInstance _ mu _ c _ = do
gitConfigSpecialRemote u c [("web", "true")] gitConfigSpecialRemote u c [("web", "true")]
return (c, u) return (c, u)
downloadKey :: UrlIncludeExclude -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> VerifyConfig -> Annex Verification downloadKey :: UrlIncludeExclude -> Key -> AssociatedFile -> OsPath -> MeterUpdate -> VerifyConfig -> Annex Verification
downloadKey urlincludeexclude key _af dest p vc = downloadKey urlincludeexclude key _af dest p vc =
go =<< getWebUrls' urlincludeexclude key go =<< getWebUrls' urlincludeexclude key
where where
@ -175,14 +175,14 @@ downloadKey urlincludeexclude key _af dest p vc =
let b = if isCryptographicallySecure db let b = if isCryptographicallySecure db
then db then db
else defaultHashBackend else defaultHashBackend
generateEquivilantKey b (toRawFilePath dest) >>= \case generateEquivilantKey b dest >>= \case
Nothing -> return Nothing Nothing -> return Nothing
Just ek -> do Just ek -> do
unless (ek `elem` eks) $ unless (ek `elem` eks) $
setEquivilantKey key ek setEquivilantKey key ek
return (Just Verified) return (Just Verified)
uploadKey :: Key -> AssociatedFile -> Maybe FilePath -> MeterUpdate -> Annex () uploadKey :: Key -> AssociatedFile -> Maybe OsPath -> MeterUpdate -> Annex ()
uploadKey _ _ _ _ = giveup "upload to web not supported" uploadKey _ _ _ _ = giveup "upload to web not supported"
dropKey :: UrlIncludeExclude -> Maybe SafeDropProof -> Key -> Annex () dropKey :: UrlIncludeExclude -> Maybe SafeDropProof -> Key -> Annex ()