cd076cd085
That is a legal url, but parseUrl parses it to "/c:/path" which is not a valid path on Windows. So as a workaround, use parseURIPortable everywhere, which removes the leading slash when run on windows. Note that if an url is parsed like this and then serialized back to a string, it will be different from the input. Which could potentially be a problem, but is probably not in practice. An alternative way to do it would be to have an uriPathPortable that fixes up the path after parsing. But it would be harder to make sure that is used everywhere, since uriPath is also used when constructing an URI. It's also worth noting that System.FilePath.normalize "/c:/path" yields "c:/path". The reason I didn't use it is that it also may change "/" to "\" in the path and I wanted to keep the url changes minimal. Also noticed that convertToWindowsNativeNamespace handles "/c:/path" the same as "c:/path". Sponsored-By: the NIH-funded NICEMAN (ReproNim TR&D3) project
125 lines
4.1 KiB
Haskell
125 lines
4.1 KiB
Haskell
{- git credential interface
|
|
-
|
|
- Copyright 2019-2022 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Git.Credential where
|
|
|
|
import Common
|
|
import Git
|
|
import Git.Types
|
|
import Git.Command
|
|
import qualified Git.Config as Config
|
|
import Utility.Url
|
|
|
|
import qualified Data.Map as M
|
|
import Network.URI
|
|
import Control.Concurrent.STM
|
|
|
|
data Credential = Credential { fromCredential :: M.Map String String }
|
|
|
|
credentialUsername :: Credential -> Maybe String
|
|
credentialUsername = M.lookup "username" . fromCredential
|
|
|
|
credentialPassword :: Credential -> Maybe String
|
|
credentialPassword = M.lookup "password" . fromCredential
|
|
|
|
credentialBasicAuth :: Credential -> Maybe BasicAuth
|
|
credentialBasicAuth cred = BasicAuth
|
|
<$> credentialUsername cred
|
|
<*> credentialPassword cred
|
|
|
|
getBasicAuthFromCredential :: Repo -> TMVar CredentialCache -> GetBasicAuth
|
|
getBasicAuthFromCredential r ccv u = do
|
|
(CredentialCache cc) <- atomically $ readTMVar ccv
|
|
case mkCredentialBaseURL r u of
|
|
Just bu -> case M.lookup bu cc of
|
|
Just c -> go (const noop) c
|
|
Nothing -> do
|
|
let storeincache = \c -> atomically $ do
|
|
(CredentialCache cc') <- takeTMVar ccv
|
|
putTMVar ccv (CredentialCache (M.insert bu c cc'))
|
|
go storeincache =<< getUrlCredential u r
|
|
Nothing -> go (const noop) =<< getUrlCredential u r
|
|
where
|
|
go storeincache c =
|
|
case credentialBasicAuth c of
|
|
Just ba -> return $ Just (ba, signalsuccess)
|
|
Nothing -> do
|
|
signalsuccess False
|
|
return Nothing
|
|
where
|
|
signalsuccess True = do
|
|
() <- storeincache c
|
|
approveUrlCredential c r
|
|
signalsuccess False = rejectUrlCredential c r
|
|
|
|
-- | This may prompt the user for the credential, or get a cached
|
|
-- credential from git.
|
|
getUrlCredential :: URLString -> Repo -> IO Credential
|
|
getUrlCredential = runCredential "fill" . urlCredential
|
|
|
|
-- | Call if the credential the user entered works, and can be cached for
|
|
-- later use if git is configured to do so.
|
|
approveUrlCredential :: Credential -> Repo -> IO ()
|
|
approveUrlCredential c = void . runCredential "approve" c
|
|
|
|
-- | Call if the credential the user entered does not work.
|
|
rejectUrlCredential :: Credential -> Repo -> IO ()
|
|
rejectUrlCredential c = void . runCredential "reject" c
|
|
|
|
urlCredential :: URLString -> Credential
|
|
urlCredential = Credential . M.singleton "url"
|
|
|
|
runCredential :: String -> Credential -> Repo -> IO Credential
|
|
runCredential action input r =
|
|
parseCredential . decodeBS <$> pipeWriteRead
|
|
[ Param "credential"
|
|
, Param action
|
|
]
|
|
(Just (flip hPutStr formatinput))
|
|
r
|
|
where
|
|
formatinput = concat
|
|
[ formatCredential input
|
|
, "\n" -- blank line signifies end of input
|
|
]
|
|
|
|
formatCredential :: Credential -> String
|
|
formatCredential = unlines . map (\(k, v) -> k ++"=" ++ v) . M.toList . fromCredential
|
|
|
|
parseCredential :: String -> Credential
|
|
parseCredential = Credential . M.fromList . map go . lines
|
|
where
|
|
go l = case break (== '=') l of
|
|
(k, _:v) -> (k, v)
|
|
(k, []) -> (k, "")
|
|
|
|
-- This is not the cache used by git, but is an in-process cache,
|
|
-- allowing a process to avoid prompting repeatedly when accessing related
|
|
-- urls even when git is not configured to cache credentials.
|
|
data CredentialCache = CredentialCache (M.Map CredentialBaseURL Credential)
|
|
|
|
-- An url with the uriPath empty when credential.useHttpPath is false.
|
|
--
|
|
-- When credential.useHttpPath is true, no caching is done, since each
|
|
-- distinct url would need a different credential to be cached, which
|
|
-- could cause the CredentialCache to use a lot of memory. Presumably,
|
|
-- when credential.useHttpPath is false, one Credential is cached
|
|
-- for each git repo accessed, and there are a reasonably small number of
|
|
-- those, so the cache will not grow too large.
|
|
data CredentialBaseURL = CredentialBaseURL URI
|
|
deriving (Show, Eq, Ord)
|
|
|
|
mkCredentialBaseURL :: Repo -> URLString -> Maybe CredentialBaseURL
|
|
mkCredentialBaseURL r s = do
|
|
u <- parseURIPortable s
|
|
let usehttppath = fromMaybe False $ Config.isTrueFalse' $
|
|
Config.get (ConfigKey "credential.useHttpPath") (ConfigValue "") r
|
|
if usehttppath
|
|
then Nothing
|
|
else Just $ CredentialBaseURL $ u { uriPath = "" }
|