diff options
| -rw-r--r-- | Assistant/Alert.hs | 6 | ||||
| -rw-r--r-- | Assistant/Pairing.hs | 9 | ||||
| -rw-r--r-- | Assistant/Pairing/Network.hs | 2 | ||||
| -rw-r--r-- | Assistant/Ssh.hs | 47 | ||||
| -rw-r--r-- | Assistant/Threads/PairListener.hs | 34 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators/Pairing.hs | 145 | ||||
| -rw-r--r-- | Assistant/WebApp/Configurators/Ssh.hs | 21 | ||||
| -rw-r--r-- | Utility/Verifiable.hs | 6 | ||||
| -rw-r--r-- | templates/configurators/pairing/inprogress.hamlet | 19 |
9 files changed, 178 insertions, 111 deletions
diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index a2f5db4e3..7eb8550cc 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -286,9 +286,9 @@ sanityCheckFixAlert msg = Alert alerthead = "The daily sanity check found and fixed a problem:" alertfoot = "If these problems persist, consider filing a bug report." -pairRequestAlert :: AlertButton -> Alert -pairRequestAlert button = baseActivityAlert - { alertData = [ UnTensed "Pairing request in progress" ] +pairingAlert :: AlertButton -> Alert +pairingAlert button = baseActivityAlert + { alertData = [ UnTensed "Pairing in progress" ] , alertPriority = High , alertButton = Just button } diff --git a/Assistant/Pairing.hs b/Assistant/Pairing.hs index 399c7e50f..b957e0835 100644 --- a/Assistant/Pairing.hs +++ b/Assistant/Pairing.hs @@ -34,6 +34,9 @@ fromPairMsg (PairMsg m) = m pairMsgStage :: PairMsg -> PairStage pairMsgStage (PairMsg (Verifiable (s, _) _)) = s +pairMsgData :: PairMsg -> PairData +pairMsgData (PairMsg (Verifiable (_, d) _)) = d + data PairData = PairData -- uname -n output, not a full domain name { remoteHostName :: Maybe HostName @@ -45,11 +48,11 @@ data PairData = PairData } deriving (Eq, Read, Show) -type SshPubKey = String type UserName = String -{- A pairing that is in progress has a secret, and a thread that is - - broadcasting pairing requests. -} +{- A pairing that is in progress has a secret, a thread that is + - broadcasting pairing messages, and a SshKeyPair that has not yet been + - set up on disk. -} data PairingInProgress = PairingInProgress { inProgressSecret :: Secret , inProgressThreadId :: ThreadId diff --git a/Assistant/Pairing/Network.hs b/Assistant/Pairing/Network.hs index 2b645a9d9..8832db05f 100644 --- a/Assistant/Pairing/Network.hs +++ b/Assistant/Pairing/Network.hs @@ -30,7 +30,7 @@ multicastAddress :: SomeAddr -> HostName multicastAddress (IPv4Addr _) = "224.0.0.1" multicastAddress (IPv6Addr _) = "ff02::1" -{- Multicasts a message repeatedly on all interfaces forever, +{- Multicasts a message repeatedly on all interfaces forever, until killed - with a 2 second delay between each transmission. - - The remoteHostAddress is set to the interface's IP address. diff --git a/Assistant/Ssh.hs b/Assistant/Ssh.hs index 35ef64caa..7e72dd99d 100644 --- a/Assistant/Ssh.hs +++ b/Assistant/Ssh.hs @@ -15,6 +15,7 @@ import qualified Data.Text as T import qualified Control.Exception as E import System.Process (CreateProcess(..)) import Control.Concurrent +import Data.Char data SshData = SshData { sshHostName :: Text @@ -31,6 +32,8 @@ data SshKeyPair = SshKeyPair , sshPrivKey :: String } +type SshPubKey = String + {- ssh -ofoo=bar command-line option -} sshOpt :: String -> String -> String sshOpt k v = concat ["-o", k, "=", v] @@ -40,6 +43,15 @@ sshDir = do home <- myHomeDir return $ home </> ".ssh" +{- host_dir, with all / in dir replaced by _, and bad characters removed -} +genSshRepoName :: String -> FilePath -> String +genSshRepoName host dir + | null dir = filter legal host + | otherwise = filter legal $ host ++ "_" ++ replace "/" "_" dir + where + legal '_' = True + legal c = isAlphaNum c + {- The output of ssh, including both stdout and stderr. -} sshTranscript :: [String] -> String -> IO (String, Bool) sshTranscript opts input = do @@ -71,27 +83,30 @@ sshTranscript opts input = do return () return (transcript, ok) + +makeAuthorizedKeys :: Bool -> SshPubKey -> IO Bool +makeAuthorizedKeys rsynconly pubkey = boolSystem "sh" + [ Param "-c" , Param $ makeAuthorizedKeysCommand rsynconly pubkey ] + {- Implemented as a shell command, so it can be run on remote servers over - ssh. -} -makeAuthorizedKeys :: SshData -> SshKeyPair -> Maybe String -makeAuthorizedKeys sshdata keypair - | needsPubKey sshdata = Just $ join "&&" $ - [ "mkdir -p ~/.ssh" - , "touch ~/.ssh/authorized_keys" - , "chmod 600 ~/.ssh/authorized_keys" - , unwords - [ "echo" - , shellEscape $ authorizedKeysLine sshdata keypair - , ">>~/.ssh/authorized_keys" - ] +makeAuthorizedKeysCommand :: Bool -> SshPubKey -> String +makeAuthorizedKeysCommand rsynconly pubkey = join "&&" $ + [ "mkdir -p ~/.ssh" + , "touch ~/.ssh/authorized_keys" + , "chmod 600 ~/.ssh/authorized_keys" + , unwords + [ "echo" + , shellEscape $ authorizedKeysLine rsynconly pubkey + , ">>~/.ssh/authorized_keys" ] - | otherwise = Nothing - -authorizedKeysLine :: SshData -> SshKeyPair -> String -authorizedKeysLine sshdata (SshKeyPair { sshPubKey = pubkey }) + ] + +authorizedKeysLine :: Bool -> SshPubKey -> String +authorizedKeysLine rsynconly pubkey {- TODO: Locking down rsync is difficult, requiring a rather - long perl script. -} - | rsyncOnly sshdata = pubkey + | rsynconly = pubkey | otherwise = limitcommand "git-annex-shell -c" ++ pubkey where limitcommand c = "command=\"perl -e 'exec qw(" ++ c ++ "), $ENV{SSH_ORIGINAL_COMMAND}'\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding " diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index e7104dc28..8b1cac2ba 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -46,15 +46,20 @@ pairListenerThread st dstatus urlrenderer = thread $ withSocketsDo $ do chunksz = 1024 dispatch Nothing = noop - dispatch (Just m) = case pairMsgStage m of - PairReq -> pairReqAlert dstatus urlrenderer m - PairAck -> pairAckAlert dstatus m - PairDone -> pairDoneAlert dstatus m + dispatch (Just m@(PairMsg v)) = do + verified <- maybe False (verify v . inProgressSecret) + . pairingInProgress + <$> getDaemonStatus dstatus + case pairMsgStage m of + PairReq -> pairReqReceived verified dstatus urlrenderer m + PairAck -> pairAckReceived verified dstatus m + PairDone -> pairDoneReceived verified dstatus m {- Pair request alerts from the same host combine, - so repeated requests do not add additional alerts. -} -pairReqAlert :: DaemonStatusHandle -> UrlRenderer -> PairMsg -> IO () -pairReqAlert dstatus urlrenderer msg = unlessM myreq $ do +pairReqReceived :: Bool -> DaemonStatusHandle -> UrlRenderer -> PairMsg -> IO () +pairReqReceived True _ _ _ = noop -- ignore out own PairReq +pairReqReceived False dstatus urlrenderer msg = do url <- renderUrl urlrenderer (FinishPairR msg) [] void $ addAlert dstatus $ pairRequestReceivedAlert repo (repo ++ " is sending a pair request.") $ @@ -74,11 +79,6 @@ pairReqAlert dstatus urlrenderer msg = unlessM myreq $ do , ":" , (remoteDirectory pairdata) ] - {- Filter out our own pair request, by checking if we - - can verify using its secret. -} - myreq = maybe False (verified v . inProgressSecret) - . pairingInProgress - <$> getDaemonStatus dstatus {- Remove the button when it's clicked, and change the - alert to be in progress. This alert cannot be entirely - removed since more pair request messages are coming in @@ -91,15 +91,16 @@ pairReqAlert dstatus urlrenderer msg = unlessM myreq $ do } {- When a valid PairAck is seen, a host has successfully paired with - - us, and we should finish pairing with them. Then send a PairDone. + - us, and we should finish pairing with them. Then send a single PairDone. - - A stale PairAck might also be seen, after we've finished pairing. - Perhaps our PairDone was not received. To handle this, we keep - a list of recently finished pairings, and re-send PairDone in - response to stale PairAcks for them. -} -pairAckAlert :: DaemonStatusHandle -> PairMsg -> IO () -pairAckAlert dstatus msg = error "TODO" +pairAckReceived :: Bool -> DaemonStatusHandle -> PairMsg -> IO () +pairAckReceived False _ _ = noop -- not verified +pairAckReceived True dstatus msg = error "TODO" {- If we get a valid PairDone, and are sending PairAcks, we can stop - sending them, as the message has been received. @@ -110,5 +111,6 @@ pairAckAlert dstatus msg = error "TODO" - Note: This does allow a bad actor to squelch pairing on a network - by sending bogus PairDones. -} -pairDoneAlert :: DaemonStatusHandle -> PairMsg -> IO () -pairDoneAlert dstatus msg = error "TODO" +pairDoneReceived :: Bool -> DaemonStatusHandle -> PairMsg -> IO () +pairDoneReceived False _ _ = noop -- not verified +pairDoneReceived True dstatus msg = error "TODO" diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index da54e6a88..96c053b86 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -11,12 +11,14 @@ - which prompts them for the same secret. - * The secret is used to verify the PairReq. If it checks out, - a PairAck is sent, and the other device adds the ssh key from the - - PairReq. An Alert is displayed noting that the pairing has been set up. + - PairReq to its authorized_keys, and sets up the remote. - * The PairAck is received back at the device that started the process. - It's verified using the stored secret. The ssh key from the PairAck - is added. An Alert is displayed noting that the pairing has been set - up. The pairing secret is removed to prevent anyone cracking the - - crypto. + - crypto. Syncing starts. A PairDone is sent. + - * The PairDone is received, and an alert shown indicating pairing is + - done. - - Copyright 2012 Joey Hess <joey@kitenet.net> - @@ -34,9 +36,10 @@ import Assistant.WebApp.Types import Assistant.WebApp.SideBar import Utility.Yesod #ifdef WITH_PAIRING +import Assistant.Common import Assistant.Pairing.Network import Assistant.Ssh -import Assistant.Common +import qualified Assistant.WebApp.Configurators.Ssh as Ssh import Assistant.Alert import Assistant.DaemonStatus import Utility.Verifiable @@ -57,74 +60,110 @@ import Control.Concurrent getStartPairR :: Handler RepHtml #ifdef WITH_PAIRING -getStartPairR = promptSecret Nothing $ \rawsecret secret -> do +getStartPairR = do + keypair <- liftIO genSshKeyPair + promptSecret Nothing $ startPairing PairReq keypair noop +#else +getStartPairR = noPairing +#endif + +getFinishPairR :: PairMsg -> Handler RepHtml +#ifdef WITH_PAIRING +getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do + keypair <- setup + startPairing PairAck keypair cleanup "" secret + where + pubkey = remoteSshPubKey $ pairMsgData msg + setup = do + unlessM (liftIO $ makeAuthorizedKeys False pubkey) $ + error "failed setting up ssh authorized keys" + keypair <- liftIO genSshKeyPair + let d = pairMsgData msg + besthostname <- liftIO $ bestHostName d + let sshdata = SshData + { sshHostName = T.pack besthostname + , sshUserName = Just (T.pack $ remoteUserName d) + , sshDirectory = T.pack (remoteDirectory d) + , sshRepoName = genSshRepoName besthostname (remoteDirectory d) + , needsPubKey = True + , rsyncOnly = False + } + sshdata' <- liftIO $ setupSshKeyPair keypair sshdata + void $ lift $ Ssh.makeSshWithKeyPair False sshdata' (Just keypair) + return keypair + cleanup = error "TODO clean up authorized keys and generated ssh key and remove git remote" +#else +getFinishPairR _ = noPairing +#endif + +getInprogressPairR :: Text -> Handler RepHtml +#ifdef WITH_PAIRING +getInprogressPairR secret = pairPage $ do + $(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 -> SshKeyPair -> IO () -> Text -> Secret -> Widget +startPairing stage keypair oncancel displaysecret secret = do dstatus <- daemonStatus <$> lift getYesod urlrender <- lift getUrlRender let homeurl = urlrender HomeR - hostname <- liftIO getHostname - username <- liftIO getUserName - reldir <- fromJust . relDir <$> lift getYesod - keypair <- liftIO genSshKeyPair - let pubkey = sshPubKey keypair ++ "foo" - let mkmsg addr = PairMsg $ mkVerifiable - (PairReq, PairData hostname addr username reldir pubkey) secret + sender <- mksender liftIO $ do pip <- PairingInProgress secret - <$> sendrequests mkmsg dstatus homeurl + <$> sendrequests sender dstatus homeurl <*> pure keypair oldpip <- modifyDaemonStatus dstatus $ \s -> (s { pairingInProgress = Just pip }, pairingInProgress s) maybe noop stopold oldpip - lift $ redirect $ InprogressPairR rawsecret + lift $ redirect $ InprogressPairR displaysecret where + mksender = do + hostname <- liftIO getHostname + username <- liftIO getUserName + reldir <- fromJust . relDir <$> lift getYesod + return $ multicastPairMsg $ \addr -> PairMsg $ mkVerifiable + (stage, PairData hostname addr username reldir (sshPubKey keypair)) secret {- Sends pairing messages until the thread is killed, - and shows an activity alert while doing it. - - - The button returns the user to the HomeR. This is + - 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. + - that just stopped, so can't go back there. -} - sendrequests mkmsg dstatus homeurl = forkIO $ do + sendrequests sender dstatus homeurl = forkIO $ do tid <- myThreadId let selfdestruct = AlertButton { buttonLabel = "Cancel" , buttonUrl = homeurl - , buttonAction = Just $ const $ killThread tid + , buttonAction = Just $ const $ do + oncancel + killThread tid } - alertDuring dstatus (pairRequestAlert selfdestruct) $ do - _ <- E.try (multicastPairMsg mkmsg) :: IO (Either E.SomeException ()) + alertDuring dstatus (pairingAlert selfdestruct) $ do + _ <- E.try sender :: IO (Either E.SomeException ()) return () stopold = killThread . inProgressThreadId -#else -getStartPairR = noPairing -#endif - -getInprogressPairR :: Text -> Handler RepHtml -#ifdef WITH_PAIRING -getInprogressPairR secret = bootstrap (Just Config) $ do - sideBarDisplay - setTitle "Pairing" - $(widgetFile "configurators/pairing/inprogress") -#else -getInprogressPairR _ = noPairing -#endif -getFinishPairR :: PairMsg -> Handler RepHtml -#ifdef WITH_PAIRING -getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do - error "TODO" -#else -getFinishPairR _ = noPairing -#endif - -#ifdef WITH_PAIRING 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 = bootstrap (Just Config) $ do - sideBarDisplay - setTitle "Pairing" +promptSecret msg cont = pairPage $ do ((result, form), enctype) <- lift $ runFormGet $ renderBootstrap $ InputSecret <$> aopt textField "Secret phrase" Nothing @@ -138,7 +177,7 @@ promptSecret msg cont = bootstrap (Just Config) $ do Just problem -> showform form enctype $ Just problem Just m -> - if verified (fromPairMsg m) secret + if verify (fromPairMsg m) secret then cont rawsecret secret else showform form enctype $ Just "That's not the right secret phrase." @@ -168,6 +207,15 @@ secretProblem s 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 @@ -177,15 +225,10 @@ sampleQuote = T.unwords , "it was the age of foolishness." ] -getUserName :: IO String -getUserName = userName <$> (getUserEntryForID =<< getEffectiveUserID) - #else noPairing :: Handler RepHtml -noPairing = bootstrap (Just Config) $ do - sideBarDisplay - setTitle "Pairing" +noPairing = pairPage $ $(widgetFile "configurators/pairing/disabled") #endif diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs index eebcdae03..3698c8370 100644 --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -49,7 +49,9 @@ mkSshData sshserver = SshData { sshHostName = fromMaybe "" $ hostname sshserver , sshUserName = username sshserver , sshDirectory = fromMaybe "" $ directory sshserver - , sshRepoName = genSshRepoName sshserver + , sshRepoName = genSshRepoName + (T.unpack $ fromJust $ hostname sshserver) + (maybe "" T.unpack $ directory sshserver) , needsPubKey = False , rsyncOnly = False } @@ -167,11 +169,6 @@ testServer sshserver = do genSshHost :: Text -> Maybe Text -> String genSshHost host user = maybe "" (\v -> T.unpack v ++ "@") user ++ T.unpack host -{- host_dir -} -genSshRepoName :: SshServer -> String -genSshRepoName s = (T.unpack $ fromJust $ hostname s) ++ - (maybe "" (\d -> '_' : T.unpack d) (directory s)) - {- 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 @@ -211,11 +208,11 @@ makeSsh rsync sshdata | needsPubKey sshdata = do keypair <- liftIO $ genSshKeyPair sshdata' <- liftIO $ setupSshKeyPair keypair sshdata - makeSsh' rsync sshdata' (Just keypair) - | otherwise = makeSsh' rsync sshdata Nothing + makeSshWithKeyPair rsync sshdata' (Just keypair) + | otherwise = makeSshWithKeyPair rsync sshdata Nothing -makeSsh' :: Bool -> SshData -> Maybe SshKeyPair -> Handler RepHtml -makeSsh' rsync sshdata keypair = +makeSshWithKeyPair :: Bool -> SshData -> Maybe SshKeyPair -> Handler RepHtml +makeSshWithKeyPair rsync sshdata keypair = sshSetup [sshhost, remoteCommand] "" $ makeSshRepo rsync sshdata where @@ -226,7 +223,9 @@ makeSsh' rsync sshdata keypair = , Just $ "cd " ++ shellEscape remotedir , if rsync then Nothing else Just $ "git init --bare --shared" , if rsync then Nothing else Just $ "git annex init" - , maybe Nothing (makeAuthorizedKeys sshdata) keypair + , if needsPubKey sshdata + then maybe Nothing (Just . makeAuthorizedKeysCommand (rsyncOnly sshdata) . sshPubKey) keypair + else Nothing ] makeSshRepo :: Bool -> SshData -> Handler RepHtml diff --git a/Utility/Verifiable.hs b/Utility/Verifiable.hs index b177787c4..d586d7453 100644 --- a/Utility/Verifiable.hs +++ b/Utility/Verifiable.hs @@ -24,14 +24,14 @@ data Verifiable a = Verifiable mkVerifiable :: Show a => a -> Secret -> Verifiable a mkVerifiable a secret = Verifiable a (calcDigest (show a) secret) -verified :: (Eq a, Show a) => Verifiable a -> Secret -> Bool -verified v secret = v == mkVerifiable (verifiableVal v) secret +verify :: (Eq a, Show a) => Verifiable a -> Secret -> Bool +verify v secret = v == mkVerifiable (verifiableVal v) secret calcDigest :: String -> Secret -> HMACDigest calcDigest v secret = showDigest $ hmacSha1 secret $ fromString v {- for quickcheck -} prop_verifiable_sane :: String -> String -> Bool -prop_verifiable_sane a s = verified (mkVerifiable a secret) secret +prop_verifiable_sane a s = verify (mkVerifiable a secret) secret where secret = fromString s diff --git a/templates/configurators/pairing/inprogress.hamlet b/templates/configurators/pairing/inprogress.hamlet index 7b655b5a9..5398a9dd2 100644 --- a/templates/configurators/pairing/inprogress.hamlet +++ b/templates/configurators/pairing/inprogress.hamlet @@ -1,10 +1,15 @@ <div .span9 .hero-unit> <h2> Pairing in progress .. - <p> - Now you should either go tell the owner of the computer you want to pair # - with the secret phrase you selected ("#{secret}"), or go enter it into # - the computer you want to pair with. - <p> - You do not need to leave this page open; pairing will finish automatically # - as soon as the secret phrase is entered into the other computer. + $if T.null secret + <p> + You do not need to leave this page open; pairing will finish # + automatically. + $else + <p> + Now you should either go tell the owner of the computer you want to pair # + with the secret phrase you selected ("#{secret}"), or go enter it into # + the computer you want to pair with. + <p> + You do not need to leave this page open; pairing will finish automatically # + as soon as the secret phrase is entered into the other computer. |