git-annex/Git/Credential.hs

{- 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 <- parseURI s
	let usehttppath = fromMaybe False $ Config.isTrueFalse' $
		Config.get (ConfigKey "credential.useHttpPath") (ConfigValue "") r
	if usehttppath
		then Nothing
		else Just $ CredentialBaseURL $ u { uriPath = "" }