git-annex 10.20220222 → 10.20220322
raw patch · 39 files changed
+543/−616 lines, 39 filesdep +ansi-terminaldep ~networkdep ~tasty
Dependencies added: ansi-terminal
Dependency ranges changed: network, tasty
Files
- Annex.hs +1/−1
- Annex/CatFile.hs +1/−1
- Annex/Content.hs +18/−9
- Annex/Init.hs +5/−3
- Annex/Link.hs +76/−27
- Annex/Perms.hs +39/−14
- Annex/Url.hs +0/−6
- Annex/View.hs +1/−1
- Assistant/Monad.hs +1/−0
- Assistant/Threads/Watcher.hs +1/−1
- CHANGELOG +43/−0
- COPYRIGHT +0/−5
- CmdLine/Seek.hs +11/−6
- Command/Add.hs +15/−10
- Command/FilterProcess.hs +2/−2
- Command/Info.hs +2/−2
- Command/Smudge.hs +20/−13
- Command/TestRemote.hs +1/−1
- Database/Keys.hs +1/−1
- Messages/JSON.hs +9/−5
- Remote.hs +5/−4
- Remote/Directory.hs +49/−45
- Remote/Helper/Encryptable.hs +1/−1
- Test.hs +32/−76
- Test/Framework.hs +157/−26
- Types/MetaData.hs +1/−1
- Types/Test.hs +3/−14
- Utility/Aeson.hs +17/−1
- Utility/AuthToken.hs +2/−0
- Utility/Base64.hs +2/−0
- Utility/Hash.hs +1/−1
- Utility/HttpManagerRestricted.hs +0/−300
- Utility/Path/Tests.hs +2/−1
- Utility/Url.hs +0/−5
- Utility/WebApp.hs +1/−1
- doc/git-annex-test.mdwn +5/−0
- doc/git-annex.mdwn +10/−7
- git-annex.cabal +8/−23
- stack.yaml +0/−2
Annex.hs view
@@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE GeneralizedNewtypeDeriving, BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, BangPatterns, PackageImports #-} module Annex ( Annex,
Annex/CatFile.hs view
@@ -162,7 +162,7 @@ -- Avoid catting large files, that cannot be symlinks or -- pointer files, which would require buffering their -- content in memory, as well as a lot of IO.- | sz <= maxPointerSz =+ | sz <= fromIntegral maxPointerSz = parseLinkTargetOrPointer . L.toStrict <$> catObject ref catKey' _ _ = return Nothing
Annex/Content.hs view
@@ -598,6 +598,14 @@ cleanObjectLoc key cleaner = do file <- calcRepo (gitAnnexLocation key) void $ tryIO $ thawContentDir file+ {- Thawing is not necessary when the file was frozen only+ - by removing write perms. But if there is a thaw hook, it may do+ - something else that is necessary to allow the file to be+ - deleted. + -}+ whenM hasThawHook $+ void $ tryIO $ thawContent file+ cleaner liftIO $ cleanObjectDirs file @@ -623,15 +631,16 @@ where -- Check associated pointer file for modifications, and reset if -- it's unmodified.- resetpointer file = ifM (isUnmodified key file)- ( adjustedBranchRefresh (AssociatedFile (Just file)) $- depopulatePointerFile 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- -- removal process, so thaw it.- , void $ tryIO $ thawContent file- )+ resetpointer file = unlessM (liftIO $ isSymbolicLink <$> getSymbolicLinkStatus (fromRawFilePath file)) $+ ifM (isUnmodified key file)+ ( adjustedBranchRefresh (AssociatedFile (Just file)) $+ depopulatePointerFile 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+ -- removal process, so thaw it.+ , void $ tryIO $ thawContent file+ ) {- Moves a key out of .git/annex/objects/ into .git/annex/bad, and - returns the file it was moved to. -}
Annex/Init.hs view
@@ -251,6 +251,7 @@ (r, warnings) <- probeCrippledFileSystem' tmp (Just (freezeContent' UnShared)) (Just (thawContent' UnShared))+ =<< hasFreezeHook mapM_ warning warnings return r @@ -259,11 +260,12 @@ => RawFilePath -> Maybe (RawFilePath -> m ()) -> Maybe (RawFilePath -> m ())+ -> Bool -> m (Bool, [String]) #ifdef mingw32_HOST_OS-probeCrippledFileSystem' _ _ _ = return (True, [])+probeCrippledFileSystem' _ _ _ _ = return (True, []) #else-probeCrippledFileSystem' tmp freezecontent thawcontent = do+probeCrippledFileSystem' tmp freezecontent thawcontent hasfreezehook = do let f = tmp P.</> "gaprobe" let f' = fromRawFilePath f liftIO $ writeFile f' ""@@ -282,7 +284,7 @@ -- running as root). But some crippled -- filesystems ignore write bit removals or ignore -- permissions entirely.- ifM ((== Just False) <$> liftIO (checkContentWritePerm' UnShared (toRawFilePath f) Nothing))+ ifM ((== Just False) <$> liftIO (checkContentWritePerm' UnShared (toRawFilePath f) Nothing hasfreezehook)) ( return (True, ["Filesystem does not allow removing write bit from files."]) , liftIO $ ifM ((== 0) <$> getRealUserID) ( return (False, [])
Annex/Link.hs view
@@ -7,7 +7,7 @@ - - Pointer files are used instead of symlinks for unlocked files. -- - Copyright 2013-2021 Joey Hess <id@joeyh.name>+ - Copyright 2013-2022 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -82,10 +82,10 @@ probesymlink = R.readSymbolicLink file probefilecontent = withFile (fromRawFilePath file) ReadMode $ \h -> do- s <- S.hGet h unpaddedMaxPointerSz+ s <- S.hGet h maxSymlinkSz -- If we got the full amount, the file is too large -- to be a symlink target.- return $ if S.length s == unpaddedMaxPointerSz+ return $ if S.length s == maxSymlinkSz then mempty else -- If there are any NUL or newline@@ -295,33 +295,70 @@ , "git update-index -q --refresh " ++ fromMaybe "<file>" mf ] -{- Parses a symlink target or a pointer file to a Key. -}+{- Parses a symlink target or a pointer file to a Key.+ -+ - Makes sure that the pointer file is valid, including not being longer+ - than the maximum allowed size of a valid pointer file, and that any+ - subsequent lines after the first contain the validPointerLineTag.+ - If a valid pointer file gets some other data appended to it, it should+ - never be considered valid, unless that data happened to itself be a+ - valid pointer file.+ -} parseLinkTargetOrPointer :: S.ByteString -> Maybe Key-parseLinkTargetOrPointer = parseLinkTarget . S8.takeWhile (not . lineend)- where- lineend '\n' = True- lineend '\r' = True- lineend _ = False+parseLinkTargetOrPointer = either (const Nothing) id+ . parseLinkTargetOrPointer' -{- Avoid looking at more of the lazy ByteString than necessary since it- - could be reading from a large file that is not a pointer file. -}-parseLinkTargetOrPointerLazy :: L.ByteString -> Maybe Key-parseLinkTargetOrPointerLazy b = - let b' = L.take (fromIntegral maxPointerSz) b- in parseLinkTargetOrPointer (L.toStrict b')+data InvalidAppendedPointerFile = InvalidAppendedPointerFile -{- Parses a symlink target to a Key. -}-parseLinkTarget :: S.ByteString -> Maybe Key-parseLinkTarget l- | isLinkToAnnex l = fileKey $ snd $ S8.breakEnd pathsep l- | otherwise = Nothing+parseLinkTargetOrPointer' :: S.ByteString -> Either InvalidAppendedPointerFile (Maybe Key)+parseLinkTargetOrPointer' b = + let (firstline, rest) = S8.span (/= '\n') b+ in case parsekey $ droptrailing '\r' firstline of+ Just k+ | S.length b > maxValidPointerSz -> Left InvalidAppendedPointerFile+ | restvalid (dropleading '\n' rest) -> Right (Just k)+ | otherwise -> Left InvalidAppendedPointerFile+ Nothing -> Right Nothing where+ parsekey l+ | isLinkToAnnex l = fileKey $ snd $ S8.breakEnd pathsep l+ | otherwise = Nothing++ restvalid r+ | S.null r = True+ | otherwise = + let (l, r') = S8.span (/= '\n') r+ in validPointerLineTag `S.isInfixOf` l+ && (not (S8.null r') && S8.head r' == '\n')+ && restvalid (S8.tail r')++ dropleading c l+ | S.null l = l+ | S8.head l == c = S8.tail l+ | otherwise = l+ + droptrailing c l+ | S.null l = l+ | S8.last l == c = S8.init l+ | otherwise = l+ pathsep '/' = True #ifdef mingw32_HOST_OS pathsep '\\' = True #endif pathsep _ = False +{- Avoid looking at more of the lazy ByteString than necessary since it+ - could be reading from a large file that is not a pointer file. -}+parseLinkTargetOrPointerLazy :: L.ByteString -> Maybe Key+parseLinkTargetOrPointerLazy = either (const Nothing) id+ . parseLinkTargetOrPointerLazy'++parseLinkTargetOrPointerLazy' :: L.ByteString -> Either InvalidAppendedPointerFile (Maybe Key)+parseLinkTargetOrPointerLazy' b = + let b' = L.take (fromIntegral maxPointerSz) b+ in parseLinkTargetOrPointer' (L.toStrict b')+ formatPointer :: Key -> S.ByteString formatPointer k = prefix <> keyFile k <> nl where@@ -333,14 +370,22 @@ - memory when reading files that may be pointers. - - 8192 bytes is plenty for a pointer to a key. This adds some additional- - padding to allow for any pointer files that might have- - lines after the key explaining what the file is used for. -}-maxPointerSz :: Integer-maxPointerSz = 81920+ - padding to allow for pointer files that have lines of additional data+ - after the key.+ -+ - One additional byte is used to detect when a valid pointer file+ - got something else appended to it.+ -}+maxPointerSz :: Int+maxPointerSz = maxValidPointerSz + 1 -unpaddedMaxPointerSz :: Int-unpaddedMaxPointerSz = 8192+{- Maximum size of a valid pointer files is 32kb. -}+maxValidPointerSz :: Int+maxValidPointerSz = 32768 +maxSymlinkSz :: Int+maxSymlinkSz = 8192+ {- Checks if a worktree file is a pointer to a key. - - Unlocked files whose content is present are not detected by this.@@ -369,7 +414,7 @@ where checkcontentfollowssymlinks = withFile (fromRawFilePath f) ReadMode readhandle- readhandle h = parseLinkTargetOrPointer <$> S.hGet h unpaddedMaxPointerSz+ readhandle h = parseLinkTargetOrPointer <$> S.hGet h maxPointerSz {- Checks a symlink target or pointer file first line to see if it - appears to point to annexed content.@@ -389,3 +434,7 @@ #ifdef mingw32_HOST_OS p' = toInternalGitPath p #endif++{- String that must appear on every line of a valid pointer file. -}+validPointerLineTag :: S.ByteString+validPointerLineTag = "/annex/"
Annex/Perms.hs view
@@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-}+ module Annex.Perms ( FileMode, setAnnexFilePerm,@@ -26,6 +28,8 @@ thawContentDir, modifyContent, withShared,+ hasFreezeHook,+ hasThawHook, ) where import Annex.Common@@ -154,6 +158,7 @@ freezeContent'' :: SharedRepository -> RawFilePath -> Maybe RepoVersion -> Annex () freezeContent'' sr file rv = do+ fastDebug "Annex.Perms" ("freezing content " ++ fromRawFilePath file) go sr freezeHook file where@@ -183,26 +188,35 @@ - permissions of a file owned by another user. So if the permissions seem - wrong, but the repository is shared, returns Nothing. If the permissions - are wrong otherwise, returns Just False.+ -+ - When there is a freeze hook, it may prevent write in some way other than+ - permissions. One use of a freeze hook is when the filesystem does not+ - support removing write permissions, so when there is such a hook+ - write permissions are ignored. -} checkContentWritePerm :: RawFilePath -> Annex (Maybe Bool) checkContentWritePerm file = ifM crippledFileSystem ( return (Just True) , do rv <- getVersion- withShared (\sr -> liftIO (checkContentWritePerm' sr file rv))+ hasfreezehook <- hasFreezeHook+ withShared $ \sr -> liftIO $+ checkContentWritePerm' sr file rv hasfreezehook ) -checkContentWritePerm' :: SharedRepository -> RawFilePath -> Maybe RepoVersion -> IO (Maybe Bool)-checkContentWritePerm' sr file rv = case sr of- GroupShared- | versionNeedsWritableContentFiles rv -> want sharedret- (includemodes [ownerWriteMode, groupWriteMode])- | otherwise -> want sharedret (excludemodes writeModes)- AllShared- | versionNeedsWritableContentFiles rv -> - want sharedret (includemodes writeModes)- | otherwise -> want sharedret (excludemodes writeModes)- _ -> want Just (excludemodes writeModes)+checkContentWritePerm' :: SharedRepository -> RawFilePath -> Maybe RepoVersion -> Bool -> IO (Maybe Bool)+checkContentWritePerm' sr file rv hasfreezehook+ | hasfreezehook = return (Just True)+ | otherwise = case sr of+ GroupShared+ | versionNeedsWritableContentFiles rv -> want sharedret+ (includemodes [ownerWriteMode, groupWriteMode])+ | otherwise -> want sharedret (excludemodes writeModes)+ AllShared+ | versionNeedsWritableContentFiles rv -> + want sharedret (includemodes writeModes)+ | otherwise -> want sharedret (excludemodes writeModes)+ _ -> want Just (excludemodes writeModes) where want mk f = catchMaybeIO (fileMode <$> R.getFileStatus file) >>= return . \case@@ -221,7 +235,9 @@ thawContent file = withShared $ \sr -> thawContent' sr file thawContent' :: SharedRepository -> RawFilePath -> Annex ()-thawContent' sr file = thawPerms (go sr) (thawHook file)+thawContent' sr file = do+ fastDebug "Annex.Perms" ("thawing content " ++ fromRawFilePath file)+ thawPerms (go sr) (thawHook file) where go GroupShared = liftIO $ void $ tryIO $ groupWriteRead file go AllShared = liftIO $ void $ tryIO $ groupWriteRead file@@ -244,6 +260,7 @@ -} freezeContentDir :: RawFilePath -> Annex () freezeContentDir file = unlessM crippledFileSystem $ do+ fastDebug "Annex.Perms" ("freezing content directory " ++ fromRawFilePath dir) withShared go freezeHook dir where@@ -253,7 +270,9 @@ go _ = liftIO $ preventWrite dir thawContentDir :: RawFilePath -> Annex ()-thawContentDir file = thawPerms (liftIO $ allowWrite dir) (thawHook dir)+thawContentDir file = do+ fastDebug "Annex.Perms" ("thawing content directory " ++ fromRawFilePath dir)+ thawPerms (liftIO $ allowWrite dir) (thawHook dir) where dir = parentDir file @@ -279,6 +298,12 @@ v <- tryNonAsync a freezeContentDir f either throwM return v++hasFreezeHook :: Annex Bool+hasFreezeHook = isJust . annexFreezeContentCommand <$> Annex.getGitConfig++hasThawHook :: Annex Bool+hasThawHook = isJust . annexThawContentCommand <$> Annex.getGitConfig freezeHook :: RawFilePath -> Annex () freezeHook p = maybe noop go =<< annexFreezeContentCommand <$> Annex.getGitConfig
Annex/Url.hs view
@@ -6,8 +6,6 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE CPP #-}- module Annex.Url ( withUrlOptions, withUrlOptionsPromptingCreds,@@ -36,11 +34,7 @@ import qualified Utility.Url as U import Utility.Hash (IncrementalVerifier) import Utility.IPAddress-#ifdef WITH_HTTP_CLIENT_RESTRICTED import Network.HTTP.Client.Restricted-#else-import Utility.HttpManagerRestricted-#endif import Utility.Metered import Git.Credential import qualified BuildInfo
Annex/View.hs view
@@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, PackageImports #-} module Annex.View where
Assistant/Monad.hs view
@@ -6,6 +6,7 @@ -} {-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+{-# LANGUAGE PackageImports #-} module Assistant.Monad ( Assistant,
Assistant/Threads/Watcher.hs view
@@ -265,7 +265,7 @@ case linktarget of Nothing -> a Just lt -> do- case parseLinkTarget lt of+ case parseLinkTargetOrPointer lt of Nothing -> noop Just key -> liftAnnex $ addassociatedfile key file
CHANGELOG view
@@ -1,3 +1,46 @@+git-annex (10.20220322) upstream; urgency=medium++ * Directory special remotes with importtree=yes have changed to once more + take inodes into account. This will cause extra work when importing+ from a directory on a FAT filesystem that changes inodes on every+ mount. To avoid that extra work, set ignoreinodes=yes when initializing+ a new directory special remote, or change the configuration of your+ existing remote:+ git-annex enableremote foo ignoreinodes=yes+ * add: Avoid unncessarily converting a newly unlocked file to be stored+ in git when it is not modified, even when annex.largefiles does not+ match it.+ * The above change to add fixes a reversion in version 10.20220222,+ where git-annex unlock followed by git-annex add, followed by git+ commit file could result in git thinking the file was modified+ after the commit.+ * Detect when an unlocked file whose content is not present has gotten+ some other content appended to it, and avoid treating it as a pointer+ file, so that appended content will not be checked into git, but will+ be annexed like any other file.+ * smudge: Warn when encountering a pointer file that has other content+ appended to it.+ * When annex.freezecontent-command is set, and the filesystem does not+ support removing write bits, avoid treating it as a crippled+ filesystem.+ * Run annex.thawcontent-command before deleting an object file,+ in case annex.freezecontent-command did something that would prevent+ deletion.+ * Fix propagation of nonzero exit status from git ls-files when a specified+ file does not exist, or a specified directory does not contain+ any files checked into git.+ * Fix build with aeson 2.0.+ Thanks, sternenseemann for the patch.+ * Avoid git-annex test being very slow when run from within the+ standalone linux tarball or OSX app.+ * test: Runs tests in parallel to speed up the test suite.+ * test: Added --jobs option.+ * Removed vendored copy of http-client-restricted, and removed the+ HttpClientRestricted build flag that avoided that dependency.+ * Removed the NetworkBSD build flag.++ -- Joey Hess <id@joeyh.name> Tue, 22 Mar 2022 13:56:12 -0400+ git-annex (10.20220222) upstream; urgency=medium * annex.skipunknown now defaults to false, so commands like
COPYRIGHT view
@@ -38,11 +38,6 @@ 2012, 2013 Joey Hess <id@joeyh.name> License: BSD-2-clause -Files: Utility/HttpManagerRestricted.hs-Copyright: 2018 Joey Hess <id@joeyh.name>- 2013 Michael Snoyman-License: Expat- Files: Utility/Attoparsec.hs Copyright: 2019 Joey Hess <id@joeyh.name> 2007-2015 Bryan O'Sullivan
CmdLine/Seek.hs view
@@ -77,13 +77,13 @@ (fs, cleanup) <- inRepo $ LsFiles.inRepoDetails os [toRawFilePath p] r <- case fs of [f] -> do- void $ liftIO $ cleanup+ propagateLsFilesError cleanup fst <$> getfiles ((SeekInput [p], f):c) ps [] -> do- void $ liftIO $ cleanup+ propagateLsFilesError cleanup fst <$> getfiles c ps _ -> do- void $ liftIO $ cleanup+ propagateLsFilesError cleanup giveup needforce return (r, pure True) withFilesInGitAnnexNonRecursive _ _ _ NoWorkTreeItems = noop@@ -321,7 +321,7 @@ checktimelimit <- mkCheckTimeLimit (fs, cleanup) <- listfs go matcher checktimelimit fs- liftIO $ void cleanup+ propagateLsFilesError cleanup where go _ _ [] = return () go matcher checktimelimit (v@(_si, f):rest) = checktimelimit noop $ do@@ -373,7 +373,7 @@ ) join (liftIO (wait mdprocessertid)) join (liftIO (wait processertid))- liftIO $ void cleanup+ propagateLsFilesError cleanup where finisher mi oreader checktimelimit = liftIO oreader >>= \case Just ((si, f), content) -> checktimelimit (liftIO discard) $ do@@ -464,7 +464,7 @@ mdprocess mi mdreader ofeeder ocloser = liftIO mdreader >>= \case Just ((si, f), Just (sha, size, _type))- | size < maxPointerSz -> do+ | size < fromIntegral maxPointerSz -> do feedmatches mi ofeeder si f sha mdprocess mi mdreader ofeeder ocloser Just _ -> mdprocess mi mdreader ofeeder ocloser@@ -618,3 +618,8 @@ cleanup liftIO $ exitWith $ ExitFailure 101 else a++propagateLsFilesError :: IO Bool -> Annex ()+propagateLsFilesError cleanup =+ unlessM (liftIO cleanup) $+ Annex.incError
Command/Add.hs view
@@ -78,16 +78,18 @@ largematcher <- largeFilesMatcher addunlockedmatcher <- addUnlockedMatcher annexdotfiles <- getGitConfigVal annexDotFiles - let gofile (si, file) = case largeFilesOverride o of+ let gofile includingsmall (si, file) = case largeFilesOverride o of Nothing -> ifM (pure (annexdotfiles || not (dotfile file)) <&&> (checkFileMatcher largematcher file <||> Annex.getState Annex.force)) ( start o si file addunlockedmatcher- , ifM (annexAddSmallFiles <$> Annex.getGitConfig)- ( startSmall o si file- , stop- )+ , if includingsmall+ then ifM (annexAddSmallFiles <$> Annex.getGitConfig)+ ( startSmall o si file+ , stop+ )+ else stop ) Just True -> start o si file addunlockedmatcher Just False -> startSmallOverridden o si file@@ -96,7 +98,7 @@ | updateOnly o -> giveup "--update --batch is not supported" | otherwise -> batchOnly Nothing (addThese o) $- batchFiles fmt gofile+ batchFiles fmt (gofile True) NoBatch -> do -- Avoid git ls-files complaining about files that -- are not known to git yet, since this will add@@ -104,11 +106,14 @@ -- problems, like files that don't exist. let ww = WarnUnmatchWorkTreeItems l <- workTreeItems ww (addThese o)- let go a = a ww (commandAction . gofile) l+ let go b a = a ww (commandAction . gofile b) l unless (updateOnly o) $- go (withFilesNotInGit (checkGitIgnoreOption o))- go withFilesMaybeModified- go withUnmodifiedUnlockedPointers+ go True (withFilesNotInGit (checkGitIgnoreOption o))+ go True withFilesMaybeModified+ -- Convert newly unlocked files back to locked files,+ -- same as a modified unlocked file would get+ -- locked when added.+ go False withUnmodifiedUnlockedPointers {- Pass file off to git-add. -} startSmall :: AddOptions -> SeekInput -> RawFilePath -> CommandStart
Command/FilterProcess.hs view
@@ -62,7 +62,7 @@ let conv b l = (B.concat (map pktLineToByteString l), b) (b, readcomplete) <- either (conv False) (conv True)- <$> liftIO (readUntilFlushPktOrSize unpaddedMaxPointerSz)+ <$> liftIO (readUntilFlushPktOrSize maxPointerSz) let passthrough | readcomplete = liftIO $ respondFilterRequest b@@ -83,7 +83,7 @@ -- hash the content provided by git, but Backend does not currently -- have an interface to do so. Command.Smudge.clean' (toRawFilePath file)- (parseLinkTargetOrPointer b)+ (parseLinkTargetOrPointer' b) passthrough discardreststdin emitpointer
Command/Info.hs view
@@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE BangPatterns, DeriveDataTypeable #-}+{-# LANGUAGE BangPatterns, DeriveDataTypeable, PackageImports, OverloadedStrings #-} module Command.Info where @@ -446,7 +446,7 @@ , maybe (fromUUID $ transferUUID t) Remote.name $ M.lookup (transferUUID t) uuidmap ]- jsonify t i = object $ map (\(k, v) -> (packString k, v)) $+ jsonify t i = object $ map (\(k, v) -> (textKey (packString k), v)) $ [ ("transfer", toJSON' (formatDirection (transferDirection t))) , ("key", toJSON' (transferKey t)) , ("file", toJSON' (fromRawFilePath <$> afile))
Command/Smudge.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2015-2021 Joey Hess <id@joeyh.name>+ - Copyright 2015-2022 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -105,7 +105,7 @@ then L.length b `seq` return () else liftIO $ hClose stdin let emitpointer = liftIO . S.hPut stdout . formatPointer- clean' file (parseLinkTargetOrPointerLazy b)+ clean' file (parseLinkTargetOrPointerLazy' b) passthrough discardreststdin emitpointer@@ -115,7 +115,7 @@ -- Handles everything except the IO of the file content. clean' :: RawFilePath- -> Maybe Key+ -> Either InvalidAppendedPointerFile (Maybe Key) -- ^ If the content provided by git is an annex pointer, -- this is the key it points to. -> Annex ()@@ -135,19 +135,26 @@ where go = case mk of- Just k -> do+ Right (Just k) -> do addingExistingLink file k $ do getMoveRaceRecovery k file passthrough- Nothing -> inRepo (Git.Ref.fileRef file) >>= \case- Just fileref -> do- indexmeta <- catObjectMetaData fileref- oldkey <- case indexmeta of- Just (_, sz, _) -> catKey' fileref sz- Nothing -> return Nothing- go' indexmeta oldkey- Nothing -> passthrough- go' indexmeta oldkey = ifM (shouldAnnex file indexmeta oldkey)+ Right Nothing -> notpointer+ Left InvalidAppendedPointerFile -> do+ toplevelWarning False $+ "The file \"" ++ fromRawFilePath file ++ "\" looks like git-annex pointer file that has had other content appended to it"+ notpointer++ notpointer = inRepo (Git.Ref.fileRef file) >>= \case+ Just fileref -> do+ indexmeta <- catObjectMetaData fileref+ oldkey <- case indexmeta of+ Just (_, sz, _) -> catKey' fileref sz+ Nothing -> return Nothing+ notpointer' indexmeta oldkey+ Nothing -> passthrough+ + notpointer' indexmeta oldkey = ifM (shouldAnnex file indexmeta oldkey) ( do discardreststdin
Command/TestRemote.hs view
@@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE RankNTypes, DeriveFunctor #-}+{-# LANGUAGE RankNTypes, DeriveFunctor, PackageImports #-} module Command.TestRemote where
Database/Keys.hs view
@@ -447,7 +447,7 @@ where procthread mdreader catfeeder = mdreader >>= \case Just (ka, Just (sha, size, _type))- | size < maxPointerSz -> do+ | size <= fromIntegral maxPointerSz -> do () <- catfeeder (ka, sha) procthread mdreader catfeeder Just _ -> procthread mdreader catfeeder
Messages/JSON.hs view
@@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE OverloadedStrings, GADTs #-}+{-# LANGUAGE OverloadedStrings, GADTs, CPP #-} module Messages.JSON ( JSONBuilder,@@ -33,7 +33,11 @@ import qualified Data.Map as M import qualified Data.Vector as V import qualified Data.ByteString.Lazy as L+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.KeyMap as HM+#else import qualified Data.HashMap.Strict as HM+#endif import System.IO import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent@@ -94,7 +98,7 @@ addErrorMessage :: [String] -> Object -> Object addErrorMessage msg o =- HM.insertWith combinearray "error-messages" v o+ HM.unionWith combinearray (HM.singleton "error-messages" v) o where combinearray (Array new) (Array old) = Array (old <> new) combinearray new _old = new@@ -102,7 +106,7 @@ note :: String -> JSONBuilder note _ Nothing = Nothing-note s (Just (o, e)) = Just (HM.insertWith combinelines "note" (toJSON' s) o, e)+note s (Just (o, e)) = Just (HM.unionWith combinelines (HM.singleton "note" (toJSON' s)) o, e) where combinelines (String new) (String old) = String (old <> "\n" <> new)@@ -127,7 +131,7 @@ j = case v of AesonObject ao -> Object ao JSONChunk l -> object $ map mkPair l- mkPair (s, d) = (packString s, toJSON' d)+ mkPair (s, d) = (textKey (packString s), toJSON' d) add _ Nothing = Nothing complete :: JSONChunk v -> JSONBuilder@@ -173,7 +177,7 @@ instance ToJSON' a => ToJSON' (ObjectMap a) where toJSON' (ObjectMap m) = object $ map go $ M.toList m where- go (k, v) = (packString k, toJSON' v)+ go (k, v) = (textKey (packString k), toJSON' v) -- An item that a git-annex command acts on, and displays a JSON object about. data JSONActionItem a = JSONActionItem
Remote.hs view
@@ -239,11 +239,12 @@ Nothing -> s Just val -> val ++ ": " ++ s jsonify hereu (u, optval) = object $ catMaybes- [ Just (packString "uuid", toJSON' (fromUUID u :: String))- , Just (packString "description", toJSON' $ finddescription u)- , Just (packString "here", toJSON' $ hereu == u)+ [ Just ("uuid", toJSON' (fromUUID u :: String))+ , Just ("description", toJSON' $ finddescription u)+ , Just ("here", toJSON' $ hereu == u) , case (optfield, optval) of- (Just field, Just val) -> Just (packString field, toJSON' val)+ (Just field, Just val) -> Just+ (textKey (packString field), toJSON' val) _ -> Nothing ]
Remote/Directory.hs view
@@ -1,6 +1,6 @@ {- A "remote" that is just a filesystem directory. -- - Copyright 2011-2021 Joey Hess <id@joeyh.name>+ - Copyright 2011-2022 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -54,6 +54,8 @@ , configParser = mkRemoteConfigParser [ optionalStringParser directoryField (FieldDesc "(required) where the special remote stores data")+ , yesNoParser ignoreinodesField (Just False)+ (FieldDesc "ignore inodes when importing/exporting") ] , setup = directorySetup , exportSupported = exportIsSupported@@ -64,12 +66,17 @@ directoryField :: RemoteConfigField directoryField = Accepted "directory" +ignoreinodesField :: RemoteConfigField+ignoreinodesField = Accepted "ignoreinodes"+ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u rc gc rs = do c <- parsedRemoteConfig remote rc cst <- remoteCost gc cheapRemoteCost let chunkconfig = getChunkConfig c cow <- liftIO newCopyCoWTried+ let ii = IgnoreInodes $ fromMaybe True $+ getRemoteConfigValue ignoreinodesField c return $ Just $ specialRemote c (storeKeyM dir chunkconfig cow) (retrieveKeyFileM dir chunkconfig cow)@@ -99,15 +106,15 @@ , renameExport = renameExportM dir } , importActions = ImportActions- { listImportableContents = listImportableContentsM dir- , importKey = Just (importKeyM dir)- , retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierM dir cow- , storeExportWithContentIdentifier = storeExportWithContentIdentifierM dir cow- , removeExportWithContentIdentifier = removeExportWithContentIdentifierM dir+ { listImportableContents = listImportableContentsM ii dir+ , importKey = Just (importKeyM ii dir)+ , retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierM ii dir cow+ , storeExportWithContentIdentifier = storeExportWithContentIdentifierM ii dir cow+ , removeExportWithContentIdentifier = removeExportWithContentIdentifierM ii dir -- Not needed because removeExportWithContentIdentifier -- auto-removes empty directories. , removeExportDirectoryWhenEmpty = Nothing- , checkPresentExportWithContentIdentifier = checkPresentExportWithContentIdentifierM dir+ , checkPresentExportWithContentIdentifier = checkPresentExportWithContentIdentifierM ii dir } , whereisKey = Nothing , remoteFsck = Nothing@@ -351,8 +358,8 @@ mkExportLocation loc' in go (upFrom loc') =<< tryIO (removeDirectory p) -listImportableContentsM :: RawFilePath -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize)))-listImportableContentsM dir = liftIO $ do+listImportableContentsM :: IgnoreInodes -> RawFilePath -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize)))+listImportableContentsM ii dir = liftIO $ do l <- dirContentsRecursive (fromRawFilePath dir) l' <- mapM (go . toRawFilePath) l return $ Just $ ImportableContentsComplete $@@ -360,41 +367,38 @@ where go f = do st <- R.getFileStatus f- mkContentIdentifier f st >>= \case+ mkContentIdentifier ii f st >>= \case Nothing -> return Nothing Just cid -> do relf <- relPathDirToFile dir f sz <- getFileSize' f st return $ Just (mkImportLocation relf, (cid, sz)) --- Make a ContentIdentifier that contains the size and mtime of the file.--- If the file is not a regular file, this will return Nothing.------ The inode is zeroed because often this is used for import from a--- FAT filesystem, whose inodes change each time it's mounted, and--- including inodes would cause repeated re-hashing of files, and--- bloat the git-annex branch with changes to content identifier logs.+newtype IgnoreInodes = IgnoreInodes Bool++-- Make a ContentIdentifier that contains the size and mtime of the file,+-- and also normally the inode, unless ignoreinodes=yes. ----- This does mean that swaps of two files with the same size and--- mtime won't be noticed, nor will modifications to files that--- preserve the size and mtime. Both very unlikely so acceptable.-mkContentIdentifier :: RawFilePath -> FileStatus -> IO (Maybe ContentIdentifier)-mkContentIdentifier f st =- fmap (ContentIdentifier . encodeBS . showInodeCache)- <$> toInodeCache' noTSDelta f st 0+-- If the file is not a regular file, this will return Nothing.+mkContentIdentifier :: IgnoreInodes -> RawFilePath -> FileStatus -> IO (Maybe ContentIdentifier)+mkContentIdentifier (IgnoreInodes ii) f st =+ liftIO $ fmap (ContentIdentifier . encodeBS . showInodeCache)+ <$> if ii+ then toInodeCache' noTSDelta f st 0+ else toInodeCache noTSDelta f st guardSameContentIdentifiers :: a -> ContentIdentifier -> Maybe ContentIdentifier -> a guardSameContentIdentifiers cont old new | new == Just old = cont | otherwise = giveup "file content has changed" -importKeyM :: RawFilePath -> ExportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> Annex (Maybe Key)-importKeyM dir loc cid sz p = do+importKeyM :: IgnoreInodes -> RawFilePath -> ExportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> Annex (Maybe Key)+importKeyM ii dir loc cid sz p = do backend <- chooseBackend f unsizedk <- fst <$> genKey ks p backend let k = alterKey unsizedk $ \kd -> kd { keySize = keySize kd <|> Just sz }- currcid <- liftIO $ mkContentIdentifier absf+ currcid <- liftIO $ mkContentIdentifier ii absf =<< R.getFileStatus absf guardSameContentIdentifiers (return (Just k)) cid currcid where@@ -406,8 +410,8 @@ , inodeCache = Nothing } -retrieveExportWithContentIdentifierM :: RawFilePath -> CopyCoWTried -> ExportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key-retrieveExportWithContentIdentifierM dir cow loc cid dest mkkey p = +retrieveExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> CopyCoWTried -> ExportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key+retrieveExportWithContentIdentifierM ii dir cow loc cid dest mkkey p = precheck docopy where f = exportPath dir loc@@ -449,7 +453,7 @@ -- Check before copy, to avoid expensive copy of wrong file -- content. precheck cont = guardSameContentIdentifiers cont cid- =<< liftIO . mkContentIdentifier f+ =<< liftIO . mkContentIdentifier ii f =<< liftIO (R.getFileStatus f) -- Check after copy, in case the file was changed while it was@@ -470,7 +474,7 @@ #else postchecknoncow cont = do #endif- currcid <- liftIO $ mkContentIdentifier f+ currcid <- liftIO $ mkContentIdentifier ii f #ifndef mingw32_HOST_OS =<< getFdStatus fd #else@@ -484,22 +488,22 @@ -- the modified version was copied CoW, and then the file was -- restored to the original content before this check. postcheckcow cont = do- currcid <- liftIO $ mkContentIdentifier f+ currcid <- liftIO $ mkContentIdentifier ii f =<< R.getFileStatus f guardSameContentIdentifiers cont cid currcid -storeExportWithContentIdentifierM :: RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier-storeExportWithContentIdentifierM dir cow src _k loc overwritablecids p = do+storeExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier+storeExportWithContentIdentifierM ii dir cow src _k loc overwritablecids p = do liftIO $ createDirectoryUnder dir (toRawFilePath destdir) withTmpFileIn destdir template $ \tmpf tmph -> do liftIO $ hClose tmph void $ fileCopier cow src tmpf p Nothing let tmpf' = toRawFilePath tmpf resetAnnexFilePerm tmpf'- liftIO (getFileStatus tmpf) >>= liftIO . mkContentIdentifier tmpf' >>= \case+ liftIO (getFileStatus tmpf) >>= liftIO . mkContentIdentifier ii tmpf' >>= \case Nothing -> giveup "unable to generate content identifier" Just newcid -> do- checkExportContent dir loc+ checkExportContent ii dir loc overwritablecids (giveup "unsafe to overwrite file") (const $ liftIO $ rename tmpf dest)@@ -509,16 +513,16 @@ (destdir, base) = splitFileName dest template = relatedTemplate (base ++ ".tmp") -removeExportWithContentIdentifierM :: RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex ()-removeExportWithContentIdentifierM dir k loc removeablecids =- checkExportContent dir loc removeablecids (giveup "unsafe to remove modified file") $ \case+removeExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex ()+removeExportWithContentIdentifierM ii dir k loc removeablecids =+ checkExportContent ii dir loc removeablecids (giveup "unsafe to remove modified file") $ \case DoesNotExist -> return () KnownContentIdentifier -> removeExportM dir k loc -checkPresentExportWithContentIdentifierM :: RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool-checkPresentExportWithContentIdentifierM dir _k loc knowncids =+checkPresentExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool+checkPresentExportWithContentIdentifierM ii dir _k loc knowncids = checkPresentGeneric' dir $- checkExportContent dir loc knowncids (return False) $ \case+ checkExportContent ii dir loc knowncids (return False) $ \case DoesNotExist -> return False KnownContentIdentifier -> return True @@ -539,12 +543,12 @@ -- -- So, it suffices to check if the destination file's current -- content is known, and immediately run the callback.-checkExportContent :: RawFilePath -> ExportLocation -> [ContentIdentifier] -> Annex a -> (CheckResult -> Annex a) -> Annex a-checkExportContent dir loc knowncids unsafe callback = +checkExportContent :: IgnoreInodes -> RawFilePath -> ExportLocation -> [ContentIdentifier] -> Annex a -> (CheckResult -> Annex a) -> Annex a+checkExportContent ii dir loc knowncids unsafe callback = tryWhenExists (liftIO $ R.getFileStatus dest) >>= \case Just destst | not (isRegularFile destst) -> unsafe- | otherwise -> catchDefaultIO Nothing (liftIO $ mkContentIdentifier dest destst) >>= \case+ | otherwise -> catchDefaultIO Nothing (liftIO $ mkContentIdentifier ii dest destst) >>= \case Just destcid | destcid `elem` knowncids -> callback KnownContentIdentifier -- dest exists with other content
Remote/Helper/Encryptable.hs view
@@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, PackageImports #-} module Remote.Helper.Encryptable ( EncryptionIsSetup,
Test.hs view
@@ -11,20 +11,17 @@ import Types.Test import Types.RepoVersion+import Types.Concurrency import Test.Framework import Options.Applicative.Types import Test.Tasty-import Test.Tasty.Runners import Test.Tasty.HUnit import Test.Tasty.QuickCheck-import Test.Tasty.Ingredients.Rerun-import Test.Tasty.Options-import Options.Applicative (switch, long, help, internal)+import Options.Applicative (switch, long, short, help, internal, maybeReader, option) import qualified Data.Map as M import qualified Data.ByteString.Lazy.UTF8 as BU8-import System.Environment import Control.Concurrent.STM hiding (check) import Common@@ -60,12 +57,9 @@ import qualified Crypto import qualified Database.Keys import qualified Annex.WorkTree-import qualified Annex.Init import qualified Annex.CatFile-import qualified Annex.Path import qualified Annex.VectorClock import qualified Annex.VariantFile-import qualified Annex.AdjustedBranch import qualified Annex.View import qualified Annex.View.ViewedFile import qualified Logs.View@@ -78,8 +72,6 @@ import qualified Utility.Process import qualified Utility.Misc import qualified Utility.InodeCache-import qualified Utility.Env-import qualified Utility.Env.Set import qualified Utility.Matcher import qualified Utility.Hash import qualified Utility.Scheduled@@ -99,7 +91,7 @@ optParser :: Parser TestOptions optParser = TestOptions- <$> snd tastyParser+ <$> snd (tastyParser (tests 1 False True (TestOptions mempty False False Nothing mempty))) <*> switch ( long "keep-failures" <> help "preserve repositories on test failure"@@ -108,66 +100,21 @@ ( long "fakessh" <> internal )+ <*> optional (option (maybeReader parseConcurrency)+ ( long "jobs"+ <> short 'J'+ <> help "number of concurrent jobs"+ )) <*> cmdParams "non-options are for internal use only" -tastyParser :: ([String], Parser Test.Tasty.Options.OptionSet)-#if MIN_VERSION_tasty(1,3,0)-tastyParser = go-#else-tastyParser = ([], go)-#endif- where- go = suiteOptionParser ingredients (tests False True mempty)- runner :: TestOptions -> IO ()-runner opts- | fakeSsh opts = runFakeSsh (internalData opts)- | otherwise = runsubprocesstests =<< Utility.Env.getEnv subenv- where- -- Run git-annex test in a subprocess, so that any files- -- it may open will be closed before running finalCleanup.- -- This should prevent most failures to clean up after the test- -- suite.- subenv = "GIT_ANNEX_TEST_SUBPROCESS"- runsubprocesstests Nothing = do- let warnings = fst tastyParser- unless (null warnings) $ do- hPutStrLn stderr "warnings from tasty:"- mapM_ (hPutStrLn stderr) warnings- pp <- Annex.Path.programPath- Utility.Env.Set.setEnv subenv "1" True- ps <- getArgs- exitcode <- withCreateProcess (proc pp ps) $- \_ _ _ pid -> waitForProcess pid- unless (keepFailuresOption opts) finalCleanup- exitWith exitcode- runsubprocesstests (Just _) = isolateGitConfig $ do- ensuretmpdir- crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem'- (toRawFilePath tmpdir)- Nothing Nothing- adjustedbranchok <- Annex.AdjustedBranch.isGitVersionSupported- case tryIngredients ingredients (tastyOptionSet opts) (tests crippledfilesystem adjustedbranchok opts) of- Nothing -> error "No tests found!?"- Just act -> ifM act- ( exitSuccess- , do- putStrLn " (Failures above could be due to a bug in git-annex, or an incompatibility"- putStrLn " with utilities, such as git, installed on this system.)"- exitFailure- )--ingredients :: [Ingredient]-ingredients =- [ listingTests- , rerunningTests [consoleTestReporter]- ]+runner opts = parallelTestRunner opts tests -tests :: Bool -> Bool -> TestOptions -> TestTree-tests crippledfilesystem adjustedbranchok opts = - testGroup "Tests" $ properties - : withTestMode remotetestmode Nothing testRemotes- : map (\(d, te) -> withTestMode te (Just initTests) (unitTests d)) testmodes+tests :: Int -> Bool -> Bool -> TestOptions -> [TestTree]+tests n crippledfilesystem adjustedbranchok opts = + properties + : withTestMode remotetestmode testRemotes+ : concatMap mkrepotests testmodes where testmodes = catMaybes [ canadjust ("v8 adjusted unlocked branch", (testMode opts (RepoVersion 8)) { adjustedUnlockedBranch = True })@@ -181,6 +128,9 @@ canadjust v | adjustedbranchok = Just v | otherwise = Nothing+ mkrepotests (d, te) = map + (\uts -> withTestMode te uts)+ (repoTests d n) properties :: TestTree properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck" $@@ -253,7 +203,7 @@ , "directory=remotedir" , "encryption=none" ] "init"- + testRemote :: Bool -> String -> (String -> IO ()) -> TestTree testRemote testvariants remotetype setupremote = withResource newEmptyTMVarIO (const noop) $ \getv -> @@ -300,15 +250,15 @@ desckeysize sz = descas ("key size " ++ show sz) {- These tests set up the test environment, but also test some basic parts- - of git-annex. They are always run before the unitTests. -}+ - of git-annex. They are always run before the repoTests. -} initTests :: TestTree initTests = testGroup "Init Tests" [ testCase "init" test_init , testCase "add" test_add ] -unitTests :: String -> TestTree-unitTests note = testGroup ("Unit Tests " ++ note)+repoTests :: String -> Int -> [TestTree]+repoTests note numparts = map mk $ sep [ testCase "add dup" test_add_dup , testCase "add extras" test_add_extras , testCase "readonly remote" test_readonly_remote@@ -387,6 +337,14 @@ , testCase "add subdirs" test_add_subdirs , testCase "addurl" test_addurl ]+ where+ mk l = testGroup groupname (initTests : map adddep l)+ adddep = Test.Tasty.after AllSucceed (groupname ++ ".Init Tests")+ groupname = "Repo Tests " ++ note+ sep = sep' (replicate numparts [])+ sep' (p:ps) (l:ls) = sep' (ps++[l:p]) ls+ sep' ps [] = ps+ sep' [] _ = [] -- this test case creates the main repo test_init :: Assertion@@ -597,8 +555,6 @@ annexed_present annexedfile git_annex "unannex" [annexedfile, sha1annexedfile] "unannex" unannexed annexedfile- git_annex "unannex" [annexedfile] "unannex on non-annexed file"- unannexed annexedfile git_annex "unannex" [ingitfile] "unannex ingitfile should be no-op" unannexed ingitfile @@ -1230,11 +1186,11 @@ withtmpclonerepo $ \r3 -> do forM_ [r1, r2, r3] $ \r -> indir r $ do when (r /= r1) $- git "remote" ["add", "r1", "../../" ++ r1] "remote add"+ git "remote" ["add", "r1", "../" ++ r1] "remote add" when (r /= r2) $- git "remote" ["add", "r2", "../../" ++ r2] "remote add"+ git "remote" ["add", "r2", "../" ++ r2] "remote add" when (r /= r3) $- git "remote" ["add", "r3", "../../" ++ r3] "remote add"+ git "remote" ["add", "r3", "../" ++ r3] "remote add" git_annex "get" [annexedfile] "get" git "remote" ["rm", "origin"] "remote rm" forM_ [r3, r2, r1] $ \r -> indir r $
Test/Framework.hs view
@@ -1,6 +1,6 @@ {- git-annex test suite framework -- - Copyright 2010-2021 Joey Hess <id@joeyh.name>+ - Copyright 2010-2022 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -12,10 +12,22 @@ import Test.Tasty import Test.Tasty.Runners import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import Test.Tasty.Options+import Test.Tasty.Ingredients.Rerun+import Test.Tasty.Ingredients.ConsoleReporter+import Options.Applicative.Types import Control.Concurrent+import Control.Concurrent.Async+import Control.Concurrent.STM+import System.Environment (getArgs)+import System.Console.Concurrent+import System.Console.ANSI+import GHC.Conc import Common import Types.Test+import Types.Concurrency import qualified Annex import qualified Annex.UUID@@ -39,6 +51,7 @@ import qualified Annex.Path import qualified Annex.Action import qualified Annex.AdjustedBranch+import qualified Annex.Init import qualified Utility.Process import qualified Utility.Process.Transcript import qualified Utility.Env@@ -166,7 +179,7 @@ -- any type of error and change back to currdir before -- rethrowing. r <- bracket_- (changeToTmpDir dir)+ (changeToTopDir dir) (setCurrentDirectory currdir) (tryNonAsync a) case r of@@ -179,7 +192,6 @@ setuprepo :: FilePath -> IO FilePath setuprepo dir = do cleanup dir- ensuretmpdir git "init" ["-q", dir] "git init" configrepo dir return dir@@ -199,7 +211,6 @@ clonerepo :: FilePath -> FilePath -> CloneRepoConfig -> IO FilePath clonerepo old new cfg = do cleanup new- ensuretmpdir let cloneparams = catMaybes [ Just "-q" , if bareClone cfg then Just "--bare" else Nothing@@ -236,11 +247,11 @@ git "config" ["annex.largefiles", "exclude=" ++ ingitfile] "git config annex.largefiles" -ensuretmpdir :: IO ()-ensuretmpdir = do- e <- doesDirectoryExist tmpdir+ensuredir :: FilePath -> IO ()+ensuredir d = do+ e <- doesDirectoryExist d unless e $- createDirectory tmpdir+ createDirectory d {- Prevent global git configs from affecting the test suite. -} isolateGitConfig :: IO a -> IO a@@ -449,29 +460,24 @@ hasUnlockedFiles :: TestMode -> Bool hasUnlockedFiles m = unlockedFiles m || adjustedUnlockedBranch m -withTestMode :: TestMode -> Maybe TestTree -> TestTree -> TestTree-withTestMode testmode minittests = withResource prepare release . const+withTestMode :: TestMode -> TestTree -> TestTree+withTestMode testmode = withResource prepare release . const where prepare = do setTestMode testmode setmainrepodir =<< newmainrepodir- case minittests of- Just inittests ->- case tryIngredients [consoleTestReporter] mempty inittests of- Nothing -> error "No tests found!?"- Just act -> unlessM act $- error "init tests failed! cannot continue"- Nothing -> return () release _ = noop setTestMode :: TestMode -> IO () setTestMode testmode = do currdir <- getCurrentDirectory p <- Utility.Env.getEnvDefault "PATH" ""+ pp <- Annex.Path.programPath mapM_ (\(var, val) -> Utility.Env.Set.setEnv var val True)- -- Ensure that the just-built git annex is used.- [ ("PATH", currdir ++ [searchPathSeparator] ++ p)+ -- Ensure that the same git-annex binary that is running+ -- git-annex test is at the front of the PATH.+ [ ("PATH", takeDirectory pp ++ [searchPathSeparator] ++ p) , ("TOPDIR", currdir) -- Avoid git complaining if it cannot determine the user's -- email address, or exploding if it doesn't know the user's@@ -488,7 +494,7 @@ , ("GIT_ANNEX_USE_GIT_SSH", "1") , ("TESTMODE", show testmode) ]-+ runFakeSsh :: [String] -> IO () runFakeSsh ("-n":ps) = runFakeSsh ps runFakeSsh (_host:cmd:[]) =@@ -506,8 +512,8 @@ git "commit" ["--allow-empty", "-m", "empty"] "git commit failed" git_annex "adjust" ["--unlock"] "git annex adjust failed" -changeToTmpDir :: FilePath -> IO ()-changeToTmpDir t = do+changeToTopDir :: FilePath -> IO ()+changeToTopDir t = do topdir <- Utility.Env.getEnvDefault "TOPDIR" (error "TOPDIR not set") setCurrentDirectory $ topdir ++ "/" ++ t @@ -525,7 +531,7 @@ newmainrepodir = go (0 :: Int) where go n = do- let d = tmpdir </> "main" ++ show n+ let d = "main" ++ show n ifM (doesDirectoryExist d) ( go $ n + 1 , do@@ -537,7 +543,7 @@ tmprepodir = go (0 :: Int) where go n = do- let d = tmpdir </> "tmprepo" ++ show n+ let d = "tmprepo" ++ show n ifM (doesDirectoryExist d) ( go $ n + 1 , return d@@ -636,9 +642,9 @@ pair :: FilePath -> FilePath -> Assertion pair r1 r2 = forM_ [r1, r2] $ \r -> indir r $ do when (r /= r1) $- git "remote" ["add", "r1", "../../" ++ r1] "remote add"+ git "remote" ["add", "r1", "../" ++ r1] "remote add" when (r /= r2) $- git "remote" ["add", "r2", "../../" ++ r2] "remote add"+ git "remote" ["add", "r2", "../" ++ r2] "remote add" {- Runs a query in the current repository, but first makes the repository@@ -661,3 +667,128 @@ make_writeable d = void $ Utility.Process.Transcript.processTranscript "chmod" ["-R", "u+w", d] Nothing++{- Tests each TestTree in parallel, and exits with succcess/failure.+ -+ - Tasty supports parallel tests, but this does not use it, because+ - many tests need to be run in test repos, and chdir would not be + - thread safe. Instead, this starts one child process for each TestTree.+ -+ - An added benefit of using child processes is that any files they may+ - leave open are closed before finalCleanup is run at the end. This+ - prevents some failures to clean up after the test suite.+ -}+parallelTestRunner :: TestOptions -> (Int -> Bool -> Bool -> TestOptions -> [TestTree]) -> IO ()+parallelTestRunner opts mkts = do+ numjobs <- case concurrentJobs opts of+ Just NonConcurrent -> pure 1+ Just (Concurrent n) -> pure n+ Just ConcurrentPerCpu -> getNumProcessors+ Nothing -> getNumProcessors+ parallelTestRunner' numjobs opts mkts++parallelTestRunner' :: Int -> TestOptions -> (Int -> Bool -> Bool -> TestOptions -> [TestTree]) -> IO ()+parallelTestRunner' numjobs opts mkts+ | fakeSsh opts = runFakeSsh (internalData opts)+ | otherwise = go =<< Utility.Env.getEnv subenv+ where+ subenv = "GIT_ANNEX_TEST_SUBPROCESS"+ -- Make more parts than there are jobs, because some parts+ -- are larger, and this allows the smaller parts to be packed+ -- in more efficiently, speeding up the test suite overall.+ numparts = numjobs * 2+ worker rs nvar a = do+ (n, m) <- atomically $ do+ (n, m) <- readTVar nvar+ writeTVar nvar (n+1, m)+ return (n, m)+ if n > m+ then return rs+ else do+ r <- a n+ worker (r:rs) nvar a+ go Nothing = withConcurrentOutput $ do+ ensuredir tmpdir+ crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem'+ (toRawFilePath tmpdir)+ Nothing Nothing False+ adjustedbranchok <- Annex.AdjustedBranch.isGitVersionSupported+ let ts = mkts numparts crippledfilesystem adjustedbranchok opts+ let warnings = fst (tastyParser ts)+ unless (null warnings) $ do+ hPutStrLn stderr "warnings from tasty:"+ mapM_ (hPutStrLn stderr) warnings+ environ <- Utility.Env.getEnvironment+ args <- getArgs+ pp <- Annex.Path.programPath+ termcolor <- hSupportsANSIColor stdout+ let ps = if useColor (lookupOption (tastyOptionSet opts)) termcolor+ then "--color=always":args+ else "--color=never":args+ let runone n = do+ let subdir = tmpdir </> show n+ ensuredir subdir+ let p = (proc pp ps)+ { env = Just ((subenv, show (n, crippledfilesystem, adjustedbranchok)):environ)+ , cwd = Just subdir+ }+ (_, _, _, pid) <- createProcessConcurrent p+ ret <- waitForProcess pid+ -- Work around this strange issue+ -- https://github.com/UnkindPartition/tasty/issues/326+ -- when other workaround does not work.+ if ret == ExitFailure (-11)+ then runone n+ else return ret+ nvar <- newTVarIO (1, length ts)+ exitcodes <- forConcurrently [1..numjobs] $ \_ -> + worker [] nvar runone+ let exitcodes' = concat exitcodes+ unless (keepFailuresOption opts) finalCleanup+ if all (== ExitSuccess) exitcodes'+ then exitSuccess+ else case (filter (/= ExitFailure 1) exitcodes') of+ [] -> do+ putStrLn " (Failures above could be due to a bug in git-annex, or an incompatibility"+ putStrLn " with utilities, such as git, installed on this system.)"+ exitFailure+ v -> do+ putStrLn $ " Test subprocesses exited with unexpected exit codes: " ++ show v+ exitFailure+ go (Just subenvval) = case readish subenvval of+ Nothing -> error ("Bad " ++ subenv)+ Just (n, crippledfilesystem, adjustedbranchok) -> isolateGitConfig $ do+ let ts = mkts numparts crippledfilesystem adjustedbranchok opts+ let t = topLevelTestGroup + -- Work around this strange issue+ -- https://github.com/UnkindPartition/tasty/issues/326+ [ testGroup "Tasty" + [ testProperty "tasty self-check" True+ ]+ , ts !! (n - 1)+ ]+ case tryIngredients ingredients (tastyOptionSet opts) t of+ Nothing -> error "No tests found!?"+ Just act -> ifM act+ ( exitSuccess+ , exitFailure+ )++topLevelTestGroup :: [TestTree] -> TestTree+topLevelTestGroup = testGroup "Tests"++tastyParser :: [TestTree] -> ([String], Parser Test.Tasty.Options.OptionSet)+#if MIN_VERSION_tasty(1,3,0)+tastyParser ts = go+#else+tastyParser ts = ([], go)+#endif+ where+ go = suiteOptionParser ingredients (topLevelTestGroup ts)++ingredients :: [Ingredient]+ingredients =+ [ listingTests+ , rerunningTests [consoleTestReporter]+ ]+
Types/MetaData.hs view
@@ -67,7 +67,7 @@ instance ToJSON' MetaData where toJSON' (MetaData m) = object $ map go (M.toList m) where- go (MetaField f, s) = (CI.original f, toJSON' s)+ go (MetaField f, s) = (textKey (CI.original f), toJSON' s) instance FromJSON MetaData where parseJSON (Object o) = do
Types/Test.hs view
@@ -1,6 +1,6 @@ {- git-annex test data types. -- - Copyright 2011-2017 Joey Hess <id@joeyh.name>+ - Copyright 2011-2022 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -8,27 +8,16 @@ module Types.Test where import Test.Tasty.Options-import Data.Monoid-import qualified Data.Semigroup as Sem-import Prelude +import Types.Concurrency import Types.Command data TestOptions = TestOptions { tastyOptionSet :: OptionSet , keepFailuresOption :: Bool , fakeSsh :: Bool+ , concurrentJobs :: Maybe Concurrency , internalData :: CmdParams }--instance Sem.Semigroup TestOptions where- a <> b = TestOptions- (tastyOptionSet a <> tastyOptionSet b)- (keepFailuresOption a || keepFailuresOption b)- (fakeSsh a || fakeSsh b)- (internalData a <> internalData b)--instance Monoid TestOptions where- mempty = TestOptions mempty False False mempty type TestRunner = TestOptions -> IO ()
Utility/Aeson.hs view
@@ -7,7 +7,7 @@ - License: BSD-2-clause -} -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, CPP #-} module Utility.Aeson ( module X,@@ -15,11 +15,19 @@ encode, packString, packByteString,+ textKey, ) where +#if MIN_VERSION_aeson(2,0,0)+import Data.Aeson as X hiding (ToJSON, toJSON, encode, Key)+#else import Data.Aeson as X hiding (ToJSON, toJSON, encode)+#endif import Data.Aeson hiding (encode) import qualified Data.Aeson+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as AK+#endif import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.ByteString.Lazy as L@@ -67,6 +75,14 @@ packString s = case T.decodeUtf8' (encodeBS s) of Right t -> t Left _ -> T.pack s++#if MIN_VERSION_aeson(2,0,0)+textKey :: T.Text -> AK.Key+textKey = AK.fromText+#else+textKey :: T.Text -> T.Text+textKey = id+#endif -- | The same as packString . decodeBS, but more efficient in the usual -- case.
Utility/AuthToken.hs view
@@ -5,6 +5,8 @@ - License: BSD-2-clause -} +{-# LANGUAGE PackageImports #-}+ module Utility.AuthToken ( AuthToken, toAuthToken,
Utility/Base64.hs view
@@ -5,6 +5,8 @@ - License: BSD-2-clause -} +{-# LANGUAGE PackageImports #-}+ module Utility.Base64 where import Utility.FileSystemEncoding
Utility/Hash.hs view
@@ -5,7 +5,7 @@ - License: BSD-2-clause -} -{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns, PackageImports #-} module Utility.Hash ( sha1,
− Utility/HttpManagerRestricted.hs
@@ -1,300 +0,0 @@-{- | Restricted `ManagerSettings` for <https://haskell-lang.org/library/http-client>- -- - Copyright 2018 Joey Hess <id@joeyh.name>- -- - Portions from http-client-tls Copyright (c) 2013 Michael Snoyman- -- - License: MIT- -}--{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, LambdaCase, PatternGuards #-}---- This is a vendored copy of Network.HTTP.Client.Restricted from the--- http-client-restricted package, and will be removed once that package--- is available in all build environments.-module Utility.HttpManagerRestricted (- Restriction,- checkAddressRestriction,- addressRestriction,- mkRestrictedManagerSettings,- ConnectionRestricted(..),- connectionRestricted,- ProxyRestricted(..),- IPAddrString,-) where--import Network.HTTP.Client-import Network.HTTP.Client.Internal (ManagerSettings(..), Connection, runProxyOverride)-import Network.HTTP.Client.TLS (mkManagerSettingsContext)-import Network.Socket-import Network.BSD (getProtocolNumber)-import Control.Exception-import qualified Network.Connection as NC-import qualified Data.ByteString.UTF8 as BU-import Data.Maybe-import Data.Default-import Data.Typeable-import qualified Data.Semigroup as Sem-import Data.Monoid-import Control.Applicative-import Prelude---- | Configuration of which HTTP connections to allow and which to--- restrict.-data Restriction = Restriction- { checkAddressRestriction :: AddrInfo -> Maybe ConnectionRestricted- }---- | Decide if a HTTP connection is allowed based on the IP address--- of the server.------ After the restriction is checked, the same IP address is used--- to connect to the server. This avoids DNS rebinding attacks--- being used to bypass the restriction.------ > myRestriction :: Restriction--- > myRestriction = addressRestriction $ \addr ->--- > if isPrivateAddress addr--- > then Just $ connectionRestricted--- > ("blocked connection to private IP address " ++)--- > else Nothing-addressRestriction :: (AddrInfo -> Maybe ConnectionRestricted) -> Restriction-addressRestriction f = mempty { checkAddressRestriction = f }--appendRestrictions :: Restriction -> Restriction -> Restriction-appendRestrictions a b = Restriction- { checkAddressRestriction = \addr ->- checkAddressRestriction a addr <|> checkAddressRestriction b addr- }---- | mempty does not restrict HTTP connections in any way-instance Monoid Restriction where- mempty = Restriction- { checkAddressRestriction = \_ -> Nothing- }--instance Sem.Semigroup Restriction where- (<>) = appendRestrictions---- | Value indicating that a connection was restricted, and giving the--- reason why.-data ConnectionRestricted = ConnectionRestricted String- deriving (Show, Typeable)--instance Exception ConnectionRestricted---- | A string containing an IP address, for display to a user.-type IPAddrString = String---- | Constructs a ConnectionRestricted, passing the function a string--- containing the IP address of the HTTP server.-connectionRestricted :: (IPAddrString -> String) -> AddrInfo -> ConnectionRestricted-connectionRestricted mkmessage = - ConnectionRestricted . mkmessage . showSockAddress . addrAddress---- | Value indicating that the http proxy will not be used.-data ProxyRestricted = ProxyRestricted- deriving (Show)---- Adjusts a ManagerSettings to enforce a Restriction. The restriction--- will be checked each time a Request is made, and for each redirect--- followed.------ This overrides the `managerRawConnection`--- and `managerTlsConnection` with its own implementations that check --- the Restriction. They should otherwise behave the same as the--- ones provided by http-client-tls.------ This function is not exported, because using it with a ManagerSettings--- produced by something other than http-client-tls would result in--- surprising behavior, since its connection methods would not be used.------ The http proxy is also checked against the Restriction, and if--- access to it is blocked, the http proxy will not be used.-restrictManagerSettings- :: Maybe NC.ConnectionContext- -> Maybe NC.TLSSettings- -> Restriction- -> ManagerSettings- -> IO (ManagerSettings, Maybe ProxyRestricted)-restrictManagerSettings mcontext mtls cfg base = restrictProxy cfg $ base- { managerRawConnection = restrictedRawConnection cfg- , managerTlsConnection = restrictedTlsConnection mcontext mtls cfg- , managerWrapException = wrapOurExceptions base- }---- | Makes a TLS-capable ManagerSettings with a Restriction applied to it.------ The Restriction will be checked each time a Request is made, and for--- each redirect followed.------ Aside from checking the Restriction, it should behave the same as--- `Network.HTTP.Client.TLS.mkManagerSettingsContext`--- from http-client-tls.------ > main = do--- > manager <- newManager . fst --- > =<< mkRestrictedManagerSettings myRestriction Nothing Nothing--- > request <- parseRequest "http://httpbin.org/get"--- > response <- httpLbs request manager--- > print $ responseBody response------ The HTTP proxy is also checked against the Restriction, and will not be--- used if the Restriction does not allow it. Just ProxyRestricted--- is returned when the HTTP proxy has been restricted.--- --- See `mkManagerSettingsContext` for why--- it can be useful to provide a `NC.ConnectionContext`.--- --- Note that SOCKS is not supported.-mkRestrictedManagerSettings- :: Restriction- -> Maybe NC.ConnectionContext- -> Maybe NC.TLSSettings- -> IO (ManagerSettings, Maybe ProxyRestricted)-mkRestrictedManagerSettings cfg mcontext mtls =- restrictManagerSettings mcontext mtls cfg $- mkManagerSettingsContext mcontext (fromMaybe def mtls) Nothing--restrictProxy- :: Restriction- -> ManagerSettings- -> IO (ManagerSettings, Maybe ProxyRestricted)-restrictProxy cfg base = do - http_proxy_addr <- getproxyaddr False- https_proxy_addr <- getproxyaddr True- let (http_proxy, http_r) = mkproxy http_proxy_addr- let (https_proxy, https_r) = mkproxy https_proxy_addr- let ms = managerSetInsecureProxy http_proxy $ - managerSetSecureProxy https_proxy base- return (ms, http_r <|> https_r)- where- -- This does not use localhost because http-client may choose- -- not to use the proxy for localhost.- testnetip = "198.51.100.1"- dummyreq https = parseRequest_ $- "http" ++ (if https then "s" else "") ++ "://" ++ testnetip-- getproxyaddr https = extractproxy >>= \case- Nothing -> return Nothing- Just p -> do- proto <- getProtocolNumber "tcp"- let serv = show (proxyPort p)- let hints = defaultHints- { addrFlags = [AI_ADDRCONFIG]- , addrProtocol = proto- , addrSocketType = Stream- }- let h = BU.toString $ proxyHost p- getAddrInfo (Just hints) (Just h) (Just serv) >>= \case- [] -> return Nothing- (addr:_) -> return $ Just addr- where- -- These contortions are necessary until this issue- -- is fixed:- -- https://github.com/snoyberg/http-client/issues/355- extractproxy = do- let po = if https- then managerProxySecure base- else managerProxyInsecure base- f <- runProxyOverride po https- return $ proxy $ f $ dummyreq https- - mkproxy Nothing = (noProxy, Nothing)- mkproxy (Just proxyaddr) = case checkAddressRestriction cfg proxyaddr of- Nothing -> (addrtoproxy (addrAddress proxyaddr), Nothing)- Just _ -> (noProxy, Just ProxyRestricted)- - addrtoproxy addr = case addr of- SockAddrInet pn _ -> mk pn- SockAddrInet6 pn _ _ _ -> mk pn- _ -> noProxy- where- mk pn = useProxy Network.HTTP.Client.Proxy- { proxyHost = BU.fromString (showSockAddress addr)- , proxyPort = fromIntegral pn- }--wrapOurExceptions :: ManagerSettings -> Request -> IO a -> IO a-wrapOurExceptions base req a =- let wrapper se- | Just (_ :: ConnectionRestricted) <- fromException se = - toException $ HttpExceptionRequest req $- InternalException se- | otherwise = se- in managerWrapException base req (handle (throwIO . wrapper) a)--restrictedRawConnection :: Restriction -> IO (Maybe HostAddress -> String -> Int -> IO Connection)-restrictedRawConnection cfg = getConnection cfg Nothing Nothing--restrictedTlsConnection :: Maybe NC.ConnectionContext -> Maybe NC.TLSSettings -> Restriction -> IO (Maybe HostAddress -> String -> Int -> IO Connection)-restrictedTlsConnection mcontext mtls cfg = - getConnection cfg (Just (fromMaybe def mtls)) mcontext---- Based on Network.HTTP.Client.TLS.getTlsConnection.------ Checks the Restriction------ Does not support SOCKS.-getConnection- :: Restriction- -> Maybe NC.TLSSettings- -> Maybe NC.ConnectionContext- -> IO (Maybe HostAddress -> String -> Int -> IO Connection)-getConnection cfg tls mcontext = do- context <- maybe NC.initConnectionContext return mcontext- return $ \_ha h p -> bracketOnError- (go context h p)- NC.connectionClose- convertConnection- where- go context h p = do- let connparams = NC.ConnectionParams- { NC.connectionHostname = h- , NC.connectionPort = fromIntegral p- , NC.connectionUseSecure = tls- , NC.connectionUseSocks = Nothing -- unsupprted- }- proto <- getProtocolNumber "tcp"- let serv = show p- let hints = defaultHints- { addrFlags = [AI_ADDRCONFIG]- , addrProtocol = proto- , addrSocketType = Stream- }- addrs <- getAddrInfo (Just hints) (Just h) (Just serv)- bracketOnError- (firstSuccessful $ map tryToConnect addrs)- close- (\sock -> NC.connectFromSocket context sock connparams)- where- tryToConnect addr = case checkAddressRestriction cfg addr of- Nothing -> bracketOnError- (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))- close- (\sock -> connect sock (addrAddress addr) >> return sock)- Just r -> throwIO r- firstSuccessful [] = throwIO $ NC.HostNotResolved h- firstSuccessful (a:as) = a `catch` \(e ::IOException) ->- case as of- [] -> throwIO e- _ -> firstSuccessful as---- Copied from Network.HTTP.Client.TLS, unfortunately not exported.-convertConnection :: NC.Connection -> IO Connection-convertConnection conn = makeConnection- (NC.connectionGetChunk conn)- (NC.connectionPut conn)- -- Closing an SSL connection gracefully involves writing/reading- -- on the socket. But when this is called the socket might be- -- already closed, and we get a @ResourceVanished@.- (NC.connectionClose conn `Control.Exception.catch` \(_ :: IOException) -> return ())---- For ipv4 and ipv6, the string will contain only the IP address,--- omitting the port that the Show instance includes.-showSockAddress :: SockAddr -> IPAddrString-showSockAddress a@(SockAddrInet _ _) =- takeWhile (/= ':') $ show a-showSockAddress a@(SockAddrInet6 _ _ _ _) =- takeWhile (/= ']') $ drop 1 $ show a-showSockAddress a = show a
Utility/Path/Tests.hs view
@@ -49,7 +49,8 @@ p = pathSeparator `B.cons` relf -- Make the input a relative path. On windows, make sure it does -- not contain anything that looks like a drive letter.- relf = B.filter (not . skipchar) $ B.dropWhile isPathSeparator $+ relf = B.dropWhile isPathSeparator $+ B.filter (not . skipchar) $ toRawFilePath (fromTestableFilePath pt) skipchar b = b == (fromIntegral (ord ':'))
Utility/Url.hs view
@@ -9,7 +9,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} module Utility.Url ( newManager,@@ -46,11 +45,7 @@ import Common import Utility.Debug import Utility.Metered-#ifdef WITH_HTTP_CLIENT_RESTRICTED import Network.HTTP.Client.Restricted-#else-import Utility.HttpManagerRestricted-#endif import Utility.IPAddress import qualified Utility.RawFilePath as R import Utility.Hash (IncrementalVerifier(..))
Utility/WebApp.hs view
@@ -5,7 +5,7 @@ - License: BSD-2-clause -} -{-# LANGUAGE OverloadedStrings, CPP, RankNTypes #-}+{-# LANGUAGE OverloadedStrings, CPP, RankNTypes, PackageImports #-} module Utility.WebApp ( browserProc,
doc/git-annex-test.mdwn view
@@ -20,6 +20,11 @@ There are several options, provided by Haskell's tasty test framework. Pass --help for details about those. +* `--jobs=N` `-JN`++ How many tests to run in parallel. The default is "cpus", which will+ runs one job per CPU core.+ * `--keep-failures` When there are test failures, leave the `.t` directory populated with
doc/git-annex.mdwn view
@@ -1231,8 +1231,10 @@ Usually the write permission bits are unset to protect annexed objects from being modified or deleted. The freezecontent-command is run after- git-annex has removed the write bit. The thawcontent-command should undo- its effect, and is run before git-annex restores the write bit.+ git-annex has removed (or attempted to remove) the write bit, and can+ be used to prevent writing in some other way.+ The thawcontent-command should undo its effect, and is run before+ git-annex restores the write bit. In the command line, %path is replaced with the file or directory to operate on.@@ -1894,11 +1896,12 @@ # EXIT STATUS -git-annex, when called as a git subcommand, may return exit codes 0 or 1-for success or failures, or, more rarely, 127 or 128 for certain very-specific failures. git-annex itself should return 0 on success and 1 on-failure, unless the `--time-limit=time` option is hit, in which case it-returns with exit code 101.+git-annex itself will exit 0 on success and 1 on failure, unless +the `--size-limit` or `--time-limit` option is hit, in +which case it exits 101. ++A few git-annex subcommands have other exit statuses used to indicate+specific problems, which are documented on their individual man pages. # ENVIRONMENT
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20220222+Version: 10.20220322 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -284,18 +284,10 @@ Flag Dbus Description: Enable dbus support -Flag NetworkBSD- Description: Build with network-3.0 which split out network-bsd- Default: True- Flag GitLfs Description: Build with git-lfs library (rather than vendored copy) Default: True -Flag HttpClientRestricted- Description: Build with http-client-restricted library (rather than vendored copy)- Default: True- source-repository head type: git location: git://git-annex.branchable.com/@@ -348,6 +340,7 @@ http-client-tls, http-types (>= 0.7), http-conduit (>= 2.3.0),+ http-client-restricted (>= 0.0.2), conduit, time (>= 1.5.0), old-locale,@@ -374,16 +367,19 @@ attoparsec (>= 0.13.2.2), concurrent-output (>= 1.10), QuickCheck (>= 2.10.0),- tasty (>= 0.7),+ tasty (>= 1.2), tasty-hunit, tasty-quickcheck, tasty-rerun,+ ansi-terminal >= 0.9, aws (>= 0.20),- DAV (>= 1.0)+ DAV (>= 1.0),+ network (>= 3.0.0.0),+ network-bsd CC-Options: -Wall GHC-Options: -Wall -fno-warn-tabs -Wincomplete-uni-patterns Default-Language: Haskell2010- Default-Extensions: PackageImports, LambdaCase+ Default-Extensions: LambdaCase Other-Extensions: TemplateHaskell -- Some things don't work with the non-threaded RTS. GHC-Options: -threaded@@ -413,23 +409,12 @@ else Build-Depends: unix (>= 2.7.2) - if flag(NetworkBSD)- Build-Depends: network-bsd, network (>= 3.0.0.0)- else- Build-Depends: network (< 3.0.0.0), network (>= 2.6.3.0)- if flag(GitLfs) Build-Depends: git-lfs (>= 1.2.0) CPP-Options: -DWITH_GIT_LFS else Other-Modules: Utility.GitLFS - if flag(HttpClientRestricted)- Build-Depends: http-client-restricted (>= 0.0.2)- CPP-Options: -DWITH_HTTP_CLIENT_RESTRICTED- else- Other-Modules: Utility.HttpManagerRestricted- if flag(Assistant) && ! os(solaris) && ! os(gnu) Build-Depends: mountpoints CPP-Options: -DWITH_ASSISTANT
stack.yaml view
@@ -9,9 +9,7 @@ dbus: false debuglocks: false benchmark: true- networkbsd: true gitlfs: true- httpclientrestricted: true packages: - '.' resolver: lts-18.13