add buddy list to pairing UI

This commit is contained in:
Joey Hess 2012-11-02 21:13:06 -04:00
parent 2ae43e71e0
commit 6a61829e2d
18 changed files with 252 additions and 84 deletions

View file

@ -14,6 +14,8 @@ import Assistant.Pairing
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Assistant.WebApp.Configurators.XMPP
import Assistant.Types.Buddies
import Utility.Yesod
#ifdef WITH_PAIRING
import Assistant.Common
@ -26,6 +28,10 @@ import Utility.Verifiable
import Utility.Network
import Annex.UUID
#endif
#ifdef WITH_XMPP
import Assistant.XMPP.Client
import Network.Protocol.XMPP
#endif
import Utility.UserInfo
import Yesod
@ -39,22 +45,55 @@ import qualified Control.Exception as E
import Control.Concurrent
#endif
{- Starts sending out pair requests. -}
{- Starts either kind of pairing. -}
getStartPairR :: Handler RepHtml
#ifdef WITH_XMPP
getStartPairR = pairPage $ do
xmppconfigured <- lift $ isJust <$> runAnnex Nothing getXMPPCreds
#ifdef WITH_PAIRING
getStartPairR = promptSecret Nothing $ startPairing PairReq noop pairingAlert Nothing
let localsupported = True
#else
getStartPairR = noPairing
let localsupported = False
#endif
$(widgetFile "configurators/pairing/start")
#else
#ifdef WITH_PAIRING
getStartPairR = redirect StartLocalPairR
#else
getStartPairR = noPairing "local or jabber"
#endif
#endif
{- Runs on the system that responds to a pair request; sets up the ssh
{- Starts pairing with an XMPP buddy. -}
getStartXMPPPairR :: BuddyID -> Handler RepHtml
#ifdef WITH_XMPP
getStartXMPPPairR (BuddyID bid) = case parseJID bid of
Nothing -> error "bad JID"
Just jid -> error "TODO"
#else
getStartXMPPPairR _ = noPairing "XMPP"
#endif
{- Starts local pairing. -}
getStartLocalPairR :: Handler RepHtml
#ifdef WITH_PAIRING
getStartLocalPairR = promptSecret Nothing $
startLocalPairing PairReq noop pairingAlert Nothing
#else
getStartLocalPairR = noLocalPairing
noLocalPairing :: Handler RepHtml
noLocalPairing = noPairing "local"
#endif
{- Runs on the system that responds to a local pair request; sets up the ssh
- authorized key first so that the originating host can immediately sync
- with us. -}
getFinishPairR :: PairMsg -> Handler RepHtml
getFinishLocalPairR :: PairMsg -> Handler RepHtml
#ifdef WITH_PAIRING
getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do
getFinishLocalPairR msg = promptSecret (Just msg) $ \_ secret -> do
liftIO $ setup
startPairing PairAck cleanup alert uuid "" secret
startLocalPairing PairAck cleanup alert uuid "" secret
where
alert = pairRequestAcknowledgedAlert (pairRepo msg) . Just
setup = setupAuthorizedKeys msg
@ -62,21 +101,21 @@ getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do
remoteSshPubKey $ pairMsgData msg
uuid = Just $ pairUUID $ pairMsgData msg
#else
getFinishPairR _ = noPairing
getFinishLocalPairR _ = noLocalPairing
#endif
getInprogressPairR :: SecretReminder -> Handler RepHtml
getRunningLocalPairR :: SecretReminder -> Handler RepHtml
#ifdef WITH_PAIRING
getInprogressPairR s = pairPage $ do
getRunningLocalPairR s = pairPage $ do
let secret = fromSecretReminder s
$(widgetFile "configurators/pairing/inprogress")
$(widgetFile "configurators/pairing/local/inprogress")
#else
getInprogressPairR _ = noPairing
getRunningLocalPairR _ = noLocalPairing
#endif
#ifdef WITH_PAIRING
{- Starts pairing, at either the PairReq (initiating host) or
{- Starts local pairing, at either the PairReq (initiating host) or
- PairAck (responding host) stage.
-
- Displays an alert, and starts a thread sending the pairing message,
@ -85,8 +124,8 @@ getInprogressPairR _ = noPairing
-
- 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
startLocalPairing :: PairStage -> IO () -> (AlertButton -> Alert) -> Maybe UUID -> Text -> Secret -> Widget
startLocalPairing stage oncancel alert muuid displaysecret secret = do
urlrender <- lift getUrlRender
reldir <- fromJust . relDir <$> lift getYesod
@ -106,7 +145,7 @@ startPairing stage oncancel alert muuid displaysecret secret = do
startSending pip stage $ sendrequests sender
void $ liftIO $ forkIO thread
lift $ redirect $ InprogressPairR $ toSecretReminder displaysecret
lift $ redirect $ RunningLocalPairR $ toSecretReminder displaysecret
where
{- Sends pairing messages until the thread is killed,
- and shows an activity alert while doing it.
@ -164,7 +203,7 @@ promptSecret msg cont = pairPage $ do
u <- T.pack <$> liftIO myUserName
let sameusername = username == u
let authtoken = webAppFormAuthToken
$(widgetFile "configurators/pairing/prompt")
$(widgetFile "configurators/pairing/local/prompt")
{- This counts unicode characters as more than one character,
- but that's ok; they *do* provide additional entropy. -}
@ -189,8 +228,8 @@ sampleQuote = T.unwords
#else
noPairing :: Handler RepHtml
noPairing = pairPage $
noPairing :: Text -> Handler RepHtml
noPairing pairingtype = pairPage $
$(widgetFile "configurators/pairing/disabled")
#endif

View file

@ -12,13 +12,17 @@ module Assistant.WebApp.Configurators.XMPP where
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.Notifications
import Assistant.WebApp.SideBar
import Assistant.Types.Buddies
import Assistant.Alert
import Assistant.DaemonStatus
import Utility.Yesod
#ifdef WITH_XMPP
import Utility.NotificationBroadcaster
import Assistant.Common
#ifdef WITH_XMPP
import Assistant.XMPP.Client
import Assistant.XMPP.Buddies
import Assistant.Pushes
import Utility.SRV
#endif
@ -45,7 +49,23 @@ xmppNeeded = whenM (isNothing <$> runAnnex Nothing getXMPPCreds) $ do
getXMPPR :: Handler RepHtml
#ifdef WITH_XMPP
getXMPPR = xmppPage $ do
getXMPPR = getXMPPR' ConfigR
#else
getXMPPR = xmppPage $
$(widgetFile "configurators/xmpp/disabled")
#endif
getXMPPForPairingR :: Handler RepHtml
#ifdef WITH_XMPP
getXMPPForPairingR = getXMPPR' StartPairR
#else
getXMPPForPairingR = xmppPage $
$(widgetFile "configurators/xmpp/disabled")
#endif
#ifdef WITH_XMPP
getXMPPR' :: Route WebApp -> Handler RepHtml
getXMPPR' redirto = xmppPage $ do
((result, form), enctype) <- lift $ do
oldcreds <- runAnnex Nothing getXMPPCreds
runFormGet $ renderBootstrap $ xmppAForm $
@ -61,12 +81,33 @@ getXMPPR = xmppPage $ do
storecreds creds = do
void $ runAnnex undefined $ setXMPPCreds creds
liftAssistant notifyRestart
redirect ConfigR
#else
getXMPPR = xmppPage $
$(widgetFile "configurators/xmpp/disabled")
redirect redirto
#endif
{- Called by client to get a list of buddies.
-
- Returns a div, which will be inserted into the calling page.
-}
getBuddyListR :: NotificationId -> Handler RepHtml
getBuddyListR nid = do
waitNotifier getBuddyListBroadcaster nid
page <- widgetToPageContent $ buddyListDisplay
hamletToRepHtml $ [hamlet|^{pageBody page}|]
buddyListDisplay :: Widget
buddyListDisplay = do
autoUpdate ident NotifierBuddyListR (10 :: Int) (10 :: Int)
#ifdef WITH_XMPP
buddies <- lift $ liftAssistant $ catMaybes . map buddySummary
<$> (getBuddyList <<~ buddyList)
#else
let buddies = []
#endif
$(widgetFile "configurators/xmpp/buddylist")
where
ident = "buddylist"
#ifdef WITH_XMPP
data XMPPForm = XMPPForm