From 88a7bb50033baab3c2d0eed7e4be868e8966300a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Roman=20Smr=C5=BE?= Date: Fri, 17 Nov 2023 20:28:44 +0100 Subject: Split to library and executable parts --- src/Pairing.hs | 241 --------------------------------------------------------- 1 file changed, 241 deletions(-) delete mode 100644 src/Pairing.hs (limited to 'src/Pairing.hs') diff --git a/src/Pairing.hs b/src/Pairing.hs deleted file mode 100644 index 0b31625..0000000 --- a/src/Pairing.hs +++ /dev/null @@ -1,241 +0,0 @@ -module Pairing ( - PairingService(..), - PairingState(..), - PairingAttributes(..), - PairingResult(..), - PairingFailureReason(..), - - pairingRequest, - pairingAccept, - pairingReject, -) 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.Kind -import Data.Maybe -import Data.Typeable -import Data.Word - -import Identity -import Network -import PubKey -import Service -import State -import Storage - -data PairingService a = PairingRequest (Stored (Signed IdentityData)) (Stored (Signed IdentityData)) RefDigest - | PairingResponse Bytes - | PairingRequestNonce Bytes - | PairingAccept a - | PairingReject - -data PairingState a = NoPairing - | OurRequest UnifiedIdentity UnifiedIdentity Bytes - | OurRequestConfirm (Maybe (PairingVerifiedResult a)) - | OurRequestReady - | PeerRequest UnifiedIdentity UnifiedIdentity Bytes RefDigest - | PeerRequestConfirm - | PairingDone - -data PairingFailureReason a = PairingUserRejected - | PairingUnexpectedMessage (PairingState a) (PairingService a) - | PairingFailedOther String - -data PairingAttributes a = PairingAttributes - { pairingHookRequest :: ServiceHandler (PairingService a) () - , pairingHookResponse :: String -> ServiceHandler (PairingService a) () - , pairingHookRequestNonce :: String -> ServiceHandler (PairingService a) () - , pairingHookRequestNonceFailed :: ServiceHandler (PairingService a) () - , pairingHookConfirmedResponse :: ServiceHandler (PairingService a) () - , pairingHookConfirmedRequest :: ServiceHandler (PairingService a) () - , pairingHookAcceptedResponse :: ServiceHandler (PairingService a) () - , pairingHookAcceptedRequest :: ServiceHandler (PairingService a) () - , pairingHookVerifyFailed :: ServiceHandler (PairingService a) () - , pairingHookRejected :: ServiceHandler (PairingService a) () - , pairingHookFailed :: PairingFailureReason a -> ServiceHandler (PairingService a) () - } - -class (Typeable a, Storable a) => PairingResult a where - type PairingVerifiedResult a :: Type - type PairingVerifiedResult a = a - - pairingServiceID :: proxy a -> ServiceID - pairingVerifyResult :: a -> ServiceHandler (PairingService a) (Maybe (PairingVerifiedResult a)) - pairingFinalizeRequest :: PairingVerifiedResult a -> ServiceHandler (PairingService a) () - pairingFinalizeResponse :: ServiceHandler (PairingService a) a - defaultPairingAttributes :: proxy (PairingService a) -> PairingAttributes a - - -instance Storable a => Storable (PairingService a) where - store' (PairingRequest idReq idRsp x) = storeRec $ do - storeRef "id-req" idReq - storeRef "id-rsp" idRsp - storeBinary "request" x - store' (PairingResponse x) = storeRec $ storeBinary "response" x - store' (PairingRequestNonce x) = storeRec $ storeBinary "reqnonce" x - store' (PairingAccept x) = store' x - store' (PairingReject) = storeRec $ storeEmpty "reject" - - load' = do - res <- loadRec $ do - (req :: Maybe Bytes) <- loadMbBinary "request" - idReq <- loadMbRef "id-req" - idRsp <- loadMbRef "id-rsp" - rsp <- loadMbBinary "response" - rnonce <- loadMbBinary "reqnonce" - rej <- loadMbEmpty "reject" - return $ catMaybes - [ PairingRequest <$> idReq <*> idRsp <*> (refDigestFromByteString =<< req) - , PairingResponse <$> rsp - , PairingRequestNonce <$> rnonce - , const PairingReject <$> rej - ] - case res of - x:_ -> return x - [] -> PairingAccept <$> load' - - -instance PairingResult a => Service (PairingService a) where - serviceID _ = pairingServiceID @a Proxy - - type ServiceAttributes (PairingService a) = PairingAttributes a - defaultServiceAttributes = defaultPairingAttributes - - type ServiceState (PairingService a) = PairingState a - emptyServiceState _ = NoPairing - - serviceHandler spacket = ((,fromStored spacket) <$> svcGet) >>= \case - (NoPairing, PairingRequest pdata sdata confirm) -> do - self <- maybe (throwError "failed to validate received identity") return $ validateIdentity sdata - self' <- maybe (throwError "failed to validate own identity") return . - validateExtendedIdentity . lsIdentity . fromStored =<< svcGetLocal - when (not $ self `sameIdentity` self') $ do - throwError "pairing request to different identity" - - peer <- maybe (throwError "failed to validate received peer identity") return $ validateIdentity pdata - peer' <- asks $ svcPeerIdentity - when (not $ peer `sameIdentity` peer') $ do - throwError "pairing request from different identity" - - join $ asks $ pairingHookRequest . svcAttributes - nonce <- liftIO $ getRandomBytes 32 - svcSet $ PeerRequest peer self nonce confirm - replyPacket $ PairingResponse nonce - (NoPairing, _) -> return () - - (PairingDone, _) -> return () - (_, PairingReject) -> do - join $ asks $ pairingHookRejected . svcAttributes - svcSet NoPairing - - (OurRequest self peer nonce, PairingResponse pnonce) -> do - hook <- asks $ pairingHookResponse . svcAttributes - hook $ confirmationNumber $ nonceDigest self peer nonce pnonce - svcSet $ OurRequestConfirm Nothing - replyPacket $ PairingRequestNonce nonce - x@(OurRequest {}, _) -> reject $ uncurry PairingUnexpectedMessage x - - (OurRequestConfirm _, PairingAccept x) -> do - flip catchError (reject . PairingFailedOther) $ do - pairingVerifyResult x >>= \case - Just x' -> do - join $ asks $ pairingHookConfirmedRequest . svcAttributes - svcSet $ OurRequestConfirm (Just x') - Nothing -> do - join $ asks $ pairingHookVerifyFailed . svcAttributes - svcSet NoPairing - replyPacket PairingReject - - x@(OurRequestConfirm _, _) -> reject $ uncurry PairingUnexpectedMessage x - - (OurRequestReady, PairingAccept x) -> do - flip catchError (reject . PairingFailedOther) $ do - pairingVerifyResult x >>= \case - Just x' -> do - pairingFinalizeRequest x' - join $ asks $ pairingHookAcceptedResponse . svcAttributes - svcSet $ PairingDone - Nothing -> do - join $ asks $ pairingHookVerifyFailed . svcAttributes - throwError "" - x@(OurRequestReady, _) -> reject $ uncurry PairingUnexpectedMessage x - - (PeerRequest peer self nonce dgst, PairingRequestNonce pnonce) -> do - if dgst == nonceDigest peer self pnonce BA.empty - then do hook <- asks $ pairingHookRequestNonce . svcAttributes - hook $ confirmationNumber $ nonceDigest peer self pnonce nonce - svcSet PeerRequestConfirm - else do join $ asks $ pairingHookRequestNonceFailed . svcAttributes - svcSet NoPairing - replyPacket PairingReject - x@(PeerRequest {}, _) -> reject $ uncurry PairingUnexpectedMessage x - x@(PeerRequestConfirm, _) -> reject $ uncurry PairingUnexpectedMessage x - -reject :: PairingResult a => PairingFailureReason a -> ServiceHandler (PairingService a) () -reject reason = do - join $ asks $ flip pairingHookFailed reason . svcAttributes - svcSet NoPairing - replyPacket PairingReject - - -nonceDigest :: UnifiedIdentity -> UnifiedIdentity -> Bytes -> Bytes -> RefDigest -nonceDigest idReq idRsp nonceReq nonceRsp = hashToRefDigest $ serializeObject $ Rec - [ (BC.pack "id-req", RecRef $ storedRef $ idData idReq) - , (BC.pack "id-rsp", RecRef $ storedRef $ idData idRsp) - , (BC.pack "nonce-req", RecBinary $ convert nonceReq) - , (BC.pack "nonce-rsp", RecBinary $ convert nonceRsp) - ] - -confirmationNumber :: RefDigest -> String -confirmationNumber dgst = - case map fromIntegral $ BA.unpack dgst :: [Word32] of - (a:b:c:d:_) -> let str = show $ ((a `shift` 24) .|. (b `shift` 16) .|. (c `shift` 8) .|. d) `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 -> Peer -> m () -pairingRequest _ peer = do - self <- liftIO $ serverIdentity $ peerServer peer - nonce <- liftIO $ getRandomBytes 32 - pid <- peerIdentity peer >>= \case - PeerIdentityFull pid -> return pid - _ -> throwError "incomplete peer identity" - sendToPeerWith @(PairingService a) peer $ \case - NoPairing -> return (Just $ PairingRequest (idData self) (idData pid) (nonceDigest self pid nonce BA.empty), OurRequest self pid nonce) - _ -> throwError "already in progress" - -pairingAccept :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m () -pairingAccept _ peer = runPeerService @(PairingService a) peer $ do - svcGet >>= \case - NoPairing -> throwError $ "none in progress" - OurRequest {} -> throwError $ "waiting for peer" - OurRequestConfirm Nothing -> do - join $ asks $ pairingHookConfirmedResponse . svcAttributes - svcSet OurRequestReady - OurRequestConfirm (Just verified) -> do - join $ asks $ pairingHookAcceptedResponse . svcAttributes - pairingFinalizeRequest verified - svcSet PairingDone - OurRequestReady -> throwError $ "already accepted, waiting for peer" - PeerRequest {} -> throwError $ "waiting for peer" - PeerRequestConfirm -> do - join $ asks $ pairingHookAcceptedRequest . svcAttributes - replyPacket . PairingAccept =<< pairingFinalizeResponse - svcSet PairingDone - PairingDone -> throwError $ "already done" - -pairingReject :: forall a m proxy. (PairingResult a, MonadIO m, MonadError String m) => proxy a -> Peer -> m () -pairingReject _ peer = runPeerService @(PairingService a) peer $ do - svcGet >>= \case - NoPairing -> throwError $ "none in progress" - PairingDone -> throwError $ "already done" - _ -> reject PairingUserRejected -- cgit v1.2.3