import Utility.Tmp.Dir
import Utility.CopyFile
import Utility.Directory.Create
+import qualified Utility.RawFilePath as R
import qualified Data.ByteString as S
import qualified System.FilePath.ByteString as P
-}
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 $
withemptydir git_dir tmpwt $ withWorkTree tmpwt $ do
-- 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'
+ whenM (R.doesPathExist src) $ do
+ dest <- relPathDirToFile git_dir src
let dest' = toRawFilePath 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
Nothing -> return ()
Just file -> do
let path = dir P.</> toRawFilePath file
- unless (dirCruft file) $ whenM (isfile path) $ do
+ unless (dirCruft (toRawFilePath file)) $ whenM (isfile path) $ do
sha <- Git.HashObject.hashFile h path
hPutStrLn jlogh file
streamer $ Git.UpdateIndex.updateIndexLine
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)
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)
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.
-
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)
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Annex.Ssh (
{- 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
- 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.
- 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 ()
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 ++
}
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
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
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 ()
import Utility.Tmp
import Messages.Progress
import Logs.Transfer
+import qualified Utility.RawFilePath as R
import Network.URI
import Control.Concurrent.Async
| 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"
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
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module Assistant.Repair where
import qualified Utility.RawFilePath as R
import Control.Concurrent.Async
+import qualified Data.ByteString as S
+import qualified System.FilePath.ByteString as P
{- When the FsckResults require a repair, tries to do a non-destructive
- repair. If that fails, pops up an alert. -}
repairStaleLocks lockfiles
return $ not $ null lockfiles
where
- findgitfiles = dirContentsRecursiveSkipping (== dropTrailingPathSeparator (fromRawFilePath annexDir)) True . fromRawFilePath . Git.localGitDir
+ findgitfiles = dirContentsRecursiveSkipping (== P.dropTrailingPathSeparator annexDir) True . Git.localGitDir
islock f
- | "gc.pid" `isInfixOf` f = False
- | ".lock" `isSuffixOf` f = True
- | takeFileName f == "MERGE_HEAD" = True
+ | "gc.pid" `S.isInfixOf` f = False
+ | ".lock" `S.isSuffixOf` f = True
+ | P.takeFileName f == "MERGE_HEAD" = True
| otherwise = False
-repairStaleLocks :: [FilePath] -> Assistant ()
+repairStaleLocks :: [RawFilePath] -> Assistant ()
repairStaleLocks lockfiles = go =<< getsizes
where
getsize lf = catchMaybeIO $ (\s -> (lf, s))
- <$> getFileSize (toRawFilePath lf)
+ <$> getFileSize lf
getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles
go [] = return ()
- go l = ifM (liftIO $ null <$> Lsof.query ("--" : map fst l))
+ go l = ifM (liftIO $ null <$> Lsof.query ("--" : map (fromRawFilePath . fst) l))
( do
waitforit "to check stale git lock file"
l' <- getsizes
if l' == l
- then liftIO $ mapM_ (removeWhenExistsWith R.removeLink . toRawFilePath . fst) l
+ then liftIO $ mapM_ (removeWhenExistsWith R.removeLink . fst) l
else go l'
, do
waitforit "for git lock file writer"
{- Called when a new transfer information file is written. -}
onAdd :: Handler
-onAdd file = case parseTransferFile file of
+onAdd file = case parseTransferFile (toRawFilePath file) of
Nothing -> noop
Just t -> go t =<< liftAnnex (checkTransfer t)
where
- The only thing that should change in the transfer info is the
- bytesComplete, so that's the only thing updated in the DaemonStatus. -}
onModify :: Handler
-onModify file = case parseTransferFile file of
+onModify file = case parseTransferFile (toRawFilePath file) of
Nothing -> noop
Just t -> go t =<< liftIO (readTransferInfoFile Nothing file)
where
{- Called when a transfer information file is removed. -}
onDel :: Handler
-onDel file = case parseTransferFile file of
+onDel file = case parseTransferFile (toRawFilePath file) of
Nothing -> noop
Just t -> do
debug [ "transfer finishing:", show t]
import qualified Annex.Url as Url hiding (download)
import Utility.Tuple
import qualified Utility.RawFilePath as R
+import qualified System.FilePath.ByteString as P
import Data.Either
import qualified Data.Map as M
makeorigsymlink olddir
return (newdir </> "git-annex", deleteold)
installby a dstdir srcdir =
- mapM_ (\x -> a (toRawFilePath x) (toRawFilePath (dstdir </> takeFileName x)))
- =<< dirContents srcdir
+ mapM_ (\x -> a x (toRawFilePath dstdir P.</> P.takeFileName x))
+ =<< dirContents (toRawFilePath srcdir)
#endif
sanitycheck dir =
unlessM (doesDirectoryExist dir) $
fs <- map (dir </>) . lines <$> catchDefaultIO "" (readFile manifest)
mapM_ (removeWhenExistsWith R.removeLink . toRawFilePath) fs
removeWhenExistsWith R.removeLink (toRawFilePath manifest)
- removeEmptyRecursive dir
+ removeEmptyRecursive (toRawFilePath dir)
where
manifest = dir </> "git-annex.MANIFEST"
-removeEmptyRecursive :: FilePath -> IO ()
+removeEmptyRecursive :: RawFilePath -> IO ()
removeEmptyRecursive dir = do
mapM_ removeEmptyRecursive =<< dirContents dir
- void $ tryIO $ removeDirectory dir
+ void $ tryIO $ removeDirectory (fromRawFilePath dir)
{- This is a file that the UpgradeWatcher can watch for modifications to
- detect when git-annex has been upgraded.
rs <- syncRemotes <$> getDaemonStatus
mapM_ (\r -> changeSyncable (Just r) False) rs
- liftAnnex $ prepareRemoveAnnexDir dir
+ liftAnnex $ prepareRemoveAnnexDir (toRawFilePath dir)
liftIO $ removeDirectoryRecursive . fromRawFilePath
=<< absPath (toRawFilePath dir)
forM_ fs $ \f -> do
let src = inTop top (x </> f)
let dst = inTop top (d </> f)
- unless (dirCruft f) $
+ unless (dirCruft (toRawFilePath f)) $
unlessM (doesDirectoryExist src) $
renameFile src dst
symlinkHwCapDirs top d
import Utility.Env
import Utility.Metered
import Utility.FileMode
+import qualified Utility.RawFilePath as R
import Network.URI
import Data.Either
import qualified Data.ByteString.Char8 as B8
import qualified Data.Map.Strict as M
import qualified System.FilePath.ByteString as P
-import qualified Utility.RawFilePath as R
import qualified Data.Set as S
run :: [String] -> IO ()
-- objects are deleted.
cleanupInitialization :: StartAnnexBranch -> FilePath -> Annex ()
cleanupInitialization sab alternatejournaldir = void $ tryNonAsync $ do
- liftIO $ mapM_ removeFile =<< dirContents alternatejournaldir
+ liftIO $ mapM_ R.removeLink
+ =<< dirContents (toRawFilePath alternatejournaldir)
case sab of
AnnexBranchExistedAlready _ -> noop
AnnexBranchCreatedEmpty r ->
import Data.Time.Clock.POSIX
import System.PosixCompat.Files (isDirectory, isSymbolicLink, deviceID, fileID)
import qualified System.FilePath.ByteString as P
+import qualified Data.ByteString as S
data AnnexedFileSeeker = AnnexedFileSeeker
{ startAction :: Maybe KeySha -> SeekInput -> RawFilePath -> Key -> CommandStart
-- exist.
get p = ifM (isDirectory <$> R.getFileStatus p')
( map (\f ->
- let f' = toRawFilePath f
- in (f', P.makeRelative (P.takeDirectory (P.dropTrailingPathSeparator p')) f'))
- <$> dirContentsRecursiveSkipping (".git" `isSuffixOf`) False p
+ (f, P.makeRelative (P.takeDirectory (P.dropTrailingPathSeparator p')) f))
+ <$> dirContentsRecursiveSkipping (".git" `S.isSuffixOf`) False p'
, return [(p', P.takeFileName p')]
)
where
findRepos :: Options -> IO [Git.Repo]
findRepos o = do
- files <- map toRawFilePath . concat
- <$> mapM dirContents (directoryOption o)
+ files <- concat
+ <$> mapM (dirContents . toRawFilePath) (directoryOption o)
map Git.Construct.newFrom . catMaybes
<$> mapM Git.Construct.checkForRepo files
removeAnnexDir :: CommandCleanup -> CommandStart
removeAnnexDir recordok = do
Annex.Queue.flush
- annexdir <- fromRawFilePath <$> fromRepo gitAnnexDir
+ annexdir <- fromRepo gitAnnexDir
annexobjectdir <- fromRepo gitAnnexObjectDir
starting ("uninit objects") (ActionItemOther Nothing) (SeekInput []) $ do
leftovers <- removeUnannexed =<< listKeys InAnnex
prepareRemoveAnnexDir annexdir
if null leftovers
then do
- liftIO $ removeDirectoryRecursive annexdir
+ liftIO $ removeDirectoryRecursive (fromRawFilePath annexdir)
next recordok
else giveup $ unlines
[ "Not fully uninitialized"
-
- Also closes sqlite databases that might be in the directory,
- to avoid later failure to write any cached changes to them. -}
-prepareRemoveAnnexDir :: FilePath -> Annex ()
+prepareRemoveAnnexDir :: RawFilePath -> Annex ()
prepareRemoveAnnexDir annexdir = do
Database.Keys.closeDb
liftIO $ prepareRemoveAnnexDir' annexdir
-prepareRemoveAnnexDir' :: FilePath -> IO ()
+prepareRemoveAnnexDir' :: RawFilePath -> IO ()
prepareRemoveAnnexDir' annexdir =
emptyWhenDoesNotExist (dirTreeRecursiveSkipping (const False) annexdir)
- >>= mapM_ (void . tryIO . allowWrite . toRawFilePath)
+ >>= mapM_ (void . tryIO . allowWrite)
{- Keys that were moved out of the annex have a hard link still in the
- annex, with > 1 link count, and those can be removed.
packIdxFile :: RawFilePath -> RawFilePath
packIdxFile = flip P.replaceExtension "idx"
-listPackFiles :: Repo -> IO [FilePath]
-listPackFiles r = filter (".pack" `isSuffixOf`)
- <$> catchDefaultIO [] (dirContents $ fromRawFilePath $ packDir r)
+listPackFiles :: Repo -> IO [RawFilePath]
+listPackFiles r = filter (".pack" `B.isSuffixOf`)
+ <$> catchDefaultIO [] (dirContents $ packDir r)
listLooseObjectShas :: Repo -> IO [Sha]
listLooseObjectShas r = catchDefaultIO [] $
- mapMaybe (extractSha . encodeBS . concat . reverse . take 2 . reverse . splitDirectories)
- <$> emptyWhenDoesNotExist (dirContentsRecursiveSkipping (== "pack") True (fromRawFilePath (objectsDir r)))
+ mapMaybe (extractSha . encodeBS . concat . reverse . take 2 . reverse . splitDirectories . decodeBS)
+ <$> emptyWhenDoesNotExist (dirContentsRecursiveSkipping (== "pack") True (objectsDir r))
looseObjectFile :: Repo -> Sha -> RawFilePath
looseObjectFile r sha = objectsDir r P.</> prefix P.</> rest
putStrLn "Unpacking all pack files."
forM_ packs $ \packfile -> do
-- Just in case permissions are messed up.
- allowRead (toRawFilePath packfile)
+ allowRead packfile
-- May fail, if pack file is corrupt.
void $ tryIO $
pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h ->
- L.hPut h =<< L.readFile packfile
- objs <- emptyWhenDoesNotExist (dirContentsRecursive tmpdir)
+ L.hPut h =<< L.readFile (fromRawFilePath packfile)
+ objs <- emptyWhenDoesNotExist (dirContentsRecursive (toRawFilePath tmpdir))
forM_ objs $ \objfile -> do
f <- relPathDirToFile
(toRawFilePath tmpdir)
- (toRawFilePath objfile)
+ objfile
let dest = objectsDir r P.</> f
createDirectoryIfMissing True
(fromRawFilePath (parentDir dest))
- moveFile (toRawFilePath objfile) dest
+ moveFile objfile dest
forM_ packs $ \packfile -> do
- let f = toRawFilePath packfile
- removeWhenExistsWith R.removeLink f
- removeWhenExistsWith R.removeLink (packIdxFile f)
+ removeWhenExistsWith R.removeLink packfile
+ removeWhenExistsWith R.removeLink (packIdxFile packfile)
return True
{- Try to retrieve a set of missing objects, from the remotes of a
- Relies on packed refs being exploded before it's called.
-}
getAllRefs :: Repo -> IO [Ref]
-getAllRefs r = getAllRefs' (fromRawFilePath (localGitDir r) </> "refs")
+getAllRefs r = getAllRefs' (localGitDir r P.</> "refs")
-getAllRefs' :: FilePath -> IO [Ref]
+getAllRefs' :: RawFilePath -> IO [Ref]
getAllRefs' refdir = do
- let topsegs = length (splitPath refdir) - 1
+ let topsegs = length (P.splitPath refdir) - 1
let toref = Ref . toInternalGitPath . encodeBS
- . joinPath . drop topsegs . splitPath
+ . joinPath . drop topsegs . splitPath
+ . decodeBS
map toref <$> emptyWhenDoesNotExist (dirContentsRecursive refdir)
explodePackedRefsFile :: Repo -> IO ()
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Control.Concurrent.STM
+import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified System.FilePath.ByteString as P
infos <- mapM checkTransfer transfers
return $ mapMaybe running $ zip transfers infos
where
- findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive . fromRawFilePath)
+ findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive)
=<< mapM (fromRepo . transferDir) dirs
running (t, Just i) = Just (t, i)
running (_, Nothing) = Nothing
where
getpairs = mapM $ \f -> do
let mt = parseTransferFile f
- mi <- readTransferInfoFile Nothing f
+ mi <- readTransferInfoFile Nothing (fromRawFilePath f)
return $ case (mt, mi) of
(Just t, Just i) -> Just (t, i)
_ -> Nothing
- findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive . fromRawFilePath)
+ findfiles = liftIO . mapM (emptyWhenDoesNotExist . dirContentsRecursive)
=<< mapM (fromRepo . failedTransferDir u) [Download, Upload]
clearFailedTransfers :: UUID -> Annex [(Transfer, TransferInfo)]
P.</> keyFile (mkKey (const kd))
{- Parses a transfer information filename to a Transfer. -}
-parseTransferFile :: FilePath -> Maybe Transfer
+parseTransferFile :: RawFilePath -> Maybe Transfer
parseTransferFile file
- | "lck." `isPrefixOf` takeFileName file = Nothing
+ | "lck." `B.isPrefixOf` P.takeFileName file = Nothing
| otherwise = case drop (length bits - 3) bits of
[direction, u, key] -> Transfer
<$> parseDirection direction
<*> pure (toUUID u)
- <*> fmap (fromKey id) (fileKey (toRawFilePath key))
+ <*> fmap (fromKey id) (fileKey key)
_ -> Nothing
where
- bits = splitDirectories file
+ bits = P.splitDirectories file
writeTransferInfoFile :: TransferInfo -> RawFilePath -> Annex ()
writeTransferInfoFile info tfile = writeLogFile tfile $ writeTransferInfo info
import Network.URI
import qualified System.FilePath.ByteString as P
+import qualified Data.ByteString as S
#ifdef WITH_TORRENTPARSER
import Data.Torrent
let metadir = othertmp P.</> "torrentmeta" P.</> kf
createAnnexDirectory metadir
showOutput
- ok <- downloadMagnetLink u
- (fromRawFilePath metadir)
- (fromRawFilePath torrent)
+ ok <- downloadMagnetLink u metadir torrent
liftIO $ removeDirectoryRecursive
(fromRawFilePath metadir)
return ok
return ok
)
-downloadMagnetLink :: URLString -> FilePath -> FilePath -> Annex Bool
+downloadMagnetLink :: URLString -> RawFilePath -> RawFilePath -> Annex Bool
downloadMagnetLink u metadir dest = ifM download
( liftIO $ do
- ts <- filter (".torrent" `isSuffixOf`)
+ ts <- filter (".torrent" `S.isSuffixOf`)
<$> dirContents metadir
case ts of
(t:[]) -> do
- moveFile (toRawFilePath t) (toRawFilePath dest)
+ moveFile t dest
return True
_ -> return False
, return False
, Param "--seed-time=0"
, Param "--summary-interval=0"
, Param "-d"
- , File metadir
+ , File (fromRawFilePath metadir)
]
downloadTorrentContent :: Key -> URLString -> FilePath -> Int -> MeterUpdate -> Annex Bool
renameDirectory (fromRawFilePath tmp) dest'
-- may fail on some filesystems
void $ tryIO $ do
- mapM_ (preventWrite . toRawFilePath) =<< dirContents dest'
+ mapM_ preventWrite =<< dirContents dest
preventWrite dest
where
dest' = fromRawFilePath dest
listImportableContentsM :: IgnoreInodes -> RawFilePath -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize)))
listImportableContentsM ii dir = liftIO $ do
- l <- dirContentsRecursiveSkipping (const False) False (fromRawFilePath dir)
- l' <- mapM (go . toRawFilePath) l
+ l' <- mapM go =<< dirContentsRecursiveSkipping (const False) False dir
return $ Just $ ImportableContentsComplete $
ImportableContents (catMaybes l') []
where
- Licensed under the GNU AGPL version 3 or higher.
-}
+{-# LANGUAGE OverloadedStrings #-}
+
module Remote.Helper.Git where
import Annex.Common
import System.PosixCompat.Files (modificationTime)
import qualified Data.Map as M
import qualified Data.Set as S
+import qualified System.FilePath.ByteString as P
repoCheap :: Git.Repo -> Bool
repoCheap = not . Git.repoIsUrl
gitRepoInfo :: Remote -> Annex [(String, String)]
gitRepoInfo r = do
- d <- fromRawFilePath <$> fromRepo Git.localGitDir
- mtimes <- liftIO $ mapM (\p -> modificationTime <$> R.getFileStatus (toRawFilePath p))
- =<< emptyWhenDoesNotExist (dirContentsRecursive (d </> "refs" </> "remotes" </> Remote.name r))
+ d <- fromRepo Git.localGitDir
+ mtimes <- liftIO $ mapM (\p -> modificationTime <$> R.getFileStatus p)
+ =<< emptyWhenDoesNotExist (dirContentsRecursive (d P.</> "refs" P.</> "remotes" P.</> encodeBS (Remote.name r)))
let lastsynctime = case mtimes of
[] -> "never"
_ -> show $ posixSecondsToUTCTime $ realToFrac $ maximum mtimes
cleanup :: FilePath -> IO ()
cleanup dir = whenM (doesDirectoryExist dir) $ do
- Command.Uninit.prepareRemoveAnnexDir' dir
+ Command.Uninit.prepareRemoveAnnexDir' (toRawFilePath dir)
-- This can fail if files in the directory are still open by a
-- subprocess.
void $ tryIO $ removeDirectoryForCleanup dir
finalCleanup :: IO ()
finalCleanup = whenM (doesDirectoryExist tmpdir) $ do
- Command.Uninit.prepareRemoveAnnexDir' tmpdir
+ Command.Uninit.prepareRemoveAnnexDir' (toRawFilePath tmpdir)
catchIO (removeDirectoryForCleanup tmpdir) $ \e -> do
print e
putStrLn "sleeping 10 seconds and will retry directory cleanup"
formatDirection Upload = "upload"
formatDirection Download = "download"
-parseDirection :: String -> Maybe Direction
+parseDirection :: B.ByteString -> Maybe Direction
parseDirection "upload" = Just Upload
parseDirection "download" = Just Download
parseDirection _ = Nothing
config <- Annex.getGitConfig
dir <- fromRepo gitStateDir
liftIO $ do
- levela <- dirContents dir
+ levela <- dirContents (toRawFilePath dir)
levelb <- mapM tryDirContents levela
files <- mapM tryDirContents (concat levelb)
return $ mapMaybe (islogfile config) (concat files)
where
tryDirContents d = catchDefaultIO [] $ dirContents d
- islogfile config f = maybe Nothing (\k -> Just (k, f)) $
- locationLogFileKey config (toRawFilePath f)
+ islogfile config f = maybe Nothing (\k -> Just (k, fromRawFilePath f)) $
+ locationLogFileKey config f
inject :: FilePath -> FilePath -> Annex ()
inject source dest = do
void (addWatch i watchevents (toInternalFilePath dir) handler)
`catchIO` failedaddwatch
withLock lock $
- mapM_ scan =<< filter (not . dirCruft) <$>
+ mapM_ scan =<< filter (not . dirCruft . toRawFilePath) <$>
getDirectoryContents dir
where
recurse d = watchDir i d ignored scanevents hooks
getDirInfo :: FilePath -> IO DirInfo
getDirInfo dir = do
- l <- filter (not . dirCruft) <$> getDirectoryContents dir
+ l <- filter (not . dirCruft . toRawFilePath) <$> getDirectoryContents dir
contents <- S.fromList . catMaybes <$> mapM getDirEnt l
return $ DirInfo dir contents
where
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Directory where
import Control.Monad
-import System.FilePath
import System.PosixCompat.Files (isDirectory, isSymbolicLink)
import Control.Applicative
import System.IO.Unsafe (unsafeInterleaveIO)
+import qualified System.FilePath.ByteString as P
import Data.Maybe
import Prelude
-import Utility.SystemDirectory
import Utility.Exception
import Utility.Monad
import Utility.FileSystemEncoding
import qualified Utility.RawFilePath as R
-dirCruft :: FilePath -> Bool
+#ifdef WITH_OSSTRING
+import Utility.OsString
+import qualified System.Directory.OsPath as OP
+#else
+import Utility.SystemDirectory
+#endif
+
+dirCruft :: R.RawFilePath -> Bool
dirCruft "." = True
dirCruft ".." = True
dirCruft _ = False
{- Lists the contents of a directory.
- Unlike getDirectoryContents, paths are not relative to the directory. -}
-dirContents :: FilePath -> IO [FilePath]
-dirContents d = map (d </>) . filter (not . dirCruft) <$> getDirectoryContents d
+dirContents :: RawFilePath -> IO [RawFilePath]
+#ifdef WITH_OSSTRING
+dirContents d = map (\p -> d P.</> fromOsString p)
+ <$> OP.listDirectory (toOsString d)
+#else
+dirContents d =
+ map (\p -> d P.</> toRawFilePath p)
+ . filter (not . dirCruft . toRawFilePath)
+ <$> getDirectoryContents (fromRawFilePath d)
+#endif
{- Gets files in a directory, and then its subdirectories, recursively,
- and lazily.
- be accessed (the use of unsafeInterleaveIO would make it difficult to
- trap such exceptions).
-}
-dirContentsRecursive :: FilePath -> IO [FilePath]
+dirContentsRecursive :: RawFilePath -> IO [RawFilePath]
dirContentsRecursive = dirContentsRecursiveSkipping (const False) True
{- Skips directories whose basenames match the skipdir. -}
-dirContentsRecursiveSkipping :: (FilePath -> Bool) -> Bool -> FilePath -> IO [FilePath]
+dirContentsRecursiveSkipping :: (RawFilePath -> Bool) -> Bool -> RawFilePath -> IO [RawFilePath]
dirContentsRecursiveSkipping skipdir followsubdirsymlinks topdir
- | skipdir (takeFileName topdir) = return []
+ | skipdir (P.takeFileName topdir) = return []
| otherwise = do
-- Get the contents of the top directory outside of
-- unsafeInterleaveIO, which allows throwing exceptions if
where
go [] = return []
go (dir:dirs)
- | skipdir (takeFileName dir) = go dirs
+ | skipdir (P.takeFileName dir) = go dirs
| otherwise = unsafeInterleaveIO $ do
(files, dirs') <- collect [] []
=<< catchDefaultIO [] (dirContents dir)
files' <- go (dirs' ++ dirs)
return (files ++ files')
+
+ collect :: [RawFilePath] -> [RawFilePath] -> [RawFilePath] -> IO ([RawFilePath], [RawFilePath])
collect files dirs' [] = return (reverse files, reverse dirs')
collect files dirs' (entry:entries)
| dirCruft entry = collect files dirs' entries
| otherwise = do
let skip = collect (entry:files) dirs' entries
let recurse = collect files (entry:dirs') entries
- ms <- catchMaybeIO $ R.getSymbolicLinkStatus (toRawFilePath entry)
+ ms <- catchMaybeIO $ R.getSymbolicLinkStatus entry
case ms of
(Just s)
| isDirectory s -> recurse
| isSymbolicLink s && followsubdirsymlinks ->
- ifM (doesDirectoryExist entry)
+#ifdef WITH_OSSTRING
+ ifM (OP.doesDirectoryExist (toOsString entry))
+#else
+ ifM (doesDirectoryExist (fromRawFilePath entry))
+#endif
( recurse
, skip
)
- be accessed (the use of unsafeInterleaveIO would make it difficult to
- trap such exceptions).
-}
-dirTreeRecursiveSkipping :: (FilePath -> Bool) -> FilePath -> IO [FilePath]
+dirTreeRecursiveSkipping :: (RawFilePath -> Bool) -> RawFilePath -> IO [RawFilePath]
dirTreeRecursiveSkipping skipdir topdir
- | skipdir (takeFileName topdir) = return []
+ | skipdir (P.takeFileName topdir) = return []
| otherwise = do
subdirs <- filterM isdir =<< dirContents topdir
go [] subdirs
where
go c [] = return c
go c (dir:dirs)
- | skipdir (takeFileName dir) = go c dirs
+ | skipdir (P.takeFileName dir) = go c dirs
| otherwise = unsafeInterleaveIO $ do
subdirs <- go []
=<< filterM isdir
=<< catchDefaultIO [] (dirContents dir)
go (subdirs++dir:c) dirs
- isdir p = isDirectory <$> R.getSymbolicLinkStatus (toRawFilePath p)
+ isdir p = isDirectory <$> R.getSymbolicLinkStatus p
{- When the action fails due to the directory not existing, returns []. -}
emptyWhenDoesNotExist :: IO [a] -> IO [a]
import Utility.Directory
import Utility.Exception
+import Utility.FileSystemEncoding
#ifndef mingw32_HOST_OS
data DirectoryHandle = DirectoryHandle IsOpen Posix.DirStream
case v of
Nothing -> return True
Just f
- | not (dirCruft f) -> return False
+ | not (dirCruft (toRawFilePath f)) -> return False
| otherwise -> check h
import Utility.Env
import Utility.Env.Set
import Utility.Tmp
+import Utility.RawFilePath
import qualified Utility.LockFile.Posix as Posix
import System.IO
-- with the SAME FILENAME exist.
checkInsaneLustre :: RawFilePath -> IO Bool
checkInsaneLustre dest = do
- let dest' = fromRawFilePath dest
- fs <- dirContents (takeDirectory dest')
- case length (filter (== dest') fs) of
+ fs <- dirContents (P.takeDirectory dest)
+ case length (filter (== dest) fs) of
1 -> return False -- whew!
0 -> return True -- wtf?
_ -> do
-- Try to clean up the extra copy we made
-- that has the same name. Egads.
- _ <- tryIO $ removeFile dest'
+ _ <- tryIO $ removeLink dest
return True
-- | Waits as necessary to take a lock.
--- /dev/null
+{- OsString utilities
+ -
+ - Copyright 2025 Joey Hess <id@joeyh.name>
+ -
+ - License: BSD-2-clause
+ -}
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE PackageImports #-}
+{-# OPTIONS_GHC -fno-warn-tabs #-}
+
+module Utility.OsString where
+
+#ifdef WITH_OSSTRING
+
+import Utility.RawFilePath
+
+import "os-string" System.OsString.Internal.Types
+import qualified Data.ByteString.Short as S
+
+{- Unlike System.OsString.fromBytes, on Windows this does not ensure a
+ - valid USC-2LE encoding. The input ByteString must be in a valid encoding
+ - already or uses of the OsString will fail. -}
+toOsString :: RawFilePath -> OsString
+#if defined(mingw32_HOST_OS)
+toOsString = OsString . WindowsString . S.toShort
+#else
+toOsString = OsString . PosixString . S.toShort
+#endif
+
+fromOsString :: OsString -> RawFilePath
+#if defined(mingw32_HOST_OS)
+fromOsString = S.fromShort . getWindowsString . getOsString
+#else
+fromOsString = S.fromShort . getPosixString . getOsString
+#endif
+
+#endif /* WITH_OSSTRING */
But this conversion is not yet complete. This is a todo to keep track of the
status.
-* The Abstract FilePath proposal (AFPP) has been implemented, and so a number of
- libraries like directory now have versions that operate on
- OSPath. That could be used in git-annex eg for things like
- getDirectoryContents, when built against those versions.
- (OSPath uses ShortByteString, while RawFilePath is ByteString, so
- conversion still entails a copy, eg using
- `System.OsString.Internal.fromBytes`)
* unix has modules that operate on RawFilePath but no OSPath versions yet.
See https://github.com/haskell/unix/issues/240
* filepath-1.4.100 implements support for OSPath. It is bundled with
Flag Servant
Description: Use the servant library, enabling using annex+http urls and git-annex p2phttp
+Flag OsString
+ Description: Use the os-string library
+
Flag Benchmark
Description: Enable benchmarking
Default: True
P2P.Http.Server
P2P.Http.State
+ if flag(OsString)
+ Build-Depends:
+ os-string (>= 2.0.0),
+ directory (>= 1.3.8.3),
+ filepath (>= 1.5.2.0)
+ CPP-Options: -DWITH_OSSTRING
+
if (os(windows))
Build-Depends:
Win32 ((>= 2.6.1.0 && < 2.12.0.0) || >= 2.13.4.0),
Utility.OpenFile
Utility.OptParse
Utility.OSX
+ Utility.OsString
Utility.PID
Utility.PartialPrelude
Utility.Path
benchmark: true
crypton: true
servant: true
+ osstring: true
packages:
- '.'
-resolver: lts-23.2
+resolver: nightly-2025-01-20
extra-deps:
- filepath-bytestring-1.4.100.3.2
+- aws-0.24.3
+- feed-1.3.2.1
+- git-lfs-1.2.2
+allow-newer: true
+allow-newer-deps:
+- filepath-bytestring
+- aws
+- feed
projects / git-annex.git / commitdiff