git-annex 10.20230828 → 10.20230926
raw patch · 23 files changed
+149/−554 lines, 23 filesdep +crypton
Dependencies added: crypton
Files
- Build/Version.hs +1/−1
- BuildFlags.hs +4/−0
- CHANGELOG +21/−0
- COPYRIGHT +2/−2
- CmdLine/GitAnnexShell.hs +4/−2
- Command/DiffDriver.hs +6/−2
- Command/EnableRemote.hs +10/−0
- Command/LookupKey.hs +26/−10
- Command/PostReceive.hs +4/−2
- Command/Sync.hs +23/−11
- Database/Handle.hs +2/−1
- Git/Config.hs +13/−2
- Git/Construct.hs +3/−2
- Git/CurrentRepo.hs +3/−1
- Git/Types.hs +5/−0
- Remote/Adb.hs +4/−18
- Remote/Git.hs +2/−1
- Remote/GitLFS.hs +0/−6
- Utility/GitLFS.hs +0/−476
- Utility/Hash.hs +2/−2
- git-annex.cabal +12/−13
- stack-lts-18.13.yaml +1/−1
- stack.yaml +1/−1
Build/Version.hs view
@@ -36,7 +36,7 @@ , catchDefaultIO changelogversion $ do gitversion <- takeWhile (\c -> isAlphaNum c) <$> readProcess "sh" [ "-c"- , "git log -n 1 --format=format:'%h'"+ , "git log -n 1 --format=format:'%H'" ] "" return $ if null gitversion then changelogversion
BuildFlags.hs view
@@ -75,7 +75,11 @@ , ("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
CHANGELOG view
@@ -1,3 +1,24 @@+git-annex (10.20230926) upstream; urgency=medium++ * Fix more breakage caused by git's fix for CVE-2022-24765, this time+ involving a remote (either local or ssh) that is a repository not owned+ by the current user.+ * Fix using git remotes that are bare when git is configured with + safe.bareRepository = explicit.+ * Fix linker optimisation in linux standalone tarballs.+ * adb: Avoid some problems with unusual characters in exporttree + filenames that confuse adb shell commands.+ * push: When on an adjusted branch, propagate changes to parent branch+ before updating export remotes.+ * lookupkey: Added --ref option.+ * enableremote: Avoid overwriting existing git remote when passed the uuid+ of a specialremote that was earlier initialized with the same name.+ * Support being built with crypton rather than the no-longer maintained + cryptonite.+ * Removed the vendored git-lfs and the GitLfs build flag.++ -- Joey Hess <id@joeyh.name> Tue, 26 Sep 2023 13:23:37 -0400+ git-annex (10.20230828) upstream; urgency=medium * oldkeys: New command that lists the keys used by old versions of a file.
COPYRIGHT view
@@ -43,8 +43,8 @@ 2007-2015 Bryan O'Sullivan License: BSD-3-clause -Files: Utility/GitLFS.hs Utility/Matcher.hs Utility/Tor.hs Utility/Yesod.hs-Copyright: © 2019 Joey Hess <id@joeyh.name>+Files: Utility/Matcher.hs Utility/Tor.hs Utility/Yesod.hs+Copyright: © 2010-2023 Joey Hess <id@joeyh.name> License: AGPL-3+ Files: Utility/*
CmdLine/GitAnnexShell.hs view
@@ -1,6 +1,6 @@ {- git-annex-shell main program -- - Copyright 2010-2021 Joey Hess <id@joeyh.name>+ - Copyright 2010-2023 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -18,6 +18,7 @@ import CmdLine.GitAnnexShell.Fields import Remote.GCrypt (getGCryptUUID) import P2P.Protocol (ServerMode(..))+import Git.Types import qualified Command.ConfigList import qualified Command.NotifyChanges@@ -123,7 +124,8 @@ mkrepo = do r <- Git.Construct.repoAbsPath (toRawFilePath dir) >>= Git.Construct.fromAbsPath- Git.Config.read r+ let r' = r { repoPathSpecifiedExplicitly = True }+ Git.Config.read r' `catchIO` \_ -> do hn <- fromMaybe "unknown" <$> getHostname giveup $ "failed to read git config of git repository in " ++ hn ++ " on " ++ dir ++ "; perhaps this repository is not set up correctly or has moved"
Command/DiffDriver.hs view
@@ -106,9 +106,13 @@ fixupReq :: Req -> Options -> Annex Req fixupReq req@(UnmergedReq {}) _ = return req fixupReq req@(Req {}) opts = - check rOldFile rOldMode (\r f -> r { rOldFile = f }) req- >>= check rNewFile rNewMode (\r f -> r { rNewFile = f })+ check rOldFile rOldMode setoldfile req+ >>= check rNewFile rNewMode setnewfile where+ setoldfile r@(Req {}) f = r { rOldFile = f }+ setoldfile r@(UnmergedReq {}) _ = r+ setnewfile r@(Req {}) f = r { rNewFile = f }+ setnewfile r@(UnmergedReq {}) _ = r check getfile getmode setfile r = case readTreeItemType (encodeBS (getmode r)) of Just TreeSymlink -> do v <- getAnnexLinkTarget' f False
Command/EnableRemote.hs view
@@ -99,6 +99,16 @@ performSpecialRemote :: PerformSpecialRemote performSpecialRemote t u oldc c gc mcu = do+ -- Avoid enabling a special remote if there is another remote+ -- with the same name.+ case SpecialRemote.lookupName c of+ Nothing -> noop+ Just name -> do+ rs <- Remote.remoteList+ case filter (\rmt -> Remote.name rmt == name) rs of+ (rmt:_) | Remote.uuid rmt /= u ->+ giveup $ "Not overwriting currently configured git remote named \"" ++ name ++ "\""+ _ -> noop (c', u') <- R.setup t (R.Enable oldc) (Just u) Nothing c gc next $ cleanupSpecialRemote t u' c' mcu
Command/LookupKey.hs view
@@ -10,6 +10,7 @@ import Command import Annex.CatFile import qualified Git.LsFiles+import Git.Types import Utility.Terminal import Utility.SafeOutput @@ -18,18 +19,33 @@ command "lookupkey" SectionPlumbing "looks up key used for file" (paramRepeating paramFile)- (batchable run (pure ()))+ (batchable run optParser) -run :: () -> SeekInput -> String -> Annex Bool-run _ _ file = seekSingleGitFile file >>= \case- Nothing -> return False- Just file' -> catKeyFile file' >>= \case- Just k -> do- IsTerminal isterminal <- liftIO $ checkIsTerminal stdout- let sk = serializeKey k- liftIO $ putStrLn $ if isterminal then safeOutput sk else sk- return True+data LookupKeyOptions = LookupKeyOptions+ { refOption :: Bool+ }++optParser :: Parser LookupKeyOptions+optParser = LookupKeyOptions+ <$> switch+ ( long "ref"+ <> help "look up key used by git ref to file"+ )++run :: LookupKeyOptions -> SeekInput -> String -> Annex Bool+run o _ file+ | refOption o = catKey (Ref (toRawFilePath file)) >>= display+ | otherwise = seekSingleGitFile file >>= \case Nothing -> return False+ Just file' -> catKeyFile file' >>= display++display :: Maybe Key -> Annex Bool+display (Just k) = do+ IsTerminal isterminal <- liftIO $ checkIsTerminal stdout+ let sk = serializeKey k+ liftIO $ putStrLn $ if isterminal then safeOutput sk else sk+ return True+display Nothing = return False -- To support absolute filenames, pass through git ls-files. -- But, this plumbing command does not recurse through directories.
Command/PostReceive.hs view
@@ -43,8 +43,10 @@ case location g of Local { gitdir = ".", worktree = Just "." } -> Annex.adjustGitRepo $ \g' -> pure $ g'- { location = (location g')- { worktree = Just ".." }+ { location = case location g' of+ loc@(Local {}) -> loc + { worktree = Just ".." }+ loc -> loc } _ -> noop
Command/Sync.hs view
@@ -979,14 +979,24 @@ - Returns True if any file transfers were made. -} seekExportContent :: Maybe SyncOptions -> [Remote] -> CurrBranch -> Annex Bool-seekExportContent o rs (currbranch, _) = or <$> forM rs go+seekExportContent o rs (mcurrbranch, madj)+ | null rs = return False+ | otherwise = do+ -- Propigate commits from the adjusted branch, so that+ -- when the remoteAnnexTrackingBranch is set to the parent+ -- branch, it will be up-to-date.+ case (mcurrbranch, madj) of+ (Just currbranch, Just adj) ->+ propigateAdjustedCommits currbranch adj+ _ -> noop+ or <$> forM rs go where go r | maybe False (\o' -> operationMode o' == SatisfyMode) o = case remoteAnnexTrackingBranch (Remote.gitconfig r) of Nothing -> return False- Just b -> withdb r $ \db ->- cannotupdateexport r db (Just b) False+ Just _ -> withdb r $ \db ->+ cannotupdateexport r db Nothing False | not (maybe True pushOption o) = return False | not (remoteAnnexPush (Remote.gitconfig r)) = return False | otherwise = withdb r (go' r)@@ -1000,7 +1010,7 @@ Nothing -> id mcurrtree <- maybe (pure Nothing) (inRepo . Git.Ref.tree . addsubdir)- currbranch+ mcurrbranch mtbcommitsha <- Command.Export.getExportCommit r b case (mtree, mcurrtree, mtbcommitsha) of (Just tree, Just currtree, Just _)@@ -1008,21 +1018,23 @@ filteredtree <- Command.Export.filterExport r tree Command.Export.changeExport r db filteredtree Command.Export.fillExport r db filteredtree mtbcommitsha- | otherwise -> cannotupdateexport r db (Just b) False- _ -> cannotupdateexport r db (Just b) True+ | otherwise -> cannotupdateexport r db Nothing False+ (Nothing, _, _) -> cannotupdateexport r db (Just (Git.fromRef b ++ " does not exist")) True+ (_, Nothing, _) -> cannotupdateexport r db (Just "no branch is currently checked out") True+ (_, _, Nothing) -> cannotupdateexport r db (Just "tracking branch name is not valid") True withdb r a = bracket (Export.openDb (Remote.uuid r)) Export.closeDb (\db -> Export.writeLockDbWhile db (a db)) - cannotupdateexport r db mtb showwarning = do+ cannotupdateexport r db mreason showwarning = do exported <- getExport (Remote.uuid r) when showwarning $- maybe noop (warncannotupdateexport r mtb exported) currbranch+ maybe noop (warncannotupdateexport r mreason exported) mcurrbranch fillexistingexport r db (exportedTreeishes exported) Nothing - warncannotupdateexport r mtb exported currb = case mtb of+ warncannotupdateexport r mreason exported currb = case mreason of Nothing -> inRepo (Git.Ref.tree currb) >>= \case Just currt | not (any (== currt) (exportedTreeishes exported)) -> showLongNote $ UnquotedString $ unwords@@ -1032,9 +1044,9 @@ , "(Set " ++ gitconfig ++ " to enable it.)" ] _ -> noop- Just b -> showLongNote $ UnquotedString $ unwords+ Just reason -> showLongNote $ UnquotedString $ unwords [ notupdating- , "because " ++ Git.fromRef b ++ " does not exist."+ , "because " ++ reason ++ "." , "(As configured by " ++ gitconfig ++ ")" ] where
Database/Handle.hs view
@@ -5,7 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE TypeFamilies, FlexibleContexts, OverloadedStrings, CPP #-}+{-# LANGUAGE TypeFamilies, TypeOperators #-}+{-# LANGUAGE FlexibleContexts, OverloadedStrings, CPP #-} module Database.Handle ( DbHandle,
Git/Config.hs view
@@ -72,12 +72,22 @@ go _ = assertLocal repo $ error "internal" git_config addparams d = withCreateProcess p (git_config' p) where- params = addparams ++ ["config", "--null", "--list"]+ params = addparams ++ explicitrepoparams+ ++ ["config", "--null", "--list"] p = (proc "git" params) { cwd = Just (fromRawFilePath d) , env = gitEnv repo , std_out = CreatePipe }+ explicitrepoparams = if repoPathSpecifiedExplicitly repo + then + -- Use * rather than d, because git treats+ -- "dir/" differently than "dir" when comparing+ -- for safe.directory purposes.+ [ "-c", "safe.directory=*"+ , "-c", "safe.bareRepository=all" + ]+ else [] git_config' p _ (Just hout) _ pid = forceSuccessProcess p pid `after`@@ -165,7 +175,7 @@ updateLocation r = return r updateLocation' :: Repo -> RepoLocation -> IO Repo-updateLocation' r l = do+updateLocation' r l@(Local {}) = do l' <- case getMaybe "core.worktree" r of Nothing -> return l Just (ConfigValue d) -> do@@ -175,6 +185,7 @@ return $ l { worktree = Just p } Just NoConfigValue -> return l return $ r { location = l' }+updateLocation' r l = return r { location = l } data ConfigStyle = ConfigList | ConfigNullList
Git/Construct.hs view
@@ -260,7 +260,7 @@ adjustGitDirFile loc = fromMaybe loc <$> adjustGitDirFile' loc adjustGitDirFile' :: RepoLocation -> IO (Maybe RepoLocation)-adjustGitDirFile' loc = do+adjustGitDirFile' loc@(Local {}) = do let gd = gitdir loc c <- firstLine <$> catchDefaultIO "" (readFile (fromRawFilePath gd)) if gitdirprefix `isPrefixOf` c@@ -275,7 +275,7 @@ else return Nothing where gitdirprefix = "gitdir: "-+adjustGitDirFile' _ = error "internal" newFrom :: RepoLocation -> Repo newFrom l = Repo@@ -287,5 +287,6 @@ , gitEnvOverridesGitDir = False , gitGlobalOpts = [] , gitDirSpecifiedExplicitly = False+ , repoPathSpecifiedExplicitly = False }
Git/CurrentRepo.hs view
@@ -82,7 +82,9 @@ r <- Git.Config.read $ (newFrom loc) { gitDirSpecifiedExplicitly = True } return $ if fromMaybe False (Git.Config.isBare r)- then r { location = (location r) { worktree = Nothing } }+ then case location r of+ loc'@(Local {}) -> r { location = loc' { worktree = Nothing } }+ _ -> r else r configure Nothing Nothing = giveup "Not in a git repository."
Git/Types.hs view
@@ -53,6 +53,11 @@ , gitGlobalOpts :: [CommandParam] -- True only when --git-dir or GIT_DIR was used , gitDirSpecifiedExplicitly :: Bool+ -- Use when the path to the repository was specified explicitly,+ -- eg in a git remote, and so it's safe to set + -- -c safe.directory=* and -c safe.bareRepository=all + -- when using this repository.+ , repoPathSpecifiedExplicitly :: Bool } deriving (Show, Eq, Ord) newtype ConfigKey = ConfigKey S.ByteString
Remote/Adb.hs view
@@ -183,24 +183,12 @@ giveup "adb failed" store' :: AndroidSerial -> AndroidPath -> FilePath -> Annex Bool-store' serial dest src = store'' serial dest src (return True)--store'' :: AndroidSerial -> AndroidPath -> FilePath -> Annex Bool -> Annex Bool-store'' serial dest src canoverwrite = checkAdbInPath False $ do+store' serial dest src = checkAdbInPath False $ do let destdir = takeDirectory $ fromAndroidPath dest void $ adbShell serial [Param "mkdir", Param "-p", File destdir] showOutput -- make way for adb push output- let tmpdest = fromAndroidPath dest ++ ".annextmp"- ifM (liftIO $ boolSystem "adb" (mkAdbCommand serial [Param "push", File src, File tmpdest]))- ( ifM canoverwrite- -- move into place atomically- ( adbShellBool serial [Param "mv", File tmpdest, File (fromAndroidPath dest)]- , do- void $ remove' serial (AndroidPath tmpdest)- return False- )- , return False- )+ liftIO $ boolSystem "adb" $ mkAdbCommand serial+ [Param "push", File src, File (fromAndroidPath dest)] retrieve :: AndroidSerial -> AndroidPath -> Retriever retrieve serial adir = fileRetriever $ \dest k _p ->@@ -385,10 +373,8 @@ storeExportWithContentIdentifierM :: AndroidSerial -> AndroidPath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier storeExportWithContentIdentifierM serial adir src _k loc overwritablecids _p =- -- Check if overwrite is safe before sending, because sending the- -- file is expensive and don't want to do it unncessarily. ifM checkcanoverwrite- ( ifM (store'' serial dest src checkcanoverwrite)+ ( ifM (store' serial dest src) ( getExportContentIdentifier serial adir loc >>= \case Right (Just cid) -> return cid Right Nothing -> giveup "adb failed to store file"
Remote/Git.hs view
@@ -339,7 +339,8 @@ warning $ UnquotedString $ "Remote " ++ Git.repoDescribe r ++ ": " ++ show e Annex.getState Annex.repo- s <- newLocal r+ let r' = r { Git.repoPathSpecifiedExplicitly = True }+ s <- newLocal r' liftIO $ Annex.eval s $ check `finally` quiesce True
Remote/GitLFS.hs view
@@ -7,7 +7,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE CPP #-} module Remote.GitLFS (remote, gen, configKnownUrl) where @@ -44,12 +43,7 @@ import Logs.RemoteState import qualified Git.Config -#ifdef WITH_GIT_LFS import qualified Network.GitLFS as LFS-#else-import qualified Utility.GitLFS as LFS-#endif- import Control.Concurrent.STM import Data.String import Network.HTTP.Types
− Utility/GitLFS.hs
@@ -1,476 +0,0 @@-{- git-lfs API- - - - https://github.com/git-lfs/git-lfs/blob/master/docs/api- -- - Copyright 2019 Joey Hess <id@joeyh.name>- -- - Licensed under the GNU AGPL version 3 or higher.- -}---- | This implementation of the git-lfs API uses http Request and Response,--- but leaves actually connecting up the http client to the user.------ You'll want to use a Manager that supports https, since the protocol--- uses http basic auth.------ Some LFS servers, notably Github's, may require a User-Agent header--- in some of the requests, in order to allow eg, uploads. No such header--- is added by default, so be sure to add your own.--{-# LANGUAGE DeriveGeneric, FlexibleInstances, FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE LambdaCase #-}---- This is a vendored copy of Network.GitLFS from the git-lfs package,--- and will be removed once that package is available in all build--- environments.-module Utility.GitLFS (- -- * Transfer requests- TransferRequest(..),- TransferRequestOperation(..),- TransferAdapter(..),- TransferRequestObject(..),- startTransferRequest,-- -- * Responses to transfer requests- TransferResponse(..),- TransferResponseOperation(..),- IsTransferResponseOperation,- DownloadOperation(..),- UploadOperation(..),- OperationParams(..),- ParsedTransferResponse(..),- parseTransferResponse,-- -- * Making transfers- downloadOperationRequest,- uploadOperationRequests,- ServerSupportsChunks(..),-- -- * Endpoint discovery- Endpoint,- guessEndpoint,- modifyEndpointRequest,- sshDiscoverEndpointCommand,- parseSshDiscoverEndpointResponse,-- -- * Errors- TransferResponseError(..),- TransferResponseObjectError(..),-- -- * Additional data types- Url,- SHA256,- GitRef(..),- NumSeconds,- HTTPHeader,- HTTPHeaderValue,-) where--import Data.Aeson-import Data.Aeson.Types-import GHC.Generics-import Network.HTTP.Client-import Data.List-import qualified Data.Map as M-import qualified Data.Text as T-import qualified Data.Text.Encoding as E-import qualified Data.ByteString.Lazy as L-import qualified Data.CaseInsensitive as CI-import qualified Network.URI as URI--data TransferRequest = TransferRequest- { req_operation :: TransferRequestOperation- , req_transfers :: [TransferAdapter]- , req_ref :: Maybe GitRef- , req_objects :: [TransferRequestObject]- }- deriving (Generic, Show)--instance ToJSON TransferRequest where- toJSON = genericToJSON transferRequestOptions- toEncoding = genericToEncoding transferRequestOptions--instance FromJSON TransferRequest where- parseJSON = genericParseJSON transferRequestOptions--transferRequestOptions :: Options-transferRequestOptions = stripFieldPrefix nonNullOptions--data TransferRequestObject = TransferRequestObject- { req_oid :: SHA256- , req_size :: Integer- }- deriving (Generic, Show)--instance ToJSON TransferRequestObject where- toJSON = genericToJSON transferRequestObjectOptions- toEncoding = genericToEncoding transferRequestObjectOptions--instance FromJSON TransferRequestObject where- parseJSON = genericParseJSON transferRequestObjectOptions--transferRequestObjectOptions :: Options-transferRequestObjectOptions = stripFieldPrefix defaultOptions--data TransferRequestOperation = RequestDownload | RequestUpload- deriving (Show)--instance ToJSON TransferRequestOperation where- toJSON RequestDownload = "download"- toJSON RequestUpload = "upload"--instance FromJSON TransferRequestOperation where- parseJSON (String "download") = pure RequestDownload- parseJSON (String "upload") = pure RequestUpload- parseJSON invalid = typeMismatch "TransferRequestOperation" invalid--data TransferResponse op = TransferResponse- { transfer :: Maybe TransferAdapter- , objects :: [TransferResponseOperation op]- }- deriving (Generic, Show)--instance IsTransferResponseOperation op => ToJSON (TransferResponse op) where- toJSON = genericToJSON nonNullOptions- toEncoding = genericToEncoding nonNullOptions--instance IsTransferResponseOperation op => FromJSON (TransferResponse op)---- | This is an error with a TransferRequest as a whole. It's also possible--- for a TransferRequest to overall succeed, but fail for some--- objects; such failures use TransferResponseObjectError.-data TransferResponseError = TransferResponseError- { resperr_message :: T.Text- , resperr_request_id :: Maybe T.Text- , resperr_documentation_url :: Maybe Url- }- deriving (Generic, Show)--instance ToJSON TransferResponseError where- toJSON = genericToJSON transferResponseErrorOptions- toEncoding = genericToEncoding transferResponseErrorOptions--instance FromJSON TransferResponseError where- parseJSON = genericParseJSON transferResponseErrorOptions--transferResponseErrorOptions :: Options-transferResponseErrorOptions = stripFieldPrefix nonNullOptions---- | An error with a single object within a TransferRequest.-data TransferResponseObjectError = TransferResponseObjectError- { respobjerr_code :: Int- , respobjerr_message :: T.Text- }- deriving (Generic, Show)--instance ToJSON TransferResponseObjectError where- toJSON = genericToJSON transferResponseObjectErrorOptions- toEncoding = genericToEncoding transferResponseObjectErrorOptions--instance FromJSON TransferResponseObjectError where- parseJSON = genericParseJSON transferResponseObjectErrorOptions--transferResponseObjectErrorOptions :: Options-transferResponseObjectErrorOptions = stripFieldPrefix nonNullOptions--data TransferAdapter = Basic- deriving (Show)--instance ToJSON TransferAdapter where- toJSON Basic = "basic"--instance FromJSON TransferAdapter where- parseJSON (String "basic") = pure Basic- parseJSON invalid = typeMismatch "basic" invalid--data TransferResponseOperation op = TransferResponseOperation- { resp_oid :: SHA256- , resp_size :: Integer- , resp_authenticated :: Maybe Bool- , resp_actions :: Maybe op- , resp_error :: Maybe TransferResponseObjectError- }- deriving (Generic, Show)--instance ToJSON op => ToJSON (TransferResponseOperation op) where- toJSON = genericToJSON transferResponseOperationOptions- toEncoding = genericToEncoding transferResponseOperationOptions--instance FromJSON op => FromJSON (TransferResponseOperation op) where- parseJSON = genericParseJSON transferResponseOperationOptions--transferResponseOperationOptions :: Options-transferResponseOperationOptions = stripFieldPrefix nonNullOptions---- | Class of types that can be responses to a transfer request,--- that contain an operation to use to make the transfer.-class (FromJSON op, ToJSON op) => IsTransferResponseOperation op--data DownloadOperation = DownloadOperation- { download :: OperationParams }- deriving (Generic, Show)--instance IsTransferResponseOperation DownloadOperation-instance ToJSON DownloadOperation-instance FromJSON DownloadOperation--data UploadOperation = UploadOperation- { upload :: OperationParams- , verify :: Maybe OperationParams- }- deriving (Generic, Show)--instance IsTransferResponseOperation UploadOperation--instance ToJSON UploadOperation where- toJSON = genericToJSON nonNullOptions- toEncoding = genericToEncoding nonNullOptions--instance FromJSON UploadOperation--data OperationParams = OperationParams- { href :: Url- , header :: Maybe (M.Map HTTPHeader HTTPHeaderValue)- , expires_in :: Maybe NumSeconds- , expires_at :: Maybe T.Text- }- deriving (Generic, Show)--instance ToJSON OperationParams where- toJSON = genericToJSON nonNullOptions- toEncoding = genericToEncoding nonNullOptions--instance FromJSON OperationParams--data Verification = Verification- { verification_oid :: SHA256- , verification_size :: Integer- }- deriving (Generic, Show)--instance ToJSON Verification where- toJSON = genericToJSON verificationOptions- toEncoding = genericToEncoding verificationOptions--instance FromJSON Verification where- parseJSON = genericParseJSON verificationOptions--verificationOptions :: Options-verificationOptions = stripFieldPrefix defaultOptions---- | Sent over ssh connection when using that to find the endpoint.-data SshDiscoveryResponse = SshDiscoveryResponse- { endpoint_href :: Url- , endpoint_header :: Maybe (M.Map HTTPHeader HTTPHeaderValue)- , endpoint_expires_in :: Maybe NumSeconds- , endpoint_expires_at :: Maybe T.Text- } deriving (Generic, Show)--instance ToJSON SshDiscoveryResponse where- toJSON = genericToJSON sshDiscoveryResponseOptions- toEncoding = genericToEncoding sshDiscoveryResponseOptions--instance FromJSON SshDiscoveryResponse where- parseJSON = genericParseJSON sshDiscoveryResponseOptions--sshDiscoveryResponseOptions :: Options-sshDiscoveryResponseOptions = stripFieldPrefix nonNullOptions--data GitRef = GitRef- { name :: T.Text }- deriving (Generic, Show)--instance FromJSON GitRef-instance ToJSON GitRef--type SHA256 = T.Text---- | The endpoint of a git-lfs server.-data Endpoint = Endpoint Request- deriving (Show)---- | Command to run via ssh with to discover an endpoint. The FilePath is--- the location of the git repository on the ssh server.------ Note that, when sshing to the server, you should take care that the--- hostname you pass to ssh is really a hostname and not something that ssh--- will parse an an option, such as -oProxyCommand=".-sshDiscoverEndpointCommand :: FilePath -> TransferRequestOperation -> [String]-sshDiscoverEndpointCommand remotepath tro =- [ "git-lfs-authenticate"- , remotepath- , case tro of- RequestDownload -> "download"- RequestUpload -> "upload"- ]---- Internal smart constructor for an Endpoint.--- --- Since this uses the LFS batch API, it adds /objects/batch--- to the endpoint url. It also adds the necessary headers to use JSON.-mkEndpoint :: URI.URI -> Maybe Endpoint-mkEndpoint uri = do- r <- requestFromURI uri- let r' = addLfsJsonHeaders $ r { path = path r <> "/objects/batch" }- return (Endpoint r')---- | Parse the json output when doing ssh endpoint discovery.-parseSshDiscoverEndpointResponse :: L.ByteString -> Maybe Endpoint-parseSshDiscoverEndpointResponse resp = do- sr <- decode resp- uri <- URI.parseURI (T.unpack (endpoint_href sr))- endpoint <- mkEndpoint uri- return $ modifyEndpointRequest endpoint $ case endpoint_header sr of- Nothing -> id- Just headers ->- let headers' = map convheader (M.toList headers)- in \req -> req- { requestHeaders = requestHeaders req ++ headers' }- where- convheader (k, v) = (CI.mk (E.encodeUtf8 k), E.encodeUtf8 v)---- | Guesses the LFS endpoint from the http url of a git remote.------ https://github.com/git-lfs/git-lfs/blob/master/docs/api/server-discovery.md-guessEndpoint :: URI.URI -> Maybe Endpoint-guessEndpoint uri = case URI.uriScheme uri of- "https:" -> endpoint- "http:" -> endpoint- _ -> Nothing- where- endpoint = mkEndpoint $ uri- -- force https because the git-lfs protocol uses http- -- basic auth tokens, which should not be exposed- { URI.uriScheme = "https:"- , URI.uriPath = guessedpath- }- - guessedpath- | ".git" `isSuffixOf` URI.uriPath uri =- URI.uriPath uri ++ "/info/lfs"- | ".git/" `isSuffixOf` URI.uriPath uri =- URI.uriPath uri ++ "info/lfs"- | otherwise = (droptrailing '/' (URI.uriPath uri)) ++ ".git/info/lfs"- - droptrailing c = reverse . dropWhile (== c) . reverse---- | When an Endpoint is used to generate a Request, this allows adjusting--- that Request.------ This can be used to add http basic authentication to an Endpoint:------ > modifyEndpointRequest (guessEndpoint u) (applyBasicAuth "user" "pass")-modifyEndpointRequest :: Endpoint -> (Request -> Request) -> Endpoint-modifyEndpointRequest (Endpoint r) f = Endpoint (f r)---- | Makes a Request that will start the process of making a transfer to or--- from the LFS endpoint.-startTransferRequest :: Endpoint -> TransferRequest -> Request-startTransferRequest (Endpoint r) tr = r- { method = "POST"- , requestBody = RequestBodyLBS (encode tr)- }--addLfsJsonHeaders :: Request -> Request-addLfsJsonHeaders r = r- { requestHeaders = requestHeaders r ++- [ ("Accept", lfsjson)- , ("Content-Type", lfsjson)- ]- }- where- lfsjson = "application/vnd.git-lfs+json"--data ParsedTransferResponse op- = ParsedTransferResponse (TransferResponse op)- | ParsedTransferResponseError TransferResponseError- | ParseFailed String---- | Parse the body of a response to a transfer request.-parseTransferResponse- :: IsTransferResponseOperation op- => L.ByteString- -> ParsedTransferResponse op-parseTransferResponse resp = case eitherDecode resp of- Right tr -> ParsedTransferResponse tr- -- If unable to decode as a TransferResponse, try to decode- -- as a TransferResponseError instead, in case the LFS server- -- sent an error message.- Left err ->- either (const $ ParseFailed err) ParsedTransferResponseError $- eitherDecode resp---- | Builds a http request to perform a download.-downloadOperationRequest :: DownloadOperation -> Maybe Request-downloadOperationRequest = fmap fst . operationParamsRequest . download---- | Builds http request to perform an upload. The content to upload is--- provided, along with its SHA256 and size.------ When the LFS server requested verification, there will be a second--- Request that does that; it should be run only after the upload has--- succeeded.------ When the LFS server already contains the object, an empty list may be--- returned.-uploadOperationRequests :: UploadOperation -> (ServerSupportsChunks -> RequestBody) -> SHA256 -> Integer -> Maybe [Request]-uploadOperationRequests op mkcontent oid size = - case (mkdlreq, mkverifyreq) of- (Nothing, _) -> Nothing- (Just dlreq, Nothing) -> Just [dlreq]- (Just dlreq, Just verifyreq) -> Just [dlreq, verifyreq]- where- mkdlreq = mkdlreq'- <$> operationParamsRequest (upload op)- mkdlreq' (r, ssc) = r- { method = "PUT"- , requestBody = mkcontent ssc- }- mkverifyreq = mkverifyreq'- <$> (operationParamsRequest =<< verify op)- mkverifyreq' (r, _ssc) = addLfsJsonHeaders $ r- { method = "POST"- , requestBody = RequestBodyLBS $ encode $- Verification oid size- }---- | When the LFS server indicates that it supports Transfer-Encoding chunked,--- this will contain a true value, and the RequestBody provided to--- uploadOperationRequests may be created using RequestBodyStreamChunked.--- Otherwise, that should be avoided as the server may not support the--- chunked encoding.-newtype ServerSupportsChunks = ServerSupportsChunks Bool--operationParamsRequest :: OperationParams -> Maybe (Request, ServerSupportsChunks)-operationParamsRequest ps = do- r <- parseRequest (T.unpack (href ps))- let headers = map convheader $ maybe [] M.toList (header ps)- let headers' = filter allowedheader headers- let ssc = ServerSupportsChunks $- any (== ("Transfer-Encoding", "chunked")) headers- return (r { requestHeaders = headers' }, ssc)- where- convheader (k, v) = (CI.mk (E.encodeUtf8 k), E.encodeUtf8 v)- -- requestHeaders is not allowed to set Transfer-Encoding or - -- Content-Length; copying those over blindly could request in a- -- malformed request.- allowedheader (k, _) = k /= "Transfer-Encoding"- && k /= "Content-Length"--type Url = T.Text--type NumSeconds = Integer--type HTTPHeader = T.Text--type HTTPHeaderValue = T.Text---- Prevent Nothing from serializing to null.-nonNullOptions :: Options-nonNullOptions = defaultOptions { omitNothingFields = True }---- Remove prefix from field names.-stripFieldPrefix :: Options -> Options-stripFieldPrefix o =- o { fieldLabelModifier = drop 1 . dropWhile (/= '_') }
Utility/Hash.hs view
@@ -76,8 +76,8 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.IORef-import "cryptonite" Crypto.MAC.HMAC hiding (Context)-import "cryptonite" Crypto.Hash+import Crypto.MAC.HMAC hiding (Context)+import Crypto.Hash sha1 :: L.ByteString -> Digest SHA1 sha1 = hashlazy
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20230828+Version: 10.20230926 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -165,6 +165,9 @@ 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 Benchmark Description: Enable benchmarking Default: True@@ -176,10 +179,6 @@ Flag Dbus Description: Enable dbus support -Flag GitLfs- Description: Build with git-lfs library (rather than vendored copy)- Default: True- source-repository head type: git location: git://git-annex.branchable.com/@@ -258,7 +257,6 @@ stm-chans, securemem, crypto-api,- cryptonite (>= 0.23), memory, deepseq, split,@@ -273,7 +271,8 @@ aws (>= 0.20), DAV (>= 1.0), network (>= 3.0.0.0),- network-bsd+ network-bsd,+ git-lfs (>= 1.2.0) CC-Options: -Wall GHC-Options: -Wall -fno-warn-tabs -Wincomplete-uni-patterns Default-Language: Haskell2010@@ -297,6 +296,12 @@ 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 (os(windows)) Build-Depends: Win32 ((>= 2.6.1.0 && < 2.12.0.0) || >= 2.13.4.0),@@ -306,12 +311,6 @@ else Build-Depends: unix (>= 2.7.2) - if flag(GitLfs)- Build-Depends: git-lfs (>= 1.2.0)- CPP-Options: -DWITH_GIT_LFS- else- Other-Modules: Utility.GitLFS- if flag(Assistant) && ! os(solaris) && ! os(gnu) CPP-Options: -DWITH_ASSISTANT -DWITH_WEBAPP Build-Depends:
stack-lts-18.13.yaml view
@@ -8,7 +8,7 @@ dbus: false debuglocks: false benchmark: true- gitlfs: true+ crypton: false packages: - '.' resolver: lts-18.13
stack.yaml view
@@ -8,7 +8,7 @@ dbus: false debuglocks: false benchmark: true- gitlfs: true+ crypton: false packages: - '.' resolver: nightly-2023-08-01