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
|
module Erebos.Invite (
Invite(..),
InviteData(..),
InviteService,
InviteServiceAttributes(..),
createSingleContactInvite,
acceptInvite,
) where
import Control.Arrow
import Control.Monad
import Control.Monad.Except
import Control.Monad.IO.Class
import Control.Monad.Reader
import Crypto.Random
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as BC
import Data.Foldable
import Data.Ord
import Data.Text (Text)
import Erebos.Contact
import Erebos.Identity
import Erebos.Network
import Erebos.Object
import Erebos.PubKey
import Erebos.Service
import Erebos.Set
import Erebos.State
import Erebos.Storable
import Erebos.Storage.Merge
import Erebos.Util
data Invite = Invite
{ inviteData :: [ Stored InviteData ]
, inviteToken :: Maybe ByteString
, inviteAccepted :: [ Stored (Signed ExtendedIdentityData) ]
, inviteContact :: Maybe Text
}
data InviteData = InviteData
{ invdPrev :: [ Stored InviteData ]
, invdToken :: Maybe ByteString
, invdAccepted :: Maybe (Stored (Signed ExtendedIdentityData))
, invdContact :: Maybe Text
}
instance Storable InviteData where
store' x = storeRec $ do
mapM_ (storeRef "PREV") $ invdPrev x
mapM_ (storeBinary "token") $ invdToken x
mapM_ (storeRef "accepted") $ invdAccepted x
mapM_ (storeText "contact") $ invdContact x
load' = loadRec $ InviteData
<$> loadRefs "PREV"
<*> loadMbBinary "token"
<*> loadMbRef "accepted"
<*> loadMbText "contact"
instance Mergeable Invite where
type Component Invite = InviteData
mergeSorted invdata = Invite
{ inviteData = invdata
, inviteToken = findPropertyFirst invdToken invdata
, inviteAccepted = findProperty invdAccepted invdata
, inviteContact = findPropertyFirst invdContact invdata
}
toComponents = inviteData
instance SharedType (Set Invite) where
sharedTypeID _ = mkSharedTypeID "78da787a-9380-432e-a51d-532a30d27b3d"
createSingleContactInvite :: MonadHead LocalState m => Text -> m Invite
createSingleContactInvite name = do
token <- liftIO $ getRandomBytes 32
invite <- mergeSorted @Invite . (: []) <$> mstore InviteData
{ invdPrev = []
, invdToken = Just token
, invdAccepted = Nothing
, invdContact = Just name
}
updateLocalState_ $ updateSharedState_ $ \invites -> do
storeSetAdd invite invites
return invite
identityOwnerDigests :: Foldable f => Identity f -> [ RefDigest ]
identityOwnerDigests pid = map (refDigest . storedRef) $ concatMap toList $ toList $ generations $ idExtDataF $ finalOwner pid
acceptInvite :: (MonadIO m, MonadError e m, FromErebosError e) => Server -> RefDigest -> ByteString -> m ()
acceptInvite server from token = do
let matchPeer peer = do
getPeerIdentity peer >>= \case
PeerIdentityFull pid -> do
return $ from `elem` identityOwnerDigests pid
_ -> return False
liftIO (findPeer server matchPeer) >>= \case
Just peer -> runPeerService @InviteService peer $ do
svcModify (token :)
replyPacket $ AcceptInvite token
Nothing -> do
throwOtherError "peer not found"
data InviteService
= AcceptInvite ByteString
| InvalidInvite ByteString
| ContactInvite ByteString (Maybe Text)
| UnknownInvitePacket
data InviteServiceAttributes = InviteServiceAttributes
{ inviteHookAccepted :: ByteString -> ServiceHandler InviteService ()
, inviteHookReplyContact :: ByteString -> Maybe Text -> ServiceHandler InviteService ()
, inviteHookReplyInvalid :: ByteString -> ServiceHandler InviteService ()
}
defaultInviteServiceAttributes :: InviteServiceAttributes
defaultInviteServiceAttributes = InviteServiceAttributes
{ inviteHookAccepted = \_ -> return ()
, inviteHookReplyContact = \_ _ -> return ()
, inviteHookReplyInvalid = \_ -> return ()
}
instance Storable InviteService where
store' x = storeRec $ case x of
AcceptInvite token -> storeBinary "accept" token
InvalidInvite token -> storeBinary "invalid" token
ContactInvite token mbName -> do
storeBinary "valid" token
maybe (storeEmpty "contact") (storeText "contact") mbName
UnknownInvitePacket -> return ()
load' = loadRec $ msum
[ AcceptInvite <$> loadBinary "accept"
, InvalidInvite <$> loadBinary "invalid"
, ContactInvite <$> loadBinary "valid" <*> msum
[ return Nothing <* loadEmpty "contact"
, Just <$> loadText "contact"
]
, return UnknownInvitePacket
]
instance Service InviteService where
serviceID _ = mkServiceID "70bff715-6856-43a0-8c58-007a06a26eb1"
type ServiceState InviteService = [ ByteString ] -- accepted invites, waiting for reply
emptyServiceState _ = []
type ServiceAttributes InviteService = InviteServiceAttributes
defaultServiceAttributes _ = defaultInviteServiceAttributes
serviceHandler = fromStored >>> \case
AcceptInvite token -> do
asks (inviteHookAccepted . svcAttributes) >>= ($ token)
invites <- fromSetBy (comparing inviteToken) . lookupSharedValue . lsShared . fromStored <$> getLocalHead
case find ((Just token ==) . inviteToken) invites of
Just invite
| Just name <- inviteContact invite
, [] <- inviteAccepted invite
-> do
identity <- asks svcPeerIdentity
cdata <- mstore ContactData
{ cdPrev = []
, cdIdentity = idExtDataF $ finalOwner identity
, cdName = Just name
}
invdata <- mstore InviteData
{ invdPrev = inviteData invite
, invdToken = Nothing
, invdAccepted = Just (idExtData identity)
, invdContact = Nothing
}
updateLocalState_ $ updateSharedState_ $ storeSetAdd (mergeSorted @Contact [ cdata ])
updateLocalState_ $ updateSharedState_ $ storeSetAdd (mergeSorted @Invite [ invdata ])
replyPacket $ ContactInvite token Nothing
| otherwise -> do
replyPacket $ InvalidInvite token
Nothing -> do
replyPacket $ InvalidInvite token
InvalidInvite token -> do
asks (inviteHookReplyInvalid . svcAttributes) >>= ($ token)
svcModify $ filter (/= token)
svcPrint $ "Invite " <> BC.unpack (showHex token) <> " rejected as invalid"
ContactInvite token mbName -> do
asks (inviteHookReplyContact . svcAttributes) >>= ($ mbName) . ($ token)
waitingTokens <- svcGet
if token `elem` waitingTokens
then do
svcSet $ filter (/= token) waitingTokens
identity <- asks svcPeerIdentity
cdata <- mstore ContactData
{ cdPrev = []
, cdIdentity = idExtDataF $ finalOwner identity
, cdName = Nothing
}
updateLocalState_ $ updateSharedState_ $ storeSetAdd (mergeSorted @Contact [ cdata ])
else do
svcPrint $ "Received unexpected invite response for " <> BC.unpack (showHex token)
UnknownInvitePacket -> do
svcPrint $ "Received unknown invite packet"
|