Move pairing logic to separate module

2 files changed, 227 insertions, 154 deletions

diff --git a/src/Attach.hs b/src/Attach.hs
index 95f0a67..5acc608 100644
--- a/src/Attach.hs
+++ b/src/Attach.hs
@@ -6,165 +6,92 @@ module Attach (
 import Control.Monad.Except
 import Control.Monad.Reader
 
-import Crypto.Random
-
-import Data.Bits
-import Data.ByteArray (Bytes, ScrubbedBytes, convert)
-import qualified Data.ByteArray as BA
-import qualified Data.ByteString.Char8 as BC
+import Data.ByteArray (ScrubbedBytes)
 import Data.Maybe
+import Data.Proxy
 import qualified Data.Text as T
-import Data.Word
 
 import Identity
 import Network
+import Pairing
 import PubKey
 import Service
 import State
 import Storage
 import Storage.Key
 
-data AttachService = AttachRequest RefDigest
-                   | AttachResponse Bytes
-                   | AttachRequestNonce Bytes
-                   | AttachIdentity (Stored (Signed IdentityData)) [ScrubbedBytes]
-                   | AttachDecline
-
-data AttachState = NoAttach
-                 | OurRequest Bytes
-                 | OurRequestConfirm (Maybe (UnifiedIdentity, [ScrubbedBytes]))
-                 | OurRequestReady
-                 | PeerRequest Bytes RefDigest
-                 | PeerRequestConfirm
-                 | AttachDone
-                 | AttachFailed
-
-instance Storable AttachService where
-    store' at = storeRec $ do
-        case at of
-             AttachRequest x -> storeBinary "request" x
-             AttachResponse x -> storeBinary "response" x
-             AttachRequestNonce x -> storeBinary "reqnonce" x
-             AttachIdentity x keys -> do
-                 storeRef "identity" x
-                 mapM_ (storeBinary "skey") keys
-             AttachDecline -> storeText "decline" ""
-
-    load' = loadRec $ do
-        (req :: Maybe Bytes) <- loadMbBinary "request"
-        rsp <- loadMbBinary "response"
-        rnonce <- loadMbBinary "reqnonce"
-        aid <- loadMbRef "identity"
-        skeys <- loadBinaries "skey"
-        (decline :: Maybe T.Text) <- loadMbText "decline"
-        let res = catMaybes
-                [ AttachRequest <$> (refDigestFromByteString =<< req)
-                , AttachResponse <$> rsp
-                , AttachRequestNonce <$> rnonce
-                , AttachIdentity <$> aid <*> pure skeys
-                , const AttachDecline <$> decline
-                ]
-        case res of
-             x:_ -> return x
-             [] -> throwError "invalid attach stange"
-
-instance Service AttachService where
-    serviceID _ = mkServiceID "4995a5f9-2d4d-48e9-ad3b-0bf1c2a1be7f"
-
-    type ServiceState AttachService = AttachState
-    emptyServiceState _ = NoAttach
-
-    serviceHandler spacket = ((,fromStored spacket) <$> svcGet) >>= \case
-        (NoAttach, AttachRequest confirm) -> do
-            peer <- asks $ svcPeer
-            svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ " initiated"
-            nonce <- liftIO $ getRandomBytes 32
-            svcSet $ PeerRequest nonce confirm
-            replyPacket $ AttachResponse nonce
-        (NoAttach, _) -> return ()
-
-        (OurRequest nonce, AttachResponse pnonce) -> do
-            peer <- asks $ svcPeer
-            self <- maybe (throwError "failed to verify own identity") return .
-                validateIdentity . lsIdentity . fromStored =<< svcGetLocal
-            svcPrint $ "Attach to " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirmationNumber (nonceDigest self peer nonce pnonce)
-            svcSet $ OurRequestConfirm Nothing
-            replyPacket $ AttachRequestNonce nonce
-        (OurRequest _, _) -> do
-            svcSet $ AttachFailed
-            replyPacket AttachDecline
-
-        (OurRequestConfirm _, AttachIdentity sdata keys) -> do
-            verifyAttachedIdentity sdata >>= \case
-                Just owner -> do
-                    svcPrint $ "Attachment confirmed by peer"
-                    svcSet $ OurRequestConfirm $ Just (owner, keys)
-                Nothing -> do
-                    svcPrint $ "Failed to verify new identity"
-                    svcSet $ AttachFailed
-                    replyPacket AttachDecline
-        (OurRequestConfirm _, _) -> do
-            svcSet $ AttachFailed
-            replyPacket AttachDecline
-
-        (OurRequestReady, AttachIdentity sdata keys) -> do
-            verifyAttachedIdentity sdata >>= \case
-                Just identity -> do
-                    svcPrint $ "Accepted updated identity"
-                    svcSetLocal =<< finalizeAttach identity keys =<< svcGetLocal
-                Nothing -> do
-                    svcPrint $ "Failed to verify new identity"
-                    svcSet $ AttachFailed
-                    replyPacket AttachDecline
-        (OurRequestReady, _) -> do
-            svcSet $ AttachFailed
-            replyPacket AttachDecline
-
-        (PeerRequest nonce dgst, AttachRequestNonce pnonce) -> do
-            peer <- asks $ svcPeer
-            self <- maybe (throwError "failed to verify own identity") return .
-                validateIdentity . lsIdentity . fromStored =<< svcGetLocal
-            if dgst == nonceDigest peer self pnonce BA.empty
-               then do svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirmationNumber (nonceDigest peer self pnonce nonce)
-                       svcSet PeerRequestConfirm
-               else do svcPrint $ "Failed attach from " ++ T.unpack (displayIdentity peer)
-                       svcSet AttachFailed
-                       replyPacket AttachDecline
-        (PeerRequest _ _, _) -> do
-            svcSet $ AttachFailed
-            replyPacket AttachDecline
-        (PeerRequestConfirm, _) -> do
-            svcSet $ AttachFailed
-            replyPacket AttachDecline
-
-        (AttachDone, _) -> return ()
-        (AttachFailed, _) -> return ()
+type AttachService = PairingService AttachIdentity
+
+data AttachIdentity = AttachIdentity (Stored (Signed IdentityData)) [ScrubbedBytes] (Maybe UnifiedIdentity)
+
+instance Storable AttachIdentity where
+    store' (AttachIdentity x keys _) = storeRec $ do
+         storeRef "identity" x
+         mapM_ (storeBinary "skey") keys
+
+    load' = loadRec $ AttachIdentity
+        <$> loadRef "identity"
+        <*> loadBinaries "skey"
+        <*> pure Nothing
+
+instance PairingResult AttachIdentity where
+    pairingServiceID _ = mkServiceID "4995a5f9-2d4d-48e9-ad3b-0bf1c2a1be7f"
+
+    pairingHookRequest = do
+        peer <- asks $ svcPeer
+        svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ " initiated"
+
+    pairingHookResponse confirm = do
+        peer <- asks $ svcPeer
+        svcPrint $ "Attach to " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirm
+
+    pairingHookRequestNonce confirm = do
+        peer <- asks $ svcPeer
+        svcPrint $ "Attach from " ++ T.unpack (displayIdentity peer) ++ ": " ++ confirm
+
+    pairingHookRequestNonceFailed = do
+        peer <- asks $ svcPeer
+        svcPrint $ "Failed attach from " ++ T.unpack (displayIdentity peer)
+
+    pairingHookConfirm (AttachIdentity sdata keys _) = do
+        verifyAttachedIdentity sdata >>= \case
+            Just identity -> do
+                svcPrint $ "Attachment confirmed by peer"
+                return $ Just $ AttachIdentity sdata keys (Just identity)
+            Nothing -> do
+                svcPrint $ "Failed to verify new identity"
+                throwError "Failed to verify new identity"
+
+    pairingHookAccept (AttachIdentity sdata keys _) = do
+        verifyAttachedIdentity sdata >>= \case
+            Just identity -> do
+                svcPrint $ "Accepted updated identity"
+                svcSetLocal =<< finalizeAttach identity keys =<< svcGetLocal
+            Nothing -> do
+                svcPrint $ "Failed to verify new identity"
+                throwError "Failed to verify new identity"
 
 attachToOwner :: (MonadIO m, MonadError String m) => (String -> IO ()) -> UnifiedIdentity -> Peer -> m ()
-attachToOwner _ self peer = do
-    nonce <- liftIO $ getRandomBytes 32
-    pid <- case peerIdentity peer of
-                PeerIdentityFull pid -> return pid
-                _ -> throwError "incomplete peer identity"
-    sendToPeerWith self peer $ \case
-        NoAttach -> return (Just $ AttachRequest (nonceDigest self pid nonce BA.empty), OurRequest nonce)
-        _ -> throwError "alredy in progress"
+attachToOwner _ = pairingRequest @AttachIdentity Proxy
 
 attachAccept :: (MonadIO m, MonadError String m) => (String -> IO ()) -> Head LocalState -> Peer -> m ()
 attachAccept printMsg h peer = do
     let st = refStorage $ headRef h
         self = headLocalIdentity h
     sendToPeerWith self peer $ \case
-        NoAttach -> throwError $ "none in progress"
+        NoPairing -> throwError $ "none in progress"
         OurRequest {} -> throwError $ "waiting for peer"
         OurRequestConfirm Nothing -> do
             liftIO $ printMsg $ "Confirmed peer, waiting for updated identity"
             return (Nothing, OurRequestReady)
-        OurRequestConfirm (Just (identity, keys)) -> do
+        OurRequestConfirm (Just (AttachIdentity _ _ Nothing)) -> do
+            liftIO $ printMsg $ "Confirmed peer, but verification of received identity failed"
+            return (Nothing, NoPairing)
+        OurRequestConfirm (Just (AttachIdentity _ keys (Just identity))) -> do
             liftIO $ do
                 printMsg $ "Accepted updated identity"
                 updateLocalState_ h $ finalizeAttach identity keys
-            return (Nothing, AttachDone)
+            return (Nothing, PairingDone)
         OurRequestReady -> throwError $ "alredy accepted, waiting for peer"
         PeerRequest {} -> throwError $ "waiting for peer"
         PeerRequestConfirm -> do
@@ -176,25 +103,9 @@ attachAccept printMsg h peer = do
                 identity <- wrappedStore st =<< sign secret =<< wrappedStore st (emptyIdentityData $ idKeyIdentity pid)
                     { iddPrev = [idData pid], iddOwner = Just (idData owner) }
                 skeys <- map keyGetData . catMaybes <$> mapM loadKey [ idKeyIdentity owner, idKeyMessage owner ]
-                return (Just $ AttachIdentity identity skeys, NoAttach)
-        AttachDone -> throwError $ "alredy done"
-        AttachFailed -> throwError $ "alredy failed"
-
-
-nonceDigest :: UnifiedIdentity -> UnifiedIdentity -> Bytes -> Bytes -> RefDigest
-nonceDigest id1 id2 nonce1 nonce2 = hashToRefDigest $ serializeObject $ Rec
-        [ (BC.pack "id", RecRef $ storedRef $ idData id1)
-        , (BC.pack "id", RecRef $ storedRef $ idData id2)
-        , (BC.pack "nonce", RecBinary $ convert nonce1)
-        , (BC.pack "nonce", RecBinary $ convert nonce2)
-        ]
-
-confirmationNumber :: RefDigest -> String
-confirmationNumber dgst = let (a:b:c:d:_) = map fromIntegral $ BA.unpack dgst :: [Word32]
-                              str = show $ (a .|. (b `shift` 8) .|. (c `shift` 16) .|. (d `shift` 24)) `mod` (10 ^ len)
-                           in replicate (len - length str) '0' ++ str
-    where len = 6
-
+                return (Just $ PairingAccept $ AttachIdentity identity skeys Nothing, PairingDone)
+        PairingDone -> throwError $ "alredy done"
+        PairingFailed -> throwError $ "alredy failed"
 
 verifyAttachedIdentity :: Stored (Signed IdentityData) -> ServiceHandler s (Maybe UnifiedIdentity)
 verifyAttachedIdentity sdata = do
@@ -209,7 +120,6 @@ verifyAttachedIdentity sdata = do
         guard $ iddPrev (fromStored $ signedData $ fromStored $ idData identity) == [curid]
         return identity
 
-
 finalizeAttach :: MonadIO m => UnifiedIdentity -> [ScrubbedBytes] -> Stored LocalState -> m (Stored LocalState)
 finalizeAttach identity skeys slocal = liftIO $ do
     let owner = finalOwner identity
@@ -221,4 +131,4 @@ finalizeAttach identity skeys slocal = liftIO $ do
     wrappedStore st (fromStored slocal)
         { lsIdentity = idData identity
         , lsShared = [ shared ]
-            }
+        }
diff --git a/src/Pairing.hs b/src/Pairing.hs
new file mode 100644
index 0000000..a0a19b3
--- /dev/null
+++ b/src/Pairing.hs
@@ -0,0 +1,163 @@
+module Pairing (
+    PairingService(..),
+    PairingState(..),
+    PairingResult(..),
+
+    pairingRequest,
+) where
+
+import Control.Monad.Except
+import Control.Monad.Reader
+
+import Crypto.Random
+
+import Data.Bits
+import Data.ByteArray (Bytes, convert)
+import qualified Data.ByteArray as BA
+import qualified Data.ByteString.Char8 as BC
+import Data.Maybe
+import qualified Data.Text as T
+import Data.Typeable
+import Data.Word
+
+import Identity
+import Network
+import Service
+import State
+import Storage
+
+data PairingService a = PairingRequest RefDigest
+                      | PairingResponse Bytes
+                      | PairingRequestNonce Bytes
+                      | PairingAccept a
+                      | PairingDecline
+
+data PairingState a = NoPairing
+                    | OurRequest Bytes
+                    | OurRequestConfirm (Maybe a)
+                    | OurRequestReady
+                    | PeerRequest Bytes RefDigest
+                    | PeerRequestConfirm
+                    | PairingDone
+                    | PairingFailed
+
+class (Typeable a, Storable a) => PairingResult a where
+    pairingServiceID :: proxy a -> ServiceID
+    pairingHookRequest :: ServiceHandler (PairingService a) ()
+    pairingHookResponse :: String -> ServiceHandler (PairingService a) ()
+    pairingHookRequestNonce :: String -> ServiceHandler (PairingService a) ()
+    pairingHookRequestNonceFailed :: ServiceHandler (PairingService a) ()
+    pairingHookConfirm :: a -> ServiceHandler (PairingService a) (Maybe a)
+    pairingHookAccept :: a -> ServiceHandler (PairingService a) ()
+
+
+instance Storable a => Storable (PairingService a) where
+    store' (PairingRequest x) = storeRec $ storeBinary "request" x
+    store' (PairingResponse x) = storeRec $ storeBinary "response" x
+    store' (PairingRequestNonce x) = storeRec $ storeBinary "reqnonce" x
+    store' (PairingAccept x) = store' x
+    store' (PairingDecline) = storeRec $ storeText "decline" ""
+
+    load' = do
+        res <- loadRec $ do
+            (req :: Maybe Bytes) <- loadMbBinary "request"
+            rsp <- loadMbBinary "response"
+            rnonce <- loadMbBinary "reqnonce"
+            (decline :: Maybe T.Text) <- loadMbText "decline"
+            return $ catMaybes
+                    [ PairingRequest <$> (refDigestFromByteString =<< req)
+                    , PairingResponse <$> rsp
+                    , PairingRequestNonce <$> rnonce
+                    , const PairingDecline <$> decline
+                    ]
+        case res of
+             x:_ -> return x
+             [] -> PairingAccept <$> load'
+
+
+instance PairingResult a => Service (PairingService a) where
+    serviceID _ = pairingServiceID @a Proxy
+
+    type ServiceState (PairingService a) = PairingState a
+    emptyServiceState _ = NoPairing
+
+    serviceHandler spacket = ((,fromStored spacket) <$> svcGet) >>= \case
+        (NoPairing, PairingRequest confirm) -> do
+            pairingHookRequest
+            nonce <- liftIO $ getRandomBytes 32
+            svcSet $ PeerRequest nonce confirm
+            replyPacket $ PairingResponse nonce
+        (NoPairing, _) -> return ()
+
+        (OurRequest nonce, PairingResponse pnonce) -> do
+            peer <- asks $ svcPeer
+            self <- maybe (throwError "failed to validate own identity") return .
+                validateIdentity . lsIdentity . fromStored =<< svcGetLocal
+            pairingHookResponse $ confirmationNumber $ nonceDigest self peer nonce pnonce
+            svcSet $ OurRequestConfirm Nothing
+            replyPacket $ PairingRequestNonce nonce
+        (OurRequest _, _) -> do
+            svcSet $ PairingFailed
+            replyPacket PairingDecline
+
+        (OurRequestConfirm _, PairingAccept x) -> do
+            (svcSet . OurRequestConfirm =<< pairingHookConfirm x) `catchError` \_ -> do
+                svcSet $ PairingFailed
+                replyPacket PairingDecline
+
+        (OurRequestConfirm _, _) -> do
+            svcSet $ PairingFailed
+            replyPacket PairingDecline
+
+        (OurRequestReady, PairingAccept x) -> do
+            pairingHookAccept x `catchError` \_ -> do
+                svcSet $ PairingFailed
+                replyPacket PairingDecline
+        (OurRequestReady, _) -> do
+            svcSet $ PairingFailed
+            replyPacket PairingDecline
+
+        (PeerRequest nonce dgst, PairingRequestNonce pnonce) -> do
+            peer <- asks $ svcPeer
+            self <- maybe (throwError "failed to verify own identity") return .
+                validateIdentity . lsIdentity . fromStored =<< svcGetLocal
+            if dgst == nonceDigest peer self pnonce BA.empty
+               then do pairingHookRequestNonce $ confirmationNumber $ nonceDigest peer self pnonce nonce
+                       svcSet PeerRequestConfirm
+               else do pairingHookRequestNonceFailed
+                       svcSet PairingFailed
+                       replyPacket PairingDecline
+        (PeerRequest _ _, _) -> do
+            svcSet $ PairingFailed
+            replyPacket PairingDecline
+        (PeerRequestConfirm, _) -> do
+            svcSet $ PairingFailed
+            replyPacket PairingDecline
+
+        (PairingDone, _) -> return ()
+        (PairingFailed, _) -> return ()
+
+
+nonceDigest :: UnifiedIdentity -> UnifiedIdentity -> Bytes -> Bytes -> RefDigest
+nonceDigest id1 id2 nonce1 nonce2 = hashToRefDigest $ serializeObject $ Rec
+        [ (BC.pack "id", RecRef $ storedRef $ idData id1)
+        , (BC.pack "id", RecRef $ storedRef $ idData id2)
+        , (BC.pack "nonce", RecBinary $ convert nonce1)
+        , (BC.pack "nonce", RecBinary $ convert nonce2)
+        ]
+
+confirmationNumber :: RefDigest -> String
+confirmationNumber dgst = let (a:b:c:d:_) = map fromIntegral $ BA.unpack dgst :: [Word32]
+                              str = show $ (a .|. (b `shift` 8) .|. (c `shift` 16) .|. (d `shift` 24)) `mod` (10 ^ len)
+                           in replicate (len - length str) '0' ++ str
+    where len = 6
+
+pairingRequest :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> UnifiedIdentity -> Peer -> m ()
+pairingRequest _ self peer = do
+    nonce <- liftIO $ getRandomBytes 32
+    pid <- case peerIdentity peer of
+                PeerIdentityFull pid -> return pid
+                _ -> throwError "incomplete peer identity"
+    sendToPeerWith @(PairingService a) self peer $ \case
+        NoPairing -> return (Just $ PairingRequest (nonceDigest self pid nonce BA.empty), OurRequest nonce)
+        _ -> throwError "alredy in progress"