summaryrefslogtreecommitdiff
path: root/src/Attach.hs
blob: c220e140bc74d7b407aa7e1e66a6dee9d82f44b3 (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
module Attach (
    AttachService,
    attachToOwner, attachAccept,
) where

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

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

import Identity
import Network
import Pairing
import PubKey
import Service
import State
import Storage
import Storage.Key

type AttachService = PairingService AttachIdentity

data AttachIdentity = AttachIdentity (Stored (Signed IdentityData)) [ScrubbedBytes]

instance Storable AttachIdentity where
    store' (AttachIdentity x keys) = storeRec $ do
         storeRef "identity" x
         mapM_ (storeBinary "skey") keys

    load' = loadRec $ AttachIdentity
        <$> loadRef "identity"
        <*> loadBinaries "skey"

instance PairingResult AttachIdentity where
    pairingServiceID _ = mkServiceID "4995a5f9-2d4d-48e9-ad3b-0bf1c2a1be7f"

    type PairingVerifiedResult AttachIdentity = (UnifiedIdentity, [ScrubbedBytes])

    pairingVerifyResult (AttachIdentity sdata keys) = do
        curid <- lsIdentity . fromStored <$> svcGetLocal
        secret <- maybe (throwError "failed to load own secret key") return =<<
            liftIO (loadKey $ iddKeyIdentity $ fromStored $ signedData $ fromStored curid)
        sdata' <- liftIO $ wrappedStore (storedStorage sdata) =<< signAdd secret (fromStored sdata)
        return $ do
            guard $ iddKeyIdentity (fromStored $ signedData $ fromStored sdata) ==
                iddKeyIdentity (fromStored $ signedData $ fromStored curid)
            identity <- validateIdentity sdata'
            guard $ iddPrev (fromStored $ signedData $ fromStored $ idData identity) == [curid]
            return (identity, keys)

    pairingFinalizeRequest (identity, keys) = updateLocalState_ $ \slocal -> do
        let owner = finalOwner identity
            st = storedStorage slocal
        pkeys <- mapM (copyStored st) [ idKeyIdentity owner, idKeyMessage owner ]
        mapM_ storeKey $ catMaybes [ keyFromData sec pub | sec <- keys, pub <- pkeys ]

        shared <- makeSharedStateUpdate st (idDataF owner) (lsShared $ fromStored slocal)
        wrappedStore st (fromStored slocal)
            { lsIdentity = idData identity
            , lsShared = [ shared ]
            }

    pairingFinalizeResponse = do
        st <- storedStorage <$> svcGetLocal
        owner <- mergeSharedIdentity
        pid <- asks svcPeerIdentity
        secret <- maybe (throwError "failed to load secret key") return =<< liftIO (loadKey $ idKeyIdentity owner)
        identity <- liftIO $ wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData $ idKeyIdentity pid)
            { iddPrev = [idData pid], iddOwner = Just (idData owner) }
        skeys <- liftIO $ map keyGetData . catMaybes <$> mapM loadKey [ idKeyIdentity owner, idKeyMessage owner ]
        return $ AttachIdentity identity skeys

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

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

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

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

        , pairingHookConfirmedResponse = do
            svcPrint $ "Confirmed peer, waiting for updated identity"

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

        , pairingHookAcceptedResponse = do
            svcPrint $ "Accepted updated identity"

        , pairingHookAcceptedRequest = do
            svcPrint $ "Accepted new attached device, seding updated identity"

        , pairingHookVerifyFailed = do
            svcPrint $ "Failed to verify new identity"
        }

attachToOwner :: (MonadIO m, MonadError String m) => Peer -> m ()
attachToOwner = pairingRequest @AttachIdentity Proxy

attachAccept :: (MonadIO m, MonadError String m) => Peer -> m ()
attachAccept = pairingAccept @AttachIdentity Proxy