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
|
{- git-annex assistant thread to listen for incoming pairing traffic
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Threads.PairListener where
import Assistant.Common
import Assistant.Pairing
import Assistant.Pairing.Network
import Assistant.Pairing.MakeRemote
import Assistant.ThreadedMonad
import Assistant.ScanRemotes
import Assistant.DaemonStatus
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.Alert
import Utility.Verifiable
import Utility.Tense
import Network.Multicast
import Network.Socket
import qualified Data.Text as T
thisThread :: ThreadName
thisThread = "PairListener"
pairListenerThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> UrlRenderer -> NamedThread
pairListenerThread st dstatus scanremotes urlrenderer = thread $ withSocketsDo $ do
sock <- multicastReceiver (multicastAddress $ IPv4Addr undefined) pairingPort
go sock
where
thread = NamedThread thisThread
go sock = do
msg <- getmsg sock []
dispatch $ readish msg
go sock
getmsg sock c = do
(msg, n, _) <- recvFrom sock chunksz
if n < chunksz
then return $ c ++ msg
else getmsg sock $ c ++ msg
where
chunksz = 1024
dispatch Nothing = noop
dispatch (Just m@(PairMsg v)) = do
pip <- pairingInProgress <$> getDaemonStatus dstatus
let verified = maybe False (verify v . inProgressSecret) pip
case pairMsgStage m of
PairReq -> pairReqReceived verified dstatus urlrenderer m
PairAck -> pairAckReceived verified pip st dstatus scanremotes m
PairDone -> pairDoneReceived verified pip st dstatus scanremotes m
{- Show an alert when a PairReq is seen.
-
- Pair request alerts from the same host combine,
- so repeated requests do not add additional alerts. -}
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.") $
AlertButton
{ buttonUrl = url
, buttonLabel = T.pack "Respond"
, buttonAction = Just onclick
}
where
pairdata = pairMsgData msg
repo = concat
[ remoteUserName pairdata
, "@"
, fromMaybe (showAddr $ pairMsgAddr msg)
(remoteHostName pairdata)
, ":"
, (remoteDirectory pairdata)
]
{- 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
- and would re-add it. -}
onclick i = updateAlert dstatus i $ \alert -> Just $ alert
{ alertButton = Nothing
, alertClass = Activity
, alertIcon = Just ActivityIcon
, alertData = [UnTensed $ T.pack $ "pair request with " ++ repo ++ " in progress"]
}
{- When a verified PairAck is seen, a host is ready to pair with us, and has
- already configured our ssh key. Stop sending PairReqs, finish the pairing,
- and send a single PairDone.
-
- TODO: 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.
-}
pairAckReceived :: Bool -> Maybe PairingInProgress -> ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PairMsg -> IO ()
pairAckReceived False _ _ _ _ _ = noop -- not verified
pairAckReceived True Nothing _ _ _ _ = noop -- not in progress
pairAckReceived True (Just pip) st dstatus scanremotes msg = do
stopSending dstatus pip
setupAuthorizedKeys msg
finishedPairing st dstatus scanremotes msg (inProgressSshKeyPair pip)
startSending dstatus pip $ multicastPairMsg
(Just 1) (inProgressSecret pip) PairDone (inProgressPairData pip)
{- If we get a verified PairDone, the host has accepted our PairAck, and
- has paired with us. Stop sending PairAcks, and finish pairing with them.
-
- TODO: Should third-party hosts remove their pair request alert when they
- see a PairDone? How to tell if a PairDone matches with the PairReq
- that brought up the alert? Cannot verify it without the secret..
-}
pairDoneReceived :: Bool -> Maybe PairingInProgress -> ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> PairMsg -> IO ()
pairDoneReceived False _ _ _ _ _ = noop -- not verified
pairDoneReceived True Nothing _ _ _ _ = noop -- not in progress
pairDoneReceived True (Just pip) st dstatus scanremotes msg = do
stopSending dstatus pip
finishedPairing st dstatus scanremotes msg (inProgressSshKeyPair pip)
|
