basic gitlab support in webapp

This works, but needs more testing and work on cases like encrypted repos,
enabling existing repositories, etc.

This commit was sponsored by Shaun Westmacott.
This commit is contained in:
Joey Hess 2015-07-20 18:38:23 -04:00
parent 2938b5e3c1
commit 343ab2e358
6 changed files with 212 additions and 34 deletions

View file

@ -34,7 +34,7 @@ setupAuthorizedKeys msg repodir = case validateSshPubKey $ remoteSshPubKey $ pai
- the host we paired with. -} - the host we paired with. -}
finishedLocalPairing :: PairMsg -> SshKeyPair -> Assistant () finishedLocalPairing :: PairMsg -> SshKeyPair -> Assistant ()
finishedLocalPairing msg keypair = do finishedLocalPairing msg keypair = do
sshdata <- liftIO $ setupSshKeyPair keypair =<< pairMsgToSshData msg sshdata <- liftIO $ installSshKeyPair keypair =<< pairMsgToSshData msg
{- Ensure that we know the ssh host key for the host we paired with. {- Ensure that we know the ssh host key for the host we paired with.
- If we don't, ssh over to get it. -} - If we don't, ssh over to get it. -}
liftIO $ unlessM (knownHost $ sshHostName sshdata) $ liftIO $ unlessM (knownHost $ sshHostName sshdata) $
@ -69,6 +69,7 @@ pairMsgToSshData msg = do
, sshPort = 22 , sshPort = 22
, needsPubKey = True , needsPubKey = True
, sshCapabilities = [GitAnnexShellCapable, GitCapable, RsyncCapable] , sshCapabilities = [GitAnnexShellCapable, GitCapable, RsyncCapable]
, sshRepoUrl = Nothing
} }
{- Finds the best hostname to use for the host that sent the PairMsg. {- Finds the best hostname to use for the host that sent the PairMsg.

View file

@ -28,28 +28,37 @@ data SshData = SshData
, sshPort :: Int , sshPort :: Int
, needsPubKey :: Bool , needsPubKey :: Bool
, sshCapabilities :: [SshServerCapability] , sshCapabilities :: [SshServerCapability]
, sshRepoUrl :: Maybe String
} }
deriving (Read, Show, Eq) deriving (Read, Show, Eq)
data SshServerCapability = GitAnnexShellCapable | GitCapable | RsyncCapable data SshServerCapability
= GitAnnexShellCapable -- server has git-annex-shell installed
| GitCapable -- server has git installed
| RsyncCapable -- server supports raw rsync access (not only via git-annex-shell)
| PushCapable -- repo on server is set up already, and ready to accept pushes
deriving (Read, Show, Eq) deriving (Read, Show, Eq)
hasCapability :: SshData -> SshServerCapability -> Bool hasCapability :: SshData -> SshServerCapability -> Bool
hasCapability d c = c `elem` sshCapabilities d hasCapability d c = c `elem` sshCapabilities d
addCapability :: SshData -> SshServerCapability -> SshData
addCapability d c = d { sshCapabilities = c : sshCapabilities d }
onlyCapability :: SshData -> SshServerCapability -> Bool onlyCapability :: SshData -> SshServerCapability -> Bool
onlyCapability d c = all (== c) (sshCapabilities d) onlyCapability d c = all (== c) (sshCapabilities d)
type SshPubKey = String
type SshPrivKey = String
data SshKeyPair = SshKeyPair data SshKeyPair = SshKeyPair
{ sshPubKey :: String { sshPubKey :: SshPubKey
, sshPrivKey :: String , sshPrivKey :: SshPrivKey
} }
instance Show SshKeyPair where instance Show SshKeyPair where
show = sshPubKey show = sshPubKey
type SshPubKey = String
{- ssh -ofoo=bar command-line option -} {- ssh -ofoo=bar command-line option -}
sshOpt :: String -> String -> String sshOpt :: String -> String -> String
sshOpt k v = concat ["-o", k, "=", v] sshOpt k v = concat ["-o", k, "=", v]
@ -60,10 +69,12 @@ genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host
{- Generates a ssh or rsync url from a SshData. -} {- Generates a ssh or rsync url from a SshData. -}
genSshUrl :: SshData -> String genSshUrl :: SshData -> String
genSshUrl sshdata = addtrailingslash $ T.unpack $ T.concat $ genSshUrl sshdata = case sshRepoUrl sshdata of
if (onlyCapability sshdata RsyncCapable) Just repourl -> repourl
then [u, h, T.pack ":", sshDirectory sshdata] Nothing -> addtrailingslash $ T.unpack $ T.concat $
else [T.pack "ssh://", u, h, d] if (onlyCapability sshdata RsyncCapable)
then [u, h, T.pack ":", sshDirectory sshdata]
else [T.pack "ssh://", u, h, d]
where where
u = maybe (T.pack "") (\v -> T.concat [v, T.pack "@"]) $ sshUserName sshdata u = maybe (T.pack "") (\v -> T.concat [v, T.pack "@"]) $ sshUserName sshdata
h = sshHostName sshdata h = sshHostName sshdata
@ -90,6 +101,7 @@ parseSshUrl u
, sshPort = 22 , sshPort = 22
, needsPubKey = True , needsPubKey = True
, sshCapabilities = [] , sshCapabilities = []
, sshRepoUrl = Nothing
} }
where where
(user, host) = if '@' `elem` userhost (user, host) = if '@' `elem` userhost
@ -222,24 +234,44 @@ genSshKeyPair = withTmpDir "git-annex-keygen" $ \dir -> do
- when git-annex and git try to access the remote, if its - when git-annex and git try to access the remote, if its
- host key has changed. - host key has changed.
-} -}
setupSshKeyPair :: SshKeyPair -> SshData -> IO SshData installSshKeyPair :: SshKeyPair -> SshData -> IO SshData
setupSshKeyPair sshkeypair sshdata = do installSshKeyPair sshkeypair sshdata = do
sshdir <- sshDir sshdir <- sshDir
createDirectoryIfMissing True $ parentDir $ sshdir </> sshprivkeyfile createDirectoryIfMissing True $ parentDir $ sshdir </> sshPrivKeyFile sshdata
unlessM (doesFileExist $ sshdir </> sshprivkeyfile) $ unlessM (doesFileExist $ sshdir </> sshPrivKeyFile sshdata) $
writeFileProtected (sshdir </> sshprivkeyfile) (sshPrivKey sshkeypair) writeFileProtected (sshdir </> sshPrivKeyFile sshdata) (sshPrivKey sshkeypair)
unlessM (doesFileExist $ sshdir </> sshpubkeyfile) $ unlessM (doesFileExist $ sshdir </> sshPubKeyFile sshdata) $
writeFile (sshdir </> sshpubkeyfile) (sshPubKey sshkeypair) writeFile (sshdir </> sshPubKeyFile sshdata) (sshPubKey sshkeypair)
setSshConfig sshdata setSshConfig sshdata
[ ("IdentityFile", "~/.ssh/" ++ sshprivkeyfile) [ ("IdentityFile", "~/.ssh/" ++ sshPrivKeyFile sshdata)
, ("IdentitiesOnly", "yes") , ("IdentitiesOnly", "yes")
, ("StrictHostKeyChecking", "yes") , ("StrictHostKeyChecking", "yes")
] ]
where
sshprivkeyfile = "git-annex" </> "key." ++ mangleSshHostName sshdata sshPrivKeyFile :: SshData -> FilePath
sshpubkeyfile = sshprivkeyfile ++ ".pub" sshPrivKeyFile sshdata = "git-annex" </> "key." ++ mangleSshHostName sshdata
sshPubKeyFile :: SshData -> FilePath
sshPubKeyFile sshdata = sshPrivKeyFile sshdata ++ ".pub"
{- Generates an installs a new ssh key pair if one is not already
- installed. Returns the modified SshData that will use the key pair,
- and the key pair. -}
setupSshKeyPair :: SshData -> IO (SshData, SshKeyPair)
setupSshKeyPair sshdata = do
sshdir <- sshDir
mprivkey <- catchMaybeIO $ readFile (sshdir </> sshPrivKeyFile sshdata)
mpubkey <- catchMaybeIO $ readFile (sshdir </> sshPubKeyFile sshdata)
keypair <- case (mprivkey, mpubkey) of
(Just privkey, Just pubkey) -> return $ SshKeyPair
{ sshPubKey = pubkey
, sshPrivKey = privkey
}
_ -> genSshKeyPair
sshdata' <- installSshKeyPair keypair sshdata
return (sshdata', keypair)
{- Fixes git-annex ssh key pairs configured in .ssh/config {- Fixes git-annex ssh key pairs configured in .ssh/config
- by old versions to set IdentitiesOnly. - by old versions to set IdentitiesOnly.

View file

@ -1,6 +1,6 @@
{- git-annex assistant webapp configurator for ssh-based remotes {- git-annex assistant webapp configurator for ssh-based remotes
- -
- Copyright 2012-2014 Joey Hess <id@joeyh.name> - Copyright 2012-2015 Joey Hess <id@joeyh.name>
- -
- Licensed under the GNU AGPL version 3 or higher. - Licensed under the GNU AGPL version 3 or higher.
-} -}
@ -21,8 +21,13 @@ import Types.StandardGroups
import Utility.UserInfo import Utility.UserInfo
import Utility.Gpg import Utility.Gpg
import Types.Remote (RemoteConfig) import Types.Remote (RemoteConfig)
import Git.Types (RemoteName) import Git.Types (RemoteName, fromRef)
import qualified Remote.GCrypt as GCrypt import qualified Remote.GCrypt as GCrypt
import qualified Git.Construct
import qualified Git.Config
import qualified Git.Command
import qualified Remote.Helper.Ssh
import qualified Annex.Branch
import Annex.UUID import Annex.UUID
import Logs.UUID import Logs.UUID
import Assistant.RemoteControl import Assistant.RemoteControl
@ -74,6 +79,7 @@ mkSshData s = SshData
, sshPort = inputPort s , sshPort = inputPort s
, needsPubKey = False , needsPubKey = False
, sshCapabilities = [] -- untested , sshCapabilities = [] -- untested
, sshRepoUrl = Nothing
} }
mkSshInput :: SshData -> SshInput mkSshInput :: SshData -> SshInput
@ -137,6 +143,7 @@ sshInputAForm hostnamefield d = normalize <$> gen
data ServerStatus data ServerStatus
= UntestedServer = UntestedServer
| UnusableServer Text -- reason why it's not usable | UnusableServer Text -- reason why it's not usable
| ServerNeedsPubKey SshPubKey
| UsableServer [SshServerCapability] | UsableServer [SshServerCapability]
deriving (Eq) deriving (Eq)
@ -486,8 +493,7 @@ combineExistingGCrypt sshdata u = do
prepSsh :: Bool -> SshData -> (SshData -> Handler Html) -> Handler Html prepSsh :: Bool -> SshData -> (SshData -> Handler Html) -> Handler Html
prepSsh needsinit sshdata a prepSsh needsinit sshdata a
| needsPubKey sshdata = do | needsPubKey sshdata = do
keypair <- liftIO genSshKeyPair (sshdata', keypair) <- liftIO $ setupSshKeyPair sshdata
sshdata' <- liftIO $ setupSshKeyPair keypair sshdata
prepSsh' needsinit sshdata sshdata' (Just keypair) a prepSsh' needsinit sshdata sshdata' (Just keypair) a
| sshPort sshdata /= 22 = do | sshPort sshdata /= 22 = do
sshdata' <- liftIO $ setSshConfig sshdata [] sshdata' <- liftIO $ setSshConfig sshdata []
@ -495,11 +501,13 @@ prepSsh needsinit sshdata a
| otherwise = prepSsh' needsinit sshdata sshdata Nothing a | otherwise = prepSsh' needsinit sshdata sshdata Nothing a
prepSsh' :: Bool -> SshData -> SshData -> Maybe SshKeyPair -> (SshData -> Handler Html) -> Handler Html prepSsh' :: Bool -> SshData -> SshData -> Maybe SshKeyPair -> (SshData -> Handler Html) -> Handler Html
prepSsh' needsinit origsshdata sshdata keypair a = sshSetup (mkSshInput origsshdata) prepSsh' needsinit origsshdata sshdata keypair a
[ "-p", show (sshPort origsshdata) | hasCapability sshdata PushCapable = a sshdata
, genSshHost (sshHostName origsshdata) (sshUserName origsshdata) | otherwise = sshSetup (mkSshInput origsshdata)
, remoteCommand [ "-p", show (sshPort origsshdata)
] Nothing (a sshdata) , genSshHost (sshHostName origsshdata) (sshUserName origsshdata)
, remoteCommand
] Nothing (a sshdata)
where where
remotedir = T.unpack $ sshDirectory sshdata remotedir = T.unpack $ sshDirectory sshdata
remoteCommand = shellWrap $ intercalate "&&" $ catMaybes remoteCommand = shellWrap $ intercalate "&&" $ catMaybes
@ -628,8 +636,7 @@ enableRsyncNetGCrypt sshinput reponame =
prepRsyncNet :: SshInput -> String -> (SshData -> Handler Html) -> Handler Html prepRsyncNet :: SshInput -> String -> (SshData -> Handler Html) -> Handler Html
prepRsyncNet sshinput reponame a = do prepRsyncNet sshinput reponame a = do
knownhost <- liftIO $ maybe (return False) knownHost (inputHostname sshinput) knownhost <- liftIO $ maybe (return False) knownHost (inputHostname sshinput)
keypair <- liftIO genSshKeyPair (sshdata, keypair) <- liftIO $ setupSshKeyPair $
sshdata <- liftIO $ setupSshKeyPair keypair $
(mkSshData sshinput) (mkSshData sshinput)
{ sshRepoName = reponame { sshRepoName = reponame
, needsPubKey = True , needsPubKey = True
@ -654,3 +661,86 @@ prepRsyncNet sshinput reponame a = do
isRsyncNet :: Maybe Text -> Bool isRsyncNet :: Maybe Text -> Bool
isRsyncNet Nothing = False isRsyncNet Nothing = False
isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host
data GitLabUrl = GitLabUrl Text
badGitLabUrl :: Text
badGitLabUrl = "Bad SSH clone url. Expected something like: git@gitlab.com:yourlogin/annex.git"
parseGitLabUrl :: GitLabUrl -> Maybe SshData
parseGitLabUrl (GitLabUrl t) =
let (u, r) = separate (== '@') (T.unpack t)
(h, p) = separate (== ':') r
in if null u || null h || null p
then Nothing
else Just $ SshData
{ sshHostName = T.pack h
, sshUserName = Just (T.pack u)
, sshDirectory = T.pack p
, sshRepoName = genSshRepoName h p
, sshPort = 22
, needsPubKey = False
, sshCapabilities =
[ GitAnnexShellCapable
, GitCapable
, PushCapable
]
, sshRepoUrl = Just (T.unpack t)
}
{- Try to ssh into the gitlab server, verify we can access the repository,
- and get the uuid of the repository, if it already has one.
-
- A repository on gitlab won't be initialized as a git-annex repo
- unless a git-annex branch was already pushed to it. So, if
- git-annex-shell fails to work that's probably why; verify if
- the server is letting us ssh in by running git send-pack
- (in dry run mode). -}
testGitLabUrl :: GitLabUrl -> Annex (ServerStatus, Maybe SshData, UUID)
testGitLabUrl glu = case parseGitLabUrl glu of
Nothing -> return (UnusableServer badGitLabUrl, Nothing, NoUUID)
Just sshdata -> do
u <- probeuuid sshdata
if u /= NoUUID
then return (UsableServer (sshCapabilities sshdata), Just sshdata, u)
else ifM (verifysshworks sshdata)
( return (UsableServer (sshCapabilities sshdata), Just sshdata, NoUUID)
, do
(sshdata', keypair) <- liftIO $ setupSshKeyPair sshdata
return (ServerNeedsPubKey (sshPubKey keypair), Just sshdata', NoUUID)
)
where
probeuuid sshdata = do
r <- inRepo $ Git.Construct.fromRemoteLocation (fromJust $ sshRepoUrl sshdata)
getUncachedUUID . either (const r) fst <$>
Remote.Helper.Ssh.onRemote r (Git.Config.fromPipe r, return (Left $ error "configlist failed")) "configlist" [] []
verifysshworks sshdata = inRepo $ Git.Command.runBool
[ Param "send-pack"
, Param (fromJust $ sshRepoUrl sshdata)
, Param "--dry-run"
, Param "--force"
, Param (fromRef Annex.Branch.name)
]
gitLabUrlAForm :: AForm Handler GitLabUrl
gitLabUrlAForm = GitLabUrl <$> areq check_input (bfs "SSH clone url") Nothing
where
check_input = checkBool (isJust . parseGitLabUrl . GitLabUrl)
badGitLabUrl textField
getAddGitLabR :: Handler Html
getAddGitLabR = postAddGitLabR
postAddGitLabR :: Handler Html
postAddGitLabR = sshConfigurator $ do
((result, form), enctype) <- liftH $
runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout gitLabUrlAForm
case result of
FormSuccess gitlaburl -> do
(status, msshdata, u) <- liftAnnex $ testGitLabUrl gitlaburl
case (status, msshdata) of
(UsableServer _, Just sshdata) ->
liftH $ redirect $ ConfirmSshR sshdata u
_ -> showform form enctype status
_ -> showform form enctype UntestedServer
where
showform form enctype status = $(widgetFile "configurators/gitlab.com/add")

View file

@ -61,6 +61,7 @@
/config/repository/add/cloud/IA AddIAR GET POST /config/repository/add/cloud/IA AddIAR GET POST
/config/repository/add/cloud/glacier AddGlacierR GET POST /config/repository/add/cloud/glacier AddGlacierR GET POST
/config/repository/add/cloud/box.com AddBoxComR GET POST /config/repository/add/cloud/box.com AddBoxComR GET POST
/config/repository/add/cloud/gitlab.com AddGitLabR GET POST
/config/repository/pair/local/start StartLocalPairR GET POST /config/repository/pair/local/start StartLocalPairR GET POST
/config/repository/pair/local/running/#SecretReminder RunningLocalPairR GET /config/repository/pair/local/running/#SecretReminder RunningLocalPairR GET

View file

@ -1,16 +1,23 @@
<h3>
<a href="@{AddGitLabR}">
<span .glyphicon .glyphicon-plus-sign>
\ Gitlab.com
<p>
Hosts git-annex repositories for free.
<h3> <h3>
<a href="@{AddBoxComR}"> <a href="@{AddBoxComR}">
<span .glyphicon .glyphicon-plus-sign> <span .glyphicon .glyphicon-plus-sign>
\ Box.com \ Box.com
<p> <p>
Provides free cloud storage for small amounts of data. Provides free storage for small amounts of data.
<h3> <h3>
<a href="@{AddRsyncNetR}"> <a href="@{AddRsyncNetR}">
<span .glyphicon .glyphicon-plus-sign> <span .glyphicon .glyphicon-plus-sign>
\ Rsync.net \ Rsync.net
<p> <p>
Works very well with git-annex. Works very well with git-annex for data storage.
<br> <br>
Offers a discounted rate for git-annex users. Offers a discounted rate for git-annex users.

View file

@ -0,0 +1,47 @@
<div .col-sm-9>
<div .content-box>
<h2>
Adding a GitLab.com repository
<p>
<a href="http://gitlab.com/">
GitLab.com #
provides free public and private git repositories, and supports #
git-annex.
<p>
$case status
$of UnusableServer msg
<div .alert .alert-danger>
<span .glyphicon .glyphicon-warning-sign>
\ #{msg}
$of ServerNeedsPubKey pubkey
<div .alert>
<span .glyphicon .glyphicon-warning-sign>
\ You need to configure GitLab to accept a SSH public key.
<p>
Open a tab to #
<a href="https://gitlab.com/profile/keys/new">
https://gitlab.com/profile/keys/new
and copy and paste this public key into it:
<pre>
#{pubkey}
<p>
Once you have added the key to GitLab, come back to this page #
to finish setting up the repository.
$of _
<p>
You can sign up for an account on #
<a href="http://gitlab.com/">
GitLab.com #
and create a git repository that you want to use with git-annex, #
or find an existing git-annex repository to share with.
<p>
Copy the GitLab repository's SSH clone url into the form below.
<form method="post" .form-horizontal enctype=#{enctype}>
<fieldset>
^{form}
^{webAppFormAuthToken}
<div .form-group>
<div .col-sm-10 .col-sm-offset-2>
<button .btn .btn-primary type=submit onclick="$('#setupmodal').modal('show');">
Use this gitlab.com repository
^{sshTestModal}