voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

wip

This commit is contained in:
voidlizard 2024-10-17 09:37:27 +03:00
parent b72c3309d3
commit 233ab24c9d
8 changed files with 194 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
Makefile
View File

@ -5,6 +5,13 @@ SHELL := bash
MAKEFLAGS += --warn-undefined-variables
MAKEFLAGS += --no-builtin-rules
RT_DIR := test/RT
VPATH += test/RT
RT_FILES := $(wildcard $(RT_DIR)/*.rt)
OUT_FILES := $(RT_FILES:.rt=.out)
GHC_VERSION := 9.6.6
BIN_DIR := ./bin
BINS := \
@ -21,11 +28,24 @@ BINS := \
fixme-new \
hbs2-storage-simple-benchmarks \
RT_DIR := tests/RT
ifeq ($(origin .RECIPEPREFIX), undefined)
$(error This Make does not support .RECIPEPREFIX. Please use GNU Make 4.0 or later)
endif
.RECIPEPREFIX = >
rt: $(OUT_FILES)
%.out: %.rt
> @hbs2-cli --run $< > $(dir $<)$(notdir $@)
> @hbs2-cli \
[define r [eq? [parse:top:file root $(dir $<)$(notdir $@)] \
[parse:top:file root $(dir $<)$(basename $(notdir $@)).baseline]]] \
and [println '"[RT]"' space [if r OK FAIL] : space $(notdir $(basename $@))]
> $(RM) $(dir $<)$(notdir $@)
$(BIN_DIR):
> @mkdir -p $@

2
hbs2-cli/app/Main.hs
View File

@ -10,6 +10,7 @@ import HBS2.CLI.Run.Keyring
import HBS2.CLI.Run.GroupKey
import HBS2.CLI.Run.Sigil
import HBS2.CLI.Run.MetaData
import HBS2.CLI.Run.Tree
import HBS2.CLI.Run.Peer
import HBS2.CLI.Run.RefLog
import HBS2.CLI.Run.RefChan
@ -64,6 +65,7 @@ main = do
keyringEntries
groupKeyEntries
sigilEntries
treeEntries
metaDataEntries
peerEntries
reflogEntries

1
hbs2-cli/hbs2-cli.cabal
View File

@ -112,6 +112,7 @@ library
HBS2.CLI.Run.GroupKey
HBS2.CLI.Run.KeyMan
HBS2.CLI.Run.Keyring
HBS2.CLI.Run.Tree
HBS2.CLI.Run.MetaData
HBS2.CLI.Run.Peer
HBS2.CLI.Run.RefLog

13
hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs
View File

@ -124,6 +124,19 @@ mailboxEntries = do
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "hbs2:mailbox:policy:basic:read:storage" $ \case
[HashLike fn] -> lift do
error "FUCK"
-- what <- liftIO (readFile fn)
-- <&> parseTop
-- >>= either (error.show) pure
-- >>= parseBasicPolicy
-- >>= orThrowUser "invalid policy"
-- mkOpaque what
_ -> throwIO (BadFormException @c nil)
entry $ bindMatch "hbs2:mailbox:policy:basic:accept:peer" $ \case
[SignPubKeyLike who, OpaqueVal box] -> lift do
p <- fromOpaqueThrow @(BasicPolicy HBS2Basic) "expected BasicPolicy" box

47
hbs2-cli/lib/HBS2/CLI/Run/Tree.hs Normal file
View File

@ -0,0 +1,47 @@
module HBS2.CLI.Run.Tree
( treeEntries
) where
import HBS2.CLI.Prelude
import HBS2.CLI.Run.Internal
import HBS2.CLI.Run.Internal.GroupKey as G
import HBS2.CLI.Run.Internal.Merkle
import HBS2.Data.Types.Refs
import HBS2.Merkle
import HBS2.System.Dir
import HBS2.Storage
import HBS2.Storage.Operations.ByteString
import HBS2.Net.Auth.Schema()
import HBS2.Peer.RPC.API.Storage
import HBS2.Peer.RPC.Client
import HBS2.Peer.RPC.Client.Unix
import Control.Monad.Except
treeEntries :: forall c m . ( IsContext c
, MonadUnliftIO m
, Exception (BadFormException c)
, HasStorage m
, HasClientAPI StorageAPI UNIX m
) => MakeDictM c m ()
treeEntries = do
brief "reads merkle tree data from storage"
$ args [arg "string" "tree"]
$ desc "hbs2:tree:read HASH"
$ returns "bytestring" "data"
$ entry $ bindMatch "hbs2:tree:read" $ \case
[ HashLike h ] -> lift do
sto <- getStorage
co <- runExceptT (getTreeContents sto h)
>>= orThrowPassIO
mkOpaque co
_ -> throwIO (BadFormException @c nil)

61
miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs
View File

@ -16,6 +16,8 @@ import Control.Monad.Reader
import Control.Monad.Writer
import Data.ByteString (ByteString)
import Data.ByteString.Char8 qualified as BS8
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.Data
import Data.Function as Export
import Data.Functor as Export
@ -30,6 +32,8 @@ import Data.String
import Data.Text.IO qualified as TIO
import Data.Text qualified as Text
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (ignore)
import Data.Time.Clock.POSIX
import GHC.Generics hiding (C)
import Prettyprinter
@ -880,15 +884,24 @@ internalEntries = do
entry $ bindValue "space" $ mkStr " "
entry $ bindMatch "parse-top" $ \case
brief "parses string as toplevel and produces a form"
$ desc "parse:top:string SYMBOL STRING-LIKE"
$ entry $ bindMatch "parse:top:string" $ \case
[SymbolVal w, LitStrVal s] -> do
pure $ parseTop s & either (const nil) (mkForm w . fmap fixContext)
[SymbolVal w, LitStrVal s] -> do
pure $ parseTop s & either (const nil) (mkForm w . fmap fixContext)
[LitStrVal s] -> do
pure $ parseTop s & either (const nil) (mkList . fmap fixContext)
_ -> throwIO (BadFormException @c nil)
_ -> throwIO (BadFormException @c nil)
brief "parses file as toplevel form and produces a form"
$ desc "parse:top:file SYMBOL <FILENAME>"
$ entry $ bindMatch "parse:top:file" $ \case
[SymbolVal w, StringLike fn] -> do
s <- liftIO $ TIO.readFile fn
pure $ parseTop s & either (const nil) (mkForm w . fmap fixContext)
_ -> throwIO (BadFormException @c nil)
let atomFrom = \case
[StringLike s] -> pure (mkSym s)
@ -988,3 +1001,39 @@ internalEntries = do
_ -> throwIO (BadFormException @c nil)
brief "decodes bytes as utf8 text"
$ desc "bytes:decode <BYTES>"
$ entry $ bindMatch "bytes:decode" $ \case
[ OpaqueVal box ] -> do
let lbs' = fromOpaque @LBS.ByteString box
<|>
(LBS.fromStrict <$> fromOpaque @BS.ByteString box)
lbs <- maybe (throwIO (UnexpectedType "unknown / ByteString")) pure lbs'
-- TODO: maybe-throw-on-invalid-encoding
let txt = decodeUtf8With ignore (LBS.toStrict lbs)
pure $ mkStr txt
_ -> throwIO (BadFormException @c nil)
brief "reads bytes from a file"
$ desc "bytes:read:file FILE"
$ entry $ bindMatch "bytes:read:file" $ \case
[ StringLike fn ] -> do
liftIO (BS.readFile fn) >>= mkOpaque
_ -> throwIO (BadFormException @c nil)
brief "reads bytes from a STDIN"
$ desc "bytes:read:stdin"
$ entry $ bindMatch "bytes:read:stdin" $ \case
[] -> do
liftIO BS.getContents >>= mkOpaque
_ -> throwIO (BadFormException @c nil)

33
test/RT/test-basic-policy-1.baseline Normal file
View File

@ -0,0 +1,33 @@
;; test some basic policy
(peer deny all)
(sender deny all)
(peer allow 5tZfGUoQ79EzFUvyyY5Wh1LzN2oaqhrn9kPnfk6ByHpf)
(peer allow yFSaUfb97ZRtQqzHWdERsR7KJvN8qyWX1M8rJcxnsiu)
(peer allow 5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb)
(sender allow 5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb)
sender yFSaUfb97ZRtQqzHWdERsR7KJvN8qyWX1M8rJcxnsiu allowed #f
sender 5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb allowed #t
peer 9mzDMTUouwoSkxuQWGwCnpP5TWR2DGKLobs2edjM5fDk allowed #f
;; test empty policy
(peer deny all)
(sender deny all)
peer yFSaUfb97ZRtQqzHWdERsR7KJvN8qyWX1M8rJcxnsiu allowed #f
peer 5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb allowed #f
sender yFSaUfb97ZRtQqzHWdERsR7KJvN8qyWX1M8rJcxnsiu allowed #f
sender 5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb allowed #f
;; test malformed policy
(peer deny all)
(sender deny all)
peer yFSaUfb97ZRtQqzHWdERsR7KJvN8qyWX1M8rJcxnsiu allowed #f
peer 5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb allowed #f
sender yFSaUfb97ZRtQqzHWdERsR7KJvN8qyWX1M8rJcxnsiu allowed #f
sender 5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb allowed #f

34
test/RT/policy/test-basic-policy-1 → test/RT/test-basic-policy-1.rt
View File

@ -16,6 +16,9 @@
(define s3 9mzDMTUouwoSkxuQWGwCnpP5TWR2DGKLobs2edjM5fDk)
(define accept:sender hbs2:mailbox:policy:basic:accept:sender)
(define accept:peer hbs2:mailbox:policy:basic:accept:peer)
;; some policy
println ";; test some basic policy"
@ -26,10 +29,10 @@ hbs2:mailbox:policy:basic:dump po1
println
println sender || s1 || allowed || [hbs2:mailbox:policy:basic:accept:sender s1 po1]
println sender || s2 || allowed || [hbs2:mailbox:policy:basic:accept:sender s2 po1]
println sender || s1 || allowed || [accept:sender s1 po1]
println sender || s2 || allowed || [accept:sender s2 po1]
println peer || s3 || allowed || [hbs2:mailbox:policy:basic:accept:peer s3 po1]
println peer || s3 || allowed || [accept:peer s3 po1]
println
@ -46,28 +49,37 @@ hbs2:mailbox:policy:basic:dump po0
println
println peer || s1 || allowed || [hbs2:mailbox:policy:basic:accept:peer s1 po0]
println peer || s2 || allowed || [hbs2:mailbox:policy:basic:accept:peer s2 po0]
println peer || s1 || allowed || [accept:peer s1 po0]
println peer || s2 || allowed || [accept:peer s2 po0]
println sender || s1 || allowed || [hbs2:mailbox:policy:basic:accept:sender s1 po0]
println sender || s2 || allowed || [hbs2:mailbox:policy:basic:accept:sender s2 po0]
println sender || s1 || allowed || [accept:sender s1 po0]
println sender || s2 || allowed || [accept:sender s2 po0]
define shitty-policy [hbs2:mailbox:policy:basic:read:syntax [quot [
shit 1
shit 2
shit 3
[shit 1]
[shit 2]
[shit 3]
bullshit
]]]
;; malformed policy
println
println "test malformed policy"
println ";; test malformed policy"
println
hbs2:mailbox:policy:basic:dump shitty-policy
println
println peer || s1 || allowed || [accept:peer s1 shitty-policy]
println peer || s2 || allowed || [accept:peer s2 shitty-policy]
println sender || s1 || allowed || [accept:sender s1 shitty-policy]
println sender || s2 || allowed || [accept:sender s2 shitty-policy]