diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index 65f8c3e674..40c37a94a8 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -34,6 +34,7 @@ data AlertName | WarningAlert String | PairAlert String | XMPPNeededAlert + | CloudRepoNeededAlert deriving (Eq) {- The first alert is the new alert, the second is an old alert. @@ -333,6 +334,24 @@ xmppNeededAlert button = Alert , alertData = [] } +cloudRepoNeededAlert :: Maybe String -> AlertButton -> Alert +cloudRepoNeededAlert friendname button = Alert + { alertHeader = Just $ fromString $ unwords + [ "Unable to download files from" + , (fromMaybe "your other devices" friendname) ++ "." + ] + , alertIcon = Just ErrorIcon + , alertPriority = High + , alertButton = Just button + , alertClosable = True + , alertClass = Message + , alertMessageRender = tenseWords + , alertBlockDisplay = True + , alertName = Just $ CloudRepoNeededAlert + , alertCombiner = Just $ dataCombiner $ \_old new -> new + , alertData = [] + } + fileAlert :: TenseChunk -> FilePath -> Alert fileAlert msg file = (activityAlert Nothing [f]) { alertName = Just $ FileAlert msg diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index ea57176b54..fcfb1a4f3f 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -51,10 +51,14 @@ calcSyncRemotes = do alive <- trustExclude DeadTrusted (map Remote.uuid rs) let good r = Remote.uuid r `elem` alive let syncable = filter good rs + let nonxmpp = filter (not . isXMPPRemote) syncable return $ \dstatus -> dstatus { syncRemotes = syncable - , syncGitRemotes = filter (not . Remote.specialRemote) syncable - , syncDataRemotes = filter (not . isXMPPRemote) syncable + , syncGitRemotes = + filter (not . Remote.specialRemote) syncable + , syncDataRemotes = nonxmpp + , syncingToCloudRemote = + any (Git.repoIsUrl . Remote.repo) nonxmpp } {- Updates the sycRemotes list from the list of all remotes in Annex state. -} diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index fb7da10c7b..69a886c4af 100644 --- a/Assistant/Threads/XMPPClient.hs +++ b/Assistant/Threads/XMPPClient.hs @@ -111,7 +111,7 @@ xmppClient urlrenderer d creds = handle _ (GotNetMessage m@(Pushing _ pushstage)) | isPushInitiation pushstage = inAssistant $ unlessM (queueNetPushMessage m) $ - void $ forkIO <~> handlePushInitiation m + void $ forkIO <~> handlePushInitiation urlrenderer m | otherwise = void $ inAssistant $ queueNetPushMessage m handle _ (Ignorable _) = noop handle _ (Unknown _) = noop diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs index df95b23c01..0fc800a37e 100644 --- a/Assistant/Types/DaemonStatus.hs +++ b/Assistant/Types/DaemonStatus.hs @@ -46,6 +46,8 @@ data DaemonStatus = DaemonStatus , syncGitRemotes :: [Remote] -- Ordered list of remotes to sync data with , syncDataRemotes :: [Remote] + -- Are we syncing to any cloud remotes? + , syncingToCloudRemote :: Bool -- List of uuids of remotes that we may have gotten out of sync with. , desynced :: S.Set UUID -- Pairing request that is in progress. @@ -81,6 +83,7 @@ newDaemonStatus = DaemonStatus <*> pure [] <*> pure [] <*> pure [] + <*> pure False <*> pure S.empty <*> pure Nothing <*> newNotificationBroadcaster diff --git a/Assistant/WebApp/Configurators/Pairing.hs b/Assistant/WebApp/Configurators/Pairing.hs index 100c122ab6..d9aacab8a5 100644 --- a/Assistant/WebApp/Configurators/Pairing.hs +++ b/Assistant/WebApp/Configurators/Pairing.hs @@ -186,12 +186,6 @@ getFinishXMPPPairR _ = noXMPPPairing xmppPairStatus :: Bool -> Maybe JID -> Handler RepHtml xmppPairStatus inprogress theirjid = pairPage $ do let friend = buddyName <$> theirjid - let cloudrepolist = repoListDisplay $ RepoSelector - { onlyCloud = True - , onlyConfigured = False - , includeHere = False - , nudgeAddMore = False - } $(widgetFile "configurators/pairing/xmpp/end") #endif diff --git a/Assistant/WebApp/Configurators/XMPP.hs b/Assistant/WebApp/Configurators/XMPP.hs index ebe0754f0a..0a136a2e4a 100644 --- a/Assistant/WebApp/Configurators/XMPP.hs +++ b/Assistant/WebApp/Configurators/XMPP.hs @@ -13,6 +13,7 @@ module Assistant.WebApp.Configurators.XMPP where import Assistant.WebApp.Common import Assistant.WebApp.Notifications import Utility.NotificationBroadcaster +import qualified Remote #ifdef WITH_XMPP import Assistant.XMPP.Client import Assistant.XMPP.Buddies @@ -21,6 +22,9 @@ import Assistant.NetMessager import Assistant.Alert import Assistant.DaemonStatus import Utility.SRV +import Assistant.WebApp.RepoList +import Assistant.WebApp.Configurators +import Assistant.XMPP #endif #ifdef WITH_XMPP @@ -30,7 +34,7 @@ import qualified Data.Text as T import Control.Exception (SomeException) #endif -{- Displays an alert suggesting to configure XMPP, with a button. -} +{- Displays an alert suggesting to configure XMPP. -} xmppNeeded :: Handler () #ifdef WITH_XMPP xmppNeeded = whenM (isNothing <$> liftAnnex getXMPPCreds) $ do @@ -46,6 +50,48 @@ xmppNeeded = whenM (isNothing <$> liftAnnex getXMPPCreds) $ do xmppNeeded = return () #endif +{- Displays an alert suggesting to configure a cloud repo + - to suppliment an XMPP remote. -} +cloudRepoNeeded :: UrlRenderer -> UUID -> Assistant () +#ifdef WITH_XMPP +cloudRepoNeeded urlrenderer for = do + buddyname <- getBuddyName for + url <- liftIO $ renderUrl urlrenderer (NeedCloudRepoR for) [] + close <- asIO1 removeAlert + void $ addAlert $ cloudRepoNeededAlert buddyname $ AlertButton + { buttonLabel = "Add a cloud repository" + , buttonUrl = url + , buttonAction = Just close + } +#else +cloudRepoNeeded = return () +#endif + +{- Returns the name of the friend corresponding to a + - repository's UUID, but not if it's our name. -} +getBuddyName :: UUID -> Assistant (Maybe String) +getBuddyName u = go =<< getclientjid + where + go Nothing = return Nothing + go (Just myjid) = (T.unpack . buddyName <$>) + . headMaybe + . filter (\j -> baseJID j /= baseJID myjid) + . map fst + . filter (\(_, r) -> Remote.uuid r == u) + <$> getXMPPRemotes + getclientjid = maybe Nothing parseJID . xmppClientID + <$> getDaemonStatus + +getNeedCloudRepoR :: UUID -> Handler RepHtml +#ifdef WITH_XMPP +getNeedCloudRepoR for = page "Cloud repository needed" (Just Configuration) $ do + buddyname <- lift $ liftAssistant $ getBuddyName for + $(widgetFile "configurators/xmpp/needcloudrepo") +#else +needCloudRepoR = xmppPage $ + $(widgetFile "configurators/xmpp/disabled") +#endif + getXMPPR :: Handler RepHtml #ifdef WITH_XMPP getXMPPR = xmppPage $ do @@ -86,8 +132,7 @@ buddyListDisplay = do myjid <- lift $ liftAssistant $ xmppClientID <$> getDaemonStatus let isself (BuddyKey b) = Just b == myjid buddies <- lift $ liftAssistant $ do - rs <- filter isXMPPRemote . syncGitRemotes <$> getDaemonStatus - let pairedwith = catMaybes $ map (parseJID . getXMPPClientID) rs + pairedwith <- map fst <$> getXMPPRemotes catMaybes . map (buddySummary pairedwith) <$> (getBuddyList <<~ buddyList) $(widgetFile "configurators/xmpp/buddylist") @@ -97,6 +142,13 @@ buddyListDisplay = do #ifdef WITH_XMPP +getXMPPRemotes :: Assistant [(JID, Remote)] +getXMPPRemotes = catMaybes . map pair . filter isXMPPRemote . syncGitRemotes + <$> getDaemonStatus + where + pair r = maybe Nothing (\jid -> Just (jid, r)) $ + parseJID $ getXMPPClientID r + data XMPPForm = XMPPForm { formJID :: Text , formPassword :: Text } diff --git a/Assistant/WebApp/RepoList.hs b/Assistant/WebApp/RepoList.hs index a09c9475fc..fa24055a1d 100644 --- a/Assistant/WebApp/RepoList.hs +++ b/Assistant/WebApp/RepoList.hs @@ -81,6 +81,15 @@ mainRepoSelector = RepoSelector , nudgeAddMore = False } +{- List of cloud repositories, configured and not. -} +cloudRepoList :: Widget +cloudRepoList = repoListDisplay $ RepoSelector + { onlyCloud = True + , onlyConfigured = False + , includeHere = False + , nudgeAddMore = False + } + repoListDisplay :: RepoSelector -> Widget repoListDisplay reposelector = do autoUpdate ident (NotifierRepoListR reposelector) (10 :: Int) (10 :: Int) diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes index 258959bd3b..c6af3fa44c 100644 --- a/Assistant/WebApp/routes +++ b/Assistant/WebApp/routes @@ -16,6 +16,7 @@ /config ConfigurationR GET /config/preferences PreferencesR GET /config/xmpp XMPPR GET +/config/xmpp/needcloudrepo/#UUID NeedCloudRepoR GET /config/addrepository AddRepositoryR GET /config/repository/new/first FirstRepositoryR GET diff --git a/Assistant/XMPP/Git.hs b/Assistant/XMPP/Git.hs index a088f459ee..74ce4b7259 100644 --- a/Assistant/XMPP/Git.hs +++ b/Assistant/XMPP/Git.hs @@ -5,6 +5,8 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Assistant.XMPP.Git where import Assistant.Common @@ -29,6 +31,10 @@ import qualified Remote as Remote import Remote.List import Utility.FileMode import Utility.Shell +#ifdef WITH_WEBAPP +import Assistant.WebApp (UrlRenderer) +import Assistant.WebApp.Configurators.XMPP +#endif import Network.Protocol.XMPP import qualified Data.Text as T @@ -80,8 +86,8 @@ makeXMPPGitRemote buddyname jid u = do - - We listen at the other end of the pipe and relay to and from XMPP. -} -xmppPush :: ClientID -> (Git.Repo -> IO Bool) -> Assistant Bool -xmppPush cid gitpush = runPush SendPack cid handleDeferred $ do +xmppPush :: ClientID -> (Git.Repo -> IO Bool) -> (NetMessage -> Assistant ()) -> Assistant Bool +xmppPush cid gitpush handledeferred = runPush SendPack cid handledeferred $ do sendNetMessage $ Pushing cid StartingPush (Fd inf, writepush) <- liftIO createPipe @@ -201,8 +207,8 @@ xmppGitRelay = do {- Relays git receive-pack stdin and stdout via XMPP, as well as propigating - its exit status to XMPP. -} -xmppReceivePack :: ClientID -> Assistant Bool -xmppReceivePack cid = runPush ReceivePack cid handleDeferred $ do +xmppReceivePack :: ClientID -> (NetMessage -> Assistant ()) -> Assistant Bool +xmppReceivePack cid handledeferred = runPush ReceivePack cid handledeferred $ do repodir <- liftAnnex $ fromRepo repoPath let p = (proc "git" ["receive-pack", repodir]) { std_in = CreatePipe @@ -250,11 +256,11 @@ xmppRemotes cid = case baseJID <$> parseJID cid of where matching loc r = repoIsUrl r && repoLocation r == loc -handlePushInitiation :: NetMessage -> Assistant () -handlePushInitiation (Pushing cid CanPush) = +handlePushInitiation :: UrlRenderer -> NetMessage -> Assistant () +handlePushInitiation _ (Pushing cid CanPush) = unlessM (null <$> xmppRemotes cid) $ sendNetMessage $ Pushing cid PushRequest -handlePushInitiation (Pushing cid PushRequest) = +handlePushInitiation urlrenderer (Pushing cid PushRequest) = go =<< liftAnnex (inRepo Git.Branch.current) where go Nothing = noop @@ -266,18 +272,30 @@ handlePushInitiation (Pushing cid PushRequest) = <*> getUUID liftIO $ Command.Sync.updateBranch (Command.Sync.syncBranch branch) g selfjid <- ((T.unpack <$>) . xmppClientID) <$> getDaemonStatus - forM_ rs $ \r -> alertWhile (syncAlert [r]) $ - xmppPush cid $ taggedPush u selfjid branch r -handlePushInitiation (Pushing cid StartingPush) = do + forM_ rs $ \r -> do + void $ alertWhile (syncAlert [r]) $ + xmppPush cid + (taggedPush u selfjid branch r) + (handleDeferred urlrenderer) + checkCloudRepos urlrenderer r +handlePushInitiation urlrenderer (Pushing cid StartingPush) = do rs <- xmppRemotes cid - unless (null rs) $ + unless (null rs) $ do void $ alertWhile (syncAlert rs) $ - xmppReceivePack cid -handlePushInitiation _ = noop + xmppReceivePack cid (handleDeferred urlrenderer) + mapM_ (checkCloudRepos urlrenderer) rs +handlePushInitiation _ _ = noop -handleDeferred :: NetMessage -> Assistant () +handleDeferred :: UrlRenderer -> NetMessage -> Assistant () handleDeferred = handlePushInitiation +checkCloudRepos :: UrlRenderer -> Remote -> Assistant () +-- TODO only display if needed +checkCloudRepos urlrenderer r = +#ifdef WITH_WEBAPP + cloudRepoNeeded urlrenderer (Remote.uuid r) +#endif + writeChunk :: Handle -> B.ByteString -> IO () writeChunk h b = do B.hPut h b diff --git a/debian/changelog b/debian/changelog index 176234e86d..2300de0d64 100644 --- a/debian/changelog +++ b/debian/changelog @@ -3,6 +3,8 @@ git-annex (4.20130315) UNRELEASED; urgency=low * webapp: Repository list is now included in the dashboard, and other UI tweaks. * webapp: Improved UI for pairing your own devices together using XMPP. + * webapp: Display an alert when there are XMPP remotes, and a cloud + transfer repository needs to be configured. -- Joey Hess Fri, 15 Mar 2013 00:10:07 -0400 diff --git a/doc/assistant/cloudnudge.png b/doc/assistant/cloudnudge.png new file mode 100644 index 0000000000..b6f9a657e0 Binary files /dev/null and b/doc/assistant/cloudnudge.png differ diff --git a/templates/configurators/pairing/xmpp/end.hamlet b/templates/configurators/pairing/xmpp/end.hamlet index 3106a521cc..28d38b1c19 100644 --- a/templates/configurators/pairing/xmpp/end.hamlet +++ b/templates/configurators/pairing/xmpp/end.hamlet @@ -26,7 +26,7 @@ Make sure that your other devices are configured to access a # cloud repository, and that the same repository is enabled here # too. - ^{cloudrepolist} + ^{cloudRepoList}

Add a cloud repository ^{makeCloudRepositories True} diff --git a/templates/configurators/xmpp/needcloudrepo.hamlet b/templates/configurators/xmpp/needcloudrepo.hamlet new file mode 100644 index 0000000000..afae858c30 --- /dev/null +++ b/templates/configurators/xmpp/needcloudrepo.hamlet @@ -0,0 +1,17 @@ +
+

+ ☂ Configure a shared cloud repository + $maybe name <- buddyname +

+ You and #{name} have combined your repositores. But you can't open # + each other's files yet. To start sharing files with #{name}, # + you need a repository in the cloud, that you both can access. + $nothing +

+ You've combined the repositories on two or more of your devices. # + But files are not flowing yet. To start sharing files # + between your devices, you should set up a repository in the cloud. + ^{cloudRepoList} +

+ Add a cloud repository + ^{makeCloudRepositories True}