diff --git a/hbs2-peer/app/MailboxProtoWorker.hs b/hbs2-peer/app/MailboxProtoWorker.hs index ccacc7ad..8a2388d1 100644 --- a/hbs2-peer/app/MailboxProtoWorker.hs +++ b/hbs2-peer/app/MailboxProtoWorker.hs @@ -96,12 +96,19 @@ deriving instance ForMailbox s => Eq (PolicyDownload s) instance ForMailbox s => Hashable (PolicyDownload s) where hashWithSalt s p = hashWithSalt s (serialise p) -data MailboxDowload = - MailboxDowload - { mailboxDownWhen :: Word64 +data MailboxDownload s = + MailboxDownload + { mailboxRef :: MailboxRefKey s + , mailboxStatusRef :: HashRef + , mailboxDownWhen :: Word64 , mailboxDownPolicy :: Maybe PolicyVersion + , mailboxDownDone :: Bool } - deriving stock Generic + deriving stock (Generic) + +deriving stock instance ForMailbox s => Eq (MailboxDownload s) + +instance ForMailbox s => Hashable (MailboxDownload s) data MailboxProtoWorker (s :: CryptoScheme) e = MailboxProtoWorker @@ -113,7 +120,7 @@ data MailboxProtoWorker (s :: CryptoScheme) e = , inMessageQueue :: TBQueue (Message s, MessageContent s) , inMessageMergeQueue :: TVar (HashMap (MailboxRefKey s) (HashSet HashRef)) , inPolicyDownloadQ :: TVar (HashMap HashRef (PolicyDownload s)) - , inMailboxDownloadQ :: TVar (HashMap HashRef MailboxDowload) + , inMailboxDownloadQ :: TVar (HashMap HashRef (MailboxDownload s)) , inMessageQueueInNum :: TVar Int , inMessageQueueOutNum :: TVar Int , inMessageQueueDropped :: TVar Int @@ -280,7 +287,9 @@ instance ( s ~ Encryption e, e ~ L4Proto let downloadStatus v = do maybe1 mbsMailboxHash (okay ()) $ \h -> do startDownloadStuff me h - atomically $ modifyTVar inMailboxDownloadQ (HM.insert h (MailboxDowload now v)) + -- one download per version per hash + let downKey = HashRef $ hashObject (serialise (v,h)) + atomically $ modifyTVar inMailboxDownloadQ (HM.insert downKey (MailboxDownload ref h now v False)) okay () case mbsMailboxPolicy of @@ -426,6 +435,7 @@ mailboxProtoWorker :: forall e s m . ( MonadIO m , IsRefPubKey s , ForMailbox s , m ~ PeerM e IO + , e ~ L4Proto ) => m [Syntax C] -> MailboxProtoWorker s e @@ -558,7 +568,7 @@ mailboxProtoWorker readConf me@MailboxProtoWorker{..} = do polling (Polling 30 30) policies $ \(pk,PolicyDownload{..}) -> do missed <- findMissedBlocks mpwStorage pk <&> L.null - unless missed do + unless missed $ flip runContT pure do let mbox = MailboxRefKey (sppMailboxKey policyDownloadWhat) current <- loadPolicyPayloadUnboxed @s dbe mpwStorage mbox @@ -567,16 +577,36 @@ mailboxProtoWorker readConf me@MailboxProtoWorker{..} = do let downloaded = sppPolicyVersion policyDownloadWhat + mlbs <- getBlock mpwStorage (coerce pk) + + lbs <- ContT $ maybe1 mlbs (err $ red "storage fail: missed block" <+> pretty pk) + + let msp = deserialiseOrFail @(SignedBox (SetPolicyPayload s) s) lbs + & either (const Nothing) Just + + spb <- ContT $ maybe1 msp (err $ red "storage fail: corrupted block" <+> pretty pk) + when (downloaded > current) do - -- set policy - pure () + void $ mailboxSetPolicy me spb atomically $ modifyTVar inPolicyDownloadQ (HM.delete pk) stateDownloadQ = do - forever do - pause @'Seconds 10 - debug $ red "mailbox: stateDownloadQ" + + let mail = readTVarIO inMailboxDownloadQ + <&> HM.toList + <&> fmap (,10) + + polling (Polling 30 30) mail $ \(pk, down@MailboxDownload{..}) -> do + missed <- findMissedBlocks mpwStorage mailboxStatusRef <&> L.null + + when (not missed && not mailboxDownDone) do + atomically $ modifyTVar inMailboxDownloadQ (HM.insert pk (down { mailboxDownDone = True })) + debug $ "mailbox state downloaded" <+> pretty pk + + unless missed do + debug $ "mailbox/debug: drop state" <+> pretty pk <+> pretty mailboxStatusRef + atomically $ modifyTVar inMailboxDownloadQ (HM.delete pk) mailboxFetchQ dbe = forever do toFetch <- atomically $ do @@ -595,9 +625,9 @@ mailboxProtoWorker readConf me@MailboxProtoWorker{..} = do mailboxCheckQ dbe = do -- FIXME: mailbox-check-period - -- right now it's 10 seconds for debug purposes + -- right now it's 60 seconds for debug purposes -- remove hardcode to smth reasonable - let mboxes = liftIO (listMailboxes @s dbe <&> fmap (set _2 10) ) + let mboxes = liftIO (listMailboxes @s dbe <&> fmap (set _2 60) ) polling (Polling 10 10) mboxes $ \r -> do debug $ yellow "mailbox: SEND FETCH REQUEST FOR" <+> pretty r