1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
|
{- git-annex assistant XMPP configuration
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, OverloadedStrings, FlexibleContexts #-}
{-# LANGUAGE CPP #-}
module Assistant.WebApp.Configurators.XMPP where
import Assistant.WebApp.Common
import Assistant.WebApp.Notifications
import Utility.NotificationBroadcaster
#ifdef WITH_XMPP
import qualified Remote
import Assistant.XMPP.Client
import Assistant.XMPP.Buddies
import Assistant.Types.Buddies
import Assistant.NetMessager
import Assistant.Alert
import Assistant.DaemonStatus
import Assistant.WebApp.RepoList
import Assistant.WebApp.Configurators
import Assistant.XMPP
#endif
import qualified Git.Remote.Remove
import Remote.List
import Creds
#ifdef WITH_XMPP
import Network.Protocol.XMPP
import Network
import qualified Data.Text as T
#endif
{- When appropriate, displays an alert suggesting to configure a cloud repo
- to suppliment an XMPP remote. -}
checkCloudRepos :: UrlRenderer -> Remote -> Assistant ()
#ifdef WITH_XMPP
checkCloudRepos urlrenderer r =
unlessM (syncingToCloudRemote <$> getDaemonStatus) $ do
buddyname <- getBuddyName $ Remote.uuid r
button <- mkAlertButton True "Add a cloud repository" urlrenderer $
NeedCloudRepoR $ Remote.uuid r
void $ addAlert $ cloudRepoNeededAlert buddyname button
#else
checkCloudRepos _ _ = noop
#endif
#ifdef WITH_XMPP
{- 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
#endif
getNeedCloudRepoR :: UUID -> Handler Html
#ifdef WITH_XMPP
getNeedCloudRepoR for = page "Cloud repository needed" (Just Configuration) $ do
buddyname <- liftAssistant $ getBuddyName for
$(widgetFile "configurators/xmpp/needcloudrepo")
#else
getNeedCloudRepoR _ = xmppPage $
$(widgetFile "configurators/xmpp/disabled")
#endif
getXMPPConfigR :: Handler Html
getXMPPConfigR = postXMPPConfigR
postXMPPConfigR :: Handler Html
postXMPPConfigR = xmppform DashboardR
getXMPPConfigForPairFriendR :: Handler Html
getXMPPConfigForPairFriendR = postXMPPConfigForPairFriendR
postXMPPConfigForPairFriendR :: Handler Html
postXMPPConfigForPairFriendR = xmppform StartXMPPPairFriendR
getXMPPConfigForPairSelfR :: Handler Html
getXMPPConfigForPairSelfR = postXMPPConfigForPairSelfR
postXMPPConfigForPairSelfR :: Handler Html
postXMPPConfigForPairSelfR = xmppform StartXMPPPairSelfR
xmppform :: Route WebApp -> Handler Html
#ifdef WITH_XMPP
xmppform next = xmppPage $ do
((result, form), enctype) <- liftH $ do
oldcreds <- liftAnnex getXMPPCreds
runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ xmppAForm $
creds2Form <$> oldcreds
let showform problem = $(widgetFile "configurators/xmpp")
case result of
FormSuccess f -> either (showform . Just) (liftH . storecreds)
=<< liftIO (validateForm f)
_ -> showform Nothing
where
storecreds creds = do
void $ liftAnnex $ setXMPPCreds creds
liftAssistant notifyNetMessagerRestart
redirect next
#else
xmppform _ = xmppPage $
$(widgetFile "configurators/xmpp/disabled")
#endif
{- Called by client to get a list of buddies.
-
- Returns a div, which will be inserted into the calling page.
-}
getBuddyListR :: NotificationId -> Handler Html
getBuddyListR nid = do
waitNotifier getBuddyListBroadcaster nid
p <- widgetToPageContent buddyListDisplay
withUrlRenderer $ [hamlet|^{pageBody p}|]
buddyListDisplay :: Widget
buddyListDisplay = do
autoUpdate ident NotifierBuddyListR (10 :: Int) (10 :: Int)
#ifdef WITH_XMPP
myjid <- liftAssistant $ xmppClientID <$> getDaemonStatus
let isself (BuddyKey b) = Just b == myjid
buddies <- liftAssistant $ do
pairedwith <- map fst <$> getXMPPRemotes
catMaybes . map (buddySummary pairedwith)
<$> (getBuddyList <<~ buddyList)
$(widgetFile "configurators/xmpp/buddylist")
#else
noop
#endif
where
ident = "buddylist"
#ifdef WITH_XMPP
getXMPPRemotes :: Assistant [(JID, Remote)]
getXMPPRemotes = catMaybes . map pair . filter Remote.isXMPPRemote . syncGitRemotes
<$> getDaemonStatus
where
pair r = maybe Nothing (\jid -> Just (jid, r)) $
parseJID $ getXMPPClientID r
data XMPPForm = XMPPForm
{ formJID :: Text
, formPassword :: Text }
creds2Form :: XMPPCreds -> XMPPForm
creds2Form c = XMPPForm (xmppJID c) (xmppPassword c)
xmppAForm :: (Maybe XMPPForm) -> MkAForm XMPPForm
xmppAForm def = XMPPForm
<$> areq jidField (bfs "Jabber address") (formJID <$> def)
<*> areq passwordField (bfs "Password") Nothing
jidField :: MkField Text
jidField = checkBool (isJust . parseJID) bad textField
where
bad :: Text
bad = "This should look like an email address.."
validateForm :: XMPPForm -> IO (Either String XMPPCreds)
validateForm f = do
let jid = fromMaybe (error "bad JID") $ parseJID (formJID f)
let username = fromMaybe "" (strNode <$> jidNode jid)
testXMPP $ XMPPCreds
{ xmppUsername = username
, xmppPassword = formPassword f
, xmppHostname = T.unpack $ strDomain $ jidDomain jid
, xmppPort = 5222
, xmppJID = formJID f
}
testXMPP :: XMPPCreds -> IO (Either String XMPPCreds)
testXMPP creds = do
(good, bad) <- partition (either (const False) (const True) . snd)
<$> connectXMPP creds (const noop)
case good of
(((h, PortNumber p), _):_) -> return $ Right $ creds
{ xmppHostname = h
, xmppPort = fromIntegral p
}
(((h, _), _):_) -> return $ Right $ creds
{ xmppHostname = h
}
_ -> return $ Left $ intercalate "; " $ map formatlog bad
where
formatlog ((h, p), Left e) = "host " ++ h ++ ":" ++ showport p ++ " failed: " ++ show e
formatlog _ = ""
showport (PortNumber n) = show n
showport (Service s) = s
showport (UnixSocket s) = s
#endif
getDisconnectXMPPR :: Handler Html
getDisconnectXMPPR = do
#ifdef WITH_XMPP
rs <- filter Remote.isXMPPRemote . syncRemotes
<$> liftAssistant getDaemonStatus
liftAnnex $ do
mapM_ (inRepo . Git.Remote.Remove.remove . Remote.name) rs
void remoteListRefresh
removeCreds xmppCredsFile
liftAssistant $ do
updateSyncRemotes
notifyNetMessagerRestart
redirect DashboardR
#else
xmppPage $ $(widgetFile "configurators/xmpp/disabled")
#endif
xmppPage :: Widget -> Handler Html
xmppPage = page "Jabber" (Just Configuration)
|
