hbs2-cli sigil functions reworked

hbs2-cli/lib/HBS2/CLI/Run/Sigil.hs

@@ -79,37 +79,55 @@ sigilEntries = do
       _ -> throwIO $ BadFormException @c nil
 
 
-  entry $ bindMatch "hbs2:sigil:create:from-keyring" $ \syn -> do
+  brief "create sigil from keyring" $
+   desc [qc|
 
-    args <- case syn of
+;; creates from keyring, uses first encryption key if found
-      [ StringLike s ] -> pure (fmap snd . headMay, s)
-      [ StringLike p, StringLike s ] -> pure ( findKey p, s)
-      [ LitIntVal n, StringLike s ] -> pure ( L.lookup n, s)
 
-      _ -> throwIO $ BadFormException @C nil
+hbs2:sigil:create:from-keyring KEYRING-FILE
 
-    let lbs = BS8.pack (snd args)
+;; creates from keyring, uses n-th encryption key if found, N starts from 1
 
-    cred <- pure (parseCredentials @'HBS2Basic (AsCredFile lbs))
+hbs2:sigil:create:from-keyring KEYRING-FILE N
-               `orDie` "bad keyring data"
 
-    let es = zip [0..]
+;; creates from keyring, uses encryption key wit prefix S if found
-                 [ p | KeyringEntry p _ _
-                     <- view peerKeyring cred
-                 ]
 
-    enc <- pure (fst args es)
+hbs2:sigil:create:from-keyring KEYRING-FILE S
-           `orDie` "key not found"
 
-    sigil <- pure (makeSigilFromCredentials @'HBS2Basic cred enc Nothing Nothing)
+   |]
-              `orDie` "can't create a sigil"
+   $ entry $ bindMatch "hbs2:sigil:create:from-keyring" $ \syn -> do
 
-    pure $ mkStr (show $ pretty $ AsBase58 sigil)
+      let readKeyring fn = liftIO (BS8.readFile fn) <&>  parseCredentials @'HBS2Basic . AsCredFile
 
-  where
+      (cred, KeyringEntry enc _ _) <- case syn of
-    findKey s xs = headMay [ k
+            [ StringLike fn ] -> do
-                           | e@(_,k) <- xs
+              s <- readKeyring fn >>= orThrowUser "malformed keyring file"
-                           , L.isPrefixOf s (show $ pretty (AsBase58 k))
+              kr <- headMay (view peerKeyring s) & orThrowUser "encryption key missed"
-                           ]
+              pure (s,kr)
 
+            [ StringLike fn, LitIntVal n ] -> do
+
+              s <- readKeyring fn >>= orThrowUser "malformed keyring file"
+              kr <- headMay (drop (fromIntegral (max 0 (n-1))) (view peerKeyring s))
+                      & orThrowUser "encryption key not found"
+              pure (s,kr)
+
+            [ StringLike fn, StringLike p ] -> do
+
+              s <- readKeyring fn >>= orThrowUser "malformed keyring file"
+              kr <- findKey p (view peerKeyring s)  & orThrowUser "encryption key not found"
+              pure (s,kr)
+
+            _ -> throwIO $ BadFormException @c nil
+
+      sigil <- pure (makeSigilFromCredentials @'HBS2Basic cred enc Nothing Nothing)
+                `orDie` "can't create a sigil"
+
+      pure $ mkStr (show $ pretty $ AsBase58 sigil)
+
+    where
+      findKey s xs = headMay [ e
+                             | e@(KeyringEntry k _ _) <- xs
+                             , L.isPrefixOf s (show $ pretty (AsBase58 k))
+                             ]
 

hbs2-peer/app/MailboxProtoWorker.hs

@@ -261,12 +261,19 @@ instance ( s ~ Encryption e, e ~ L4Proto
 
       pure $ Right r
 
-  mailboxAcceptStatus me@MailboxProtoWorker{..} ref who MailBoxStatusPayload{..} = do
+  mailboxAcceptStatus me@MailboxProtoWorker{..} ref who s2@MailBoxStatusPayload{..} = do
     -- TODO: implement-policy-first
     --   итак, мы не можем двигаться, пока не будет реализована policy.
 
+
     flip runContT pure $ callCC \stop -> do
 
+      s0 <- runMaybeT do
+        MailBoxStatusPayload{..} <- mailboxGetStatus me ref
+                                      >>= toMPlus
+                                      >>= toMPlus
+        toMPlus mbsMailboxHash
+
       now <- liftIO $ getPOSIXTime <&> round
 
       mdbe <- readTVarIO mailboxDB
@@ -283,17 +290,18 @@ instance ( s ~ Encryption e, e ~ L4Proto
                   <+> "from"
                   <+> pretty (AsBase58 who)
 
-
       let downloadStatus v = do
             maybe1 mbsMailboxHash (okay ()) $ \h -> do
-              startDownloadStuff me h
+              when (s0 /= Just h) do
-              -- one download per version per hash
+                startDownloadStuff me h
-              let downKey = HashRef $ hashObject (serialise (v,h))
+                -- one download per version per hash
-              atomically $ modifyTVar inMailboxDownloadQ (HM.insert downKey (MailboxDownload ref h now v False))
+                let downKey = HashRef $ hashObject (serialise (v,h))
+                atomically $ modifyTVar inMailboxDownloadQ (HM.insert downKey (MailboxDownload ref h now v False))
               okay ()
 
       case mbsMailboxPolicy of
         Nothing -> downloadStatus Nothing
+
         Just newPolicy -> do
 
           -- TODO: handle-invalid-policy-error
@@ -775,4 +783,11 @@ instance ForMailbox s => FromField (MailboxRefKey s) where
 instance FromField MailboxType where
   fromField w = fromField @String w <&> fromString @MailboxType
 
+-- TODO: test-multiple-recipients
+
+-- TODO: implement-basic-policy
+
+-- TODO: test-basic-policy
+
+
 

hbs2-peer/app/PeerTypes.hs

@@ -312,9 +312,6 @@ addDownload :: forall e m . ( DownloadConstr e m
 
 addDownload mbh h = do
 
-  -- FIXME: remove-shit
-  debug $ "addDownload" <+> pretty h
-
   tinq <- asks (view blockInQ)
   checkQ <- asks (view blockCheckQ)
   dirty <- asks (view blockInDirty)