wip

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

@@ -22,13 +22,13 @@ import Data.ByteString.Lazy.Char8 qualified as LBS8
 import Data.Coerce
 import Data.Either
 
-createMessageFromByteString :: forall s m . ( MonadUnliftIO m
+createShortMessageFromByteString :: forall s m . ( MonadUnliftIO m
                                             , s ~ HBS2Basic
                                             , HasStorage m
                                             )
                             => LBS8.ByteString
                             -> m (Message s)
-createMessageFromByteString lbs = do
+createShortMessageFromByteString lbs = do
   let ls0 = LBS8.lines lbs
   let (hbs, rest1) = break LBS8.null ls0
   let payload      = dropWhile LBS8.null rest1 & LBS8.unlines
@@ -63,12 +63,11 @@ mailboxEntries = do
     $ args [arg "string" "filename"]
     $ desc ""
     $ returns "blob" "message"
-    $ entry $ bindMatch "hbs2:mailbox:message:create" $ \case
+    $ entry $ bindMatch "hbs2:mailbox:message:create:short" $ \case
         [StringLike fn] -> lift do
           lbs <- liftIO $ LBS8.readFile fn
-          mess <- createMessageFromByteString lbs
-          let what = serialise mess
-          pure $ mkForm @c "blob" [mkStr (LBS8.unpack what)]
+          mess <- createShortMessageFromByteString lbs
+          mkOpaque (serialise mess)
 
         _ -> throwIO (BadFormException @c nil)
 

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

@@ -1,3 +1,5 @@
+{-# Language ViewPatterns #-}
+{-# Language PatternSynonyms #-}
 module HBS2.CLI.Run.Peer where
 
 import HBS2.CLI.Prelude
@@ -20,7 +22,9 @@ import Data.List qualified as L
 import Data.Maybe
 import Control.Monad.Trans.Cont
 import Data.Text qualified as Text
+import Data.ByteString qualified as BS
 import Data.ByteString.Lazy.Char8 qualified as LBS8
+import Data.ByteString.Lazy qualified as LBS
 import Lens.Micro.Platform
 
 import Text.InterpolatedString.Perl6 (qc)
@@ -51,7 +55,7 @@ peerEntries = do
   entry $ bindMatch "hbs2:peer:detect" $ \case
     _ -> detectRPC <&> maybe (nil @c) mkStr
 
-  entry $ bindMatch "hbs2:peer:get-block" $ \case
+  entry $ bindMatch "hbs2:peer:storage:block:get" $ \case
     [StringLike s] -> do
       flip runContT pure do
 
@@ -66,23 +70,29 @@ peerEntries = do
 
     _ -> throwIO $ BadFormException @c nil
 
-  entry $ bindMatch "hbs2:peer:has-block" $ \case
-    [StringLike s] -> do
+  entry $ bindMatch "hbs2:peer:block:size" $ \case
+    [HashLike ha] -> do
       flip runContT pure do
-
         sto <- getStorage
-
-        ha <- pure (fromStringMay @HashRef s)
-               `orDie` "invalid hash"
-
         mbsz <- hasBlock sto (fromHashRef ha)
-
         pure $ maybe (mkSym "no-block") mkInt mbsz
 
     _ -> throwIO $ BadFormException @c nil
 
   -- stores *small* block
-  entry $ bindMatch "hbs2:peer:put-block" $ \case
+  entry $ bindMatch "hbs2:peer:storage:block:put" $ \case
+
+    [isOpaqueOf @LBS.ByteString -> Just lbs] -> do
+      sto <- getStorage
+      (putBlock sto lbs <&> fmap (mkStr . show . pretty . HashRef) )
+        >>= orThrowUser "storage error"
+
+    [isOpaqueOf @BS.ByteString -> Just bs] -> do
+      sto <- getStorage
+      (putBlock sto (LBS.fromStrict bs) <&> fmap (mkStr . show . pretty . HashRef) )
+        >>= orThrowUser "storage error"
+
+    -- FIXME: deprecate-this
     [ListVal [SymbolVal "blob", LitStrVal s]] -> do
       flip runContT pure do
         sto <- getStorage

hbs2-core/lib/HBS2/Data/Types/SignedBox.hs

@@ -33,6 +33,7 @@ type ForSignedBox s = ( Serialise ( PubKey 'Sign s)
                       , FromStringMaybe (PubKey 'Sign s)
                       , Serialise (Signature s)
                       , Signatures s
+                      , Eq (Signature s)
                       , Hashable (PubKey 'Sign s)
                       )
 

hbs2-core/lib/HBS2/Data/Types/SmallEncryptedBlock.hs

@@ -14,7 +14,7 @@ data SmallEncryptedBlock t =
   , sebNonce :: ByteString
   , sebBox   :: EncryptedBox t
   }
-  deriving stock (Generic)
+  deriving stock (Eq,Generic)
 
 instance Serialise  (SmallEncryptedBlock t)
 

hbs2-core/lib/HBS2/Net/Auth/Credentials/Sigil.hs

@@ -63,6 +63,7 @@ type ForSigil s = ( Serialise (PubKey 'Encrypt s)
                   , Hashable (PubKey 'Sign s)
                   , IsEncoding (PubKey 'Encrypt s)
                   , Eq (PubKey 'Encrypt s)
+                  , Eq (Signature s)
                   , FromStringMaybe (PubKey 'Sign s)
                   )
 

hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs

@@ -213,6 +213,8 @@ data Message s =
   }
   deriving stock Generic
 
+deriving stock instance ForMailbox s => Eq (MessageContent s)
+deriving stock instance ForMailbox s => Eq (Message s)
 
 instance Serialise MessageTimestamp
 instance Serialise MessageTTL
@@ -222,10 +224,6 @@ instance ForMailbox s => Serialise (MessageContent s)
 instance ForMailbox s => Serialise (Message s)
 
 
-
-
-
-
 data MailboxServiceError =
     MailboxCreateFailed String
   | MailboxOperationError String

hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs

@@ -151,6 +151,7 @@ type ForRefChans e = ( Serialise (PubKey 'Sign (Encryption e))
                      , FromStringMaybe (PubKey 'Sign (Encryption e))
                      , FromStringMaybe (PubKey 'Encrypt (Encryption e))
                      , Signatures (Encryption e)
+                     , Eq (Signature (Encryption e))
                      , Hashable (PubKey 'Encrypt (Encryption e))
                      , Hashable (PubKey 'Sign (Encryption e))
                      )

miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs

@@ -15,9 +15,12 @@ module Data.Config.Suckless.Syntax
   , Context(..)
   , IsContext(..)
   , IsLiteral(..)
+  , ByteStringSorts(..)
   , mkOpaque
+  , isOpaqueOf
   , fromOpaque
   , fromOpaqueThrow
+  , isByteString
   , SyntaxTypeError(..)
   , pattern SymbolVal
   , pattern ListVal
@@ -40,26 +43,23 @@ import Data.Text (Text)
 import Data.Scientific
 import GHC.Generics (Generic(..))
 import Data.Maybe
--- import GHC.Generics( Fixity(..) )
--- import Data.Data as Data
 import Data.Aeson
 import Data.Aeson.Key
 import Data.Aeson.KeyMap qualified as Aeson
 import Data.Vector qualified as V
 import Data.Traversable (forM)
 import Data.Text qualified as Text
+import Data.ByteString (ByteString)
+import Data.ByteString.Lazy qualified as LBS
 import Data.Function
-import Data.Hashable
+import Data.Functor
+import Control.Applicative
 import Control.Exception
 import Type.Reflection
 import Control.Monad.IO.Class
-import System.Mem.StableName
-import Foreign.Ptr (ptrToIntPtr)
-import Foreign.StablePtr
 import System.IO.Unsafe (unsafePerformIO)
 import Data.IORef
 import Data.Word
-import Data.Bits
 
 import Prettyprinter
 
@@ -92,6 +92,8 @@ stringLike = \case
 stringLikeList :: [Syntax c] -> [String]
 stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes
 
+data ByteStringSorts = ByteStringLazy LBS.ByteString | ByteStringStrict ByteString
+
 
 pattern StringLike :: forall {c} . String -> Syntax c
 pattern StringLike e <- (stringLike -> Just e)
@@ -108,6 +110,20 @@ pattern OpaqueVal box <- OpaqueValue box
 
 data family Context c :: Type
 
+isOpaqueOf :: forall a c . (Typeable a, IsContext c) => Syntax c -> Maybe a
+isOpaqueOf = \case
+ OpaqueValue box -> fromOpaque @a box
+ _ -> Nothing
+
+isByteString :: Syntax c -> Maybe ByteStringSorts
+isByteString = \case
+  OpaqueValue box -> do
+    let lbs = fromOpaque @LBS.ByteString box <&> ByteStringLazy
+    let bs = fromOpaque @ByteString box <&> ByteStringStrict
+    lbs <|> bs
+
+  _ -> Nothing
+
 class IsContext c where
   noContext :: Context c