diff options
Diffstat (limited to 'Assistant/WebApp/Configurators/Ssh.hs')
| -rw-r--r-- | Assistant/WebApp/Configurators/Ssh.hs | 339 |
1 files changed, 0 insertions, 339 deletions
diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs deleted file mode 100644 index 7fba8ff52..000000000 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ /dev/null @@ -1,339 +0,0 @@ -{- git-annex assistant webapp configurator for ssh-based remotes - - - - Copyright 2012 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-} - -module Assistant.WebApp.Configurators.Ssh where - -import Assistant.Common -import Assistant.Ssh -import Assistant.MakeRemote -import Assistant.WebApp -import Assistant.WebApp.Types -import Assistant.WebApp.SideBar -import Utility.Yesod -import Utility.Rsync (rsyncUrlIsShell) -import Logs.Remote -import Remote - -import Yesod -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Map as M -import Network.BSD -import System.Posix.User - -sshConfigurator :: Widget -> Handler RepHtml -sshConfigurator a = bootstrap (Just Config) $ do - sideBarDisplay - setTitle "Add a remote server" - a - -data SshInput = SshInput - { hostname :: Maybe Text - , username :: Maybe Text - , directory :: Maybe Text - } - deriving (Show) - -{- SshInput is only used for applicative form prompting, this converts - - the result of such a form into a SshData. -} -mkSshData :: SshInput -> SshData -mkSshData s = SshData - { sshHostName = fromMaybe "" $ hostname s - , sshUserName = username s - , sshDirectory = fromMaybe "" $ directory s - , sshRepoName = genSshRepoName - (T.unpack $ fromJust $ hostname s) - (maybe "" T.unpack $ directory s) - , needsPubKey = False - , rsyncOnly = False - } - -sshInputAForm :: SshInput -> AForm WebApp WebApp SshInput -sshInputAForm def = SshInput - <$> aopt check_hostname "Host name" (Just $ hostname def) - <*> aopt check_username "User name" (Just $ username def) - <*> aopt textField "Directory" (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ directory def) - where - check_hostname = checkM (liftIO . checkdns) textField - checkdns t = do - let h = T.unpack t - r <- catchMaybeIO $ getHostByName h - return $ case r of - -- canonicalize input hostname if it had no dot - Just hostentry - | '.' `elem` h -> Right t - | otherwise -> Right $ T.pack $ hostName hostentry - Nothing -> Left bad_hostname - - check_username = checkBool (all (`notElem` "/:@ \t") . T.unpack) - bad_username textField - - bad_hostname = "cannot resolve host name" :: Text - bad_username = "bad user name" :: Text - -data ServerStatus - = UntestedServer - | UnusableServer Text -- reason why it's not usable - | UsableRsyncServer - | UsableSshInput - deriving (Eq) - -usable :: ServerStatus -> Bool -usable UntestedServer = False -usable (UnusableServer _) = False -usable UsableRsyncServer = True -usable UsableSshInput = True - -getAddSshR :: Handler RepHtml -getAddSshR = sshConfigurator $ do - u <- liftIO $ T.pack . userName - <$> (getUserEntryForID =<< getEffectiveUserID) - ((result, form), enctype) <- lift $ - runFormGet $ renderBootstrap $ sshInputAForm $ - SshInput Nothing (Just u) Nothing - case result of - FormSuccess sshinput -> do - s <- liftIO $ testServer sshinput - case s of - Left status -> showform form enctype status - Right sshdata -> lift $ redirect $ ConfirmSshR sshdata - _ -> showform form enctype UntestedServer - where - showform form enctype status = do - let authtoken = webAppFormAuthToken - $(widgetFile "configurators/ssh/add") - -{- To enable an existing rsync special remote, parse the SshInput from - - its rsyncurl, and display a form whose only real purpose is to check - - if ssh public keys need to be set up. From there, we can proceed with - - the usual repo setup; all that code is idempotent. - - - - Note that there's no EnableSshR because ssh remotes are not special - - remotes, and so their configuration is not shared between repositories. - -} -getEnableRsyncR :: UUID -> Handler RepHtml -getEnableRsyncR u = do - m <- runAnnex M.empty readRemoteLog - case parseSshRsyncUrl =<< M.lookup "rsyncurl" =<< M.lookup u m of - Nothing -> redirect AddSshR - Just sshinput -> sshConfigurator $ do - ((result, form), enctype) <- lift $ - runFormGet $ renderBootstrap $ sshInputAForm sshinput - case result of - FormSuccess sshinput' - | isRsyncNet (hostname sshinput') -> - void $ lift $ makeRsyncNet sshinput' - | otherwise -> do - s <- liftIO $ testServer sshinput' - case s of - Left status -> showform form enctype status - Right sshdata -> enable sshdata - _ -> showform form enctype UntestedServer - where - showform form enctype status = do - description <- lift $ runAnnex "" $ - T.pack . concat <$> prettyListUUIDs [u] - let authtoken = webAppFormAuthToken - $(widgetFile "configurators/ssh/enable") - enable sshdata = - lift $ redirect $ ConfirmSshR $ - sshdata { rsyncOnly = True } - -{- Converts a rsyncurl value to a SshInput. But only if it's a ssh rsync - - url; rsync:// urls or bare path names are not supported. - - - - The hostname is stored mangled in the remote log for rsync special - - remotes configured by this webapp. So that mangling has to reversed - - here to get back the original hostname. - -} -parseSshRsyncUrl :: String -> Maybe SshInput -parseSshRsyncUrl u - | not (rsyncUrlIsShell u) = Nothing - | otherwise = Just $ SshInput - { hostname = val $ unMangleSshHostName host - , username = if null user then Nothing else val user - , directory = val dir - } - where - val = Just . T.pack - (userhost, dir) = separate (== ':') u - (user, host) = if '@' `elem` userhost - then separate (== '@') userhost - else (userhost, "") - -{- Test if we can ssh into the server. - - - - Two probe attempts are made. First, try sshing in using the existing - - configuration, but don't let ssh prompt for any password. If - - passwordless login is already enabled, use it. Otherwise, - - a special ssh key will need to be generated just for this server. - - - - Once logged into the server, probe to see if git-annex-shell is - - available, or rsync. - -} -testServer :: SshInput -> IO (Either ServerStatus SshData) -testServer (SshInput { hostname = Nothing }) = return $ - Left $ UnusableServer "Please enter a host name." -testServer sshinput@(SshInput { hostname = Just hn }) = do - status <- probe [sshOpt "NumberOfPasswordPrompts" "0"] - if usable status - then ret status False - else do - status' <- probe [] - if usable status' - then ret status' True - else return $ Left status' - where - ret status needspubkey = return $ Right $ - (mkSshData sshinput) - { needsPubKey = needspubkey - , rsyncOnly = status == UsableRsyncServer - } - probe extraopts = do - let remotecommand = join ";" - [ report "loggedin" - , checkcommand "git-annex-shell" - , checkcommand "rsync" - ] - knownhost <- knownHost hn - let sshopts = filter (not . null) $ extraopts ++ - {- If this is an already known host, let - - ssh check it as usual. - - Otherwise, trust the host key. -} - [ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no" - , "-n" -- don't read from stdin - , genSshHost (fromJust $ hostname sshinput) (username sshinput) - , remotecommand - ] - parsetranscript . fst <$> sshTranscript sshopts "" - parsetranscript s - | reported "git-annex-shell" = UsableSshInput - | reported "rsync" = UsableRsyncServer - | reported "loggedin" = UnusableServer - "Neither rsync nor git-annex are installed on the server. Perhaps you should go install them?" - | otherwise = UnusableServer $ T.pack $ - "Failed to ssh to the server. Transcript: " ++ s - where - reported r = token r `isInfixOf` s - checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi" - token r = "git-annex-probe " ++ r - report r = "echo " ++ token r - -{- Runs a ssh command; if it fails shows the user the transcript, - - and if it succeeds, runs an action. -} -sshSetup :: [String] -> String -> Handler RepHtml -> Handler RepHtml -sshSetup opts input a = do - (transcript, ok) <- liftIO $ sshTranscript opts input - if ok - then a - else showSshErr transcript - -showSshErr :: String -> Handler RepHtml -showSshErr msg = sshConfigurator $ - $(widgetFile "configurators/ssh/error") - -getConfirmSshR :: SshData -> Handler RepHtml -getConfirmSshR sshdata = sshConfigurator $ do - let authtoken = webAppFormAuthToken - $(widgetFile "configurators/ssh/confirm") - -getMakeSshGitR :: SshData -> Handler RepHtml -getMakeSshGitR = makeSsh False - -getMakeSshRsyncR :: SshData -> Handler RepHtml -getMakeSshRsyncR = makeSsh True - -makeSsh :: Bool -> SshData -> Handler RepHtml -makeSsh rsync sshdata - | needsPubKey sshdata = do - keypair <- liftIO genSshKeyPair - sshdata' <- liftIO $ setupSshKeyPair keypair sshdata - makeSsh' rsync sshdata' (Just keypair) - | otherwise = makeSsh' rsync sshdata Nothing - -makeSsh' :: Bool -> SshData -> Maybe SshKeyPair -> Handler RepHtml -makeSsh' rsync sshdata keypair = - sshSetup [sshhost, remoteCommand] "" $ - makeSshRepo rsync sshdata - where - sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata) - remotedir = T.unpack $ sshDirectory sshdata - remoteCommand = join "&&" $ catMaybes - [ Just $ "mkdir -p " ++ shellEscape remotedir - , Just $ "cd " ++ shellEscape remotedir - , if rsync then Nothing else Just "git init --bare --shared" - , if rsync then Nothing else Just "git annex init" - , if needsPubKey sshdata - then addAuthorizedKeysCommand (rsyncOnly sshdata) . sshPubKey <$> keypair - else Nothing - ] - -makeSshRepo :: Bool -> SshData -> Handler RepHtml -makeSshRepo forcersync sshdata = do - webapp <- getYesod - liftIO $ makeSshRemote - (fromJust $ threadState webapp) - (daemonStatus webapp) - (scanRemotes webapp) - forcersync sshdata - redirect RepositoriesR - -getAddRsyncNetR :: Handler RepHtml -getAddRsyncNetR = do - ((result, form), enctype) <- runFormGet $ - renderBootstrap $ sshInputAForm $ - SshInput Nothing Nothing Nothing - let showform status = bootstrap (Just Config) $ do - sideBarDisplay - setTitle "Add a Rsync.net repository" - let authtoken = webAppFormAuthToken - $(widgetFile "configurators/addrsync.net") - case result of - FormSuccess sshinput - | isRsyncNet (hostname sshinput) -> - makeRsyncNet sshinput - | otherwise -> - showform $ UnusableServer - "That is not a rsync.net host name." - _ -> showform UntestedServer - -makeRsyncNet :: SshInput -> Handler RepHtml -makeRsyncNet sshinput = do - knownhost <- liftIO $ maybe (return False) knownHost (hostname sshinput) - keypair <- liftIO $ genSshKeyPair - sshdata <- liftIO $ setupSshKeyPair keypair $ - (mkSshData sshinput) - { sshRepoName = "rsync.net" - , needsPubKey = True - , rsyncOnly = True - } - {- I'd prefer to separate commands with && , but - - rsync.net's shell does not support that. - - - - The dd method of appending to the authorized_keys file is the - - one recommended by rsync.net documentation. I touch the file first - - to not need to use a different method to create it. - -} - let remotecommand = join ";" - [ "mkdir -p .ssh" - , "touch .ssh/authorized_keys" - , "dd of=.ssh/authorized_keys oflag=append conv=notrunc" - , "mkdir -p " ++ T.unpack (sshDirectory sshdata) - ] - let sshopts = filter (not . null) - [ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no" - , genSshHost (sshHostName sshdata) (sshUserName sshdata) - , remotecommand - ] - sshSetup sshopts (sshPubKey keypair) $ - makeSshRepo True sshdata - -isRsyncNet :: Maybe Text -> Bool -isRsyncNet Nothing = False -isRsyncNet (Just host) = ".rsync.net" `T.isSuffixOf` T.toLower host |