From 55400a03d3d2e205cd40ecbafb4913c5a5a85322 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 2 Nov 2020 16:31:28 -0400 Subject: [PATCH] more RawFilePath conversion This commit was sponsored by Luke Shumaker on Patreon. --- Command/FuzzTest.hs | 8 ++++---- Command/Info.hs | 17 +++++++++-------- Command/Inprogress.hs | 2 +- Command/Lock.hs | 8 ++++---- Command/Log.hs | 7 ++++--- Command/Map.hs | 3 +-- Command/MetaData.hs | 4 ++-- Command/Multicast.hs | 10 +++++----- Command/ReKey.hs | 8 ++++---- Command/RecvKey.hs | 2 +- Command/Reinject.hs | 20 +++++++++++--------- Command/RmUrl.hs | 3 ++- Command/SetKey.hs | 6 +++--- Command/Smudge.hs | 21 ++++++++++----------- Command/Status.hs | 2 +- Command/TestRemote.hs | 14 +++++++------- Command/TransferInfo.hs | 5 +++-- Command/TransferKey.hs | 2 +- Command/TransferKeys.hs | 2 +- Git/Construct.hs | 3 ++- Git/Types.hs | 14 ++++++++++---- Test/Framework.hs | 9 +++++---- 22 files changed, 91 insertions(+), 79 deletions(-) diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs index c1c6d4cee1..bad58d14fe 100644 --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -174,7 +174,7 @@ instance Arbitrary FuzzAction where runFuzzAction :: FuzzAction -> Annex () runFuzzAction (FuzzAdd (FuzzFile f)) = do - createWorkTreeDirectory (parentDir f) + createWorkTreeDirectory (parentDir (toRawFilePath f)) n <- liftIO (getStdRandom random :: IO Int) liftIO $ writeFile f $ show n ++ "\n" runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $ @@ -209,7 +209,7 @@ genFuzzAction = do case md of Nothing -> genFuzzAction Just d -> do - newd <- liftIO $ newDir (parentDir $ toFilePath d) + newd <- liftIO $ newDir (parentDir $ toRawFilePath $ toFilePath d) maybe genFuzzAction (return . FuzzMoveDir d) newd FuzzDeleteDir _ -> do d <- liftIO existingDir @@ -261,13 +261,13 @@ newFile = go (100 :: Int) , go (n - 1) ) -newDir :: FilePath -> IO (Maybe FuzzDir) +newDir :: RawFilePath -> IO (Maybe FuzzDir) newDir parent = go (100 :: Int) where go 0 = return Nothing go n = do (FuzzDir d) <- genFuzzDir - ifM (doesnotexist (parent d)) + ifM (doesnotexist (fromRawFilePath parent d)) ( return $ Just $ FuzzDir d , go (n - 1) ) diff --git a/Command/Info.hs b/Command/Info.hs index 2e078cd887..2b330143b5 100644 --- a/Command/Info.hs +++ b/Command/Info.hs @@ -12,6 +12,7 @@ module Command.Info where import "mtl" Control.Monad.State.Strict import qualified Data.Map.Strict as M import qualified Data.Vector as V +import qualified System.FilePath.ByteString as P import Data.Ord import qualified Data.Semigroup as Sem import Prelude @@ -152,9 +153,9 @@ itemInfo o (si, p) = ifM (isdir p) case v' of Right u -> uuidInfo o u si Left _ -> do - relp <- liftIO $ relPathCwdToFile p - ifAnnexed (toRawFilePath relp) - (fileInfo o relp si) + relp <- liftIO $ relPathCwdToFile (toRawFilePath p) + ifAnnexed relp + (fileInfo o (fromRawFilePath relp) si) (treeishInfo o p si) ) where @@ -435,7 +436,7 @@ transfer_list = stat desc $ nojson $ lift $ do where desc = "transfers in progress" line uuidmap t i = unwords - [ formatDirection (transferDirection t) ++ "ing" + [ fromRawFilePath (formatDirection (transferDirection t)) ++ "ing" , fromRawFilePath $ actionItemDesc $ mkActionItem (transferKey t, associatedFile i) , if transferDirection t == Upload then "to" else "from" @@ -579,7 +580,7 @@ getDirStatInfo o dir = do then return (numcopiesstats, repodata) else do locs <- Remote.keyLocations key - nc <- updateNumCopiesStats (fromRawFilePath file) numcopiesstats locs + nc <- updateNumCopiesStats file numcopiesstats locs return (nc, updateRepoData key locs repodata) return $! (presentdata', referenceddata', numcopiesstats', repodata') , return vs @@ -643,7 +644,7 @@ updateRepoData key locs m = m' M.fromList $ zip locs (map update locs) update loc = addKey key (fromMaybe emptyKeyInfo $ M.lookup loc m) -updateNumCopiesStats :: FilePath -> NumCopiesStats -> [UUID] -> Annex NumCopiesStats +updateNumCopiesStats :: RawFilePath -> NumCopiesStats -> [UUID] -> Annex NumCopiesStats updateNumCopiesStats file (NumCopiesStats m) locs = do have <- trustExclude UnTrusted locs !variance <- Variance <$> numCopiesCheck' file (-) have @@ -663,7 +664,7 @@ showSizeKeys d = do "+ " ++ show (unknownSizeKeys d) ++ " unknown size" -staleSize :: String -> (Git.Repo -> FilePath) -> Stat +staleSize :: String -> (Git.Repo -> RawFilePath) -> Stat staleSize label dirspec = go =<< lift (dirKeys dirspec) where go [] = nostat @@ -676,7 +677,7 @@ staleSize label dirspec = go =<< lift (dirKeys dirspec) keysizes keys = do dir <- lift $ fromRepo dirspec liftIO $ forM keys $ \k -> catchDefaultIO 0 $ - getFileSize (dir fromRawFilePath (keyFile k)) + getFileSize (fromRawFilePath (dir P. keyFile k)) aside :: String -> String aside s = " (" ++ s ++ ")" diff --git a/Command/Inprogress.hs b/Command/Inprogress.hs index f08cdc7d80..f5414e8815 100644 --- a/Command/Inprogress.hs +++ b/Command/Inprogress.hs @@ -55,7 +55,7 @@ start s _si _file k start' :: Key -> CommandStart start' k = startingCustomOutput k $ do - tmpf <- fromRepo $ gitAnnexTmpObjectLocation k + tmpf <- fromRawFilePath <$> fromRepo (gitAnnexTmpObjectLocation k) whenM (liftIO $ doesFileExist tmpf) $ liftIO $ putStrLn tmpf next $ return True diff --git a/Command/Lock.hs b/Command/Lock.hs index 39798d8f1c..c084bc6e83 100644 --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -67,7 +67,7 @@ perform file key = do lockdown obj = do ifM (isUnmodified key obj) ( breakhardlink obj - , repopulate (fromRawFilePath obj) + , repopulate obj ) whenM (liftIO $ R.doesPathExist obj) $ freezeContent $ fromRawFilePath obj @@ -78,7 +78,7 @@ perform file key = do mfc <- withTSDelta (liftIO . genInodeCache file) unlessM (sameInodeCache obj (maybeToList mfc)) $ do let obj' = fromRawFilePath obj - modifyContent obj' $ replaceGitAnnexDirFile obj' $ \tmp -> do + modifyContent obj $ replaceGitAnnexDirFile obj' $ \tmp -> do unlessM (checkedCopyFile key obj' tmp Nothing) $ giveup "unable to lock file" Database.Keys.storeInodeCaches key [obj] @@ -89,10 +89,10 @@ perform file key = do fs <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key mfile <- firstM (isUnmodified key) fs - liftIO $ removeWhenExistsWith removeLink obj + liftIO $ removeWhenExistsWith R.removeLink obj case mfile of Just unmodified -> - unlessM (checkedCopyFile key (fromRawFilePath unmodified) obj Nothing) + unlessM (checkedCopyFile key (fromRawFilePath unmodified) (fromRawFilePath obj) Nothing) lostcontent Nothing -> lostcontent diff --git a/Command/Log.hs b/Command/Log.hs index db1c48bac8..b46749d9ba 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -12,6 +12,7 @@ import qualified Data.Map as M import Data.Char import Data.Time.Clock.POSIX import Data.Time +import qualified System.FilePath.ByteString as P import Command import Logs @@ -207,10 +208,10 @@ compareChanges format changes = concatMap diff changes getKeyLog :: Key -> [CommandParam] -> Annex ([RefChange], IO Bool) getKeyLog key os = do top <- fromRepo Git.repoPath - p <- liftIO $ relPathCwdToFile $ fromRawFilePath top + p <- liftIO $ relPathCwdToFile top config <- Annex.getGitConfig - let logfile = p fromRawFilePath (locationLogFile config key) - getGitLog [logfile] (Param "--remove-empty" : os) + let logfile = p P. locationLogFile config key + getGitLog [fromRawFilePath logfile] (Param "--remove-empty" : os) {- Streams the git log for all git-annex branch changes. -} getAllLog :: [CommandParam] -> Annex ([RefChange], IO Bool) diff --git a/Command/Map.hs b/Command/Map.hs index 0d0e923577..cafec0aab6 100644 --- a/Command/Map.hs +++ b/Command/Map.hs @@ -178,8 +178,7 @@ absRepo reference r | Git.repoIsUrl reference = return $ Git.Construct.localToUrl reference r | Git.repoIsUrl r = return r | otherwise = liftIO $ do - r' <- Git.Construct.fromAbsPath - =<< absPath (fromRawFilePath (Git.repoPath r)) + r' <- Git.Construct.fromAbsPath =<< absPath (Git.repoPath r) r'' <- safely $ flip Annex.eval Annex.gitRepo =<< Annex.new r' return (fromMaybe r' r'') diff --git a/Command/MetaData.hs b/Command/MetaData.hs index 730abf70bc..8fd980d345 100644 --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -165,8 +165,8 @@ parseJSONInput i = case eitherDecode (BU.fromString i) of (Just k, _) -> return $ Right (Right k, m) (Nothing, Just f) -> do - f' <- liftIO $ relPathCwdToFile f - return $ Right (Left (toRawFilePath f'), m) + f' <- liftIO $ relPathCwdToFile (toRawFilePath f) + return $ Right (Left f', m) (Nothing, Nothing) -> return $ Left "JSON input is missing either file or key" diff --git a/Command/Multicast.hs b/Command/Multicast.hs index c4ef2ce23e..bb423aea4e 100644 --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -83,7 +83,7 @@ genAddress = starting "gen-address" (ActionItemOther Nothing) (SeekInput []) $ d (s, ok) <- case k of KeyContainer s -> liftIO $ genkey (Param s) KeyFile f -> do - createAnnexDirectory (takeDirectory f) + createAnnexDirectory (toRawFilePath (takeDirectory f)) liftIO $ removeWhenExistsWith removeLink f liftIO $ protectedOutput $ genkey (File f) case (ok, parseFingerprint s) of @@ -176,8 +176,8 @@ receive ups = starting "receiving multicast files" ai si $ do (callback, environ, statush) <- liftIO multicastCallbackEnv tmpobjdir <- fromRepo gitAnnexTmpObjectDir createAnnexDirectory tmpobjdir - withTmpDirIn tmpobjdir "multicast" $ \tmpdir -> withAuthList $ \authlist -> do - abstmpdir <- liftIO $ absPath tmpdir + withTmpDirIn (fromRawFilePath tmpobjdir) "multicast" $ \tmpdir -> withAuthList $ \authlist -> do + abstmpdir <- liftIO $ absPath (toRawFilePath tmpdir) abscallback <- liftIO $ searchPath callback let ps = -- Avoid it running as a daemon. @@ -190,7 +190,7 @@ receive ups = starting "receiving multicast files" ai si $ do , Param "-S", Param authlist -- Receive files into tmpdir -- (it needs an absolute path) - , Param "-D", File abstmpdir + , Param "-D", File (fromRawFilePath abstmpdir) -- Run callback after each file received -- (it needs an absolute path) , Param "-s", Param (fromMaybe callback abscallback) @@ -214,7 +214,7 @@ storeReceived f = do Just k -> void $ getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k $ \dest -> unVerified $ liftIO $ catchBoolIO $ do - rename f dest + rename f (fromRawFilePath dest) return True -- Under Windows, uftp uses key containers, which are not files on the diff --git a/Command/ReKey.hs b/Command/ReKey.hs index d39b25ef65..6853507e10 100644 --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -47,8 +47,8 @@ batchParser s = case separate (== ' ') (reverse s) of Nothing -> return $ Left "bad key" Just k -> do let f = reverse rf - f' <- liftIO $ relPathCwdToFile f - return $ Right (toRawFilePath f', k) + f' <- liftIO $ relPathCwdToFile (toRawFilePath f) + return $ Right (f', k) seek :: ReKeyOptions -> CommandSeek seek o = case batchOption o of @@ -91,7 +91,7 @@ linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file) - unlocked file, which would leave the new key unlocked - and vulnerable to corruption. -} ( getViaTmpFromDisk RetrievalAllKeysSecure DefaultVerify newkey $ \tmp -> unVerified $ do - oldobj <- fromRawFilePath <$> calcRepo (gitAnnexLocation oldkey) + oldobj <- calcRepo (gitAnnexLocation oldkey) isJust <$> linkOrCopy' (return True) newkey oldobj tmp Nothing , do {- The file being rekeyed is itself an unlocked file; if @@ -111,7 +111,7 @@ linkKey file oldkey newkey = ifM (isJust <$> isAnnexLink file) warning (show e) return False Right () -> do - r <- linkToAnnex newkey (fromRawFilePath file) ic + r <- linkToAnnex newkey file ic return $ case r of LinkAnnexFailed -> False LinkAnnexOk -> True diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs index d431c5f91a..3455acc876 100644 --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -45,4 +45,4 @@ start (_, key) = fieldTransfer Download key $ \_p -> do go tmp = unVerified $ do opts <- filterRsyncSafeOptions . maybe [] words <$> getField "RsyncOptions" - liftIO $ rsyncServerReceive (map Param opts) tmp + liftIO $ rsyncServerReceive (map Param opts) (fromRawFilePath tmp) diff --git a/Command/Reinject.hs b/Command/Reinject.hs index dfc0bfb76c..a1e8327be1 100644 --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -43,11 +43,13 @@ seek os startSrcDest :: [FilePath] -> CommandStart startSrcDest ps@(src:dest:[]) | src == dest = stop - | otherwise = notAnnexed src $ ifAnnexed (toRawFilePath dest) go stop + | otherwise = notAnnexed src' $ + ifAnnexed (toRawFilePath dest) go stop where + src' = toRawFilePath src go key = starting "reinject" ai si $ ifM (verifyKeyContent RetrievalAllKeysSecure DefaultVerify UnVerified key src) - ( perform src key + ( perform src' key , giveup $ src ++ " does not have expected content of " ++ dest ) ai = ActionItemOther (Just src) @@ -55,31 +57,31 @@ startSrcDest ps@(src:dest:[]) startSrcDest _ = giveup "specify a src file and a dest file" startKnown :: FilePath -> CommandStart -startKnown src = notAnnexed src $ +startKnown src = notAnnexed src' $ starting "reinject" ai si $ do (key, _) <- genKey ks nullMeterUpdate Nothing ifM (isKnownKey key) - ( perform src key + ( perform src' key , do warning "Not known content; skipping" next $ return True ) where - ks = KeySource src' src' Nothing src' = toRawFilePath src + ks = KeySource src' src' Nothing ai = ActionItemOther (Just src) si = SeekInput [src] -notAnnexed :: FilePath -> CommandStart -> CommandStart +notAnnexed :: RawFilePath -> CommandStart -> CommandStart notAnnexed src a = ifM (fromRepo Git.repoIsLocalBare) ( a - , ifAnnexed (toRawFilePath src) - (giveup $ "cannot used annexed file as src: " ++ src) + , ifAnnexed src + (giveup $ "cannot used annexed file as src: " ++ fromRawFilePath src) a ) -perform :: FilePath -> Key -> CommandPerform +perform :: RawFilePath -> Key -> CommandPerform perform src key = ifM move ( next $ cleanup key , error "failed" diff --git a/Command/RmUrl.hs b/Command/RmUrl.hs index 3d5575ba15..507f1d0099 100644 --- a/Command/RmUrl.hs +++ b/Command/RmUrl.hs @@ -41,7 +41,8 @@ batchParser s = case separate (== ' ') (reverse s) of | null ru || null rf -> return $ Left "Expected: \"file url\"" | otherwise -> do let f = reverse rf - f' <- liftIO $ relPathCwdToFile f + f' <- liftIO $ fromRawFilePath + <$> relPathCwdToFile (toRawFilePath f) return $ Right (f', reverse ru) start :: (SeekInput, (FilePath, URLString)) -> CommandStart diff --git a/Command/SetKey.hs b/Command/SetKey.hs index 9138b1840b..859a5871e5 100644 --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -21,7 +21,7 @@ seek = withWords (commandAction . start) start :: [String] -> CommandStart start ps@(keyname:file:[]) = starting "setkey" ai si $ - perform file (keyOpt keyname) + perform (toRawFilePath file) (keyOpt keyname) where ai = ActionItemOther (Just file) si = SeekInput ps @@ -30,7 +30,7 @@ start _ = giveup "specify a key and a content file" keyOpt :: String -> Key keyOpt = fromMaybe (giveup "bad key") . deserializeKey -perform :: FilePath -> Key -> CommandPerform +perform :: RawFilePath -> Key -> CommandPerform perform file key = do -- the file might be on a different filesystem, so moveFile is used -- rather than simply calling moveAnnex; disk space is also @@ -38,7 +38,7 @@ perform file key = do ok <- getViaTmp RetrievalAllKeysSecure DefaultVerify key $ \dest -> unVerified $ if dest /= file then liftIO $ catchBoolIO $ do - moveFile file dest + moveFile (fromRawFilePath file) (fromRawFilePath dest) return True else return True if ok diff --git a/Command/Smudge.hs b/Command/Smudge.hs index 7d0d884c6c..436ec4c7ef 100644 --- a/Command/Smudge.hs +++ b/Command/Smudge.hs @@ -54,7 +54,7 @@ optParser desc = smudgeoptions <|> updateoption seek :: SmudgeOptions -> CommandSeek seek (SmudgeOptions f False) = commandAction (smudge f) -seek (SmudgeOptions f True) = commandAction (clean f) +seek (SmudgeOptions f True) = commandAction (clean (toRawFilePath f)) seek UpdateOption = commandAction update -- Smudge filter is fed git file content, and if it's a pointer to an @@ -83,7 +83,7 @@ smudge file = do -- Clean filter is fed file content on stdin, decides if a file -- should be stored in the annex, and outputs a pointer to its -- injested content if so. Otherwise, the original content. -clean :: FilePath -> CommandStart +clean :: RawFilePath -> CommandStart clean file = do b <- liftIO $ L.hGetContents stdin ifM fileoutsiderepo @@ -98,10 +98,10 @@ clean file = do where go b = case parseLinkTargetOrPointerLazy b of Just k -> do - getMoveRaceRecovery k (toRawFilePath file) + getMoveRaceRecovery k file liftIO $ L.hPut stdout b Nothing -> do - let fileref = Git.Ref.fileRef (toRawFilePath file) + let fileref = Git.Ref.fileRef file indexmeta <- catObjectMetaData fileref go' b indexmeta =<< catKey' fileref indexmeta go' b indexmeta oldkey = ifM (shouldAnnex file indexmeta oldkey) @@ -120,7 +120,7 @@ clean file = do -- annexed and is unmodified. case oldkey of Nothing -> doingest oldkey - Just ko -> ifM (isUnmodifiedCheap ko (toRawFilePath file)) + Just ko -> ifM (isUnmodifiedCheap ko file) ( liftIO $ emitPointer ko , doingest oldkey ) @@ -141,7 +141,7 @@ clean file = do liftIO . emitPointer =<< postingest =<< (\ld -> ingest' oldbackend nullMeterUpdate ld Nothing norestage) - =<< lockDown cfg file + =<< lockDown cfg (fromRawFilePath file) postingest (Just k, _) = do logStatus k InfoPresent @@ -156,8 +156,7 @@ clean file = do -- git diff can run the clean filter on files outside the -- repository; can't annex those fileoutsiderepo = do - repopath <- liftIO . absPath . fromRawFilePath - =<< fromRepo Git.repoPath + repopath <- liftIO . absPath =<< fromRepo Git.repoPath filepath <- liftIO $ absPath file return $ not $ dirContains repopath filepath @@ -175,7 +174,7 @@ clean file = do -- annexed content before, annex it. This handles cases such as renaming an -- unlocked annexed file followed by git add, which the user naturally -- expects to behave the same as git mv. -shouldAnnex :: FilePath -> Maybe (Sha, FileSize, ObjectType) -> Maybe Key -> Annex Bool +shouldAnnex :: RawFilePath -> Maybe (Sha, FileSize, ObjectType) -> Maybe Key -> Annex Bool shouldAnnex file indexmeta moldkey = ifM (annexGitAddToAnnex <$> Annex.getGitConfig) ( checkunchangedgitfile $ checkmatcher checkheuristics , checkunchangedgitfile checkheuristics @@ -196,7 +195,7 @@ shouldAnnex file indexmeta moldkey = ifM (annexGitAddToAnnex <$> Annex.getGitCon Just _ -> return True Nothing -> checkknowninode - checkknowninode = withTSDelta (liftIO . genInodeCache (toRawFilePath file)) >>= \case + checkknowninode = withTSDelta (liftIO . genInodeCache file) >>= \case Nothing -> pure False Just ic -> Database.Keys.isInodeKnown ic =<< sentinalStatus @@ -208,7 +207,7 @@ shouldAnnex file indexmeta moldkey = ifM (annexGitAddToAnnex <$> Annex.getGitCon -- annex.largefiles now matches it, because the content is not -- changed. checkunchangedgitfile cont = case (moldkey, indexmeta) of - (Nothing, Just (sha, sz, _)) -> liftIO (catchMaybeIO (getFileSize file)) >>= \case + (Nothing, Just (sha, sz, _)) -> liftIO (catchMaybeIO (getFileSize (fromRawFilePath file))) >>= \case Just sz' | sz' == sz -> do -- The size is the same, so the file -- is not much larger than what was stored diff --git a/Command/Status.hs b/Command/Status.hs index 82c48e2b75..2925e6332e 100644 --- a/Command/Status.hs +++ b/Command/Status.hs @@ -61,6 +61,6 @@ displayStatus (Renamed _ _) = noop displayStatus s = do let c = statusChar s absf <- fromRepo $ fromTopFilePath (statusFile s) - f <- liftIO $ relPathCwdToFile $ fromRawFilePath absf + f <- liftIO $ fromRawFilePath <$> relPathCwdToFile absf unlessM (showFullJSON $ JSONChunk [("status", [c]), ("file", f)]) $ liftIO $ putStrLn $ [c] ++ " " ++ f diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs index a07ab67b3c..44be49f8b0 100644 --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -251,7 +251,7 @@ test runannex mkr mkk = , check "fsck downloaded object" fsck , check "retrieveKeyFile resume from 33%" $ \r k -> do loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) - tmp <- prepTmp k + tmp <- fromRawFilePath <$> prepTmp k partial <- liftIO $ bracket (openBinaryFile loc ReadMode) hClose $ \h -> do sz <- hFileSize h L.hGet h $ fromInteger $ sz `div` 3 @@ -260,14 +260,14 @@ test runannex mkr mkk = get r k , check "fsck downloaded object" fsck , check "retrieveKeyFile resume from 0" $ \r k -> do - tmp <- prepTmp k + tmp <- fromRawFilePath <$> prepTmp k liftIO $ writeFile tmp "" lockContentForRemoval k noop removeAnnex get r k , check "fsck downloaded object" fsck , check "retrieveKeyFile resume from end" $ \r k -> do loc <- fromRawFilePath <$> Annex.calcRepo (gitAnnexLocation k) - tmp <- prepTmp k + tmp <- fromRawFilePath <$> prepTmp k void $ liftIO $ copyFileExternal CopyAllMetaData loc tmp lockContentForRemoval k noop removeAnnex get r k @@ -295,7 +295,7 @@ test runannex mkr mkk = Nothing -> return True Just verifier -> verifier k (serializeKey k) get r k = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> - tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) dest nullMeterUpdate) >>= \case + tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate) >>= \case Right v -> return (True, v) Left _ -> return (False, UnVerified) store r k = Remote.storeKey r k (AssociatedFile Nothing) nullMeterUpdate @@ -369,14 +369,14 @@ testUnavailable runannex mkr mkk = Remote.checkPresent r k , check (== Right False) "retrieveKeyFile" $ \r k -> getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> - tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) dest nullMeterUpdate) >>= \case + tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate) >>= \case Right v -> return (True, v) Left _ -> return (False, UnVerified) , check (== Right False) "retrieveKeyFileCheap" $ \r k -> case Remote.retrieveKeyFileCheap r of Nothing -> return False Just a -> getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k $ \dest -> unVerified $ isRight - <$> tryNonAsync (a k (AssociatedFile Nothing) dest) + <$> tryNonAsync (a k (AssociatedFile Nothing) (fromRawFilePath dest)) ] where check checkval desc a = testCase desc $ @@ -436,7 +436,7 @@ randKey sz = withTmpFile "randkey" $ \f h -> do k <- case Types.Backend.genKey Backend.Hash.testKeyBackend of Just a -> a ks nullMeterUpdate Nothing -> giveup "failed to generate random key (backend problem)" - _ <- moveAnnex k f + _ <- moveAnnex k (toRawFilePath f) return k getReadonlyKey :: Remote -> FilePath -> Annex Key diff --git a/Command/TransferInfo.hs b/Command/TransferInfo.hs index 402f1ef8ec..2df9fa92fc 100644 --- a/Command/TransferInfo.hs +++ b/Command/TransferInfo.hs @@ -11,9 +11,10 @@ import Command import Annex.Content import Types.Transfer import Logs.Transfer -import qualified CmdLine.GitAnnexShell.Fields as Fields import Utility.Metered import Utility.SimpleProtocol +import qualified CmdLine.GitAnnexShell.Fields as Fields +import qualified Utility.RawFilePath as R cmd :: Command cmd = noCommit $ @@ -58,7 +59,7 @@ start (k:[]) = do bytes <- readUpdate maybe (error "transferinfo protocol error") (update . toBytesProcessed) bytes - , tryIO $ removeFile tfile + , tryIO $ R.removeLink tfile , exitSuccess ] stop diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs index fe2e0f8238..43f0eb254f 100644 --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -64,7 +64,7 @@ fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform fromPerform key file remote = go Upload file $ download (uuid remote) key file stdRetry $ \p -> getViaTmp (retrievalSecurityPolicy remote) (RemoteVerify remote) key $ \t -> - tryNonAsync (Remote.retrieveKeyFile remote key file t p) >>= \case + tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case Right v -> return (True, v) Left e -> do warning (show e) diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs index 8370950096..4d13f3d28f 100644 --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -48,7 +48,7 @@ start = do | otherwise = notifyTransfer direction file $ download (Remote.uuid remote) key file stdRetry $ \p -> getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key $ \t -> do - r <- tryNonAsync (Remote.retrieveKeyFile remote key file t p) >>= \case + r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case Left e -> do warning (show e) return (False, UnVerified) diff --git a/Git/Construct.hs b/Git/Construct.hs index e2a36f5035..4ca8db2b94 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -134,7 +134,8 @@ fromRemotes repo = mapM construct remotepairs filterconfig f = filter f $ M.toList $ config repo filterkeys f = filterconfig (\(k,_) -> f k) remotepairs = filterkeys isRemoteKey - construct (k,v) = remoteNamedFromKey k (fromRemoteLocation (fromConfigValue v) repo) + construct (k,v) = remoteNamedFromKey k $ + fromRemoteLocation (fromConfigValue v) repo {- Sets the name of a remote when constructing the Repo to represent it. -} remoteNamed :: String -> IO Repo -> IO Repo diff --git a/Git/Types.hs b/Git/Types.hs index 4bf61e5670..77a52d1e45 100644 --- a/Git/Types.hs +++ b/Git/Types.hs @@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} module Git.Types where @@ -79,9 +79,15 @@ fromConfigKey (ConfigKey s) = decodeBS' s instance Show ConfigKey where show = fromConfigKey -fromConfigValue :: ConfigValue -> String -fromConfigValue (ConfigValue s) = decodeBS' s -fromConfigValue NoConfigValue = mempty +class FromConfigValue a where + fromConfigValue :: ConfigValue -> a + +instance FromConfigValue S.ByteString where + fromConfigValue (ConfigValue s) = s + fromConfigValue NoConfigValue = mempty + +instance FromConfigValue String where + fromConfigValue = decodeBS' . fromConfigValue instance Show ConfigValue where show = fromConfigValue diff --git a/Test/Framework.hs b/Test/Framework.hs index ce7f482d06..c369daf5e2 100644 --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -93,8 +93,9 @@ with_ssh_origin :: (Assertion -> Assertion) -> (Assertion -> Assertion) with_ssh_origin cloner a = cloner $ do let k = Git.Types.ConfigKey (encodeBS' config) let v = Git.Types.ConfigValue (toRawFilePath "/dev/null") - origindir <- absPath . Git.Types.fromConfigValue =<< annexeval (Config.getConfig k v) - let originurl = "localhost:" ++ origindir + origindir <- absPath . Git.Types.fromConfigValue + =<< annexeval (Config.getConfig k v) + let originurl = "localhost:" ++ fromRawFilePath origindir boolSystem "git" [Param "config", Param config, Param originurl] @? "git config failed" a where @@ -105,7 +106,7 @@ intmpclonerepo a = withtmpclonerepo $ \r -> indir r a checkRepo :: Types.Annex a -> FilePath -> IO a checkRepo getval d = do - s <- Annex.new =<< Git.Construct.fromPath d + s <- Annex.new =<< Git.Construct.fromPath (toRawFilePath d) Annex.eval s $ getval `finally` Annex.Action.stopCoProcesses @@ -223,7 +224,7 @@ ensuretmpdir = do {- Prevent global git configs from affecting the test suite. -} isolateGitConfig :: IO a -> IO a isolateGitConfig a = Utility.Tmp.Dir.withTmpDir "testhome" $ \tmphome -> do - tmphomeabs <- absPath tmphome + tmphomeabs <- fromRawFilePath <$> absPath (toRawFilePath tmphome) Utility.Env.Set.setEnv "HOME" tmphomeabs True Utility.Env.Set.setEnv "XDG_CONFIG_HOME" tmphomeabs True Utility.Env.Set.setEnv "GIT_CONFIG_NOSYSTEM" "1" True -- 2.30.2