From 50300a47fe92cd19dbdce5d7cf54aad0b3de6135 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 26 Dec 2022 12:42:45 -0400 Subject: [PATCH] Removed the vendored git-lfs and the GitLfs build flag AFAICS all git-annex builds are using the git-lfs library not the vendored copy. Debian stable now includes a new enough haskell-git-lfs package as well. Last time this was tried it did not. --- CHANGELOG | 6 + COPYRIGHT | 4 +- Remote/GitLFS.hs | 6 - Utility/GitLFS.hs | 476 ------------------------ debian/control | 1 + git-annex.cabal | 13 +- stack-lts-18.13.yaml | 1 - stack.yaml | 1 - standalone/linux/stack-i386ancient.yaml | 1 - 9 files changed, 11 insertions(+), 498 deletions(-) delete mode 100644 Utility/GitLFS.hs diff --git a/CHANGELOG b/CHANGELOG index 231b98000c..04b4583bdd 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,9 @@ +git-annex (10.20230829) UNRELEASED; urgency=medium + + * Removed the vendored git-lfs and the GitLfs build flag. + + -- Joey Hess Mon, 28 Aug 2023 13:10:17 -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 index ac6f0a6f54..d8920f3fd3 100644 --- a/COPYRIGHT +++ b/COPYRIGHT @@ -43,8 +43,8 @@ Copyright: 2019 Joey Hess 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/Remote/GitLFS.hs b/Remote/GitLFS.hs index 31ddc6ccef..33cbb0338e 100644 --- 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.Remote 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 index 3df8ec953b..0000000000 --- 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/debian/control b/debian/control index fbccb4861e..0cfe536bf7 100644 --- a/debian/control +++ b/debian/control @@ -82,6 +82,7 @@ Build-Depends: libghc-vector-dev, libghc-unliftio-core-dev, libghc-filepath-bytestring-dev, + libghc-git-lfs-dev (>= 1.2.0), libghc-criterion-dev, lsof [linux-any], ikiwiki, diff --git a/git-annex.cabal b/git-annex.cabal index 8101dcd7ad..b4f08a1640 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -176,10 +176,6 @@ Flag DebugLocks 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/ @@ -273,7 +269,8 @@ Executable git-annex 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 @@ -306,12 +303,6 @@ Executable git-annex 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 index 7dbfb657ac..9ad08015da 100644 --- a/stack-lts-18.13.yaml +++ b/stack-lts-18.13.yaml @@ -8,7 +8,6 @@ flags: dbus: false debuglocks: false benchmark: true - gitlfs: true packages: - '.' resolver: lts-18.13 diff --git a/stack.yaml b/stack.yaml index de88546345..dd9f9defe2 100644 --- a/stack.yaml +++ b/stack.yaml @@ -8,7 +8,6 @@ flags: dbus: false debuglocks: false benchmark: true - gitlfs: true packages: - '.' resolver: nightly-2023-08-01 diff --git a/standalone/linux/stack-i386ancient.yaml b/standalone/linux/stack-i386ancient.yaml index 6b3e79cc31..06ec341c5c 100644 --- a/standalone/linux/stack-i386ancient.yaml +++ b/standalone/linux/stack-i386ancient.yaml @@ -8,7 +8,6 @@ flags: dbus: false debuglocks: false benchmark: false - gitlfs: true packages: - '.' extra-deps: -- 2.30.2