diff --git a/Build/Version.hs b/Build/Version.hs --- a/Build/Version.hs +++ b/Build/Version.hs @@ -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 diff --git a/BuildFlags.hs b/BuildFlags.hs --- a/BuildFlags.hs +++ b/BuildFlags.hs @@ -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 diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 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. diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -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 +Files: Utility/Matcher.hs Utility/Tor.hs Utility/Yesod.hs +Copyright: © 2010-2023 Joey Hess License: AGPL-3+ Files: Utility/* diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs --- a/CmdLine/GitAnnexShell.hs +++ b/CmdLine/GitAnnexShell.hs @@ -1,6 +1,6 @@ {- git-annex-shell main program - - - Copyright 2010-2021 Joey Hess + - Copyright 2010-2023 Joey Hess - - 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" diff --git a/Command/DiffDriver.hs b/Command/DiffDriver.hs --- a/Command/DiffDriver.hs +++ b/Command/DiffDriver.hs @@ -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 diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -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 diff --git a/Command/LookupKey.hs b/Command/LookupKey.hs --- a/Command/LookupKey.hs +++ b/Command/LookupKey.hs @@ -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. diff --git a/Command/PostReceive.hs b/Command/PostReceive.hs --- a/Command/PostReceive.hs +++ b/Command/PostReceive.hs @@ -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 diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -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 diff --git a/Database/Handle.hs b/Database/Handle.hs --- a/Database/Handle.hs +++ b/Database/Handle.hs @@ -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, diff --git a/Git/Config.hs b/Git/Config.hs --- a/Git/Config.hs +++ b/Git/Config.hs @@ -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 diff --git a/Git/Construct.hs b/Git/Construct.hs --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -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 } diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -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." diff --git a/Git/Types.hs b/Git/Types.hs --- a/Git/Types.hs +++ b/Git/Types.hs @@ -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 diff --git a/Remote/Adb.hs b/Remote/Adb.hs --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -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" diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -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 diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -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 diff --git a/Utility/GitLFS.hs b/Utility/GitLFS.hs deleted file mode 100644 --- a/Utility/GitLFS.hs +++ /dev/null @@ -1,476 +0,0 @@ -{- git-lfs API - - - - https://github.com/git-lfs/git-lfs/blob/master/docs/api - - - - Copyright 2019 Joey Hess - - - - 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 (/= '_') } diff --git a/Utility/Hash.hs b/Utility/Hash.hs --- a/Utility/Hash.hs +++ b/Utility/Hash.hs @@ -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 diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 10.20230828 +Version: 10.20230926 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess @@ -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: diff --git a/stack-lts-18.13.yaml b/stack-lts-18.13.yaml --- a/stack-lts-18.13.yaml +++ b/stack-lts-18.13.yaml @@ -8,7 +8,7 @@ dbus: false debuglocks: false benchmark: true - gitlfs: true + crypton: false packages: - '.' resolver: lts-18.13 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -8,7 +8,7 @@ dbus: false debuglocks: false benchmark: true - gitlfs: true + crypton: false packages: - '.' resolver: nightly-2023-08-01