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/Contact.hs | 175 --------------------------------------------------------- 1 file changed, 175 deletions(-) delete mode 100644 src/Contact.hs (limited to 'src/Contact.hs') diff --git a/src/Contact.hs b/src/Contact.hs deleted file mode 100644 index a232b8c..0000000 --- a/src/Contact.hs +++ /dev/null @@ -1,175 +0,0 @@ -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 ExtendedIdentityData)] - , 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_ = validateExtendedIdentityF $ 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 = idExtDataF $ finalOwner identity - , cdName = Nothing - } - storeSetAdd st (mergeSorted @Contact [cdata]) contacts -- cgit v1.2.3