279991604d
This should make code that reads shas and refs from git faster. Does not compile yet, a lot needs to be done still.
81 lines
2.3 KiB
Haskell
81 lines
2.3 KiB
Haskell
{- git credential interface
|
|
-
|
|
- Copyright 2019-2020 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Git.Credential where
|
|
|
|
import Common
|
|
import Git
|
|
import Git.Command
|
|
import Utility.Url
|
|
|
|
import qualified Data.Map as M
|
|
|
|
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 -> GetBasicAuth
|
|
getBasicAuthFromCredential r u = do
|
|
c <- getUrlCredential u r
|
|
case credentialBasicAuth c of
|
|
Just ba -> return $ Just (ba, signalsuccess c)
|
|
Nothing -> do
|
|
signalsuccess c False
|
|
return Nothing
|
|
where
|
|
signalsuccess c True = approveUrlCredential c r
|
|
signalsuccess c False = rejectUrlCredential c r
|
|
|
|
-- | This may prompt the user for login information, or get cached login
|
|
-- information.
|
|
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, "")
|