summaryrefslogtreecommitdiff
path: root/src/Contact.hs
blob: 2d1e2a9f5395f287776657842ab262a0abf07953 (plain)
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
module Contact (
    Contact,
    contactIdentity,
    contactCustomName,
    contactName,

    contactSetName,

    ContactService,
    contactRequest,
    contactAccept,
    contactReject,
) where

import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader

import Data.Maybe
import Data.Proxy
import Data.Text (Text)
import qualified Data.Text as T

import Identity
import Network
import Pairing
import PubKey
import Service
import Set
import State
import Storage
import Storage.Merge

data Contact = Contact
    { contactData :: [Stored ContactData]
    , contactIdentity_ :: Maybe ComposedIdentity
    , contactCustomName_ :: Maybe Text
    }

data ContactData = ContactData
    { cdPrev :: [Stored ContactData]
    , cdIdentity :: [Stored (Signed IdentityData)]
    , cdName :: Maybe Text
    }

instance Storable ContactData where
    store' x = storeRec $ do
        mapM_ (storeRef "PREV") $ cdPrev x
        mapM_ (storeRef "identity") $ cdIdentity x
        storeMbText "name" $ cdName x

    load' = loadRec $ ContactData
        <$> loadRefs "PREV"
        <*> loadRefs "identity"
        <*> loadMbText "name"

instance Mergeable Contact where
    type Component Contact = ContactData

    mergeSorted cdata = Contact
        { contactData = cdata
        , contactIdentity_ = validateIdentityF $ concat $ findProperty ((\case [] -> Nothing; xs -> Just xs) . cdIdentity) cdata
        , contactCustomName_ = findPropertyFirst cdName cdata
        }

    toComponents = contactData

instance SharedType (Set Contact) where
    sharedTypeID _ = mkSharedTypeID "34fbb61e-6022-405f-b1b3-a5a1abecd25e"

contactIdentity :: Contact -> Maybe ComposedIdentity
contactIdentity = contactIdentity_

contactCustomName :: Contact -> Maybe Text
contactCustomName = contactCustomName_

contactName :: Contact -> Text
contactName c = fromJust $ msum
    [ contactCustomName c
    , idName =<< contactIdentity c
    , Just T.empty
    ]

contactSetName :: MonadHead LocalState m => Contact -> Text -> Set Contact -> m (Set Contact)
contactSetName contact name set = do
    st <- getStorage
    cdata <- wrappedStore st ContactData
        { cdPrev = toComponents contact
        , cdIdentity = []
        , cdName = Just name
        }
    storeSetAdd st (mergeSorted @Contact [cdata]) set


type ContactService = PairingService ContactAccepted

data ContactAccepted = ContactAccepted

instance Storable ContactAccepted where
    store' ContactAccepted = storeRec $ do
        storeText "accept" ""
    load' = loadRec $ do
        (_ :: T.Text) <- loadText "accept"
        return ContactAccepted

instance PairingResult ContactAccepted where
    pairingServiceID _ = mkServiceID "d9c37368-0da1-4280-93e9-d9bd9a198084"

    pairingVerifyResult = return . Just

    pairingFinalizeRequest ContactAccepted = do
        pid <- asks svcPeerIdentity
        finalizeContact pid

    pairingFinalizeResponse = do
        pid <- asks svcPeerIdentity
        finalizeContact pid
        return ContactAccepted

    defaultPairingAttributes _ = PairingAttributes
        { pairingHookRequest = do
            peer <- asks $ svcPeerIdentity
            svcPrint $ "Contact pairing from " ++ T.unpack (displayIdentity peer) ++ " initiated"

        , pairingHookResponse = \confirm -> do
            peer <- asks $ svcPeerIdentity
            svcPrint $ "Confirm contact " ++ T.unpack (displayIdentity $ finalOwner peer) ++ ": " ++ confirm

        , pairingHookRequestNonce = \confirm -> do
            peer <- asks $ svcPeerIdentity
            svcPrint $ "Contact request from " ++ T.unpack (displayIdentity $ finalOwner peer) ++ ": " ++ confirm

        , pairingHookRequestNonceFailed = do
            peer <- asks $ svcPeerIdentity
            svcPrint $ "Failed contact request from " ++ T.unpack (displayIdentity peer)

        , pairingHookConfirmedResponse = do
            svcPrint $ "Contact accepted, waiting for peer confirmation"

        , pairingHookConfirmedRequest = do
            svcPrint $ "Contact confirmed by peer"

        , pairingHookAcceptedResponse = do
            svcPrint $ "Contact accepted"

        , pairingHookAcceptedRequest = do
            svcPrint $ "Contact accepted"

        , pairingHookVerifyFailed = return ()

        , pairingHookRejected = do
            svcPrint $ "Contact rejected by peer"

        , pairingHookFailed = \_ -> do
            svcPrint $ "Contact failed"
        }

contactRequest :: (MonadIO m, MonadError String m) => Peer -> m ()
contactRequest = pairingRequest @ContactAccepted Proxy

contactAccept :: (MonadIO m, MonadError String m) => Peer -> m ()
contactAccept = pairingAccept @ContactAccepted Proxy

contactReject :: (MonadIO m, MonadError String m) => Peer -> m ()
contactReject = pairingReject @ContactAccepted Proxy

finalizeContact :: MonadHead LocalState m => UnifiedIdentity -> m ()
finalizeContact identity = updateLocalHead_ $ updateSharedState_ $ \contacts -> do
    st <- getStorage
    cdata <- wrappedStore st ContactData
        { cdPrev = []
        , cdIdentity = idDataF $ finalOwner identity
        , cdName = Nothing
        }
    storeSetAdd st (mergeSorted @Contact [cdata]) contacts