diff options
Diffstat (limited to 'Assistant/WebApp/Configurators')
| -rw-r--r-- | Assistant/WebApp/Configurators/Local.hs | 319 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators/Pairing.hs | 204 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators/Ssh.hs | 339 |
3 files changed, 0 insertions, 862 deletions
diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs deleted file mode 100644 index a86d13026..000000000 --- a/Assistant/WebApp/Configurators/Local.hs +++ /dev/null @@ -1,319 +0,0 @@ -{- git-annex assistant webapp configurators for making local repositories - - - - 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.Local where - -import Assistant.Common -import Assistant.WebApp -import Assistant.WebApp.Types -import Assistant.WebApp.SideBar -import Assistant.Sync -import Assistant.MakeRemote -import Utility.Yesod -import Init -import qualified Git -import qualified Git.Construct -import qualified Git.Config -import qualified Annex -import Locations.UserConfig -import Utility.FreeDesktop -import Utility.Mounts -import Utility.DiskFree -import Utility.DataUnits -import Utility.Network -import Remote (prettyListUUIDs) - -import Yesod -import Data.Text (Text) -import qualified Data.Text as T -import Data.Char -import System.Posix.Directory -import qualified Control.Exception as E - -data RepositoryPath = RepositoryPath Text - deriving Show - -{- Custom field display for a RepositoryPath, with an icon etc. - - - - Validates that the path entered is not empty, and is a safe value - - to use as a repository. -} -repositoryPathField :: forall sub. Bool -> Field sub WebApp Text -repositoryPathField autofocus = Field { fieldParse = parse, fieldView = view } - where - view idAttr nameAttr attrs val isReq = - [whamlet|<input type="text" *{attrs} id="#{idAttr}" name="#{nameAttr}" :isReq:required :autofocus:autofocus value="#{either id id val}">|] - - parse [path] - | T.null path = nopath - | otherwise = liftIO $ checkRepositoryPath path - parse [] = return $ Right Nothing - parse _ = nopath - - nopath = return $ Left "Enter a location for the repository" - -{- As well as checking the path for a lot of silly things, tilde is - - expanded in the returned path. -} -checkRepositoryPath :: Text -> IO (Either (SomeMessage WebApp) (Maybe Text)) -checkRepositoryPath p = do - home <- myHomeDir - let basepath = expandTilde home $ T.unpack p - path <- absPath basepath - let parent = parentDir path - problems <- catMaybes <$> mapM runcheck - [ (return $ path == "/", "Enter the full path to use for the repository.") - , (return $ all isSpace basepath, "A blank path? Seems unlikely.") - , (doesFileExist path, "A file already exists with that name.") - , (return $ path == home, "Sorry, using git-annex for your whole home directory is not currently supported.") - , (not <$> doesDirectoryExist parent, "Parent directory does not exist.") - , (not <$> canWrite path, "Cannot write a repository there.") - , (not <$> canMakeSymlink path, "That directory is on a filesystem that does not support symlinks. Try a different location.") - ] - return $ - case headMaybe problems of - Nothing -> Right $ Just $ T.pack basepath - Just prob -> Left prob - where - runcheck (chk, msg) = ifM (chk) - ( return $ Just msg - , return Nothing - ) - expandTilde home ('~':'/':path) = home </> path - expandTilde _ path = path - - -{- On first run, if run in the home directory, default to putting it in - - ~/Desktop/annex, when a Desktop directory exists, and ~/annex otherwise. - - - - If run in another directory, the user probably wants to put it there. -} -defaultRepositoryPath :: Bool -> IO FilePath -defaultRepositoryPath firstrun = do - cwd <- liftIO $ getCurrentDirectory - home <- myHomeDir - if home == cwd && firstrun - then do - desktop <- userDesktopDir - ifM (doesDirectoryExist desktop) - ( relHome $ desktop </> gitAnnexAssistantDefaultDir - , return $ "~" </> gitAnnexAssistantDefaultDir - ) - else return cwd - -newRepositoryForm :: FilePath -> Form RepositoryPath -newRepositoryForm defpath msg = do - (pathRes, pathView) <- mreq (repositoryPathField True) "" - (Just $ T.pack $ addTrailingPathSeparator defpath) - let (err, errmsg) = case pathRes of - FormMissing -> (False, "") - FormFailure l -> (True, concat $ map T.unpack l) - FormSuccess _ -> (False, "") - let form = do - webAppFormAuthToken - $(widgetFile "configurators/newrepository/form") - return (RepositoryPath <$> pathRes, form) - -{- Making the first repository, when starting the webapp for the first time. -} -getFirstRepositoryR :: Handler RepHtml -getFirstRepositoryR = bootstrap (Just Config) $ do - sideBarDisplay - setTitle "Getting started" - path <- liftIO . defaultRepositoryPath =<< lift inFirstRun - ((res, form), enctype) <- lift $ runFormGet $ newRepositoryForm path - case res of - FormSuccess (RepositoryPath p) -> lift $ - startFullAssistant $ T.unpack p - _ -> $(widgetFile "configurators/newrepository/first") - -{- Adding a new, separate repository. -} -getNewRepositoryR :: Handler RepHtml -getNewRepositoryR = bootstrap (Just Config) $ do - sideBarDisplay - setTitle "Add another repository" - home <- liftIO myHomeDir - ((res, form), enctype) <- lift $ runFormGet $ newRepositoryForm home - case res of - FormSuccess (RepositoryPath p) -> lift $ do - let path = T.unpack p - liftIO $ do - makeRepo path False - initRepo path Nothing - addAutoStart path - redirect $ SwitchToRepositoryR path - _ -> $(widgetFile "configurators/newrepository") - -data RemovableDrive = RemovableDrive - { diskFree :: Maybe Integer - , mountPoint :: Text - } - deriving (Show, Eq, Ord) - -selectDriveForm :: [RemovableDrive] -> Maybe RemovableDrive -> Form RemovableDrive -selectDriveForm drives def = renderBootstrap $ RemovableDrive - <$> pure Nothing - <*> areq (selectFieldList pairs) "Select drive:" (mountPoint <$> def) - where - pairs = zip (map describe drives) (map mountPoint drives) - describe drive = case diskFree drive of - Nothing -> mountPoint drive - Just free -> - let sz = roughSize storageUnits True free - in T.unwords - [ mountPoint drive - , T.concat ["(", T.pack sz] - , "free)" - ] - -{- Adding a removable drive. -} -getAddDriveR :: Handler RepHtml -getAddDriveR = bootstrap (Just Config) $ do - sideBarDisplay - setTitle "Add a removable drive" - removabledrives <- liftIO $ driveList - writabledrives <- liftIO $ - filterM (canWrite . T.unpack . mountPoint) removabledrives - ((res, form), enctype) <- lift $ runFormGet $ - selectDriveForm (sort writabledrives) Nothing - case res of - FormSuccess (RemovableDrive { mountPoint = d }) -> lift $ do - go $ T.unpack d - redirect RepositoriesR - _ -> do - let authtoken = webAppFormAuthToken - $(widgetFile "configurators/adddrive") - where - go mountpoint = do - liftIO $ makerepo dir - liftIO $ initRepo dir $ Just remotename - r <- addremote dir remotename - syncRemote r - where - dir = mountpoint </> gitAnnexAssistantDefaultDir - remotename = takeFileName mountpoint - {- The repo may already exist, when adding removable media - - that has already been used elsewhere. -} - makerepo dir = liftIO $ do - r <- E.try (inDir dir $ return True) :: IO (Either E.SomeException Bool) - case r of - Right _ -> noop - Left _e -> do - createDirectoryIfMissing True dir - bare <- not <$> canMakeSymlink dir - makeRepo dir bare - {- Each repository is made a remote of the other. -} - addremote dir name = runAnnex undefined $ do - hostname <- maybe "host" id <$> liftIO getHostname - hostlocation <- fromRepo Git.repoLocation - liftIO $ inDir dir $ - void $ makeGitRemote hostname hostlocation - addRemote $ makeGitRemote name dir - -getEnableDirectoryR :: UUID -> Handler RepHtml -getEnableDirectoryR uuid = bootstrap (Just Config) $ do - sideBarDisplay - setTitle "Enable a repository" - description <- lift $ runAnnex "" $ - T.pack . concat <$> prettyListUUIDs [uuid] - $(widgetFile "configurators/enabledirectory") - -{- Start syncing a newly added remote, using a background thread. -} -syncRemote :: Remote -> Handler () -syncRemote remote = do - webapp <- getYesod - liftIO $ syncNewRemote - (fromJust $ threadState webapp) - (daemonStatus webapp) - (scanRemotes webapp) - remote - -{- List of removable drives. -} -driveList :: IO [RemovableDrive] -driveList = mapM (gen . mnt_dir) =<< filter sane <$> getMounts - where - gen dir = RemovableDrive - <$> getDiskFree dir - <*> pure (T.pack dir) - -- filter out some things that are surely not removable drives - sane Mntent { mnt_dir = dir, mnt_fsname = dev } - {- We want real disks like /dev/foo, not - - dummy mount points like proc or tmpfs or - - gvfs-fuse-daemon. -} - | not ('/' `elem` dev) = False - {- Just in case: These mount points are surely not - - removable disks. -} - | dir == "/" = False - | dir == "/tmp" = False - | dir == "/run/shm" = False - | dir == "/run/lock" = False - | otherwise = True - -{- Bootstraps from first run mode to a fully running assistant in a - - repository, by running the postFirstRun callback, which returns the - - url to the new webapp. -} -startFullAssistant :: FilePath -> Handler () -startFullAssistant path = do - webapp <- getYesod - url <- liftIO $ do - makeRepo path False - initRepo path Nothing - addAutoStart path - changeWorkingDirectory path - fromJust $ postFirstRun webapp - redirect $ T.pack url - -{- Makes a new git-annex repository. -} -makeRepo :: FilePath -> Bool -> IO () -makeRepo path bare = do - unlessM (boolSystem "git" params) $ - error "git init failed!" - where - baseparams = [Param "init", Param "--quiet"] - params - | bare = baseparams ++ [Param "--bare", File path] - | otherwise = baseparams ++ [File path] - -{- Runs an action in the git-annex repository in the specified directory. -} -inDir :: FilePath -> Annex a -> IO a -inDir dir a = do - state <- Annex.new =<< Git.Config.read =<< Git.Construct.fromPath dir - Annex.eval state a - -{- Initializes a git-annex repository in a directory with a description. -} -initRepo :: FilePath -> Maybe String -> IO () -initRepo dir desc = inDir dir $ - unlessM isInitialized $ - initialize desc - -{- Adds a directory to the autostart file. -} -addAutoStart :: FilePath -> IO () -addAutoStart path = do - autostart <- autoStartFile - createDirectoryIfMissing True (parentDir autostart) - appendFile autostart $ path ++ "\n" - -{- Checks if the user can write to a directory. - - - - The directory may be in the process of being created; if so - - the parent directory is checked instead. -} -canWrite :: FilePath -> IO Bool -canWrite dir = do - tocheck <- ifM (doesDirectoryExist dir) - (return dir, return $ parentDir dir) - catchBoolIO $ fileAccess tocheck False True False - -{- Checks if a directory is on a filesystem that supports symlinks. -} -canMakeSymlink :: FilePath -> IO Bool -canMakeSymlink dir = ifM (doesDirectoryExist dir) - ( catchBoolIO $ test dir - , canMakeSymlink (parentDir dir) - ) - where - test d = do - let link = d </> "delete.me" - createSymbolicLink link link - removeLink link - return True diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs deleted file mode 100644 index 87353be3c..000000000 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ /dev/null @@ -1,204 +0,0 @@ -{- git-annex assistant webapp configurator for pairing - - - - Copyright 2012 Joey Hess <joey@kitenet.net> - - - - Licensed under the GNU GPL version 3 or higher. - -} - -{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-} -{-# LANGUAGE CPP #-} - -module Assistant.WebApp.Configurators.Pairing where - -import Assistant.Pairing -import Assistant.WebApp -import Assistant.WebApp.Types -import Assistant.WebApp.SideBar -import Utility.Yesod -#ifdef WITH_PAIRING -import Assistant.Common -import Assistant.Pairing.Network -import Assistant.Pairing.MakeRemote -import Assistant.Ssh -import Assistant.Alert -import Assistant.DaemonStatus -import Utility.Verifiable -import Utility.Network -import Annex.UUID -#endif - -import Yesod -import Data.Text (Text) -#ifdef WITH_PAIRING -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.ByteString.Lazy as B -import Data.Char -import System.Posix.User -import qualified Control.Exception as E -import Control.Concurrent -#endif - -{- Starts sending out pair requests. -} -getStartPairR :: Handler RepHtml -#ifdef WITH_PAIRING -getStartPairR = promptSecret Nothing $ startPairing PairReq noop pairingAlert Nothing -#else -getStartPairR = noPairing -#endif - -{- Runs on the system that responds to a pair request; sets up the ssh - - authorized key first so that the originating host can immediately sync - - with us. -} -getFinishPairR :: PairMsg -> Handler RepHtml -#ifdef WITH_PAIRING -getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do - liftIO $ setup - startPairing PairAck cleanup alert uuid "" secret - where - alert = pairRequestAcknowledgedAlert (pairRepo msg) . Just - setup = setupAuthorizedKeys msg - cleanup = removeAuthorizedKeys False $ - remoteSshPubKey $ pairMsgData msg - uuid = Just $ pairUUID $ pairMsgData msg -#else -getFinishPairR _ = noPairing -#endif - -getInprogressPairR :: SecretReminder -> Handler RepHtml -#ifdef WITH_PAIRING -getInprogressPairR s = pairPage $ do - let secret = fromSecretReminder s - $(widgetFile "configurators/pairing/inprogress") -#else -getInprogressPairR _ = noPairing -#endif - -#ifdef WITH_PAIRING - -{- Starts pairing, at either the PairReq (initiating host) or - - PairAck (responding host) stage. - - - - Displays an alert, and starts a thread sending the pairing message, - - which will continue running until the other host responds, or until - - canceled by the user. If canceled by the user, runs the oncancel action. - - - - Redirects to the pairing in progress page. - -} -startPairing :: PairStage -> IO () -> (AlertButton -> Alert) -> Maybe UUID -> Text -> Secret -> Widget -startPairing stage oncancel alert muuid displaysecret secret = do - dstatus <- daemonStatus <$> lift getYesod - urlrender <- lift getUrlRender - reldir <- fromJust . relDir <$> lift getYesod - - {- Generating a ssh key pair can take a while, so do it in the - - background. -} - void $ liftIO $ forkIO $ do - keypair <- genSshKeyPair - pairdata <- PairData - <$> getHostname - <*> getUserName - <*> pure reldir - <*> pure (sshPubKey keypair) - <*> (maybe genUUID return muuid) - let sender = multicastPairMsg Nothing secret pairdata - let pip = PairingInProgress secret Nothing keypair pairdata stage - startSending dstatus pip stage $ sendrequests sender dstatus urlrender - - lift $ redirect $ InprogressPairR $ toSecretReminder displaysecret - where - {- Sends pairing messages until the thread is killed, - - and shows an activity alert while doing it. - - - - The cancel button returns the user to the HomeR. This is - - not ideal, but they have to be sent somewhere, and could - - have been on a page specific to the in-process pairing - - that just stopped, so can't go back there. - -} - sendrequests sender dstatus urlrender _stage = do - tid <- myThreadId - let selfdestruct = AlertButton - { buttonLabel = "Cancel" - , buttonUrl = urlrender HomeR - , buttonAction = Just $ const $ do - oncancel - killThread tid - } - alertDuring dstatus (alert selfdestruct) $ do - _ <- E.try (sender stage) :: IO (Either E.SomeException ()) - return () - -data InputSecret = InputSecret { secretText :: Maybe Text } - -{- If a PairMsg is passed in, ensures that the user enters a secret - - that can validate it. -} -promptSecret :: Maybe PairMsg -> (Text -> Secret -> Widget) -> Handler RepHtml -promptSecret msg cont = pairPage $ do - ((result, form), enctype) <- lift $ - runFormGet $ renderBootstrap $ - InputSecret <$> aopt textField "Secret phrase" Nothing - case result of - FormSuccess v -> do - let rawsecret = fromMaybe "" $ secretText v - let secret = toSecret rawsecret - case msg of - Nothing -> case secretProblem secret of - Nothing -> cont rawsecret secret - Just problem -> - showform form enctype $ Just problem - Just m -> - if verify (fromPairMsg m) secret - then cont rawsecret secret - else showform form enctype $ Just - "That's not the right secret phrase." - _ -> showform form enctype Nothing - where - showform form enctype mproblem = do - let start = isNothing msg - let badphrase = isJust mproblem - let problem = fromMaybe "" mproblem - let (username, hostname) = maybe ("", "") - (\(_, v, a) -> (T.pack $ remoteUserName v, T.pack $ fromMaybe (showAddr a) (remoteHostName v))) - (verifiableVal . fromPairMsg <$> msg) - u <- T.pack <$> liftIO getUserName - let sameusername = username == u - let authtoken = webAppFormAuthToken - $(widgetFile "configurators/pairing/prompt") - -{- This counts unicode characters as more than one character, - - but that's ok; they *do* provide additional entropy. -} -secretProblem :: Secret -> Maybe Text -secretProblem s - | B.null s = Just "The secret phrase cannot be left empty. (Remember that punctuation and white space is ignored.)" - | B.length s < 7 = Just "Enter a longer secret phrase, at least 6 characters, but really, a phrase is best! This is not a password you'll need to enter every day." - | s == toSecret sampleQuote = Just "Speaking of foolishness, don't paste in the example I gave. Enter a different phrase, please!" - | otherwise = Nothing - -toSecret :: Text -> Secret -toSecret s = B.fromChunks [T.encodeUtf8 $ T.toLower $ T.filter isAlphaNum s] - -getUserName :: IO String -getUserName = userName <$> (getUserEntryForID =<< getEffectiveUserID) - -pairPage :: Widget -> Handler RepHtml -pairPage w = bootstrap (Just Config) $ do - sideBarDisplay - setTitle "Pairing" - w - -{- From Dickens -} -sampleQuote :: Text -sampleQuote = T.unwords - [ "It was the best of times," - , "it was the worst of times," - , "it was the age of wisdom," - , "it was the age of foolishness." - ] - -#else - -noPairing :: Handler RepHtml -noPairing = pairPage $ - $(widgetFile "configurators/pairing/disabled") - -#endif 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 |