bring back OsPath changes
I hope that the windows test suite failure on appveyor was fixed by updating to a newer windows there. I have not been able to reproduce that failure in a windows 11 VM run locally.
This commit is contained in:
Joey Hess
parent
f0ab439c95
commit
84291b6014
119 changed files with 1003 additions and 647 deletions
|
|
@ -70,6 +70,7 @@ import Logs.View (is_branchView)
|
|||
import Logs.AdjustedBranchUpdate
|
||||
import Utility.FileMode
|
||||
import qualified Utility.RawFilePath as R
|
||||
import qualified Utility.FileIO as F
|
||||
|
||||
import Data.Time.Clock.POSIX
|
||||
import qualified Data.Map as M
|
||||
|
|
@ -268,7 +269,7 @@ updateAdjustedBranch adj (AdjBranch currbranch) origbranch
|
|||
-- origbranch.
|
||||
_ <- propigateAdjustedCommits' True origbranch adj commitlck
|
||||
|
||||
origheadfile <- inRepo $ readFileStrict . Git.Ref.headFile
|
||||
origheadfile <- inRepo $ F.readFile' . toOsPath . Git.Ref.headFile
|
||||
origheadsha <- inRepo (Git.Ref.sha currbranch)
|
||||
|
||||
b <- adjustBranch adj origbranch
|
||||
|
|
@ -280,8 +281,8 @@ updateAdjustedBranch adj (AdjBranch currbranch) origbranch
|
|||
newheadfile <- case origheadsha of
|
||||
Just s -> do
|
||||
inRepo $ \r -> do
|
||||
let newheadfile = fromRef s
|
||||
writeFile (Git.Ref.headFile r) newheadfile
|
||||
let newheadfile = fromRef' s
|
||||
F.writeFile' (toOsPath (Git.Ref.headFile r)) newheadfile
|
||||
return (Just newheadfile)
|
||||
_ -> return Nothing
|
||||
|
||||
|
|
@ -295,9 +296,9 @@ updateAdjustedBranch adj (AdjBranch currbranch) origbranch
|
|||
unless ok $ case newheadfile of
|
||||
Nothing -> noop
|
||||
Just v -> preventCommits $ \_commitlck -> inRepo $ \r -> do
|
||||
v' <- readFileStrict (Git.Ref.headFile r)
|
||||
v' <- F.readFile' (toOsPath (Git.Ref.headFile r))
|
||||
when (v == v') $
|
||||
writeFile (Git.Ref.headFile r) origheadfile
|
||||
F.writeFile' (toOsPath (Git.Ref.headFile r)) origheadfile
|
||||
|
||||
return ok
|
||||
| otherwise = preventCommits $ \commitlck -> do
|
||||
|
|
|
|||
|
|
@ -29,8 +29,9 @@ import Annex.GitOverlay
|
|||
import Utility.Tmp.Dir
|
||||
import Utility.CopyFile
|
||||
import Utility.Directory.Create
|
||||
import qualified Utility.RawFilePath as R
|
||||
import qualified Utility.FileIO as F
|
||||
|
||||
import qualified Data.ByteString as S
|
||||
import qualified System.FilePath.ByteString as P
|
||||
|
||||
canMergeToAdjustedBranch :: Branch -> (OrigBranch, Adjustment) -> Annex Bool
|
||||
|
|
@ -72,26 +73,25 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm
|
|||
-}
|
||||
changestomerge (Just updatedorig) = withOtherTmp $ \othertmpdir -> do
|
||||
git_dir <- fromRepo Git.localGitDir
|
||||
let git_dir' = fromRawFilePath git_dir
|
||||
tmpwt <- fromRepo gitAnnexMergeDir
|
||||
withTmpDirIn (fromRawFilePath othertmpdir) "git" $ \tmpgit -> withWorkTreeRelated tmpgit $
|
||||
withTmpDirIn (fromRawFilePath othertmpdir) (toOsPath "git") $ \tmpgit -> withWorkTreeRelated tmpgit $
|
||||
withemptydir git_dir tmpwt $ withWorkTree tmpwt $ do
|
||||
let tmpgit' = toRawFilePath tmpgit
|
||||
liftIO $ writeFile (tmpgit </> "HEAD") (fromRef updatedorig)
|
||||
-- Copy in refs and packed-refs, to work
|
||||
-- around bug in git 2.13.0, which
|
||||
-- causes it not to look in GIT_DIR for refs.
|
||||
refs <- liftIO $ emptyWhenDoesNotExist $
|
||||
dirContentsRecursive $
|
||||
git_dir' </> "refs"
|
||||
let refs' = (git_dir' </> "packed-refs") : refs
|
||||
git_dir P.</> "refs"
|
||||
let refs' = (git_dir P.</> "packed-refs") : refs
|
||||
liftIO $ forM_ refs' $ \src -> do
|
||||
let src' = toRawFilePath src
|
||||
whenM (doesFileExist src) $ do
|
||||
dest <- relPathDirToFile git_dir src'
|
||||
let dest' = toRawFilePath tmpgit P.</> dest
|
||||
whenM (R.doesPathExist src) $ do
|
||||
dest <- relPathDirToFile git_dir src
|
||||
let dest' = tmpgit' P.</> dest
|
||||
createDirectoryUnder [git_dir]
|
||||
(P.takeDirectory dest')
|
||||
void $ createLinkOrCopy src' dest'
|
||||
void $ createLinkOrCopy src dest'
|
||||
-- This reset makes git merge not care
|
||||
-- that the work tree is empty; otherwise
|
||||
-- it will think that all the files have
|
||||
|
|
@ -107,7 +107,7 @@ mergeToAdjustedBranch tomerge (origbranch, adj) mergeconfig canresolvemerge comm
|
|||
if merged
|
||||
then do
|
||||
!mergecommit <- liftIO $ extractSha
|
||||
<$> S.readFile (tmpgit </> "HEAD")
|
||||
<$> F.readFile' (toOsPath (tmpgit' P.</> "HEAD"))
|
||||
-- This is run after the commit lock is dropped.
|
||||
return $ postmerge mergecommit
|
||||
else return $ return False
|
||||
|
|
|
|||
|
|
@ -35,10 +35,10 @@ import Annex.InodeSentinal
|
|||
import Utility.InodeCache
|
||||
import Utility.FileMode
|
||||
import qualified Utility.RawFilePath as R
|
||||
import qualified Utility.FileIO as F
|
||||
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import System.PosixCompat.Files (isSymbolicLink)
|
||||
|
||||
{- Merges from a branch into the current branch (which may not exist yet),
|
||||
|
|
@ -236,8 +236,9 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
|
|||
| otherwise = pure f
|
||||
|
||||
makesymlink key dest = do
|
||||
l <- calcRepo $ gitAnnexLink (toRawFilePath dest) key
|
||||
unless inoverlay $ replacewithsymlink dest l
|
||||
let rdest = toRawFilePath dest
|
||||
l <- calcRepo $ gitAnnexLink rdest key
|
||||
unless inoverlay $ replacewithsymlink rdest l
|
||||
dest' <- toRawFilePath <$> stagefile dest
|
||||
stageSymlink dest' =<< hashSymlink l
|
||||
|
||||
|
|
@ -265,9 +266,9 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
|
|||
|
||||
let replacefile isexecutable = case selectwant' (LsFiles.unmergedSha u) of
|
||||
Nothing -> noop
|
||||
Just sha -> replaceWorkTreeFile item $ \tmp -> do
|
||||
Just sha -> replaceWorkTreeFile (toRawFilePath item) $ \tmp -> do
|
||||
c <- catObject sha
|
||||
liftIO $ L.writeFile (decodeBS tmp) c
|
||||
liftIO $ F.writeFile (toOsPath tmp) c
|
||||
when isexecutable $
|
||||
liftIO $ void $ tryIO $
|
||||
modifyFileMode tmp $
|
||||
|
|
@ -280,7 +281,7 @@ resolveMerge' unstagedmap (Just us) them inoverlay u = do
|
|||
Nothing -> noop
|
||||
Just sha -> do
|
||||
link <- catSymLinkTarget sha
|
||||
replacewithsymlink item link
|
||||
replacewithsymlink (toRawFilePath item) link
|
||||
(Just TreeFile, Just TreeSymlink) -> replacefile False
|
||||
(Just TreeExecutable, Just TreeSymlink) -> replacefile True
|
||||
_ -> ifM (liftIO $ doesDirectoryExist item)
|
||||
|
|
|
|||
|
|
@ -11,11 +11,12 @@ import Key
|
|||
import Types.UUID
|
||||
import Utility.Hash
|
||||
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.Bits (shiftL)
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.ByteArray as BA
|
||||
import Data.List
|
||||
import Prelude
|
||||
|
||||
-- The Int is how many UUIDs to pick.
|
||||
type BalancedPicker = S.Set UUID -> Key -> Int -> [UUID]
|
||||
|
|
|
|||
|
|
@ -96,6 +96,7 @@ import Annex.Hook
|
|||
import Utility.Directory.Stream
|
||||
import Utility.Tmp
|
||||
import qualified Utility.RawFilePath as R
|
||||
import qualified Utility.FileIO as F
|
||||
|
||||
{- Name of the branch that is used to store git-annex's information. -}
|
||||
name :: Git.Ref
|
||||
|
|
@ -711,9 +712,9 @@ forceUpdateIndex jl branchref = do
|
|||
{- Checks if the index needs to be updated. -}
|
||||
needUpdateIndex :: Git.Ref -> Annex Bool
|
||||
needUpdateIndex branchref = do
|
||||
f <- fromRawFilePath <$> fromRepo gitAnnexIndexStatus
|
||||
f <- toOsPath <$> fromRepo gitAnnexIndexStatus
|
||||
committedref <- Git.Ref . firstLine' <$>
|
||||
liftIO (catchDefaultIO mempty $ B.readFile f)
|
||||
liftIO (catchDefaultIO mempty $ F.readFile' f)
|
||||
return (committedref /= branchref)
|
||||
|
||||
{- Record that the branch's index has been updated to correspond to a
|
||||
|
|
@ -741,7 +742,7 @@ stageJournal jl commitindex = withIndex $ withOtherTmp $ \tmpdir -> do
|
|||
g <- gitRepo
|
||||
st <- getState
|
||||
let dir = gitAnnexJournalDir st g
|
||||
(jlogf, jlogh) <- openjlog (fromRawFilePath tmpdir)
|
||||
(jlogf, jlogh) <- openjlog tmpdir
|
||||
withHashObjectHandle $ \h ->
|
||||
withJournalHandle gitAnnexJournalDir $ \jh ->
|
||||
Git.UpdateIndex.streamUpdateIndex g
|
||||
|
|
@ -752,12 +753,12 @@ stageJournal jl commitindex = withIndex $ withOtherTmp $ \tmpdir -> do
|
|||
genstream dir h jh jlogh streamer = readDirectory jh >>= \case
|
||||
Nothing -> return ()
|
||||
Just file -> do
|
||||
let path = dir P.</> toRawFilePath file
|
||||
let path = dir P.</> file
|
||||
unless (dirCruft file) $ whenM (isfile path) $ do
|
||||
sha <- Git.HashObject.hashFile h path
|
||||
hPutStrLn jlogh file
|
||||
B.hPutStr jlogh (file <> "\n")
|
||||
streamer $ Git.UpdateIndex.updateIndexLine
|
||||
sha TreeFile (asTopFilePath $ fileJournal $ toRawFilePath file)
|
||||
sha TreeFile (asTopFilePath $ fileJournal file)
|
||||
genstream dir h jh jlogh streamer
|
||||
isfile file = isRegularFile <$> R.getFileStatus file
|
||||
-- Clean up the staged files, as listed in the temp log file.
|
||||
|
|
@ -769,8 +770,8 @@ stageJournal jl commitindex = withIndex $ withOtherTmp $ \tmpdir -> do
|
|||
stagedfs <- lines <$> hGetContents jlogh
|
||||
mapM_ (removeFile . (dir </>)) stagedfs
|
||||
hClose jlogh
|
||||
removeWhenExistsWith (R.removeLink) (toRawFilePath jlogf)
|
||||
openjlog tmpdir = liftIO $ openTmpFileIn tmpdir "jlog"
|
||||
removeWhenExistsWith (R.removeLink) (fromOsPath jlogf)
|
||||
openjlog tmpdir = liftIO $ openTmpFileIn (toOsPath tmpdir) (toOsPath "jlog")
|
||||
|
||||
getLocalTransitions :: Annex Transitions
|
||||
getLocalTransitions =
|
||||
|
|
@ -931,8 +932,8 @@ getIgnoredRefs =
|
|||
S.fromList . mapMaybe Git.Sha.extractSha . fileLines' <$> content
|
||||
where
|
||||
content = do
|
||||
f <- fromRawFilePath <$> fromRepo gitAnnexIgnoredRefs
|
||||
liftIO $ catchDefaultIO mempty $ B.readFile f
|
||||
f <- toOsPath <$> fromRepo gitAnnexIgnoredRefs
|
||||
liftIO $ catchDefaultIO mempty $ F.readFile' f
|
||||
|
||||
addMergedRefs :: [(Git.Sha, Git.Branch)] -> Annex ()
|
||||
addMergedRefs [] = return ()
|
||||
|
|
@ -949,8 +950,8 @@ getMergedRefs = S.fromList . map fst <$> getMergedRefs'
|
|||
|
||||
getMergedRefs' :: Annex [(Git.Sha, Git.Branch)]
|
||||
getMergedRefs' = do
|
||||
f <- fromRawFilePath <$> fromRepo gitAnnexMergedRefs
|
||||
s <- liftIO $ catchDefaultIO mempty $ B.readFile f
|
||||
f <- toOsPath <$> fromRepo gitAnnexMergedRefs
|
||||
s <- liftIO $ catchDefaultIO mempty $ F.readFile' f
|
||||
return $ map parse $ fileLines' s
|
||||
where
|
||||
parse l =
|
||||
|
|
|
|||
|
|
@ -23,11 +23,11 @@ import Utility.Directory.Create
|
|||
import qualified Git
|
||||
import Git.Sha
|
||||
import qualified Utility.SimpleProtocol as Proto
|
||||
import qualified Utility.FileIO as F
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Concurrent.STM
|
||||
import Control.Concurrent.STM.TBMChan
|
||||
import qualified Data.ByteString as S
|
||||
import qualified System.FilePath.ByteString as P
|
||||
|
||||
newtype ChangedRefs = ChangedRefs [Git.Ref]
|
||||
|
|
@ -104,7 +104,7 @@ notifyHook chan reffile _
|
|||
| ".lock" `isSuffixOf` reffile = noop
|
||||
| otherwise = void $ do
|
||||
sha <- catchDefaultIO Nothing $
|
||||
extractSha <$> S.readFile reffile
|
||||
extractSha <$> F.readFile' (toOsPath (toRawFilePath reffile))
|
||||
-- When the channel is full, there is probably no reader
|
||||
-- running, or ref changes have been occurring very fast,
|
||||
-- so it's ok to not write the change to it.
|
||||
|
|
|
|||
|
|
@ -108,6 +108,7 @@ import Utility.HumanTime
|
|||
import Utility.TimeStamp
|
||||
import Utility.FileMode
|
||||
import qualified Utility.RawFilePath as R
|
||||
import qualified Utility.FileIO as F
|
||||
|
||||
import qualified System.FilePath.ByteString as P
|
||||
import System.PosixCompat.Files (isSymbolicLink, linkCount)
|
||||
|
|
@ -581,7 +582,7 @@ linkToAnnex key src srcic = ifM (checkSecureHashes' key)
|
|||
-}
|
||||
linkFromAnnex :: Key -> RawFilePath -> Maybe FileMode -> Annex LinkAnnexResult
|
||||
linkFromAnnex key dest destmode =
|
||||
replaceFile' (const noop) (fromRawFilePath dest) (== LinkAnnexOk) $ \tmp ->
|
||||
replaceFile' (const noop) dest (== LinkAnnexOk) $ \tmp ->
|
||||
linkFromAnnex' key tmp destmode
|
||||
|
||||
{- This is only safe to use when dest is not a worktree file. -}
|
||||
|
|
@ -817,7 +818,7 @@ listKeys' keyloc want = do
|
|||
s <- Annex.getState id
|
||||
r <- Annex.getRead id
|
||||
depth <- gitAnnexLocationDepth <$> Annex.getGitConfig
|
||||
liftIO $ walk (s, r) depth (fromRawFilePath dir)
|
||||
liftIO $ walk (s, r) depth dir
|
||||
where
|
||||
walk s depth dir = do
|
||||
contents <- catchDefaultIO [] (dirContents dir)
|
||||
|
|
@ -825,7 +826,7 @@ listKeys' keyloc want = do
|
|||
then do
|
||||
contents' <- filterM present contents
|
||||
keys <- filterM (Annex.eval s . want) $
|
||||
mapMaybe (fileKey . P.takeFileName . toRawFilePath) contents'
|
||||
mapMaybe (fileKey . P.takeFileName) contents'
|
||||
continue keys []
|
||||
else do
|
||||
let deeper = walk s (depth - 1)
|
||||
|
|
@ -843,8 +844,8 @@ listKeys' keyloc want = do
|
|||
present _ | inanywhere = pure True
|
||||
present d = presentInAnnex d
|
||||
|
||||
presentInAnnex = doesFileExist . contentfile
|
||||
contentfile d = d </> takeFileName d
|
||||
presentInAnnex = R.doesPathExist . contentfile
|
||||
contentfile d = d P.</> P.takeFileName d
|
||||
|
||||
{- Things to do to record changes to content when shutting down.
|
||||
-
|
||||
|
|
@ -1076,7 +1077,7 @@ writeContentRetentionTimestamp key rt t = do
|
|||
modifyContentDirWhenExists lckfile $ bracket (lock lckfile) unlock $ \_ ->
|
||||
readContentRetentionTimestamp rt >>= \case
|
||||
Just ts | ts >= t -> return ()
|
||||
_ -> replaceFile (const noop) (fromRawFilePath rt) $ \tmp ->
|
||||
_ -> replaceFile (const noop) rt $ \tmp ->
|
||||
liftIO $ writeFile (fromRawFilePath tmp) $ show t
|
||||
where
|
||||
lock = takeExclusiveLock
|
||||
|
|
@ -1086,7 +1087,7 @@ writeContentRetentionTimestamp key rt t = do
|
|||
readContentRetentionTimestamp :: RawFilePath -> Annex (Maybe POSIXTime)
|
||||
readContentRetentionTimestamp rt =
|
||||
liftIO $ join <$> tryWhenExists
|
||||
(parsePOSIXTime <$> readFile (fromRawFilePath rt))
|
||||
(parsePOSIXTime <$> F.readFile' (toOsPath rt))
|
||||
|
||||
{- Checks if the retention timestamp is in the future, if so returns
|
||||
- Nothing.
|
||||
|
|
|
|||
|
|
@ -34,10 +34,9 @@ populatePointerFile :: Restage -> Key -> RawFilePath -> RawFilePath -> Annex (Ma
|
|||
populatePointerFile restage k obj f = go =<< liftIO (isPointerFile f)
|
||||
where
|
||||
go (Just k') | k == k' = do
|
||||
let f' = fromRawFilePath f
|
||||
destmode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus f
|
||||
liftIO $ removeWhenExistsWith R.removeLink f
|
||||
(ic, populated) <- replaceWorkTreeFile f' $ \tmp -> do
|
||||
(ic, populated) <- replaceWorkTreeFile f $ \tmp -> do
|
||||
ok <- linkOrCopy k obj tmp destmode >>= \case
|
||||
Just _ -> thawContent tmp >> return True
|
||||
Nothing -> liftIO (writePointerFile tmp k destmode) >> return False
|
||||
|
|
@ -58,7 +57,7 @@ depopulatePointerFile key file = do
|
|||
let mode = fmap fileMode st
|
||||
secureErase file
|
||||
liftIO $ removeWhenExistsWith R.removeLink file
|
||||
ic <- replaceWorkTreeFile (fromRawFilePath file) $ \tmp -> do
|
||||
ic <- replaceWorkTreeFile file $ \tmp -> do
|
||||
liftIO $ writePointerFile tmp key mode
|
||||
#if ! defined(mingw32_HOST_OS)
|
||||
-- Don't advance mtime; this avoids unnecessary re-smudging
|
||||
|
|
|
|||
|
|
@ -19,6 +19,7 @@ import Utility.Directory
|
|||
import Utility.Exception
|
||||
import Utility.Monad
|
||||
import Utility.FileSystemEncoding
|
||||
import Utility.SystemDirectory
|
||||
import qualified Utility.RawFilePath as R
|
||||
import Utility.PartialPrelude
|
||||
|
||||
|
|
|
|||
|
|
@ -9,6 +9,8 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Annex.Hook where
|
||||
|
||||
import Annex.Common
|
||||
|
|
@ -85,7 +87,8 @@ hookWarning :: Git.Hook -> String -> Annex ()
|
|||
hookWarning h msg = do
|
||||
r <- gitRepo
|
||||
warning $ UnquotedString $
|
||||
Git.hookName h ++ " hook (" ++ Git.hookFile h r ++ ") " ++ msg
|
||||
fromRawFilePath (Git.hookName h) ++
|
||||
" hook (" ++ fromRawFilePath (Git.hookFile h r) ++ ") " ++ msg
|
||||
|
||||
{- To avoid checking if the hook exists every time, the existing hooks
|
||||
- are cached. -}
|
||||
|
|
@ -118,7 +121,7 @@ runAnnexHook' hook commandcfg = ifM (doesAnnexHookExist hook)
|
|||
( return Nothing
|
||||
, do
|
||||
h <- fromRepo (Git.hookFile hook)
|
||||
commandfailed h
|
||||
commandfailed (fromRawFilePath h)
|
||||
)
|
||||
runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case
|
||||
Nothing -> return Nothing
|
||||
|
|
|
|||
|
|
@ -118,20 +118,21 @@ lockDown' cfg file = tryNonAsync $ ifM crippledFileSystem
|
|||
withhardlink tmpdir = do
|
||||
setperms
|
||||
withTSDelta $ \delta -> liftIO $ do
|
||||
(tmpfile, h) <- openTmpFileIn (fromRawFilePath tmpdir) $
|
||||
relatedTemplate $ "ingest-" ++ takeFileName file
|
||||
(tmpfile, h) <- openTmpFileIn (toOsPath tmpdir) $
|
||||
relatedTemplate $ toRawFilePath $
|
||||
"ingest-" ++ takeFileName file
|
||||
hClose h
|
||||
removeWhenExistsWith R.removeLink (toRawFilePath tmpfile)
|
||||
withhardlink' delta tmpfile
|
||||
let tmpfile' = fromOsPath tmpfile
|
||||
removeWhenExistsWith R.removeLink tmpfile'
|
||||
withhardlink' delta tmpfile'
|
||||
`catchIO` const (nohardlink' delta)
|
||||
|
||||
withhardlink' delta tmpfile = do
|
||||
let tmpfile' = toRawFilePath tmpfile
|
||||
R.createLink file' tmpfile'
|
||||
cache <- genInodeCache tmpfile' delta
|
||||
R.createLink file' tmpfile
|
||||
cache <- genInodeCache tmpfile delta
|
||||
return $ LockedDown cfg $ KeySource
|
||||
{ keyFilename = file'
|
||||
, contentLocation = tmpfile'
|
||||
, contentLocation = tmpfile
|
||||
, inodeCache = cache
|
||||
}
|
||||
|
||||
|
|
@ -308,7 +309,7 @@ restoreFile file key e = do
|
|||
makeLink :: RawFilePath -> Key -> Maybe InodeCache -> Annex LinkTarget
|
||||
makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do
|
||||
l <- calcRepo $ gitAnnexLink file key
|
||||
replaceWorkTreeFile file' $ makeAnnexLink l
|
||||
replaceWorkTreeFile file $ makeAnnexLink l
|
||||
|
||||
-- touch symlink to have same time as the original file,
|
||||
-- as provided in the InodeCache
|
||||
|
|
@ -317,8 +318,6 @@ makeLink file key mcache = flip catchNonAsync (restoreFile file key) $ do
|
|||
Nothing -> noop
|
||||
|
||||
return l
|
||||
where
|
||||
file' = fromRawFilePath file
|
||||
|
||||
{- Creates the symlink to the annexed content, and stages it in git. -}
|
||||
addSymlink :: RawFilePath -> Key -> Maybe InodeCache -> Annex ()
|
||||
|
|
|
|||
|
|
@ -27,6 +27,7 @@ import Annex.BranchState
|
|||
import Types.BranchState
|
||||
import Utility.Directory.Stream
|
||||
import qualified Utility.RawFilePath as R
|
||||
import qualified Utility.FileIO as F
|
||||
|
||||
import qualified Data.Set as S
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
|
|
@ -92,7 +93,7 @@ setJournalFile _jl ru file content = withOtherTmp $ \tmp -> do
|
|||
-- journal file is written atomically
|
||||
let jfile = journalFile file
|
||||
let tmpfile = tmp P.</> jfile
|
||||
liftIO $ withFile (fromRawFilePath tmpfile) WriteMode $ \h ->
|
||||
liftIO $ F.withFile (toOsPath tmpfile) WriteMode $ \h ->
|
||||
writeJournalHandle h content
|
||||
let dest = jd P.</> jfile
|
||||
let mv = do
|
||||
|
|
@ -133,7 +134,7 @@ checkCanAppendJournalFile _jl ru file = do
|
|||
-}
|
||||
appendJournalFile :: Journalable content => JournalLocked -> AppendableJournalFile -> content -> Annex ()
|
||||
appendJournalFile _jl (AppendableJournalFile (jd, jfile)) content = do
|
||||
let write = liftIO $ withFile (fromRawFilePath jfile) ReadWriteMode $ \h -> do
|
||||
let write = liftIO $ F.withFile (toOsPath jfile) ReadWriteMode $ \h -> do
|
||||
sz <- hFileSize h
|
||||
when (sz /= 0) $ do
|
||||
hSeek h SeekFromEnd (-1)
|
||||
|
|
@ -204,7 +205,7 @@ getJournalFileStale (GetPrivate getprivate) file = do
|
|||
jfile = journalFile file
|
||||
getfrom d = catchMaybeIO $
|
||||
discardIncompleteAppend . L.fromStrict
|
||||
<$> B.readFile (fromRawFilePath (d P.</> jfile))
|
||||
<$> F.readFile' (toOsPath (d P.</> jfile))
|
||||
|
||||
-- Note that this forces read of the whole lazy bytestring.
|
||||
discardIncompleteAppend :: L.ByteString -> L.ByteString
|
||||
|
|
@ -243,17 +244,15 @@ withJournalHandle getjournaldir a = do
|
|||
where
|
||||
-- avoid overhead of creating the journal directory when it already
|
||||
-- exists
|
||||
opendir d = liftIO (openDirectory (fromRawFilePath d))
|
||||
opendir d = liftIO (openDirectory d)
|
||||
`catchIO` (const (createAnnexDirectory d >> opendir d))
|
||||
|
||||
{- Checks if there are changes in the journal. -}
|
||||
journalDirty :: (BranchState -> Git.Repo -> RawFilePath) -> Annex Bool
|
||||
journalDirty getjournaldir = do
|
||||
st <- getState
|
||||
d <- fromRawFilePath <$> fromRepo (getjournaldir st)
|
||||
liftIO $
|
||||
(not <$> isDirectoryEmpty d)
|
||||
`catchIO` (const $ doesDirectoryExist d)
|
||||
d <- fromRepo (getjournaldir st)
|
||||
liftIO $ isDirectoryPopulated d
|
||||
|
||||
{- Produces a filename to use in the journal for a file on the branch.
|
||||
- The filename does not include the journal directory.
|
||||
|
|
|
|||
|
|
@ -38,6 +38,7 @@ import Utility.Tmp.Dir
|
|||
import Utility.CopyFile
|
||||
import qualified Database.Keys.Handle
|
||||
import qualified Utility.RawFilePath as R
|
||||
import qualified Utility.FileIO as F
|
||||
|
||||
import qualified Data.ByteString as S
|
||||
import qualified Data.ByteString.Char8 as S8
|
||||
|
|
@ -87,7 +88,7 @@ getAnnexLinkTarget' file coresymlinks = if coresymlinks
|
|||
|
||||
probesymlink = R.readSymbolicLink file
|
||||
|
||||
probefilecontent = withFile (fromRawFilePath file) ReadMode $ \h -> do
|
||||
probefilecontent = F.withFile (toOsPath file) ReadMode $ \h -> do
|
||||
s <- S.hGet h maxSymlinkSz
|
||||
-- If we got the full amount, the file is too large
|
||||
-- to be a symlink target.
|
||||
|
|
@ -117,7 +118,7 @@ makeGitLink linktarget file = ifM (coreSymlinks <$> Annex.getGitConfig)
|
|||
( liftIO $ do
|
||||
void $ tryIO $ R.removeLink file
|
||||
R.createSymbolicLink linktarget file
|
||||
, liftIO $ S.writeFile (fromRawFilePath file) linktarget
|
||||
, liftIO $ F.writeFile' (toOsPath file) linktarget
|
||||
)
|
||||
|
||||
{- Creates a link on disk, and additionally stages it in git. -}
|
||||
|
|
@ -152,7 +153,7 @@ stagePointerFile file mode sha =
|
|||
|
||||
writePointerFile :: RawFilePath -> Key -> Maybe FileMode -> IO ()
|
||||
writePointerFile file k mode = do
|
||||
S.writeFile (fromRawFilePath file) (formatPointer k)
|
||||
F.writeFile' (toOsPath file) (formatPointer k)
|
||||
maybe noop (R.setFileMode file) mode
|
||||
|
||||
newtype Restage = Restage Bool
|
||||
|
|
@ -245,7 +246,9 @@ restagePointerFiles r = unlessM (Annex.getState Annex.insmudgecleanfilter) $ do
|
|||
when (numfiles > 0) $
|
||||
bracket lockindex unlockindex go
|
||||
where
|
||||
withtmpdir = withTmpDirIn (fromRawFilePath $ Git.localGitDir r) "annexindex"
|
||||
withtmpdir = withTmpDirIn
|
||||
(fromRawFilePath $ Git.localGitDir r)
|
||||
(toOsPath "annexindex")
|
||||
|
||||
isunmodified tsd f orig =
|
||||
genInodeCache f tsd >>= return . \case
|
||||
|
|
@ -434,7 +437,7 @@ maxSymlinkSz = 8192
|
|||
isPointerFile :: RawFilePath -> IO (Maybe Key)
|
||||
isPointerFile f = catchDefaultIO Nothing $
|
||||
#if defined(mingw32_HOST_OS)
|
||||
withFile (fromRawFilePath f) ReadMode readhandle
|
||||
F.withFile (toOsPath f) ReadMode readhandle
|
||||
#else
|
||||
#if MIN_VERSION_unix(2,8,0)
|
||||
let open = do
|
||||
|
|
@ -445,7 +448,7 @@ isPointerFile f = catchDefaultIO Nothing $
|
|||
#else
|
||||
ifM (isSymbolicLink <$> R.getSymbolicLinkStatus f)
|
||||
( return Nothing
|
||||
, withFile (fromRawFilePath f) ReadMode readhandle
|
||||
, F.withFile (toOsPath f) ReadMode readhandle
|
||||
)
|
||||
#endif
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@
|
|||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Annex.Proxy where
|
||||
|
||||
|
|
@ -30,6 +31,7 @@ import Utility.Tmp.Dir
|
|||
import Utility.Metered
|
||||
import Git.Types
|
||||
import qualified Database.Export as Export
|
||||
import qualified Utility.FileIO as F
|
||||
#ifndef mingw32_HOST_OS
|
||||
import Utility.OpenFile
|
||||
#endif
|
||||
|
|
@ -173,7 +175,7 @@ proxySpecialRemote protoversion r ihdl ohdl owaitv oclosedv mexportdb = go
|
|||
-- independently. Also, this key is not getting added into the
|
||||
-- local annex objects.
|
||||
withproxytmpfile k a = withOtherTmp $ \othertmpdir ->
|
||||
withTmpDirIn (fromRawFilePath othertmpdir) "proxy" $ \tmpdir ->
|
||||
withTmpDirIn (fromRawFilePath othertmpdir) (toOsPath "proxy") $ \tmpdir ->
|
||||
a (toRawFilePath tmpdir P.</> keyFile k)
|
||||
|
||||
proxyput af k = do
|
||||
|
|
@ -184,7 +186,7 @@ proxySpecialRemote protoversion r ihdl ohdl owaitv oclosedv mexportdb = go
|
|||
-- the client, to avoid bad content
|
||||
-- being stored in the special remote.
|
||||
iv <- startVerifyKeyContentIncrementally Remote.AlwaysVerify k
|
||||
h <- liftIO $ openFile (fromRawFilePath tmpfile) WriteMode
|
||||
h <- liftIO $ F.openFile (toOsPath tmpfile) WriteMode
|
||||
let nuketmp = liftIO $ removeWhenExistsWith removeFile (fromRawFilePath tmpfile)
|
||||
gotall <- liftIO $ receivetofile iv h len
|
||||
liftIO $ hClose h
|
||||
|
|
|
|||
|
|
@ -1,12 +1,10 @@
|
|||
{- git-annex file replacing
|
||||
-
|
||||
- Copyright 2013-2021 Joey Hess <id@joeyh.name>
|
||||
- Copyright 2013-2025 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Annex.ReplaceFile (
|
||||
replaceGitAnnexDirFile,
|
||||
replaceGitDirFile,
|
||||
|
|
@ -19,24 +17,24 @@ import Annex.Common
|
|||
import Annex.Tmp
|
||||
import Annex.Perms
|
||||
import Git
|
||||
import Utility.Tmp
|
||||
import Utility.Tmp.Dir
|
||||
import Utility.Directory.Create
|
||||
#ifndef mingw32_HOST_OS
|
||||
import Utility.Path.Max
|
||||
#endif
|
||||
|
||||
import qualified System.FilePath.ByteString as P
|
||||
|
||||
{- replaceFile on a file located inside the gitAnnexDir. -}
|
||||
replaceGitAnnexDirFile :: FilePath -> (RawFilePath -> Annex a) -> Annex a
|
||||
replaceGitAnnexDirFile :: RawFilePath -> (RawFilePath -> Annex a) -> Annex a
|
||||
replaceGitAnnexDirFile = replaceFile createAnnexDirectory
|
||||
|
||||
{- replaceFile on a file located inside the .git directory. -}
|
||||
replaceGitDirFile :: FilePath -> (RawFilePath -> Annex a) -> Annex a
|
||||
replaceGitDirFile :: RawFilePath -> (RawFilePath -> Annex a) -> Annex a
|
||||
replaceGitDirFile = replaceFile $ \dir -> do
|
||||
top <- fromRepo localGitDir
|
||||
liftIO $ createDirectoryUnder [top] dir
|
||||
|
||||
{- replaceFile on a worktree file. -}
|
||||
replaceWorkTreeFile :: FilePath -> (RawFilePath -> Annex a) -> Annex a
|
||||
replaceWorkTreeFile :: RawFilePath -> (RawFilePath -> Annex a) -> Annex a
|
||||
replaceWorkTreeFile = replaceFile createWorkTreeDirectory
|
||||
|
||||
{- Replaces a possibly already existing file with a new version,
|
||||
|
|
@ -54,28 +52,17 @@ replaceWorkTreeFile = replaceFile createWorkTreeDirectory
|
|||
- The createdirectory action is only run when moving the file into place
|
||||
- fails, and can create any parent directory structure needed.
|
||||
-}
|
||||
replaceFile :: (RawFilePath -> Annex ()) -> FilePath -> (RawFilePath -> Annex a) -> Annex a
|
||||
replaceFile :: (RawFilePath -> Annex ()) -> RawFilePath -> (RawFilePath -> Annex a) -> Annex a
|
||||
replaceFile createdirectory file action = replaceFile' createdirectory file (const True) action
|
||||
|
||||
replaceFile' :: (RawFilePath -> Annex ()) -> FilePath -> (a -> Bool) -> (RawFilePath -> Annex a) -> Annex a
|
||||
replaceFile' :: (RawFilePath -> Annex ()) -> RawFilePath -> (a -> Bool) -> (RawFilePath -> Annex a) -> Annex a
|
||||
replaceFile' createdirectory file checkres action = withOtherTmp $ \othertmpdir -> do
|
||||
let othertmpdir' = fromRawFilePath othertmpdir
|
||||
#ifndef mingw32_HOST_OS
|
||||
-- Use part of the filename as the template for the temp
|
||||
-- directory. This does not need to be unique, but it
|
||||
-- makes it more clear what this temp directory is for.
|
||||
filemax <- liftIO $ fileNameLengthLimit othertmpdir'
|
||||
let basetmp = take (filemax `div` 2) (takeFileName file)
|
||||
#else
|
||||
-- Windows has limits on the whole path length, so keep
|
||||
-- it short.
|
||||
let basetmp = "t"
|
||||
#endif
|
||||
withTmpDirIn othertmpdir' basetmp $ \tmpdir -> do
|
||||
let tmpfile = toRawFilePath (tmpdir </> basetmp)
|
||||
let basetmp = relatedTemplate' (P.takeFileName file)
|
||||
withTmpDirIn (fromRawFilePath othertmpdir) (toOsPath basetmp) $ \tmpdir -> do
|
||||
let tmpfile = toRawFilePath tmpdir P.</> basetmp
|
||||
r <- action tmpfile
|
||||
when (checkres r) $
|
||||
replaceFileFrom tmpfile (toRawFilePath file) createdirectory
|
||||
replaceFileFrom tmpfile file createdirectory
|
||||
return r
|
||||
|
||||
replaceFileFrom :: RawFilePath -> RawFilePath -> (RawFilePath -> Annex ()) -> Annex ()
|
||||
|
|
|
|||
|
|
@ -161,7 +161,7 @@ checkStaleSizeChanges h@(RepoSizeHandle (Just _) livev) = do
|
|||
where
|
||||
go livedir lck pidlockfile now = do
|
||||
void $ tryNonAsync $ do
|
||||
lockfiles <- liftIO $ filter (not . dirCruft)
|
||||
lockfiles <- liftIO $ filter (not . dirCruft . toRawFilePath)
|
||||
<$> getDirectoryContents (fromRawFilePath livedir)
|
||||
stale <- forM lockfiles $ \lockfile ->
|
||||
if (lockfile /= pidlockfile)
|
||||
|
|
|
|||
30
Annex/Ssh.hs
30
Annex/Ssh.hs
|
|
@ -5,6 +5,7 @@
|
|||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Annex.Ssh (
|
||||
|
|
@ -100,15 +101,16 @@ consumeStdinParams NoConsumeStdin = [Param "-n"]
|
|||
|
||||
{- Returns a filename to use for a ssh connection caching socket, and
|
||||
- parameters to enable ssh connection caching. -}
|
||||
sshCachingInfo :: (SshHost, Maybe Integer) -> Annex (Maybe FilePath, [CommandParam])
|
||||
sshCachingInfo :: (SshHost, Maybe Integer) -> Annex (Maybe RawFilePath, [CommandParam])
|
||||
sshCachingInfo (host, port) = go =<< sshCacheDir'
|
||||
where
|
||||
go (Right dir) =
|
||||
liftIO (bestSocketPath $ dir P.</> hostport2socket host port) >>= return . \case
|
||||
Nothing -> (Nothing, [])
|
||||
Just socketfile ->
|
||||
let socketfile' = fromRawFilePath socketfile
|
||||
in (Just socketfile', sshConnectionCachingParams socketfile')
|
||||
(Just socketfile
|
||||
, sshConnectionCachingParams (fromRawFilePath socketfile)
|
||||
)
|
||||
-- No connection caching with concurrency is not a good
|
||||
-- combination, so warn the user.
|
||||
go (Left whynocaching) = do
|
||||
|
|
@ -214,7 +216,7 @@ portParams (Just port) = [Param "-p", Param $ show port]
|
|||
- Locks the socket lock file to prevent other git-annex processes from
|
||||
- stopping the ssh multiplexer on this socket.
|
||||
-}
|
||||
prepSocket :: FilePath -> SshHost -> [CommandParam] -> Annex ()
|
||||
prepSocket :: RawFilePath -> SshHost -> [CommandParam] -> Annex ()
|
||||
prepSocket socketfile sshhost sshparams = do
|
||||
-- There could be stale ssh connections hanging around
|
||||
-- from a previous git-annex run that was interrupted.
|
||||
|
|
@ -286,13 +288,13 @@ prepSocket socketfile sshhost sshparams = do
|
|||
- and this check makes such files be skipped since the corresponding lock
|
||||
- file won't exist.
|
||||
-}
|
||||
enumSocketFiles :: Annex [FilePath]
|
||||
enumSocketFiles :: Annex [RawFilePath]
|
||||
enumSocketFiles = liftIO . go =<< sshCacheDir
|
||||
where
|
||||
go Nothing = return []
|
||||
go (Just dir) = filterM (R.doesPathExist . socket2lock)
|
||||
=<< filter (not . isLock)
|
||||
<$> catchDefaultIO [] (dirContents (fromRawFilePath dir))
|
||||
<$> catchDefaultIO [] (dirContents dir)
|
||||
|
||||
{- Stop any unused ssh connection caching processes. -}
|
||||
sshCleanup :: Annex ()
|
||||
|
|
@ -324,9 +326,9 @@ sshCleanup = mapM_ cleanup =<< enumSocketFiles
|
|||
forceSshCleanup :: Annex ()
|
||||
forceSshCleanup = mapM_ forceStopSsh =<< enumSocketFiles
|
||||
|
||||
forceStopSsh :: FilePath -> Annex ()
|
||||
forceStopSsh :: RawFilePath -> Annex ()
|
||||
forceStopSsh socketfile = withNullHandle $ \nullh -> do
|
||||
let (dir, base) = splitFileName socketfile
|
||||
let (dir, base) = splitFileName (fromRawFilePath socketfile)
|
||||
let p = (proc "ssh" $ toCommand $
|
||||
[ Param "-O", Param "stop" ] ++
|
||||
sshConnectionCachingParams base ++
|
||||
|
|
@ -338,7 +340,7 @@ forceStopSsh socketfile = withNullHandle $ \nullh -> do
|
|||
}
|
||||
void $ liftIO $ catchMaybeIO $ withCreateProcess p $ \_ _ _ pid ->
|
||||
forceSuccessProcess p pid
|
||||
liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath socketfile)
|
||||
liftIO $ removeWhenExistsWith R.removeLink socketfile
|
||||
|
||||
{- This needs to be as short as possible, due to limitations on the length
|
||||
- of the path to a socket file. At the same time, it needs to be unique
|
||||
|
|
@ -355,13 +357,13 @@ hostport2socket' s
|
|||
where
|
||||
lengthofmd5s = 32
|
||||
|
||||
socket2lock :: FilePath -> RawFilePath
|
||||
socket2lock socket = toRawFilePath (socket ++ lockExt)
|
||||
socket2lock :: RawFilePath -> RawFilePath
|
||||
socket2lock socket = socket <> lockExt
|
||||
|
||||
isLock :: FilePath -> Bool
|
||||
isLock f = lockExt `isSuffixOf` f
|
||||
isLock :: RawFilePath -> Bool
|
||||
isLock f = lockExt `S.isSuffixOf` f
|
||||
|
||||
lockExt :: String
|
||||
lockExt :: S.ByteString
|
||||
lockExt = ".lock"
|
||||
|
||||
{- This is the size of the sun_path component of sockaddr_un, which
|
||||
|
|
|
|||
10
Annex/Tmp.hs
10
Annex/Tmp.hs
|
|
@ -60,15 +60,17 @@ cleanupOtherTmp = do
|
|||
void $ tryIO $ tryExclusiveLock tmplck $ do
|
||||
tmpdir <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDir
|
||||
void $ liftIO $ tryIO $ removeDirectoryRecursive tmpdir
|
||||
oldtmp <- fromRawFilePath <$> fromRepo gitAnnexTmpOtherDirOld
|
||||
oldtmp <- fromRepo gitAnnexTmpOtherDirOld
|
||||
liftIO $ mapM_ cleanold
|
||||
=<< emptyWhenDoesNotExist (dirContentsRecursive oldtmp)
|
||||
liftIO $ void $ tryIO $ removeDirectory oldtmp -- when empty
|
||||
-- remove when empty
|
||||
liftIO $ void $ tryIO $
|
||||
removeDirectory (fromRawFilePath oldtmp)
|
||||
where
|
||||
cleanold f = do
|
||||
now <- liftIO getPOSIXTime
|
||||
let oldenough = now - (60 * 60 * 24 * 7)
|
||||
catchMaybeIO (modificationTime <$> R.getSymbolicLinkStatus (toRawFilePath f)) >>= \case
|
||||
catchMaybeIO (modificationTime <$> R.getSymbolicLinkStatus f) >>= \case
|
||||
Just mtime | realToFrac mtime <= oldenough ->
|
||||
void $ tryIO $ removeWhenExistsWith R.removeLink (toRawFilePath f)
|
||||
void $ tryIO $ removeWhenExistsWith R.removeLink f
|
||||
_ -> return ()
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@ import qualified Annex
|
|||
import Utility.TimeStamp
|
||||
|
||||
import Data.ByteString.Builder
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.Attoparsec.ByteString.Lazy as A
|
||||
|
||||
currentVectorClock :: Annex CandidateVectorClock
|
||||
|
|
@ -76,7 +77,7 @@ formatVectorClock (VectorClock t) = show t
|
|||
buildVectorClock :: VectorClock -> Builder
|
||||
buildVectorClock = string7 . formatVectorClock
|
||||
|
||||
parseVectorClock :: String -> Maybe VectorClock
|
||||
parseVectorClock :: B.ByteString -> Maybe VectorClock
|
||||
parseVectorClock t = VectorClock <$> parsePOSIXTime t
|
||||
|
||||
vectorClockParser :: A.Parser VectorClock
|
||||
|
|
|
|||
|
|
@ -12,12 +12,13 @@ import Data.Time.Clock.POSIX
|
|||
import Types.VectorClock
|
||||
import Utility.Env
|
||||
import Utility.TimeStamp
|
||||
import Utility.FileSystemEncoding
|
||||
|
||||
startVectorClock :: IO (IO CandidateVectorClock)
|
||||
startVectorClock = go =<< getEnv "GIT_ANNEX_VECTOR_CLOCK"
|
||||
where
|
||||
go Nothing = timebased
|
||||
go (Just s) = case parsePOSIXTime s of
|
||||
go (Just s) = case parsePOSIXTime (encodeBS s) of
|
||||
Just t -> return (pure (CandidateVectorClock t))
|
||||
Nothing -> timebased
|
||||
-- Avoid using fractional seconds in the CandidateVectorClock.
|
||||
|
|
|
|||
|
|
@ -30,6 +30,8 @@ import Utility.Metered
|
|||
import Utility.Tmp
|
||||
import Messages.Progress
|
||||
import Logs.Transfer
|
||||
import qualified Utility.RawFilePath as R
|
||||
import qualified Utility.FileIO as F
|
||||
|
||||
import Network.URI
|
||||
import Control.Concurrent.Async
|
||||
|
|
@ -37,7 +39,6 @@ import Text.Read
|
|||
import Data.Either
|
||||
import qualified Data.Aeson as Aeson
|
||||
import GHC.Generics
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Char8 as B8
|
||||
|
||||
-- youtube-dl can follow redirects to anywhere, including potentially
|
||||
|
|
@ -101,9 +102,9 @@ youtubeDl' url workdir p uo
|
|||
| isytdlp cmd = liftIO $
|
||||
(nub . lines <$> readFile filelistfile)
|
||||
`catchIO` (pure . const [])
|
||||
| otherwise = workdirfiles
|
||||
workdirfiles = liftIO $ filter (/= filelistfile)
|
||||
<$> (filterM (doesFileExist) =<< dirContents workdir)
|
||||
| otherwise = map fromRawFilePath <$> workdirfiles
|
||||
workdirfiles = liftIO $ filter (/= toRawFilePath filelistfile)
|
||||
<$> (filterM R.doesPathExist =<< dirContents (toRawFilePath workdir))
|
||||
filelistfile = workdir </> filelistfilebase
|
||||
filelistfilebase = "git-annex-file-list-file"
|
||||
isytdlp cmd = cmd == "yt-dlp"
|
||||
|
|
@ -159,7 +160,7 @@ youtubeDlMaxSize workdir = ifM (Annex.getRead Annex.force)
|
|||
Just have -> do
|
||||
inprogress <- sizeOfDownloadsInProgress (const True)
|
||||
partial <- liftIO $ sum
|
||||
<$> (mapM (getFileSize . toRawFilePath) =<< dirContents workdir)
|
||||
<$> (mapM getFileSize =<< dirContents (toRawFilePath workdir))
|
||||
reserve <- annexDiskReserve <$> Annex.getGitConfig
|
||||
let maxsize = have - reserve - inprogress + partial
|
||||
if maxsize > 0
|
||||
|
|
@ -352,7 +353,7 @@ youtubePlaylist url = do
|
|||
else return $ Left $ "Scraping needs yt-dlp, but git-annex has been configured to use " ++ cmd
|
||||
|
||||
youtubePlaylist' :: URLString -> String -> IO (Either String [YoutubePlaylistItem])
|
||||
youtubePlaylist' url cmd = withTmpFile "yt-dlp" $ \tmpfile h -> do
|
||||
youtubePlaylist' url cmd = withTmpFile (toOsPath (toRawFilePath "yt-dlp")) $ \tmpfile h -> do
|
||||
hClose h
|
||||
(outerr, ok) <- processTranscript cmd
|
||||
[ "--simulate"
|
||||
|
|
@ -362,14 +363,14 @@ youtubePlaylist' url cmd = withTmpFile "yt-dlp" $ \tmpfile h -> do
|
|||
, "--print-to-file"
|
||||
-- Write json with selected fields.
|
||||
, "%(.{" ++ intercalate "," youtubePlaylistItemFields ++ "})j"
|
||||
, tmpfile
|
||||
, fromRawFilePath (fromOsPath tmpfile)
|
||||
, url
|
||||
]
|
||||
Nothing
|
||||
if ok
|
||||
then flip catchIO (pure . Left . show) $ do
|
||||
v <- map Aeson.eitherDecodeStrict . B8.lines
|
||||
<$> B.readFile tmpfile
|
||||
<$> F.readFile' tmpfile
|
||||
return $ case partitionEithers v of
|
||||
((parserr:_), _) ->
|
||||
Left $ "yt-dlp json parse error: " ++ parserr
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue