mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

move IO code out

Browse source 
Let's keep this entirely pure.

git-annex has its own facilities for running a ssh command, that make it
respect various config settings, and cache connections, etc. So better
not to have the library run ssh itself.
This commit is contained in:
Joey Hess 2019-08-02 10:57:40 -04:00
parent 2533acc7a2
commit 03a765909c
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
1 changed files with 19 additions and 26 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

45
Utility/GitLFS.hs
View file

@ -32,7 +32,8 @@ module Utility.GitLFS (
Endpoint, Endpoint,
guessEndpoint, guessEndpoint,
HostUser, HostUser,
sshDiscoverEndpoint, sshDiscoverEndpointCommand,
parseSshDiscoverEndpointResponse,
-- * errors -- * errors
TransferResponseError(..), TransferResponseError(..),
TransferResponseObjectError(..), TransferResponseObjectError(..),
@ -59,9 +60,6 @@ import Data.Aeson
import Data.Aeson.Types import Data.Aeson.Types
import GHC.Generics import GHC.Generics
import Network.HTTP.Client import Network.HTTP.Client
import System.Process
import Control.Exception
import Data.String
import Data.List import Data.List
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Text as T import qualified Data.Text as T
@ -283,29 +281,24 @@ data Endpoint
| EndpointDiscovered SshDiscoveryResponse | EndpointDiscovered SshDiscoveryResponse
deriving (Show) deriving (Show)
-- | Discovers an LFS endpoint for a git remote using ssh. -- | Command to run via ssh with to discover an endpoint. The FilePath is
-- the location of the git repository on the ssh server.
-- --
-- May generate console output, including error messages from ssh or the -- Note that, when sshing to the server, you should take care that the
-- remote server, and ssh password prompting. -- hostname you pass to ssh is really a hostname and not something that ssh
-- -- will parse an an option, such as -oProxyCommand=".
-- Note that this does not sanitize the hostname. It is the responsibility sshDiscoverEndpointCommand :: FilePath -> TransferRequestOperation -> [String]
-- of the caller to avoid calling this with a value that ssh will sshDiscoverEndpointCommand remotepath tro =
-- interpert as an option, such as "-oProxyCommand=" [ "git-lfs-authenticate"
sshDiscoverEndpoint :: HostUser -> FilePath -> TransferRequestOperation -> IO (Maybe Endpoint) , remotepath
sshDiscoverEndpoint hostuser remotepath tro = , case tro of
(try (readProcess "ssh" ps "") :: IO (Either IOError String)) >>= \case RequestDownload -> "download"
Left _err -> return Nothing RequestUpload -> "upload"
Right resp -> return $ ]
EndpointDiscovered <$> decode (fromString resp)
where -- | Parse the json output when doing ssh endpoint discovery.
ps = parseSshDiscoverEndpointResponse :: L.ByteString -> Maybe Endpoint
[ hostuser parseSshDiscoverEndpointResponse resp = EndpointDiscovered <$> decode resp
, "git-lfs-authenticate"
, remotepath
, case tro of
RequestDownload -> "download"
RequestUpload -> "upload"
]
-- | Guesses the LFS endpoint from the http url of a git remote. -- | Guesses the LFS endpoint from the http url of a git remote.
-- --