diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -226,6 +226,7 @@ , cachedgitenv :: Maybe (AltIndexFile, OsPath, [(String, String)]) , urloptions :: Maybe UrlOptions , insmudgecleanfilter :: Bool + , inreconcilestaged :: Bool , getvectorclock :: IO CandidateVectorClock , proxyremote :: Maybe (Either ClusterUUID (Types.Remote.RemoteA Annex)) , reposizehandle :: Maybe RepoSizeHandle @@ -283,6 +284,7 @@ , cachedgitenv = Nothing , urloptions = Nothing , insmudgecleanfilter = False + , inreconcilestaged = False , getvectorclock = vc , proxyremote = Nothing , reposizehandle = Nothing diff --git a/Annex/Balanced.hs b/Annex/Balanced.hs --- a/Annex/Balanced.hs +++ b/Annex/Balanced.hs @@ -12,11 +12,10 @@ import Utility.Hash import Data.Maybe +import Data.List 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] diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -276,8 +276,7 @@ winLocker takelock _ (Just lockfile) = let lck = do modifyContentDir lockfile $ - void $ liftIO $ tryIO $ - writeFile (fromOsPath lockfile) "" + void $ liftIO $ tryIO $ writeFileString lockfile "" liftIO $ takelock lockfile in (lck, Nothing) -- never reached; windows always uses a separate lock file @@ -543,7 +542,7 @@ unless (null fs) $ do destic <- withTSDelta $ liftIO . genInodeCache dest - ics <- mapM (populatePointerFile (Restage True) key dest) fs + ics <- mapM (populatePointerFile QueueRestage key dest) fs Database.Keys.addInodeCaches key (catMaybes (destic:ics)) ) @@ -785,7 +784,7 @@ resetpointer file = unlessM (liftIO $ isSymbolicLink <$> R.getSymbolicLinkStatus (fromOsPath file)) $ ifM (isUnmodified key file) ( adjustedBranchRefresh $ - depopulatePointerFile key file + depopulatePointerFile QueueRestage key file -- Modified file, so leave it alone. -- If it was a hard link to the annex object, -- that object might have been frozen as part of the @@ -991,7 +990,7 @@ -- clean up gitAnnexTmpWorkDir for those it finds. obj <- prepTmp key unlessM (liftIO $ doesFileExist obj) $ do - liftIO $ writeFile (fromOsPath obj) "" + liftIO $ writeFileString obj "" setAnnexFilePerm obj let tmpdir = gitAnnexTmpWorkDir obj createAnnexDirectory tmpdir @@ -1083,7 +1082,7 @@ readContentRetentionTimestamp rt >>= \case Just ts | ts >= t -> return () _ -> replaceFile (const noop) rt $ \tmp -> - liftIO $ writeFile (fromOsPath tmp) $ show t + liftIO $ writeFileString tmp $ show t where lock = takeExclusiveLock unlock = liftIO . dropLock diff --git a/Annex/Content/PointerFile.hs b/Annex/Content/PointerFile.hs --- a/Annex/Content/PointerFile.hs +++ b/Annex/Content/PointerFile.hs @@ -52,8 +52,8 @@ {- Removes the content from a pointer file, replacing it with a pointer. - - Does not check if the pointer file is modified. -} -depopulatePointerFile :: Key -> OsPath -> Annex () -depopulatePointerFile key file = do +depopulatePointerFile :: Restage -> Key -> OsPath -> Annex () +depopulatePointerFile restage key file = do st <- liftIO $ catchMaybeIO $ R.getFileStatus (fromOsPath file) let mode = fmap fileMode st secureErase file @@ -68,4 +68,4 @@ (fmap Posix.modificationTimeHiRes st) #endif withTSDelta (liftIO . genInodeCache tmp) - maybe noop (restagePointerFile (Restage True) file) ic + maybe noop (restagePointerFile restage file) ic diff --git a/Annex/Fixup.hs b/Annex/Fixup.hs --- a/Annex/Fixup.hs +++ b/Annex/Fixup.hs @@ -1,6 +1,6 @@ {- git-annex repository fixups - - - Copyright 2013-2020 Joey Hess + - Copyright 2013-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -9,29 +9,14 @@ module Annex.Fixup where +import Common import Git.Types import Git.Config import Types.GitConfig -import Utility.Path -import Utility.Path.AbsRel -import Utility.SafeCommand -import Utility.Directory -import Utility.Exception -import Utility.Monad -import Utility.SystemDirectory -import Utility.OsPath import qualified Utility.RawFilePath as R -import Utility.PartialPrelude import qualified Utility.OsString as OS -import System.IO -import Data.List -import Data.Maybe -import Control.Monad -import Control.Monad.IfElse import qualified Data.Map as M -import Control.Applicative -import Prelude fixupRepo :: Repo -> GitConfig -> IO Repo fixupRepo r c = do @@ -132,11 +117,11 @@ -- git-worktree sets up a "commondir" file that contains -- the path to the main git directory. -- Using --separate-git-dir does not. - commondirfile = fromOsPath (d literalOsPath "commondir") + commondirfile = d literalOsPath "commondir" readcommondirfile = catchDefaultIO Nothing $ fmap toOsPath . headMaybe . lines - <$> readFile commondirfile + <$> readFileString commondirfile setworktreepath r' = readcommondirfile >>= \case Just gd -> return $ r' diff --git a/Annex/Import.hs b/Annex/Import.hs --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -21,6 +21,7 @@ importKeys, makeImportMatcher, getImportableContents, + PostExportLogUpdate, ) where import Annex.Common @@ -112,8 +113,9 @@ -> ImportCommitConfig -> AddUnlockedMatcher -> Imported + -> PostExportLogUpdate -> Annex (Maybe Ref) -buildImportCommit remote importtreeconfig importcommitconfig addunlockedmatcher imported = +buildImportCommit remote importtreeconfig importcommitconfig addunlockedmatcher imported postexportlogupdate = case importCommitTracking importcommitconfig of Nothing -> go Nothing Just trackingcommit -> inRepo (Git.Ref.tree trackingcommit) >>= \case @@ -121,12 +123,14 @@ Just _ -> go (Just trackingcommit) where go trackingcommit = do - (importedtree, updatestate) <- recordImportTree remote importtreeconfig (Just addunlockedmatcher) imported + (importedtree, updatestate) <- recordImportTree remote importtreeconfig (Just addunlockedmatcher) imported postexportlogupdate buildImportCommit' remote importcommitconfig trackingcommit importedtree >>= \case Just finalcommit -> do updatestate return (Just finalcommit) - Nothing -> return Nothing + Nothing -> do + postExportLogUpdate postexportlogupdate + return Nothing {- Builds a tree for an import from a special remote. - @@ -138,8 +142,9 @@ -> ImportTreeConfig -> Maybe AddUnlockedMatcher -> Imported + -> PostExportLogUpdate -> Annex (History Sha, Annex ()) -recordImportTree remote importtreeconfig addunlockedmatcher imported = do +recordImportTree remote importtreeconfig addunlockedmatcher imported postexportlogupdate = do importedtree@(History finaltree _) <- buildImportTrees basetree subdir addunlockedmatcher imported return (importedtree, updatestate finaltree) where @@ -180,6 +185,7 @@ { oldTreeish = exportedTreeishes oldexport , newTreeish = importedtree } + postExportLogUpdate postexportlogupdate return oldexport -- importKeys takes care of updating the location log @@ -498,12 +504,27 @@ where ia = Remote.importActions remote --- Result of an import. ImportUnfinished indicates that some file failed to --- be imported. Running again should resume where it left off. +-- Result of an import. data ImportResult t - = ImportFinished t + = ImportFinished PostExportLogUpdate t | ImportUnfinished + -- ^ ImportUnfinished indicates that some file failed to + -- be imported. Running again should resume where it left off. +-- An action to run after the export log has been updated to reflect an +-- import. +newtype PostExportLogUpdate = PostExportLogUpdate (Annex ()) + +instance Semigroup PostExportLogUpdate where + PostExportLogUpdate a <> PostExportLogUpdate b = + PostExportLogUpdate (a >> b) + +noPostExportLogUpdate :: PostExportLogUpdate +noPostExportLogUpdate = PostExportLogUpdate (return ()) + +postExportLogUpdate :: PostExportLogUpdate -> Annex () +postExportLogUpdate (PostExportLogUpdate a) = a + data Diffed t = DiffChanged t | DiffRemoved @@ -546,7 +567,10 @@ Nothing -> fullimport currcidtree Just lastimportedtree -> diffimport cidtreemap prevcidtree currcidtree lastimportedtree where - remember = recordContentIdentifierTree (Remote.uuid remote) + -- Record the content identifier tree after the export log is + -- updated for the import. + remember = PostExportLogUpdate . + recordContentIdentifierTree (Remote.uuid remote) -- In order to use a diff, the previous ContentIdentifier tree must -- not have been garbage collected. Which can happen since there @@ -567,11 +591,11 @@ ) fullimport currcidtree = - importKeys remote importtreeconfig importcontent thirdpartypopulated importablecontents >>= \case - ImportUnfinished -> return ImportUnfinished - ImportFinished r -> do - remember currcidtree - return $ ImportFinished $ ImportedFull r + importKeys remote importtreeconfig importcontent thirdpartypopulated importablecontents >>= return . \case + ImportUnfinished -> ImportUnfinished + ImportFinished a r -> + ImportFinished (a <> remember currcidtree) $ + ImportedFull r diffimport cidtreemap prevcidtree currcidtree lastimportedtree = do (diff, cleanup) <- inRepo $ Git.DiffTree.diffTreeRecursive @@ -589,17 +613,15 @@ ImportUnfinished -> do void $ liftIO cleanup return ImportUnfinished - ImportFinished (ImportableContentsComplete ic') -> - liftIO cleanup >>= \case - False -> return ImportUnfinished - True -> do - remember currcidtree - return $ ImportFinished $ - ImportedDiff lastimportedtree - (mkdiff ic' removed) + ImportFinished a (ImportableContentsComplete ic') -> + liftIO cleanup >>= return . \case + False -> ImportUnfinished + True -> ImportFinished (a <> remember currcidtree) $ + ImportedDiff lastimportedtree + (mkdiff ic' removed) -- importKeys is not passed ImportableContentsChunked -- above, so it cannot return it - ImportFinished (ImportableContentsChunked {}) -> error "internal" + ImportFinished _ (ImportableContentsChunked {}) -> error "internal" isremoval ti = Git.DiffTree.dstsha ti `elem` nullShas @@ -685,12 +707,12 @@ ImportableContentsComplete ic -> go False largematcher cidmap importing db ic >>= return . \case Nothing -> ImportUnfinished - Just v -> ImportFinished $ ImportableContentsComplete v + Just v -> ImportFinished noPostExportLogUpdate $ ImportableContentsComplete v ImportableContentsChunked {} -> do c <- gochunked db (importableContentsChunk importablecontents) gohistory largematcher cidmap importing db (importableHistoryComplete importablecontents) >>= return . \case Nothing -> ImportUnfinished - Just h -> ImportFinished $ ImportableContentsChunked + Just h -> ImportFinished noPostExportLogUpdate $ ImportableContentsChunked { importableContentsChunk = c , importableHistoryComplete = h } diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -172,7 +172,7 @@ {- Ingests a locked down file into the annex. Does not update the working - tree or the index. -} ingest :: MeterUpdate -> Maybe LockedDown -> Maybe Key -> Annex (Maybe Key, Maybe InodeCache) -ingest meterupdate ld mk = ingest' Nothing meterupdate ld mk (Restage True) +ingest meterupdate ld mk = ingest' Nothing meterupdate ld mk QueueRestage ingest' :: Maybe Backend -> MeterUpdate -> Maybe LockedDown -> Maybe Key -> Restage -> Annex (Maybe Key, Maybe InodeCache) ingest' _ _ Nothing _ _ = return (Nothing, Nothing) @@ -228,7 +228,7 @@ finishIngestUnlocked :: Key -> KeySource -> Annex () finishIngestUnlocked key source = do cleanCruft source - finishIngestUnlocked' key source (Restage True) Nothing + finishIngestUnlocked' key source QueueRestage Nothing finishIngestUnlocked' :: Key -> KeySource -> Restage -> Maybe LinkAnnexResult -> Annex () finishIngestUnlocked' key source restage lar = do diff --git a/Annex/Link.hs b/Annex/Link.hs --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -7,7 +7,7 @@ - - Pointer files are used instead of symlinks for unlocked files. - - - Copyright 2013-2022 Joey Hess + - Copyright 2013-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -32,6 +32,7 @@ import Annex.HashObject import Annex.InodeSentinal import Annex.PidLock +import Types.CleanupActions import Utility.FileMode import Utility.InodeCache import Utility.Tmp.Dir @@ -44,8 +45,10 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L + #ifndef mingw32_HOST_OS #if MIN_VERSION_unix(2,8,0) +import Utility.OpenFd #else import System.PosixCompat.Files (isSymbolicLink) #endif @@ -159,7 +162,10 @@ F.writeFile' file (formatPointer k) maybe noop (R.setFileMode (fromOsPath file)) mode -newtype Restage = Restage Bool +data Restage + = NoRestage + | QueueRestage + | LaterRestage {- Restage pointer file. This is used after updating a worktree file - when content is added/removed, to prevent git status from showing @@ -183,26 +189,27 @@ - and will store it in the restage log. Displays a message to help the - user understand why the file will appear to be modified. - - - This uses the git queue, so the update is not performed immediately, - - and this can be run multiple times cheaply. Using the git queue also - - prevents building up too large a number of updates when many files - - are being processed. It's also recorded in the restage log so that, - - if the process is interrupted before the git queue is fulushed, the - - restage will be taken care of later. + - The update is not performed immediately, so and this can be run multiple + - times cheaply. It's also recorded in the restage log so that, if the + - process is interrupted before the git queue is fulushed, the restage + - will be taken care of later. -} restagePointerFile :: Restage -> OsPath -> InodeCache -> Annex () -restagePointerFile (Restage False) f orig = do +restagePointerFile NoRestage f orig = do flip writeRestageLog orig =<< inRepo (toTopFilePath f) toplevelWarning True $ unableToRestage $ Just f -restagePointerFile (Restage True) f orig = do +{- Using the git queue prevents building up too large a number of updates + - when many files are being processed. -} +restagePointerFile QueueRestage f orig = do flip writeRestageLog orig =<< inRepo (toTopFilePath f) - -- Avoid refreshing the index if run by the - -- smudge clean filter, because git uses that when - -- it's already refreshing the index, probably because - -- this very action is running. Running it again would likely - -- deadlock. unlessM (Annex.getState Annex.insmudgecleanfilter) $ Annex.Queue.addFlushAction restagePointerFileRunner [f] +{- Defer the restage until the end. -} +restagePointerFile LaterRestage f orig = do + flip writeRestageLog orig =<< inRepo (toTopFilePath f) + unlessM (Annex.getState Annex.insmudgecleanfilter) $ + Annex.addCleanupAction RestagePointerFiles $ + restagePointerFiles =<< Annex.gitRepo restagePointerFileRunner :: Git.Queue.FlushActionRunner Annex restagePointerFileRunner = @@ -218,7 +225,7 @@ -- to bypass the lock. Then replace the old index file with the new -- updated index file. restagePointerFiles :: Git.Repo -> Annex () -restagePointerFiles r = unlessM (Annex.getState Annex.insmudgecleanfilter) $ do +restagePointerFiles r = checkcanrun $ do -- Flush any queued changes to the keys database, so they -- are visible to child processes. -- The database is closed because that may improve behavior @@ -329,6 +336,9 @@ ck = ConfigKey "filter.annex.process" ckd = ConfigKey "filter.annex.process-temp-disabled" + checkcanrun a = unlessM (Annex.getState Annex.insmudgecleanfilter) $ + unlessM (Annex.getState Annex.inreconcilestaged) $ a + unableToRestage :: Maybe OsPath -> StringContainingQuotedPath unableToRestage mf = "git status will show " <> maybe "some files" QuotedPath mf @@ -447,8 +457,9 @@ #else #if MIN_VERSION_unix(2,8,0) let open = do - fd <- openFd (fromOsPath f) ReadOnly + fd <- openFdWithMode (fromOsPath f) ReadOnly Nothing (defaultFileFlags { nofollow = True }) + (CloseOnExecFlag True) fdToHandle fd in bracket open hClose readhandle #else diff --git a/Annex/Locations.hs b/Annex/Locations.hs --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -47,7 +47,6 @@ gitAnnexUnusedLog, gitAnnexKeysDbDir, gitAnnexKeysDbLock, - gitAnnexKeysDbIndexCache, gitAnnexFsckState, gitAnnexFsckDbDir, gitAnnexFsckDbDirOld, @@ -410,11 +409,6 @@ {- Lock file for the keys database. -} gitAnnexKeysDbLock :: Git.Repo -> GitConfig -> OsPath gitAnnexKeysDbLock r c = gitAnnexKeysDbDir r c <> literalOsPath ".lck" - -{- Contains the stat of the last index file that was - - reconciled with the keys database. -} -gitAnnexKeysDbIndexCache :: Git.Repo -> GitConfig -> OsPath -gitAnnexKeysDbIndexCache r c = gitAnnexKeysDbDir r c <> literalOsPath ".cache" {- .git/annex/fsck/uuid/ is used to store information about incremental - fscks. -} diff --git a/Annex/MetaData/StandardFields.hs b/Annex/MetaData/StandardFields.hs --- a/Annex/MetaData/StandardFields.hs +++ b/Annex/MetaData/StandardFields.hs @@ -22,8 +22,6 @@ import Types.MetaData import qualified Data.Text as T -import Data.Monoid -import Prelude tagMetaField :: MetaField tagMetaField = mkMetaFieldUnchecked "tag" diff --git a/Annex/Multicast.hs b/Annex/Multicast.hs --- a/Annex/Multicast.hs +++ b/Annex/Multicast.hs @@ -1,18 +1,25 @@ {- git-annex multicast receive callback - - - Copyright 2017 Joey Hess + - Copyright 2017-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Annex.Multicast where import Common import Annex.Path import Utility.Env -import System.Process -import GHC.IO.Handle.FD +#ifndef mingw32_HOST_OS +import System.Posix.IO +#else +import System.Process (createPipeFd) +import GHC.IO.Handle.FD (fdToHandle) +#endif +import GHC.IO.Encoding (getLocaleEncoding) multicastReceiveEnv :: String multicastReceiveEnv = "GIT_ANNEX_MULTICAST_RECEIVE" @@ -20,9 +27,16 @@ multicastCallbackEnv :: IO (OsPath, [(String, String)], Handle) multicastCallbackEnv = do gitannex <- programPath - -- This will even work on Windows +#ifndef mingw32_HOST_OS + (rfd, wfd) <- noCreateProcessWhile $ do + (rfd, wfd) <- createPipe + setFdOption rfd CloseOnExec True + return (rfd, wfd) +#else (rfd, wfd) <- createPipeFd +#endif rh <- fdToHandle rfd + getLocaleEncoding >>= hSetEncoding rh environ <- addEntry multicastReceiveEnv (show wfd) <$> getEnvironment return (gitannex, environ, rh) @@ -35,6 +49,7 @@ runMulticastReceive ("-I":_sessionid:fs) hs = case readish hs of Just fd -> do h <- fdToHandle fd + getLocaleEncoding >>= hSetEncoding h mapM_ (hPutStrLn h) fs hClose h Nothing -> return () diff --git a/Annex/Path.hs b/Annex/Path.hs --- a/Annex/Path.hs +++ b/Annex/Path.hs @@ -65,7 +65,7 @@ readProgramFile :: IO (Maybe OsPath) readProgramFile = catchDefaultIO Nothing $ do programfile <- programFile - fmap toOsPath . headMaybe . lines <$> readFile (fromOsPath programfile) + fmap toOsPath . headMaybe . lines <$> readFileString programfile cannotFindProgram :: IO a cannotFindProgram = do diff --git a/Annex/Sim.hs b/Annex/Sim.hs --- a/Annex/Sim.hs +++ b/Annex/Sim.hs @@ -1356,16 +1356,15 @@ let st'' = st' { simRepoState = M.map freeze (simRepoState st') } - let statefile = fromOsPath $ - toOsPath (simRootDirectory st'') literalOsPath "state" - writeFile statefile (show st'') + let statefile = toOsPath (simRootDirectory st'') literalOsPath "state" + writeFileString statefile (show st'') where freeze :: SimRepoState SimRepo -> SimRepoState () freeze rst = rst { simRepo = Nothing } restoreSim :: OsPath -> IO (Either String (SimState SimRepo)) restoreSim rootdir = - tryIO (readFile statefile) >>= \case + tryIO (readFileString statefile) >>= \case Left err -> return (Left (show err)) Right c -> case readMaybe c :: Maybe (SimState ()) of Nothing -> return (Left "unable to parse sim state file") @@ -1379,7 +1378,7 @@ } return (Right st'') where - statefile = fromOsPath $ rootdir literalOsPath "state" + statefile = rootdir literalOsPath "state" thaw st (u, rst) = tryNonAsync (thaw' st u) >>= return . \case Left _ -> (u, rst { simRepo = Nothing }) Right r -> (u, rst { simRepo = Just r }) diff --git a/Annex/SpecialRemote/Config.hs b/Annex/SpecialRemote/Config.hs --- a/Annex/SpecialRemote/Config.hs +++ b/Annex/SpecialRemote/Config.hs @@ -206,13 +206,23 @@ getRemoteConfigValue f (ParsedRemoteConfig m _) = case M.lookup f m of Just (RemoteConfigValue v) -> case cast v of Just v' -> Just v' - Nothing -> error $ unwords - [ "getRemoteConfigValue" - , fromProposedAccepted f - , "found value of unexpected type" - , show (typeOf v) ++ "." - , "This is a bug in git-annex!" - ] + Nothing -> case cast v :: Maybe PassedThrough of + -- Handle the case where an external special remote + -- tries to SETCONFIG a value belonging to git-annex, + -- resulting in a PassedThrough type being stored. + Just _ -> giveup $ unwords + [ "Special remote config " + , fromProposedAccepted f + , "has been overwritten by SETCONFIG." + , "This is not supported." + ] + Nothing -> error $ unwords + [ "getRemoteConfigValue" + , fromProposedAccepted f + , "found value of unexpected type" + , show (typeOf v) ++ "." + , "This is a bug in git-annex!" + ] Nothing -> Nothing {- Gets all fields that remoteConfigRestPassthrough matched. -} diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -484,4 +484,4 @@ sshAskPassEnv = "GIT_ANNEX_SSHASKPASS" runSshAskPass :: FilePath -> IO () -runSshAskPass passfile = putStrLn =<< readFile passfile +runSshAskPass passfile = putStrLn =<< readFileString (toOsPath passfile) diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -94,7 +94,7 @@ nofiles = Left $ youtubeDlCommand ++ " did not put any media in its work directory, perhaps it's been configured to store files somewhere else?" toomanyfiles fs = Left $ youtubeDlCommand ++ " downloaded multiple media files; git-annex is only able to deal with one per url: " ++ show fs downloadedfiles = liftIO $ - (nub . lines <$> readFile (fromOsPath filelistfile)) + (nub . lines <$> readFileString filelistfile) `catchIO` (pure . const []) workdirfiles = liftIO $ filter (/= filelistfile) <$> (filterM doesFileExist =<< dirContents workdir) diff --git a/Assistant.hs b/Assistant.hs --- a/Assistant.hs +++ b/Assistant.hs @@ -56,6 +56,8 @@ #ifdef mingw32_HOST_OS import Utility.Env import System.Environment (getArgs) +#else +import GHC.IO.Encoding (getLocaleEncoding) #endif import qualified Utility.Debug as Debug @@ -82,10 +84,15 @@ let logfd = handleToFd =<< openLog (fromOsPath logfile) if foreground then do - origout <- liftIO $ catchMaybeIO $ - fdToHandle =<< dup stdOutput - origerr <- liftIO $ catchMaybeIO $ - fdToHandle =<< dup stdError + enc <- liftIO getLocaleEncoding + origout <- liftIO $ catchMaybeIO $ do + h <- fdToHandle =<< dup stdOutput + hSetEncoding h enc + return h + origerr <- liftIO $ catchMaybeIO $ do + h <- fdToHandle =<< dup stdError + hSetEncoding h enc + return h let undaemonize = Utility.Daemon.foreground logfd (Just pidfile) start undaemonize $ case startbrowser of diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -132,7 +132,7 @@ ] readDaemonStatusFile :: FilePath -> IO DaemonStatus -readDaemonStatusFile file = parse <$> newDaemonStatus <*> readFile file +readDaemonStatusFile file = parse <$> newDaemonStatus <*> readFileString (toOsPath file) where parse status = foldr parseline status . lines parseline line status diff --git a/Assistant/Gpg.hs b/Assistant/Gpg.hs --- a/Assistant/Gpg.hs +++ b/Assistant/Gpg.hs @@ -16,8 +16,6 @@ import Data.Maybe import qualified Data.Map as M -import Control.Applicative -import Prelude {- Generates a gpg user id that is not used by any existing secret key -} newUserId :: GpgCmd -> IO UserId diff --git a/Assistant/Install.hs b/Assistant/Install.hs --- a/Assistant/Install.hs +++ b/Assistant/Install.hs @@ -57,7 +57,7 @@ let program = base literalOsPath "git-annex" programfile <- programFile createDirectoryIfMissing True (parentDir programfile) - writeFile (fromOsPath programfile) (fromOsPath program) + writeFileString programfile (fromOsPath program) #ifdef darwin_HOST_OS autostartfile <- userAutoStart osxAutoStartLabel @@ -70,7 +70,7 @@ let bootfile = toOsPath home literalOsPath ".termux" literalOsPath "boot" literalOsPath "git-annex" unlessM (doesFileExist bootfile) $ do createDirectoryIfMissing True (takeDirectory bootfile) - writeFile (fromOsPath bootfile) "git-annex assistant --autostart" + writeFileString bootfile "git-annex assistant --autostart" , do menufile <- desktopMenuFilePath "git-annex" <$> userDataDir icondir <- iconDir <$> userDataDir @@ -125,7 +125,7 @@ userdata <- userDataDir let kdeServiceMenusdir = userdata literalOsPath "kservices5" literalOsPath "ServiceMenus" createDirectoryIfMissing True kdeServiceMenusdir - writeFile (fromOsPath (kdeServiceMenusdir literalOsPath "git-annex.desktop")) + writeFileString (kdeServiceMenusdir literalOsPath "git-annex.desktop") (kdeDesktopFile actions) where genNautilusScript scriptdir action = @@ -136,7 +136,7 @@ ] scriptname action = "git-annex " ++ action installscript f c = whenM (safetoinstallscript f) $ do - writeFile (fromOsPath f) c + writeFileString f c modifyFileMode f $ addModes [ownerExecuteMode] safetoinstallscript f = catchDefaultIO True $ elem (encodeBS autoaddedcomment) . fileLines' diff --git a/Assistant/Install/AutoStart.hs b/Assistant/Install/AutoStart.hs --- a/Assistant/Install/AutoStart.hs +++ b/Assistant/Install/AutoStart.hs @@ -23,7 +23,7 @@ installAutoStart command file = do #ifdef darwin_HOST_OS createDirectoryIfMissing True (parentDir file) - writeFile (fromOsPath file) $ genOSXAutoStartFile osxAutoStartLabel command + writeFileString file $ genOSXAutoStartFile osxAutoStartLabel command ["assistant", "--autostart"] #else writeDesktopMenuFile (fdoAutostart command) file diff --git a/Assistant/Install/Menu.hs b/Assistant/Install/Menu.hs --- a/Assistant/Install/Menu.hs +++ b/Assistant/Install/Menu.hs @@ -13,6 +13,7 @@ import Common import Utility.FreeDesktop +import qualified Utility.FileIO as F installMenu :: String -> OsPath -> OsPath -> OsPath -> IO () #ifdef darwin_HOST_OS @@ -40,8 +41,8 @@ installIcon :: OsPath -> OsPath -> IO () installIcon src dest = do createDirectoryIfMissing True (parentDir dest) - withBinaryFile (fromOsPath src) ReadMode $ \hin -> - withBinaryFile (fromOsPath dest) WriteMode $ \hout -> + F.withBinaryFile src ReadMode $ \hin -> + F.withBinaryFile dest WriteMode $ \hout -> hGetContents hin >>= hPutStr hout iconBaseName :: String diff --git a/Assistant/Restart.hs b/Assistant/Restart.hs --- a/Assistant/Restart.hs +++ b/Assistant/Restart.hs @@ -79,7 +79,7 @@ r <- Git.Config.read =<< Git.Construct.fromPath repo waiturl $ gitAnnexUrlFile r waiturl urlfile = do - v <- tryIO $ readFile (fromOsPath urlfile) + v <- tryIO $ readFileString urlfile case v of Left _ -> delayed $ waiturl urlfile Right url -> ifM (assistantListening url) diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -224,8 +224,8 @@ unless ok $ giveup "ssh-keygen failed" SshKeyPair - <$> readFile (fromOsPath (dir literalOsPath "key.pub")) - <*> readFile (fromOsPath (dir literalOsPath "key")) + <$> readFileString (dir literalOsPath "key.pub") + <*> readFileString (dir literalOsPath "key") {- Installs a ssh key pair, and sets up ssh config with a mangled hostname - that will enable use of the key. This way we avoid changing the user's @@ -255,7 +255,7 @@ writeFileProtected (sshdir sshPrivKeyFile sshdata) (sshPrivKey sshkeypair) unlessM (doesFileExist $ sshdir sshPubKeyFile sshdata) $ - writeFile (fromOsPath (sshdir sshPubKeyFile sshdata)) + writeFileString (sshdir sshPubKeyFile sshdata) (sshPubKey sshkeypair) setSshConfig sshdata @@ -277,8 +277,10 @@ setupSshKeyPair :: SshData -> IO (SshData, SshKeyPair) setupSshKeyPair sshdata = do sshdir <- sshDir - mprivkey <- catchMaybeIO $ readFile (fromOsPath (sshdir sshPrivKeyFile sshdata)) - mpubkey <- catchMaybeIO $ readFile (fromOsPath (sshdir sshPubKeyFile sshdata)) + mprivkey <- catchMaybeIO $ readFileString + (sshdir sshPrivKeyFile sshdata) + mpubkey <- catchMaybeIO $ readFileString + (sshdir sshPubKeyFile sshdata) keypair <- case (mprivkey, mpubkey) of (Just privkey, Just pubkey) -> return $ SshKeyPair { sshPubKey = pubkey @@ -330,15 +332,15 @@ setSshConfig sshdata config = do sshdir <- sshDir createDirectoryIfMissing True sshdir - let configfile = fromOsPath (sshdir literalOsPath "config") - unlessM (catchBoolIO $ isInfixOf mangledhost <$> readFile configfile) $ do - appendFile configfile $ unlines $ + let configfile = sshdir literalOsPath "config" + unlessM (catchBoolIO $ isInfixOf mangledhost <$> readFileString configfile) $ do + appendFileString configfile $ unlines $ [ "" , "# Added automatically by git-annex" , "Host " ++ mangledhost ] ++ map (\(k, v) -> "\t" ++ k ++ " " ++ v) (settings ++ config) - setSshConfigMode (toOsPath configfile) + setSshConfigMode configfile return $ sshdata { sshHostName = T.pack mangledhost diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -62,6 +62,11 @@ fmap Seconds . annexDelayAdd <$> Annex.getGitConfig largefilematcher <- liftAnnex largeFilesMatcher annexdotfiles <- liftAnnex $ getGitConfigVal annexDotFiles + addunlockedmatcher <- liftAnnex $ + ifM (annexSupportUnlocked <$> Annex.getGitConfig) + ( Just <$> addUnlockedMatcher + , return Nothing + ) msg <- liftAnnex Command.Sync.commitMsg lockdowndir <- liftAnnex $ fromRepo gitAnnexTmpWatcherDir liftAnnex $ do @@ -70,7 +75,7 @@ void $ liftIO $ tryIO $ removeDirectoryRecursive lockdowndir void $ createAnnexDirectory lockdowndir waitChangeTime $ \(changes, time) -> do - readychanges <- handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd $ + readychanges <- handleAdds lockdowndir havelsof largefilematcher annexdotfiles addunlockedmatcher delayadd $ simplifyChanges changes if shouldCommit False time (length readychanges) readychanges then do @@ -275,8 +280,8 @@ - Any pending adds that are not ready yet are put back into the ChangeChan, - where they will be retried later. -} -handleAdds :: OsPath -> Bool -> GetFileMatcher -> Bool -> Maybe Seconds -> [Change] -> Assistant [Change] -handleAdds lockdowndir havelsof largefilematcher annexdotfiles delayadd cs = returnWhen (null incomplete) $ do +handleAdds :: OsPath -> Bool -> GetFileMatcher -> Bool -> Maybe AddUnlockedMatcher -> Maybe Seconds -> [Change] -> Assistant [Change] +handleAdds lockdowndir havelsof largefilematcher annexdotfiles addunlockedmatcher delayadd cs = returnWhen (null incomplete) $ do let (pending, inprocess) = partition isPendingAddChange incomplete let lockdownconfig = LockDownConfig { lockingFile = False @@ -340,9 +345,9 @@ Command.Add.addFile Command.Add.Small f =<< liftIO (R.getSymbolicLinkStatus (fromOsPath f)) - {- Avoid overhead of re-injesting a renamed unlocked file, by - - examining the other Changes to see if a removed file has the - - same InodeCache as the new file. If so, we can just update + {- When adding the file unlocked, avoid overhead of re-injesting a renamed + - unlocked file, by examining the other Changes to see if a removed + - file has the same InodeCache as the new file. If so, we can just update - bookkeeping, and stage the file in git. -} addannexed :: [Change] -> Assistant [Maybe Change] @@ -357,18 +362,36 @@ , checkWritePerms = True } if M.null m - then forM toadd (addannexed' cfg) + then forM toadd $ \c -> do + mcache <- liftIO $ genInodeCache (changeFile c) delta + addunlocked <- checkaddunlocked c + addannexed' cfg c addunlocked mcache else forM toadd $ \c -> do mcache <- liftIO $ genInodeCache (changeFile c) delta - case mcache of - Nothing -> addannexed' cfg c - Just cache -> - case M.lookup (inodeCacheToKey ct cache) m of - Nothing -> addannexed' cfg c - Just k -> fastadd c k + ifM (checkaddunlocked c) + ( case mcache of + Nothing -> addannexed' cfg c True Nothing + Just cache -> + case M.lookup (inodeCacheToKey ct cache) m of + Nothing -> addannexed' cfg c True Nothing + Just k -> fastadd c k + , addannexed' cfg c False mcache + ) - addannexed' :: LockDownConfig -> Change -> Assistant (Maybe Change) - addannexed' lockdownconfig change@(InProcessAddChange { lockedDown = ld }) = + checkaddunlocked (InProcessAddChange { lockedDown = ld }) = + case addunlockedmatcher of + Just addunlockedmatcher' -> do + let mi = MatchingFile $ FileInfo + { contentFile = contentLocation (keySource ld) + , matchFile = keyFilename (keySource ld) + , matchKey = Nothing + } + liftAnnex $ addUnlocked addunlockedmatcher' mi True + Nothing -> return True + checkaddunlocked _ = return True + + addannexed' :: LockDownConfig -> Change -> Bool -> Maybe InodeCache -> Assistant (Maybe Change) + addannexed' lockdownconfig change@(InProcessAddChange { lockedDown = ld }) addunlocked mcache = catchDefaultIO Nothing <~> doadd where ks = keySource ld @@ -376,14 +399,14 @@ (mkey, _mcache) <- liftAnnex $ do showStartMessage (StartMessage "add" (ActionItemOther (Just (QuotedPath (keyFilename ks)))) (SeekInput [])) ingest nullMeterUpdate (Just $ LockedDown lockdownconfig ks) Nothing - maybe (failedingest change) (done change $ keyFilename ks) mkey - addannexed' _ _ = return Nothing + maybe (failedingest change) (done change addunlocked mcache $ keyFilename ks) mkey + addannexed' _ _ _ _ = return Nothing fastadd :: Change -> Key -> Assistant (Maybe Change) fastadd change key = do let source = keySource $ lockedDown change liftAnnex $ finishIngestUnlocked key source - done change (keyFilename source) key + done change True Nothing (keyFilename source) key removedKeysMap :: InodeComparisonType -> [Change] -> Annex (M.Map InodeCacheKey Key) removedKeysMap ct l = do @@ -399,11 +422,14 @@ liftAnnex showEndFail return Nothing - done change file key = liftAnnex $ do + done change addunlocked mcache file key = liftAnnex $ do logStatus NoLiveUpdate key InfoPresent - mode <- liftIO $ catchMaybeIO $ - fileMode <$> R.getFileStatus (fromOsPath file) - stagePointerFile file mode =<< hashPointerFile key + if addunlocked + then do + mode <- liftIO $ catchMaybeIO $ + fileMode <$> R.getFileStatus (fromOsPath file) + stagePointerFile file mode =<< hashPointerFile key + else addSymlink file key mcache showEndOk return $ Just $ finishedChange change key diff --git a/Assistant/Types/BranchChange.hs b/Assistant/Types/BranchChange.hs --- a/Assistant/Types/BranchChange.hs +++ b/Assistant/Types/BranchChange.hs @@ -8,8 +8,6 @@ module Assistant.Types.BranchChange where import Control.Concurrent.MSampleVar -import Control.Applicative -import Prelude newtype BranchChangeHandle = BranchChangeHandle (MSampleVar ()) diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -160,7 +160,7 @@ unlessM (boolSystem (fromOsPath program) [Param "version"]) $ giveup "New git-annex program failed to run! Not using." pf <- programFile - liftIO $ writeFile (fromOsPath pf) (fromOsPath program) + liftIO $ writeFileString pf (fromOsPath program) #ifdef darwin_HOST_OS {- OS X uses a dmg, so mount it, and copy the contents into place. -} @@ -281,7 +281,7 @@ deleteFromManifest :: OsPath -> IO () deleteFromManifest dir = do fs <- map (\f -> dir toOsPath f) . lines - <$> catchDefaultIO "" (readFile (fromOsPath manifest)) + <$> catchDefaultIO "" (readFileString manifest) mapM_ (removeWhenExistsWith removeFile) fs removeWhenExistsWith removeFile manifest removeEmptyRecursive dir diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -185,7 +185,7 @@ where addignore = do liftIO $ unlessM (doesFileExist $ literalOsPath ".gitignore") $ - writeFile ".gitignore" ".thumbnails" + writeFileString (literalOsPath ".gitignore") ".thumbnails" void $ inRepo $ Git.Command.runBool [Param "add", File ".gitignore"] diff --git a/Assistant/WebApp/Control.hs b/Assistant/WebApp/Control.hs --- a/Assistant/WebApp/Control.hs +++ b/Assistant/WebApp/Control.hs @@ -74,5 +74,5 @@ getLogR = page "Logs" Nothing $ do logfile <- liftAnnex $ fromRepo gitAnnexDaemonLogFile logs <- liftIO $ listLogs (fromOsPath logfile) - logcontent <- liftIO $ concat <$> mapM readFile logs + logcontent <- liftIO $ concat <$> mapM (readFileString . toOsPath) logs $(widgetFile "control/log") diff --git a/Assistant/WebApp/Documentation.hs b/Assistant/WebApp/Documentation.hs --- a/Assistant/WebApp/Documentation.hs +++ b/Assistant/WebApp/Documentation.hs @@ -34,7 +34,7 @@ Just f -> customPage (Just About) $ do -- no sidebar, just pages of legalese.. setTitle "License" - license <- liftIO $ readFile (fromOsPath f) + license <- liftIO $ readFileString f $(widgetFile "documentation/license") getRepoGroupR :: Handler Html diff --git a/Build/Configure.hs b/Build/Configure.hs --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -12,10 +12,9 @@ import qualified Git.Version import Utility.SystemDirectory import Utility.OsPath +import qualified Utility.FileIO as F import Control.Monad -import Control.Applicative -import Prelude tests :: [TestCase] tests = @@ -93,7 +92,7 @@ setup :: IO () setup = do createDirectoryIfMissing True (toOsPath tmpDir) - writeFile testFile "test file contents" + F.writeFileString (toOsPath testFile) "test file contents" cleanup :: IO () cleanup = removeDirectoryRecursive (toOsPath tmpDir) diff --git a/Build/DesktopFile.hs b/Build/DesktopFile.hs --- a/Build/DesktopFile.hs +++ b/Build/DesktopFile.hs @@ -22,7 +22,6 @@ import System.Environment #ifndef mingw32_HOST_OS import System.Posix.User -import Prelude #endif systemwideInstall :: IO Bool @@ -74,7 +73,7 @@ , do programfile <- inDestDir =<< programFile createDirectoryIfMissing True (parentDir programfile) - writeFile (fromOsPath programfile) command + writeFileString programfile command ) installUser :: FilePath -> IO () diff --git a/Build/Mans.hs b/Build/Mans.hs --- a/Build/Mans.hs +++ b/Build/Mans.hs @@ -1,6 +1,6 @@ {- Build man pages. - - - Copyright 2016 Joey Hess + - Copyright 2016-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -9,16 +9,14 @@ module Build.Mans where +import Utility.Process import System.Directory import System.FilePath import Data.List import Control.Monad -import System.Process import System.Exit import Data.Maybe import Utility.Exception -import Control.Applicative -import Prelude buildMansOrWarn :: IO () buildMansOrWarn = do @@ -37,15 +35,17 @@ destm <- catchMaybeIO $ getModificationTime dest if (Just srcm > destm) then do - r <- system $ unwords - -- Run with per because in some + (Nothing, Nothing, Nothing, pid) <- createProcess $ shell $ unwords $ + -- Run with perl because in some -- cases it may not be executable. - [ "perl", "./Build/mdwn2man" + [ "perl" + , "./Build/mdwn2man" , progName src , "1" , src , "> " ++ dest ] + r <- waitForProcess pid if r == ExitSuccess then return (Just dest) else return Nothing diff --git a/Build/TestConfig.hs b/Build/TestConfig.hs --- a/Build/TestConfig.hs +++ b/Build/TestConfig.hs @@ -1,6 +1,7 @@ {- Tests the system and generates SysConfig. -} {-# OPTIONS_GHC -fno-warn-tabs #-} +{-# LANGUAGE OverloadedStrings #-} module Build.TestConfig where @@ -9,6 +10,7 @@ import Utility.SafeCommand import Utility.SystemDirectory import Utility.OsPath +import qualified Utility.FileIO as F import System.IO @@ -42,7 +44,7 @@ valuetype (MaybeBoolConfig _) = "Maybe Bool" writeSysConfig :: [Config] -> IO () -writeSysConfig config = writeFile "Build/SysConfig" body +writeSysConfig config = F.writeFileString (literalOsPath "Build/SysConfig") body where body = unlines $ header ++ map show config ++ footer header = [ @@ -100,12 +102,16 @@ ifM (inSearchPath command) ( return $ Config k $ MaybeStringConfig $ Just command , do - r <- getM find ["/usr/sbin", "/sbin", "/usr/local/sbin"] + r <- getM find + [ literalOsPath "/usr/sbin" + , literalOsPath "/sbin" + , literalOsPath "/usr/local/sbin" + ] return $ Config k $ MaybeStringConfig r ) where find d = - let f = toOsPath d toOsPath command + let f = d toOsPath command in ifM (doesFileExist f) ( return (Just (fromOsPath f)) , return Nothing diff --git a/Build/Version.hs b/Build/Version.hs --- a/Build/Version.hs +++ b/Build/Version.hs @@ -8,14 +8,12 @@ import Data.List import System.Environment import Data.Char -import System.Process -import Control.Applicative -import Prelude import Utility.Monad import Utility.Exception import Utility.OsPath import Utility.FileSystemEncoding +import Utility.Process import qualified Utility.FileIO as F type Version = String @@ -39,7 +37,7 @@ gitversion <- takeWhile (\c -> isAlphaNum c) <$> readProcess "sh" [ "-c" , "git log -n 1 --format=format:'%H'" - ] "" + ] return $ if null gitversion then changelogversion else concat @@ -51,7 +49,7 @@ getChangelogVersion :: IO Version getChangelogVersion = do - changelog <- readFile "CHANGELOG" + changelog <- F.readFileString (literalOsPath "CHANGELOG") let verline = takeWhile (/= '\n') changelog return $ middle (words verline !! 1) where diff --git a/BuildFlags.hs b/BuildFlags.hs --- a/BuildFlags.hs +++ b/BuildFlags.hs @@ -69,6 +69,11 @@ , "Testsuite" , "S3" , "WebDAV" +#ifdef WITH_OSPATH + , "OsPath" +#else +#warning Building without the OsPath build flag set results in slower filename manipulation and is not recommended. +#endif ] -- Not a complete list, let alone a listing transitive deps, but only @@ -80,11 +85,7 @@ , ("bloomfilter", VERSION_bloomfilter) , ("http-client", VERSION_http_client) , ("persistent-sqlite", VERSION_persistent_sqlite) -#ifdef WITH_CRYPTON , ("crypton", VERSION_crypton) -#else - , ("cryptonite", VERSION_cryptonite) -#endif , ("aws", VERSION_aws) , ("DAV", VERSION_DAV) #ifdef WITH_TORRENTPARSER diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,35 @@ +git-annex (10.20250925) upstream; urgency=medium + + * Fix bug that made changes to a special remote sometimes be missed when + importing a tree from it. After upgrading, any such missed changes + will be included in the next tree imported from a special remote. + Fixes reversion introduced in version 10.20230626. + * Fix crash operating on filenames that are exactly 21 bytes long + and begin with a utf-8 character. + * Fix hang that could occur when using git-annex adjust on a branch with + a number of files greater than annex.queuesize. + * Fix bug that could cause an invalid utf-8 sequence to be used in a + temporary filename when the input filename was valid utf-8. + * Improve performance when used with a local git remote that has a + large working tree. + * drop: --fast support when dropping from a remote. + * Added annex.assistant.allowunlocked config. + * Add git-remote-p2p-annex and git-remote-tor-annex to standalone builds. + * enableremote: Disallow using type= to attempt to change the type of an + existing remote. + * Add build warnings when git-annex is built without the OsPath + build flag. + * version: Report on whether it was built with the OsPath build flag. + * Avoid leaking file descriptors to child processes started by git-annex + in some situations. Note that when not built with the OsPath build + flag, these leaks can still happen. + * git-annex.cabal: Turn on the OsPath build flag by default. + * p2phttp: Fix a hang that could occur when used with --directory, + and a repository in the directory got removed. + * Removed support for building with unmaintained cryptonite, use crypton. + + -- Joey Hess Thu, 25 Sep 2025 13:20:38 -0400 + git-annex (10.20250828) upstream; urgency=medium * p2p: Added --enable option, which can be used to enable P2P networks diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -42,6 +42,11 @@ 2007-2015 Bryan O'Sullivan License: BSD-3-clause +Files: Utility/FileIO/CloseOnExec.hs +Copyright: 2025 Joey Hess + 2024 Julian Ospald +License: BSD-3-clause + Files: Utility/Matcher.hs Utility/Tor.hs Utility/Yesod.hs Copyright: © 2010-2023 Joey Hess License: AGPL-3+ @@ -144,7 +149,7 @@ notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. . - 3. Neither the name of the author nor the names of his contributors + 3. Neither the name of the author nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. . diff --git a/Command/Drop.hs b/Command/Drop.hs --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2010-2021 Joey Hess + - Copyright 2010-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -109,8 +109,17 @@ performLocal lu pcc key afile numcopies mincopies preverified ud startRemote :: LiveUpdate -> PreferredContentChecked -> AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> MinCopies -> Key -> DroppingUnused -> Remote -> CommandStart -startRemote lu pcc afile ai si numcopies mincopies key ud remote = - starting "drop" (OnlyActionOn key ai) si $ do +startRemote lu pcc afile ai si numcopies mincopies key ud remote = do + fast <- Annex.getRead Annex.fast + if fast + then do + remotes <- Remote.keyPossibilities (Remote.IncludeIgnored True) key + if remote `elem` remotes + then go + else stop + else go + where + go = starting "drop" (OnlyActionOn key ai) si $ do showAction $ UnquotedString $ "from " ++ Remote.name remote performRemote lu pcc key afile numcopies mincopies remote ud diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -59,8 +59,11 @@ start o (name:rest) = go =<< filter matchingname <$> Annex.getGitRemotes where matchingname r = Git.remoteName r == Just name - go [] = deadLast name $ - startSpecialRemote o name (Logs.Remote.keyValToConfig Proposed rest) + go [] = deadLast name $ + let config = Logs.Remote.keyValToConfig Proposed rest + in case M.lookup SpecialRemote.typeField config of + Nothing -> startSpecialRemote o name config + Just _ -> giveup "Cannot change type= of existing special remote. Instead, use: git-annex initremote --sameas" go (r:_) | not (null rest) = go [] | otherwise = do diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -178,7 +178,7 @@ runFuzzAction (FuzzAdd (FuzzFile f)) = do createWorkTreeDirectory (parentDir (toOsPath f)) n <- liftIO (getStdRandom random :: IO Int) - liftIO $ writeFile f $ show n ++ "\n" + liftIO $ writeFileString (toOsPath f) $ show n ++ "\n" runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $ removeWhenExistsWith removeFile (toOsPath f) runFuzzAction (FuzzMove (FuzzFile src) (FuzzFile dest)) = liftIO $ diff --git a/Command/Import.hs b/Command/Import.hs --- a/Command/Import.hs +++ b/Command/Import.hs @@ -349,9 +349,9 @@ , Remote.name remote , ". Re-run command to resume import." ] - ImportFinished imported -> void $ - includeCommandAction $ - commitimport imported + ImportFinished postexportlogupdate imported -> + void $ includeCommandAction $ + commitimport imported postexportlogupdate where importmessages' | null importmessages = ["import from " ++ Remote.name remote] @@ -383,10 +383,10 @@ , err ] -commitRemote :: Remote -> Branch -> RemoteTrackingBranch -> Maybe Sha -> ImportTreeConfig -> ImportCommitConfig -> AddUnlockedMatcher -> Imported -> CommandStart -commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig addunlockedmatcher imported = +commitRemote :: Remote -> Branch -> RemoteTrackingBranch -> Maybe Sha -> ImportTreeConfig -> ImportCommitConfig -> AddUnlockedMatcher -> Imported -> PostExportLogUpdate -> CommandStart +commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig addunlockedmatcher imported postexportlogupdate = starting "update" ai si $ do - importcommit <- buildImportCommit remote importtreeconfig importcommitconfig addunlockedmatcher imported + importcommit <- buildImportCommit remote importtreeconfig importcommitconfig addunlockedmatcher imported postexportlogupdate next $ updateremotetrackingbranch importcommit where ai = ActionItemOther (Just $ UnquotedString $ fromRef $ fromRemoteTrackingBranch tb) diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2013-2024 Joey Hess + - Copyright 2013-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -22,6 +22,7 @@ import Data.Time.Calendar import Data.Time.LocalTime import Control.Concurrent.STM +import Codec.Binary.UTF8.String (decodeString) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.ByteString as B @@ -48,6 +49,7 @@ import Annex.MetaData import Annex.FileMatcher import Annex.UntrustedFilePath +import qualified Utility.FileIO as F import qualified Utility.RawFilePath as R import qualified Database.ImportFeed as Db @@ -158,19 +160,16 @@ | otherwise = get get = withTmpFile (literalOsPath "feed") $ \tmpf h -> do - let tmpf' = fromRawFilePath $ fromOsPath tmpf liftIO $ hClose h - ifM (downloadFeed url tmpf') - ( parse tmpf' + ifM (downloadFeed url tmpf) + ( parse tmpf , do recordfail next $ feedProblem url "downloading the feed failed" ) - -- Use parseFeedFromFile rather than reading the file - -- ourselves because it goes out of its way to handle encodings. - parse tmpf = liftIO (parseFeedFromFile tmpf) >>= \case + parse tmpf = liftIO (parseFeedFromFile' tmpf) >>= \case Nothing -> debugfeedcontent tmpf "parsing the feed failed" Just f -> do case decodeBS $ fromFeedText $ getFeedTitle f of @@ -183,7 +182,7 @@ next $ return True debugfeedcontent tmpf msg = do - feedcontent <- liftIO $ readFile tmpf + feedcontent <- liftIO $ readFileString tmpf fastDebug "Command.ImportFeed" $ unlines [ "start of feed content" , feedcontent @@ -265,11 +264,11 @@ } {- Feeds change, so a feed download cannot be resumed. -} -downloadFeed :: URLString -> FilePath -> Annex Bool +downloadFeed :: URLString -> OsPath -> Annex Bool downloadFeed url f | Url.parseURIRelaxed url == Nothing = giveup "invalid feed url" | otherwise = Url.withUrlOptions Nothing $ - Url.download nullMeterUpdate Nothing url (toOsPath f) + Url.download nullMeterUpdate Nothing url f startDownload :: AddUnlockedMatcher -> ImportFeedOptions -> Cache -> TMVar Bool -> ToDownload -> CommandStart startDownload addunlockedmatcher opts cache cv todownload = case location todownload of @@ -611,7 +610,7 @@ checkFeedBroken' :: URLString -> OsPath -> Annex Bool checkFeedBroken' url f = do prev <- maybe Nothing readish - <$> liftIO (catchMaybeIO $ readFile (fromOsPath f)) + <$> liftIO (catchMaybeIO $ readFileString f) now <- liftIO getCurrentTime case prev of Nothing -> do @@ -645,3 +644,11 @@ -} fromFeedText :: T.Text -> B.ByteString fromFeedText = TE.encodeUtf8 + +{- Like Test.Feed.parseFeedFromFile, but ensures the close-on-exec bit is + - set when opening the file. -} +parseFeedFromFile' :: OsPath -> IO (Maybe Feed) +parseFeedFromFile' fp = parseFeedString <$> utf8readfile fp + where + utf8readfile :: OsPath -> IO String + utf8readfile f = fmap decodeString (hGetContents =<< F.openBinaryFile f ReadMode) diff --git a/Command/Info.hs b/Command/Info.hs --- a/Command/Info.hs +++ b/Command/Info.hs @@ -17,8 +17,6 @@ import Data.ByteString.Short (fromShort) import System.PosixCompat.Files (isDirectory) import Data.Ord -import qualified Data.Semigroup as Sem -import Prelude import Command import qualified Git @@ -68,7 +66,7 @@ , backendsKeys :: M.Map KeyVariety Integer } -instance Sem.Semigroup KeyInfo where +instance Semigroup KeyInfo where a <> b = KeyInfo { countKeys = countKeys a + countKeys b , sizeKeys = sizeKeys a + sizeKeys b diff --git a/Command/Map.hs b/Command/Map.hs --- a/Command/Map.hs +++ b/Command/Map.hs @@ -55,7 +55,7 @@ <$> fromRepo gitAnnexDir <*> pure (literalOsPath "map.dot") - liftIO $ writeFile (fromOsPath file) (drawMap rs trustmap umap) + liftIO $ writeFileString file (drawMap rs trustmap umap) next $ ifM (Annex.getRead Annex.fast) ( runViewer file [] diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -42,7 +42,7 @@ =<< isAnnexLink f -- after a merge conflict or git cherry-pick or stash, pointer -- files in the worktree won't be populated, so populate them here - Command.Smudge.updateSmudged (Restage False) + Command.Smudge.updateSmudged NoRestage runAnnexHook preCommitAnnexHook annexPreCommitCommand diff --git a/Command/RemoteDaemon.hs b/Command/RemoteDaemon.hs --- a/Command/RemoteDaemon.hs +++ b/Command/RemoteDaemon.hs @@ -31,7 +31,9 @@ #ifndef mingw32_HOST_OS git_annex <- fromOsPath <$> liftIO programPath ps <- gitAnnexDaemonizeParams - let logfd = openFdWithMode (toRawFilePath "/dev/null") ReadOnly Nothing defaultFileFlags + let logfd = openFdWithMode (toRawFilePath "/dev/null") ReadOnly Nothing + defaultFileFlags + (CloseOnExecFlag True) liftIO $ daemonize git_annex ps logfd Nothing False runNonInteractive #else liftIO $ foreground Nothing runNonInteractive diff --git a/Command/Sim.hs b/Command/Sim.hs --- a/Command/Sim.hs +++ b/Command/Sim.hs @@ -70,7 +70,7 @@ let st = emptySimState rng (fromOsPath simdir) case simfile of Nothing -> startup simdir st [] - Just f -> liftIO (readFile f) >>= \c -> + Just f -> liftIO (readFileString (toOsPath f)) >>= \c -> case parseSimFile c of Left err -> giveup err Right cs -> startup simdir st cs diff --git a/Command/Smudge.hs b/Command/Smudge.hs --- a/Command/Smudge.hs +++ b/Command/Smudge.hs @@ -173,7 +173,7 @@ doingest preferredbackend = do -- Can't restage associated files because git add -- runs this and has the index locked. - let norestage = Restage False + let norestage = NoRestage emitpointer =<< postingest =<< (\ld -> ingest' preferredbackend nullMeterUpdate ld Nothing norestage) @@ -294,7 +294,7 @@ obj <- calcRepo (gitAnnexLocation k) -- Cannot restage because git add is running and has -- the index locked. - populatePointerFile (Restage False) k obj file >>= \case + populatePointerFile NoRestage k obj file >>= \case Nothing -> return () Just ic -> Database.Keys.addInodeCaches k [ic] @@ -305,7 +305,7 @@ -- Doing it explicitly here avoids a later pause in the middle of -- some other action. scanAnnexedFiles - updateSmudged (Restage True) + updateSmudged LaterRestage stop updateSmudged :: Restage -> Annex () diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -606,8 +606,8 @@ Command.Import.listContents' remote ImportTree (CheckGitIgnore False) go where go (Just importable) = importChanges remote ImportTree False True importable >>= \case - ImportFinished imported -> do - (_t, updatestate) <- recordImportTree remote ImportTree Nothing imported + ImportFinished postexportlogupdate imported -> do + (_t, updatestate) <- recordImportTree remote ImportTree Nothing imported postexportlogupdate next $ do updatestate return True diff --git a/Command/Unlock.hs b/Command/Unlock.hs --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -67,6 +67,6 @@ cleanup :: OsPath -> Maybe InodeCache -> Key -> Maybe FileMode -> CommandCleanup cleanup dest destic key destmode = do stagePointerFile dest destmode =<< hashPointerFile key - maybe noop (restagePointerFile (Restage True) dest) destic + maybe noop (restagePointerFile QueueRestage dest) destic Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath dest) return True diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -49,7 +49,7 @@ createAnnexDirectory $ parentDir f cfg <- getCfg descs <- uuidDescriptions - liftIO $ writeFile (fromOsPath f) $ genCfg cfg descs + liftIO $ writeFileString f $ genCfg cfg descs vicfg cfg f stop @@ -65,7 +65,7 @@ liftIO $ removeWhenExistsWith removeFile f case r of Left s -> do - liftIO $ writeFile (fromOsPath f) s + liftIO $ writeFileString f s vicfg curcfg f Right newcfg -> setCfg curcfg newcfg where diff --git a/Command/WebApp.hs b/Command/WebApp.hs --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -90,7 +90,7 @@ ( if isJust (listenAddress o) || isJust (listenPort o) then giveup "The assistant is already running, so --listen and --port cannot be used." else do - url <- liftIO . readFile . fromOsPath + url <- liftIO . readFileString =<< fromRepo gitAnnexUrlFile liftIO $ if isJust listenAddress' then putStrLn url diff --git a/Common.hs b/Common.hs --- a/Common.hs +++ b/Common.hs @@ -33,5 +33,6 @@ import Utility.Split as X import Utility.FileSystemEncoding as X import Utility.OsPath as X +import Utility.FileIO as X (readFileString, writeFileString, appendFileString) import Utility.PartialPrelude as X diff --git a/Config/Files.hs b/Config/Files.hs --- a/Config/Files.hs +++ b/Config/Files.hs @@ -32,4 +32,4 @@ noAnnexFileContent :: Maybe OsPath -> IO (Maybe String) noAnnexFileContent repoworktree = case repoworktree of Nothing -> return Nothing - Just wt -> catchMaybeIO (readFile (fromOsPath (wt literalOsPath ".noannex"))) + Just wt -> catchMaybeIO (readFileString (wt literalOsPath ".noannex")) diff --git a/Config/Files/AutoStart.hs b/Config/Files/AutoStart.hs --- a/Config/Files/AutoStart.hs +++ b/Config/Files/AutoStart.hs @@ -18,7 +18,7 @@ readAutoStartFile = do f <- autoStartFile filter valid . nub . map (dropTrailingPathSeparator . toOsPath) . lines - <$> catchDefaultIO "" (readFile (fromOsPath f)) + <$> catchDefaultIO "" (readFileString f) where -- Ignore any relative paths; some old buggy versions added eg "." valid = isAbsolute @@ -30,7 +30,7 @@ when (dirs' /= dirs) $ do f <- autoStartFile createDirectoryIfMissing True (parentDir f) - viaTmp (writeFile . fromRawFilePath . fromOsPath) f + viaTmp writeFileString f (unlines (map fromOsPath dirs')) {- Adds a directory to the autostart file. If the directory is already diff --git a/Config/Smudge.hs b/Config/Smudge.hs --- a/Config/Smudge.hs +++ b/Config/Smudge.hs @@ -70,7 +70,7 @@ lf <- Annex.fromRepo Git.attributesLocal ls <- liftIO $ catchDefaultIO [] $ map decodeBS . fileLines' <$> F.readFile' lf - liftIO $ writeFile (fromOsPath lf) $ unlines $ + liftIO $ writeFileString lf $ unlines $ filter (\l -> l `notElem` stdattr && not (null l)) ls unsetConfig (ConfigKey "filter.annex.smudge") unsetConfig (ConfigKey "filter.annex.clean") diff --git a/Crypto.hs b/Crypto.hs --- a/Crypto.hs +++ b/Crypto.hs @@ -25,7 +25,6 @@ decryptCipher', encryptKey, isEncKey, - feedFile, feedBytes, readBytes, readBytesStrictly, @@ -187,9 +186,6 @@ type Feeder = Handle -> IO () type Reader m a = Handle -> m a - -feedFile :: FilePath -> Feeder -feedFile f h = L.hPut h =<< L.readFile f feedBytes :: L.ByteString -> Feeder feedBytes = flip L.hPut diff --git a/Database/Keys.hs b/Database/Keys.hs --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -47,7 +47,6 @@ import Git.FilePath import Git.Command import Git.Types -import Git.Index import Git.Sha import Git.CatFile import Git.Branch (writeTreeQuiet, update') @@ -81,8 +80,8 @@ else return tableschanged v <- a (SQL.ReadHandle qh) return (v, DbOpen (qh, tableschanged')) - go DbClosed = do - st <- openDb False DbClosed + go startst@(DbClosed _) = do + st <- openDb False startst v <- case st of (DbOpen (qh, _)) -> a (SQL.ReadHandle qh) _ -> return mempty @@ -124,7 +123,11 @@ openDb :: Bool -> DbState -> Annex DbState openDb _ st@(DbOpen _) = return st openDb False DbUnavailable = return DbUnavailable -openDb forwrite _ = do +openDb forwrite (DbClosed wasopen) = openDb' forwrite wasopen +openDb forwrite DbUnavailable = openDb' forwrite (DbWasOpen False) + +openDb' :: Bool -> DbWasOpen -> Annex DbState +openDb' forwrite wasopen = do lck <- calcRepo' gitAnnexKeysDbLock catchPermissionDenied permerr $ withExclusiveLock lck $ do dbdir <- calcRepo' gitAnnexKeysDbDir @@ -144,7 +147,7 @@ open db dbisnew = do qh <- liftIO $ H.openDbQueue db SQL.containedTable - tc <- reconcileStaged dbisnew qh + tc <- reconcileStaged dbisnew qh wasopen return $ DbOpen (qh, tc) {- Closes the database if it was open. Any writes will be flushed to it. @@ -238,8 +241,8 @@ - This is run with a lock held, so only one process can be running this at - a time. - - - To avoid unnecessary work, the index file is statted, and if it's not - - changed since last time this was run, nothing is done. + - If the database gets closed and then reopened by the same process, this + - will avoid doing any repeated work. - - A tree is generated from the index, and the diff between that tree - and the last processed tree is examined for changes. @@ -259,30 +262,19 @@ - So when using getAssociatedFiles, have to make sure the file still - is an associated file. -} -reconcileStaged :: Bool -> H.DbQueue -> Annex DbTablesChanged -reconcileStaged dbisnew qh = ifM isBareRepo +reconcileStaged :: Bool -> H.DbQueue -> DbWasOpen -> Annex DbTablesChanged +reconcileStaged _ _ (DbWasOpen True) = + return (DbTablesChanged False False) +reconcileStaged dbisnew qh _ = ifM isBareRepo ( return mempty - , do - gitindex <- inRepo currentIndexFile - indexcache <- fromOsPath <$> calcRepo' gitAnnexKeysDbIndexCache - withTSDelta (liftIO . genInodeCache gitindex) >>= \case - Just cur -> readindexcache indexcache >>= \case - Nothing -> go cur indexcache =<< getindextree - Just prev -> ifM (compareInodeCaches prev cur) - ( return mempty - , go cur indexcache =<< getindextree - ) - Nothing -> return mempty + , inReconcileStaged $ go =<< getindextree ) where lastindexref = Ref "refs/annex/last-index" - readindexcache indexcache = liftIO $ maybe Nothing readInodeCache - <$> catchMaybeIO (readFile indexcache) - getoldtree = fromMaybe emptyTree <$> inRepo (Git.Ref.sha lastindexref) - go cur indexcache (Just newtree) = do + go (Just newtree) = do oldtree <- getoldtree when (oldtree /= newtree) $ do fastDebug "Database.Keys" "reconcileStaged start" @@ -292,7 +284,6 @@ (Just (fromRef oldtree)) (fromRef newtree) (procdiff mdfeeder) - liftIO $ writeFile indexcache $ showInodeCache cur -- Storing the tree in a ref makes sure it does not -- get garbage collected, and is available to diff -- against next time. @@ -309,7 +300,7 @@ -- When there is a merge conflict, that will not see the new local -- version of the files that are conflicted. So a second diff -- is done, with --staged but no old tree. - go _ _ Nothing = do + go Nothing = do fastDebug "Database.Keys" "reconcileStaged start (in conflict)" oldtree <- getoldtree g <- Annex.gitRepo @@ -442,13 +433,19 @@ filepopulated <- sameInodeCache p ics case (keypopulated, filepopulated) of (True, False) -> - populatePointerFile (Restage True) key obj p >>= \case + populatePointerFile restage key obj p >>= \case Nothing -> return () Just ic -> addinodecaches key (catMaybes [Just ic, mobjic]) - (False, True) -> depopulatePointerFile key p + (False, True) -> depopulatePointerFile restage key p _ -> return () + -- Cannot use QueueRestage here, because it could deadlock; + -- restagePointerFiles tries to close the database handle, + -- but the database handle is open while reconcileStaged + -- is running. + restage = LaterRestage + send :: ((Maybe Key -> Annex a, Ref) -> IO ()) -> Ref -> (Maybe Key -> Annex a) -> IO () send feeder r withk = feeder (withk, r) @@ -508,6 +505,15 @@ addassociatedfile | dbisnew = SQL.newAssociatedFile | otherwise = SQL.addAssociatedFile + +-- Avoid a potential deadlock. +inReconcileStaged :: Annex a -> Annex a +inReconcileStaged = bracket setup cleanup . const + where + setup = Annex.changeState $ \s -> s + { Annex.inreconcilestaged = True } + cleanup () = Annex.changeState $ \s -> s + { Annex.inreconcilestaged = False } {- Normally the keys database is updated incrementally when opened, - by reconcileStaged. Calling this explicitly allows running the diff --git a/Database/Keys/Handle.hs b/Database/Keys/Handle.hs --- a/Database/Keys/Handle.hs +++ b/Database/Keys/Handle.hs @@ -9,6 +9,7 @@ DbHandle, newDbHandle, DbState(..), + DbWasOpen(..), withDbState, flushDbQueue, closeDbHandle, @@ -21,8 +22,6 @@ import Control.Concurrent import Control.Monad.IO.Class (liftIO, MonadIO) -import Control.Applicative -import Prelude -- The MVar is always left full except when actions are run -- that access the database. @@ -30,10 +29,16 @@ -- The database can be closed or open, but it also may have been -- tried to open (for read) and didn't exist yet or is not readable. -data DbState = DbClosed | DbOpen (H.DbQueue, DbTablesChanged) | DbUnavailable +data DbState + = DbClosed DbWasOpen + | DbOpen (H.DbQueue, DbTablesChanged) + | DbUnavailable +-- Was the database previously opened by this process? +data DbWasOpen = DbWasOpen Bool + newDbHandle :: IO DbHandle -newDbHandle = DbHandle <$> newMVar DbClosed +newDbHandle = DbHandle <$> newMVar (DbClosed (DbWasOpen False)) -- Runs an action on the state of the handle, which can change its state. -- The MVar is empty while the action runs, which blocks other users @@ -65,5 +70,5 @@ where go (DbOpen (qh, _)) = do H.closeDbQueue qh - return ((), DbClosed) + return ((), DbClosed (DbWasOpen True)) go st = return ((), st) diff --git a/Database/Keys/Tables.hs b/Database/Keys/Tables.hs --- a/Database/Keys/Tables.hs +++ b/Database/Keys/Tables.hs @@ -7,10 +7,6 @@ module Database.Keys.Tables where -import Data.Monoid -import qualified Data.Semigroup as Sem -import Prelude - data DbTable = AssociatedTable | ContentTable deriving (Eq, Show) @@ -20,7 +16,7 @@ } deriving (Show) -instance Sem.Semigroup DbTablesChanged where +instance Semigroup DbTablesChanged where a <> b = DbTablesChanged { associatedTable = associatedTable a || associatedTable b , contentTable = contentTable a || contentTable b diff --git a/Database/Queue.hs b/Database/Queue.hs --- a/Database/Queue.hs +++ b/Database/Queue.hs @@ -27,8 +27,6 @@ import Database.Persist.Sqlite import Control.Concurrent import Data.Time.Clock -import Control.Applicative -import Prelude {- A DbQueue wraps a DbHandle, adding a queue of writes to perform. - diff --git a/Git/Construct.hs b/Git/Construct.hs --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -280,7 +280,7 @@ adjustGitDirFile' :: RepoLocation -> IO (Maybe RepoLocation) adjustGitDirFile' loc@(Local {}) = do let gd = gitdir loc - c <- firstLine <$> catchDefaultIO "" (readFile (fromOsPath gd)) + c <- firstLine <$> catchDefaultIO "" (readFileString gd) if gitdirprefix `isPrefixOf` c then do top <- takeDirectory <$> absPath gd diff --git a/Git/Fsck.hs b/Git/Fsck.hs --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -26,8 +26,6 @@ import qualified Data.Set as S import Control.Concurrent.Async -import qualified Data.Semigroup as Sem -import Prelude data FsckResults = FsckFoundMissing @@ -56,7 +54,7 @@ appendFsckOutput AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning appendFsckOutput NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning -instance Sem.Semigroup FsckOutput where +instance Semigroup FsckOutput where (<>) = appendFsckOutput instance Monoid FsckOutput where diff --git a/Git/Hook.hs b/Git/Hook.hs --- a/Git/Hook.hs +++ b/Git/Hook.hs @@ -59,7 +59,7 @@ f = hookFile h r go = do -- On Windows, using a ByteString as the file content - -- avoids the newline translation done by writeFile. + -- avoids the newline translation done by writeFileString. -- Hook scripts on Windows could use CRLF endings, but -- they typically use unix newlines, which does work there -- and makes the repository more portable. @@ -85,11 +85,11 @@ expectedContent :: Hook -> Repo -> IO ExpectedContent expectedContent h r = do - -- Note that on windows, this readFile does newline translation, + -- Note that on windows, this readFileString does newline translation, -- and so a hook file that has CRLF will be treated the same as one -- that has LF. That is intentional, since users may have a reason -- to prefer one or the other. - content <- readFile $ fromOsPath $ hookFile h r + content <- readFileString $ hookFile h r return $ if content == hookScript h then ExpectedContent else if any (content ==) (hookOldScripts h) diff --git a/Git/LockFile.hs b/Git/LockFile.hs --- a/Git/LockFile.hs +++ b/Git/LockFile.hs @@ -53,8 +53,7 @@ #ifndef mingw32_HOST_OS -- On unix, git simply uses O_EXCL h <- openFdWithMode (fromOsPath lck) ReadWrite (Just 0O666) - (defaultFileFlags { exclusive = True }) - setFdOption h CloseOnExec True + (defaultFileFlags { exclusive = True }) (CloseOnExecFlag True) #else -- It's not entirely clear how git manages locking on Windows, -- since it's buried in the portability layer, and different diff --git a/Git/Objects.hs b/Git/Objects.hs --- a/Git/Objects.hs +++ b/Git/Objects.hs @@ -50,7 +50,7 @@ listAlternates :: Repo -> IO [FilePath] listAlternates r = catchDefaultIO [] $ - lines <$> readFile (fromOsPath alternatesfile) + lines <$> readFileString alternatesfile where alternatesfile = objectsDir r literalOsPath "info" literalOsPath "alternates" diff --git a/Git/Quote.hs b/Git/Quote.hs --- a/Git/Quote.hs +++ b/Git/Quote.hs @@ -28,8 +28,6 @@ import Data.Word import Data.String import qualified Data.ByteString as S -import qualified Data.Semigroup as Sem -import Prelude unquote :: S.ByteString -> RawFilePath unquote b = case S.uncons b of @@ -108,7 +106,7 @@ instance IsString StringContainingQuotedPath where fromString = UnquotedByteString . encodeBS -instance Sem.Semigroup StringContainingQuotedPath where +instance Semigroup StringContainingQuotedPath where UnquotedString a <> UnquotedString b = UnquotedString (a <> b) UnquotedByteString a <> UnquotedByteString b = UnquotedByteString (a <> b) a <> b = a :+: b diff --git a/Git/Repair.hs b/Git/Repair.hs --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -269,7 +269,7 @@ let dest = gitd toOsPath (fromRef' ref) createDirectoryUnder [gitd] (parentDir dest) unlessM (doesFileExist dest) $ - writeFile (fromOsPath dest) (fromRef sha) + writeFileString dest (fromRef sha) packedRefsFile :: Repo -> OsPath packedRefsFile r = localGitDir r literalOsPath "packed-refs" @@ -472,7 +472,7 @@ preRepair g = do unlessM (validhead <$> catchDefaultIO "" (decodeBS <$> safeReadFile headfile)) $ do removeWhenExistsWith removeFile headfile - writeFile (fromOsPath headfile) "ref: refs/heads/master" + writeFileString headfile "ref: refs/heads/master" explodePackedRefsFile g unless (repoIsLocalBare g) $ void $ tryIO $ allowWrite $ indexFile g diff --git a/Git/Types.hs b/Git/Types.hs --- a/Git/Types.hs +++ b/Git/Types.hs @@ -21,8 +21,6 @@ import qualified Data.ByteString as S import qualified Data.List.NonEmpty as NE import System.Posix.Types -import qualified Data.Semigroup as Sem -import Prelude {- Support repositories on local disk, and repositories accessed via an URL. - @@ -81,7 +79,7 @@ -- with an empty value deriving (Ord, Eq) -instance Sem.Semigroup ConfigValue where +instance Semigroup ConfigValue where ConfigValue a <> ConfigValue b = ConfigValue (a <> b) a <> NoConfigValue = a NoConfigValue <> b = b diff --git a/Logs/File.hs b/Logs/File.hs --- a/Logs/File.hs +++ b/Logs/File.hs @@ -38,7 +38,7 @@ writeLogFile f c = createDirWhenNeeded f $ viaTmp writelog f c where writelog tmp c' = do - liftIO $ writeFile (fromOsPath tmp) c' + liftIO $ writeFileString tmp c' setAnnexFilePerm tmp -- | Runs the action with a handle connected to a temp file. diff --git a/Logs/FsckResults.hs b/Logs/FsckResults.hs --- a/Logs/FsckResults.hs +++ b/Logs/FsckResults.hs @@ -45,7 +45,7 @@ readFsckResults u = do logfile <- fromRepo $ gitAnnexFsckResultsLog u liftIO $ catchDefaultIO (FsckFoundMissing S.empty False) $ - deserializeFsckResults <$> readFile (fromOsPath logfile) + deserializeFsckResults <$> readFileString logfile deserializeFsckResults :: String -> FsckResults deserializeFsckResults = deserialize . lines diff --git a/Logs/Import.hs b/Logs/Import.hs --- a/Logs/Import.hs +++ b/Logs/Import.hs @@ -1,6 +1,6 @@ {- git-annex import logs - - - Copyright 2023 Joey Hess + - Copyright 2023-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -14,24 +14,60 @@ import Git.Types import Git.Sha import Logs.File +import Logs.Export import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Char8 as S8 +import qualified Data.Set as S {- Records the sha of a tree that contains hashes of ContentIdentifiers - - that were imported from a remote. -} + - that were imported from a remote. + - + - The sha is on the first line of the log file, and following it + - is a line with the the currently exported treeishs, and then a line with + - the incomplete exported treeishes. + -} recordContentIdentifierTree :: UUID -> Sha -> Annex () recordContentIdentifierTree u t = do l <- calcRepo' (gitAnnexImportLog u) - writeLogFile l (fromRef t) + exported <- getExport u + writeLogFile l $ unlines + [ fromRef t + , unwords $ map fromRef $ exportedTreeishes exported + , unwords $ map fromRef $ incompleteExportedTreeishes exported + ] -{- Gets the tree last recorded for a remote. -} +{- Gets the ContentIdentifier tree last recorded for a remote. + - + - This returns Nothing if no tree was recorded yet. + - + - It also returns Nothing when there have been changes to what is exported + - to the remote since the tree was recorded. That avoids a problem where + - diffing from the current Contentidentifier tree to the previous tree + - would miss changes that were made to a remote by an export, but were + - later undone manually. For example, if a file was exported to the remote, + - and then the file was manually removed from the remote, the current tree + - would not contain the file, and neither would the previous tree. + - So diffing between the trees would miss that removal. The removed + - file would then remain in the imported tree. + -} getContentIdentifierTree :: UUID -> Annex (Maybe Sha) getContentIdentifierTree u = do l <- calcRepo' (gitAnnexImportLog u) -- This is safe because the log file is written atomically. - calcLogFileUnsafe l Nothing update + ls <- calcLogFileUnsafe l [] (\v ls -> L.toStrict v : ls) + exported <- getExport u + return $ case reverse ls of + -- Subsequent lines are ignored. This leaves room for future + -- expansion of what is logged. + (a:b:c:_) -> do + t <- extractSha a + exportedtreeishs <- mapM extractSha (S8.words b) + incompleteexportedtreeishs <- mapM extractSha (S8.words c) + if same exportedtreeishs (exportedTreeishes exported) && + same incompleteexportedtreeishs (incompleteExportedTreeishes exported) + then Just t + else Nothing + _ -> Nothing where - update l Nothing = extractSha (L.toStrict l) - -- Subsequent lines are ignored. This leaves room for future - -- expansion of what is logged. - update _l (Just l) = Just l + same l1 l2 = S.fromList l1 == S.fromList l2 diff --git a/Logs/MapLog.hs b/Logs/MapLog.hs --- a/Logs/MapLog.hs +++ b/Logs/MapLog.hs @@ -28,8 +28,6 @@ import qualified Data.Attoparsec.ByteString.Lazy as AL import qualified Data.Attoparsec.ByteString.Char8 as A8 import Data.ByteString.Builder -import qualified Data.Semigroup as Sem -import Prelude data LogEntry v = LogEntry { changed :: VectorClock @@ -42,7 +40,7 @@ newtype MapLog f v = MapLog (M.Map f (LogEntry v)) deriving (Show, Eq) -instance Ord f => Sem.Semigroup (MapLog f v) +instance Ord f => Semigroup (MapLog f v) where a <> MapLog b = foldl' (\m (f, v) -> addMapLog f v m) a (M.toList b) diff --git a/Logs/Restage.hs b/Logs/Restage.hs --- a/Logs/Restage.hs +++ b/Logs/Restage.hs @@ -55,7 +55,7 @@ ifM (doesPathExist oldf) ( do h <- F.openFile oldf AppendMode - hPutStr h =<< readFile (fromOsPath logf) + hPutStr h =<< readFileString logf hClose h liftIO $ removeWhenExistsWith removeFile logf , moveFile logf oldf diff --git a/Logs/Schedule.hs b/Logs/Schedule.hs --- a/Logs/Schedule.hs +++ b/Logs/Schedule.hs @@ -63,9 +63,9 @@ getLastRunTimes :: Annex (M.Map ScheduledActivity LocalTime) getLastRunTimes = do - f <- fromOsPath <$> fromRepo gitAnnexScheduleState + f <- fromRepo gitAnnexScheduleState liftIO $ fromMaybe M.empty - <$> catchDefaultIO Nothing (readish <$> readFile f) + <$> catchDefaultIO Nothing (readish <$> readFileString f) setLastRunTime :: ScheduledActivity -> LocalTime -> Annex () setLastRunTime activity lastrun = do diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -263,7 +263,7 @@ -- after it's been created with the right perms by writeTransferInfoFile. updateTransferInfoFile :: TransferInfo -> OsPath -> IO () updateTransferInfoFile info tfile = - writeFile (fromOsPath tfile) $ writeTransferInfo info + writeFileString tfile $ writeTransferInfo info {- File format is a header line containing the startedTime and any - bytesComplete value. Followed by a newline and the associatedFile. diff --git a/Logs/View.hs b/Logs/View.hs --- a/Logs/View.hs +++ b/Logs/View.hs @@ -54,8 +54,8 @@ recentViews :: Annex [View] recentViews = do - f <- fromOsPath <$> fromRepo gitAnnexViewLog - liftIO $ mapMaybe readish . lines <$> catchDefaultIO [] (readFile f) + f <- fromRepo gitAnnexViewLog + liftIO $ mapMaybe readish . lines <$> catchDefaultIO [] (readFileString f) {- Gets the currently checked out view, if there is one. - diff --git a/Messages/JSON.hs b/Messages/JSON.hs --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -31,7 +31,6 @@ module Utility.Aeson, ) where -import Control.Applicative import qualified Data.Map as M import qualified Data.Vector as V import qualified Data.ByteString as S @@ -41,8 +40,6 @@ import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent import Data.Maybe -import Data.Monoid -import Prelude import Types.Command (SeekInput(..)) import Types.ActionItem diff --git a/P2P/Http/Server.hs b/P2P/Http/Server.hs --- a/P2P/Http/Server.hs +++ b/P2P/Http/Server.hs @@ -477,14 +477,19 @@ let lock = do lockresv <- newEmptyTMVarIO unlockv <- newEmptyTMVarIO + -- A single worker thread takes the lock, and keeps running + -- until unlock in order to keep the lock held. annexworker <- async $ inAnnexWorker st $ do lockres <- runFullProto (clientRunState conn) (clientP2PConnection conn) $ do net $ sendMessage (LOCKCONTENT k) checkSuccess liftIO $ atomically $ putTMVar lockresv lockres - liftIO $ atomically $ takeTMVar unlockv - void $ runFullProto (clientRunState conn) (clientP2PConnection conn) $ do - net $ sendMessage UNLOCKCONTENT + case lockres of + Right True -> do + liftIO $ atomically $ takeTMVar unlockv + void $ runFullProto (clientRunState conn) (clientP2PConnection conn) $ do + net $ sendMessage UNLOCKCONTENT + _ -> return () atomically (takeTMVar lockresv) >>= \case Right True -> return (Just (annexworker, unlockv)) _ -> return Nothing diff --git a/P2P/Http/State.hs b/P2P/Http/State.hs --- a/P2P/Http/State.hs +++ b/P2P/Http/State.hs @@ -44,8 +44,6 @@ import qualified Data.Set as S import Control.Concurrent.Async import Data.Time.Clock.POSIX -import qualified Data.Semigroup as Sem -import Prelude data P2PHttpServerState = P2PHttpServerState { servedRepos :: M.Map UUID PerRepoServerState @@ -62,7 +60,7 @@ , updateRepos = const mempty } -instance Sem.Semigroup P2PHttpServerState where +instance Semigroup P2PHttpServerState where a <> b = P2PHttpServerState { servedRepos = servedRepos a <> servedRepos b , serverShutdownCleanup = do diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs --- a/P2P/Protocol.hs +++ b/P2P/Protocol.hs @@ -44,9 +44,7 @@ import Data.Char import Data.Maybe import Data.Time.Clock.POSIX -import Control.Applicative import Control.DeepSeq -import Prelude newtype Offset = Offset Integer deriving (Show, Eq, NFData, Num, Real, Ord, Enum, Integral) diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -470,10 +470,12 @@ docopynoncow iv = do #ifndef mingw32_HOST_OS - let open = do + let open = noCreateProcessWhile $ do + fd <- openFdWithMode f' ReadOnly Nothing + defaultFileFlags (CloseOnExecFlag True) -- Need a duplicate fd for the post check. - fd <- openFdWithMode f' ReadOnly Nothing defaultFileFlags dupfd <- dup fd + setFdOption dupfd CloseOnExec True h <- fdToHandle fd return (h, dupfd) let close (h, dupfd) = do diff --git a/Remote/Directory/LegacyChunked.hs b/Remote/Directory/LegacyChunked.hs --- a/Remote/Directory/LegacyChunked.hs +++ b/Remote/Directory/LegacyChunked.hs @@ -33,7 +33,7 @@ let chunkcount = f ++ Legacy.chunkCount ifM (check chunkcount) ( do - chunks <- Legacy.listChunks f <$> readFile chunkcount + chunks <- Legacy.listChunks f <$> readFileString (toOsPath chunkcount) ifM (allM check chunks) ( a chunks , return False ) , do @@ -52,14 +52,14 @@ storeLegacyChunked meterupdate chunksize alldests@(firstdest:_) b | L.null b = do -- always write at least one file, even for empty - L.writeFile firstdest b + F.writeFile (toOsPath firstdest) b return [firstdest] | otherwise = storeLegacyChunked' meterupdate chunksize alldests (L.toChunks b) [] storeLegacyChunked' :: MeterUpdate -> ChunkSize -> [FilePath] -> [S.ByteString] -> [FilePath] -> IO [FilePath] storeLegacyChunked' _ _ [] _ _ = error "ran out of dests" storeLegacyChunked' _ _ _ [] c = return $ reverse c storeLegacyChunked' meterupdate chunksize (d:dests) bs c = do - bs' <- withFile d WriteMode $ + bs' <- F.withFile (toOsPath d) WriteMode $ feed zeroBytesProcessed chunksize bs storeLegacyChunked' meterupdate chunksize dests bs' (d:c) where @@ -85,7 +85,7 @@ recorder f s = do let f' = toOsPath f void $ tryIO $ allowWrite f' - writeFile f s + writeFileString f' s void $ tryIO $ preventWrite f' store :: FilePath -> ChunkSize -> (OsPath -> OsPath -> IO ()) -> Key -> L.ByteString -> MeterUpdate -> FilePath -> FilePath -> IO () @@ -103,7 +103,7 @@ let go = \k sink -> do liftIO $ void $ withStoredFiles (fromOsPath d) (legacyLocations locations) k $ \fs -> do forM_ fs $ - F.appendFile' tmp <=< S.readFile + F.appendFile' tmp <=< F.readFile' . toOsPath return True b <- liftIO $ F.readFile tmp liftIO $ removeWhenExistsWith removeFile tmp diff --git a/Remote/Helper/Chunked/Legacy.hs b/Remote/Helper/Chunked/Legacy.hs --- a/Remote/Helper/Chunked/Legacy.hs +++ b/Remote/Helper/Chunked/Legacy.hs @@ -10,6 +10,7 @@ import Annex.Common import Remote.Helper.Chunked import Utility.Metered +import qualified Utility.FileIO as F import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L @@ -116,6 +117,6 @@ -} meteredWriteFileChunks :: MeterUpdate -> FilePath -> [v] -> (v -> IO L.ByteString) -> IO () meteredWriteFileChunks meterupdate dest chunks feeder = - withBinaryFile dest WriteMode $ \h -> + F.withBinaryFile (toOsPath dest) WriteMode $ \h -> forM_ chunks $ meteredWrite meterupdate (S.hPut h) <=< feeder diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -96,7 +96,7 @@ fileStorer :: (Key -> OsPath -> MeterUpdate -> Annex ()) -> Storer fileStorer a k (FileContent f) m = a k f m fileStorer a k (ByteContent b) m = withTmp k $ \f -> do - liftIO $ L.writeFile (fromOsPath f) b + liftIO $ F.writeFile f b a k f m -- A Storer that expects to be provided with a L.ByteString of diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -213,7 +213,7 @@ writeSharedConvergenceSecret :: TahoeConfigDir -> SharedConvergenceSecret -> IO () writeSharedConvergenceSecret configdir scs = - writeFile (fromOsPath (convergenceFile configdir)) + writeFileString (convergenceFile configdir) (unlines [scs]) {- The tahoe daemon writes the convergenceFile shortly after it starts @@ -223,11 +223,11 @@ getSharedConvergenceSecret :: TahoeConfigDir -> IO SharedConvergenceSecret getSharedConvergenceSecret configdir = go (60 :: Int) where - f = fromOsPath $ convergenceFile configdir + f = convergenceFile configdir go n - | n == 0 = giveup $ "tahoe did not write " ++ f ++ " after 1 minute. Perhaps the daemon failed to start?" + | n == 0 = giveup $ "tahoe did not write " ++ fromOsPath f ++ " after 1 minute. Perhaps the daemon failed to start?" | otherwise = do - v <- catchMaybeIO (readFile f) + v <- catchMaybeIO (readFileString f) case v of Just s | "\n" `isSuffixOf` s || "\r" `isSuffixOf` s -> return $ takeWhile (`notElem` ("\n\r" :: String)) s diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -38,8 +38,8 @@ import qualified Git.Ref import qualified Git.LsTree import qualified Git.FilePath -import qualified Annex.Locations #ifndef mingw32_HOST_OS +import qualified Annex.Locations import qualified Git.Bundle import qualified Types.GitConfig #endif @@ -556,8 +556,8 @@ #ifdef WITH_MAGICMIME git "config" ["annex.largefiles", "mimeencoding=binary"] "git config annex.largefiles" - writeFile "binary" "\127" - writeFile "text" "test\n" + writeFileString (literalOsPath "binary") "\127" + writeFileString (literalOsPath "text") "test\n" git_annex "add" ["binary", "text"] "git-annex add with mimeencoding in largefiles" git_annex "sync" ["--no-content"] @@ -879,7 +879,7 @@ changecontent annexedfile git "add" [annexedfile] "add of modified file" runchecks [checkregularfile, checkwritable] annexedfile - c <- readFile annexedfile + c <- readFileString (toOsPath annexedfile) assertEqual "content of modified file" c (changedcontent annexedfile) git_annex_shouldfail "drop" [annexedfile] "drop with no known copy of modified file should not be allowed" @@ -896,8 +896,6 @@ Just k <- Annex.WorkTree.lookupKey (toOsPath annexedfile) Database.Keys.removeInodeCaches k Database.Keys.closeDb - liftIO . removeWhenExistsWith removeFile - =<< Annex.calcRepo' Annex.Locations.gitAnnexKeysDbIndexCache writecontent annexedfile "test_lock_force content" git_annex_shouldfail "lock" [annexedfile] "lock of modified file should not be allowed" git_annex "lock" ["--force", annexedfile] "lock --force of modified file" @@ -921,7 +919,7 @@ then git_annex "pre-commit" [] "pre-commit" else git "commit" ["-q", "-m", "contentchanged"] "git commit of edited file" runchecks [checkregularfile, checkwritable] annexedfile - c <- readFile annexedfile + c <- readFileString (toOsPath annexedfile) assertEqual "content of modified file" c (changedcontent annexedfile) git_annex_shouldfail "drop" [annexedfile] "drop no known copy of modified file should not be allowed" @@ -947,7 +945,7 @@ git "mv" [annexedfile, subdir] "git mv" git_annex "fix" [newfile] "fix of moved file" runchecks [checklink, checkunwritable] newfile - c <- readFile newfile + c <- readFileString (toOsPath newfile) assertEqual "content of moved file" c (content annexedfile) where subdir = "s" @@ -1069,7 +1067,8 @@ annexed_present sha1annexedfile if usegitattributes then do - writeFile ".gitattributes" "* annex.backend=SHA1" + writeFileString (literalOsPath ".gitattributes") + "* annex.backend=SHA1" git_annex "migrate" [sha1annexedfile] "migrate sha1annexedfile" git_annex "migrate" [annexedfile] @@ -1085,7 +1084,8 @@ checkbackend sha1annexedfile backendSHA1 -- check that reversing a migration works - writeFile ".gitattributes" "* annex.backend=SHA256" + writeFileString (literalOsPath ".gitattributes") + "* annex.backend=SHA256" git_annex "migrate" [sha1annexedfile] "migrate sha1annexedfile" git_annex "migrate" [annexedfile] "migrate annexedfile" annexed_present annexedfile @@ -1531,7 +1531,7 @@ length v == 1 @? (what ++ " too many variant files in: " ++ show v) conflictor `elem` l @? (what ++ " conflictor file missing in: " ++ show l) - s <- catchMaybeIO $ readFile $ fromOsPath $ + s <- catchMaybeIO $ readFileString $ toOsPath d toOsPath conflictor s == Just nonannexed_content @? (what ++ " wrong content for nonannexed file: " ++ show s) @@ -1918,19 +1918,19 @@ where testscheme scheme = intmpclonerepo $ test_with_gpg $ \gpgcmd environ -> do createDirectory (literalOsPath "dir") - let initps = + let ps = [ "foo" - , "type=directory" , "encryption=" ++ scheme , "directory=dir" , "highRandomQuality=false" ] ++ if scheme `elem` ["hybrid","pubkey"] then ["keyid=" ++ Utility.Gpg.testKeyId] else [] + let initps = ps ++ [ "type=directory" ] git_annex' "initremote" initps (Just environ) "initremote" git_annex_shouldfail' "initremote" initps (Just environ) "initremote should not work when run twice in a row" - git_annex' "enableremote" initps (Just environ) "enableremote" - git_annex' "enableremote" initps (Just environ) "enableremote when run twice in a row" + git_annex' "enableremote" ps (Just environ) "enableremote" + git_annex' "enableremote" ps (Just environ) "enableremote when run twice in a row" git_annex' "get" [annexedfile] (Just environ) "get of file" annexed_present annexedfile git_annex' "copy" [annexedfile, "--to", "foo"] (Just environ) "copy --to encrypted remote" @@ -2074,9 +2074,9 @@ dircontains "import" (content "newimport3") where dircontains f v = do - let df = fromOsPath (literalOsPath "dir" stringToOsPath f) - ((v==) <$> readFile df) - @? ("did not find expected content of " ++ df) + let df = literalOsPath "dir" stringToOsPath f + ((v==) <$> readFileString df) + @? ("did not find expected content of " ++ fromOsPath df) writedir f = writecontent (fromOsPath (literalOsPath "dir" stringToOsPath f)) -- When on an adjusted branch, this updates the master branch -- to match it, which is necessary since the master branch is going @@ -2111,9 +2111,9 @@ testexport where dircontains f v = do - let df = fromOsPath (literalOsPath "dir" toOsPath f) - ((v==) <$> readFile df) - @? ("did not find expected content of " ++ df) + let df = literalOsPath "dir" toOsPath f + ((v==) <$> readFileString df) + @? ("did not find expected content of " ++ fromOsPath df) subdir = "subdir" subannexedfile = fromOsPath $ diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -391,7 +391,7 @@ checkcontent :: FilePath -> Assertion checkcontent f = do - c <- Utility.Exception.catchDefaultIO "could not read file" $ readFile f + c <- Utility.Exception.catchDefaultIO "could not read file" $ readFileString (toOsPath f) assertEqual ("checkcontent " ++ f) (content f) c checkunwritable :: FilePath -> Assertion @@ -415,7 +415,7 @@ checkdangling f = ifM (annexeval Config.crippledFileSystem) ( return () -- probably no real symlinks to test , do - r <- tryIO $ readFile f + r <- tryIO $ readFileString (toOsPath f) case r of Left _ -> return () -- expected; dangling link Right _ -> assertFailure $ f ++ " was not a dangling link as expected" @@ -675,9 +675,10 @@ writecontent f c = go (10000000 :: Integer) where go ticsleft = do - oldmtime <- catchMaybeIO $ getModificationTime (toOsPath f) - writeFile f c - newmtime <- getModificationTime (toOsPath f) + let f' = toOsPath f + oldmtime <- catchMaybeIO $ getModificationTime f' + writeFileString f' c + newmtime <- getModificationTime f' if Just newmtime == oldmtime then do threadDelay 100000 diff --git a/Types/CleanupActions.hs b/Types/CleanupActions.hs --- a/Types/CleanupActions.hs +++ b/Types/CleanupActions.hs @@ -10,7 +10,7 @@ import Types.UUID import Utility.Url -import System.Process (Pid) +import Utility.Process (Pid) data CleanupAction = RemoteCleanup UUID @@ -20,6 +20,7 @@ | AdjustedBranchUpdate | TorrentCleanup URLString | OtherTmpCleanup + | RestagePointerFiles deriving (Eq, Ord) data SignalAction diff --git a/Types/DeferredParse.hs b/Types/DeferredParse.hs --- a/Types/DeferredParse.hs +++ b/Types/DeferredParse.hs @@ -12,8 +12,6 @@ import Annex import Options.Applicative -import qualified Data.Semigroup as Sem -import Prelude -- Some values cannot be fully parsed without performing an action. -- The action may be expensive, so it's best to call finishParse on such a @@ -47,7 +45,7 @@ , annexReadSetter :: AnnexRead -> AnnexRead } -instance Sem.Semigroup AnnexSetter where +instance Semigroup AnnexSetter where a <> b = AnnexSetter { annexStateSetter = annexStateSetter a >> annexStateSetter b , annexReadSetter = annexReadSetter b . annexReadSetter a diff --git a/Types/DesktopNotify.hs b/Types/DesktopNotify.hs --- a/Types/DesktopNotify.hs +++ b/Types/DesktopNotify.hs @@ -7,17 +7,13 @@ module Types.DesktopNotify where -import Data.Monoid -import qualified Data.Semigroup as Sem -import Prelude - data DesktopNotify = DesktopNotify { notifyStart :: Bool , notifyFinish :: Bool } deriving (Show) -instance Sem.Semigroup DesktopNotify where +instance Semigroup DesktopNotify where (DesktopNotify s1 f1) <> (DesktopNotify s2 f2) = DesktopNotify (s1 || s2) (f1 || f2) diff --git a/Types/Difference.hs b/Types/Difference.hs --- a/Types/Difference.hs +++ b/Types/Difference.hs @@ -26,11 +26,8 @@ import Git.Types import Data.Maybe -import Data.Monoid import qualified Data.ByteString as B import qualified Data.Set as S -import qualified Data.Semigroup as Sem -import Prelude -- Describes differences from the standard repository format. -- @@ -85,7 +82,7 @@ } appendDifferences _ _ = UnknownDifferences -instance Sem.Semigroup Differences where +instance Semigroup Differences where (<>) = appendDifferences instance Monoid Differences where diff --git a/Types/Distribution.hs b/Types/Distribution.hs --- a/Types/Distribution.hs +++ b/Types/Distribution.hs @@ -14,9 +14,6 @@ import Data.Time.Clock import Git.Config (isTrueFalse, boolConfig) -import Control.Applicative -import Prelude - type GitAnnexVersion = String data GitAnnexDistribution = GitAnnexDistribution diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -157,6 +157,7 @@ , annexSkipUnknown :: Bool , annexAdjustedBranchRefresh :: Integer , annexSupportUnlocked :: Bool + , annexAssistantAllowUnlocked :: Bool , coreSymlinks :: Bool , coreSharedRepository :: SharedRepository , coreQuotePath :: QuotePath @@ -281,6 +282,7 @@ (if getbool "adjustedbranchrefresh" False then 1 else 0) (getmayberead (annexConfig "adjustedbranchrefresh")) , annexSupportUnlocked = getbool (annexConfig "supportunlocked") True + , annexAssistantAllowUnlocked = getbool (annexConfig "assistant.allowunlocked") False , coreSymlinks = getbool "core.symlinks" True , coreSharedRepository = getSharedRepository r , coreQuotePath = QuotePath (getbool "core.quotepath" True) diff --git a/Types/GitRemoteAnnex.hs b/Types/GitRemoteAnnex.hs --- a/Types/GitRemoteAnnex.hs +++ b/Types/GitRemoteAnnex.hs @@ -14,7 +14,6 @@ import Types.Key -import qualified Data.Semigroup as Sem import qualified Data.Set as S -- The manifest contains an ordered list of git bundle keys. @@ -39,7 +38,7 @@ instance Monoid Manifest where mempty = Manifest mempty mempty -instance Sem.Semigroup Manifest where +instance Semigroup Manifest where a <> b = mkManifest (inManifest a <> inManifest b) (S.union (outManifest a) (outManifest b)) diff --git a/Types/Key.hs b/Types/Key.hs --- a/Types/Key.hs +++ b/Types/Key.hs @@ -42,11 +42,9 @@ import Data.Char import System.Posix.Types import Foreign.C.Types -import Data.Monoid import Control.Applicative import GHC.Generics import Control.DeepSeq -import Prelude {- A Key has a unique name, which is derived from a particular backend, - and may contain other optional metadata. -} diff --git a/Types/Transfer.hs b/Types/Transfer.hs --- a/Types/Transfer.hs +++ b/Types/Transfer.hs @@ -23,8 +23,6 @@ import Data.Time.Clock.POSIX import Control.Concurrent -import Control.Applicative -import Prelude {- Enough information to uniquely identify a transfer. -} data Transfer = Transfer diff --git a/Types/UUID.hs b/Types/UUID.hs --- a/Types/UUID.hs +++ b/Types/UUID.hs @@ -20,7 +20,6 @@ import Data.String import Data.ByteString.Builder import Control.DeepSeq -import qualified Data.Semigroup as Sem import Common import Git.Types (ConfigValue(..)) @@ -115,7 +114,7 @@ -- A description of a UUID. newtype UUIDDesc = UUIDDesc B.ByteString - deriving (Eq, Sem.Semigroup, Monoid, IsString) + deriving (Eq, Semigroup, Monoid, IsString) fromUUIDDesc :: UUIDDesc -> String fromUUIDDesc (UUIDDesc d) = decodeBS d diff --git a/Types/VectorClock.hs b/Types/VectorClock.hs --- a/Types/VectorClock.hs +++ b/Types/VectorClock.hs @@ -8,8 +8,6 @@ module Types.VectorClock where import Data.Time.Clock.POSIX -import Control.Applicative -import Prelude import Utility.QuickCheck diff --git a/Upgrade/V2.hs b/Upgrade/V2.hs --- a/Upgrade/V2.hs +++ b/Upgrade/V2.hs @@ -87,7 +87,7 @@ inject :: OsPath -> OsPath -> Annex () inject source dest = do old <- fromRepo olddir - new <- liftIO (readFile $ fromOsPath $ old source) + new <- liftIO $ readFileString (old source) Annex.Branch.change (Annex.Branch.RegardingUUID []) dest $ \prev -> encodeBL $ unlines $ nub $ lines (decodeBL prev) ++ lines new @@ -141,7 +141,7 @@ whenM (doesFileExist attributes) $ do c <- map decodeBS . fileLines' <$> F.readFile' attributes - liftIO $ viaTmp (writeFile . fromOsPath) attributes + liftIO $ viaTmp writeFileString attributes (unlines $ filter (`notElem` attrLines) c) Git.Command.run [Param "add", File (fromOsPath attributes)] repo diff --git a/Upgrade/V7.hs b/Upgrade/V7.hs --- a/Upgrade/V7.hs +++ b/Upgrade/V7.hs @@ -136,7 +136,7 @@ <$> catchDefaultIO "" (F.readFile' lf) let ls' = removedotfilter ls when (ls /= ls') $ - liftIO $ writeFile (fromOsPath lf) (unlines ls') + liftIO $ writeFileString lf (unlines ls') where removedotfilter ("* filter=annex":".* !filter":rest) = "* filter=annex" : removedotfilter rest diff --git a/Utility/Aeson.hs b/Utility/Aeson.hs --- a/Utility/Aeson.hs +++ b/Utility/Aeson.hs @@ -30,7 +30,6 @@ import qualified Data.Set import qualified Data.Map import qualified Data.Vector -import Prelude import Utility.FileSystemEncoding #ifdef WITH_OSPATH diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs --- a/Utility/Daemon.hs +++ b/Utility/Daemon.hs @@ -52,7 +52,8 @@ maybe noop lockPidFile pidfile a _ -> do - nullfd <- openFdWithMode (toRawFilePath "/dev/null") ReadOnly Nothing defaultFileFlags + nullfd <- openFdWithMode (toRawFilePath "/dev/null") ReadOnly Nothing defaultFileFlags + (CloseOnExecFlag True) redir nullfd stdInput redirLog =<< openlogfd environ <- getEnvironment @@ -91,7 +92,8 @@ #endif {- Locks the pid file, with an exclusive, non-blocking lock, - - and leaves it locked on return. + - and leaves it locked on return. The lock file is not closed on exec, so + - when daemonize runs the process again, it inherits it. - - Writes the pid to the file, fully atomically. - Fails if the pid file is already locked by another process. -} @@ -99,9 +101,11 @@ lockPidFile pidfile = do #ifndef mingw32_HOST_OS fd <- openFdWithMode (fromOsPath pidfile) ReadWrite (Just stdFileMode) defaultFileFlags + (CloseOnExecFlag False) locked <- catchMaybeIO $ setLock fd (WriteLock, AbsoluteSeek, 0, 0) - fd' <- openFdWithMode (fromOsPath newfile) ReadWrite (Just stdFileMode) defaultFileFlags - { trunc = True } + fd' <- openFdWithMode (fromOsPath newfile) ReadWrite (Just stdFileMode) + (defaultFileFlags { trunc = True }) + (CloseOnExecFlag True) locked' <- catchMaybeIO $ setLock fd' (WriteLock, AbsoluteSeek, 0, 0) case (locked, locked') of (Nothing, _) -> alreadyRunning @@ -117,9 +121,9 @@ unlessM (isNothing <$> checkDaemon pidfile) alreadyRunning pid <- getPID - writeFile (fromOsPath pidfile) (show pid) + writeFileString pidfile (show pid) lckfile <- winLockFile pid pidfile - writeFile (fromOsPath lckfile) "" + writeFileString lckfile "" void $ lockExclusive lckfile #endif @@ -135,12 +139,15 @@ checkDaemon pidfile = bracket setup cleanup go where setup = catchMaybeIO $ - openFdWithMode (fromOsPath pidfile) ReadOnly (Just stdFileMode) defaultFileFlags + openFdWithMode (fromOsPath pidfile) ReadOnly + (Just stdFileMode) + defaultFileFlags + (CloseOnExecFlag True) cleanup (Just fd) = closeFd fd cleanup Nothing = return () go (Just fd) = catchDefaultIO Nothing $ do locked <- getLock fd (ReadLock, AbsoluteSeek, 0, 0) - p <- readish <$> readFile (fromOsPath pidfile) + p <- readish <$> readFileString pidfile return (check locked p) go Nothing = return Nothing @@ -154,7 +161,7 @@ "; expected " ++ show pid ++ " )" #else checkDaemon pidfile = maybe (return Nothing) (check . readish) - =<< catchMaybeIO (readFile (fromOsPath pidfile)) + =<< catchMaybeIO (readFileString pidfile) where check Nothing = return Nothing check (Just pid) = do diff --git a/Utility/Debug.hs b/Utility/Debug.hs --- a/Utility/Debug.hs +++ b/Utility/Debug.hs @@ -23,8 +23,6 @@ import Data.String import Data.Time import System.IO.Unsafe (unsafePerformIO) -import qualified Data.Semigroup as Sem -import Prelude import Utility.FileSystemEncoding @@ -41,7 +39,7 @@ = DebugSelector (DebugSource -> Bool) | NoDebugSelector -instance Sem.Semigroup DebugSelector where +instance Semigroup DebugSelector where DebugSelector a <> DebugSelector b = DebugSelector (\v -> a v || b v) NoDebugSelector <> NoDebugSelector = NoDebugSelector NoDebugSelector <> b = b diff --git a/Utility/DirWatcher/Kqueue.hs b/Utility/DirWatcher/Kqueue.hs --- a/Utility/DirWatcher/Kqueue.hs +++ b/Utility/DirWatcher/Kqueue.hs @@ -111,7 +111,9 @@ Nothing -> walk c rest Just info -> do mfd <- catchMaybeIO $ - openFdWithMode (toRawFilePath dir) Posix.ReadOnly Nothing Posix.defaultFileFlags + openFdWithMode (toRawFilePath dir) Posix.ReadOnly Nothing + Posix.defaultFileFlags + (CloseOnExecFlag True) case mfd of Nothing -> walk c rest Just fd -> do diff --git a/Utility/Directory.hs b/Utility/Directory.hs --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -19,10 +19,7 @@ #endif import Control.Monad import System.PosixCompat.Files (isDirectory, isSymbolicLink) -import Control.Applicative import System.IO.Unsafe (unsafeInterleaveIO) -import Data.Maybe -import Prelude import Utility.OsPath import Utility.Exception diff --git a/Utility/Directory/Create.hs b/Utility/Directory/Create.hs --- a/Utility/Directory/Create.hs +++ b/Utility/Directory/Create.hs @@ -15,12 +15,9 @@ ) where import Control.Monad -import Control.Applicative import Control.Monad.IO.Class import Control.Monad.IfElse import System.IO.Error -import Data.Maybe -import Prelude import Utility.SystemDirectory import Utility.Path.AbsRel diff --git a/Utility/Directory/Stream.hs b/Utility/Directory/Stream.hs --- a/Utility/Directory/Stream.hs +++ b/Utility/Directory/Stream.hs @@ -21,7 +21,6 @@ import Control.Monad import Control.Concurrent import Data.Maybe -import Prelude #ifdef mingw32_HOST_OS import qualified System.Win32 as Win32 diff --git a/Utility/Env.hs b/Utility/Env.hs --- a/Utility/Env.hs +++ b/Utility/Env.hs @@ -21,7 +21,6 @@ import Utility.Exception import Control.Applicative import Data.Maybe -import Prelude import qualified System.Environment as E #else import qualified System.Posix.Env as PE diff --git a/Utility/Env/Basic.hs b/Utility/Env/Basic.hs --- a/Utility/Env/Basic.hs +++ b/Utility/Env/Basic.hs @@ -13,9 +13,7 @@ ) where import Utility.Exception -import Control.Applicative import Data.Maybe -import Prelude import qualified System.Environment as E getEnv :: String -> IO (Maybe String) diff --git a/Utility/FileIO.hs b/Utility/FileIO.hs --- a/Utility/FileIO.hs +++ b/Utility/FileIO.hs @@ -1,5 +1,14 @@ -{- File IO on OsPaths. +{- This is a subset of the functions provided by file-io, supplimented with + - readFileString, writeFileString, and appendFileString. - + - When building with file-io, all exported functions set the close-on-exec + - flag. Also, some other issues are handled that file-io does not handle + - correctly. + - + - When not building with file-io, this provides equvilant + - RawFilePath versions. Note that those versions do not currently + - set the close-on-exec flag. + - - Since Prelude exports many of these as well, this needs to be imported - qualified. - @@ -25,12 +34,17 @@ appendFile, appendFile', openTempFile, + + readFileString, + writeFileString, + appendFileString, ) where #ifdef WITH_OSPATH #ifndef mingw32_HOST_OS -import System.File.OsPath +import Utility.FileIO.CloseOnExec +import Utility.FileIO.String #else -- On Windows, System.File.OsPath does not handle UNC-style conversion itself, -- so that has to be done when calling it. See @@ -38,8 +52,9 @@ import Utility.Path.Windows import Utility.OsPath import System.IO (IO, Handle, IOMode) -import Prelude (return) -import qualified System.File.OsPath as O +import Prelude (String, return) +import qualified Utility.FileIO.CloseOnExec as O +import qualified Utility.FileIO.String as O import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Control.Applicative @@ -101,15 +116,30 @@ -- Avoid returning mangled path from convertToWindowsNativeNamespace let t' = p takeFileName t return (t', h) + +readFileString :: OsPath -> IO String +readFileString p = do + p' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath p) + O.readFileString p' + +writeFileString :: OsPath -> String -> IO () +writeFileString f txt = do + f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) + O.writeFileString f' txt + +appendFileString :: OsPath -> String -> IO () +appendFileString f txt = do + f' <- toOsPath <$> convertToWindowsNativeNamespace (fromOsPath f) + O.appendFileString f' txt #endif #else --- When not building with OsPath, export RawFilePath versions --- instead. +-- RawFilePath versions import Utility.OsPath import Utility.FileSystemEncoding import System.IO (IO, Handle, IOMode) -import Prelude ((.), return) +import Prelude (String, (.), return) +import qualified Prelude as P import qualified System.IO import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L @@ -150,4 +180,13 @@ (fromRawFilePath p) (fromRawFilePath s) return (toRawFilePath t, h) + +readFileString :: OsPath -> IO String +readFileString = P.readFile . fromRawFilePath + +writeFileString :: OsPath -> String -> IO () +writeFileString = P.writeFile . fromRawFilePath + +appendFileString :: OsPath -> String -> IO () +appendFileString = P.appendFile . fromRawFilePath #endif diff --git a/Utility/FileIO/CloseOnExec.hs b/Utility/FileIO/CloseOnExec.hs new file mode 100644 --- /dev/null +++ b/Utility/FileIO/CloseOnExec.hs @@ -0,0 +1,148 @@ +{- This is a subset of the functions provided by file-io. + - + - All functions have been modified to set the close-on-exec + - flag to True. + - + - Also, functions that return a Handle have been modified to + - use the locale encoding, working around this bug: + - https://github.com/haskell/file-io/issues/45 + - + - Copyright 2025 Joey Hess + - Copyright 2024 Julian Ospald + - + - License: BSD-3-clause + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Utility.FileIO.CloseOnExec +( +#ifdef WITH_OSPATH + withFile, + withFile', + openFile, + withBinaryFile, + openBinaryFile, + readFile, + readFile', + writeFile, + writeFile', + appendFile, + appendFile', + openTempFile, +#endif +) where + +#ifdef WITH_OSPATH + +import System.File.OsPath.Internal (withOpenFile', augmentError) +import qualified System.File.OsPath.Internal as I +import System.IO (IO, Handle, IOMode(..), hSetEncoding) +import GHC.IO.Encoding (getLocaleEncoding) +import System.OsPath (OsPath, OsString) +import Prelude (Bool(..), pure, either, (.), (>>=), ($)) +import Control.Exception +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +#ifndef mingw32_HOST_OS +import System.Posix.IO +import Utility.Process +#endif + +closeOnExec :: Bool +closeOnExec = True + +withFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r +withFile osfp iomode act = (augmentError "withFile" osfp + $ withOpenFileEncoding osfp iomode False False closeOnExec (try . act) True) + >>= either ioError pure + +withFile' :: OsPath -> IOMode -> (Handle -> IO r) -> IO r +withFile' osfp iomode act = (augmentError "withFile'" osfp + $ withOpenFileEncoding osfp iomode False False closeOnExec (try . act) False) + >>= either ioError pure + +openFile :: OsPath -> IOMode -> IO Handle +openFile osfp iomode = augmentError "openFile" osfp $ + withOpenFileEncoding osfp iomode False False closeOnExec pure False + +withBinaryFile :: OsPath -> IOMode -> (Handle -> IO r) -> IO r +withBinaryFile osfp iomode act = (augmentError "withBinaryFile" osfp + $ withOpenFileEncoding osfp iomode True False closeOnExec (try . act) True) + >>= either ioError pure + +openBinaryFile :: OsPath -> IOMode -> IO Handle +openBinaryFile osfp iomode = augmentError "openBinaryFile" osfp $ + withOpenFileEncoding osfp iomode True False closeOnExec pure False + +readFile :: OsPath -> IO BSL.ByteString +readFile fp = withFileNoEncoding' fp ReadMode BSL.hGetContents + +readFile' + :: OsPath -> IO BS.ByteString +readFile' fp = withFileNoEncoding fp ReadMode BS.hGetContents + +writeFile :: OsPath -> BSL.ByteString -> IO () +writeFile fp contents = withFileNoEncoding fp WriteMode (`BSL.hPut` contents) + +writeFile' + :: OsPath -> BS.ByteString -> IO () +writeFile' fp contents = withFileNoEncoding fp WriteMode (`BS.hPut` contents) + +appendFile :: OsPath -> BSL.ByteString -> IO () +appendFile fp contents = withFileNoEncoding fp AppendMode (`BSL.hPut` contents) + +appendFile' + :: OsPath -> BS.ByteString -> IO () +appendFile' fp contents = withFileNoEncoding fp AppendMode (`BS.hPut` contents) + +{- Re-implementing openTempFile is difficult due to the current + - structure of file-io. See this issue for discussion about improving + - that: https://github.com/haskell/file-io/issues/44 + - So, instead this uses noCreateProcessWhile. + - -} +openTempFile :: OsPath -> OsString -> IO (OsPath, Handle) +openTempFile tmp_dir template = do +#ifdef mingw32_HOST_OS + (p, h) <- I.openTempFile tmp_dir template + getLocaleEncoding >>= hSetEncoding h + pure (p, h) +#else + noCreateProcessWhile $ do + (p, h) <- I.openTempFile tmp_dir template + fd <- handleToFd h + setFdOption fd CloseOnExec True + h' <- fdToHandle fd + getLocaleEncoding >>= hSetEncoding h' + pure (p, h') +#endif + +{- Wrapper around withOpenFile' that sets the locale encoding on the + - Handle. -} +withOpenFileEncoding :: OsPath -> IOMode -> Bool -> Bool -> Bool -> (Handle -> IO r) -> Bool -> IO r +withOpenFileEncoding fp iomode binary existing cloExec action close_finally = + withOpenFile' fp iomode binary existing cloExec action' close_finally + where + action' h = do + getLocaleEncoding >>= hSetEncoding h + action h + +{- Variant of withFile above that does not have the overhead of setting the + - locale encoding. Faster to use when the Handle is not used in a way that + - needs any encoding. -} +withFileNoEncoding :: OsPath -> IOMode -> (Handle -> IO r) -> IO r +withFileNoEncoding osfp iomode act = (augmentError "withFile" osfp + $ withOpenFile' osfp iomode False False closeOnExec (try . act) True) + >>= either ioError pure + +{- Variant of withFile' above that does not have the overhead of setting the + - locale encoding. Faster to use when the Handle is not used in a way that + - needs any encoding. -} +withFileNoEncoding' :: OsPath -> IOMode -> (Handle -> IO r) -> IO r +withFileNoEncoding' osfp iomode act = (augmentError "withFile'" osfp + $ withOpenFile' osfp iomode False False closeOnExec (try . act) False) + >>= either ioError pure + +#endif diff --git a/Utility/FileIO/String.hs b/Utility/FileIO/String.hs new file mode 100644 --- /dev/null +++ b/Utility/FileIO/String.hs @@ -0,0 +1,38 @@ +{- Functions that operate on OsPath, but treat the contents of files as + - Strings. + - + - These functions all set the close-on-exec flag to True, unlike + - the Prelude versions. + - + - Copyright 2025 Joey Hess + - + - License: BSD-2-clause + -} + +{-# OPTIONS_GHC -fno-warn-tabs #-} +{-# LANGUAGE CPP #-} + +module Utility.FileIO.String +( +#ifdef WITH_OSPATH + readFileString, + writeFileString, + appendFileString, +#endif +) where + +#ifdef WITH_OSPATH +import qualified Utility.FileIO.CloseOnExec as I +import Utility.OsPath (OsPath) +import Prelude (String, IO, (>>=)) +import System.IO (IOMode(..), hGetContents, hPutStr) + +readFileString :: OsPath -> IO String +readFileString f = I.openFile f ReadMode >>= hGetContents + +writeFileString :: OsPath -> String -> IO () +writeFileString f txt = I.withFile f WriteMode (\hdl -> hPutStr hdl txt) + +appendFileString :: OsPath -> String -> IO () +appendFileString f txt = I.withFile f AppendMode (\hdl -> hPutStr hdl txt) +#endif diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -171,7 +171,7 @@ - When possible, this is done using the umask. - - On a filesystem that does not support file permissions, this is the same - - as writeFile. + - as writeFileString. -} writeFileProtected :: OsPath -> String -> IO () writeFileProtected file content = writeFileProtected' file diff --git a/Utility/FileSystemEncoding.hs b/Utility/FileSystemEncoding.hs --- a/Utility/FileSystemEncoding.hs +++ b/Utility/FileSystemEncoding.hs @@ -119,11 +119,14 @@ toRawFilePath :: FilePath -> RawFilePath toRawFilePath = encodeBS -{- Truncates a FilePath to the given number of bytes (or less), +{- Truncates a path to the given number of bytes (or less), - as represented on disk. - - Avoids returning an invalid part of a unicode byte sequence, at the - cost of efficiency when running on a large FilePath. + - + - Note that this may return ""! That can happen if it is asked to truncate + - to eg 1 byte, but the input path starts with a unicode byte sequence. -} truncateFilePath :: Int -> RawFilePath -> RawFilePath #ifndef mingw32_HOST_OS diff --git a/Utility/FreeDesktop.hs b/Utility/FreeDesktop.hs --- a/Utility/FreeDesktop.hs +++ b/Utility/FreeDesktop.hs @@ -75,7 +75,7 @@ writeDesktopMenuFile :: DesktopEntry -> OsPath -> IO () writeDesktopMenuFile d file = do createDirectoryIfMissing True (takeDirectory file) - writeFile (fromOsPath file) $ buildDesktopMenuFile d + writeFileString file $ buildDesktopMenuFile d {- Path to use for a desktop menu file, in either the systemDataDir or - the userDataDir -} diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs --- a/Utility/Gpg.hs +++ b/Utility/Gpg.hs @@ -162,8 +162,10 @@ #ifndef mingw32_HOST_OS let setup = liftIO $ do -- pipe the passphrase into gpg on a fd - (frompipe, topipe) <- System.Posix.IO.createPipe - setFdOption topipe CloseOnExec True + (frompipe, topipe) <- noCreateProcessWhile $ do + (frompipe, topipe) <- System.Posix.IO.createPipe + setFdOption topipe CloseOnExec True + return (frompipe, topipe) toh <- fdToHandle topipe t <- async $ do B.hPutStr toh (passphrase <> "\n") diff --git a/Utility/Hash.hs b/Utility/Hash.hs --- a/Utility/Hash.hs +++ b/Utility/Hash.hs @@ -1,4 +1,4 @@ -{- Convenience wrapper around cryptonite's hashing. +{- Convenience wrapper around crypton's hashing. - - Copyright 2013-2024 Joey Hess - @@ -7,7 +7,6 @@ {-# LANGUAGE BangPatterns, PackageImports #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE CPP #-} module Utility.Hash ( sha1, @@ -78,13 +77,8 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.IORef -#ifdef WITH_CRYPTON import "crypton" Crypto.MAC.HMAC hiding (Context) import "crypton" Crypto.Hash -#else -import "cryptonite" Crypto.MAC.HMAC hiding (Context) -import "cryptonite" Crypto.Hash -#endif sha1 :: L.ByteString -> Digest SHA1 sha1 = hashlazy diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs --- a/Utility/HumanTime.hs +++ b/Utility/HumanTime.hs @@ -23,8 +23,6 @@ import Data.Time.Clock import Data.Time.Clock.POSIX (POSIXTime) import Data.Char -import Control.Applicative -import Prelude newtype Duration = Duration { durationSeconds :: Integer } deriving (Eq, Ord, Read, Show) diff --git a/Utility/IPAddress.hs b/Utility/IPAddress.hs --- a/Utility/IPAddress.hs +++ b/Utility/IPAddress.hs @@ -23,9 +23,7 @@ import Data.Word import Data.Memory.Endian import Data.List -import Control.Applicative import Text.Printf -import Prelude extractIPAddress :: SockAddr -> Maybe String extractIPAddress (SockAddrInet _ ipv4) = diff --git a/Utility/InodeCache.hs b/Utility/InodeCache.hs --- a/Utility/InodeCache.hs +++ b/Utility/InodeCache.hs @@ -234,7 +234,7 @@ writeSentinalFile :: SentinalFile -> IO () writeSentinalFile s = do F.writeFile' (sentinalFile s) mempty - maybe noop (writeFile (fromOsPath (sentinalCacheFile s)) . showInodeCache) + maybe noop (writeFileString (sentinalCacheFile s) . showInodeCache) =<< genInodeCache (sentinalFile s) noTSDelta data SentinalStatus = SentinalStatus @@ -263,7 +263,7 @@ Just new -> return $ calc old new where loadoldcache = catchDefaultIO Nothing $ - readInodeCache <$> readFile (fromOsPath (sentinalCacheFile s)) + readInodeCache <$> readFileString (sentinalCacheFile s) gennewcache = genInodeCache (sentinalFile s) noTSDelta calc (InodeCache (InodeCachePrim oldinode oldsize oldmtime)) (InodeCache (InodeCachePrim newinode newsize newmtime)) = SentinalStatus (not unchanged) tsdelta diff --git a/Utility/LinuxMkLibs.hs b/Utility/LinuxMkLibs.hs --- a/Utility/LinuxMkLibs.hs +++ b/Utility/LinuxMkLibs.hs @@ -33,8 +33,6 @@ import System.Posix.Files (isSymbolicLink) import Data.Char import Control.Monad.IfElse -import Control.Applicative -import Prelude {- Installs a library. If the library is a symlink to another file, - install the file it links to, and update the symlink to be relative. -} diff --git a/Utility/LockFile/PidLock.hs b/Utility/LockFile/PidLock.hs --- a/Utility/LockFile/PidLock.hs +++ b/Utility/LockFile/PidLock.hs @@ -41,6 +41,7 @@ import Utility.Tmp import Utility.RawFilePath import Utility.OsPath +import qualified Utility.FileIO as F import qualified Utility.LockFile.Posix as Posix import System.IO @@ -48,13 +49,12 @@ import System.Posix.IO.ByteString import System.Posix.Files.ByteString import System.Posix.Process +import GHC.IO.Encoding (getLocaleEncoding) import Control.Monad import Control.Monad.IO.Class (liftIO, MonadIO) import Data.Maybe import Data.List import Network.BSD -import Control.Applicative -import Prelude type PidLockFile = OsPath @@ -77,7 +77,7 @@ readPidLock :: PidLockFile -> IO (Maybe PidLock) readPidLock lockfile = (readish =<<) - <$> catchMaybeIO (readFile (fromOsPath lockfile)) + <$> catchMaybeIO (F.readFileString lockfile) -- To avoid races when taking over a stale pid lock, a side lock is used. -- This is a regular posix exclusive lock. @@ -210,10 +210,13 @@ let setup = do fd <- openFdWithMode dest' WriteOnly (Just $ combineModes readModes) - (defaultFileFlags {exclusive = True}) - fdToHandle fd + (defaultFileFlags { exclusive = True }) + (CloseOnExecFlag True) + h <- fdToHandle fd + getLocaleEncoding >>= hSetEncoding h + return h let cleanup = hClose - let go h = readFile (fromOsPath src) >>= hPutStr h + let go h = F.readFileString src >>= hPutStr h bracket setup cleanup go getFileStatus dest' where diff --git a/Utility/LockFile/Posix.hs b/Utility/LockFile/Posix.hs --- a/Utility/LockFile/Posix.hs +++ b/Utility/LockFile/Posix.hs @@ -74,11 +74,10 @@ -- Close on exec flag is set so child processes do not inherit the lock. openLockFile :: LockRequest -> Maybe ModeSetter -> LockFile -> IO Fd -openLockFile lockreq filemode lockfile = do - l <- applyModeSetter filemode lockfile $ \filemode' -> - openFdWithMode (fromOsPath lockfile) openfor filemode' defaultFileFlags - setFdOption l CloseOnExec True - return l +openLockFile lockreq filemode lockfile = + applyModeSetter filemode lockfile $ \filemode' -> + openFdWithMode (fromOsPath lockfile) openfor filemode' + defaultFileFlags (CloseOnExecFlag True) where openfor = case lockreq of ReadLock -> ReadOnly diff --git a/Utility/LockPool/LockHandle.hs b/Utility/LockPool/LockHandle.hs --- a/Utility/LockPool/LockHandle.hs +++ b/Utility/LockPool/LockHandle.hs @@ -25,7 +25,6 @@ import Control.Concurrent.STM import Control.Monad.Catch import Control.Monad.IO.Class (liftIO, MonadIO) -import Prelude data LockHandle = LockHandle P.LockHandle FileLockOps diff --git a/Utility/LockPool/PidLock.hs b/Utility/LockPool/PidLock.hs --- a/Utility/LockPool/PidLock.hs +++ b/Utility/LockPool/PidLock.hs @@ -25,15 +25,12 @@ import Utility.LockPool.LockHandle import Utility.ThreadScheduler -import System.IO import System.Posix import Control.Concurrent.STM import Data.Maybe import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class -import Control.Applicative -import Prelude -- Does locking using a pid lock, blocking until the lock is available -- or the Seconds timeout if the pid lock is held by another process. diff --git a/Utility/LockPool/Posix.hs b/Utility/LockPool/Posix.hs --- a/Utility/LockPool/Posix.hs +++ b/Utility/LockPool/Posix.hs @@ -26,11 +26,7 @@ import Utility.LockPool.LockHandle import Utility.FileMode -import System.IO import System.Posix -import Data.Maybe -import Control.Applicative -import Prelude -- Takes a shared lock, blocking until the lock is available. lockShared :: Maybe ModeSetter -> LockFile -> IO LockHandle diff --git a/Utility/MagicWormhole.hs b/Utility/MagicWormhole.hs --- a/Utility/MagicWormhole.hs +++ b/Utility/MagicWormhole.hs @@ -38,8 +38,6 @@ import Control.Concurrent.Async import Data.Char import Data.List -import Control.Applicative -import Prelude -- | A Magic Wormhole code. newtype Code = Code String diff --git a/Utility/Misc.hs b/Utility/Misc.hs --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -34,12 +34,10 @@ import Data.Char import Data.List import System.Exit -import Control.Applicative import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8 -import Prelude {- A version of hgetContents that is not lazy. Ensures file is - all read before it gets closed. -} @@ -110,7 +108,7 @@ fileLines' = S8.lines #endif --- One windows, writeFile does NewlineMode translation, +-- On windows, writeFile does NewlineMode translation, -- adding CR before LF. When converting to ByteString, use this to emulate that. linesFile :: L.ByteString -> L.ByteString #ifndef mingw32_HOST_OS diff --git a/Utility/MoveFile.hs b/Utility/MoveFile.hs --- a/Utility/MoveFile.hs +++ b/Utility/MoveFile.hs @@ -15,7 +15,6 @@ import Control.Monad import System.IO.Error -import Prelude #ifndef mingw32_HOST_OS import System.PosixCompat.Files (isDirectory) diff --git a/Utility/Network.hs b/Utility/Network.hs --- a/Utility/Network.hs +++ b/Utility/Network.hs @@ -12,9 +12,6 @@ import Utility.Process import Utility.Exception -import Control.Applicative -import Prelude - {- Haskell lacks uname(2) bindings, except in the - Bindings.Uname addon. Rather than depend on that, - use uname -n when available. -} diff --git a/Utility/OpenFd.hs b/Utility/OpenFd.hs --- a/Utility/OpenFd.hs +++ b/Utility/OpenFd.hs @@ -1,6 +1,6 @@ {- openFd wrapper to support old versions of unix package. - - - Copyright 2023 Joey Hess + - Copyright 2023-2025 Joey Hess - - License: BSD-2-clause -} @@ -17,12 +17,17 @@ import Utility.RawFilePath -openFdWithMode :: RawFilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd +newtype CloseOnExecFlag = CloseOnExecFlag Bool + +openFdWithMode :: RawFilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> CloseOnExecFlag -> IO Fd +openFdWithMode f openmode filemode flags (CloseOnExecFlag closeonexec) = do #if MIN_VERSION_unix(2,8,0) -openFdWithMode f openmode filemode flags = - openFd f openmode (flags { creat = filemode }) + openFd f openmode (flags { creat = filemode, cloexec = closeonexec }) #else -openFdWithMode = openFd + fd <- openFd f openmode filemode flags + when closeonexec $ + setFdOption fd CloseOnExec True + return fd #endif #endif diff --git a/Utility/OpenFile.hs b/Utility/OpenFile.hs --- a/Utility/OpenFile.hs +++ b/Utility/OpenFile.hs @@ -31,7 +31,7 @@ -} openFileBeingWritten :: RawFilePath -> IO Handle openFileBeingWritten f = do - fd <- openFdWithMode f ReadOnly Nothing defaultFileFlags + fd <- openFdWithMode f ReadOnly Nothing defaultFileFlags (CloseOnExecFlag True) (fd', fdtype) <- mkFD (fromIntegral fd) ReadMode (Just (Stream, 0, 0)) False False mkHandleFromFD fd' fdtype (fromRawFilePath f) ReadMode False Nothing diff --git a/Utility/OptParse.hs b/Utility/OptParse.hs --- a/Utility/OptParse.hs +++ b/Utility/OptParse.hs @@ -11,8 +11,6 @@ ) where import Options.Applicative -import Data.Monoid -import Prelude -- | A switch that can be enabled using --foo and disabled using --no-foo. -- diff --git a/Utility/Path.hs b/Utility/Path.hs --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -31,8 +31,6 @@ import Data.List import Data.Maybe import Control.Monad -import Control.Applicative -import Prelude import Author import Utility.Monad diff --git a/Utility/Path/AbsRel.hs b/Utility/Path/AbsRel.hs --- a/Utility/Path/AbsRel.hs +++ b/Utility/Path/AbsRel.hs @@ -18,8 +18,6 @@ ) where import qualified Data.ByteString as B -import Control.Applicative -import Prelude import Utility.Path import Utility.UserInfo diff --git a/Utility/Path/Max.hs b/Utility/Path/Max.hs --- a/Utility/Path/Max.hs +++ b/Utility/Path/Max.hs @@ -13,9 +13,6 @@ #ifndef mingw32_HOST_OS import Utility.Exception import System.Posix.Files -import Data.List -import Control.Applicative -import Prelude #endif {- Maximum size to use for a file in a specified directory. diff --git a/Utility/Path/Tests.hs b/Utility/Path/Tests.hs --- a/Utility/Path/Tests.hs +++ b/Utility/Path/Tests.hs @@ -17,11 +17,6 @@ prop_dirContains_regressionTest, ) where -import Data.List -import Data.Maybe -import Control.Applicative -import Prelude - import Common import Utility.QuickCheck import qualified Utility.OsString as OS diff --git a/Utility/Process.hs b/Utility/Process.hs --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -1,7 +1,8 @@ {- System.Process enhancements, including additional ways of running - - processes, and logging. + - processes, logging, and amelorations for cases where FDs are not able to + - be opened with close-on-exec. - - - Copyright 2012-2020 Joey Hess + - Copyright 2012-2025 Joey Hess - - License: BSD-2-clause -} @@ -21,6 +22,7 @@ forceSuccessProcess', checkSuccessProcess, withNullHandle, + noCreateProcessWhile, createProcess, withCreateProcess, waitForProcess, @@ -36,7 +38,7 @@ ) where import qualified Utility.Process.Shim -import Utility.Process.Shim as X (CreateProcess(..), ProcessHandle, StdStream(..), CmdSpec(..), proc, getPid, getProcessExitCode, shell, terminateProcess, interruptProcessGroupOf) +import Utility.Process.Shim as X (CreateProcess(..), ProcessHandle, StdStream(..), CmdSpec(..), proc, getPid, getProcessExitCode, shell, terminateProcess, interruptProcessGroupOf, Pid) import Utility.Misc import Utility.Exception import Utility.Monad @@ -46,7 +48,9 @@ import System.IO import Control.Monad.IO.Class import Control.Concurrent.Async +import Control.Concurrent import qualified Data.ByteString as S +import System.IO.Unsafe (unsafePerformIO) data StdHandle = StdinHandle | StdoutHandle | StderrHandle deriving (Eq) @@ -173,9 +177,34 @@ (Just from, Just to, _, pid) <- createProcess p return (pid, to, from) --- | Wrapper around 'System.Process.createProcess' that does debug logging. +-- | Runs an action, preventing any new processes from being started +-- until it is finished. +-- +-- Unfortunately, Haskell has a pervasive problem with the close-on-exec +-- flag not being set when opening files. It's also difficult to portably +-- dup or pipe a FD with the close-on-exec flag set. So, this can be used +-- to run an action that opens a FD, and then calls setFdOption to set the +-- close-on-exec flag, without risking a race with a process being forked +-- at the same time. +-- +-- Note that only one of these actions can run at a time, and long-duration +-- actions are not advisable. +noCreateProcessWhile :: (MonadIO m, MonadMask m) => (m a) -> m a +noCreateProcessWhile = bracket setup cleanup . const + where + setup = liftIO $ takeMVar createProcessSem + cleanup () = liftIO $ putMVar createProcessSem () + +-- | A shared global MVar. Processes are not created while it is empty. +{-# NOINLINE createProcessSem #-} +createProcessSem :: MVar () +createProcessSem = unsafePerformIO $ newMVar () + +-- | Wrapper around 'System.Process.createProcess'. +-- This adds debug logging, and avoids starting a process when in a +-- noCreateProcessWhile block. createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -createProcess p = do +createProcess p = noCreateProcessWhile $ do r@(_, _, _, h) <- Utility.Process.Shim.createProcess p debugProcess p h return r diff --git a/Utility/Process/Transcript.hs b/Utility/Process/Transcript.hs --- a/Utility/Process/Transcript.hs +++ b/Utility/Process/Transcript.hs @@ -23,11 +23,9 @@ #ifndef mingw32_HOST_OS import Control.Exception import qualified System.Posix.IO -#else -import Control.Applicative +import GHC.IO.Encoding (getLocaleEncoding) #endif import Data.Maybe -import Prelude -- | Runs a process and returns a transcript combining its stdout and -- stderr, and whether it succeeded or failed. @@ -45,12 +43,15 @@ #ifndef mingw32_HOST_OS {- This implementation interleves stdout and stderr in exactly the order - the process writes them. -} - let setup = do + let setup = noCreateProcessWhile $ do (readf, writef) <- System.Posix.IO.createPipe System.Posix.IO.setFdOption readf System.Posix.IO.CloseOnExec True System.Posix.IO.setFdOption writef System.Posix.IO.CloseOnExec True readh <- System.Posix.IO.fdToHandle readf writeh <- System.Posix.IO.fdToHandle writef + enc <- getLocaleEncoding + hSetEncoding readh enc + hSetEncoding writeh enc return (readh, writeh) let cleanup (readh, writeh) = do hClose readh diff --git a/Utility/QuickCheck.hs b/Utility/QuickCheck.hs --- a/Utility/QuickCheck.hs +++ b/Utility/QuickCheck.hs @@ -24,7 +24,6 @@ import Data.Char import System.Posix.Types import Data.List.NonEmpty (NonEmpty(..)) -import Prelude {- A String, but Arbitrary is limited to ascii. - diff --git a/Utility/SafeCommand.hs b/Utility/SafeCommand.hs --- a/Utility/SafeCommand.hs +++ b/Utility/SafeCommand.hs @@ -26,9 +26,6 @@ import System.Exit import System.FilePath import Data.Char -import Data.List -import Control.Applicative -import Prelude -- | Parameters that can be passed to a shell command. data CommandParam diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs --- a/Utility/Scheduled.hs +++ b/Utility/Scheduled.hs @@ -40,8 +40,6 @@ import Data.Time.Calendar.OrdinalDate import Data.Time.Format () import Data.Char -import Control.Applicative -import Prelude {- Some sort of scheduled event. -} data Schedule = Schedule Recurrence ScheduledTime diff --git a/Utility/Scheduled/QuickCheck.hs b/Utility/Scheduled/QuickCheck.hs --- a/Utility/Scheduled/QuickCheck.hs +++ b/Utility/Scheduled/QuickCheck.hs @@ -12,9 +12,6 @@ import Utility.Scheduled import Utility.QuickCheck -import Control.Applicative -import Prelude - instance Arbitrary Schedule where arbitrary = Schedule <$> arbitrary <*> arbitrary diff --git a/Utility/Shell.hs b/Utility/Shell.hs --- a/Utility/Shell.hs +++ b/Utility/Shell.hs @@ -19,6 +19,7 @@ import Utility.Path import Utility.Exception import Utility.PartialPrelude +import Utility.FileIO (readFileString) #endif shellPath :: FilePath @@ -37,7 +38,7 @@ #ifndef mingw32_HOST_OS defcmd #else - l <- catchDefaultIO Nothing $ headMaybe . lines <$> readFile (fromOsPath f) + l <- catchDefaultIO Nothing $ headMaybe . lines <$> readFileString f case l of Just ('#':'!':rest) -> case words rest of [] -> defcmd diff --git a/Utility/ShellEscape.hs b/Utility/ShellEscape.hs --- a/Utility/ShellEscape.hs +++ b/Utility/ShellEscape.hs @@ -18,10 +18,9 @@ import Author import Utility.QuickCheck import Utility.Split -import Data.Function +import Data.Function import Data.List -import Prelude copyright :: Copyright copyright = author JoeyHess (2000+30-20) diff --git a/Utility/StatelessOpenPGP.hs b/Utility/StatelessOpenPGP.hs --- a/Utility/StatelessOpenPGP.hs +++ b/Utility/StatelessOpenPGP.hs @@ -141,8 +141,10 @@ #ifndef mingw32_HOST_OS let setup = liftIO $ do -- pipe the passphrase in on a fd - (frompipe, topipe) <- System.Posix.IO.createPipe - setFdOption topipe CloseOnExec True + (frompipe, topipe) <- noCreateProcessWhile $ do + (frompipe, topipe) <- System.Posix.IO.createPipe + setFdOption topipe CloseOnExec True + return (frompipe, topipe) toh <- fdToHandle topipe t <- async $ do B.hPutStr toh (password <> "\n") diff --git a/Utility/Tmp.hs b/Utility/Tmp.hs --- a/Utility/Tmp.hs +++ b/Utility/Tmp.hs @@ -49,13 +49,13 @@ let loc = ioeGetLocation e ++ " template " ++ decodeBS (fromOsPath template) in annotateIOError e loc Nothing Nothing -{- Runs an action like writeFile, writing to a temp file first and +{- Runs an action like writeFileString, writing to a temp file first and - then moving it into place. The temp file is stored in the same - directory as the final file to avoid cross-device renames. - - While this uses a temp file, the file will end up with the same - - mode as it would when using writeFile, unless the writer action changes - - it. + - mode as it would when using writeFileString, unless the writer action + - changes it. -} viaTmp :: (MonadMask m, MonadIO m) => (OsPath -> v -> m ()) -> OsPath -> v -> m () viaTmp a file content = bracketIO setup cleanup use @@ -116,17 +116,32 @@ #ifndef mingw32_HOST_OS relatedTemplate' f | len > templateAddedLength = - {- Some filesystems like FAT have issues with filenames - - ending in ".", and others like VFAT don't allow a - - filename to end with trailing whitespace, so avoid - - truncating a filename to end that way. -} - B.dropWhileEnd disallowed $ - truncateFilePath (len - templateAddedLength) f + let p = fixend $ truncateFilePath (len - templateAddedLength) f + in if B.null p + then "t" + else p | otherwise = f where len = B.length f - disallowed c = c == dot || isSpace (chr (fromIntegral c)) + {- Some filesystems like FAT have issues with filenames + - ending in ".", and others like VFAT don't allow a + - filename to end with trailing whitespace, so avoid + - truncating a filename to end that way. + - + - Checking with unsnoc for the path to end with a disallowed + - character doesn't take wide characters into account, + - so will have false positives, but it is fast. + -} + fixend p = case B.unsnoc p of + Just (_, c) | disallowed c -> + -- Convert to String to take wide characters into + -- account. + toRawFilePath $ reverse $ + dropWhile (disallowed . fromIntegral . ord) $ + reverse $ fromRawFilePath p + _ -> p dot = fromIntegral (ord '.') + disallowed c = c == dot || isSpace (chr (fromIntegral c)) #else -- Avoids a test suite failure on windows, reason unknown, but -- best to keep paths short on windows anyway. diff --git a/Utility/Tor.hs b/Utility/Tor.hs --- a/Utility/Tor.hs +++ b/Utility/Tor.hs @@ -71,7 +71,7 @@ addHiddenService :: AppName -> UserID -> UniqueIdent -> IO (OnionAddress, OnionPort) addHiddenService appname uid ident = do prepHiddenServiceSocketDir appname uid ident - ls <- lines <$> (readFile . fromOsPath =<< findTorrc) + ls <- lines <$> (readFileString =<< findTorrc) let portssocks = mapMaybe (parseportsock . separate isSpace) ls case filter (\(_, s) -> s == fromOsPath sockfile) portssocks of ((p, _s):_) -> waithiddenservice 1 p @@ -80,7 +80,7 @@ let newport = fromMaybe (error "internal") $ headMaybe $ filter (`notElem` map fst portssocks) highports torrc <- findTorrc - writeFile (fromOsPath torrc) $ unlines $ + writeFileString torrc $ unlines $ ls ++ [ "" , "HiddenServiceDir " ++ fromOsPath (hiddenServiceDir appname uid ident) @@ -112,7 +112,7 @@ waithiddenservice :: Int -> OnionPort -> IO (OnionAddress, OnionPort) waithiddenservice 0 _ = giveup "tor failed to create hidden service, perhaps the tor service is not running" waithiddenservice n p = do - v <- tryIO $ readFile $ fromOsPath $ + v <- tryIO $ readFileString $ hiddenServiceHostnameFile appname uid ident case v of Right s | ".onion\n" `isSuffixOf` s -> @@ -152,7 +152,7 @@ getHiddenServiceSocketFile :: AppName -> UserID -> UniqueIdent -> IO (Maybe OsPath) getHiddenServiceSocketFile _appname uid ident = parse . map words . lines <$> catchDefaultIO "" - (readFile . fromOsPath =<< findTorrc) + (readFileString =<< findTorrc) where parse [] = Nothing parse (("HiddenServiceDir":hsdir:[]):("HiddenServicePort":_hsport:hsaddr:[]):rest) diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -18,14 +18,11 @@ import Utility.Exception #ifndef mingw32_HOST_OS import Utility.Data -import Control.Applicative import System.Posix.User #if MIN_VERSION_unix(2,8,0) import System.Posix.User.ByteString (UserEntry) #endif #endif - -import Prelude {- Current user's home directory. - diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 10.20250828 +Version: 10.20250925 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess @@ -169,14 +169,12 @@ Flag MagicMime Description: Use libmagic to determine file MIME types -Flag Crypton - Description: Use the crypton library rather than the no longer maintained cryptonite - Flag Servant Description: Use the servant library, enabling using annex+http urls and git-annex p2phttp Flag OsPath Description: Use the os-string library and related libraries, for faster filename manipulation + Default: True Flag Benchmark Description: Enable benchmarking @@ -205,7 +203,7 @@ time (>= 1.9.1), directory (>= 1.2.7.0), async, - utf8-string, + utf8-string (>= 1.0.0), Cabal (< 4.0) Executable git-annex @@ -233,7 +231,7 @@ IfElse, monad-logger (>= 0.3.10), free, - utf8-string, + utf8-string (>= 1.0.0), bytestring, text, sandi, @@ -283,7 +281,8 @@ network (>= 3.0.0.0), network-bsd, git-lfs (>= 1.2.0), - clock (>= 0.3.0) + clock (>= 0.3.0), + crypton CC-Options: -Wall GHC-Options: -Wall -fno-warn-tabs -Wincomplete-uni-patterns Default-Language: Haskell2010 @@ -310,12 +309,6 @@ if os(linux) || os(freebsd) GHC-Options: -optl-Wl,--as-needed - if flag(Crypton) - Build-Depends: crypton - CPP-Options: -DWITH_CRYPTON - else - Build-Depends: cryptonite (>= 0.23) - if flag(Servant) Build-Depends: servant, @@ -1147,6 +1140,8 @@ Utility.Su Utility.SystemDirectory Utility.FileIO + Utility.FileIO.CloseOnExec + Utility.FileIO.String Utility.Terminal Utility.TimeStamp Utility.TList diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -9,7 +9,6 @@ dbus: false debuglocks: false benchmark: true - crypton: true servant: true ospath: true packages: