diff --git a/.fixme/log b/.fixme/log index e69de29b..a61aa318 100644 --- a/.fixme/log +++ b/.fixme/log @@ -0,0 +1,2 @@ + +(fixme-set "workflow" "test" "CGPnKdSirc") \ No newline at end of file diff --git a/flake.lock b/flake.lock index d13cdda3..ba4f51f9 100644 --- a/flake.lock +++ b/flake.lock @@ -295,11 +295,11 @@ ] }, "locked": { - "lastModified": 1679815688, - "narHash": "sha256-xLvIoeG5krM0CXfWRcwSgHGP7W8i8dsoKP5hUb182hE=", + "lastModified": 1689215736, + "narHash": "sha256-cd/iK5ttyls62RI5JYYANf2O8rV6Ubu1a/4VXDrQCBc=", "owner": "voidlizard", "repo": "suckless-conf", - "rev": "04c432681d3627f180a402674523736f409f964d", + "rev": "0ee3ef62e833df65da99af3feba9feaa7ef4d12b", "type": "github" }, "original": { diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index 51601614..b1935fe3 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -87,7 +87,6 @@ library , HBS2.Net.PeerLocator , HBS2.Net.PeerLocator.Static , HBS2.Net.Proto - , HBS2.Net.Proto.ACB , HBS2.Net.Proto.BlockAnnounce , HBS2.Net.Proto.BlockChunks , HBS2.Net.Proto.BlockInfo diff --git a/hbs2-core/lib/HBS2/Net/Proto/ACB.hs b/hbs2-core/lib/HBS2/Net/Proto/ACB.hs deleted file mode 100644 index 36769094..00000000 --- a/hbs2-core/lib/HBS2/Net/Proto/ACB.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# Language TemplateHaskell #-} -{-# Language PatternSynonyms #-} -{-# Language UndecidableInstances #-} -module HBS2.Net.Proto.ACB where - -import HBS2.Prelude.Plated -import HBS2.Net.Auth.Credentials -import HBS2.Base58 -import HBS2.Data.Types - -import Data.Config.Suckless - -import Control.Applicative -import Lens.Micro.Platform -import Codec.Serialise() -import Data.List qualified as L -import Data.Text qualified as Text -import Data.Maybe -import Data.Either - -data family ACB s - -data DefineACB s = DefineACB Text (ACB s) - -type ACBSimple s = ACB s - -data instance ACB s = - ACB1 - { _acbRoot :: !(Maybe (PubKey 'Sign s)) -- it's monoid. no choice but Maybe - , _acbOwners :: ![PubKey 'Sign s] - , _acbReaders :: ![PubKey 'Encrypt s] - , _acbWriters :: ![PubKey 'Sign s] - , _acbPrev :: !(Maybe HashRef) - } - deriving stock (Generic) - - -makeLenses 'ACB1 - -type ForACB e = ( Serialise (PubKey 'Sign e) - , Serialise (PubKey 'Encrypt e) - , Eq (PubKey 'Sign e) - , Eq (PubKey 'Encrypt e) - , FromStringMaybe (PubKey 'Sign e) - , FromStringMaybe (PubKey 'Encrypt e) - ) - -deriving instance ForACB e => Eq (ACBSimple e) - -instance ForACB e => Serialise (ACBSimple e) - -instance ForACB e => Monoid (ACBSimple e) where - mempty = ACB1 Nothing mempty mempty mempty Nothing - -instance ForACB e => Semigroup (ACBSimple e) where - (<>) a b = ACB1 (view acbRoot a <|> view acbRoot b) - (L.nub (view acbOwners a <> view acbOwners b)) - (L.nub (view acbReaders a <> view acbReaders b)) - (L.nub (view acbWriters a <> view acbWriters b)) - (view acbPrev a <|> view acbPrev b) - - -instance ( Pretty (AsBase58 (PubKey 'Sign s)) - , Pretty (AsBase58 (PubKey 'Encrypt s) ) - ) => Pretty (AsSyntax (DefineACB s)) where - pretty (AsSyntax (DefineACB nacb' acb)) = vcat [ - "define-acb" <+> nacb - , prev - , root - , owners - , readers - , writers - , line - ] - - where - - nacb = pretty nacb' - - wacb = (<+> nacb) - - prev = maybe mempty (dquotes . pretty . AsBase58) (view acbPrev acb) - - root = maybe mempty ( (acbR <+>) . dquotes . pretty . AsBase58 ) (view acbRoot acb) - owners = vcat $ fmap owner (view acbOwners acb) - acbR = "acb-root" <+> nacb - readers = vcat $ fmap reader (view acbReaders acb) - writers = vcat $ fmap writer (view acbWriters acb) - - owner = (wacb "acb-owner" <+>) . dquotes . pretty . AsBase58 - reader = (wacb "acb-reader" <+>) . dquotes . pretty . AsBase58 - writer = (wacb "acb-writer" <+>) . dquotes . pretty . AsBase58 - - -pattern Key :: forall {c}. Id -> [Syntax c] -> [Syntax c] -pattern Key n ns <- SymbolVal n : ns - -instance ForACB s => FromStringMaybe (ACB s) where - fromStringMay s = Just $ ACB1 root owners readers writers prev - - where - parsed = parseTop s & fromRight mempty - defAcb = headMay [ acb | (ListVal (Key "define-acb" [SymbolVal acb]) ) <- parsed ] - - root = lastMay $ catMaybes $ - [ fromStringMay (Text.unpack e) - | (ListVal (Key "acb-root" [SymbolVal a, LitStrVal e]) ) <- parsed - , Just a == defAcb - ] - - owners = L.nub $ catMaybes - [ fromStringMay (Text.unpack e) - | (ListVal (Key "acb-owner" [SymbolVal a, LitStrVal e]) ) <- parsed - , Just a == defAcb - ] - - readers = L.nub $ catMaybes - [ fromStringMay (Text.unpack e) - | (ListVal (Key "acb-reader" [SymbolVal a, LitStrVal e]) ) <- parsed - , Just a == defAcb - ] - - writers = L.nub $ catMaybes - [ fromStringMay (Text.unpack e) - | (ListVal (Key "acb-writer" [SymbolVal a, LitStrVal e]) ) <- parsed - , Just a == defAcb - ] - - prev =lastMay $ catMaybes $ - [ fromStringMay (Text.unpack e) - | (ListVal (Key "acb-prev" [SymbolVal a, LitStrVal e]) ) <- parsed - , Just a == defAcb - ] - - diff --git a/hbs2-git/lib/HBS2Git/Types.hs b/hbs2-git/lib/HBS2Git/Types.hs index fd1af37b..d5f54d6f 100644 --- a/hbs2-git/lib/HBS2Git/Types.hs +++ b/hbs2-git/lib/HBS2Git/Types.hs @@ -62,8 +62,6 @@ makeLenses 'DBEnv type RepoRef = RefLogKey Schema -type C = MegaParsec - data ConfBranch data HeadBranch data KeyRingFile @@ -140,9 +138,6 @@ instance FromStringMaybe RepoHead where decodePair other = Left other -pattern Key :: forall {c}. Id -> [Syntax c] -> [Syntax c] -pattern Key n ns <- SymbolVal n : ns - class HasProgress m where type family ProgressMonitor m :: Type newProgressMonitor :: String -> Int -> m (ProgressMonitor m) @@ -187,16 +182,6 @@ instance (HasCatAPI m, MonadIO m) => HasCatAPI (ResourceT m) where -- getHttpPutAPI = lift getHttpPutAPI -- getHttpRefLogGetAPI = lift getHttpRefLogGetAPI -class Monad m => HasCfgKey a b m where - -- type family CfgValue a :: Type - key :: Id - -class (Monad m, HasCfgKey a b m) => HasCfgValue a b m where - cfgValue :: m b - -class Monad m => HasConf m where - getConf :: m [Syntax C] - newtype App m a = App { fromApp :: ReaderT AppEnv m a } deriving newtype ( Applicative @@ -214,20 +199,6 @@ newtype App m a = instance MonadIO m => HasConf (App m) where getConf = asks (view appConf) -instance {-# OVERLAPPABLE #-} (HasConf m, Ord b, IsString b, HasCfgKey a (Maybe b) m) => HasCfgValue a (Maybe b) m where - cfgValue = lastMay . val <$> getConf - where - val syn = [ fromString (show $ pretty e) - | ListVal @C (Key s [LitStrVal e]) <- syn, s == key @a @(Maybe b) @m - ] - -instance {-# OVERLAPPABLE #-} (HasConf m, Ord b, IsString b, HasCfgKey a (Set b) m) => HasCfgValue a (Set b) m where - cfgValue = Set.fromList . val <$> getConf - where - val syn = [ fromString (show $ pretty e) - | ListVal @C (Key s [LitStrVal e]) <- syn, s == key @a @(Set b) @m - ] - hPrint :: (Show a, MonadIO m) => Handle -> a -> m () hPrint h s = liftIO $ IO.hPrint h s diff --git a/hbs2-peer/app/PeerConfig.hs b/hbs2-peer/app/PeerConfig.hs index 48c8bcb1..c4f55ec0 100644 --- a/hbs2-peer/app/PeerConfig.hs +++ b/hbs2-peer/app/PeerConfig.hs @@ -3,14 +3,16 @@ {-# Language PatternSynonyms #-} module PeerConfig ( module PeerConfig - , module Data.Config.Suckless + , module Data.Config.Suckless.Syntax + , module Data.Config.Suckless.Parse ) where import HBS2.Prelude.Plated import HBS2.System.Logger.Simple import HBS2.Base58 -import Data.Config.Suckless +import Data.Config.Suckless.Syntax +import Data.Config.Suckless.Parse import Control.Exception import Data.Either diff --git a/hbs2-tests/hbs2-tests.cabal b/hbs2-tests/hbs2-tests.cabal index 6f10f04a..749b3a4f 100644 --- a/hbs2-tests/hbs2-tests.cabal +++ b/hbs2-tests/hbs2-tests.cabal @@ -358,54 +358,6 @@ executable test-saltine , fast-logger -test-suite test-acb - import: shared-properties - import: common-deps - default-language: Haskell2010 - - ghc-options: - -- -prof - -- -fprof-auto - - other-modules: - - -- other-extensions: - - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: TestACB.hs - - build-depends: - base, hbs2-core - -- , async - -- , attoparsec - -- , bytestring - -- , cache - -- , clock - , containers - -- , data-default - -- , data-textual - -- , directory - -- , hashable - -- , microlens-platform - -- , mtl - -- , mwc-random - -- , network - -- , network-ip - -- , prettyprinter - -- , random - -- , safe - -- , serialise - -- , stm - -- , streaming - -- , saltine - , text - -- , transformers - -- , uniplate - -- , vector - -- , fast-logger - - executable test-walk-tree-meta import: shared-properties import: common-deps diff --git a/hbs2-tests/test/TestACB.hs b/hbs2-tests/test/TestACB.hs deleted file mode 100644 index 5c131e91..00000000 --- a/hbs2-tests/test/TestACB.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# Language PatternSynonyms #-} -module Main where - -import HBS2.Prelude -import HBS2.Net.Proto.ACB -import HBS2.Data.Types -import HBS2.Net.Auth.Credentials -import HBS2.Net.Proto.Definition -import HBS2.OrDie --- import HBS2.Net.Messaging.UDP - -import Test.Tasty.HUnit -import Data.Config.Suckless - -import Data.Maybe -import Prettyprinter -import System.IO -import Lens.Micro.Platform -import Data.Either -import Data.Text qualified as Text -import Safe - -data T - -type SK = PubKey 'Sign T - - - -main :: IO () -main = do - - let pek1 = fromStringMay "5k9rLmFdXCP4RncG9WHEaXXEjxvnxmBvvMUqcKkoY45q" - let pek2 = fromStringMay "FpZbzEbdFBztGUSXy5yCoWgkYUbJYDuCmSVxFTTrHx7D" - - let root = fromStringMay @SK "sRyP45vd7wnopdLP6MLxUJAFGJu5wGVHyzF64mKwBbH" - let owners = catMaybes [ fromStringMay "EJgvBg9bL2yKXk3GvZaYJgqpHy5kvpXdtEnAgoi4B5DN" ] - - let acb = set acbRoot root - . set acbOwners ( owners <> maybeToList root ) - . set acbWriters ( owners <> maybeToList root ) - . set acbReaders ( catMaybes [pek1, pek2 ] ) - $ mempty :: ACBSimple T - - let s = show $ pretty (AsSyntax (DefineACB "a1" acb)) - - putStrLn s - - let macb2 = fromStringMay s :: Maybe (ACBSimple T) - - acb2 <- pure macb2 `orDie` "can't load ACB" - - print $ pretty (AsSyntax (DefineACB "a1" acb2)) - - assertBool "1" $ view acbRoot acb == view acbRoot acb2 - assertBool "2" $ view acbOwners acb == view acbOwners acb2 - assertBool "3" $ view acbReaders acb == view acbReaders acb2 - assertBool "4" $ view acbWriters acb == view acbWriters acb2 - assertBool "5" $ view acbPrev acb == view acbPrev acb2 - - assertBool "6" $ acb == acb2 - - -- TODO: acbPrev test - - pure () - - diff --git a/hbs2/Main.hs b/hbs2/Main.hs index d81eb2f4..9b385153 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -13,7 +13,6 @@ import HBS2.Prelude.Plated import HBS2.Storage.Simple import HBS2.Storage.Simple.Extra import HBS2.OrDie -import HBS2.Net.Proto.ACB import HBS2.System.Logger.Simple hiding (info) @@ -338,24 +337,7 @@ runShowPeerKey fp = do maybe1 cred' exitFailure $ \cred -> do print $ pretty $ AsBase58 (view peerSignPk cred) --- FIXME: hardcoded-encryption-schema -runGenACB :: Maybe FilePath -> Maybe FilePath -> IO () -runGenACB inFile outFile = do - inf <- maybe (pure stdin) (`openFile` ReadMode) inFile - s <- hGetContents inf - acb <- pure (fromStringMay s :: Maybe (ACBSimple HBS2Basic)) `orDie` "invalid ACB syntax" - let bin = serialise acb - out <- maybe (pure stdout) (`openFile` WriteMode) outFile - LBS.hPutStr out bin - hClose out - hClose inf -runDumpACB :: Maybe FilePath -> IO () -runDumpACB inFile = do - inf <- maybe (pure stdin) (`openFile` ReadMode) inFile - acb <- LBS.hGetContents inf <&> deserialise @(ACBSimple HBS2Basic) - -- acb <- LBS.hGetContents inf <&> (either (error . show) id . deserialiseOrFail @(ACBSimple HBS2Basic)) - print $ pretty (AsSyntax (DefineACB "a1" acb)) --- @@ -560,8 +542,6 @@ main = join . customExecParser (prefs showHelpOnError) $ <> command "keyring-key-del" (info pKeyDel (progDesc "removes a keypair from the keyring")) <> command "show-peer-key" (info pShowPeerKey (progDesc "show peer key from credential file")) <> command "groupkey-new" (info pNewGroupkey (progDesc "generates a new groupkey")) - <> command "acb-gen" (info pACBGen (progDesc "generates binary ACB from text config")) - <> command "acb-dump" (info pACBDump (progDesc "dumps binary ACB to text config")) <> command "lref-new" (info pNewLRef (progDesc "generates a new linear ref")) <> command "lref-list" (info pListLRef (progDesc "list node linear refs")) <> command "lref-get" (info pGetLRef (progDesc "get a linear ref")) @@ -621,15 +601,6 @@ main = join . customExecParser (prefs showHelpOnError) $ f <- strArgument ( metavar "KEYRING-FILE" ) pure (runKeyDel s f) - pACBGen = do - f <- optional $ strArgument ( metavar "ACB-FILE-INPUT" ) - o <- optional $ strArgument ( metavar "ACB-FILE-OUTPUT" ) - pure (runGenACB f o) - - pACBDump = do - f <- optional $ strArgument ( metavar "ACB-FILE-INPUT" ) - pure (runDumpACB f) - pNewLRef = do nodeCredFile <- strArgument ( metavar "NODE-KEYRING-FILE" ) ownerCredFile <- strArgument ( metavar "REF-OWNER-KEYRING-FILE" )