diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs b/hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs index 141cc9db..6d1191aa 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs +++ b/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) diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs b/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs index 67678bc2..12617937 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/Data/Types/SignedBox.hs b/hbs2-core/lib/HBS2/Data/Types/SignedBox.hs index 62f4e061..d4a88ae0 100644 --- a/hbs2-core/lib/HBS2/Data/Types/SignedBox.hs +++ b/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) ) diff --git a/hbs2-core/lib/HBS2/Data/Types/SmallEncryptedBlock.hs b/hbs2-core/lib/HBS2/Data/Types/SmallEncryptedBlock.hs index 7fbba673..a3d22869 100644 --- a/hbs2-core/lib/HBS2/Data/Types/SmallEncryptedBlock.hs +++ b/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) diff --git a/hbs2-core/lib/HBS2/Net/Auth/Credentials/Sigil.hs b/hbs2-core/lib/HBS2/Net/Auth/Credentials/Sigil.hs index ed90fcbf..70f8c6f0 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/Credentials/Sigil.hs +++ b/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) ) diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs index 331b962b..61d2f8f6 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Types.hs +++ b/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 diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs index a0045ea1..ac5d20a8 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs +++ b/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)) ) diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs index dd9cb2b8..9067aefe 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs +++ b/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