diff --git a/.envrc b/.envrc index ce34212a..b83dc681 100644 --- a/.envrc +++ b/.envrc @@ -1,3 +1,4 @@ +## wtf if [ -f .envrc.local ]; then source_env .envrc.local fi diff --git a/.fixme-new/.gitignore b/.fixme-new/.gitignore new file mode 100644 index 00000000..a247e95f --- /dev/null +++ b/.fixme-new/.gitignore @@ -0,0 +1 @@ +state.db diff --git a/.fixme-new/config b/.fixme-new/config new file mode 100644 index 00000000..6842955e --- /dev/null +++ b/.fixme-new/config @@ -0,0 +1,106 @@ + +; fixme-files **/*.hs docs/devlog.md + +; no-debug +; debug + +fixme-prefix FIXME: +fixme-prefix TODO: +fixme-prefix PR: +fixme-prefix REVIEW: + +fixme-git-scan-filter-days 30 + +fixme-attribs assigned workflow type + +fixme-attribs resolution cat scope + +fixme-value-set workflow new backlog wip test fixed done + +fixme-value-set cat bug feat refactor + +fixme-value-set scope mvp-0 mvp-1 backlog + +fixme-value-set type bug feature code + +fixme-files **/*.txt docs/devlog.md +fixme-files **/*.hs + +fixme-file-comments "*.scm" ";" + +fixme-comments ";" "--" + +(update-action + (import-git-logs ".fixme-new/log") +) + +(update-action + (import ".fixme-new/fixme.log") +) + +(update-action + (export ".fixme-new/fixme.log") +) + + +(update-action + (hello kitty) +) + +(define-macro done + (modify $1 workflow done) +) + +(define-macro wip + (modify $1 workflow wip) +) + +(define-macro test + (modify $1 workflow test) +) + +(define-macro backlog + (modify $1 workflow backlog) +) + +(define-macro fixed + (modify $1 workflow fixed) +) + +(define-macro new + (modify $1 workflow new) +) + +(define-macro stage + (builtin:show-stage)) + +(define-macro log + (builtin:show-log .fixme-new/fixme.log)) + + +(define-template short + (simple + (trim 10 $fixme-key) " " + + (if (~ FIXME $fixme-tag) + (then (fgd red (align 6 $fixme-tag)) ) + (else (if (~ TODO $fixme-tag) + (then (fgd green (align 6 $fixme-tag))) + (else (align 6 $fixme-tag)) ) ) + ) + + + (align 10 ("[" $workflow "]")) " " + (align 8 $type) " " + (align 12 $assigned) " " + (align 20 (trim 20 $committer-name)) " " + (trim 50 ($fixme-title)) " " + (nl) + ) +) + +(set-template default short) + +; update + + diff --git a/.fixme-new/fixme.log b/.fixme-new/fixme.log new file mode 100644 index 00000000..d35da624 Binary files /dev/null and b/.fixme-new/fixme.log differ diff --git a/.fixme/config b/.fixme/config index fc21f46a..c867bd3d 100644 --- a/.fixme/config +++ b/.fixme/config @@ -20,8 +20,7 @@ fixme-files docs/notes/**/*.txt fixme-files-ignore .direnv/** dist-newstyle/** -fixme-id-show-len 10 - +fixme-id-show-len 12 fixme-attribs assigned workflow resolution cat scope diff --git a/.fixme/log b/.fixme/log index 2da00207..245c419e 100644 --- a/.fixme/log +++ b/.fixme/log @@ -1,2 +1,3 @@ -(fixme-set "workflow" "done" "RsTry2C5Gk") \ No newline at end of file +(fixme-set "workflow" "done" "RsTry2C5Gk") +(fixme-set "workflow" "done" "DYfcfsNCrU") \ No newline at end of file diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 00000000..9b69395a --- /dev/null +++ b/.gitattributes @@ -0,0 +1,2 @@ +.fixme-new/log merge=fixme-log-merge +.fixme-new/fixme.log merge=fixme-log-merge diff --git a/.gitignore b/.gitignore index 0479bb49..bcd3f9ac 100644 --- a/.gitignore +++ b/.gitignore @@ -11,3 +11,5 @@ cabal.project.local .backup/ .hbs2-git/ +bin/ +.fixme-new/current-stage.log diff --git a/CHANGELOG.md b/CHANGELOG.md index 88d20478..a4de3c3d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,4 @@ -# 0.24.1.1 2024-04-02 - - Don't do HTTP redirect on /ref/XXXXXXXXXX requests; show content directly +# 0.24.1.2 2024-04-27 + - Bump scotty version + diff --git a/Makefile b/Makefile index 5757ba4b..3b1858d8 100644 --- a/Makefile +++ b/Makefile @@ -13,8 +13,13 @@ BINS := \ hbs2-keyman \ hbs2-fixer \ hbs2-git-subscribe \ + hbs2-git-dashboard \ git-remote-hbs2 \ git-hbs2 \ + hbs2-cli \ + hbs2-sync \ + fixme-new \ + hbs2-storage-simple-benchmarks \ ifeq ($(origin .RECIPEPREFIX), undefined) $(error This Make does not support .RECIPEPREFIX. Please use GNU Make 4.0 or later) diff --git a/cabal.project b/cabal.project index 42ba3ea8..83818f3c 100644 --- a/cabal.project +++ b/cabal.project @@ -3,6 +3,9 @@ packages: **/*.cabal allow-newer: all +constraints: pandoc >=3.1.11, suckless-conf >= 0.1.2.6 + + -- executable-static: True -- profiling: True -- library-profiling: False diff --git a/examples/refchan-qblf/app/RefChanQBLFMain.hs b/examples/refchan-qblf/app/RefChanQBLFMain.hs index eea5a666..ef9e2783 100644 --- a/examples/refchan-qblf/app/RefChanQBLFMain.hs +++ b/examples/refchan-qblf/app/RefChanQBLFMain.hs @@ -70,36 +70,36 @@ data DefStateOpt data StateRefOpt data QBLFRefKey -type MyRefKey = AnyRefKey QBLFRefKey HBS2Basic +type MyRefKey = AnyRefKey QBLFRefKey 'HBS2Basic -instance Monad m => HasCfgKey HttpPortOpt (Maybe Int) m where +instance HasCfgKey HttpPortOpt (Maybe Int) where key = "http" -instance {-# OVERLAPPING #-} (HasConf m, HasCfgKey HttpPortOpt (Maybe Int) m) => HasCfgValue HttpPortOpt (Maybe Int) m where +instance {-# OVERLAPPING #-} (HasConf m, HasCfgKey HttpPortOpt (Maybe Int)) => HasCfgValue HttpPortOpt (Maybe Int) m where cfgValue = val <$> getConf where val syn = lastMay [ fromIntegral e - | ListVal (Key s [LitIntVal e]) <- syn, s == key @HttpPortOpt @(Maybe Int) @m + | ListVal (Key s [LitIntVal e]) <- syn, s == key @HttpPortOpt @(Maybe Int) ] -instance Monad m => HasCfgKey RefChanOpt (Maybe String) m where +instance HasCfgKey RefChanOpt (Maybe String) where key = "refchan" -instance Monad m => HasCfgKey SocketOpt (Maybe String) m where +instance HasCfgKey SocketOpt (Maybe String) where key = "socket" -instance Monad m => HasCfgKey ActorOpt (Maybe String) m where +instance HasCfgKey ActorOpt (Maybe String) where key = "actor" -instance Monad m => HasCfgKey DefStateOpt (Maybe String) m where +instance HasCfgKey DefStateOpt (Maybe String) where key = "default-state" -instance Monad m => HasCfgKey StateRefOpt (Maybe String) m where +instance HasCfgKey StateRefOpt (Maybe String) where key = "state-ref" -class ToBalance e tx where - toBalance :: tx -> [(Account e, Amount)] +class ToBalance s tx where + toBalance :: tx -> [(Account s, Amount)] tracePrefix :: SetLoggerEntry tracePrefix = toStderr . logPrefix "[trace] " @@ -153,7 +153,7 @@ data MyEnv = , myChan :: RefChanId UNIX , myRef :: MyRefKey , mySto :: AnyStorage - , myCred :: PeerCredentials HBS2Basic + , myCred :: PeerCredentials 'HBS2Basic , myHttpPort :: Int , myFetch :: Cache HashRef () } @@ -211,8 +211,8 @@ instance Monad m => HasTimeLimits UNIX (RefChanNotify UNIX) (App m) where tryLockForPeriod _ _ = pure True instance (ForConsensus m, MonadUnliftIO m) => IsQBLF ConsensusQBLF (App m) where - type QBLFActor ConsensusQBLF = Actor L4Proto - type QBLFTransaction ConsensusQBLF = QBLFDemoToken L4Proto + type QBLFActor ConsensusQBLF = Actor 'HBS2Basic + type QBLFTransaction ConsensusQBLF = QBLFDemoToken 'HBS2Basic type QBLFState ConsensusQBLF = DAppState qblfMoveForward _ s1 = do @@ -247,7 +247,7 @@ instance (ForConsensus m, MonadUnliftIO m) => IsQBLF ConsensusQBLF (App m) wher -- пробуем разослать бандлы с транзакциями runMaybeT do ref <- MaybeT $ createBundle sto (fmap HashRef hashes) - let refval = makeBundleRefValue @L4Proto pk sk (BundleRefSimple ref) + let refval = makeBundleRefValue @'HBS2Basic pk sk (BundleRefSimple ref) r <- MaybeT $ liftIO $ putBlock sto (serialise refval) lift $ request self (ActionRequest @UNIX chan (RefChanAnnounceBlock (HashRef r))) @@ -280,7 +280,7 @@ instance (ForConsensus m, MonadUnliftIO m) => IsQBLF ConsensusQBLF (App m) wher let sk = view peerSignSk creds let pk = view peerSignPk creds nonce <- randomIO @Word64 <&> serialise <&> LBS.toStrict - let box = makeSignedBox @UNIX pk sk (LBS.toStrict (serialise msg) <> nonce) + let box = makeSignedBox pk sk (LBS.toStrict (serialise msg) <> nonce) let notify = Notify @UNIX chan box request self notify @@ -327,17 +327,17 @@ instance (ForConsensus m, MonadUnliftIO m) => IsQBLF ConsensusQBLF (App m) wher bs <- MaybeT $ liftIO $ getBlock sto (fromHashRef t) - tx <- MaybeT $ pure $ deserialiseOrFail @(QBLFDemoToken L4Proto) bs & either (const Nothing) Just + tx <- MaybeT $ pure $ deserialiseOrFail @(QBLFDemoToken 'HBS2Basic) bs & either (const Nothing) Just case tx of Emit box -> do - (pk, e@(EmitTx a q _)) <- MaybeT $ pure $ unboxSignedBox0 @(EmitTx L4Proto) box + (pk, e@(EmitTx a q _)) <- MaybeT $ pure $ unboxSignedBox0 @(EmitTx 'HBS2Basic) box guard ( chan == pk ) debug $ "VALID EMIT TRANSACTION" <+> pretty t <+> pretty (AsBase58 a) <+> pretty q pure ([(t,e)], mempty) (Move box) -> do - (_, m@(MoveTx _ _ qty _)) <- MaybeT $ pure $ unboxSignedBox0 @(MoveTx L4Proto) box + (_, m@(MoveTx _ _ qty _)) <- MaybeT $ pure $ unboxSignedBox0 @(MoveTx 'HBS2Basic) box guard (qty > 0) debug $ "MOVE TRANSACTION" <+> pretty t @@ -352,7 +352,7 @@ instance (ForConsensus m, MonadUnliftIO m) => IsQBLF ConsensusQBLF (App m) wher bal0 <- balances (fromDAppState s0) -- баланс с учётом новых emit - let balE = foldMap (toBalance @L4Proto . snd) emits + let balE = foldMap (toBalance @'HBS2Basic. snd) emits & HashMap.fromListWith (+) & HashMap.unionWith (+) bal0 @@ -391,12 +391,12 @@ balances :: forall e s m . ( e ~ L4Proto , HasStorage m -- , FromStringMaybe (PubKey 'Sign s) , s ~ Encryption e - , ToBalance L4Proto (EmitTx L4Proto) - , ToBalance L4Proto (MoveTx L4Proto) + , ToBalance s (EmitTx s) + , ToBalance s (MoveTx s) , Pretty (AsBase58 (PubKey 'Sign s)) ) => HashRef - -> m (HashMap (Account e) Amount) + -> m (HashMap (Account s) Amount) balances root = do sto <- getStorage @@ -406,7 +406,7 @@ balances root = do cached <- runMaybeT do rval <- MaybeT $ liftIO $ getRef sto pk val <- MaybeT $ liftIO $ getBlock sto rval - MaybeT $ deserialiseOrFail @(HashMap (Account e) Amount) val + MaybeT $ deserialiseOrFail @(HashMap (Account s) Amount) val & either (const $ pure Nothing) (pure . Just) case cached of @@ -417,16 +417,16 @@ balances root = do r <- forM txs $ \h -> runMaybeT do blk <- MaybeT $ liftIO $ getBlock sto (fromHashRef h) - tx <- MaybeT $ pure $ deserialiseOrFail @(QBLFDemoToken L4Proto) blk & either (const Nothing) Just + tx <- MaybeT $ pure $ deserialiseOrFail @(QBLFDemoToken s) blk & either (const Nothing) Just case tx of Emit box -> do - (_, emit) <- MaybeT $ pure $ unboxSignedBox0 @(EmitTx L4Proto) box - pure $ toBalance @e emit + (_, emit) <- MaybeT $ pure $ unboxSignedBox0 @(EmitTx s) box + pure $ toBalance @s emit Move box -> do - (_, move) <- MaybeT $ pure $ unboxSignedBox0 @(MoveTx L4Proto) box - pure $ toBalance @e move + (_, move) <- MaybeT $ pure $ unboxSignedBox0 @(MoveTx s) box + pure $ toBalance @s move let val = catMaybes r & mconcat & HashMap.fromListWith (+) @@ -450,8 +450,8 @@ balances root = do -- -> [(tx, b)] -- -> [(tx, b)] -updBalances :: forall e a tx . (ForRefChans e, ToBalance e tx) - => HashMap (Account e) Amount +updBalances :: forall e s a tx . (ForRefChans e, ToBalance s tx, s ~ Encryption e) + => HashMap (Account s) Amount -> [(a, tx)] -> [(a, tx)] @@ -467,7 +467,7 @@ updBalances = go go bal rest where - nb = HashMap.unionWith (+) bal (HashMap.fromList (toBalance @e (snd t))) + nb = HashMap.unionWith (+) bal (HashMap.fromList (toBalance @s (snd t))) good = HashMap.filter (<0) nb & HashMap.null @@ -515,7 +515,7 @@ runMe conf = withLogging $ flip runReaderT conf do ) `orDie` "state-ref not set" sc <- liftIO $ BS.readFile kr - creds <- pure (parseCredentials @HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file" + creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file" chan <- pure (fromStringMay @(RefChanId L4Proto) chan') `orDie` "invalid REFCHAN" @@ -560,11 +560,11 @@ runMe conf = withLogging $ flip runReaderT conf do headBlk <- getRefChanHead @L4Proto sto (RefChanHeadKey chan) `orDie` "can't read head block" - let self = view peerSignPk creds & Actor @L4Proto + let self = view peerSignPk creds & Actor let actors = view refChanHeadAuthors headBlk & HashSet.toList - & fmap (Actor @L4Proto) + & fmap Actor runApp myEnv do @@ -590,7 +590,7 @@ runMe conf = withLogging $ flip runReaderT conf do debug $ "GOT TX" <+> pretty hBin - tok <- check DeserializationError =<< pure (deserialiseOrFail @(QBLFDemoToken L4Proto) bin) + tok <- check DeserializationError =<< pure (deserialiseOrFail @(QBLFDemoToken 'HBS2Basic) bin) tx <- case tok of (Emit box) -> do @@ -649,7 +649,7 @@ runMe conf = withLogging $ flip runReaderT conf do let coco = hashObject @HbSync $ serialise msg void $ runMaybeT do - (_, wrapped) <- MaybeT $ pure $ unboxSignedBox0 @ByteString @UNIX msg + (_, wrapped) <- MaybeT $ pure $ unboxSignedBox0 msg qbmess <- MaybeT $ pure $ deserialiseOrFail @(QBLFMessage ConsensusQBLF) (LBS.fromStrict wrapped) & either (const Nothing) Just @@ -687,7 +687,7 @@ runMe conf = withLogging $ flip runReaderT conf do Just val -> do pure val -type Config = [Syntax MegaParsec] +type Config = [Syntax C] main :: IO () main = join . customExecParser (prefs showHelpOnError) $ @@ -729,11 +729,11 @@ main = join . customExecParser (prefs showHelpOnError) $ dest <- strArgument ( metavar "ADDRESS" ) pure $ const $ silently do sc <- BS.readFile kr - creds <- pure (parseCredentials @HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file" + creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file" let pk = view peerSignPk creds let sk = view peerSignSk creds acc <- pure (fromStringMay @(RefChanId L4Proto) dest) `orDie` "bad account address" - tx <- makeEmitTx @L4Proto pk sk acc amnt + tx <- makeEmitTx @_ @L4Proto pk sk acc amnt LBS.putStr $ serialise tx pGenMove = do @@ -742,29 +742,29 @@ main = join . customExecParser (prefs showHelpOnError) $ dest <- strArgument ( metavar "ADDRESS" ) pure $ const $ silently do sc <- BS.readFile kr - creds <- pure (parseCredentials @HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file" + creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file" let pk = view peerSignPk creds let sk = view peerSignSk creds acc <- pure (fromStringMay @(RefChanId L4Proto) dest) `orDie` "bad account address" - tx <- makeMoveTx @L4Proto pk sk acc amnt + tx <- makeMoveTx @_ @L4Proto pk sk acc amnt LBS.putStr $ serialise tx pCheckTx = do kr <- strOption ( long "keyring" <> short 'k' <> help "keyring file" ) pure $ const do sc <- BS.readFile kr - creds <- pure (parseCredentials @HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file" + creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file" let pk = view peerSignPk creds let sk = view peerSignSk creds - tx <- LBS.getContents <&> deserialise @(QBLFDemoToken L4Proto) + tx <- LBS.getContents <&> deserialise @(QBLFDemoToken 'HBS2Basic) case tx of Emit box -> do - void $ pure (unboxSignedBox0 @(EmitTx L4Proto) @L4Proto box) `orDie` "bad emit tx" + void $ pure (unboxSignedBox0 box) `orDie` "bad emit tx" Move box -> do - void $ pure (unboxSignedBox0 @(MoveTx L4Proto) @L4Proto box) `orDie` "bad move tx" + void $ pure (unboxSignedBox0 box) `orDie` "bad move tx" pure () diff --git a/examples/refchan-qblf/lib/Demo/QBLF/Transactions.hs b/examples/refchan-qblf/lib/Demo/QBLF/Transactions.hs index 59f184af..1b131e1c 100644 --- a/examples/refchan-qblf/lib/Demo/QBLF/Transactions.hs +++ b/examples/refchan-qblf/lib/Demo/QBLF/Transactions.hs @@ -1,4 +1,6 @@ {-# Language UndecidableInstances #-} +{-# Language AllowAmbiguousTypes #-} +{-# Language TypeOperators #-} module Demo.QBLF.Transactions where import HBS2.Prelude.Plated @@ -16,17 +18,17 @@ import Data.ByteString.Lazy (ByteString) import Data.Word (Word64) import System.Random -newtype Actor e = - Actor { fromActor :: PubKey 'Sign (Encryption e) } +newtype Actor s = + Actor { fromActor :: PubKey 'Sign s } deriving stock (Generic) -deriving stock instance Eq (PubKey 'Sign (Encryption e)) => Eq (Actor e) -deriving newtype instance Hashable (PubKey 'Sign (Encryption e)) => Hashable (Actor e) +deriving stock instance Eq (PubKey 'Sign s) => Eq (Actor s) +deriving newtype instance Hashable (PubKey 'Sign s) => Hashable (Actor s) -instance Pretty (AsBase58 (PubKey 'Sign (Encryption e))) => Pretty (Actor e) where +instance Pretty (AsBase58 (PubKey 'Sign s)) => Pretty (Actor s) where pretty (Actor a) = pretty (AsBase58 a) -type Account e = PubKey 'Sign (Encryption e) +type Account s = PubKey 'Sign s newtype Amount = Amount Integer deriving stock (Eq,Show,Ord,Data,Generic) @@ -39,48 +41,48 @@ newtype DAppState = DAppState { fromDAppState :: HashRef } instance Hashed HbSync DAppState where hashObject (DAppState (HashRef h)) = h -data EmitTx e = EmitTx (Account e) Amount Word64 +data EmitTx s = EmitTx (Account s) Amount Word64 deriving stock (Generic) -data MoveTx e = MoveTx (Account e) (Account e) Amount Word64 +data MoveTx s = MoveTx (Account s) (Account s) Amount Word64 deriving stock (Generic) -data QBLFDemoToken e = - Emit (SignedBox (EmitTx e) e) -- proof: owner's key - | Move (SignedBox (MoveTx e) e) -- proof: wallet's key +data QBLFDemoToken s = + Emit (SignedBox (EmitTx s) s) -- proof: owner's key + | Move (SignedBox (MoveTx s) s) -- proof: wallet's key deriving stock (Generic) -instance ForRefChans e => Serialise (Actor e) +instance ForQBLFDemoToken s => Serialise (Actor s) instance Serialise DAppState instance Serialise Amount -instance Serialise (PubKey 'Sign (Encryption e)) => Serialise (EmitTx e) +instance ForQBLFDemoToken s => Serialise (EmitTx s) -instance Serialise (PubKey 'Sign (Encryption e)) => Serialise (MoveTx e) +instance ForQBLFDemoToken s => Serialise (MoveTx s) -instance (Serialise (Account e), ForRefChans e) => Serialise (QBLFDemoToken e) +instance ForQBLFDemoToken s => Serialise (QBLFDemoToken s) -type ForQBLFDemoToken e = ( Eq (PubKey 'Sign (Encryption e)) - , Eq (Signature (Encryption e)) - , Pretty (AsBase58 (PubKey 'Sign (Encryption e))) - , ForSignedBox e - , FromStringMaybe (PubKey 'Sign (Encryption e)) - , Serialise (PubKey 'Sign (Encryption e)) - , Serialise (Signature (Encryption e)) - , Hashable (PubKey 'Sign (Encryption e)) +type ForQBLFDemoToken s = ( Eq (PubKey 'Sign s) + , Eq (Signature s) + , Pretty (AsBase58 (PubKey 'Sign s)) + , ForSignedBox s + , FromStringMaybe (PubKey 'Sign s) + , Serialise (PubKey 'Sign s) + , Serialise (Signature s) + , Hashable (PubKey 'Sign s) ) -deriving stock instance (ForQBLFDemoToken e) => Eq (QBLFDemoToken e) +deriving stock instance (ForQBLFDemoToken s) => Eq (QBLFDemoToken s) -instance ForQBLFDemoToken e => Hashable (QBLFDemoToken e) where +instance ForQBLFDemoToken s => Hashable (QBLFDemoToken s) where hashWithSalt salt = \case Emit box -> hashWithSalt salt box Move box -> hashWithSalt salt box newtype QBLFDemoTran e = - QBLFDemoTran (SignedBox (QBLFDemoToken e) e) + QBLFDemoTran (SignedBox (QBLFDemoToken (Encryption e)) (Encryption e)) deriving stock Generic instance ForRefChans e => Serialise (QBLFDemoTran e) @@ -93,39 +95,43 @@ deriving newtype instance (Eq (Signature (Encryption e)), ForRefChans e) => Hashable (QBLFDemoTran e) -instance Serialise (QBLFDemoTran UNIX) => HasProtocol UNIX (QBLFDemoTran UNIX) where +instance HasProtocol UNIX (QBLFDemoTran UNIX) where type instance ProtocolId (QBLFDemoTran UNIX) = 0xFFFF0001 type instance Encoded UNIX = ByteString decode = either (const Nothing) Just . deserialiseOrFail encode = serialise -makeEmitTx :: forall e m . ( MonadIO m - , ForRefChans e - , Signatures (Encryption e) - ) - => PubKey 'Sign (Encryption e) - -> PrivKey 'Sign (Encryption e) - -> Account e +makeEmitTx :: forall s e m . ( MonadIO m + , ForRefChans e + , ForQBLFDemoToken s + , Signatures (Encryption e) + , s ~ Encryption e + ) + => PubKey 'Sign s + -> PrivKey 'Sign s + -> Account s -> Amount - -> m (QBLFDemoToken e) + -> m (QBLFDemoToken s) makeEmitTx pk sk acc amount = do nonce <- randomIO - let box = makeSignedBox @e pk sk (EmitTx @e acc amount nonce) - pure (Emit @e box) + let box = makeSignedBox @s pk sk (EmitTx acc amount nonce) + pure (Emit @s box) -makeMoveTx :: forall e m . ( MonadIO m - , ForRefChans e - , Signatures (Encryption e) - ) - => PubKey 'Sign (Encryption e) -- from pk - -> PrivKey 'Sign (Encryption e) -- from sk - -> Account e +makeMoveTx :: forall s e m . ( MonadIO m + , ForQBLFDemoToken s + , ForRefChans e + , Signatures s + , s ~ Encryption e + ) + => PubKey 'Sign s -- from pk + -> PrivKey 'Sign s -- from sk + -> Account s -> Amount -- amount - -> m (QBLFDemoToken e) + -> m (QBLFDemoToken s) makeMoveTx pk sk acc amount = do nonce <- randomIO - let box = makeSignedBox @e pk sk (MoveTx @e pk acc amount nonce) - pure (Move @e box) + let box = makeSignedBox @s pk sk (MoveTx pk acc amount nonce) + pure (Move @s box) diff --git a/fixme-new/LICENSE b/fixme-new/LICENSE new file mode 100644 index 00000000..3cbe915d --- /dev/null +++ b/fixme-new/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2023, + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/fixme-new/README.md b/fixme-new/README.md new file mode 100644 index 00000000..e3e9cc31 --- /dev/null +++ b/fixme-new/README.md @@ -0,0 +1,22 @@ + + +## The new glorious fixme + +This is a new fixme implementation! It's a re-implementation +of fixme aiming for using multiple sources for issues, not +only git repo, and able to share the state via hbs2 +privimites. + +It will replace the old good fixme and will reuse all the +code from there that could be re-used. + +It's indendent to be mostly compatible with the old +fixme, but we will see. + +The binary is called fixme-new in order not to be confused +with old fixme, but it's only for a while. + +It will be replaced as soon, as this fixme will be fully +operational. + + diff --git a/fixme-new/app/FixmeMain.hs b/fixme-new/app/FixmeMain.hs new file mode 100644 index 00000000..90090cd8 --- /dev/null +++ b/fixme-new/app/FixmeMain.hs @@ -0,0 +1,72 @@ +module Main where + +import Fixme +import Fixme.Run +import System.Environment + +-- TODO: fixme-new +-- $author: Dmitry Zuikov +-- $milestone: undefined +-- $priority: ASAP +-- после майских: +-- 1. fixme переезжает в дерево hbs2, конкретно в hbs2-git + +-- 2. fixme преобразуется в утилиту для генерации отчётов по репозиторию git +-- +-- 3. fixme генерирует поток фактов про репозиторий git, включая записи todo/fixme +-- +-- 4. fixme начинает генерировать PR-ы в формате git (у гита есть простенькие пулл-реквесты!) +-- и умеет постить их куда там их следует постить +-- +-- 5. fixme получает ограничитель глубины сканирования и фильтр бранчей, +-- что бы не окочуриваться на больших проектах +-- +-- 6. fixme генерирует настройки по умолчанию, включая .gitignore +-- +-- 7. fixme позволяет явно задавать лог изменений статуса, беря его как из +-- .fixme/log так и откуда скажут +-- +-- 8. fixme интегрируется в hbs2-git-dashboard +-- +-- 9. fixme временно получает название fixme2 или nfixme или hfixme (не решил пока), +-- потом возвращается к старому названию +-- +-- 10. fixme умеет постить записи в своём формате в hbs2 или же умеет любые источники дампить в своём формате так, +-- что бы hbs2-git мог запостить их в соответствующий рефчан +-- +-- 11. fixme оформляет либу для экстракции фактов из git, которую будет использовать и hbs2-git-dashboard +-- +-- 12. hbs2-git-dashboard понимает и уважает каталог настроек .fixme , а стейт берёт прямо оттуда + +-- открытые вопросы: + +-- hbs2-git использует fixme или fixme использует hbs2 + +-- переводить fixme на fuzzy-parse или нет (скорее, да) + +-- переводить ли suckless-conf на fuzzy-parse сейчас (или хрен пока с ним) + +-- встроить ли jq внутрь или лучше дать доступ к sql запросам по json + +main :: IO () +main = do + + -- TODO: discover-config + -- + -- TODO: local-config-has-same-name-with-binary + -- + -- TODO: per-user-config-has-same-name-with-binary + -- + -- TODO: per-user-config-added-after-per-project-config + + -- TODO: scan-all-sources + -- for-source-from-con + + runFixmeCLI (run =<< liftIO getArgs) + +-- FIXME: test-fixme +-- $workflow: wip +-- $assigned: voidlizard +-- +-- Тестовый тикет с параметрами + diff --git a/fixme-new/fixme.cabal b/fixme-new/fixme.cabal new file mode 100644 index 00000000..bad8b84e --- /dev/null +++ b/fixme-new/fixme.cabal @@ -0,0 +1,140 @@ +cabal-version: 3.0 +name: fixme-new +version: 0.24.1.2 +synopsis: reimplemented fixme +-- description: +license: BSD-3-Clause +license-file: LICENSE +author: Dmitry Zuikov +-- copyright: +category: System +build-type: Simple +-- extra-doc-files: CHANGELOG.md +-- extra-source-files: + +common shared-properties + ghc-options: + -Wall + -fno-warn-type-defaults + -threaded + -rtsopts + -O2 + "-with-rtsopts=-N4 -A64m -AL256m -I0" + + default-language: GHC2021 + + default-extensions: + ApplicativeDo + , BangPatterns + , BlockArguments + , ConstraintKinds + , DataKinds + , DeriveDataTypeable + , DeriveGeneric + , DerivingStrategies + , DerivingVia + , ExtendedDefaultRules + , FlexibleContexts + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , ImportQualifiedPost + , LambdaCase + , MultiParamTypeClasses + , OverloadedStrings + , QuasiQuotes + , RecordWildCards + , ScopedTypeVariables + , StandaloneDeriving + , TupleSections + , TypeApplications + , TypeFamilies + + + build-depends: + hbs2-core + , hbs2-peer + , hbs2-storage-simple + , hbs2-keyman + , hbs2-git + , db-pipe + , suckless-conf >= 0.1.2.6 + , fuzzy-parse + + , aeson + , aeson-pretty + , attoparsec + , atomic-write + , bytestring + , binary + , containers + , directory + , exceptions + , filepath + , filepattern + , generic-lens + , generic-deriving + , interpolatedstring-perl6 + , memory + , microlens-platform + , mtl + , safe + , serialise + , scientific + , streaming + , stm + , split + , text + , temporary + , time + , timeit + , transformers + , typed-process + , unordered-containers + , unliftio + , unliftio-core + , zlib + , prettyprinter + , prettyprinter-ansi-terminal + , random + , vector + , unix + + +library + import: shared-properties + + exposed-modules: + Fixme + Fixme.Config + Fixme.Run + Fixme.Log + Fixme.Types + Fixme.Prelude + Fixme.State + Fixme.Scan + Fixme.Scan.Git.Local + + build-depends: base + , base16-bytestring + , binary + , unix + + hs-source-dirs: lib + + +executable fixme-new + import: shared-properties + main-is: FixmeMain.hs + -- other-modules: + -- other-extensions: + build-depends: + base, fixme-new, hbs2-core, hbs2-peer, hbs2-git + , binary + , vector + , optparse-applicative + + hs-source-dirs: app + default-language: GHC2021 + + diff --git a/fixme-new/lib/Fixme.hs b/fixme-new/lib/Fixme.hs new file mode 100644 index 00000000..d57be6f0 --- /dev/null +++ b/fixme-new/lib/Fixme.hs @@ -0,0 +1,8 @@ +module Fixme + ( module Fixme.Types + , module Fixme.Prelude + ) where + +import Fixme.Prelude +import Fixme.Types + diff --git a/fixme-new/lib/Fixme/Config.hs b/fixme-new/lib/Fixme/Config.hs new file mode 100644 index 00000000..db93590a --- /dev/null +++ b/fixme-new/lib/Fixme/Config.hs @@ -0,0 +1,38 @@ +module Fixme.Config where + +import Fixme.Prelude +import Fixme.Types + +import HBS2.System.Dir +import System.Environment +import System.Directory + +binName :: FixmePerks m => m FilePath +binName = liftIO getProgName + +localConfigDir :: FixmePerks m => m FilePath +localConfigDir = do + p <- pwd + b <- binName + pure (p ("." <> b)) + +localConfig:: FixmePerks m => m FilePath +localConfig = localConfigDir <&> ( "config") + +userConfigs :: FixmePerks m => m [FilePath] +userConfigs= do + bin <- binName + h <- home + xdg <- liftIO (getXdgDirectory XdgConfig bin) + + let conf1 = h ("." <> bin) + let conf2 = xdg "config" + + pure [conf2, conf1] + +localDBName :: FilePath +localDBName = "state.db" + +localDBPath :: FixmePerks m => m FilePath +localDBPath = localConfigDir <&> ( localDBName) + diff --git a/fixme-new/lib/Fixme/Log.hs b/fixme-new/lib/Fixme/Log.hs new file mode 100644 index 00000000..47b6f1cd --- /dev/null +++ b/fixme-new/lib/Fixme/Log.hs @@ -0,0 +1,31 @@ +module Fixme.Log where + +import Fixme.Prelude +import Fixme.Types + +import HBS2.Storage.Compact + +import Data.Config.Suckless + +import Data.ByteString.Lazy qualified as LBS +import Data.Maybe +import Data.Either + +{- HLINT ignore "Functor law"-} + +loadAllEntriesFromLog :: FixmePerks m + => CompactStorage HbSync + -> FixmeM m [Syntax C] +loadAllEntriesFromLog sto = do + ks <- keys sto + + entries <- mapM (get sto) ks + <&> catMaybes + <&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict) + <&> rights + + let top = show $ vcat (fmap pretty entries) + let theLog = parseTop top & fromRight mempty + + pure theLog + diff --git a/fixme-new/lib/Fixme/Prelude.hs b/fixme-new/lib/Fixme/Prelude.hs new file mode 100644 index 00000000..3f69c708 --- /dev/null +++ b/fixme-new/lib/Fixme/Prelude.hs @@ -0,0 +1,20 @@ +module Fixme.Prelude + ( module All + , GitHash(..) + , GitRef(..) + , Serialise(..) + , serialise, deserialiseOrFail, deserialise + ) where + +import HBS2.Prelude.Plated as All +import HBS2.Hash as All +import HBS2.Data.Types.Refs as All +import HBS2.Misc.PrettyStuff as All +import HBS2.System.Logger.Simple.ANSI as All +import HBS2.Git.Local (GitHash(..),GitRef(..)) +import Codec.Serialise (Serialise(..),serialise,deserialise,deserialiseOrFail) +import Data.Functor as All +import Data.Function as All +import UnliftIO as All +import System.FilePattern as All +import Control.Monad.Reader as All diff --git a/fixme-new/lib/Fixme/Run.hs b/fixme-new/lib/Fixme/Run.hs new file mode 100644 index 00000000..072c1cc3 --- /dev/null +++ b/fixme-new/lib/Fixme/Run.hs @@ -0,0 +1,827 @@ +{-# Language MultiWayIf #-} +{-# Language PatternSynonyms #-} +{-# Language ViewPatterns #-} +module Fixme.Run where + +import Prelude hiding (init) +import Fixme.Prelude hiding (indent) +import Fixme.Types +import Fixme.Config +import Fixme.State +import Fixme.Scan.Git.Local as Git +import Fixme.Scan as Scan +import Fixme.Log + +import HBS2.Git.Local.CLI + +import HBS2.Base58 +import HBS2.Merkle +import HBS2.Data.Types.Refs +import HBS2.Storage +import HBS2.Storage.Compact +import HBS2.System.Dir +import DBPipe.SQLite hiding (field) +import Data.Config.Suckless + +import Data.Aeson.Encode.Pretty as Aeson +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.Either +import Data.Maybe +import Data.HashSet qualified as HS +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HM +import Data.HashSet (HashSet) +import Data.Set qualified as Set +import Data.Generics.Product.Fields (field) +import Data.List qualified as List +import Data.Text qualified as Text +import Data.Text.IO qualified as Text +import Text.InterpolatedString.Perl6 (qc) +import Data.Coerce +import Control.Monad.Identity +import Lens.Micro.Platform +import System.Process.Typed +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Maybe +import System.IO.Temp as Temp +import System.IO qualified as IO + + +import Streaming.Prelude qualified as S + + +{- HLINT ignore "Functor law" -} + +pattern Init :: forall {c}. Syntax c +pattern Init <- ListVal [SymbolVal "init"] + +pattern ScanGitLocal :: forall {c}. [ScanGitArgs] -> Syntax c +pattern ScanGitLocal e <- ListVal (SymbolVal "scan-git" : (scanGitArgs -> e)) + +pattern Update :: forall {c}. [ScanGitArgs] -> Syntax c +pattern Update e <- ListVal (SymbolVal "update" : (scanGitArgs -> e)) + +pattern ReadFixmeStdin :: forall {c}. Syntax c +pattern ReadFixmeStdin <- ListVal [SymbolVal "read-fixme-stdin"] + +pattern FixmeFiles :: forall {c} . [FilePattern] -> Syntax c +pattern FixmeFiles e <- ListVal (SymbolVal "fixme-files" : (fileMasks -> e)) + + +pattern FixmePrefix :: forall {c} . FixmeTag -> Syntax c +pattern FixmePrefix s <- ListVal [SymbolVal "fixme-prefix", fixmePrefix -> Just s] + +pattern FixmeGitScanFilterDays :: forall {c}. Integer -> Syntax c +pattern FixmeGitScanFilterDays d <- ListVal [ SymbolVal "fixme-git-scan-filter-days", LitIntVal d ] + + +logRootKey :: SomeRefKey ByteString +logRootKey = SomeRefKey "ROOT" + +scanGitArgs :: [Syntax c] -> [ScanGitArgs] +scanGitArgs syn = [ w | ScanGitArgs w <- syn ] + + +fileMasks :: [Syntax c] -> [FilePattern] +fileMasks what = [ show (pretty s) | s <- what ] + +fixmePrefix :: Syntax c -> Maybe FixmeTag +fixmePrefix = \case + SymbolVal s -> Just (FixmeTag (coerce s)) + _ -> Nothing + + +defaultTemplate :: HashMap Id FixmeTemplate +defaultTemplate = HM.fromList [ ("default", Simple (SimpleTemplate short)) ] + where + short = parseTop s & fromRight mempty + s = [qc| +(trim 10 $fixme-key) " " +(align 6 $fixme-tag) " " +(trim 50 ($fixme-title)) +(nl) + |] + + +runFixmeCLI :: FixmePerks m => FixmeM m a -> m a +runFixmeCLI m = do + dbPath <- localDBPath + git <- findGitDir + env <- FixmeEnv + <$> newMVar () + <*> newTVarIO mempty + <*> newTVarIO dbPath + <*> newTVarIO Nothing + <*> newTVarIO git + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO defCommentMap + <*> newTVarIO Nothing + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO defaultCatAction + <*> newTVarIO defaultTemplate + <*> newTVarIO mempty + <*> newTVarIO (1,3) + + -- FIXME: defer-evolve + -- не все действия требуют БД, + -- хорошо бы, что бы она не создавалась, + -- если не требуется + runReaderT ( setupLogger >> fromFixmeM (handle @_ @SomeException (err . viaShow) evolve >> m) ) env + `finally` flushLoggers + where + setupLogger = do + setLogging @ERROR $ toStderr . logPrefix "[error] " + setLogging @WARN $ toStderr . logPrefix "[warn] " + setLogging @NOTICE $ toStdout . logPrefix "" + pure () + + flushLoggers = do + silence + + -- FIXME: tied-fucking-context + defaultCatAction = CatAction $ \dict lbs -> do + LBS.putStr lbs + pure () + +silence :: FixmePerks m => m () +silence = do + setLoggingOff @DEBUG + setLoggingOff @ERROR + setLoggingOff @WARN + setLoggingOff @NOTICE + + + +readConfig :: FixmePerks m => FixmeM m [Syntax C] +readConfig = do + + user <- userConfigs + lo <- localConfig + + w <- for (lo : user) $ \conf -> do + try @_ @IOException (liftIO $ readFile conf) + <&> fromRight mempty + <&> parseTop + <&> fromRight mempty + + pure $ mconcat w + +init :: FixmePerks m => FixmeM m () +init = do + + lo <- localConfigDir + + let lo0 = takeFileName lo + + mkdir lo + touch (lo "config") + + let gitignore = lo ".gitignore" + here <- doesPathExist gitignore + + unless here do + liftIO $ writeFile gitignore $ show $ + vcat [ pretty ("." localDBName) + ] + + notice $ yellow "run" <> line <> vcat [ + "git add" <+> pretty (lo0 ".gitignore") + , "git add" <+> pretty (lo0 "config") + ] + + + +readFixmeStdin :: FixmePerks m => FixmeM m () +readFixmeStdin = do + what <- liftIO LBS8.getContents + fixmies <- Scan.scanBlob Nothing what + liftIO $ print $ vcat (fmap pretty fixmies) + + +list_ :: (FixmePerks m, HasPredicate a) => Maybe Id -> a -> FixmeM m () +list_ tpl a = do + tpl <- asks fixmeEnvTemplates >>= readTVarIO + <&> HM.lookup (fromMaybe "default" tpl) + + fixmies <- selectFixmeThin a + + case tpl of + Nothing-> do + liftIO $ LBS.putStr $ Aeson.encodePretty fixmies + + Just (Simple (SimpleTemplate simple)) -> do + for_ fixmies $ \(FixmeThin attr) -> do + let subst = [ (mkId k, mkstr @C v) | (k,v) <- HM.toList attr ] + let what = render (SimpleTemplate (inject subst simple)) + & fromRight "render error" + + liftIO $ hPutDoc stdout what + + +catFixmeMetadata :: FixmePerks m => Text -> FixmeM m () +catFixmeMetadata = cat_ True + +catFixme :: FixmePerks m => Text -> FixmeM m () +catFixme = cat_ False + +cat_ :: FixmePerks m => Bool -> Text -> FixmeM m () +cat_ metaOnly hash = do + + (before,after) <- asks fixmeEnvCatContext >>= readTVarIO + gd <- fixmeGetGitDirCLIOpt + + CatAction action <- asks fixmeEnvCatAction >>= readTVarIO + + void $ flip runContT pure do + callCC \exit -> do + + mha <- lift $ selectFixmeHash hash + + ha <- ContT $ maybe1 mha (pure ()) + + fme' <- lift $ selectFixme ha + + Fixme{..} <- ContT $ maybe1 fme' (pure ()) + + when metaOnly do + for_ (HM.toList fixmeAttr) $ \(k,v) -> do + liftIO $ print $ (pretty k <+> pretty v) + exit () + + let gh' = HM.lookup "blob" fixmeAttr + + -- FIXME: define-fallback-action + gh <- ContT $ maybe1 gh' none + + let cmd = [qc|git {gd} cat-file blob {pretty gh}|] :: String + + let start = fromMaybe 0 fixmeStart & fromIntegral & (\x -> x - before) & max 0 + let bbefore = if start > before then before + 1 else 1 + let origLen = maybe 0 fromIntegral fixmeEnd - maybe 0 fromIntegral fixmeStart & max 1 + let lno = max 1 $ origLen + after + before + + let dict = [ (mkId k, mkstr @C v) | (k,v) <- HM.toList fixmeAttr ] + <> + [ (mkId (FixmeAttrName "before"), mkstr @C (FixmeAttrVal $ Text.pack $ show bbefore)) + ] + + debug (pretty cmd) + + w <- gitRunCommand cmd + <&> either (LBS8.pack . show) id + <&> LBS8.lines + <&> drop start + <&> take lno + + liftIO $ action dict (LBS8.unlines w) + +delete :: FixmePerks m => Text -> FixmeM m () +delete txt = do + acts <- asks fixmeEnvUpdateActions >>= readTVarIO + hashes <- selectFixmeHashes txt + for_ hashes $ \ha -> do + insertFixmeDelStaged ha + +modify_ :: FixmePerks m => Text -> String -> String -> FixmeM m () +modify_ txt a b = do + acts <- asks fixmeEnvUpdateActions >>= readTVarIO + void $ runMaybeT do + ha <- toMPlus =<< lift (selectFixmeHash txt) + lift $ insertFixmeModStaged ha (fromString a) (fromString b) + +exportToLog :: FixmePerks m => FilePath -> FixmeM m () +exportToLog fn = do + e <- getEpoch + warn $ red "EXPORT-FIXMIES" <+> pretty fn + sto <- compactStorageOpen @HbSync mempty fn + fx <- selectFixmeThin () + for_ fx $ \(FixmeThin m) -> void $ runMaybeT do + h <- HM.lookup "fixme-hash" m & toMPlus + loaded <- lift (selectFixme (coerce h)) >>= toMPlus + let what = Added e loaded + let k = mkKey what + get sto k >>= guard . isNothing + put sto (mkKey what) (LBS.toStrict $ serialise what) + warn $ red "export" <+> pretty h + + what <- selectStage + + for_ what $ \w -> do + let k = mkKey w + v0 <- get sto k <&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict) + case v0 of + Nothing -> do + put sto k (LBS.toStrict $ serialise w) + + Just (Left{}) -> do + put sto k (LBS.toStrict $ serialise w) + + Just (Right prev) | getSequence w > getSequence prev -> do + put sto k (LBS.toStrict $ serialise w) + + _ -> pure () + + compactStorageClose sto + + cleanStage + +importFromLog :: FixmePerks m => CompactStorage HbSync -> FixmeM m () +importFromLog sto = do + fset <- listAllFixmeHashes + + -- sto <- compactStorageOpen @HbSync readonly fn + ks <- keys sto + + toImport <- S.toList_ do + for_ ks $ \k -> runMaybeT do + v <- get sto k & MaybeT + what <- deserialiseOrFail @CompactAction (LBS.fromStrict v) & toMPlus + + case what of + Added _ fx -> do + let ha = hashObject @HbSync (serialise fx) & HashRef + unless (HS.member ha fset) do + warn $ red "import" <+> viaShow (pretty ha) + lift $ S.yield (Right fx) + w -> lift $ S.yield (Left $ fromRight mempty $ parseTop (show $ pretty w)) + + withState $ transactional do + for_ (rights toImport) insertFixme + + let w = lefts toImport + runForms (mconcat w) + + unless (List.null toImport) do + updateIndexes + + -- compactStorageClose sto + +printEnv :: FixmePerks m => FixmeM m () +printEnv = do + g <- asks fixmeEnvGitDir >>= readTVarIO + masks <- asks fixmeEnvFileMask >>= readTVarIO + tags <- asks fixmeEnvTags >>= readTVarIO + days <- asks fixmeEnvGitScanDays >>= readTVarIO + comments1 <- asks fixmeEnvDefComments >>= readTVarIO <&> HS.toList + + comments2 <- asks fixmeEnvFileComments >>= readTVarIO + <&> HM.toList + <&> fmap (over _2 HS.toList) + + attr <- asks fixmeEnvAttribs >>= readTVarIO <&> HS.toList + vals <- asks fixmeEnvAttribValues >>= readTVarIO <&> HM.toList + + for_ tags $ \m -> do + liftIO $ print $ "fixme-prefix" <+> pretty m + + for_ masks $ \m -> do + liftIO $ print $ "fixme-files" <+> dquotes (pretty m) + + for_ days $ \d -> do + liftIO $ print $ "fixme-git-scan-filter-days" <+> pretty d + + for_ comments1 $ \d -> do + liftIO $ print $ "fixme-comments" <+> dquotes (pretty d) + + for_ comments2 $ \(ft, comm') -> do + for_ comm' $ \comm -> do + liftIO $ print $ "fixme-file-comments" + <+> dquotes (pretty ft) <+> dquotes (pretty comm) + + for_ attr $ \a -> do + liftIO $ print $ "fixme-attribs" + <+> pretty a + + for_ vals$ \(v, vs) -> do + liftIO $ print $ "fixme-value-set" <+> pretty v <+> hsep (fmap pretty (HS.toList vs)) + + for_ g $ \git -> do + liftIO $ print $ "fixme-git-dir" <+> dquotes (pretty git) + + dbPath <- asks fixmeEnvDbPath >>= readTVarIO + liftIO $ print $ "fixme-state-path" <+> dquotes (pretty dbPath) + + (before,after) <- asks fixmeEnvCatContext >>= readTVarIO + + liftIO $ print $ "fixme-def-context" <+> pretty before <+> pretty after + + ma <- asks fixmeEnvMacro >>= readTVarIO <&> HM.toList + + for_ ma $ \(n, syn) -> do + liftIO $ print $ parens ("define-macro" <+> pretty n <+> pretty syn) + + +help :: FixmePerks m => m () +help = do + notice "this is help message" + + +splitForms :: [String] -> [[String]] +splitForms s0 = runIdentity $ S.toList_ (go mempty s0) + where + go acc ( "then" : rest ) = emit acc >> go mempty rest + go acc ( "and" : rest ) = emit acc >> go mempty rest + go acc ( x : rest ) = go ( x : acc ) rest + go acc [] = emit acc + + emit = S.yield . reverse + +sanitizeLog :: [Syntax c] -> [Syntax c] +sanitizeLog lls = flip filter lls $ \case + ListVal (SymbolVal "deleted" : _) -> True + ListVal (SymbolVal "modified" : _) -> True + _ -> False + +pattern Template :: forall {c}. Maybe Id -> [Syntax c] -> [Syntax c] +pattern Template w syn <- (mbTemplate -> (w, syn)) + +mbTemplate :: [Syntax c] -> (Maybe Id, [Syntax c]) +mbTemplate = \case + ( SymbolVal "template" : StringLike w : rest ) -> (Just (fromString w), rest) + other -> (Nothing, other) + +pattern IsSimpleTemplate :: forall {c} . [Syntax c] -> [Syntax c] +pattern IsSimpleTemplate xs <- [ListVal (SymbolVal "simple" : xs)] + +run :: FixmePerks m => [String] -> FixmeM m () +run what = do + + sc <- readConfig + + let s0 = fmap (parseTop . unwords) (splitForms what) + & rights + & mconcat + + runForms (sc <> s0) + + +runForms :: forall c m . (IsContext c, Data c, Data (Context c), FixmePerks m) + => [Syntax c] + -> FixmeM m () +runForms ss = for_ ss $ \s -> do + + macros <- asks fixmeEnvMacro >>= readTVarIO + + debug $ pretty s + + case s of + + (ListVal (SymbolVal name : rest)) | HM.member name macros -> do + let repl = [ (mkId ("$",i), syn) | (i,syn) <- zip [1..] rest ] + maybe1 (inject repl (HM.lookup name macros)) none $ \macro -> do + debug $ yellow "run macro" <+> pretty macro + runForms [macro] + + FixmeFiles xs -> do + t <- asks fixmeEnvFileMask + atomically (modifyTVar t (<> xs)) + + FixmePrefix tag -> do + t <- asks fixmeEnvTags + atomically (modifyTVar t (HS.insert tag)) + + FixmeGitScanFilterDays d -> do + t <- asks fixmeEnvGitScanDays + atomically (writeTVar t (Just d)) + + ListVal [SymbolVal "fixme-file-comments", StringLike ft, StringLike b] -> do + let co = Text.pack b & HS.singleton + t <- asks fixmeEnvFileComments + atomically (modifyTVar t (HM.insertWith (<>) (commentKey ft) co)) + + ListVal (SymbolVal "fixme-comments" : StringLikeList xs) -> do + t <- asks fixmeEnvDefComments + let co = fmap Text.pack xs & HS.fromList + atomically $ modifyTVar t (<> co) + + ListVal (SymbolVal "fixme-attribs" : StringLikeList xs) -> do + ta <- asks fixmeEnvAttribs + atomically $ modifyTVar ta (<> HS.fromList (fmap fromString xs)) + + ListVal [SymbolVal "fixme-git-dir", StringLike g] -> do + ta <- asks fixmeEnvGitDir + atomically $ writeTVar ta (Just g) + + ListVal [SymbolVal "fixme-state-path", StringLike g] -> do + p <- asks fixmeEnvDbPath + db <- asks fixmeEnvDb + atomically do + writeTVar p g + writeTVar db Nothing + + evolve + + ListVal [SymbolVal "fixme-def-context", LitIntVal a, LitIntVal b] -> do + t <- asks fixmeEnvCatContext + atomically $ writeTVar t (fromIntegral a, fromIntegral b) + + ListVal [SymbolVal "fixme-pager", ListVal cmd0] -> do + t <- asks fixmeEnvCatAction + let action = CatAction $ \dict lbs -> do + + let ccmd = case inject dict cmd0 of + (StringLike p : StringLikeList xs) -> Just (p, xs) + _ -> Nothing + + + debug $ pretty ccmd + + maybe1 ccmd none $ \(p, args) -> do + + let input = byteStringInput lbs + let cmd = setStdin input $ setStderr closed + $ proc p args + void $ runProcess cmd + + atomically $ writeTVar t action + + ListVal (SymbolVal "fixme-value-set" : StringLike n : StringLikeList xs) -> do + t <- asks fixmeEnvAttribValues + let name = fromString n + let vals = fmap fromString xs & HS.fromList + atomically $ modifyTVar t (HM.insertWith (<>) name vals) + + Init -> init + + ScanGitLocal args -> scanGitLocal args Nothing + + Update args -> scanGitLocal args Nothing + + ListVal (SymbolVal "list" : (Template n [])) -> do + debug $ "list" <+> pretty n + list_ n () + + ListVal (SymbolVal "list" : (Template n whatever)) -> do + debug $ "list" <+> pretty n + list_ n whatever + + ListVal [SymbolVal "cat", SymbolVal "metadata", FixmeHashLike hash] -> do + catFixmeMetadata hash + + ListVal [SymbolVal "cat", FixmeHashLike hash] -> do + catFixme hash + + ListVal [SymbolVal "delete", FixmeHashLike hash] -> do + delete hash + + ListVal [SymbolVal "modify", FixmeHashLike hash, StringLike a, StringLike b] -> do + modify_ hash a b + + ListVal [SymbolVal "modified", TimeStampLike t, FixmeHashLike hash, StringLike a, StringLike b] -> do + debug $ green $ pretty s + updateFixme (Just t) hash (fromString a) (fromString b) + + ListVal [SymbolVal "modified", FixmeHashLike hash, StringLike a, StringLike b] -> do + debug $ green $ pretty s + updateFixme Nothing hash (fromString a) (fromString b) + + ListVal [SymbolVal "deleted", TimeStampLike _, FixmeHashLike hash] -> do + deleteFixme hash + + ListVal [SymbolVal "deleted", FixmeHashLike hash] -> do + deleteFixme hash + + ListVal [SymbolVal "added", FixmeHashLike _] -> do + -- we don't add fixmies at this stage + -- but in fixme-import + none + + ReadFixmeStdin -> readFixmeStdin + + ListVal [SymbolVal "print-env"] -> printEnv + + ListVal (SymbolVal "hello" : xs) -> do + notice $ "hello" <+> pretty xs + + ListVal [SymbolVal "define-macro", SymbolVal name, macro@(ListVal{})] -> do + debug $ yellow "define-macro" <+> pretty name <+> pretty macro + macros <- asks fixmeEnvMacro + atomically $ modifyTVar macros (HM.insert name (fixContext macro)) + + ListVal (SymbolVal "define-template" : SymbolVal who : IsSimpleTemplate xs) -> do + trace $ "define-template" <+> pretty who <+> "simple" <+> hsep (fmap pretty xs) + t <- asks fixmeEnvTemplates + atomically $ modifyTVar t (HM.insert who (Simple (SimpleTemplate xs))) + + ListVal [SymbolVal "set-template", SymbolVal who, SymbolVal w] -> do + templates <- asks fixmeEnvTemplates + t <- readTVarIO templates + for_ (HM.lookup w t) $ \tpl -> do + atomically $ modifyTVar templates (HM.insert who tpl) + + -- FIXME: maybe-rename-fixme-update-action + ListVal (SymbolVal "fixme-update-action" : xs) -> do + debug $ "fixme-update-action" <+> pretty xs + env <- ask + t <- asks fixmeEnvUpdateActions + let repl syn = [ ( "$1", syn ) ] + let action = UpdateAction @c $ \syn -> do + liftIO (withFixmeEnv env (runForms (inject (repl syn) xs))) + + atomically $ modifyTVar t (<> [action]) + + ListVal (SymbolVal "update-action" : xs) -> do + debug $ "update-action" <+> pretty xs + env <- ask + t <- asks fixmeEnvReadLogActions + let action = ReadLogAction @c $ \_ -> liftIO (withFixmeEnv env (runForms xs)) + atomically $ modifyTVar t (<> [action]) + + ListVal [SymbolVal "import-git-logs", StringLike fn] -> do + warn $ red "import-git-logs" <+> pretty fn + scanGitLogLocal fn importFromLog + + ListVal [SymbolVal "import", StringLike fn] -> do + warn $ red "IMPORT" <+> pretty fn + sto <- compactStorageOpen readonly fn + importFromLog sto + compactStorageClose sto + + ListVal [SymbolVal "export", StringLike fn] -> do + warn $ red "EXPORT" <+> pretty fn + exportToLog fn + + ListVal [SymbolVal "git:list-refs"] -> do + refs <- listRefs False + for_ refs $ \(h,r) -> do + liftIO $ print $ pretty h <+> pretty r + + ListVal [SymbolVal "git:merge-binary-log",StringLike o, StringLike target, StringLike b] -> do + debug $ red "git:merge-binary-log" <+> pretty o <+> pretty target <+> pretty b + + temp <- liftIO $ emptyTempFile "." "merge-result" + sa <- compactStorageOpen @HbSync readonly o + sb <- compactStorageOpen @HbSync readonly b + r <- compactStorageOpen @HbSync mempty temp + + for_ [sa,sb] $ \sto -> do + ks <- keys sto + for_ ks $ \k -> runMaybeT do + v <- get sto k & MaybeT + put r k v + + compactStorageClose r + compactStorageClose sa + compactStorageClose sb + + mv temp target + + ListVal [SymbolVal "no-debug"] -> do + setLoggingOff @DEBUG + + ListVal [SymbolVal "silence"] -> do + silence + + ListVal [SymbolVal "builtin:run-stdin"] -> do + let ini = mempty :: [Text] + flip fix ini $ \next acc -> do + eof <- liftIO IO.isEOF + s <- if eof then pure "" else liftIO Text.getLine <&> Text.strip + if Text.null s then do + let code = parseTop (Text.unlines acc) & fromRight mempty + runForms code + unless eof do + next mempty + else do + next (acc <> [s]) + + ListVal [SymbolVal "builtin:evolve"] -> do + evolve + + ListVal [SymbolVal "builtin:list-commits"] -> do + co <- listCommits + liftIO $ print $ vcat (fmap (pretty . view _1) co) + + ListVal [SymbolVal "builtin:cleanup-state"] -> do + cleanupDatabase + + ListVal [SymbolVal "builtin:clean-stage"] -> do + cleanStage + + ListVal [SymbolVal "builtin:drop-stage"] -> do + cleanStage + + ListVal [SymbolVal "builtin:show-stage"] -> do + stage <- selectStage + liftIO $ print $ vcat (fmap pretty stage) + + ListVal [SymbolVal "builtin:show-log", StringLike fn] -> do + sto <- compactStorageOpen @HbSync readonly fn + + ks <- keys sto + + entries <- mapM (get sto) ks + <&> catMaybes + <&> fmap (deserialiseOrFail @CompactAction . LBS.fromStrict) + <&> rights + + liftIO $ print $ vcat (fmap pretty entries) + + compactStorageClose sto + + ListVal [SymbolVal "builtin:update-indexes"] -> do + updateIndexes + + ListVal [SymbolVal "builtin:scan-magic"] -> do + magic <- scanMagic + liftIO $ print $ pretty magic + + ListVal [SymbolVal "builtin:select-fixme-hash", FixmeHashLike x] -> do + w <- selectFixmeHash x + liftIO $ print $ pretty w + + ListVal [SymbolVal "builtin:git:list-stage"] -> do + stage <- gitListStage + for_ stage $ \case + Left (fn,h) -> liftIO $ print $ "N" <+> pretty h <+> pretty fn + Right (fn,h) -> liftIO $ print $ "E" <+> pretty h <+> pretty fn + + ListVal (SymbolVal "builtin:git:extract-file-meta-data" : StringLikeList fs) -> do + fxm <- gitExtractFileMetaData fs <&> HM.toList + liftIO $ print $ vcat (fmap (pretty.snd) fxm) + + ListVal (SymbolVal "builtin:git:extract-from-stage" : opts) -> do + env <- ask + gitStage <- gitListStage + + let dry = or [ True | StringLike "dry" <- opts ] + let verbose = or [ True | StringLike "verbose" <- opts ] + + blobs <- for gitStage $ \case + Left (fn, hash) -> pure (fn, hash, liftIO $ LBS8.readFile fn) + Right (fn,hash) -> pure (fn, hash, liftIO (withFixmeEnv env $ gitCatBlob hash)) + + let fns = fmap (view _1) blobs + + -- TODO: extract-metadata-from-git-blame + -- subj + + stageFile <- localConfigDir <&> ( "current-stage.log") + + fmeStage <- compactStorageOpen mempty stageFile + + for_ blobs $ \(fn, bhash, readBlob) -> do + nno <- newTVarIO (mempty :: HashMap FixmeTitle Integer) + lbs <- readBlob + fxs <- scanBlob (Just fn) lbs + >>= \e -> do + for e $ \fx0 -> do + n <- atomically $ stateTVar nno (\m -> do + let what = HM.lookup (fixmeTitle fx0) m & fromMaybe 0 + (what, HM.insert (fixmeTitle fx0) (succ what) m) + ) + let ls = fixmePlain fx0 + meta <- getMetaDataFromGitBlame fn fx0 + let tit = fixmeTitle fx0 & coerce @_ @Text + + -- FIXME: fix-this-copypaste + let ks = [qc|{fn}#{tit}:{n}|] :: Text + let ksh = hashObject @HbSync (serialise ks) & pretty & show & Text.pack & FixmeAttrVal + let kh = HM.singleton "fixme-key" ksh + let kv = HM.singleton "fixme-key-string" (FixmeAttrVal ks) <> kh + + pure $ fixmeDerivedFields (fx0 <> mkFixmeFileName fn <> meta) + & set (field @"fixmePlain") ls + + & over (field @"fixmeAttr") + (HM.insert "blob" (fromString $ show $ pretty bhash)) + & over (field @"fixmeAttr") + (mappend (kh<>kv)) + + unless dry do + for_ fxs $ \fx -> void $ runMaybeT do + e <- getEpoch + let what = Added e fx + let k = mkKey (FromFixmeKey fx) + get fmeStage k >>= guard . isNothing + put fmeStage k (LBS.toStrict $ serialise what) + + when verbose do + liftIO $ print (pretty fx) + + when dry do + warn $ red "FUCKING DRY!" + + compactStorageClose fmeStage + + ListVal [SymbolVal "trace"] -> do + setLogging @TRACE (logPrefix "[trace] " . toStderr) + trace "trace on" + + ListVal [SymbolVal "no-trace"] -> do + trace "trace off" + setLoggingOff @TRACE + + ListVal [SymbolVal "debug"] -> do + setLogging @DEBUG $ toStderr . logPrefix "[debug] " + + w -> err (pretty w) + + diff --git a/fixme-new/lib/Fixme/Scan.hs b/fixme-new/lib/Fixme/Scan.hs new file mode 100644 index 00000000..386cad6b --- /dev/null +++ b/fixme-new/lib/Fixme/Scan.hs @@ -0,0 +1,215 @@ +{-# Language MultiWayIf #-} +module Fixme.Scan (scanBlob,scanMagic) where + +import Fixme.Prelude hiding (indent) +import Fixme.Types + +import Data.ByteString.Lazy.Char8 (ByteString) +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.Text qualified as Text +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (ignore) +import Data.Char (isSpace) + +import Data.Maybe +import Data.HashSet qualified as HS +import Data.HashMap.Strict qualified as HM +import Data.Coerce + +import Data.Generics.Product.Fields (field) +import Lens.Micro.Platform +import Text.InterpolatedString.Perl6 (qc) + +import Streaming.Prelude qualified as S + +{- HLINT ignore "Functor law" -} + + +data SfEnv = + SfEnv { lno :: Int -- ^ line number + , l0 :: Int -- ^ fixme indent + , eln :: Int -- ^ empty lines counter + } + deriving stock Generic + + +succEln :: SfEnv -> ByteString -> SfEnv +succEln f s | LBS8.null s = over (field @"eln") succ f + | otherwise = set (field @"eln") 0 f + +data Sx = S0 | Sf SfEnv + +data S = S Sx [(Int,ByteString)] + + +data FixmePart = FixmePart Int FixmeWhat + deriving stock (Show,Data,Generic) + +data FixmeWhat = FixmeHead Int Int Text Text + | FixmeLine Text + | FixmeAttr FixmeAttrName FixmeAttrVal + deriving stock (Show,Data,Generic) + +data P = P0 [FixmePart] | P1 Int Fixme [FixmePart] + + +scanMagic :: FixmePerks m => FixmeM m HashRef +scanMagic = do + env <- ask + w <- atomically do + tagz <- fixmeEnvTags env & readTVar + co <- fixmeEnvDefComments env & readTVar + fco <- fixmeEnvFileComments env & readTVar + m <- fixmeEnvFileMask env & readTVar + a <- fixmeEnvAttribs env & readTVar + v <- fixmeEnvAttribValues env & readTVar + + pure $ serialise (tagz, co, fco, m, a, v) + pure $ HashRef $ hashObject w + +scanBlob :: forall m . FixmePerks m + => Maybe FilePath -- ^ filename to detect type + -> ByteString -- ^ content + -> FixmeM m [Fixme] + +scanBlob fpath lbs = do + + tagz <- asks fixmeEnvTags + >>= readTVarIO + <&> HS.toList + <&> fmap (Text.unpack . coerce) + <&> filter (not . null) + <&> fmap LBS8.pack + + comments <- fixmeGetCommentsFor fpath + <&> filter (not . LBS8.null) . fmap (LBS8.pack . Text.unpack) + + anames <- asks fixmeEnvAttribs >>= readTVarIO <&> HS.toList + + let setters = [ ( LBS8.pack [qc|${show $ pretty n}:|], n ) | n <- anames ] + + let ls = LBS8.lines lbs & zip [0..] + + parts <- S.toList_ do + + flip fix (S S0 ls) $ \next -> \case + S S0 ((lno,x):xs) -> do + + (l,bs) <- eatPrefix0 Nothing comments x + + let mtag = headMay [ t | t <- tagz, LBS8.isPrefixOf t bs ] + + case mtag of + Nothing -> + next (S S0 xs) + + Just tag -> do + emitFixmeStart lno l tag (LBS8.drop (LBS8.length tag) bs) + next (S (Sf (SfEnv lno l 0)) xs) + + S sf@(Sf env@(SfEnv{..})) (x : xs) -> do + + (li,bs) <- eatPrefix0 (Just l0) comments (snd x) + + if | eln > 1 -> next (S S0 (x:xs)) + + | li <= l0 && not (LBS8.null bs) -> next (S S0 (x:xs)) + + | otherwise -> do + + let stripped = LBS8.dropWhile isSpace bs + let attr = headMay [ (s, LBS8.drop (LBS8.length a) stripped) + | (a,s) <- setters, LBS8.isPrefixOf a stripped + ] + + case attr of + Just (a,v) -> do + let vv = LBS8.toStrict v & decodeUtf8With ignore & Text.strip + emitFixmeAttr (fst x) l0 a (FixmeAttrVal vv) + Nothing -> do + emitFixmeLine (fst x) l0 bs + + next (S (Sf (succEln env bs)) xs) + + S _ [] -> pure () + -- debug $ vcat (fmap viaShow parts) + + S.toList_ do + flip fix (P0 parts) $ \next -> \case + + (P0 (FixmePart l h@FixmeHead{} : rs)) -> do + next (P1 l (fromHead h) rs) + + (P1 _ fx (FixmePart l h@FixmeHead{} : rs)) -> do + emitFixme fx + next (P1 l (fromHead h) rs) + + (P1 _ fx (FixmePart lno (FixmeLine what) : rs)) -> do + next (P1 lno (setLno lno $ over (field @"fixmePlain") (<> [FixmePlainLine what]) fx) rs) + + (P1 _ fx (FixmePart lno (FixmeAttr a v) : rs)) -> do + next (P1 lno (setLno lno $ over (field @"fixmeAttr") (<> HM.singleton a v) fx) rs) + + (P1 _ fx []) -> emitFixme fx + (P0 ( _ : rs ) ) -> next (P0 rs) + (P0 []) -> pure () + + where + + setLno lno fx@Fixme{} = do + let lno1 = Just (FixmeOffset (fromIntegral lno)) + set (field @"fixmeEnd") lno1 fx + + emitFixme e = do + S.yield $ over (field @"fixmePlain") dropEmpty e + where + dropEmpty = dropWhile $ \case + FixmePlainLine "" -> True + _ -> False + + -- FIXME: jopakita + fromHead = \case + FixmeHead lno _ tag title -> + Fixme (FixmeTag tag) + (FixmeTitle title) + Nothing + Nothing + (Just (FixmeOffset (fromIntegral lno))) + Nothing + mempty + mempty + + _ -> mempty + + emitFixmeStart lno lvl tagbs restbs = do + let tag = decodeUtf8With ignore (LBS8.toStrict tagbs) & Text.strip + let rest = decodeUtf8With ignore (LBS8.toStrict restbs) & Text.strip + S.yield (FixmePart lno (FixmeHead lno lvl tag rest)) + + emitFixmeAttr lno _ name val = do + S.yield (FixmePart lno (FixmeAttr name val)) + + emitFixmeLine lno _ restbs = do + let rest = decodeUtf8With ignore (LBS8.toStrict restbs) & Text.stripEnd + S.yield (FixmePart lno (FixmeLine rest)) + + eatPrefix0 lim' comments x = do + over _2 LBS8.pack <$> do + + flip fix (0, LBS8.unpack x) $ \next w@(k, left) -> do + + let lim = fromMaybe (succ k) lim' + + if k > lim then + pure (k, left) + else + case w of + (n, ' ' : rest) -> next (n+1, if k == lim then ' ' : rest else rest) + (n, '\t' : rest) -> next (n+8, if k == lim then '\t' : rest else rest) + + (n, rest) -> do + let comm = headMay [ co | co <- comments, LBS8.isPrefixOf co (LBS8.pack rest) ] + case comm of + Nothing -> pure (n, rest) + Just co -> next (n+1, drop (fromIntegral $ LBS8.length co) rest) + diff --git a/fixme-new/lib/Fixme/Scan/Git/Local.hs b/fixme-new/lib/Fixme/Scan/Git/Local.hs new file mode 100644 index 00000000..445f5369 --- /dev/null +++ b/fixme-new/lib/Fixme/Scan/Git/Local.hs @@ -0,0 +1,619 @@ +{-# Language MultiWayIf #-} +{-# Language PatternSynonyms #-} +{-# Language ViewPatterns #-} +module Fixme.Scan.Git.Local where + + +import Prelude hiding (init) +import Fixme.Prelude hiding (indent) +import Fixme.Types +import Fixme.State +import Fixme.Scan as Scan +import Fixme.Log + +import HBS2.Storage +import HBS2.Storage.Compact +import HBS2.System.Dir +import HBS2.Git.Local.CLI + +import DBPipe.SQLite hiding (field) +import Data.Config.Suckless +import Data.Text.Fuzzy.Tokenize + +import Data.ByteString.Char8 qualified as BS +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.ByteString.Lazy (ByteString) +import Data.Either +import Data.Fixed +import Data.List qualified as List +import Data.List.Split (chunksOf) +import Data.Maybe +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS +import Data.HashSet (HashSet) +import Data.Text qualified as Text +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (ignore) +import Data.Word +import Text.InterpolatedString.Perl6 (qc) +import Data.Coerce +import Data.Generics.Product.Fields (field) +import Lens.Micro.Platform +import System.Process.Typed +import Control.Monad.Trans.Cont +import Control.Monad.Trans.Maybe +import System.IO qualified as IO +import System.IO.Temp (emptySystemTempFile) +import System.TimeIt + +import Data.Map qualified as Map + +import Streaming.Prelude qualified as S + +data ScanGitArgs = + PrintBlobs + | PrintFixme + | ScanRunDry + | ScanAllCommits + deriving stock (Eq,Ord,Show,Data,Generic) + +pattern ScanGitArgs :: forall {c} . ScanGitArgs -> Syntax c +pattern ScanGitArgs w <- ( scanGitArg -> Just w ) + +scanGitArg :: Syntax c -> Maybe ScanGitArgs +scanGitArg = \case + SymbolVal "print-blobs" -> Just PrintBlobs + SymbolVal "print-fixme" -> Just PrintFixme + SymbolVal "dry" -> Just ScanRunDry + SymbolVal "all-commits" -> Just ScanAllCommits + _ -> Nothing + + +{- HLINT ignore "Functor law" -} + + +listCommits :: FixmePerks m => FixmeM m [(GitHash, HashMap FixmeAttrName FixmeAttrVal)] +listCommits = do + gd <- fixmeGetGitDirCLIOpt + + days <- asks fixmeEnvGitScanDays + >>= readTVarIO + <&> fmap ( \x -> "--since" <+> squotes (pretty x <+> "days ago")) + <&> fromMaybe mempty + <&> show + + let cmd = [qc|git {gd} log --all --format="%H '%cn' '%ce' %ct" {days}|] + + debug $ yellow "listCommits" <+> pretty cmd + + gitRunCommand cmd + <&> fromRight mempty + <&> LBS8.lines + <&> mapMaybe extract + + where + extract :: ByteString -> Maybe (GitHash, HashMap FixmeAttrName FixmeAttrVal) + extract lbs = do + let txt = decodeUtf8With ignore (LBS8.toStrict lbs) + let r = tokenize @Text spec txt + case r of + [co, n, e, t] -> do + let gh = fromStringMay @GitHash (Text.unpack co) + + let bag = [ ("commit", co) + , ("commit-time", t) + , ("committer-name", n) + , ("committer-email", e) + , ("committer", [qc|{n} <{e}>|]) + ] & fmap ( over _1 FixmeAttrName . over _2 FixmeAttrVal) + & HM.fromList + + (,) <$> gh <*> pure bag + + _ -> Nothing + + spec = sq <> delims " \t" + + +listRefs :: FixmePerks m => Bool -> FixmeM m [(GitHash, GitRef)] +listRefs every = do + gd <- fixmeGetGitDirCLIOpt + gitRunCommand [qc|git {gd} show-ref --dereference|] + <&> fromRight mempty + <&> fmap LBS8.words . LBS8.lines + <&> mapMaybe + (\case + [h,b] -> (,) <$> fromStringMay @GitHash (LBS8.unpack h) <*> pure (GitRef (LBS8.toStrict b)) + _ -> Nothing + ) + >>= filterM filt + + where + filt _ | every = pure True + + filt (h,_) = do + done <- withState $ isProcessed $ ViaSerialise h + pure (not done) + +listBlobs :: (FixmePerks m, MonadReader FixmeEnv m) => GitHash -> m [(FilePath,GitHash)] +listBlobs co = do + gd <- fixmeGetGitDirCLIOpt + gitRunCommand [qc|git {gd} ls-tree -r -l -t {pretty co}|] + <&> fromRight mempty + <&> fmap LBS8.words . LBS8.lines + <&> mapMaybe + (\case + [a,"blob",h,_,fn] -> (LBS8.unpack fn,) <$> fromStringMay @GitHash (LBS8.unpack h) + _ -> Nothing) + +filterBlobs0 :: FixmePerks m + => [(Bool,FilePattern)] + -> [(FilePath,GitHash)] + -> FixmeM m [(FilePath,GitHash)] + +filterBlobs0 pat xs = do + -- pat <- asks fixmeEnvFileMask >>= readTVarIO <&> fmap (True,) + let src = [ ((f,h),f) | (f,h) <- xs ] + let r = [(h,f) | (_,(f,h),_) <- matchMany pat src] & HM.fromList & HM.toList + pure $ [ (b,a) | (a,b) <- r ] + +filterBlobs :: FixmePerks m + => [(FilePath,GitHash)] + -> FixmeM m [(FilePath,GitHash)] + +filterBlobs xs = do + pat <- asks fixmeEnvFileMask >>= readTVarIO <&> fmap (True,) + filterBlobs0 pat xs + + +scanGitLogLocal :: FixmePerks m + => FilePath + -> ( CompactStorage HbSync -> FixmeM m () ) + -> FixmeM m () +scanGitLogLocal refMask play = do + warn $ red "scanGitLogLocal" <+> pretty refMask + + (t,refs) <- timeItT $ listRefs False + + let hashes = fmap fst refs + + warn $ yellow "listRefs in" <+> pretty (realToFrac t :: Fixed E6) + + let pat = [(True, refMask)] + + -- FIXME: use-cache-to-skip-already-processed-tips + logz <- withState do + S.toList_ $ for_ hashes $ \h -> do + done <- lift $ isProcessed (ViaSerialise h) + unless done do + blobs <- lift $ lift $ (listBlobs h >>= filterBlobs0 pat) + when (List.null blobs) do + lift $ insertProcessed (ViaSerialise h) + for_ blobs $ \(_,b) -> do + S.yield (h,b) + + warn $ yellow "STEP 3" <+> "for each tree --- find log" + + warn $ vcat (fmap pretty logz) + + warn $ yellow "STEP 4" <+> "for each log --- scan log" + + withState $ transactional do + + flip runContT pure do + for_ logz $ \(commitHash, h) -> callCC \shit -> do + warn $ blue "SCAN BLOB" <+> pretty h + tmp <- ContT $ bracket (liftIO (emptySystemTempFile "fixme-log")) rm + blob <- lift $ lift $ gitCatBlob h + liftIO (LBS8.writeFile tmp blob) + + esto <- lift $ try @_ @CompactStorageOpenError $ compactStorageOpen @HbSync readonly tmp + + -- skip even problematic commit + lift $ insertProcessed (ViaSerialise commitHash) + + either (const $ warn $ "skip malformed/unknown log" <+> pretty h) (const none) esto + sto <- either (const $ shit ()) pure esto + + lift $ lift $ play sto + + compactStorageClose sto + +scanGitLocal :: FixmePerks m + => [ScanGitArgs] + -> Maybe FilePath + -> FixmeM m () +scanGitLocal args p = do + + env <- ask + + flip runContT pure do + + (dbFn, _) <- ContT $ withSystemTempFile "fixme-db" . curry + + tempDb <- newDBPipeEnv dbPipeOptsDef dbFn + + withDB tempDb do + ddl [qc| create table co + ( cohash text not null + , ts int null + , primary key (cohash) + ) + |] + + ddl [qc| create table coattr + ( cohash text not null + , name text not null + , value text not null + , primary key (cohash,name) + ) + |] + + ddl [qc| create table blob + ( hash text not null + , cohash text not null + , path text not null + , primary key (hash,cohash,path) + ) + |] + + -- update_ [qc|ATTACH DATABASE '{dbpath}' as fixme|] + + let onlyNewCommits xs + | ScanAllCommits `elem` args = pure xs + | otherwise = lift $ filterM (newCommit . view _1) xs + + co <- lift listCommits >>= onlyNewCommits + + lift do + withDB tempDb $ transactional do + for_ co $ \(commit, attr) -> do + + debug $ "commit" <+> pretty commit + + blobs <- lift $ listBlobs commit >>= withFixmeEnv env . filterBlobs + + let ts = HM.lookup "commit-time" attr + >>= readMay @Word64 . Text.unpack . coerce + + insert [qc| + insert into co (cohash,ts) values (?,?) on conflict (cohash) do nothing + |] (commit,ts) + + for_ (HM.toList attr) $ \(a,b) -> do + insert [qc| + insert into coattr(cohash,name,value) values(?,?,?) + on conflict (cohash,name) do nothing + |] (commit,a,b) + + for_ blobs $ \(fp,h) -> do + insert [qc| insert into blob (hash,cohash,path) + values (?,?,?) + on conflict (hash,cohash,path) do nothing + |] (h,commit,fp) + + + blobs <- withDB tempDb do + select_ @_ @(GitHash, FilePath) [qc|select distinct hash, path from blob order by path|] + + when ( PrintBlobs `elem` args ) do + for_ blobs $ \(h,fp) -> do + notice $ pretty h <+> pretty fp + + callCC \fucked -> do + + gitCat <- ContT $ bracket startGitCatFile (hClose . getStdin) + + let ssin = getStdin gitCat + let ssout = getStdout gitCat + + liftIO $ IO.hSetBuffering ssin LineBuffering + + for_ blobs $ \(h,fp) -> callCC \next -> do + + seen <- lift (withState $ selectObjectHash h) <&> isJust + + when seen do + trace $ red "ALREADY SEEN BLOB" <+> pretty h + next () + + liftIO $ IO.hPrint ssin (pretty h) >> IO.hFlush ssin + prefix <- liftIO (BS.hGetLine ssout) <&> BS.words + + case prefix of + [bh, "blob", ssize] -> do + let mslen = readMay @Int (BS.unpack ssize) + len <- ContT $ maybe1 mslen (pure ()) + blob <- liftIO $ LBS8.hGet ssout len + void $ liftIO $ BS.hGetLine ssout + + + poor <- lift (Scan.scanBlob (Just fp) blob) + + rich <- withDB tempDb do + let q = [qc| + + WITH CommitAttributes AS ( + SELECT co.cohash, co.ts, coattr.name, coattr.value + FROM co + JOIN coattr ON co.cohash = coattr.cohash + ), + MinCommitTimes AS ( + SELECT blob.hash, MIN(co.ts) as mintime + FROM blob + JOIN co ON blob.cohash = co.cohash + WHERE co.ts IS NOT NULL + GROUP BY blob.hash + ), + RelevantCommits AS ( + SELECT blob.hash, blob.cohash, blob.path + FROM blob + JOIN MinCommitTimes ON blob.hash = MinCommitTimes.hash + JOIN co ON blob.cohash = co.cohash AND co.ts = MinCommitTimes.mintime + ) + SELECT CommitAttributes.name, CommitAttributes.value + FROM RelevantCommits + JOIN CommitAttributes ON RelevantCommits.cohash = CommitAttributes.cohash + WHERE RelevantCommits.hash = ? + |] + + what <- select @(FixmeAttrName,FixmeAttrVal) q (Only h) + <&> HM.fromList + <&> (<> HM.fromList [ ("blob",fromString $ show (pretty h)) + , ("file",fromString fp) + ]) + + for poor $ \f -> do + let lno = maybe mempty ( HM.singleton "line" + . FixmeAttrVal + . Text.pack + . show + ) + (fixmeStart f) + + let ts = HM.lookup "commit-time" what + <&> Text.unpack . coerce + >>= readMay + <&> FixmeTimestamp + + pure $ set (field @"fixmeTs") ts $ over (field @"fixmeAttr") (<> (what <> lno)) f + + + let fxpos1 = [ (fixmeTitle fx, [i :: Int]) + | (i,fx) <- zip [0..] rich + -- , fixmeTitle fx /= mempty + ] & Map.fromListWith (flip (<>)) + + let mt e = do + let seed = [ (fst e, i) | i <- snd e ] + flip fix (0,[],seed) $ \next (num,acc,rest) -> + case rest of + [] -> acc + (x:xs) -> next (succ num, (x,num) : acc, xs) + + let fxpos2 = [ mt e + | e <- Map.toList fxpos1 + ] & mconcat + & Map.fromList + + fixmies <- for (zip [0..] rich) $ \(i,fx) -> do + let title = fixmeTitle fx + let kb = Map.lookup (title,i) fxpos2 + let ka = HM.lookup "file" (fixmeAttr fx) + let kk = (,,) <$> ka <*> pure title <*> kb + + case kk of + Nothing -> pure fx + Just (a,b,c) -> do + let ks = [qc|{show (pretty a)}#{show (pretty b)}:{show c}|] :: Text + let ksh = hashObject @HbSync (serialise ks) & pretty & show & Text.pack & FixmeAttrVal + let kh = HM.singleton "fixme-key" ksh + let kv = HM.singleton "fixme-key-string" (FixmeAttrVal ks) <> kh + pure $ over (field @"fixmeAttr") (<> kv) fx + + when ( PrintFixme `elem` args ) do + for_ fixmies $ \fixme -> do + notice $ pretty fixme + + when ( ScanRunDry `elem` args ) $ fucked () + + debug $ "actually-import-fixmies" <+> pretty h + + liftIO $ withFixmeEnv env $ withState $ transactional do + insertBlob h + for_ fixmies insertFixme + + _ -> fucked () + + unless ( ScanRunDry `elem` args ) do + lift runLogActions + + liftIO $ withFixmeEnv env $ withState $ transactional do + for_ co $ \w -> do + insertCommit (view _1 w) + + +gitListStage :: (FixmePerks m) + => FixmeM m [Either (FilePath, GitHash) (FilePath, GitHash)] +gitListStage = do + gd <- fixmeGetGitDirCLIOpt + modified <- gitRunCommand [qc|git {gd} status --porcelain|] + <&> fromRight mempty + <&> fmap LBS8.words . LBS8.lines + <&> mapMaybe ( \case + ["M", fn] -> Just (LBS8.unpack fn) + _ -> Nothing + ) + + new <- S.toList_ $ do + for_ modified $ \fn -> void $ runMaybeT do + + e <- gitRunCommand [qc|git {gd} hash-object {fn}|] + >>= toMPlus + <&> maybe mempty LBS8.unpack . headMay . LBS8.words + <&> fromStringMay @GitHash + >>= toMPlus + + lift (S.yield $ (fn,e)) + + old <- gitRunCommand [qc|git {gd} ls-files -s|] + <&> fromRight mempty + <&> fmap LBS8.words . LBS8.lines + <&> mapMaybe ( \case + [_, h, _, fn] -> (LBS8.unpack fn,) <$> fromStringMay @GitHash (LBS8.unpack h) + _ -> Nothing + ) + + new1 <- filterBlobs new <&> fmap Left + old1 <- filterBlobs old <&> fmap Right + + pure (old1 <> new1) + + +getMetaDataFromGitBlame :: FixmePerks m => FilePath -> Fixme -> FixmeM m Fixme +getMetaDataFromGitBlame f fx0 = do + gd <- fixmeGetGitDirCLIOpt + fromMaybe mempty <$> runMaybeT do + l0 <- fixmeStart fx0 & toMPlus <&> fromIntegral <&> succ + let cmd = [qc|git {gd} blame {f} -L{l0},{l0} -t -l -p|] + + s0 <- gitRunCommand cmd + <&> LBS8.unpack . fromRight mempty + + s <- parseTop s0 & toMPlus + + let ko = headMay (words <$> lines s0) + >>= headMay + >>= (\z -> do + if z == "0000000000000000000000000000000000000000" + then Nothing + else Just z ) + >>= fromStringMay @GitHash + + pieces <- for s $ \case + ListVal (SymbolVal "committer" : StringLikeList w) | isJust ko -> do + let co = FixmeAttrVal $ fromString $ unwords w + pure $ mempty { fixmeAttr = HM.singleton "committer-name" co } + + ListVal (SymbolVal "committer-mail" : StringLikeList w) | isJust ko -> do + let co = FixmeAttrVal $ fromString $ unwords w + pure $ mempty { fixmeAttr = HM.singleton "committer-email" co } + + ListVal [SymbolVal "committer-time", TimeStampLike t] | isJust ko -> do + let ct = FixmeAttrVal $ fromString $ show t + pure $ mempty { fixmeAttr = HM.singleton "commit-time" ct, fixmeTs = Just t } + + _ -> pure mempty + + let coco = mempty { fixmeAttr = maybe mempty (HM.singleton "commit" . fromString . show . pretty) ko } + + pure $ mconcat pieces <> coco + +gitExtractFileMetaData :: FixmePerks m => [FilePath] -> FixmeM m (HashMap FilePath Fixme) +gitExtractFileMetaData fns = do + -- FIXME: magic-number + let chunks = chunksOf 64 fns + + gd <- fixmeGetGitDirCLIOpt + + commitz <- S.toList_ $ for_ chunks $ \chu -> do + let filez = unwords chu + let cmd = [qc|git {gd} log --diff-filter=AMR --pretty=format:'entry %H %at "%an" "%ae"' -- {filez}|] + ss <- gitRunCommand cmd + <&> fromRight mempty + <&> fmap LBS8.unpack . LBS8.lines + + for_ ss $ \s -> do + let syn = parseTop s & fromRight mempty + case syn of + [ListVal [SymbolVal "entry", SymbolVal (Id e), LitIntVal t, StringLike n, StringLike m]] -> do + -- liftIO $ print $ pretty e <+> pretty syn + S.yield (fromString @GitHash (Text.unpack e), (t,n,m) ) + + _ -> pure () + + let co = HM.fromList commitz + & HM.toList + + rich0 <- S.toList_ $ do + for_ co $ \(c, (t,n,m)) -> do + let pat = [ (True, f) | f <- fns ] + blobz <- lift $ listBlobs c >>= filterBlobs0 pat + + for_ blobz $ \(f,h) -> do + let attr = HM.fromList [ ("commit", FixmeAttrVal (fromString $ show $ pretty c)) + , ("commit-time", FixmeAttrVal (fromString $ show $ pretty t)) + , ("committer-name", FixmeAttrVal (fromString n)) + , ("committer-email", FixmeAttrVal (fromString m)) + , ("committer", FixmeAttrVal (fromString $ [qc|{n} <{m}>|])) + , ("file", FixmeAttrVal (fromString f)) + , ("blob", FixmeAttrVal (fromString $ show $ pretty $ h)) + ] + let what = mempty { fixmeAttr = attr } + S.yield (f,t,what) + + let rich = List.sortBy (\a b -> compare (view _2 a) (view _2 b)) rich0 + + pure $ HM.fromList [ (view _1 w, view _3 w) | w <- rich ] + +-- TODO: move-outta-here +runLogActions :: FixmePerks m => FixmeM m () +runLogActions = do + debug $ yellow "runLogActions" + actions <- asks fixmeEnvReadLogActions >>= readTVarIO + + for_ actions $ \(ReadLogAction a) -> do + liftIO (a (List noContext [])) + + updateIndexes + +data GitBlobInfo = GitBlobInfo FilePath GitHash + deriving stock (Eq,Ord,Data,Generic,Show) + +instance Hashable GitBlobInfo + +data GitIndexEntry = + GitCommit Word64 (HashSet GitBlobInfo) + deriving stock (Eq,Ord,Data,Generic,Show) + +instance Serialise GitBlobInfo +instance Serialise GitIndexEntry + +listCommitForIndex :: forall m . (FixmePerks m, MonadReader FixmeEnv m) => ( (GitHash, GitIndexEntry) -> m ()) -> m () +listCommitForIndex fn = do + + gd <- fixmeGetGitDirCLIOpt + let cmd = [qc|git {gd} log --all --format="%H %ct"|] + + debug $ yellow "listCommits" <+> pretty cmd + + s0 <- gitRunCommand cmd + <&> fromRight mempty + <&> fmap (words . LBS8.unpack) . LBS8.lines + <&> mapMaybe ( \case + [a,b] -> (,) <$> fromStringMay @GitHash a <*> makeIndexEntry0 a b + _ -> Nothing + ) + + for_ s0 $ \(h, GitCommit w _) -> do + blobz <- listBlobs h <&> HS.fromList . fmap ( uncurry GitBlobInfo ) + fn (h, GitCommit w blobz) + + where + makeIndexEntry0 _ t = GitCommit <$> readMay t <*> pure mempty + +gitCatBlob :: (FixmePerks m, MonadReader FixmeEnv m) => GitHash -> m ByteString +gitCatBlob h = do + gd <- fixmeGetGitDirCLIOpt + (_,s,_) <- readProcess $ shell [qc|git {gd} cat-file blob {pretty h}|] + pure s + +startGitCatFile :: (FixmePerks m, MonadReader FixmeEnv m) => m (Process Handle Handle ()) +startGitCatFile = do + gd <- fixmeGetGitDirCLIOpt + let cmd = [qc|git {gd} cat-file --batch|] + debug $ pretty cmd + let config = setStdin createPipe $ setStdout createPipe $ setStderr closed $ shell cmd + startProcess config + diff --git a/fixme-new/lib/Fixme/State.hs b/fixme-new/lib/Fixme/State.hs new file mode 100644 index 00000000..9bc8b96d --- /dev/null +++ b/fixme-new/lib/Fixme/State.hs @@ -0,0 +1,707 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Fixme.State + ( evolve + , withState + , insertFixme + , selectFixmeThin + , selectFixmeHash + , selectFixmeHashes + , selectFixme + , deleteFixme + , updateFixme + , insertCommit + , insertBlob + , selectObjectHash + , newCommit + , cleanupDatabase + , updateIndexes + , insertFixmeDelStaged + , insertFixmeModStaged + , selectStageModified + , selectStageDeleted + , selectStage + , cleanStage + , insertProcessed + , isProcessed + , selectProcessed + , checkFixmeExists + , listAllFixmeHashes + , HasPredicate(..) + , SelectPredicate(..) + ) where + +import Fixme.Prelude +import Fixme.Types +import Fixme.Config + +import HBS2.System.Dir +import Data.Config.Suckless +import Data.Config.Suckless.Syntax +import DBPipe.SQLite hiding (field) + +import Data.HashSet (HashSet) +import Data.HashSet qualified as HS +import Data.Aeson as Aeson +import Data.HashMap.Strict qualified as HM +import Text.InterpolatedString.Perl6 (q,qc) +import Data.Text qualified as Text +import Data.Maybe +import Data.List qualified as List +import Data.Either +import Data.List (sortBy,sortOn) +import Data.Ord +import Lens.Micro.Platform +import Data.Generics.Product.Fields (field) +import Control.Monad.Trans.Maybe +import Data.Coerce +import Data.Fixed +import Data.Word (Word64) +import System.TimeIt + +-- TODO: runPipe-omitted +-- runPipe нигде не запускается, значит, все изменения +-- будут закоммичены в БД только по явному вызову +-- commitAll или transactional +-- это может объясняеть некоторые артефакты. +-- Но это и удобно: кажется, что можно менять БД +-- на лету бесплатно + + +pattern Operand :: forall {c} . Text -> Syntax c +pattern Operand what <- (operand -> Just what) + +pattern BinOp :: forall {c} . Id -> Syntax c +pattern BinOp what <- (binOp -> Just what) + +binOp :: Syntax c -> Maybe Id +binOp = \case + SymbolVal "~" -> Just "like" + SymbolVal "&&" -> Just "and" + SymbolVal "||" -> Just "or" + _ -> Nothing + +operand :: Syntax c -> Maybe Text +operand = \case + SymbolVal c -> Just (coerce c) + LitStrVal s -> Just s + LitIntVal i -> Just (Text.pack (show i)) + LitScientificVal v -> Just (Text.pack (show v)) + _ -> Nothing + + +instance ToField HashRef where + toField x = toField $ show $ pretty x + +instance FromField HashRef where + fromField = fmap (fromString @HashRef) . fromField @String + +evolve :: FixmePerks m => FixmeM m () +evolve = withState do + createTables + +withState :: forall m a . (FixmePerks m, MonadReader FixmeEnv m) => DBPipeM m a -> m a +withState what = do + lock <- asks fixmeLock + db <- withMVar lock $ \_ -> do + t <- asks fixmeEnvDb + mdb <- readTVarIO t + case mdb of + Just d -> pure (Right d) + Nothing -> do + path <- asks fixmeEnvDbPath >>= readTVarIO + newDb <- try @_ @IOException (newDBPipeEnv dbPipeOptsDef path) + case newDb of + Left e -> pure (Left e) + Right db -> do + debug "set-new-db" + atomically $ writeTVar t (Just db) + pure $ Right db + + either throwIO (`withDB` what) db + +createTables :: FixmePerks m => DBPipeM m () +createTables = do + + -- тут все таблицы будут называться с префиксом + -- fixme, что бы может быть можно было встроить + -- в другую бд, если вдруг понадобится + + ddl [qc| + create table if not exists fixmegitobject + ( hash text not null + , type text null + , primary key (hash) + ) + |] + + ddl [qc| + create table if not exists fixme + ( id text not null + , ts integer + , fixme blob not null + , primary key (id) + ) + |] + + ddl [qc| + create table if not exists fixmedeleted + ( id text not null + , ts integer not null + , deleted bool not null + , primary key (id,ts) + ) + |] + + ddl [qc| + create table if not exists fixmerel + ( origin text not null + , related text not null + , ts integer not null + , reason text not null + , primary key (origin,related,ts) + ) + |] + + ddl [qc| + create table if not exists fixmeattr + ( fixme text not null + , ts integer null + , name text not null + , value text + , primary key (fixme,ts,name) + ) + |] + + ddl [qc| drop view if exists fixmeattrview |] + + let commits = [qc|name in ('commit','committer','committer-name','committer-email','commit-time')|] :: Text + + ddl [qc| + create view fixmeattrview as + with ranked1 as ( + select + fixme, + name, + value, + row_number() over (partition by fixme, name order by ts desc nulls first) as rn + from fixmeattr + where not ({commits}) + ) + , ranked2 as ( + select + fixme, + name, + value, + row_number() over (partition by fixme, name order by ts asc nulls last) as rn + from fixmeattr + where ({commits}) + ) + + select distinct fixme,name,value + from + ( + select + fixme, + name, + value + from ranked1 + where rn = 1 + + union + + select + fixme, + name, + value + from ranked2 + where rn = 1 + ) + |] + + ddl [qc|drop view if exists fixmeactualview|] + + ddl [qc| + create view fixmeactualview as + with a1 as ( + select + a.fixme, + f.ts, + a.name, + a.value + from + fixmeattrview a + join fixme f on a.fixme = f.id + where + a.name = 'fixme-key' + and not exists (select null from fixmedeleted d where d.id = f.id) + ), + rn AS ( + select + f.id, + f.ts, + a.value AS fixmekey, + row_number() over (partition by a.value order by f.ts desc) as rn + from + fixme f + join a1 a on f.id = a.fixme and a.name = 'fixme-key' + ) + select id as fixme, fixmekey, ts from rn + where rn = 1 + and not exists ( + select null + from fixmeattr a + join fixmedeleted d on d.id = a.fixme + where a.name = 'fixme-key' + and a.value = rn.fixmekey + ) + + |] + + + ddl [qc| + create table if not exists fixmeactual + ( fixme text not null + , primary key (fixme) + ) + |] + + ddl [qc| + create table if not exists fixmejson + ( fixme text not null + , fixmekey text + , json blob + , primary key (fixme) + ) + |] + + ddl [qc| + create index if not exists idx_fixmekey ON fixmejson(fixmekey) + |] + + ddl [qc| create table if not exists fixmestagedel + ( hash text not null primary key + , ts integer not null + ) + |] + + ddl [qc| create table if not exists fixmestagemod + ( hash text not null + , ts integer not null + , attr text not null + , value text + , primary key (hash,attr) + ) + |] + + ddl [qc| create table if not exists fixmeprocessed + ( hash text not null + , primary key (hash) + ) + |] + +-- .fixme-new/state.db +-- and not exists (select null from fixmedeleted d where a.fixme = id limit 1) + +insertCommit :: FixmePerks m => GitHash -> DBPipeM m () +insertCommit gh = do + insert [qc| + insert into fixmegitobject (hash,type) values(?,'commit') + on conflict (hash) do nothing + |] (Only gh) + +insertBlob :: FixmePerks m => GitHash -> DBPipeM m () +insertBlob gh = do + insert [qc| + insert into fixmegitobject (hash,type) values(?,'blob') + on conflict (hash) do nothing + |] (Only gh) + +selectObjectHash :: FixmePerks m => GitHash -> DBPipeM m (Maybe GitHash) +selectObjectHash gh = do + select [qc|select hash from fixmegitobject where hash = ?|] (Only gh) + <&> fmap fromOnly . listToMaybe + +newCommit :: (FixmePerks m, MonadReader FixmeEnv m) => GitHash -> m Bool +newCommit gh = isNothing <$> withState (selectObjectHash gh) + +insertFixme :: FixmePerks m => Fixme -> DBPipeM m () +insertFixme fx@Fixme{..} = do + let fixme = serialise fx + let fxId = hashObject @HbSync fixme & HashRef + insert [qc|insert into fixme (id, ts, fixme) values (?,?,?) + on conflict(id) do nothing + |] (fxId, fixmeTs, fixme) + + for_ (HM.toList fixmeAttr) $ \(n,v) -> do + insert [qc| + insert into fixmeattr(fixme,ts,name,value) + values (?,?,?,?) + on conflict (fixme,ts,name) do update set value = excluded.value + |] (fxId, fixmeTs, n, v) + + insert [qc| + insert into fixmeattr(fixme,ts,name,value) + values (?,?,?,?) + on conflict (fixme,ts,name) do update set value = excluded.value + |] (fxId, fixmeTs, "fixme-tag", fixmeTag) + + insert [qc| + insert into fixmeattr(fixme,ts,name,value) + values (?,?,?,?) + on conflict (fixme,ts,name) do update set value = excluded.value + |] (fxId, fixmeTs, "fixme-title", fixmeTitle) + + +data SelectPredicate = + All + | FixmeHashExactly Text + | AttrLike Text Text + | And SelectPredicate SelectPredicate + | Or SelectPredicate SelectPredicate + | Not SelectPredicate + | Ignored + deriving stock (Data,Generic,Show) + +class HasPredicate a where + predicate :: a -> SelectPredicate + +instance HasPredicate () where + predicate = const All + +instance HasPredicate SelectPredicate where + predicate = id + + +instance IsContext c => HasPredicate [Syntax c] where + predicate s = goPred $ unlist $ go s + where + + goPred :: Syntax c -> SelectPredicate + goPred = \case + ListVal [SymbolVal "not", a] -> Not (goPred a) + ListVal [SymbolVal "or", a, b] -> Or (goPred a) (goPred b) + ListVal [SymbolVal "and", a, b] -> And (goPred a) (goPred b) + ListVal [SymbolVal "like", StringLike a, StringLike b] -> AttrLike (Text.pack a) (Text.pack b) + _ -> Ignored + + go :: [Syntax c] -> Syntax c + go = \case + + ( SymbolVal "!" : rest ) -> do + mklist [mksym "not", unlist (go rest)] + + ( Operand a : SymbolVal "~" : Operand b : rest ) -> do + go (mklist [mksym "like", mkstr a, mkstr b] : rest) + + ( w : SymbolVal "&&" : rest ) -> do + mklist [mksym "and", unlist w, unlist (go rest)] + + ( w : SymbolVal "||" : rest ) -> do + mklist [mksym "or", unlist w, unlist (go rest)] + + w -> mklist w + + unlist = \case + ListVal [x] -> x + x -> x + + +{- HLINT ignore "Functor law" -} +{- HLINT ignore "Eta reduce" -} + +selectFixmeHash :: (FixmePerks m) => Text -> FixmeM m (Maybe Text) +selectFixmeHash what = listToMaybe <$> selectFixmeHashes what + +selectFixmeHashes :: (FixmePerks m) => Text -> FixmeM m [Text] +selectFixmeHashes what = withState do + let w = what <> "%" + select @(Only Text) + [qc| select fixme + from fixmejson + where json_extract(json,'$."fixme-key"') like ? + union + select id + from fixme + where id like ? + |] (w,w) + <&> fmap fromOnly + +selectFixme :: FixmePerks m => Text -> FixmeM m (Maybe Fixme) +selectFixme txt = do + + attrs <- selectFixmeThin (FixmeHashExactly txt) + <&> fmap coerce . headMay + <&> fromMaybe mempty + + runMaybeT do + + lift (withState $ select [qc|select fixme from fixme where id = ? limit 1|] (Only txt)) + <&> listToMaybe . fmap fromOnly + >>= toMPlus + <&> (deserialiseOrFail @Fixme) + >>= toMPlus + <&> over (field @"fixmeAttr") (<> attrs) + + +listAllFixmeHashes :: (FixmePerks m, MonadReader FixmeEnv m) => m (HashSet HashRef) +listAllFixmeHashes = withState do + select_ @_ @(Only HashRef) [qc|select id from fixme|] + <&> HS.fromList . fmap fromOnly + +checkFixmeExists :: FixmePerks m => HashRef -> FixmeM m Bool +checkFixmeExists what = withState do + select @(Only (Maybe Int)) [qc|select 1 from fixme where id = ? limit 1|] (Only what) + <&> not . List.null + +data Bound = forall a . (ToField a, Show a) => Bound a + +instance ToField Bound where + toField (Bound x) = toField x + +instance Show Bound where + show (Bound x) = show x + +genPredQ :: Text -> SelectPredicate -> (Text, [Bound]) +genPredQ tbl what = go what + where + go = \case + All -> ("true", mempty) + + FixmeHashExactly x -> + ([qc|({tbl}.fixme = ?)|], [Bound x]) + + AttrLike "fixme-hash" val -> do + let binds = [Bound (val <> "%")] + ([qc|({tbl}.fixme like ?)|], binds) + + AttrLike name val -> do + let x = val <> "%" + let binds = [Bound x] + ([qc|(json_extract({tbl}.json, '$."{name}"') like ?)|], binds) + + Not a -> do + let (sql, bound) = go a + ([qc|(coalesce(not {sql},true))|], bound) + + And a b -> do + let (asql, abound) = go a + let (bsql, bbound) = go b + ([qc|{asql} and {bsql}|], abound <> bbound) + + Or a b -> do + let asql = go a + let bsql = go b + ([qc|{fst asql} or {fst bsql}|], snd asql <> snd bsql) + + Ignored -> ("false", mempty) + + +updateFixmeJson :: FixmePerks m => DBPipeM m () +updateFixmeJson = do + + update_ [qc| + + insert into fixmejson (fixme,fixmekey,json) + with json as ( + select + a.fixme as fixme, + cast(json_set(json_group_object(a.name,a.value), '$."fixme-hash"', f.fixme) as blob) as json + + from + fixmeattrview a join fixmeactual f on f.fixme = a.fixme + + group by a.fixme + ) + + select + fixme + , json_extract(json, '$."fixme-key"') as fixmekey + , json + from json where true + on conflict (fixme) do update set json = excluded.json, fixmekey = excluded.fixmekey + |] + + +-- TODO: predicate-for-stage-toggle +selectFixmeThin :: (FixmePerks m, HasPredicate a) => a -> FixmeM m [FixmeThin] +selectFixmeThin a = withState do + + let predic = genPredQ "j" (predicate a) + + let emptyObect = [q|'{}'|] :: String + + let sql = [qc| + +with s1 as ( + select m.hash as hash + , cast(json_group_object(m.attr,m.value) as blob) as json + from fixmestagemod m +) + +select cast(json_patch(j.json, coalesce(s.json,{emptyObect})) as blob) as blob + +from + fixmejson j join fixmeactual f on f.fixme = j.fixme + join fixme f0 on f0.id = f.fixme + left join s1 s on s.hash = j.fixme + +where + + ( + {fst predic} + ) + +order by json_extract(blob, '$.commit-time'), json_extract(blob, '$.title') + + |] + + trace $ red "selectFixmeThin" <> line <> pretty sql + + (t,r) <- timeItT $ select sql (snd predic) <&> mapMaybe (Aeson.decode @FixmeThin . fromOnly) + + trace $ yellow "selectFixmeThin" <> line + <> pretty sql <> line + <> pretty (length r) <+> "rows" <> line + <> pretty "elapsed" <+> pretty (realToFrac t :: Fixed E6) + + pure r + +cleanupDatabase :: (FixmePerks m, MonadReader FixmeEnv m) => m () +cleanupDatabase = do + warn $ red "cleanupDatabase" + withState $ transactional do + update_ [qc|delete from fixme|] + update_ [qc|delete from fixmeattr|] + update_ [qc|delete from fixmegitobject|] + update_ [qc|delete from fixmedeleted|] + update_ [qc|delete from fixmerel|] + update_ [qc|delete from fixmeactual|] + update_ [qc|delete from fixmejson|] + update_ [qc|delete from fixmestagedel|] + update_ [qc|delete from fixmestagemod|] + + +insertFixmeModStaged :: (FixmePerks m,MonadReader FixmeEnv m) + => Text + -> FixmeAttrName + -> FixmeAttrVal + -> m () +insertFixmeModStaged hash k v = withState do + ts <- getEpoch + insert [qc| insert into fixmestagemod (hash,ts,attr,value) values(?,?,?,?) + on conflict (hash,attr) + do update set hash = excluded.hash + , ts = excluded.ts + , attr = excluded.attr + , value = excluded.value + |] (hash,ts,k,v) + + +insertFixmeDelStaged :: (FixmePerks m,MonadReader FixmeEnv m) => Text -> m () +insertFixmeDelStaged hash = withState do + ts <- getEpoch + insert [qc| insert into fixmestagedel (hash,ts) values(?,?) + on conflict (hash) + do update set hash = excluded.hash + , ts = excluded.ts + |] (hash,ts) + + +type StageModRow = (HashRef,Word64,Text,Text) + +selectStageModified :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction] +selectStageModified = withState do + what <- select_ @_ @StageModRow [qc|select hash,ts,attr,value from fixmestagemod|] + for what $ \(h,t,k,v) -> do + pure $ Modified t h (FixmeAttrName k) (FixmeAttrVal v) + +selectStageDeleted :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction] +selectStageDeleted = withState do + what <- select_ @_ @(HashRef,Word64) [qc|select hash,ts from fixmestagedel|] + for what $ \(h,t) -> do + pure $ Deleted t h + +selectStage :: (FixmePerks m,MonadReader FixmeEnv m) => m [CompactAction] +selectStage = do + a <- selectStageModified + b <- selectStageDeleted + pure (a<>b) + +cleanStage :: (FixmePerks m,MonadReader FixmeEnv m) => m () +cleanStage = withState do + transactional do + update_ [qc|delete from fixmestagedel|] + update_ [qc|delete from fixmestagemod|] + +deleteFixme :: (FixmePerks m,MonadReader FixmeEnv m) => Text -> m () +deleteFixme hash = withState do + trace $ red "deleteFixme" <+> pretty hash + + here <- select [qc| select true + from fixmedeleted + where deleted and id = ? + order by ts desc + limit 1 + |] (Only hash) <&> isJust . listToMaybe . fmap (fromOnly @Bool) + + unless here do + insert [qc| insert into fixmedeleted (id,ts,deleted) + values (?,(strftime('%s', 'now')),true) + on conflict(id,ts) do nothing + |] (Only hash) + +updateFixme :: (FixmePerks m,MonadReader FixmeEnv m) + => Maybe FixmeTimestamp + -> Text + -> FixmeAttrName + -> FixmeAttrVal + -> m () + +updateFixme ts hash a b = withState do + warn $ red "updateFixme" <+> pretty hash + insert [qc| insert into fixmeattr (fixme,ts,name,value) + values (?,coalesce(?,strftime('%s', 'now')),?,?) + on conflict(fixme,ts,name) do update set value = excluded.value + |] (hash,ts,a,b) + +updateIndexes :: (FixmePerks m, MonadReader FixmeEnv m) => m () +updateIndexes = withState $ transactional do + update_ [qc|delete from fixmeactual|] + update_ [qc| + insert into fixmeactual + select distinct fixme from fixmeactualview + |] + updateFixmeJson + -- FIXME: delete-table-grows + -- надо добавлять статус в fixmedeleted + -- только если он отличается от последнего + -- известного статуса + update_ [qc|delete from fixmejson where fixme in (select distinct id from fixmedeleted)|] + + + +insertProcessed :: (FixmePerks m, MonadReader FixmeEnv m, Hashed HbSync w) + => w + -> DBPipeM m () +insertProcessed what = do + insert [qc| insert into fixmeprocessed (hash) values(?) + on conflict (hash) do nothing + |] (Only (show $ pretty $ hashObject @HbSync what)) + + +isProcessed :: (FixmePerks m, MonadReader FixmeEnv m, Hashed HbSync w) + => w + -> DBPipeM m Bool +isProcessed what = do + let k = show $ pretty $ hashObject @HbSync what + select @(Only (Maybe Int)) [qc| select null from fixmeprocessed where hash = ? limit 1 |] (Only k) + <&> isJust . listToMaybe + +selectProcessed :: (FixmePerks m, MonadReader FixmeEnv m) + => m [HashRef] +selectProcessed = withState do + select_ [qc|select hash from fixmeprocessed|] + <&> fmap fromOnly + + diff --git a/fixme-new/lib/Fixme/Types.hs b/fixme-new/lib/Fixme/Types.hs new file mode 100644 index 00000000..571a672b --- /dev/null +++ b/fixme-new/lib/Fixme/Types.hs @@ -0,0 +1,648 @@ +{-# LANGUAGE PatternSynonyms, ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Fixme.Types + ( module Fixme.Types + ) where + +import Fixme.Prelude hiding (align) +import HBS2.Base58 + +import DBPipe.SQLite hiding (field) +import HBS2.Git.Local + +import Data.Config.Suckless + +import Prettyprinter.Render.Terminal +import Control.Applicative +import Data.Aeson +import Data.ByteString (ByteString) +import Data.ByteString.Char8 qualified as BS8 +import Data.ByteString.Lazy qualified as LBS +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HM +import Data.HashSet (HashSet) +import Data.HashSet qualified as HS +import Data.Word (Word64,Word32) +import Data.Maybe +import Data.Coerce +import Data.Text qualified as Text +import Data.List qualified as List +import Data.Map qualified as Map +import System.FilePath +import Text.InterpolatedString.Perl6 (qc) +import Data.Generics.Product.Fields (field) +import Lens.Micro.Platform + +-- FIXME: move-to-suckless-conf +deriving stock instance Ord (Syntax C) + +pattern StringLike :: forall {c} . String -> Syntax c +pattern StringLike e <- (stringLike -> Just e) + +pattern StringLikeList :: forall {c} . [String] -> [Syntax c] +pattern StringLikeList e <- (stringLikeList -> e) + +pattern FixmeHashLike :: forall {c} . Text -> Syntax c +pattern FixmeHashLike e <- (fixmeHashFromSyn -> Just e) + + +pattern TimeStampLike :: forall {c} . FixmeTimestamp -> Syntax c +pattern TimeStampLike e <- (tsFromFromSyn -> Just e) + +fixContext :: IsContext c => Syntax c -> Syntax C +fixContext = go + where + go = \case + List _ xs -> List noContext (fmap go xs) + Symbol _ w -> Symbol noContext w + Literal _ l -> Literal noContext l + +mklist :: IsContext c => [Syntax c] -> Syntax c +mklist = List noContext + +mkint :: (IsContext c, Integral a) => a -> Syntax c +mkint = Literal noContext . LitInt . fromIntegral + +mksym :: IsContext c => Id -> Syntax c +mksym = Symbol noContext + +class MkId a where + mkId :: a -> Id + +instance MkId FixmeAttrName where + mkId (k :: FixmeAttrName) = Id ("$" <> coerce k) + +instance MkId (Text,Int) where + mkId (p, i) = Id (p <> fromString (show i)) + +instance MkId (String,Integer) where + mkId (p, i) = Id (fromString p <> fromString (show i)) + +class IsContext c => MkStr c a where + mkstr :: a -> Syntax c + + +instance IsContext c => MkStr c String where + mkstr s = Literal (noContext @c) (LitStr $ Text.pack s) + +instance IsContext c => MkStr c ByteString where + mkstr s = Literal (noContext @c) (LitStr $ Text.pack $ BS8.unpack s) + +instance IsContext c => MkStr c (Maybe FixmeKey) where + mkstr Nothing = Literal (noContext @c) (LitStr "") + mkstr (Just k) = Literal (noContext @c) (LitStr (coerce k)) + +instance IsContext c => MkStr c FixmeAttrVal where + mkstr (s :: FixmeAttrVal) = Literal (noContext @c) (LitStr (coerce s)) + + +instance IsContext c => MkStr c (Maybe FixmeAttrVal) where + mkstr (Just v) = mkstr v + mkstr Nothing = mkstr ( "" :: Text ) + +instance IsContext c => MkStr c FixmeAttrName where + mkstr (s :: FixmeAttrName) = Literal (noContext @c) (LitStr (coerce s)) + +instance IsContext c => MkStr c HashRef where + mkstr s = Literal (noContext @c) (LitStr (fromString $ show $ pretty s)) + +instance IsContext c => MkStr c Text where + mkstr = Literal noContext . LitStr + +stringLike :: Syntax c -> Maybe String +stringLike = \case + LitStrVal s -> Just $ Text.unpack s + SymbolVal (Id s) -> Just $ Text.unpack s + _ -> Nothing + +stringLikeList :: [Syntax c] -> [String] +stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes + +fixmeHashFromSyn :: Syntax c -> Maybe Text +fixmeHashFromSyn = \case + StringLike s -> do + let (_,value) = span (`elem` "#%~:") s + Just $ Text.pack value + + _ -> Nothing + +tsFromFromSyn :: Syntax c -> Maybe FixmeTimestamp +tsFromFromSyn = \case + LitIntVal n -> Just (fromIntegral n) + _ -> Nothing + +newtype FixmeTag = FixmeTag { fromFixmeTag :: Text } + deriving newtype (Eq,Ord,Show,IsString,Hashable,Semigroup,Monoid,ToField,FromField) + deriving stock (Data,Generic) + +newtype FixmeTitle = FixmeTitle { fromFixmeTitle :: Text } + deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid,ToField,FromField,Hashable) + deriving stock (Data,Generic) + +newtype FixmePlainLine = FixmePlainLine { fromFixmeText :: Text } + deriving newtype (Eq,Ord,Show,IsString,Semigroup,Monoid,ToField,FromField) + deriving stock (Data,Generic) + + +newtype FixmeAttrName = FixmeAttrName { fromFixmeAttrName :: Text } + deriving newtype (Eq,Ord,Show,IsString,Hashable) + deriving newtype (ToField,FromField) + deriving newtype (ToJSON,FromJSON,ToJSONKey,FromJSONKey) + deriving stock (Data,Generic) + + +newtype FixmeAttrVal = FixmeAttrVal { fromFixmeAttrVal :: Text } + deriving newtype (Eq,Ord,Show,IsString,Hashable,ToField,FromField,ToJSON,FromJSON,Semigroup,Monoid) + deriving stock (Data,Generic) + +newtype FixmeTimestamp = FixmeTimestamp Word64 + deriving newtype (Eq,Ord,Show,Num,ToField,FromField) + deriving stock (Data,Generic) + + +newtype FixmeKey = FixmeKey Text + deriving newtype (Eq,Ord,Show,ToField,FromField) + deriving stock (Data,Generic) + +newtype FixmeOffset = FixmeOffset Word32 + deriving newtype (Eq,Ord,Show,Num,ToField,FromField) + deriving newtype (Integral,Real,Enum) + deriving stock (Data,Generic) + + +data Fixme = + Fixme + { fixmeTag :: FixmeTag + , fixmeTitle :: FixmeTitle + , fixmeKey :: Maybe FixmeKey + , fixmeTs :: Maybe FixmeTimestamp + , fixmeStart :: Maybe FixmeOffset + , fixmeEnd :: Maybe FixmeOffset + , fixmePlain :: [FixmePlainLine] + , fixmeAttr :: HashMap FixmeAttrName FixmeAttrVal + } + deriving stock (Ord,Eq,Show,Data,Generic) + +instance Monoid Fixme where + mempty = Fixme mempty mempty Nothing Nothing Nothing Nothing mempty mempty + +instance Semigroup Fixme where + (<>) a b = b { fixmeTs = fixmeTs b <|> fixmeTs a + , fixmeTitle = fixmeAttrNonEmpty (fixmeTitle a) (fixmeTitle b) + , fixmeTag = fixmeAttrNonEmpty (fixmeTag a) (fixmeTag b) + , fixmeStart = fixmeStart b <|> fixmeStart a + , fixmeEnd = fixmeEnd b <|> fixmeEnd a + , fixmePlain = fixmePlain b + , fixmeAttr = fixmeAttr a <> fixmeAttr b + } + +newtype FixmeThin = FixmeThin (HashMap FixmeAttrName FixmeAttrVal) + deriving newtype (Semigroup,Monoid,Eq,Ord,Show,ToJSON,FromJSON) + deriving stock (Data,Generic) + + + + +type FixmePerks m = ( MonadUnliftIO m + , MonadIO m + ) + + +data UpdateAction = forall c . IsContext c => UpdateAction { runUpdateAction :: Syntax c -> IO () } + +data ReadLogAction = forall c . IsContext c => ReadLogAction { runReadLog :: Syntax c -> IO () } + +-- FIXME: fucking-context-hardcode-wtf-1 +data CatAction = CatAction { catAction :: [(Id, Syntax C)] -> LBS.ByteString -> IO () } + +data SimpleTemplate = forall c . (IsContext c, Data (Context c), Data c) => SimpleTemplate [Syntax c] + +class HasSequence w where + getSequence :: w -> Word64 + +newtype FromFixmeKey a = FromFixmeKey a + +data CompactAction = + Deleted Word64 HashRef + | Modified Word64 HashRef FixmeAttrName FixmeAttrVal + | Added Word64 Fixme + deriving stock (Eq,Ord,Show,Generic) + +class MkKey a where + mkKey :: a -> ByteString + +instance MkKey CompactAction where + mkKey (Deleted _ h) = "D" <> LBS.toStrict (serialise h) + mkKey (Modified _ h _ _) = "M" <> LBS.toStrict (serialise h) + mkKey (Added _ fixme) = "A" <> coerce (hashObject @HbSync $ serialise fixme) + +instance MkKey (FromFixmeKey Fixme) where + mkKey (FromFixmeKey fx@Fixme{..}) = + maybe k2 (mappend "A" . LBS.toStrict . serialise) (HM.lookup "fixme-key" fixmeAttr) + where k2 = mappend "A" $ serialise fx & LBS.toStrict + +instance Pretty CompactAction where + pretty = \case + Deleted s r -> pretty $ mklist @C [ mksym "deleted", mkint s, mkstr r ] + Modified s r k v -> pretty $ mklist @C [ mksym "modified", mkint s, mkstr r, mkstr k, mkstr v ] + -- FIXME: normal-pretty-instance + e@(Added w fx) -> do + pretty $ mklist @C [ mksym "added", mkstr (toBase58 $ mkKey e) ] + +instance Serialise CompactAction + +pattern CompactActionSeq :: Word64 -> CompactAction +pattern CompactActionSeq s <- (seqOf -> Just s) + +{-# COMPLETE CompactActionSeq #-} + +seqOf :: CompactAction -> Maybe Word64 +seqOf = \case + Deleted w _ -> Just w + Modified w _ _ _ -> Just w + Added w _ -> Just w + +instance HasSequence CompactAction where + getSequence x = fromMaybe 0 (seqOf x) + +data FixmeTemplate = + Simple SimpleTemplate + +data RenderError = RenderError String + deriving stock (Eq,Show,Typeable) + +class FixmeRenderTemplate a b where + render :: a -> Either RenderError b + +data FixmeOpts = + FixmeOpts + { fixmeOptNoEvolve :: Bool + } + deriving stock (Eq,Ord,Show,Data,Generic) + +instance Monoid FixmeOpts where + mempty = FixmeOpts False + +instance Semigroup FixmeOpts where + (<>) _ b = FixmeOpts (fixmeOptNoEvolve b) + +data FixmeEnv = + FixmeEnv + { fixmeLock :: MVar () + , fixmeEnvOpts :: TVar FixmeOpts + , fixmeEnvDbPath :: TVar FilePath + , fixmeEnvDb :: TVar (Maybe DBPipeEnv) + , fixmeEnvGitDir :: TVar (Maybe FilePath) + , fixmeEnvFileMask :: TVar [FilePattern] + , fixmeEnvTags :: TVar (HashSet FixmeTag) + , fixmeEnvAttribs :: TVar (HashSet FixmeAttrName) + , fixmeEnvAttribValues :: TVar (HashMap FixmeAttrName (HashSet FixmeAttrVal)) + , fixmeEnvDefComments :: TVar (HashSet Text) + , fixmeEnvFileComments :: TVar (HashMap FilePath (HashSet Text)) + , fixmeEnvGitScanDays :: TVar (Maybe Integer) + , fixmeEnvUpdateActions :: TVar [UpdateAction] + , fixmeEnvReadLogActions :: TVar [ReadLogAction] + , fixmeEnvCatAction :: TVar CatAction + , fixmeEnvTemplates :: TVar (HashMap Id FixmeTemplate) + , fixmeEnvMacro :: TVar (HashMap Id (Syntax C)) + , fixmeEnvCatContext :: TVar (Int,Int) + } + + +fixmeGetCommentsFor :: FixmePerks m => Maybe FilePath -> FixmeM m [Text] + +fixmeGetCommentsFor Nothing = do + asks fixmeEnvDefComments >>= readTVarIO + <&> HS.toList + +fixmeGetCommentsFor (Just fp) = do + cof <- asks fixmeEnvFileComments >>= readTVarIO + def <- asks fixmeEnvDefComments >>= readTVarIO + + let r = maybe mempty HS.toList (HM.lookup (commentKey fp) cof) + <> HS.toList def + + pure r + +{- HLINT ignore "Functor law" -} + +fixmeGetGitDirCLIOpt :: (FixmePerks m, MonadReader FixmeEnv m) => m String +fixmeGetGitDirCLIOpt = do + asks fixmeEnvGitDir + >>= readTVarIO + <&> fmap (\d -> [qc|--git-dir {d}|]) + <&> fromMaybe "" + +newtype FixmeM m a = FixmeM { fromFixmeM :: ReaderT FixmeEnv m a } + deriving newtype ( Applicative + , Functor + , Monad + , MonadIO + , MonadUnliftIO + , MonadReader FixmeEnv + ) + + +fixmeEnvBare :: FixmePerks m => m FixmeEnv +fixmeEnvBare = + FixmeEnv + <$> newMVar () + <*> newTVarIO mempty + <*> newTVarIO ":memory:" + <*> newTVarIO Nothing + <*> newTVarIO Nothing + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO defCommentMap + <*> newTVarIO Nothing + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO (CatAction $ \_ _ -> pure ()) + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO (1,3) + +withFixmeEnv :: FixmePerks m => FixmeEnv -> FixmeM m a -> m a +withFixmeEnv env what = runReaderT ( fromFixmeM what) env + +-- FIXME: move-to-suckless-conf-library +deriving newtype instance Hashable Id + +instance Serialise FixmeTag +instance Serialise FixmeTitle +instance Serialise FixmePlainLine +instance Serialise FixmeAttrName +instance Serialise FixmeAttrVal +instance Serialise FixmeTimestamp +instance Serialise FixmeOffset +instance Serialise FixmeKey +instance Serialise Fixme + + +instance ToField GitHash where + toField h = toField (show $ pretty h) + +instance ToField GitRef where + toField h = toField (show $ pretty h) + +instance FromField GitRef where + fromField = fmap fromString . fromField @String + +instance FromField GitHash where + fromField = fmap fromString . fromField @String + +instance Pretty FixmeTimestamp where + pretty = pretty . coerce @_ @Word64 + +instance Pretty FixmeOffset where + pretty = pretty . coerce @_ @Word32 + +instance Pretty FixmeAttrName where + pretty = pretty . coerce @_ @Text + +instance Pretty FixmeAttrVal where + pretty = pretty . coerce @_ @Text + +instance Pretty FixmeTitle where + pretty = pretty . coerce @_ @Text + +instance Pretty FixmeTag where + pretty = pretty . coerce @_ @Text + +instance Pretty FixmePlainLine where + pretty = pretty . coerce @_ @Text + +instance Pretty Fixme where + pretty Fixme{..} = + pretty fixmeTag <+> pretty fixmeTitle + <> fstart + <> fend + <> la + <> lls + <> line + where + + fstart = case fixmeStart of + Just s -> line <> pretty ([qc| $fixme-start: {show $ pretty s}|] :: String) + Nothing -> mempty + + fend = case fixmeEnd of + Just s -> line <> pretty ([qc| $fixme-end: {show $ pretty s}|] :: String) + Nothing -> mempty + + la | not (HM.null fixmeAttr) = do + let a = HM.toList fixmeAttr + let ss = [ [qc| ${show $ pretty n}: {show $ pretty v}|] | (n,v) <- a ] :: [String] + line <> vcat ( fmap pretty ss ) <> line + + | otherwise = mempty + + lls | not (null fixmePlain) = line <> vcat (fmap pretty fixmePlain) + | otherwise = mempty + + +defCommentMap :: HashMap FilePath (HashSet Text) +defCommentMap = HM.fromList + [ comment ".cabal" ["--"] + , comment ".hs" ["--"] + , comment ".c" ["//"] + , comment ".h" ["//"] + , comment ".cc" ["//"] + , comment ".cpp" ["//"] + , comment ".cxx" ["//"] + , comment "Makefile" ["#"] + ] + where + comment a b = (a, HS.fromList b) + +commentKey :: FilePath -> FilePath +commentKey fp = + case takeExtension fp of + "" -> takeFileName fp + xs -> xs + +type ContextShit c = (Data c, Data (Context c), IsContext c, Data (Syntax c)) + + +cc0 :: forall c . ContextShit c => Context c +cc0 = noContext :: Context c + +inject :: forall c a . (ContextShit c, Data a) => [(Id,Syntax c)] -> a -> a +inject repl target = + flip transformBi target $ \case + (SymbolVal x) | issubst x -> fromMaybe mt (Map.lookup x rmap) + other -> other + where + mt = Literal (noContext @c) (LitStr "") + rmap = Map.fromList repl + issubst (Id x) = Text.isPrefixOf "$" x + +pattern NL :: forall {c}. Syntax c +pattern NL <- ListVal [SymbolVal "nl"] + + +instance FixmeRenderTemplate SimpleTemplate (Doc AnsiStyle) where + + render (SimpleTemplate syn) = Right $ mconcat $ + flip fix (mempty,syn) $ \next -> \case + (acc, NL : rest) -> next (acc <> nl, rest) + (acc, ListVal [StringLike w] : rest) -> next (acc <> txt w, rest) + (acc, StringLike w : rest) -> next (acc <> txt w, rest) + (acc, ListVal [SymbolVal "trim", LitIntVal n, e] : rest) -> next (acc <> trim n (deep' [e]), rest) + (acc, ListVal [SymbolVal "align", LitIntVal n, e] : rest) -> next (acc <> align n (deep' [e]), rest) + (acc, ListVal [SymbolVal "fg", SymbolVal co, e] : rest) -> next (acc <> fmap (fg_ (color_ co)) (deep [e]), rest) + (acc, ListVal [SymbolVal "bg", SymbolVal co, e] : rest) -> next (acc <> fmap (bg_ (color_ co)) (deep [e]), rest) + (acc, ListVal [SymbolVal "fgd", SymbolVal co, e] : rest) -> next (acc <> fmap (fgd_ (color_ co)) (deep [e]), rest) + (acc, ListVal [SymbolVal "bgd", SymbolVal co, e] : rest) -> next (acc <> fmap (bgd_ (color_ co)) (deep [e]), rest) + + (acc, ListVal [ SymbolVal "if", cond + , ListVal (SymbolVal "then" : then_) + , ListVal (SymbolVal "else" : else_) + ] : rest) -> do + + let r = case cond of + ListVal [SymbolVal "~", StringLike p, evaluated -> Just x] -> + Text.isPrefixOf (Text.pack p) x + _ -> False + + next (acc <> if r then deep then_ else deep else_, rest) + + + (acc, ListVal es : rest) -> next (acc <> deep es, rest) + (acc, e : rest) -> next (acc <> p e, rest) + (acc, []) -> acc + + where + + evaluated :: (ContextShit c) => Syntax c -> Maybe Text + evaluated what = Just (deep' [what] & Text.concat) + + color_ = \case + "black" -> Just Black + "red" -> Just Red + "green" -> Just Green + "yellow" -> Just Yellow + "blue" -> Just Blue + "magenta" -> Just Magenta + "cyan" -> Just Cyan + "white" -> Just White + _ -> Nothing + + + fg_ = maybe id (annotate . color) + bg_ = maybe id (annotate . bgColor) + + fgd_ = maybe id (annotate . colorDull) + bgd_ = maybe id (annotate . bgColorDull) + + untxt = fmap pretty + + align n0 s0 | n > 0 = untxt [Text.justifyLeft n ' ' s] + | otherwise = untxt [Text.justifyRight (abs n) ' ' s] + + where + n = fromIntegral n0 + s = mconcat s0 + + trim n0 s0 | n >= 0 = untxt [ Text.take n s ] + | otherwise = untxt [ Text.takeEnd (abs n) s ] + where + n = fromIntegral n0 + s = mconcat s0 + + deep :: forall c . (ContextShit c) => [Syntax c] -> [Doc AnsiStyle] + deep sy = either mempty List.singleton (render (SimpleTemplate sy)) + + deep' :: forall c . (ContextShit c) => [Syntax c] -> [Text] + deep' sy = do + let what = deep sy + [ Text.pack (show x) | x <- what] + + nl = [ line ] + txt s = [fromString s] + p e = untxt [Text.pack (show $ pretty e)] + + +instance FixmeRenderTemplate SimpleTemplate Text where + render (SimpleTemplate syn) = Right $ Text.concat $ + flip fix (mempty,syn) $ \next -> \case + (acc, NL : rest) -> next (acc <> nl, rest) + (acc, ListVal [StringLike w] : rest) -> next (acc <> txt w, rest) + (acc, StringLike w : rest) -> next (acc <> txt w, rest) + (acc, ListVal [SymbolVal "trim", LitIntVal n, e] : rest) -> next (acc <> trim n (deep [e]), rest) + (acc, ListVal [SymbolVal "align", LitIntVal n, e] : rest) -> next (acc <> align n (deep [e]), rest) + (acc, ListVal es : rest) -> next (acc <> deep es, rest) + (acc, e : rest) -> next (acc <> p e, rest) + (acc, []) -> acc + + where + + align n0 s0 | n > 0 = [Text.justifyLeft n ' ' s] + | otherwise = [Text.justifyRight (abs n) ' ' s] + + where + n = fromIntegral n0 + s = mconcat s0 + + trim n0 s0 | n >= 0 = [ Text.take n s ] + | otherwise = [ Text.takeEnd (abs n) s ] + where + n = fromIntegral n0 + s = mconcat s0 + + deep :: forall c . (ContextShit c) => [Syntax c] -> [Text] + deep sy = either mempty List.singleton (render (SimpleTemplate sy)) + + nl = [ "\n" ] + txt s = [fromString s] + p e = [Text.pack (show $ pretty e)] + + +newtype ViaSerialise a = ViaSerialise a + +instance Serialise a => Hashed HbSync (ViaSerialise a) where + hashObject (ViaSerialise x) = hashObject (serialise x) + + +fixmeTitleNonEmpty :: FixmeTitle -> FixmeTitle -> FixmeTitle +fixmeTitleNonEmpty a b = case (coerce a :: Text, coerce b :: Text) of + (x,y) | Text.null x && not (Text.null y) -> FixmeTitle y + (x,y) | not (Text.null x) && Text.null y -> FixmeTitle x + (_,y) -> FixmeTitle y + +fixmeAttrNonEmpty :: Coercible a Text => a -> a -> a +fixmeAttrNonEmpty a b = case (coerce a :: Text, coerce b :: Text) of + (x,y) | Text.null x && not (Text.null y) -> b + (x,y) | not (Text.null x) && Text.null y -> a + (_,_) -> b + +fixmeDerivedFields :: Fixme -> Fixme +fixmeDerivedFields fx = fx <> fxCo <> tag <> fxLno <> fxMisc + where + email = HM.lookup "commiter-email" (fixmeAttr fx) + & maybe mempty (\x -> " <" <> x <> ">") + + comitter = HM.lookup "commiter-name" (fixmeAttr fx) + <&> (<> email) + + tag = mempty { fixmeAttr = HM.singleton "fixme-tag" (FixmeAttrVal (coerce $ fixmeTag fx)) } + + lno = succ <$> fixmeStart fx <&> FixmeAttrVal . fromString . show + + fxLno = mempty { fixmeAttr = maybe mempty (HM.singleton "line") lno } + + fxCo = + maybe mempty (\c -> mempty { fixmeAttr = HM.singleton "committer" c }) comitter + + fxMisc = + fx & over (field @"fixmeAttr") + (HM.insert "fixme-title" (FixmeAttrVal (coerce (fixmeTitle fx)))) + +mkFixmeFileName :: FilePath -> Fixme +mkFixmeFileName fp = + mempty { fixmeAttr = HM.singleton "file" (FixmeAttrVal (fromString fp)) } + + diff --git a/flake.lock b/flake.lock index 45da053e..b9145195 100644 --- a/flake.lock +++ b/flake.lock @@ -8,15 +8,16 @@ ] }, "locked": { - "lastModified": 1708680396, - "narHash": "sha256-ZPwDreNdnyCS/hNdaE0OqVhytm+SzZGRfGRTRvBuSzE=", - "ref": "refs/heads/master", - "rev": "221fde04a00a9c38d2f6c0d05b1e1c3457d5a827", - "revCount": 7, + "lastModified": 1713359411, + "narHash": "sha256-BzOZ6xU+Li5nIe71Wy4p+lOEQlYK/e94T0gBcP8IKgE=", + "ref": "generic-sql", + "rev": "03635c54b2e2bd809ec1196bc9082447279f6f24", + "revCount": 9, "type": "git", "url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft" }, "original": { + "ref": "generic-sql", "type": "git", "url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft" } @@ -133,6 +134,92 @@ "type": "github" } }, + "flake-utils_7": { + "locked": { + "lastModified": 1644229661, + "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "flake-utils_8": { + "locked": { + "lastModified": 1644229661, + "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "flake-utils_9": { + "locked": { + "lastModified": 1644229661, + "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "fuzzy": { + "inputs": { + "haskell-flake-utils": "haskell-flake-utils_4", + "nixpkgs": [ + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1711855026, + "narHash": "sha256-uO2dNqFiio46cuZURBC00k17uKGAtUgP7bZAYZ9HlOU=", + "ref": "refs/heads/master", + "rev": "a579201f0672f90eec7c42e65d6828978dddb816", + "revCount": 39, + "type": "git", + "url": "http://git.hbs2/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA" + }, + "original": { + "type": "git", + "url": "http://git.hbs2/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA" + } + }, + "fuzzy_2": { + "inputs": { + "haskell-flake-utils": "haskell-flake-utils_8", + "nixpkgs": "nixpkgs_2" + }, + "locked": { + "lastModified": 1715918584, + "narHash": "sha256-moioa3ixAZb0y/xxyxUVjSvXoSiDGXy/vAx6B70d2yM=", + "ref": "refs/heads/master", + "rev": "831879978213a1aed15ac70aa116c33bcbe964b8", + "revCount": 63, + "type": "git", + "url": "http://git.hbs2/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?tag=0.1.3.1" + }, + "original": { + "rev": "831879978213a1aed15ac70aa116c33bcbe964b8", + "type": "git", + "url": "http://git.hbs2/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA?tag=0.1.3.1" + } + }, "haskell-flake-utils": { "inputs": { "flake-utils": "flake-utils" @@ -191,6 +278,24 @@ "inputs": { "flake-utils": "flake-utils_4" }, + "locked": { + "lastModified": 1707809372, + "narHash": "sha256-wfTL9PlCSOqSSyU4eenFFI7pHrV21gba4GEILnI4nAU=", + "owner": "ivanovs-4", + "repo": "haskell-flake-utils", + "rev": "3cbdc5d6093e8b4464ae64097e0c8c61e4414ff2", + "type": "github" + }, + "original": { + "owner": "ivanovs-4", + "repo": "haskell-flake-utils", + "type": "github" + } + }, + "haskell-flake-utils_5": { + "inputs": { + "flake-utils": "flake-utils_5" + }, "locked": { "lastModified": 1698938553, "narHash": "sha256-oXpTKXioqFbl2mhhvpJIAvgNd+wYyv4ekI+YnJHEJ6s=", @@ -206,25 +311,6 @@ "type": "github" } }, - "haskell-flake-utils_5": { - "inputs": { - "flake-utils": "flake-utils_5" - }, - "locked": { - "lastModified": 1672412555, - "narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=", - "owner": "ivanovs-4", - "repo": "haskell-flake-utils", - "rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9", - "type": "github" - }, - "original": { - "owner": "ivanovs-4", - "repo": "haskell-flake-utils", - "rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9", - "type": "github" - } - }, "haskell-flake-utils_6": { "inputs": { "flake-utils": "flake-utils_6" @@ -237,6 +323,61 @@ "rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9", "type": "github" }, + "original": { + "owner": "ivanovs-4", + "repo": "haskell-flake-utils", + "rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9", + "type": "github" + } + }, + "haskell-flake-utils_7": { + "inputs": { + "flake-utils": "flake-utils_7" + }, + "locked": { + "lastModified": 1698938553, + "narHash": "sha256-oXpTKXioqFbl2mhhvpJIAvgNd+wYyv4ekI+YnJHEJ6s=", + "owner": "ivanovs-4", + "repo": "haskell-flake-utils", + "rev": "19b273b5dc401a0a565e7f75cf50a593871b80c9", + "type": "github" + }, + "original": { + "owner": "ivanovs-4", + "repo": "haskell-flake-utils", + "type": "github" + } + }, + "haskell-flake-utils_8": { + "inputs": { + "flake-utils": "flake-utils_8" + }, + "locked": { + "lastModified": 1707809372, + "narHash": "sha256-wfTL9PlCSOqSSyU4eenFFI7pHrV21gba4GEILnI4nAU=", + "owner": "ivanovs-4", + "repo": "haskell-flake-utils", + "rev": "3cbdc5d6093e8b4464ae64097e0c8c61e4414ff2", + "type": "github" + }, + "original": { + "owner": "ivanovs-4", + "repo": "haskell-flake-utils", + "type": "github" + } + }, + "haskell-flake-utils_9": { + "inputs": { + "flake-utils": "flake-utils_9" + }, + "locked": { + "lastModified": 1672412555, + "narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=", + "owner": "ivanovs-4", + "repo": "haskell-flake-utils", + "rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9", + "type": "github" + }, "original": { "owner": "ivanovs-4", "repo": "haskell-flake-utils", @@ -245,7 +386,7 @@ }, "hspup": { "inputs": { - "haskell-flake-utils": "haskell-flake-utils_5", + "haskell-flake-utils": "haskell-flake-utils_6", "nixpkgs": [ "nixpkgs" ] @@ -264,6 +405,27 @@ "type": "github" } }, + "lsm": { + "inputs": { + "haskell-flake-utils": "haskell-flake-utils_7", + "nixpkgs": [ + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1711033804, + "narHash": "sha256-z9cb5yuWfuZmGukxsZebXhc6KUZoPVT60oXxQ6j6ML8=", + "ref": "refs/heads/master", + "rev": "0e8286a43da5b9e54c4f3ecdb994173fe77351db", + "revCount": 26, + "type": "git", + "url": "https://git.hbs2.net/5BCaH95cWsVKBmWaDNLWQr2umxzzT5kqRRKNTm2J15Ls" + }, + "original": { + "type": "git", + "url": "https://git.hbs2.net/5BCaH95cWsVKBmWaDNLWQr2umxzzT5kqRRKNTm2J15Ls" + } + }, "nixpkgs": { "locked": { "lastModified": 1707451808, @@ -280,12 +442,30 @@ "type": "github" } }, + "nixpkgs_2": { + "locked": { + "lastModified": 1707451808, + "narHash": "sha256-UwDBUNHNRsYKFJzyTMVMTF5qS4xeJlWoeyJf+6vvamU=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "442d407992384ed9c0e6d352de75b69079904e4e", + "type": "github" + }, + "original": { + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "442d407992384ed9c0e6d352de75b69079904e4e", + "type": "github" + } + }, "root": { "inputs": { "db-pipe": "db-pipe", "fixme": "fixme", - "haskell-flake-utils": "haskell-flake-utils_4", + "fuzzy": "fuzzy", + "haskell-flake-utils": "haskell-flake-utils_5", "hspup": "hspup", + "lsm": "lsm", "nixpkgs": "nixpkgs", "saltine": "saltine", "suckless-conf": "suckless-conf_2" @@ -332,23 +512,25 @@ }, "suckless-conf_2": { "inputs": { - "haskell-flake-utils": "haskell-flake-utils_6", + "fuzzy": "fuzzy_2", + "haskell-flake-utils": "haskell-flake-utils_9", "nixpkgs": [ "nixpkgs" ] }, "locked": { - "lastModified": 1704001322, - "narHash": "sha256-D7T/8wAg5J4KkRw0uB90w3+adY11aQaX7rjmQPXkkQc=", + "lastModified": 1715919707, + "narHash": "sha256-lbvrCqJHC//NJgfvsy15+Evup5CS+CE50NolDwPIh94=", "ref": "refs/heads/master", - "rev": "8cfc1272bb79ef6ad62ae6a625f21e239916d196", - "revCount": 28, + "rev": "41830ea2f2e9bb589976f0433207a8f1b73b0b01", + "revCount": 35, "type": "git", - "url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ" + "url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ?tag=0.1.2.6" }, "original": { + "rev": "41830ea2f2e9bb589976f0433207a8f1b73b0b01", "type": "git", - "url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ" + "url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ?tag=0.1.2.6" } } }, diff --git a/flake.nix b/flake.nix index 8373d009..98609cc2 100644 --- a/flake.nix +++ b/flake.nix @@ -10,14 +10,23 @@ inputs = { hspup.inputs.nixpkgs.follows = "nixpkgs"; fixme.url = "git+https://git.hbs2.net/Fujv1Uy4W5d9Z7REEArMxbXSJ8nLLn4dYuvaAs8b86hr"; + #fixme.url = "git+file:///home/dmz/w/fixme?ref=dev-0.2"; fixme.inputs.nixpkgs.follows = "nixpkgs"; - suckless-conf.url = "git+https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ"; + suckless-conf.url = + "git+https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ?rev=41830ea2f2e9bb589976f0433207a8f1b73b0b01&tag=0.1.2.6"; + suckless-conf.inputs.nixpkgs.follows = "nixpkgs"; - db-pipe.url = "git+https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"; + db-pipe.url = "git+https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft?ref=generic-sql"; db-pipe.inputs.nixpkgs.follows = "nixpkgs"; + lsm.url = "git+https://git.hbs2.net/5BCaH95cWsVKBmWaDNLWQr2umxzzT5kqRRKNTm2J15Ls"; + lsm.inputs.nixpkgs.follows = "nixpkgs"; + + fuzzy.url = "git+http://git.hbs2/GmcLB9gEPT4tbx9eyQiECwsu8oPyEh6qKEpQDtyBWVPA"; + fuzzy.inputs.nixpkgs.follows = "nixpkgs"; + saltine = { url = "github:tel/saltine/3d3a54cf46f78b71b4b55653482fb6f4cee6b77d"; flake = false; @@ -35,8 +44,10 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs: "hbs2-git" "hbs2-qblf" "hbs2-keyman" - "hbs2-share" "hbs2-fixer" + "hbs2-cli" + "hbs2-sync" + "fixme-new" ]; in haskell-flake-utils.lib.simpleCabalProject2flake { @@ -58,13 +69,16 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs: "hbs2-storage-simple" = "./hbs2-storage-simple"; "hbs2-peer" = "./hbs2-peer"; "hbs2-keyman" = "./hbs2-keyman"; - "hbs2-share" = "./hbs2-share"; "hbs2-git" = "./hbs2-git"; "hbs2-fixer" = "./hbs2-fixer"; + "hbs2-cli" = "./hbs2-cli"; + "hbs2-sync" = "./hbs2-sync"; + "fixme-new" = "./fixme-new"; }; hpPreOverrides = {pkgs, ...}: final: prev: with pkgs; { saltine = prev.callCabal2nix "saltine" inputs.saltine { inherit (pkgs) libsodium; }; + scotty = final.callHackage "scotty" "0.21" { }; }; packagePostOverrides = { pkgs }: with pkgs; with haskell.lib; [ diff --git a/hbs2-cli/LICENSE b/hbs2-cli/LICENSE new file mode 100644 index 00000000..be7e6285 --- /dev/null +++ b/hbs2-cli/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2024, Dmitry Zuikov + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Dmitry Zuikov nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/hbs2-cli/app/Main.hs b/hbs2-cli/app/Main.hs new file mode 100644 index 00000000..e2fe2f6e --- /dev/null +++ b/hbs2-cli/app/Main.hs @@ -0,0 +1,97 @@ +{-# Language AllowAmbiguousTypes #-} +{-# Language UndecidableInstances #-} +module Main where + +import HBS2.CLI.Prelude +import HBS2.CLI.Run +import HBS2.CLI.Run.Help +import HBS2.CLI.Run.KeyMan +import HBS2.CLI.Run.Keyring +import HBS2.CLI.Run.GroupKey +import HBS2.CLI.Run.Sigil +import HBS2.CLI.Run.MetaData +import HBS2.CLI.Run.Peer +import HBS2.CLI.Run.RefLog +import HBS2.CLI.Run.RefChan +import HBS2.CLI.Run.LWWRef + +import Data.Config.Suckless.Script.File as SF + +import HBS2.Peer.RPC.Client.Unix + +import HBS2.Net.Auth.Schema() + +import System.Environment + +type RefLogId = PubKey 'Sign 'HBS2Basic + +{- HLINT ignore "Functor law" -} + + +setupLogger :: MonadIO m => m () +setupLogger = do + -- setLogging @DEBUG $ toStderr . logPrefix "[debug] " + setLogging @ERROR $ toStderr . logPrefix "[error] " + setLogging @WARN $ toStderr . logPrefix "[warn] " + setLogging @NOTICE $ toStdout . logPrefix "" + pure () + +flushLoggers :: MonadIO m => m () +flushLoggers = do + silence + +silence :: MonadIO m => m () +silence = do + setLoggingOff @DEBUG + setLoggingOff @ERROR + setLoggingOff @WARN + setLoggingOff @NOTICE + + +main :: IO () +main = do + + setupLogger + + cli <- getArgs <&> unlines . fmap unwords . splitForms + >>= either (error.show) pure . parseTop + + let dict = makeDict do + + internalEntries + keymanEntries + keyringEntries + groupKeyEntries + sigilEntries + metaDataEntries + peerEntries + reflogEntries + refchanEntries + lwwRefEntries + helpEntries + + SF.entries + + entry $ bindMatch "--help" $ nil_ \case + HelpEntryBound what -> helpEntry what + [StringLike s] -> helpList False (Just s) + _ -> helpList False Nothing + + entry $ bindMatch "debug:cli:show" $ nil_ \case + _ -> display cli + + runHBS2Cli do + + case cli of + [ListVal [SymbolVal "stdin"]] -> do + what <- liftIO getContents + >>= either (error.show) pure . parseTop + + recover $ run dict what >>= eatNil display + + [] -> do + void $ run dict [mkForm "help" []] + + _ -> do + recover $ run dict cli >>= eatNil display + diff --git a/hbs2-cli/hbs2-cli.cabal b/hbs2-cli/hbs2-cli.cabal new file mode 100644 index 00000000..a2767111 --- /dev/null +++ b/hbs2-cli/hbs2-cli.cabal @@ -0,0 +1,143 @@ +cabal-version: 3.0 +name: hbs2-cli +version: 0.24.1.2 +-- synopsis: +-- description: +license: BSD-3-Clause +license-file: LICENSE +author: Dmitry Zuikov +-- copyright: +category: System +build-type: Simple +-- extra-doc-files: CHANGELOG.md +-- extra-source-files: + +common shared-properties + ghc-options: + -Wall + -fno-warn-type-defaults + -threaded + -rtsopts + -O2 + "-with-rtsopts=-N4 -A64m -AL256m -I0" + + default-language: GHC2021 + + default-extensions: + ApplicativeDo + , BangPatterns + , BlockArguments + , ConstraintKinds + , DataKinds + , DeriveDataTypeable + , DeriveGeneric + , DerivingStrategies + , DerivingVia + , ExtendedDefaultRules + , FlexibleContexts + , FlexibleInstances + , GADTs + , GeneralizedNewtypeDeriving + , ImportQualifiedPost + , LambdaCase + , MultiParamTypeClasses + , OverloadedStrings + , QuasiQuotes + , RecordWildCards + , ScopedTypeVariables + , StandaloneDeriving + , TupleSections + , TypeApplications + , TypeFamilies + , PatternSynonyms + , ViewPatterns + + + build-depends: + hbs2-core + , hbs2-peer + , hbs2-storage-simple + , hbs2-keyman + , db-pipe + , suckless-conf + + , attoparsec + , atomic-write + , bytestring + , binary + , containers + , directory + , exceptions + , filepath + , filepattern + , hashable + , interpolatedstring-perl6 + , memory + , microlens-platform + , mtl + , safe + , serialise + , streaming + , stm + , text + , time + , timeit + , transformers + , typed-process + , unordered-containers + , unliftio + , unliftio-core + , zlib + , prettyprinter + , prettyprinter-ansi-terminal + , random + , vector + , unix + , split + + +library + import: shared-properties + + exposed-modules: + HBS2.CLI + HBS2.CLI.Prelude + HBS2.CLI.Bind + HBS2.CLI.Run + HBS2.CLI.Run.Internal + HBS2.CLI.Run.Internal.GroupKey + HBS2.CLI.Run.Internal.Merkle + HBS2.CLI.Run.Internal.KeyMan + HBS2.CLI.Run.GroupKey + HBS2.CLI.Run.KeyMan + HBS2.CLI.Run.Keyring + HBS2.CLI.Run.MetaData + HBS2.CLI.Run.Peer + HBS2.CLI.Run.RefLog + HBS2.CLI.Run.RefChan + HBS2.CLI.Run.LWWRef + HBS2.CLI.Run.Sigil + + HBS2.CLI.Run.Help + + Data.Config.Suckless.Script + Data.Config.Suckless.Script.Internal + Data.Config.Suckless.Script.File + + build-depends: base + , magic + + hs-source-dirs: lib + + +executable hbs2-cli + import: shared-properties + main-is: Main.hs + -- other-modules: + -- other-extensions: + build-depends: + base, hbs2-cli + + hs-source-dirs: app + default-language: GHC2021 + diff --git a/hbs2-cli/lib/Data/Config/Suckless/Script.hs b/hbs2-cli/lib/Data/Config/Suckless/Script.hs new file mode 100644 index 00000000..735398f9 --- /dev/null +++ b/hbs2-cli/lib/Data/Config/Suckless/Script.hs @@ -0,0 +1,48 @@ +{-# Language UndecidableInstances #-} +module Data.Config.Suckless.Script + ( module Exported + , module Data.Config.Suckless.Script + ) where + +import Data.Config.Suckless as Exported +import Data.Config.Suckless.Script.Internal as Exported + +import Control.Monad.Reader +import Data.HashMap.Strict qualified as HM +import Prettyprinter +import Prettyprinter.Render.Terminal +import Data.List qualified as List +import Data.Text qualified as Text +import UnliftIO + + +{- HLINT ignore "Functor law" -} + +helpList :: MonadUnliftIO m => Bool -> Maybe String -> RunM c m () +helpList hasDoc p = do + + let match = maybe (const True) (Text.isPrefixOf . Text.pack) p + + d <- ask >>= readTVarIO + let ks = [k | Id k <- List.sort (HM.keys d) + , match k + , not hasDoc || docDefined (HM.lookup (Id k) d) + ] + + display_ $ vcat (fmap pretty ks) + + where + docDefined (Just (Bind (Just w) _)) = True + docDefined _ = False + +helpEntry :: MonadUnliftIO m => Id -> RunM c m () +helpEntry what = do + man <- ask >>= readTVarIO + <&> HM.lookup what + <&> maybe mzero bindMan + + liftIO $ hPutDoc stdout (pretty man) + +pattern HelpEntryBound :: forall {c}. Id -> [Syntax c] +pattern HelpEntryBound what <- [ListVal (SymbolVal "builtin:lambda" : SymbolVal what : _ )] + diff --git a/hbs2-cli/lib/Data/Config/Suckless/Script/File.hs b/hbs2-cli/lib/Data/Config/Suckless/Script/File.hs new file mode 100644 index 00000000..893243bd --- /dev/null +++ b/hbs2-cli/lib/Data/Config/Suckless/Script/File.hs @@ -0,0 +1,84 @@ +{-# Language MultiWayIf #-} +module Data.Config.Suckless.Script.File where + +import Data.Config.Suckless +import Data.Config.Suckless.Script.Internal + +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Cont +import Data.Maybe +import Data.Either +import Data.Foldable +import System.Directory +import System.FilePath +import System.FilePattern +import Data.HashSet qualified as HS + +import Lens.Micro.Platform +import UnliftIO +import Control.Concurrent.STM qualified as STM +import Streaming.Prelude qualified as S + +glob :: forall m . MonadIO m + => [FilePattern] -- ^ search patterns + -> [FilePattern] -- ^ ignore patterns + -> FilePath -- ^ directory + -> (FilePath -> m Bool) -- ^ file action + -> m () + +glob pat ignore dir action = do + q <- newTQueueIO + void $ liftIO (async $ go q dir >> atomically (writeTQueue q Nothing)) + fix $ \next -> do + atomically (readTQueue q) >>= \case + Nothing -> pure () + Just x -> do + r <- action x + when r next + + where + + matches p f = or [ i ?== f | i <- p ] + skip p = or [ i ?== p | i <- ignore ] + + go q f = do + + isD <- doesDirectoryExist f + + if not isD then do + isF <- doesFileExist f + when (isF && matches pat f && not (skip f)) do + atomically $ writeTQueue q (Just f) + else do + co' <- (try @_ @IOError $ listDirectory f) + <&> fromRight mempty + + forConcurrently_ co' $ \x -> do + let p = normalise (f x) + unless (skip p) (go q p) + +entries :: forall c m . ( IsContext c + , Exception (BadFormException c) + , MonadUnliftIO m) + => MakeDictM c m () +entries = do + entry $ bindMatch "glob" $ \syn -> do + + (p,i,d) <- case syn of + [] -> pure (["*"], [], ".") + + [StringLike d, StringLike i, StringLike e] -> do + pure ([i], [e], d) + + [StringLike d, ListVal (StringLikeList i), ListVal (StringLikeList e)] -> do + pure (i, e, d) + + _ -> throwIO (BadFormException @c nil) + + r <- S.toList_ $ glob p i d $ \fn -> do + S.yield (mkStr @c fn) -- do + pure True + + pure (mkList r) + diff --git a/hbs2-cli/lib/Data/Config/Suckless/Script/Internal.hs b/hbs2-cli/lib/Data/Config/Suckless/Script/Internal.hs new file mode 100644 index 00000000..2a682a79 --- /dev/null +++ b/hbs2-cli/lib/Data/Config/Suckless/Script/Internal.hs @@ -0,0 +1,975 @@ +{-# Language AllowAmbiguousTypes #-} +{-# Language UndecidableInstances #-} +module Data.Config.Suckless.Script.Internal + ( module Data.Config.Suckless.Script.Internal + , module Export + ) where + +import Data.Config.Suckless + +import Control.Applicative +import Control.Monad.Identity +import Control.Monad.Reader +import Control.Monad.Writer +import Data.ByteString (ByteString) +import Data.ByteString.Char8 qualified as BS8 +import Data.Data +import Data.Function as Export +import Data.Functor as Export +import Data.Hashable +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HM +import Data.Kind +import Data.List (isPrefixOf) +import Data.List qualified as List +import Data.Maybe +import Data.String +import Data.Text.IO qualified as TIO +import Data.Text qualified as Text +import Data.Text (Text) +import Data.Time.Clock.POSIX +import GHC.Generics hiding (C) +import Prettyprinter +import Prettyprinter.Render.Terminal +import Safe +import Streaming.Prelude qualified as S +import System.Environment +import Text.InterpolatedString.Perl6 (qc) +import UnliftIO + +-- TODO: move-to-suckless-conf + +data ManApplyArg = ManApplyArg Text Text + deriving stock (Eq,Show,Data,Generic) + +newtype ManApply = ManApply [ ManApplyArg ] + deriving stock (Eq,Show,Data,Generic) + deriving newtype (Semigroup,Monoid) + +data ManSynopsis = + ManSynopsis ManApply + deriving stock (Eq,Show,Data,Generic) + +data ManDesc = ManDescRaw Text + deriving stock (Eq,Show,Data,Generic) + +data ManRetVal = ManRetVal + deriving stock (Eq,Show,Data,Generic) + +newtype ManName a = ManName Id + deriving stock (Eq,Show,Data,Generic) + deriving newtype (IsString,Pretty) + +newtype ManBrief = ManBrief Text + deriving stock (Eq,Show,Data,Generic) + deriving newtype (Pretty,IsString) + +data ManReturns = ManReturns Text Text + deriving stock (Eq,Show,Data,Generic) + +newtype ManExamples = + ManExamples Text + deriving stock (Eq,Show,Data,Generic) + deriving newtype (Pretty,IsString,Monoid,Semigroup) + +class ManNameOf a ann where + manNameOf :: a -> ManName ann + +data Man a = + Man + { manName :: Maybe (ManName a) + , manHidden :: Bool + , manBrief :: Maybe ManBrief + , manSynopsis :: [ManSynopsis] + , manDesc :: Maybe ManDesc + , manReturns :: Maybe ManReturns + , manExamples :: [ManExamples] + } + deriving stock (Eq,Show,Generic) + +instance Monoid (Man a) where + mempty = Man Nothing False Nothing mempty Nothing Nothing mempty + +instance Semigroup (Man a) where + (<>) a b = Man (manName b <|> manName a) + (manHidden b || manHidden a) + (manBrief b <|> manBrief a) + (manSynopsis a <> manSynopsis b) + (manDesc b <|> manDesc a) + (manReturns b <|> manReturns a) + (manExamples a <> manExamples b) + +instance ManNameOf Id a where + manNameOf = ManName + + +instance Pretty ManDesc where + pretty = \case + ManDescRaw t -> pretty t + +instance IsString ManDesc where + fromString s = ManDescRaw (Text.pack s) + +instance Pretty (Man a) where + pretty e = "NAME" + <> line + <> indent 8 (pretty (manName e) <> fmtBrief e) + <> line + <> fmtSynopsis + <> fmtDescription + <> retval + <> fmtExamples + where + fmtBrief a = case manBrief a of + Nothing -> mempty + Just x -> " - " <> pretty x + + retval = case manReturns e of + Nothing -> mempty + Just (ManReturns t s) -> + line <> "RETURN VALUE" <> line + <> indent 8 ( + if not (Text.null s) then + (pretty t <> hsep ["","-",""] <> pretty s) <> line + else pretty t ) + + fmtDescription = line + <> "DESCRIPTION" <> line + <> indent 8 ( case manDesc e of + Nothing -> pretty (manBrief e) + Just x -> pretty x) + <> line + + fmtSynopsis = case manSynopsis e of + [] -> mempty + _ -> + line + <> "SYNOPSIS" + <> line + <> vcat (fmap synEntry (manSynopsis e)) + <> line + + fmtExamples = case manExamples e of + [] -> mempty + es -> line + <> "EXAMPLES" + <> line + <> indent 8 ( vcat (fmap pretty es) ) + + synEntry (ManSynopsis (ManApply [])) = + indent 8 ( parens (pretty (manName e)) ) <> line + + synEntry (ManSynopsis (ManApply xs)) = do + indent 8 do + parens (pretty (manName e) <+> + hsep [ pretty n | ManApplyArg t n <- xs ] ) + <> line + <> line + <> vcat [ pretty n <+> ":" <+> pretty t | ManApplyArg t n <- xs ] + +pattern StringLike :: forall {c} . String -> Syntax c +pattern StringLike e <- (stringLike -> Just e) + +pattern StringLikeList :: forall {c} . [String] -> [Syntax c] +pattern StringLikeList e <- (stringLikeList -> e) + +pattern BlobLike :: forall {c} . ByteString -> Syntax c +pattern BlobLike s <- (blobLike -> Just s) + +pattern Nil :: forall {c} . Syntax c +pattern Nil <- ListVal [] + + + +class Display a where + display :: MonadIO m => a -> m () + +instance {-# OVERLAPPABLE #-} Pretty w => Display w where + display = liftIO . print . pretty + +instance IsContext c => Display (Syntax c) where + display = \case + LitStrVal s -> liftIO $ TIO.putStr s + -- ListVal [SymbolVal "small-encrypted-block", LitStrVal txt] -> do + -- let s = Text.unpack txt & BS8.pack & toBase58 & AsBase58 & pretty + -- liftIO $ print $ parens $ "small-encrypted-block" <+> parens ("blob" <+> dquotes s) + -- ListVal [SymbolVal "blob", LitStrVal txt] -> do + -- let s = Text.unpack txt & BS8.pack & toBase58 & AsBase58 & pretty + -- liftIO $ print $ parens $ "blob:base58" <+> dquotes s + x -> liftIO $ putStr (show $ pretty x) + +instance Display Text where + display = liftIO . TIO.putStr + +instance Display String where + display = liftIO . putStr + +display_ :: (MonadIO m, Show a) => a -> m () +display_ = liftIO . print + +{- HLINT ignore "Functor law" -} + +class IsContext c => MkSym c a where + mkSym :: a -> Syntax c + +instance IsContext c => MkSym c String where + mkSym s = Symbol noContext (Id $ Text.pack s) + +instance IsContext c => MkSym c Text where + mkSym s = Symbol noContext (Id s) + +instance IsContext c => MkSym c Id where + mkSym = Symbol noContext + +class IsContext c => MkStr c s where + mkStr :: s -> Syntax c + +instance IsContext c => MkStr c String where + mkStr s = Literal noContext $ LitStr (Text.pack s) + +instance IsContext c => MkStr c Text where + mkStr s = Literal noContext $ LitStr s + +mkBool :: forall c . IsContext c => Bool -> Syntax c +mkBool v = Literal noContext (LitBool v) + + +class IsContext c => MkForm c a where + mkForm :: a-> [Syntax c] -> Syntax c + +instance (IsContext c, MkSym c s) => MkForm c s where + mkForm s sy = List noContext ( mkSym @c s : sy ) + +mkList :: forall c. IsContext c => [Syntax c] -> Syntax c +mkList = List noContext + +isFalse :: forall c . IsContext c => Syntax c -> Bool +isFalse = \case + Literal _ (LitBool False) -> True + ListVal [] -> True + _ -> False + +eatNil :: Monad m => (Syntax c -> m a) -> Syntax c -> m () +eatNil f = \case + Nil -> pure () + x -> void $ f x + +class IsContext c => MkInt c s where + mkInt :: s -> Syntax c + +instance (Integral i, IsContext c) => MkInt c i where + mkInt n = Literal noContext $ LitInt (fromIntegral n) + +class OptionalVal c b where + optional :: b -> Syntax c -> b + +instance IsContext c => OptionalVal c Int where + optional d = \case + LitIntVal x -> fromIntegral x + _ -> d + +hasKey :: IsContext c => Id -> [Syntax c] -> Maybe (Syntax c) +hasKey k ss = headMay [ e | ListVal [SymbolVal z, e] <- ss, z == k] + +stringLike :: Syntax c -> Maybe String +stringLike = \case + LitStrVal s -> Just $ Text.unpack s + SymbolVal (Id s) -> Just $ Text.unpack s + _ -> Nothing + +stringLikeList :: [Syntax c] -> [String] +stringLikeList syn = [ stringLike s | s <- syn ] & takeWhile isJust & catMaybes + +pattern Lambda :: forall {c}. [Id] -> Syntax c -> Syntax c +pattern Lambda a e <- ListVal [SymbolVal "lambda", LambdaArgs a, e] + +pattern LambdaArgs :: [Id] -> Syntax c +pattern LambdaArgs a <- (lambdaArgList -> Just a) + + +lambdaArgList :: Syntax c -> Maybe [Id] + +lambdaArgList (ListVal a) = sequence argz + where + argz = flip fmap a \case + (SymbolVal x) -> Just x + _ -> Nothing + +lambdaArgList _ = Nothing + +blobLike :: Syntax c -> Maybe ByteString +blobLike = \case + LitStrVal s -> Just $ BS8.pack (Text.unpack s) + ListVal [SymbolVal "blob", LitStrVal s] -> Just $ BS8.pack (Text.unpack s) + _ -> Nothing + +pattern PairList :: [Syntax c] -> [Syntax c] +pattern PairList es <- (pairList -> es) + +pairList :: [Syntax c ] -> [Syntax c] +pairList syn = [ isPair s | s <- syn ] & takeWhile isJust & catMaybes + +optlist :: IsContext c => [Syntax c] -> [(Id, Syntax c)] +optlist = reverse . go [] + where + go acc ( SymbolVal i : b : rest ) = go ((i, b) : acc) rest + go acc [ SymbolVal i ] = (i, nil) : acc + go acc _ = acc + + +isPair :: Syntax c -> Maybe (Syntax c) +isPair = \case + e@(ListVal [_,_]) -> Just e + _ -> Nothing + +data BindAction c ( m :: Type -> Type) = + BindLambda { fromLambda :: [Syntax c] -> RunM c m (Syntax c) } + | BindValue (Syntax c) + +data Bind c ( m :: Type -> Type) = Bind + { bindMan :: Maybe (Man AnsiStyle) + , bindAction :: BindAction c m + } deriving (Generic) + +deriving newtype instance Hashable Id + +newtype NameNotBoundException = + NameNotBound Id + deriving stock Show + deriving newtype (Generic,Typeable) + +newtype NotLambda = NotLambda Id + deriving stock Show + deriving newtype (Generic,Typeable) + +instance Exception NotLambda + +data BadFormException c = BadFormException (Syntax c) + | ArityMismatch (Syntax c) + +newtype TypeCheckError c = TypeCheckError (Syntax c) + +instance Exception (TypeCheckError C) + +newtype BadValueException = BadValueException String + deriving stock Show + deriving newtype (Generic,Typeable) + +instance Exception NameNotBoundException + +instance IsContext c => Show (BadFormException c) where + show (BadFormException sy) = show $ "BadFormException" <+> pretty sy + show (ArityMismatch sy) = show $ "ArityMismatch" <+> pretty sy + +instance IsContext c => Show (TypeCheckError c) where + show (TypeCheckError sy) = show $ "TypeCheckError" <+> pretty sy + +instance Exception (BadFormException C) + +instance Exception BadValueException + +type Dict c m = HashMap Id (Bind c m) + +newtype RunM c m a = RunM { fromRunM :: ReaderT (TVar (Dict c m)) m a } + deriving newtype ( Applicative + , Functor + , Monad + , MonadIO + , MonadUnliftIO + , MonadReader (TVar (Dict c m)) + ) + +instance MonadTrans (RunM c) where + lift = RunM . lift + +newtype MakeDictM c m a = MakeDictM { fromMakeDict :: Writer (Dict c m) a } + deriving newtype ( Applicative + , Functor + , Monad + , MonadWriter (Dict c m) + ) + +makeDict :: (IsContext c, Monad m) => MakeDictM c m () -> Dict c m +makeDict w = execWriter ( fromMakeDict w ) + +entry :: Dict c m -> MakeDictM c m () +entry = tell + +hide :: MakeDictM c m () +hide = pure () + +desc :: Doc ann -> MakeDictM c m () -> MakeDictM c m () +desc txt = censor (HM.map setDesc) + where + w0 = mempty { manDesc = Just (ManDescRaw $ Text.pack $ show txt) } + setDesc (Bind w x) = Bind (Just (maybe w0 (<> w0) w)) x + +brief :: ManBrief -> MakeDictM c m () -> MakeDictM c m () +brief txt = censor (HM.map setBrief) + where + w0 = mempty { manBrief = Just txt } + setBrief (Bind w x) = Bind (Just (maybe w0 (<> w0) w)) x + +returns :: Text -> Text -> MakeDictM c m () -> MakeDictM c m () +returns tp txt = censor (HM.map setReturns) + where + w0 = mempty { manReturns = Just (ManReturns tp txt) } + setReturns (Bind w x) = Bind (Just (maybe w0 (<>w0) w)) x + + +addSynopsis :: ManSynopsis -> Bind c m -> Bind c m +addSynopsis synopsis (Bind w x) = Bind (Just updatedMan) x + where + updatedMan = case w of + Nothing -> mempty { manSynopsis = [synopsis] } + Just man -> man { manSynopsis = manSynopsis man <> [synopsis] } + +noArgs :: MakeDictM c m () -> MakeDictM c m () +noArgs = censor (HM.map (addSynopsis (ManSynopsis (ManApply [])))) + +arg :: Text -> Text -> ManApplyArg +arg = ManApplyArg + + +args :: [ManApplyArg] -> MakeDictM c m () -> MakeDictM c m () +args argList = censor (HM.map (addSynopsis (ManSynopsis (ManApply argList)))) + +opt :: Doc a -> Doc a -> Doc a +opt n d = n <+> "-" <+> d + +examples :: ManExamples -> MakeDictM c m () -> MakeDictM c m () +examples (ManExamples s) = censor (HM.map setExamples ) + where + ex = ManExamples (Text.unlines $ Text.strip <$> Text.lines (Text.strip s)) + ex0 = mempty { manExamples = [ex] } + setExamples (Bind w x) = Bind (Just (maybe ex0 (<>ex0) w)) x + +splitForms :: [String] -> [[String]] +splitForms s0 = runIdentity $ S.toList_ (go mempty s0) + where + go acc ( "then" : rest ) = emit acc >> go mempty rest + go acc ( "and" : rest ) = emit acc >> go mempty rest + go acc ( x : rest ) | isPrefixOf "-" x = go ( x : acc ) rest + go acc ( x : rest ) | isPrefixOf "--" x = go ( x : acc ) rest + go acc ( x : rest ) = go ( x : acc ) rest + go acc [] = emit acc + + emit = S.yield . reverse + +applyLambda :: forall c m . ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c) + ) + => [Id] + -> Syntax c + -> [Syntax c] + -> RunM c m (Syntax c) +applyLambda decl body args = do + + when (length decl /= length args) do + throwIO (ArityMismatch @c nil) + + ev <- mapM eval args + tv <- ask + d0 <- readTVarIO tv + + forM_ (zip decl ev) $ \(n,v) -> do + bind n v + + e <- eval body + + atomically $ writeTVar tv d0 + pure e + +apply_ :: forall c m . ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c) + ) + => Syntax c + -> [Syntax c] + -> RunM c m (Syntax c) + +apply_ s args = case s of + ListVal [SymbolVal "builtin:lambda", SymbolVal n] -> apply n args + SymbolVal what -> apply what args + Lambda d body -> applyLambda d body args + e -> throwIO $ BadFormException @c s + +apply :: forall c m . ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c) + ) + => Id + -> [Syntax c] + -> RunM c m (Syntax c) +apply name args' = do + -- notice $ red "APPLY" <+> pretty name + what <- ask >>= readTVarIO <&> HM.lookup name + + case bindAction <$> what of + Just (BindLambda e) -> mapM eval args' >>= e + + Just (BindValue (Lambda argz body) ) -> do + applyLambda argz body args' + + Just (BindValue _) -> do + throwIO (NotLambda name) + + Nothing -> throwIO (NameNotBound name) + +bind :: forall c m . ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c) + ) + => Id + -> Syntax c + -> RunM c m () +bind name expr = do + t <- ask + + what <- case expr of + ListVal [SymbolVal "builtin:lambda", SymbolVal n] -> do + m <- readTVarIO t + HM.lookup n m & maybe (throwIO (NameNotBound n)) pure + + e -> pure $ Bind mzero (BindValue e) + + atomically do + modifyTVar t (HM.insert name what) + +bindBuiltins :: forall c m . ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c) + ) + => Dict c m + -> RunM c m () + +bindBuiltins dict = do + t <- ask + atomically do + modifyTVar t (<> dict) + +eval :: forall c m . ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c) + ) => Syntax c -> RunM c m (Syntax c) +eval syn = handle (handleForm syn) $ do + + dict <- ask >>= readTVarIO + + case syn of + + ListVal [ w, SymbolVal ".", b] -> do + pure $ mkList [w, b] + + ListVal [ SymbolVal "quot", ListVal b] -> do + pure $ mkList b + + ListVal [SymbolVal "define", SymbolVal what, e] -> do + ev <- eval e + bind what ev>> pure nil + + ListVal [SymbolVal "lambda", arglist, body] -> do + pure $ mkForm @c "lambda" [ arglist, body ] + + ListVal [SymbolVal "define", LambdaArgs (name : args), e] -> do + bind name ( mkForm @c "lambda" [ mkList [ mkSym s | s <- args], e ] ) + pure nil + + ListVal [SymbolVal "false?", e'] -> do + e <- eval e' + pure $ if isFalse e then mkBool True else mkBool False + + ListVal [SymbolVal "if", w, e1, e2] -> do + what <- eval w + if isFalse what then eval e2 else eval e1 + + ListVal (SymbolVal "begin" : what) -> do + evalTop what + + e@(ListVal (SymbolVal "blob" : what)) -> do + pure e + -- evalTop what + + lc@(ListVal (Lambda decl body : args)) -> do + applyLambda decl body args + + ListVal (SymbolVal name : args') -> do + apply name args' + + SymbolVal (Id s) | Text.isPrefixOf ":" s -> do + pure (mkSym @c (Text.drop 1 s)) + + SymbolVal name | HM.member name dict -> do + let what = HM.lookup name dict + & maybe (BindValue (mkSym name)) bindAction + + case what of + BindValue e -> pure e + BindLambda e -> pure $ mkForm "builtin:lambda" [mkSym name] + + e@(SymbolVal name) | not (HM.member name dict) -> do + pure e + + e@Literal{} -> pure e + + e -> throwIO $ BadFormException @c e + + where + handleForm syn = \case + (BadFormException _ :: BadFormException c) -> do + throwIO (BadFormException syn) + (ArityMismatch s :: BadFormException c) -> do + throwIO (ArityMismatch syn) + +runM :: forall c m a. ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c) + ) => Dict c m -> RunM c m a -> m a +runM d m = do + tvd <- newTVarIO d + runReaderT (fromRunM m) tvd + +run :: forall c m . ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c) + ) => Dict c m -> [Syntax c] -> m (Syntax c) +run d sy = do + tvd <- newTVarIO d + lastDef nil <$> runReaderT (fromRunM (mapM eval sy)) tvd + +evalTop :: forall c m . ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c)) + => [Syntax c] + -> RunM c m (Syntax c) +evalTop syn = lastDef nil <$> mapM eval syn + +bindMatch :: Id -> ([Syntax c] -> RunM c m (Syntax c)) -> Dict c m +bindMatch n fn = HM.singleton n (Bind man (BindLambda fn)) + where + man = Just $ mempty { manName = Just (manNameOf n) } + +bindValue :: Id -> Syntax c -> Dict c m +bindValue n e = HM.singleton n (Bind mzero (BindValue e)) + +nil :: forall c . IsContext c => Syntax c +nil = List noContext [] + +nil_ :: (IsContext c, MonadIO m) => (a -> RunM c m b) -> a -> RunM c m (Syntax c) +nil_ m w = m w >> pure (List noContext []) + +fixContext :: (IsContext c1, IsContext c2) => Syntax c1 -> Syntax c2 +fixContext = go + where + go = \case + List _ xs -> List noContext (fmap go xs) + Symbol _ w -> Symbol noContext w + Literal _ l -> Literal noContext l + + +fmt :: Syntax c -> Doc ann +fmt = \case + LitStrVal x -> pretty $ Text.unpack x + x -> pretty x + +internalEntries :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m) => MakeDictM c m () +internalEntries = do + + entry $ bindValue "false" (mkBool False) + entry $ bindValue "true" (mkBool True) + entry $ bindValue "chr:semi" (mkStr ";") + entry $ bindValue "chr:tilda" (mkStr "~") + entry $ bindValue "chr:colon" (mkStr ":") + entry $ bindValue "chr:comma" (mkStr ",") + entry $ bindValue "chr:q" (mkStr "'") + entry $ bindValue "chr:minus" (mkStr "-") + entry $ bindValue "chr:dq" (mkStr "\"") + entry $ bindValue "chr:lf" (mkStr "\n") + entry $ bindValue "chr:cr" (mkStr "\r") + entry $ bindValue "chr:tab" (mkStr "\t") + entry $ bindValue "chr:space" (mkStr " ") + + brief "concatenates list of string-like elements into a string" + $ args [arg "list" "(list ...)"] + $ args [arg "..." "..."] + $ returns "string" "" + $ examples [qc| + (concat a b c d) + abcd|] + $ examples [qc| + (concat 1 2 3 4 5) + 12345|] + + $ entry $ bindMatch "concat" $ \syn -> do + + case syn of + [ListVal xs] -> do + pure $ mkStr ( show $ hcat (fmap fmt xs) ) + + xs -> do + pure $ mkStr ( show $ hcat (fmap fmt xs) ) + + brief "creates a list of elements" + $ args [arg "..." "..."] + $ returns "list" "" + $ examples [qc| +(list 1 2 3 fuu bar "baz") +(1 2 3 fuu bar "baz") + |] + $ entry $ bindMatch "list" $ \case + es -> do + pure $ mkList es + + entry $ bindMatch "dict" $ \case + (pairList -> es@(_:_)) -> do + pure $ mkForm "dict" es + [a, b] -> do + pure $ mkForm "dict" [ mkList [a, b] ] + _ -> throwIO (BadFormException @C nil) + + brief "creates a dict from a linear list of string-like items" + $ args [arg "list-of-terms" "..."] + $ desc ( "macro; syntax sugar" <> line + <> "useful for creating function args" <> line + <> "leftover records are skipped" + ) + $ returns "dict" "" + $ examples [qc| +[kw a 1 b 2 c 3] +(dict (a 1) (b 2) (c 3)) + +[kw a] +(dict (a ())) + +[kw a b] +(dict (a b)) + +[kw 1 2 3] +(dict) + +[kw a b c] +(dict (a b) (c ())) + |] + $ entry $ bindMatch "kw" $ \syn -> do + let wat = [ mkList @c [mkSym i, e] | (i,e) <- optlist syn ] + pure $ mkForm "dict" wat + + entry $ bindMatch "iterate" $ nil_ $ \syn -> do + case syn of + [ListVal (SymbolVal "builtin:lambda" : SymbolVal fn : _), ListVal rs] -> do + mapM_ (apply @c fn . List.singleton) rs + + [Lambda decl body, ListVal args] -> do + mapM_ (applyLambda decl body . List.singleton) args + + _ -> do + throwIO (BadFormException @C nil) + + entry $ bindMatch "repeat" $ nil_ $ \case + [LitIntVal n, Lambda [] b] -> do + replicateM_ (fromIntegral n) (applyLambda [] b []) + + [LitIntVal n, e@(ListVal _)] -> do + replicateM_ (fromIntegral n) (eval e) + + z -> + throwIO (BadFormException @C nil) + + entry $ bindMatch "map" $ \syn -> do + case syn of + [ListVal (SymbolVal "builtin:lambda" : SymbolVal fn : _), ListVal rs] -> do + mapM (apply @c fn . List.singleton) rs + <&> mkList + + [Lambda decl body, ListVal args] -> do + mapM (applyLambda decl body . List.singleton) args + <&> mkList + + _ -> do + throwIO (BadFormException @C nil) + + entry $ bindMatch "head" $ \case + [ ListVal es ] -> pure (head es) + _ -> throwIO (TypeCheckError @C nil) + + brief "get tail of list" + $ args [arg "list" "list"] + $ desc "nil if the list is empty; error if not list" + $ examples [qc| + (tail [list 1 2 3]) + (2 3) + (tail [list]) + |] + $ entry $ bindMatch "tail" $ \case + [] -> pure nil + [ListVal []] -> pure nil + [ListVal es] -> pure $ mkList (tail es) + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "lookup" $ \case + [s, ListVal (SymbolVal "dict" : es) ] -> do + let val = headDef nil [ v | ListVal [k, v] <- es, k == s ] + pure val + + [StringLike s, ListVal [] ] -> do + pure nil + + _ -> throwIO (BadFormException @c nil) + + brief "returns current unix time" + $ returns "int" "current unix time in seconds" + $ noArgs + $ entry $ bindMatch "now" $ \case + [] -> mkInt . round <$> liftIO getPOSIXTime + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "display" $ nil_ \case + [ sy ] -> display sy + ss -> display (mkList ss) + + brief "prints new line character to stdout" + $ entry $ bindMatch "newline" $ nil_ $ \case + [] -> liftIO (putStrLn "") + _ -> throwIO (BadFormException @c nil) + + brief "prints a list of terms to stdout" + $ entry $ bindMatch "print" $ nil_ $ \case + [ sy ] -> display sy + ss -> mapM_ display ss + + entry $ bindMatch "println" $ nil_ $ \case + [ sy ] -> display sy >> liftIO (putStrLn "") + ss -> mapM_ display ss >> liftIO (putStrLn "") + + entry $ bindMatch "str:read-stdin" $ \case + [] -> liftIO getContents <&> mkStr @c + + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "str:put" $ nil_ $ \case + [LitStrVal s] -> liftIO $ TIO.putStr s + _ -> throwIO (BadFormException @c nil) + + brief "reads file as a string" do + entry $ bindMatch "str:read-file" $ \case + [StringLike fn] -> liftIO (TIO.readFile fn) <&> mkStr + + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "str:save" $ nil_ \case + [StringLike fn, StringLike what] -> + liftIO (writeFile fn what) + + _ -> throwIO (BadFormException @c nil) + + entry $ bindValue "space" $ mkStr " " + + entry $ bindMatch "parse-top" $ \case + + [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) + + let atomFrom = \case + [StringLike s] -> pure (mkSym s) + [e] -> pure (mkSym $ show $ pretty e) + _ -> throwIO (BadFormException @c nil) + + brief "type of argument" + $ args [arg "term" "term"] + $ returns "symbol" "type" + $ entry $ bindMatch "type" \case + [ListVal _] -> pure $ mkSym "list" + [SymbolVal _] -> pure $ mkSym "symbol" + [LitStrVal _] -> pure $ mkSym "string" + [LitIntVal _] -> pure $ mkSym "int" + [LitScientificVal _] -> pure $ mkSym "float" + [LitBoolVal _] -> pure $ mkSym "bool" + _ -> throwIO (BadFormException @c nil) + + brief "creates a symbol from argument" + $ args [arg "any-term" "term"] + $ returns "symbol" "" + do + entry $ bindMatch "sym" atomFrom + entry $ bindMatch "atom" atomFrom + + brief "compares two terms" $ + args [arg "term" "a", arg "term" "b"] $ + returns "boolean" "#t if terms are equal, otherwise #f" $ + entry $ bindMatch "eq?" $ \case + [a, b] -> do + pure $ if a == b then mkBool True else mkBool False + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "length" $ \case + [ListVal es] -> pure $ mkInt (length es) + [StringLike es] -> pure $ mkInt (length es) + _ -> pure $ mkInt 0 + + entry $ bindMatch "nil?" $ \case + [ListVal []] -> pure $ mkBool True + _ -> pure $ mkBool False + + entry $ bindMatch "not" $ \case + [w] -> do + pure $ if isFalse w then mkBool True else mkBool False + _ -> throwIO (BadFormException @c nil) + + brief "get system environment" + $ args [] + $ args [ arg "string" "string" ] + $ returns "env" "single var or dict of all vars" + $ examples [qc| + (env HOME) + /home/user + + (env) + (dict + (HOME "/home/user") ... (CC "gcc") ...) + |] + $ entry $ bindMatch "env" $ \case + [] -> do + s <- liftIO getEnvironment + pure $ mkForm "dict" [ mkList [mkSym @c a, mkStr b] | (a,b) <- s ] + + [StringLike s] -> do + liftIO (lookupEnv s) + <&> maybe nil mkStr + _ -> throwIO (BadFormException @c nil) + + -- FIXME: we-need-opaque-type + entry $ bindMatch "blob:read-stdin" $ \case + [] -> do + blob <- liftIO BS8.getContents <&> BS8.unpack + pure (mkForm "blob" [mkStr @c blob]) + + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "blob:read-file" $ \case + [StringLike fn] -> do + blob <- liftIO (BS8.readFile fn) <&> BS8.unpack + pure (mkForm "blob" [mkStr @c blob]) + + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "blob:save" $ nil_ $ \case + [StringLike fn, ListVal [SymbolVal "blob", LitStrVal t]] -> do + let s = Text.unpack t & BS8.pack + liftIO $ BS8.writeFile fn s + + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "blob:put" $ nil_ $ \case + [ListVal [SymbolVal "blob", LitStrVal t]] -> do + let s = Text.unpack t & BS8.pack + liftIO $ BS8.putStr s + + _ -> throwIO (BadFormException @c nil) + + diff --git a/hbs2-cli/lib/HBS2/CLI.hs b/hbs2-cli/lib/HBS2/CLI.hs new file mode 100644 index 00000000..8804214a --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI.hs @@ -0,0 +1 @@ +module HBS2.CLI where diff --git a/hbs2-cli/lib/HBS2/CLI/Bind.hs b/hbs2-cli/lib/HBS2/CLI/Bind.hs new file mode 100644 index 00000000..ec6145aa --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Bind.hs @@ -0,0 +1,4 @@ +module HBS2.CLI.Bind where + +import HBS2.CLI.Prelude + diff --git a/hbs2-cli/lib/HBS2/CLI/Prelude.hs b/hbs2-cli/lib/HBS2/CLI/Prelude.hs new file mode 100644 index 00000000..52ea1a4d --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Prelude.hs @@ -0,0 +1,26 @@ +module HBS2.CLI.Prelude + ( module HBS2.Prelude.Plated + , module HBS2.OrDie + , module UnliftIO + , module Data.Config.Suckless + , module Data.HashMap.Strict + , module Control.Monad.Reader + , module HBS2.System.Logger.Simple.ANSI + , module HBS2.Misc.PrettyStuff + , qc,qq,q + , Generic + ) where + +import HBS2.Prelude.Plated +import HBS2.OrDie +import HBS2.System.Logger.Simple.ANSI +import HBS2.Misc.PrettyStuff + +import Data.HashMap.Strict +import Data.Config.Suckless + +import Control.Monad.Reader +import UnliftIO + +import Text.InterpolatedString.Perl6 (qc,q,qq) + diff --git a/hbs2-cli/lib/HBS2/CLI/Run.hs b/hbs2-cli/lib/HBS2/CLI/Run.hs new file mode 100644 index 00000000..968324c2 --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run.hs @@ -0,0 +1,9 @@ +{-# Language UndecidableInstances #-} +module HBS2.CLI.Run + ( module HBS2.CLI.Run.Internal + ) where + +import HBS2.CLI.Run.Internal + + + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs b/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs new file mode 100644 index 00000000..85f0ef0c --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/GroupKey.hs @@ -0,0 +1,142 @@ +module HBS2.CLI.Run.GroupKey + ( module HBS2.CLI.Run.GroupKey + , loadGroupKey + ) where + +import HBS2.CLI.Prelude hiding (mapMaybe) + +import HBS2.Data.Types.Refs +import HBS2.Storage.Operations.Class +import HBS2.Storage.Operations.ByteString +import HBS2.Base58 +import HBS2.CLI.Run.Internal +import HBS2.CLI.Run.Internal.GroupKey as G +import HBS2.Net.Auth.GroupKeySymm as Symm +import HBS2.Storage + + +import HBS2.Peer.RPC.API.Storage +import HBS2.Peer.RPC.Client +import HBS2.Peer.RPC.Client.Unix + +import Data.Text qualified as Text +import Data.ByteString.Lazy.Char8 as LBS8 +import Data.ByteString.Lazy as LBS +import Data.ByteString.Char8 as BS8 +import Data.HashMap.Strict qualified as HM +import Control.Monad.Except +import Codec.Serialise + +{- HLINT ignore "Functor law" -} + + +groupKeyEntries :: forall c m . ( MonadUnliftIO m + , IsContext c + , HasClientAPI StorageAPI UNIX m + , HasStorage m + ) => MakeDictM c m () +groupKeyEntries = do + + entry $ bindMatch "hbs2:groupkey:load" $ \case + [HashLike h] -> do + sto <- getStorage + + gk <- loadGroupKey h + >>= orThrowUser "can not load groupkey" + + pure $ mkStr (show $ pretty $ AsGroupKeyFile gk) + + _ -> throwIO $ BadFormException @C nil + + entry $ bindMatch "hbs2:groupkey:store" $ \case + [LitStrVal s] -> do + let lbs = LBS8.pack (Text.unpack s) + gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs) + `orDie` "invalid group key" + + sto <- getStorage + ha <- writeAsMerkle sto (serialise gk) + pure $ mkStr (show $ pretty ha) + + _ -> throwIO $ BadFormException @C nil + + +-- $ hbs2-cli print [hbs2:groupkey:update [hbs2:groupkey:load 6XJGpJszP6f68fmhF17AtJ9PTgE7BKk8RMBHWQ2rXu6N] \ +-- [list [remove . CcRDzezX1XQdPxRMuMKzJkfHFB4yG7vGJeTYvScKkbP8] \ +-- [add . 5sJXsw7qhmq521hwhE67jYvrD6ZNVazc89rFwfWaQPyY]] ] +-- + entry $ bindMatch "hbs2:groupkey:update" $ \case + [LitStrVal s, ListVal ins] -> do + + sto <- getStorage + + let lbs = LBS8.pack (Text.unpack s) + gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs) + `orDie` "invalid group key" + + gk1 <- modifyGroupKey gk ins + + pure $ mkStr (show $ pretty $ AsGroupKeyFile gk1) + + _ -> throwIO $ BadFormException @C nil + + entry $ bindMatch "hbs2:groupkey:create" $ \syn -> do + case syn of + [ListVal (StringLikeList keys)] -> do + s <- groupKeyFromKeyList keys + <&> AsGroupKeyFile + <&> show . pretty + + pure $ mkStr s + + StringLikeList keys -> do + s <- groupKeyFromKeyList keys + <&> AsGroupKeyFile + <&> show . pretty + + pure $ mkStr s + + _ -> throwIO $ BadFormException @C nil + + + entry $ bindMatch "hbs2:groupkey:list-public-keys" $ \syn -> do + case syn of + [LitStrVal s] -> do + + let lbs = LBS8.pack (Text.unpack s) + gk <- pure (Symm.parseGroupKey @'HBS2Basic $ AsGroupKeyFile lbs) + `orDie` "invalid group key" + + let rcpt = recipients gk & HM.keys & fmap (mkStr . show . pretty . AsBase58) + + pure $ mkList @c rcpt + + _ -> throwIO $ BadFormException @C nil + + + entry $ bindMatch "hbs2:groupkey:decrypt-block" $ \case + [BlobLike bs] -> do + + sto <- getStorage + + let lbs = LBS.fromStrict bs + + seb <- pure (deserialiseOrFail lbs) + `orDie` "invalid SmallEncryptedBlock" + + decrypted <- G.decryptBlock sto seb + + pure $ mkForm @c "blob" [mkStr (BS8.unpack decrypted)] + + _ -> throwIO $ BadFormException @C nil + + entry $ bindMatch "hbs2:groupkey:encrypt-block" $ \case + [StringLike gkh, BlobLike what] -> do + sto <- getStorage + gk <- loadGroupKey (fromString gkh) + `orDie` "can't load group key" + seb <- G.encryptBlock sto gk what + pure $ mkForm "blob" [mkStr (LBS8.unpack (serialise seb))] + + _ -> throwIO $ BadFormException @C nil + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Help.hs b/hbs2-cli/lib/HBS2/CLI/Run/Help.hs new file mode 100644 index 00000000..cde30753 --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/Help.hs @@ -0,0 +1,28 @@ +module HBS2.CLI.Run.Help where + +import HBS2.CLI.Prelude +import HBS2.CLI.Run.Internal + +import Data.HashMap.Strict qualified as HM +import Data.List qualified as List +import Data.Text qualified as Text + +helpEntries :: (MonadUnliftIO m, IsContext c) => MakeDictM c m () +helpEntries = do + + entry $ bindMatch "help" $ nil_ $ \syn -> do + + display_ $ "hbs2-cli tool" <> line + + case syn of + + [StringLike "--documented"] -> do + helpList True Nothing + + (StringLike p : _) -> do + helpList False (Just p) + + HelpEntryBound what -> helpEntry what + + _ -> helpList False Nothing + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs new file mode 100644 index 00000000..3a5e2439 --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs @@ -0,0 +1,213 @@ +{-# Language TemplateHaskell #-} +{-# Language UndecidableInstances #-} +{-# Language AllowAmbiguousTypes #-} +module HBS2.CLI.Run.Internal + ( module HBS2.CLI.Run.Internal + , module SC + ) where + +import HBS2.CLI.Prelude + +import HBS2.OrDie +import HBS2.Base58 +import HBS2.Data.Types.Refs +import HBS2.Storage +import HBS2.Peer.CLI.Detect +import HBS2.Peer.RPC.Client +import HBS2.Peer.RPC.Client.Unix +import HBS2.Peer.RPC.API.Peer +import HBS2.Peer.RPC.API.RefLog +import HBS2.Peer.RPC.API.RefChan +import HBS2.Peer.RPC.API.LWWRef +import HBS2.Peer.RPC.API.Storage +import HBS2.Peer.RPC.API.RefChan +import HBS2.Peer.RPC.Client.StorageClient + +import Data.Config.Suckless.Script qualified as SC +import Data.Config.Suckless.Script hiding (internalEntries) + +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Cont +import Data.ByteString.Char8 qualified as BS8 +import Data.Text qualified as Text +import Lens.Micro.Platform + +pattern HashLike:: forall {c} . HashRef -> Syntax c +pattern HashLike x <- ( + \case + StringLike s -> fromStringMay @HashRef s + _ -> Nothing + -> Just x ) + +pattern SignPubKeyLike :: forall {c} . (PubKey 'Sign 'HBS2Basic) -> Syntax c +pattern SignPubKeyLike x <- ( + \case + StringLike s -> fromStringMay s + _ -> Nothing + -> Just x ) + + +data HBS2CliEnv = + HBS2CliEnv + { _peerSocket :: FilePath + , _peerRefChanAPI :: ServiceCaller RefChanAPI UNIX + , _peerRefLogAPI :: ServiceCaller RefLogAPI UNIX + , _peerLwwRefAPI :: ServiceCaller LWWRefAPI UNIX + , _peerPeerAPI :: ServiceCaller PeerAPI UNIX + , _peerStorageAPI :: ServiceCaller StorageAPI UNIX + } + +makeLenses 'HBS2CliEnv + +newtype HBS2Cli m a = HBS2Cli { fromHBS2Cli :: ReaderT (TVar (Maybe HBS2CliEnv)) m a } + deriving newtype ( Applicative + , Functor + , Monad + , MonadIO + , MonadUnliftIO + , MonadReader (TVar (Maybe HBS2CliEnv)) + ) + +withHBS2Cli :: TVar (Maybe HBS2CliEnv) -> HBS2Cli m a -> m a +withHBS2Cli env action = runReaderT (fromHBS2Cli action) env + +recover :: HBS2Cli IO a -> HBS2Cli IO a +recover what = do + catch what $ \case + PeerNotConnectedException -> do + + soname <- detectRPC + `orDie` "can't locate hbs2-peer rpc" + + flip runContT pure do + + client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname) + >>= orThrowUser ("can't connect to" <+> pretty soname) + + void $ ContT $ withAsync $ runMessagingUnix client + + peerAPI <- makeServiceCaller @PeerAPI (fromString soname) + refLogAPI <- makeServiceCaller @RefLogAPI (fromString soname) + refChanAPI <- makeServiceCaller @RefChanAPI (fromString soname) + storageAPI <- makeServiceCaller @StorageAPI (fromString soname) + lwwAPI <- makeServiceCaller @LWWRefAPI (fromString soname) + + -- let sto = AnyStorage (StorageClient storageAPI) + + let endpoints = [ Endpoint @UNIX peerAPI + , Endpoint @UNIX refLogAPI + , Endpoint @UNIX refChanAPI + , Endpoint @UNIX lwwAPI + , Endpoint @UNIX storageAPI + ] + + void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client + + let env = Just (HBS2CliEnv soname refChanAPI refLogAPI lwwAPI peerAPI storageAPI) + tv <- newTVarIO env + + liftIO $ withHBS2Cli tv what + + +runHBS2Cli :: MonadUnliftIO m => HBS2Cli m a -> m a +runHBS2Cli action = do + noenv <- newTVarIO Nothing + withHBS2Cli noenv action + +data PeerException = + PeerNotConnectedException + deriving stock (Show, Typeable) + +instance Exception PeerException + + +instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto (RunM c m) where + getClientAPI = lift (getClientAPI @api @proto) + +instance (MonadUnliftIO m, HasStorage m) => HasStorage (RunM c m) where + getStorage = lift getStorage + +instance (MonadUnliftIO m, HasClientAPI StorageAPI UNIX m, HasStorage m) => HasStorage (ContT a (RunM c m)) where + getStorage = lift getStorage + +instance (MonadUnliftIO m, HasClientAPI api proto m) => HasClientAPI api proto (ContT a (RunM c m)) where + getClientAPI = lift $ getClientAPI @api @proto + +instance MonadUnliftIO m => HasClientAPI RefChanAPI UNIX (HBS2Cli m) where + getClientAPI = do + what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException + pure $ view peerRefChanAPI what + +instance MonadUnliftIO m => HasClientAPI RefLogAPI UNIX (HBS2Cli m) where + getClientAPI = do + what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException + pure $ view peerRefLogAPI what + +instance MonadUnliftIO m => HasClientAPI PeerAPI UNIX (HBS2Cli m) where + getClientAPI = do + what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException + pure $ view peerPeerAPI what + +instance MonadUnliftIO m => HasClientAPI StorageAPI UNIX (HBS2Cli m) where + getClientAPI = do + what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException + pure $ view peerStorageAPI what + +instance MonadUnliftIO m => HasClientAPI LWWRefAPI UNIX (HBS2Cli m) where + getClientAPI = do + what <- ask >>= readTVarIO >>= orThrow PeerNotConnectedException + pure $ view peerLwwRefAPI what + +instance MonadUnliftIO m => HasStorage (HBS2Cli m) where + getStorage = getClientAPI @StorageAPI @UNIX <&> AnyStorage . StorageClient + +internalEntries :: forall c m . (IsContext c, Exception (BadFormException c), MonadUnliftIO m) => MakeDictM c m () +internalEntries = do + SC.internalEntries + + entry $ bindMatch "blob:base58" $ \case + [LitStrVal t] -> do + bs <- pure (Text.unpack t & BS8.pack & fromBase58) + `orDie` "invalid base58" + <&> BS8.unpack + + pure (mkForm "blob" [mkStr @c bs]) + + _ -> throwIO (BadFormException @c nil) + + + let decodeB58 t = do + pure (Text.unpack t & BS8.pack & fromBase58) + `orDie` "invalid base58" + + let decodeAndOut t = do + liftIO $ BS8.putStr =<< decodeB58 t + + entry $ bindMatch "base58:encode" $ \case + [LitStrVal t] -> do + let s = Text.unpack t & BS8.pack & toBase58 & BS8.unpack + pure (mkForm "blob:base58" [mkStr @c s]) + + [ListVal [SymbolVal "blob", LitStrVal t]] -> do + let s = Text.unpack t & BS8.pack & toBase58 & BS8.unpack + pure (mkForm "blob:base58" [mkStr @c s]) + + e -> throwIO (BadFormException @c nil) + + entry $ bindMatch "base58:decode" $ \case + + [ListVal [SymbolVal "blob:base58", LitStrVal t]] -> do + s <- decodeB58 t <&> BS8.unpack + pure $ mkForm "blob" [mkStr @c s] + + e -> throwIO (BadFormException @c nil) + + entry $ bindMatch "base58:put" $ nil_ $ \case + [ListVal [SymbolVal "blob:base58", LitStrVal t]] -> + decodeAndOut t + + [LitStrVal t] -> decodeAndOut t + + e -> throwIO (BadFormException @c nil) + + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal/GroupKey.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal/GroupKey.hs new file mode 100644 index 00000000..1023443d --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal/GroupKey.hs @@ -0,0 +1,107 @@ +module HBS2.CLI.Run.Internal.GroupKey + ( module HBS2.CLI.Run.Internal.GroupKey + , SmallEncryptedBlock(..) + ) where + +import HBS2.CLI.Prelude hiding (mapMaybe) +import HBS2.CLI.Run.Internal + +import HBS2.Base58 +import HBS2.Hash +import HBS2.Storage +import HBS2.Data.Types.Refs +import HBS2.Data.Types.SmallEncryptedBlock +import HBS2.Storage.Operations.Class +import HBS2.Storage.Operations.ByteString +import HBS2.KeyMan.Keys.Direct +import HBS2.Net.Auth.GroupKeySymm as Symm + +import HBS2.Peer.RPC.Client.Unix +import HBS2.Peer.RPC.Client +import HBS2.Peer.RPC.API.Storage + +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS +import Data.Maybe +import Control.Monad.Trans.Cont +import Control.Monad.Except +import Codec.Serialise +import Data.ByteString (ByteString) + +groupKeyFromKeyList :: MonadUnliftIO m => [String] -> m (GroupKey 'Symm HBS2Basic) +groupKeyFromKeyList ks = do + let members = mapMaybe (fromStringMay @(PubKey 'Encrypt 'HBS2Basic)) ks + Symm.generateGroupKey @'HBS2Basic Nothing members + + +encryptBlock :: (MonadUnliftIO m, Serialise t) + => AnyStorage + -> GroupKey 'Symm 'HBS2Basic + -> t + -> m (SmallEncryptedBlock t) + +encryptBlock sto gk x = do + + let HbSyncHash non = hashObject (serialise x) + + gks <- runKeymanClient (extractGroupKeySecret gk) + >>= orThrowUser "can't extract group key secret" + + Symm.encryptBlock sto gks (Right gk) (Just non) x + +decryptBlock :: (MonadUnliftIO m, Serialise t) + => AnyStorage + -> SmallEncryptedBlock t + -> m t +decryptBlock sto seb = do + let find gk = runKeymanClient (extractGroupKeySecret gk) + + -- FIXME: improve-error-diagnostics + runExceptT (Symm.decryptBlock sto find seb) + >>= orThrowUser "can't decrypt block" + +loadGroupKey :: ( IsContext c + , MonadUnliftIO m + , HasStorage m + , HasClientAPI StorageAPI UNIX m + ) => HashRef -> RunM c m (Maybe (GroupKey 'Symm HBS2Basic)) +loadGroupKey h = do + + flip runContT pure do + sto <- getStorage + + raw <- runExceptT (readFromMerkle sto (SimpleKey (fromHashRef h))) + <&> either (const Nothing) Just + + bs <- ContT (maybe1 raw (pure Nothing)) + + let gk = deserialiseOrFail bs + & either (const Nothing) Just + + pure gk + +modifyGroupKey :: (IsContext c, MonadUnliftIO m) + => GroupKey 'Symm 'HBS2Basic + -> [Syntax c] + -> m (GroupKey 'Symm HBS2Basic) +modifyGroupKey gk ins = do + + gks <- runKeymanClient do + extractGroupKeySecret gk + `orDie` "can't extract group key secret" + + let r = catMaybes [ fromStringMay @(PubKey 'Encrypt HBS2Basic) k + | ListVal [SymbolVal "remove", StringLike k] <- ins + ] & HS.fromList + + let a = catMaybes [ fromStringMay @(PubKey 'Encrypt HBS2Basic) k + | ListVal [SymbolVal "add", StringLike k] <- ins + ] & HS.fromList + + let x = recipients gk & HM.keysSet + + let new = x `HS.difference` r `mappend` a & HS.toList + + generateGroupKey @'HBS2Basic (Just gks) new + + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal/KeyMan.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal/KeyMan.hs new file mode 100644 index 00000000..79395988 --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal/KeyMan.hs @@ -0,0 +1,59 @@ +module HBS2.CLI.Run.Internal.KeyMan where + +import HBS2.CLI.Prelude +import HBS2.CLI.Run.Internal + +import HBS2.Hash +import HBS2.System.Dir +import HBS2.Net.Auth.Credentials + +import HBS2.KeyMan.Keys.Direct +import HBS2.KeyMan.State +import HBS2.KeyMan.App.Types + +import Codec.Serialise +import Data.Either +import Data.ByteString.Lazy qualified as LBS +import Data.Text.Encoding qualified as TE +import Data.Text.IO qualified as TIO +import System.Process.Typed +import Text.InterpolatedString.Perl6 (qc) + + + +keymanGetConfig :: (IsContext c, MonadUnliftIO m) => m [Syntax c] +keymanGetConfig = do + (_,lbs,_) <- readProcess (shell [qc|hbs2-keyman config|] & setStderr closed) + + let conf = TE.decodeUtf8 (LBS.toStrict lbs) + & parseTop + & fromRight mempty + + pure $ fmap fixContext conf + +keymanUpdate :: MonadUnliftIO m => m () +keymanUpdate = do + void $ runProcess (shell [qc|hbs2-keyman update|]) + +keymanNewCredentials :: MonadUnliftIO m => Maybe String -> Int -> m (PubKey 'Sign 'HBS2Basic) +keymanNewCredentials suff n = do + conf <- keymanGetConfig @C + + path <- [ p + | ListVal [SymbolVal "default-key-path", StringLike p] <- conf + ] & headMay & orThrowUser "default-key-path not set" + + creds <- newCredentialsEnc @'HBS2Basic n + + let s = show $ pretty $ AsCredFile (AsBase58 creds) + + let psk = view peerSignPk creds + + let fpath = path show (pretty (AsBase58 psk) <> "-" <> pretty suff <> ".key") + + liftIO $ writeFile fpath s + + keymanUpdate + + pure psk + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs new file mode 100644 index 00000000..8217dbb9 --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal/Merkle.hs @@ -0,0 +1,117 @@ +module HBS2.CLI.Run.Internal.Merkle where + +import HBS2.CLI.Prelude +import HBS2.Defaults +import HBS2.CLI.Run.Internal +import HBS2.CLI.Run.Internal.GroupKey as G + +import HBS2.Hash +import HBS2.Net.Auth.GroupKeySymm as Symm +import HBS2.Data.Types.Refs +import HBS2.Merkle +import HBS2.Storage +import HBS2.Storage.Operations.ByteString +import HBS2.Peer.RPC.Client.Unix +import HBS2.Peer.RPC.Client +import HBS2.Peer.RPC.API.Storage +import HBS2.KeyMan.Keys.Direct + +import HBS2.Net.Auth.Schema() + +import Codec.Serialise +import Data.ByteString.Lazy qualified as LBS +import Data.HashMap.Strict qualified as HM +import Data.Text qualified as Text +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Cont +import Control.Monad.Except + +--FIXME: move-somewhere-else +getGroupKeyHash :: ( IsContext c + , MonadUnliftIO m + , HasStorage m + , HasClientAPI StorageAPI UNIX m + ) + => HashRef + -> RunM c m (Maybe HashRef, MTreeAnn [HashRef]) +getGroupKeyHash h = do + flip runContT pure do + sto <- getStorage + + headBlock <- getBlock sto (fromHashRef h) + >>= orThrowUser "no-block" + <&> deserialiseOrFail @(MTreeAnn [HashRef]) + >>= orThrowUser "invalid block format" + + case _mtaCrypt headBlock of + (EncryptGroupNaClSymm hash _) -> + pure $ (Just $ HashRef hash, headBlock) + _ -> pure (Nothing, headBlock) + +-- TODO: client-api-candidate +createTreeWithMetadata :: (MonadUnliftIO m) + => AnyStorage + -> Maybe (GroupKey 'Symm 'HBS2Basic) + -> HashMap Text Text + -> LBS.ByteString + -> m (Either OperationError HashRef) +createTreeWithMetadata sto mgk meta lbs = do -- flip runContT pure do + + let mt = vcat [ pretty k <> ":" <+> dquotes (pretty v) | (k,v) <- HM.toList meta ] + & show & Text.pack + + case mgk of + Nothing -> Right <$> createSimpleTree mt + Just gk -> createEncryptedTree gk mt + + where + createSimpleTree mt = do + t0 <- writeAsMerkle sto lbs + >>= getBlock sto + >>= orThrowUser "can't read merkle tree just written" + <&> deserialiseOrFail @(MTree [HashRef]) + >>= orThrowUser "merkle tree corrupted/invalid" + + let mann = MTreeAnn (ShortMetadata mt) NullEncryption t0 + + putBlock sto (serialise mann) + >>= orThrowUser "can't write tree" + <&> HashRef + + -- FIXME: support-encryption + createEncryptedTree gk mt = do + -- 1. find key + mgks <- runKeymanClient do + extractGroupKeySecret gk + + gks <- orThrowUser "can't get groupkey's secret" mgks + + -- FIXME: consider-other-nonce-calculation + -- надо считать начальный нонс (от чего / как?) + -- нонс: да так-то пофиг от чего, но: + -- если брать рандомные места в байтстроке -- + -- она зафорсится + -- что вообще зависит от начального нонса: + -- если в файл будет допись в конец, то + -- "старые" блоки останутся такими же, как были + -- что хорошо для дедуплицирования, но + -- потенциально это менее безопасно. + -- можно еще с метаданными похэшировать, тогда + -- нонс будет более уникальный; но поменялись метаданные -- поменялось всё + let s0 = LBS.take ( 1024 * 1024 ) lbs + + let (HbSyncHash nonce) = hashObject @HbSync s0 + -- куда-то девать зашифрованные метаданные + -- + let segments = readChunkedBS lbs defBlockSize + + seb <- G.encryptBlock sto gk (ShortMetadata mt) + + hmeta <- putBlock sto (serialise seb) + >>= orThrowUser "can't put block" + + let source = ToEncryptSymmBS gks (Right gk) nonce segments (AnnHashRef hmeta) Nothing + + runExceptT $ writeAsMerkle sto source <&> HashRef + + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs b/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs new file mode 100644 index 00000000..43a92c3b --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/KeyMan.hs @@ -0,0 +1,51 @@ +module HBS2.CLI.Run.KeyMan + (keymanEntries) where + +import HBS2.CLI.Prelude +import HBS2.CLI.Run.Internal +import HBS2.CLI.Run.Internal.KeyMan + +import HBS2.Hash +import HBS2.System.Dir + +import HBS2.KeyMan.Keys.Direct +import HBS2.KeyMan.State +import HBS2.KeyMan.App.Types + +import Codec.Serialise +import Data.Either +import Data.ByteString.Lazy qualified as LBS +import Data.Text.Encoding qualified as TE +import Data.Text.IO qualified as TIO +import System.Process.Typed +import Text.InterpolatedString.Perl6 (qc) + + +keymanEntries :: (MonadUnliftIO m, IsContext c) => MakeDictM c m () +keymanEntries = do + entry $ bindMatch "hbs2:keyman:list" $ nil_ \case + _ -> do + void $ runKeymanClient $ KeyManClient $ do + k <- listKeys + display_ $ vcat (fmap pretty k) + + entry $ bindMatch "hbs2:keyman:update" $ nil_ $ \_ -> do + keymanUpdate + + entry $ bindMatch "hbs2:keyman:config" $ \_ -> do + mkForm "dict" <$> keymanGetConfig + + entry $ bindMatch "hbs2:keyman:keys:add" $ \case + [ LitStrVal ke ] -> do + conf <- keymanGetConfig @C + let path = head [ s | ListVal [ SymbolVal "default-key-path", StringLike s ] <- conf ] + mkdir path + let n = hashObject @HbSync (serialise ke) & pretty & show + let fname = n `addExtension` ".key" + let fpath = path fname + liftIO $ TIO.writeFile fpath ke + keymanUpdate + pure $ mkStr fpath + + _ -> throwIO (BadFormException @C nil) + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Keyring.hs b/hbs2-cli/lib/HBS2/CLI/Run/Keyring.hs new file mode 100644 index 00000000..6928b877 --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/Keyring.hs @@ -0,0 +1,60 @@ +module HBS2.CLI.Run.Keyring where + +import HBS2.CLI.Prelude +import HBS2.CLI.Run.Internal + +import HBS2.Net.Auth.Credentials +import HBS2.KeyMan.App.Types + +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BS8 +import Data.Text qualified as Text + +keyringEntries :: forall c m . ( MonadUnliftIO m + , IsContext c + , Exception (BadFormException c) + ) => MakeDictM c m () +keyringEntries = do + entry $ bindMatch "hbs2:keyring:list-encryption" $ \syn -> do + lbs <- case syn of + + [ ListVal [ SymbolVal "file", StringLike fn ] ] -> do + liftIO $ BS.readFile fn + + [ LitStrVal s ] -> do + pure (BS8.pack (Text.unpack s)) + + _ -> throwIO (BadFormException @C nil) + + cred <- pure (parseCredentials @'HBS2Basic (AsCredFile lbs)) + `orDie` "bad keyring file" + + let e = [ mkStr @c (show (pretty (AsBase58 p))) | KeyringEntry p _ _ <- view peerKeyring cred ] + + pure $ mkList @c e + + brief "creates a new keyring (credentials)" + $ args [arg "int?" "encrypt-keys-num"] + $ returns "keyring" "string" + $ entry $ bindMatch "hbs2:keyring:new" $ \syn -> do + n <- case syn of + [LitIntVal k] -> pure k + [] -> pure 1 + _ -> throwIO (BadFormException @C nil) + + cred0 <- newCredentials @'HBS2Basic + cred <- foldM (\cred _ -> addKeyPair Nothing cred) cred0 [1..n] + pure $ mkStr @c $ show $ pretty $ AsCredFile $ AsBase58 cred + + + entry $ bindMatch "hbs2:keyring:show" $ \case + [StringLike fn] -> do + bs <- liftIO $ BS.readFile fn + cred <- parseCredentials @'HBS2Basic (AsCredFile bs) + & orThrowUser "bad credentials file" + + pure $ mkStr $ show $ pretty (ListKeyringKeys cred) + + _ -> throwIO $ BadFormException @c nil + + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs b/hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs new file mode 100644 index 00000000..b912ee8a --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/LWWRef.hs @@ -0,0 +1,129 @@ +module HBS2.CLI.Run.LWWRef where + +import HBS2.CLI.Prelude +import HBS2.CLI.Run.Internal +import HBS2.CLI.Run.Internal.KeyMan + +import HBS2.Data.Types.Refs +import HBS2.Storage +import HBS2.Peer.CLI.Detect +import HBS2.Peer.RPC.Client.Unix +import HBS2.Peer.RPC.Client +import HBS2.Peer.RPC.API.Peer +import HBS2.Peer.RPC.API.LWWRef + +import HBS2.Peer.Proto.LWWRef +import HBS2.Base58 +import HBS2.Net.Auth.Credentials +import HBS2.Net.Auth.Schema() +import HBS2.Data.Types.SignedBox + +import HBS2.KeyMan.Keys.Direct +import HBS2.KeyMan.App.Types + +import Control.Monad.Trans.Cont + + +lwwRefEntries :: forall c m . ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c) + , HasClientAPI PeerAPI UNIX m + , HasClientAPI LWWRefAPI UNIX m + ) => MakeDictM c m () +lwwRefEntries = do + + brief "creates a new lwwref" + $ desc "Creates a new keyring; adds it to keyman and subsribes hbs2-peer to listen this lwwref" + $ returns "string" "lwwref public key" + $ entry $ bindMatch "hbs2:lwwref:create" $ \case + [] -> do + reflog <- keymanNewCredentials (Just "lwwref") 0 + api <- getClientAPI @PeerAPI @UNIX + void $ callService @RpcPollAdd api (reflog, "lwwref", 31) + pure $ mkStr (show $ pretty (AsBase58 reflog)) + + _ -> throwIO (BadFormException @C nil) + + brief "lists all lwwref that hbs2-peer is subscribed to" + $ noArgs + $ returns "list of string" "lwwref list" + $ entry $ bindMatch "hbs2:lwwref:list" $ \case + [] -> do + api <- getClientAPI @PeerAPI @UNIX + r <- callService @RpcPollList2 api (Just "lwwref", Nothing) + >>= orThrowUser "can't get lwwref list" + pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r + + _ -> throwIO (BadFormException @C nil) + + + brief "fetches lwwref value" + $ desc "makes peer to request lwwref from neighbors" + $ args [arg "string" "lwwref"] + $ returns "atom" "okay" + $ entry $ bindMatch "hbs2:lwwref:fetch" $ \case + [StringLike puk] -> do + lww <- orThrowUser "bad lwwref key" (fromStringMay puk) + api <- getClientAPI @LWWRefAPI @UNIX + void $ callService @RpcLWWRefFetch api lww + pure $ mkStr "okay" + + _ -> throwIO (BadFormException @C nil) + + + brief "get lwwref value" + $ args [arg "string" "lwwref"] + $ returns "string" "hashref" + $ examples [qc| + +(hbs2:lwwref:get BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP) +(lwwref + (seq 4) + (value "74vDGwBYebH3oM6xPXC7kqpgu6deqi7E549QpvHvvQKf") + ) + |] + $ entry $ bindMatch "hbs2:lwwref:get" $ \case + [StringLike puk] -> do + + ref <- orThrowUser "bad lwwref key" (fromStringMay puk) + api <- getClientAPI @LWWRefAPI @UNIX + what <- callService @RpcLWWRefGet api ref + >>= orThrowUser "can't get lwwref value" + pure $ mkStr (show $ pretty what) + + _ -> throwIO (BadFormException @C nil) + + + brief "updates lwwref" + $ desc "updates lwwref value and increments it's counter" + $ args [arg "string" "lwwref", arg "string" "hash"] + $ returns "nil" "" + $ entry $ bindMatch "hbs2:lwwref:update" $ \case + [StringLike puks, HashLike new] -> do + + puk <- orThrowUser "bad lwwref key" (fromStringMay puks) + api <- getClientAPI @LWWRefAPI @UNIX + + (sk,pk) <- liftIO $ runKeymanClient do + creds <- loadCredentials puk + >>= orThrowUser "can't load credentials" + pure ( view peerSignSk creds, view peerSignPk creds ) + + what <- callService @RpcLWWRefGet api puk + >>= orThrowUser "can't get lwwref value" + + sno' <- case what of + Nothing -> pure 0 + Just lwwv -> pure (lwwSeq lwwv) + + let sno = succ sno' + + let box = makeSignedBox pk sk (LWWRef sno new Nothing) + + callService @RpcLWWRefUpdate api box + >>= orThrowUser "lww ref update error" + + pure nil + + _ -> throwIO (BadFormException @C nil) + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs new file mode 100644 index 00000000..599f6759 --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs @@ -0,0 +1,329 @@ +{-# Language MultiWayIf #-} + +module HBS2.CLI.Run.MetaData + ( metaDataEntries + , createTreeWithMetadata + ) 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 Codec.Serialise +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Cont +import Data.ByteString.Lazy qualified as LBS +import Data.Either +import Data.Set qualified as Set +import Data.HashMap.Strict qualified as HM +import Data.Maybe +import Data.Text.Encoding qualified as TE +import Data.Text qualified as Text + +import Magic.Data +import Magic.Init (magicLoadDefault,magicOpen) +import Magic.Operations (magicFile) + +{- HLINT ignore "Functor law" -} + +data CreateMetaDataOpt = + Auto + | Stdin + | Encrypted String + | MetaDataEntry Id String + | MetaDataFile FilePath + deriving stock (Eq,Ord,Show,Data,Generic) + +txt :: Pretty a => a -> Text +txt a = Text.pack (show $ pretty a) + +metaFromSyntax :: [Syntax c] -> HashMap Text Text +metaFromSyntax syn = + HM.fromList [ (t k, t v) | (ListVal [ k, v ]) <- syn ] + where + t x = Text.pack (show $ pretty x) + + +metaDataEntries :: forall c m . ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c) + , HasStorage m + , HasClientAPI StorageAPI UNIX m + ) => MakeDictM c m () +metaDataEntries = do + + brief "update group key for tree" + $ args [arg "string" "tree", arg "list" "update-ops"] + $ desc ( "update-ops is a list of pairs, like" <> line + <> indent 4 ( parens ("list" + <+> indent 2 (vcat [ parens "remove . PUBLIC-KEY-ID" + , parens "add . PUBLIC-KEY-ID" + ])))) + $ returns "string" "new-tree-hash" + $ examples [qc| + +(define gk (hbs2:groupkey:load 6XJGpJszP6f68fmhF17AtJ9PTgE7BKk8RMBHWQ2rXu6N)) + +(hbs2:groupkey:update gk + (list (remove . CcRDzezX1XQdPxRMuMKzJkfHFB4yG7vGJeTYvScKkbP8) + (add . EiwWxY3xwTfnLKJdzzxNMZgA2ZvYAZd9e8B8pFeCtnrn))) + |] + $ entry $ bindMatch "hbs2:tree:metadata:update-gk" $ \case + [StringLike tree, ListVal ins] -> do + + ha <- orThrowUser "invalid hash" (fromStringMay tree) + + -- 1. load-group-key + (gkh', headBlk) <- getGroupKeyHash ha + + gkh <- orThrowUser "not encrypted" gkh' + + gk <- loadGroupKey gkh + >>= orThrowUser "can't load gk" + + gk1 <- modifyGroupKey gk ins + + sto <- getStorage + gk1h <- writeAsMerkle sto (serialise gk1) + + case headBlk of + w@(MTreeAnn { _mtaCrypt = EncryptGroupNaClSymm _ nonce }) -> do + let w1 = w { _mtaCrypt = EncryptGroupNaClSymm gk1h nonce } + + h <- putBlock sto (serialise w1) + >>= orThrowUser "can't put block" + + pure $ mkStr (show $ pretty h) + + _ -> pure nil + + _ -> throwIO (BadFormException @c nil) + + brief "get group key from encrypted tree" + $ args [arg "string" "tree-hash"] + $ returns "group-key-hash" "string" + $ examples [qc| + +(hbs2:tree:metadata:get-gk 7J2BZYskBjmDsWZHvVoGGorZDrFYkbbQweRauaYGSTNd) +5fshZRucawt47YJLuD1rVXRez2dcvCbz17m69YyduTEm + + |] + $ entry $ bindMatch "hbs2:tree:metadata:get-gk" $ \case + [ StringLike hash ] -> flip runContT pure do + + (gk,_) <- lift $ getGroupKeyHash (fromString hash) + + case gk of + Just h -> pure $ mkStr (show $ pretty h) + _ -> pure nil + + _ -> throwIO (BadFormException @c nil) + + brief "get metadata from tree" + $ args [arg "symbol?" "method", arg "string" "tree-hash"] + $ returns "group-key-hash" "string" + $ desc ( opt "symbol?" ":parsed" <+> "return metadata as dict" <> line + <> "if other value or absense then return metadata as string" + ) + $ examples [qc| + +(hbs2:tree:metadata:get :parsed 7J2BZYskBjmDsWZHvVoGGorZDrFYkbbQweRauaYGSTNd) +(dict (mime-type: "text/plain; charset=us-ascii") (file-name: "qqq.txt")) + +(hbs2:tree:metadata:get :raw 7J2BZYskBjmDsWZHvVoGGorZDrFYkbbQweRauaYGSTNd +mime-type: "text/plain; charset=us-ascii" +file-name: "qqq.txt" + |] + $ entry $ bindMatch "hbs2:tree:metadata:get" + $ \case + [ SymbolVal how, StringLike hash ] -> do + + r <- flip runContT pure do + + sto <- getStorage + + runMaybeT do + + headBlock <- getBlock sto (fromString hash) + >>= toMPlus + <&> deserialiseOrFail @(MTreeAnn [HashRef]) + >>= toMPlus + + case headBlock of + MTreeAnn { _mtaMeta = ShortMetadata s } -> do + pure $ mkStr s + + MTreeAnn { _mtaMeta = AnnHashRef h, _mtaCrypt = NullEncryption } -> do + getBlock sto h + >>= toMPlus + <&> LBS.toStrict + <&> TE.decodeUtf8 + <&> mkStr + + MTreeAnn { _mtaMeta = AnnHashRef h } -> do + getBlock sto h + >>= toMPlus + <&> deserialiseOrFail @(SmallEncryptedBlock AnnMetaData) + >>= toMPlus + >>= lift . lift . G.decryptBlock sto + <&> \case + ShortMetadata s -> mkStr s + _ -> nil + + _ -> mzero + + case (how, r) of + ("parsed", Just (LitStrVal r0)) -> do + + + let xs = parseTop r0 + & either mempty (fmap fixContext) + + pure $ mkForm "dict" xs + + _ -> pure $ fromMaybe nil r + + _ -> throwIO (BadFormException @c nil) + + brief "creates a merkle tree with metadata" + $ returns "string" "hash" + $ args [ arg "list-of-options" "..." ] + $ desc ( "options:" <> line + <> indent 4 ( + vcat [ opt ":stdin" "read data from stdin" + , opt ":auto" "create metadata from file using libmagic" + , opt "[kw [encrypted group-key-hash]]" "encrypt metadata with given group key" + , opt "dict" "custom metadata dictionary" + , opt "filename : string-like" "file name, ignored if stdin option set" + ]) + ) + $ examples [qc| +Create not encrypted merkle tree for string from stdin without metadata + +$ echo TEST | hbs2-cli hbs2:tree:metadata:create :stdin +7dGqTtoehsgn7bADcVTyp93tq2FfuQgtBuVvYL46jdyz + +;; empty metadata + +hbs2-cli hbs2:tree:metadata:get :raw 7dGqTtoehsgn7bADcVTyp93tq2FfuQgtBuVvYL46jdyz + +Create merkle tree with custom metadata + +$ echo TEST | hbs2-cli hbs2:tree:metadata:create :stdin [kw hello world] +2ASBLBPRUMrHoSkNYsRWwJQiiXuSGDZTaCXAdDTdeJY6 + +$ hbs2-cli hbs2:tree:metadata:get :raw 2ASBLBPRUMrHoSkNYsRWwJQiiXuSGDZTaCXAdDTdeJY6 +hello: "world" + +$ hbs2-cli hbs2:tree:metadata:create :auto ./lambda.svg +3fv5ym8NhY8zat37NaTvY9PDcwJqMLUD73ewHxtHysWg + +$ hbs2-cli hbs2:tree:metadata:get :raw 3fv5ym8NhY8zat37NaTvY9PDcwJqMLUD73ewHxtHysWg +mime-type: "image/svg+xml; charset=us-ascii" +file-name: "lambda.svg" + +Create encrypted tree metadata with a new groupkey + +$ hbs2-cli [define pks [list EiwWxY3xwTfnLKJdzzxNMZgA2ZvYAZd9e8B8pFeCtnrn]] \ + and [define gk [hbs2:groupkey:store [hbs2:groupkey:create pks]]] \ + and [hbs2:tree:metadata:create :auto [kw :encrypted gk] ./lambda.svg] + +BFLcbpNEqngsJ8gzx3ps4ETXfpUMGgjEETNEVgR18KG4 + +Check group key + +$ hbs2-cli hbs2:tree:metadata:get-gk BFLcbpNEqngsJ8gzx3ps4ETXfpUMGgjEETNEVgR18KG4y + +GixS4wssCD4x7LzvHve2JhFCghW1Hwia2tiGTfTTef1u + +Check metadata + +$ hbs2-cli hbs2:tree:metadata:get :raw BFLcbpNEqngsJ8gzx3ps4ETXfpUMGgjEETNEVgR18KG4y + +mime-type: "image/svg+xml; charset=us-ascii" +file-name: "lambda.svg" + +List group key + +$ hbs2-cli hbs2:groupkey:list-public-keys [hbs2:groupkey:load GixS4wssCD4x7LzvHve2JhFCghW1Hwia2tiGTfTTef1u] +("EiwWxY3xwTfnLKJdzzxNMZgA2ZvYAZd9e8B8pFeCtnrn") + |] + $ entry $ bindMatch "hbs2:tree:metadata:create" $ \syn -> do + case syn of + + args -> do + opts' <- for args $ \case + SymbolVal "stdin" -> pure [Stdin] + + SymbolVal "auto" -> pure [Auto] + + ListVal (SymbolVal "dict" : [ListVal [SymbolVal "encrypted", StringLike key]]) + -> do + pure [Encrypted key] + + ListVal (SymbolVal "dict" : w) -> do + pure [MetaDataEntry x y | ListVal [SymbolVal x, StringLike y] <- w ] + + StringLike rest -> do + pure [MetaDataFile rest] + + _ -> pure mempty + + let opts = mconcat opts' & Set.fromList + let inFile = headMay [ x | MetaDataFile x <- universeBi opts ] + + lbs <- case (Set.member Stdin opts, inFile) of + (True, _) -> liftIO LBS.getContents + (False, Just fn) -> liftIO (LBS.readFile fn) + (_, Nothing) -> liftIO LBS.getContents + + meta0 <- if not (Set.member Auto opts) || isNothing inFile then + pure (mempty :: HashMap Text Text) + else liftIO do + let fn = fromJust inFile + magic <- magicOpen [MagicMimeType,MagicMime,MagicMimeEncoding] + magicLoadDefault magic + mime <- magicFile magic fn + pure $ HM.fromList [ ("file-name", Text.pack (takeFileName fn)) + , ("mime-type", Text.pack mime) + ] + + let meta1 = HM.fromList [ (txt n, txt e) | MetaDataEntry n e <- universeBi opts ] + + let enc = headMay [ e | x@(Encrypted e) <- universeBi opts ] + + gk <- runMaybeT do + s <- toMPlus enc + g <- lift $ loadGroupKey (fromString s) + toMPlus g + + when (isJust enc && isNothing gk) do + error $ show $ "Can't load group key" <+> pretty enc + + sto <- getStorage + + href <- lift (createTreeWithMetadata sto gk (meta0 <> meta1) lbs) + `orDie` "encryption error" + + pure $ mkStr (show $ pretty href) + + entry $ bindMatch "cbor:base58" $ \case + [ LitStrVal x ] -> do + pure $ mkForm "cbor:base58" [mkStr x] + + _ -> throwIO (BadFormException @c nil) + + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs b/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs new file mode 100644 index 00000000..67678bc2 --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/Peer.hs @@ -0,0 +1,121 @@ +module HBS2.CLI.Run.Peer where + +import HBS2.CLI.Prelude +import HBS2.CLI.Run.Internal + +import HBS2.Hash +import HBS2.Base58 +import HBS2.Data.Types.Refs +import HBS2.Storage +import HBS2.Peer.RPC.Client +import HBS2.Peer.CLI.Detect +import HBS2.Peer.RPC.Client.Unix +import HBS2.Peer.RPC.API.Peer +import HBS2.Peer.RPC.API.RefLog +import HBS2.Peer.RPC.API.Storage +import HBS2.Peer.RPC.API.LWWRef +import HBS2.Net.Auth.Schema() + +import Data.List qualified as L +import Data.Maybe +import Control.Monad.Trans.Cont +import Data.Text qualified as Text +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Lens.Micro.Platform + +import Text.InterpolatedString.Perl6 (qc) + +{- HLINT ignore "Functor law" -} + +putTextLit :: forall c m . (IsContext c, MonadUnliftIO m) + => AnyStorage + -> Text + -> RunM c m (Syntax c) + +putTextLit sto s = do + h <- putBlock sto (LBS8.pack (Text.unpack s)) + `orDie` "can't store block" + <&> HashRef + + pure (mkStr @c (show $ pretty h)) + +peerEntries :: forall c m . ( IsContext c + , MonadUnliftIO m + , HasClientAPI PeerAPI UNIX m + , HasClientAPI StorageAPI UNIX m + , HasStorage m + , Exception (BadFormException c) + ) => MakeDictM c m () +peerEntries = do + + entry $ bindMatch "hbs2:peer:detect" $ \case + _ -> detectRPC <&> maybe (nil @c) mkStr + + entry $ bindMatch "hbs2:peer:get-block" $ \case + [StringLike s] -> do + flip runContT pure do + + sto <- getStorage + ha <- pure (fromStringMay @HashRef s) + `orDie` "invalid hash" + + lbs <- getBlock sto (fromHashRef ha) + `orDie` show ("missed-block" <+> pretty ha) + + pure $ mkForm "blob" [mkStr (LBS8.unpack lbs)] + + _ -> throwIO $ BadFormException @c nil + + entry $ bindMatch "hbs2:peer:has-block" $ \case + [StringLike s] -> 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 + [ListVal [SymbolVal "blob", LitStrVal s]] -> do + flip runContT pure do + sto <- getStorage + lift $ putTextLit sto s + + [LitStrVal s] -> do + flip runContT pure do + sto <- getStorage + lift $ putTextLit sto s + + _ -> throwIO $ BadFormException @c nil + + brief "checks if peer available" + $ noArgs + $ returns "dict" "dictionary of peer attributes" + $ examples [qc| +(hbs2:peer:poke) + +(dict + (peer-key: "35gKUG1mwBTr3tQpjWwR2kBYEnDmHxesoJL5Lj7tMjq3") + (udp: "0.0.0.0:7354") + (tcp: "tcp://0.0.0.0:3001") + (local-multicast: "239.192.152.145:10153") + (rpc: "/tmp/hbs2-rpc.socket") + (http-port: 5000)) + |] + $ entry $ bindMatch "hbs2:peer:poke" $ \case + _ -> do + api <- getClientAPI @PeerAPI @UNIX + callRpcWaitMay @RpcPoke (TimeoutSec 1) api () + <&> fromMaybe "" + <&> parseTop + <&> either (const nil) (mkForm "dict" . fmap fixContext) + + + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs b/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs new file mode 100644 index 00000000..e864bc5e --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/RefChan.hs @@ -0,0 +1,297 @@ +module HBS2.CLI.Run.RefChan where + +import HBS2.CLI.Prelude +import HBS2.CLI.Run.Internal +import HBS2.CLI.Run.Internal.KeyMan + +import HBS2.Data.Types.Refs +import HBS2.Peer.CLI.Detect +import HBS2.Peer.RPC.Client.Unix +import HBS2.Peer.RPC.API.Peer +import HBS2.Peer.RPC.API.RefChan +import HBS2.Peer.RPC.Client.RefChan as Client + +import HBS2.Storage.Operations.ByteString + +-- import HBS2.Net.Proto +-- import HBS2.Net.Auth.Credentials +-- import HBS2.Base58 +-- import HBS2.Defaults +-- import HBS2.Events +-- import HBS2.Peer.Proto.Peer +-- import HBS2.Net.Proto.Sessions +-- import HBS2.Data.Types.Refs +-- import HBS2.Data.Types.SignedBox +-- import HBS2.Storage + + +import HBS2.Peer.Proto.RefChan +import Data.Either +import HBS2.Base58 +import HBS2.Net.Auth.Credentials +import HBS2.Net.Auth.Schema() +import HBS2.Data.Types.SignedBox +import HBS2.Peer.RPC.Client +import HBS2.Peer.RPC.API.Storage +import HBS2.Storage + +import HBS2.KeyMan.Keys.Direct +import HBS2.KeyMan.App.Types + +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS +import Data.Coerce +import Control.Monad.Trans.Cont +import Control.Monad.Except + +import Text.InterpolatedString.Perl6 (qc) + +refchanEntries :: forall c m . ( IsContext c + , MonadUnliftIO m + , Exception (BadFormException c) + , HasClientAPI RefChanAPI UNIX m + , HasClientAPI StorageAPI UNIX m + , HasClientAPI PeerAPI UNIX m + , HasStorage m + ) => MakeDictM c m () +refchanEntries = do + + brief "requests all rechans that peer is subcribed to" + $ args [] + $ returns "list" "list of all refchans" + $ examples [qc| + +(hbs2:refchan:list) +("Atg67E6CPMJWKvR9BvwZTTEjg3Hjz4CYCaEARGANepGP" + "A5W6jPBjzvdpxaQ2e8xBLYaRZjPXzi4yX7xjC52gTiKk" + "EjjK7rpgRRJ4yzAhTcwis4XawwagCbmkns8n73ogY3uS") + |] + $ entry $ bindMatch "hbs2:refchan:list" $ \case + [] -> do + flip runContT pure do + api <- getClientAPI @PeerAPI @UNIX + r <- callService @RpcPollList2 api (Just "refchan", Nothing) + >>= orThrowUser "can't get refchan list" + pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r + + _ -> throwIO (BadFormException @c nil) + + + brief "reads refchan head block" + $ args [arg "symbol" "parsed|_", arg "string" "PUBKEY"] + $ returns "" "string" + $ examples [qc| + +(hbs2:refchan:head:get :parsed ExTZuEy2qVBRshWdSwfxeKcMmQLbK2f5NxRwhvXda9qd) +(version 2) +(quorum 1) +(wait 10) +(peer "5tZfGUoQ79EzFUvyyY5Wh1LzN2oaqhrn9kPnfk6ByHpf" 1) +(peer "35gKUG1mwBTr3tQpjWwR2kBYEnDmHxesoJL5Lj7tMjq3" 1) +(peer "5GnroAC8FXNRL8rcgJj6RTu9mt1AbuNd5MZVnDBcCKzb" 1) +(author "Gu5FxngYYwpRfCUS9DJBGyH3tvtjXFbcZ7CbxmJPWEGH") +(author "ExTZuEy2qVBRshWdSwfxeKcMmQLbK2f5NxRwhvXda9qd") +(reader "5UXrEhYECJ2kEQZZPEf4TisfWsLNdh2nGYQQz8X9ioMv") +(reader "CcRDzezX1XQdPxRMuMKzJkfHFB4yG7vGJeTYvScKkbP8") +; (head-extensions: (count: 0) (size 0)) + + +(hbs2:refchan:head:get :whatever ExTZuEy2qVBRshWdSwfxeKcMmQLbK2f5NxRwhvXda9qd) +HucjFUznHJeA2UYZCdUFHtnE3pTwhCW5Dp7LV3ArZBcr + + |] + $ entry $ bindMatch "hbs2:refchan:head:get" $ \case + [StringLike what, SignPubKeyLike puk] -> do + + flip runContT pure do + + callCC $ \exit -> do + + w <- lift (getRefChanHeadHash @UNIX puk) + + hx <- ContT $ maybe1 w (pure nil) + + case what of + "parsed" -> do + hdblk <- lift (Client.getRefChanHead @UNIX puk) + + exit $ mkStr (show $ pretty hdblk) + + _ -> exit $ mkStr (show $ pretty $ AsBase58 hx) + + pure nil + + + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "hbs2:refchan:head:update" $ \case + [SignPubKeyLike rchan, StringLike headFile] -> do + + sto <- getStorage + + rchanApi <- getClientAPI @RefChanAPI @UNIX + + rch <- liftIO (readFile headFile) + <&> fromStringMay @(RefChanHeadBlock L4Proto) + >>= orThrowUser "can't parse RefChanHeadBlock" + + creds <- runKeymanClient $ loadCredentials rchan + >>= orThrowUser "can't load credentials" + + let box = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) rch + + href <- writeAsMerkle sto (serialise box) + + callService @RpcRefChanHeadPost rchanApi (HashRef href) + >>= orThrowUser "can't post refchan head" + + pure nil + + _ -> throwIO (BadFormException @c nil) + + + entry $ bindMatch "hbs2:refchan:get" $ \case + [SignPubKeyLike rchan] -> do + + api <- getClientAPI @RefChanAPI @UNIX + + h <- callService @RpcRefChanGet api rchan + >>= orThrowUser "can't request refchan head" + + pure $ maybe nil (mkStr . show . pretty . AsBase58) h + + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "hbs2:refchan:create" $ \syn -> do + + peerApi <- getClientAPI @PeerAPI @UNIX + rchanApi <- getClientAPI @RefChanAPI @UNIX + sto <- getStorage + + rch <- case syn of + [StringLike headFile] -> do + liftIO (readFile headFile) + <&> fromStringMay @(RefChanHeadBlock L4Proto) + >>= orThrowUser "can't parse RefChanHeadBlock" + + [] -> do + poked <- callService @RpcPoke peerApi () + >>= orThrowUser "can't poke hbs2-peer" + <&> parseTop + >>= orThrowUser "invalid hbs2-peer attributes" + + ke <- [ x + | ListVal [SymbolVal "peer-key:", SignPubKeyLike x] <- poked + ] & headMay & orThrowUser "hbs2-peer key not found" + + let rch0 = refChanHeadDefault @L4Proto + & set refChanHeadPeers (HM.singleton ke 1) + & set refChanHeadAuthors (HS.singleton ke) + + pure rch0 + + _ -> throwIO (BadFormException @c nil) + + refchan <- keymanNewCredentials (Just "refchan") 0 + + creds <- runKeymanClient $ loadCredentials refchan + >>= orThrowUser "can't load credentials" + + let box = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) rch + + href <- writeAsMerkle sto (serialise box) + + callService @RpcPollAdd peerApi (refchan, "refchan", 17) + >>= orThrowUser "can't subscribe to refchan" + + callService @RpcRefChanHeadPost rchanApi (HashRef href) + >>= orThrowUser "can't post refchan head" + + let r = mkStr @c $ show $ "; refchan " <+> pretty (AsBase58 refchan) <> line + <> pretty rch + + pure r + + brief "prints refchan head example" + $ returns "nil" mempty + $ entry $ bindMatch "hbs2:refchan:head:example" $ nil_ $ \case + [] -> flip runContT pure do + + let rch0 = refChanHeadDefault @L4Proto + + api <- getClientAPI @PeerAPI @UNIX + + pips <- callService @RpcPeers api () + <&> either (const mempty) (HM.fromList . fmap ((,1) . fst) . take 3) + + + creds <- replicateM 3 (newCredentialsEnc @HBS2Basic 1) + + let authors = fmap (view peerSignPk) creds + & HS.fromList + + let readers = foldMap (view peerKeyring) creds + & fmap (view krPk) + & take 3 + & HS.fromList + + let rch = ( set refChanHeadPeers pips + . set refChanHeadAuthors authors + . set refChanHeadReaders readers + . set refChanHeadNotifiers authors + ) rch0 + + liftIO $ print $ + ";" <+> "this is an example of refchan head block config" + <> line + <> ";" <+> "edit it before applying" <> line + <> ";" <+> "set up the actual keys / credentials you need" <> line + <> line <> line + <> ";" <+> "(version INT) is the head block version" <> line + <> ";" <+> "the refchan head block will be set only" <>line + <> ";" <+> "if it's version if greater than the already existed one" <> line + <> line + + <> ";" <+> "(quorum INT) is a number of accept messages issued by peers" <> line + <> ";" <+> "to include propose message to the refchan" <> line + <> line + + <> ";" <+> "(wait INT) is an quorum wait time in seconds" <> line + <> line + + <> ";" <+> "(peer PUBKEY WEIGHT) sets the peer allowed for posting propose/accept messages" <> line + <> ";" <+> "PUBKEY is a SIGNATURE public key as base58 string" <> line + <> ";" <+> "only messages from that peers will be accepted" <> line + <> ";" <+> "WEIGHT is not used yet but reserved for the future" <> line + <> ";" <+> "this parameter is optional but there is should be some peers or" <> line + <> ";" <+> "all messages will be sent to nowhere" <> line + <> line + + <> ";" <+> "(author PUBKEY) adds 'author' i.e. key that is allowed to sign the propose message" <> line + <> ";" <+> "PUBKEY is a SIGNATURE public key as base58 string" <> line + <> ";" <+> "only the propose messages signed by one of thise keys will be accepted" <> line + <> line + + <> ";" <+> "(notifier PUBKEY) adds 'notifier' i.e. key that is allowed to sign the notify message" <> line + <> ";" <+> "PUBKEY is a SIGNATURE public key as base58 string" <> line + <> ";" <+> "only the propose messages signed by one of thise keys will be accepted" <> line + <> ";" <+> "notify messages are not written to the refchan merkle tree" <> line + <> ";" <+> "and they useful for implementing any sort of ephemeral messaging" <> line + <> ";" <+> "those clauses are OPTIONAL and may be omitted" <> line + <> line + + <> ";" <+> "(reader PUBKEY) adds 'author' i.e. key that is allowed to decrypt messages" <> line + <> ";" <+> "PUBKEY is a ENCRYPTION public key as base58 string" <> line + <> ";" <+> "NOTE: messages in a refchan are not encrypted by default" <> line + <> ";" <+> " it's totally up to an application for this refchan" <> line + <> ";" <+> " therefore this clause is just used for setting reader keys to" <> line + <> ";" <+> " implement any ACL/encrypting mechanism" <> line + <> ";" <+> " i.e. groupkey may be inherited from the RefChanHead block" <> line + <> ";" <+> " to encrypt data posted to a refchan" <> line + <> ";" <+> "those clauses are OPTIONAL and may be omitted" <> line + <> line + + <> pretty rch + + _ -> throwIO (BadFormException @C nil) + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs b/hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs new file mode 100644 index 00000000..859f98b4 --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/RefLog.hs @@ -0,0 +1,220 @@ +module HBS2.CLI.Run.RefLog where + +import HBS2.CLI.Prelude +import HBS2.CLI.Run.Internal +import HBS2.CLI.Run.Internal.KeyMan + +import HBS2.Data.Types.Refs +import HBS2.Merkle +import HBS2.Storage +import HBS2.Peer.RPC.Client +import HBS2.Peer.CLI.Detect +import HBS2.Peer.RPC.Client.Unix +import HBS2.Peer.RPC.API.Peer +import HBS2.Peer.RPC.API.RefLog +import HBS2.Peer.RPC.API.Storage + +import HBS2.Peer.Proto hiding (request) +import HBS2.Base58 +import HBS2.Net.Auth.Credentials +import HBS2.Net.Auth.Schema() + +import HBS2.KeyMan.Keys.Direct +import HBS2.KeyMan.App.Types + +import Codec.Serialise +import Data.Coerce +import Data.Either +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BS8 +import Data.ByteString (ByteString) +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.ByteString.Lazy qualified as LBS +import Data.Text.Encoding qualified as TE +import Data.Text qualified as Text +import Control.Monad.Trans.Cont + +import Streaming.Prelude qualified as S + +getCredentialsForReflog :: MonadUnliftIO m => RefLogKey 'HBS2Basic -> m (PeerCredentials 'HBS2Basic) +getCredentialsForReflog reflog = do + runKeymanClient (loadCredentials reflog) + >>= orThrowUser "credentials not found" + +mkRefLogUpdateFrom :: (MonadUnliftIO m) => RefLogKey 'HBS2Basic -> m ByteString -> m (RefLogUpdate L4Proto) +mkRefLogUpdateFrom reflog mbs = do + what <- getCredentialsForReflog reflog + let puk = view peerSignPk what + let privk = view peerSignSk what + txraw <- mbs + makeRefLogUpdate @L4Proto @'HBS2Basic (coerce puk) privk txraw + + +reflogEntries :: forall c m . ( IsContext c + , Exception (BadFormException c) + , MonadUnliftIO m + , HasStorage m + , HasClientAPI PeerAPI UNIX m + , HasClientAPI RefLogAPI UNIX m + , HasClientAPI StorageAPI UNIX m + ) => MakeDictM c m () +reflogEntries = do + + entry $ bindMatch "hbs2:reflog:create" $ \case + [] -> do + reflog <- keymanNewCredentials (Just "reflog") 0 + + api <- getClientAPI @PeerAPI @UNIX + void $ callService @RpcPollAdd api (reflog, "reflog", 31) + pure $ mkStr (show $ pretty (AsBase58 reflog)) + + _ -> throwIO (BadFormException @C nil) + + entry $ bindMatch "hbs2:reflog:add" $ \case + [SignPubKeyLike reflog] -> do + -- reflog <- keymanNewCredentials (Just "reflog") 0 + + api <- getClientAPI @PeerAPI @UNIX + void $ callService @RpcPollAdd api (reflog, "reflog", 31) + pure $ mkStr (show $ pretty (AsBase58 reflog)) + + _ -> throwIO (BadFormException @C nil) + + + + entry $ bindMatch "hbs2:reflog:tx:annhashref:create" $ \case + [StringLike puk, StringLike hash] -> do + reflog <- orThrowUser "bad reflog key" (fromStringMay puk) + sto <- getStorage + hashref <- orThrowUser "bad hash" (fromStringMay @HashRef hash) + void $ hasBlock sto (fromHashRef hashref) `orDie` "no block" + let sref = AnnotatedHashRef Nothing hashref + rlu <- mkRefLogUpdateFrom reflog (pure $ LBS.toStrict $ serialise sref) <&> serialise + pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)] + + _ -> throwIO (BadFormException @C nil) + + + entry $ bindMatch "hbs2:reflog:tx:post" $ nil_ \case + [BlobLike blob] -> do + caller <- getClientAPI @RefLogAPI @UNIX + wtf <- deserialiseOrFail @(RefLogUpdate L4Proto) (LBS.fromStrict blob) + & orThrowUser "invalid tx" + void $ callService @RpcRefLogPost caller wtf + + _ -> throwIO (BadFormException @C nil) + + entry $ bindMatch "hbs2:reflog:tx:seqref:create" $ \case + [StringLike puk, LitIntVal sn, StringLike hash] -> do + reflog <- orThrowUser "bad reflog key" (fromStringMay puk) + sto <- getStorage + hashref <- orThrowUser "bad hash" (fromStringMay @HashRef hash) + void $ hasBlock sto (fromHashRef hashref) `orDie` "no block" + let sref = SequentialRef sn (AnnotatedHashRef Nothing hashref) + rlu <- mkRefLogUpdateFrom reflog (pure $ LBS.toStrict $ serialise sref) <&> serialise + pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)] + + _ -> throwIO (BadFormException @C nil) + + entry $ bindMatch "hbs2:reflog:tx:raw:create" $ \case + [SymbolVal "stdin", SignPubKeyLike reflog] -> do + + rlu <- mkRefLogUpdateFrom (RefLogKey reflog) ( liftIO BS.getContents ) + <&> serialise + + pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)] + + [LitStrVal s, StringLike rlo] -> do + reflog <- orThrowUser "bad reflog" (fromStringMay rlo) + + rlu <- mkRefLogUpdateFrom reflog ( pure (BS8.pack (Text.unpack s)) ) + <&> serialise + + pure $ mkForm "blob" [mkStr (LBS8.unpack rlu)] + + _ -> throwIO (BadFormException @C nil) + + + entry $ bindMatch "hbs2:reflog:get" $ \case + [StringLike puk] -> do + + flip runContT pure do + reflog <- orThrowUser "bad reflog key" (fromStringMay puk) + api <- getClientAPI @RefLogAPI @UNIX + what <- callService @RpcRefLogGet api reflog + >>= orThrowUser "can't get reflog" + pure $ mkStr (show $ pretty what) + + _ -> throwIO (BadFormException @C nil) + + entry $ bindMatch "hbs2:reflog:fetch" $ \case + [StringLike puk] -> do + flip runContT pure do + reflog <- orThrowUser "bad reflog key" (fromStringMay puk) + api <- getClientAPI @RefLogAPI @UNIX + void $ callService @RpcRefLogFetch api reflog + pure $ mkStr "okay" + + _ -> throwIO (BadFormException @C nil) + + entry $ bindMatch "hbs2:reflog:list" $ \case + [] -> do + flip runContT pure do + api <- getClientAPI @PeerAPI @UNIX + r <- callService @RpcPollList2 api (Just "reflog", Nothing) + >>= orThrowUser "can't get reflog list" + pure $ mkList $ fmap (mkStr . show . pretty . AsBase58 . view _1) r + + _ -> throwIO (BadFormException @C nil) + + + entry $ bindMatch "hbs2:reflog:tx:seqref:decode" $ \case + [ListVal [SymbolVal "blob", LitStrVal s]] -> do + let lbs = Text.unpack s & BS8.pack & LBS.fromStrict + + SequentialRef n (AnnotatedHashRef _ h) <- deserialiseOrFail @SequentialRef lbs + & orThrowUser "FUCKED" + + pure $ mkForm "seqref" [mkInt n, mkStr (show $ pretty h)] + + e -> throwIO $ BadFormException @c nil + + entry $ bindMatch "hbs2:reflog:tx:list" $ \case + [e, SignPubKeyLike puk] -> do + + flip runContT pure do + + callCC \exit -> do + + api <- getClientAPI @RefLogAPI @UNIX + sto <- getStorage + + r <- callService @RpcRefLogGet api puk + >>= orThrowUser "can't get reflog value" + + rlh <- ContT $ maybe1 r (pure nil) + + hashes <- S.toList_ do + walkMerkle @[HashRef] (fromHashRef rlh) (getBlock sto) $ \case + (Left _) -> lift $ exit nil + (Right (hs :: [HashRef])) -> S.each hs + + rr <- forM hashes $ \ha -> do + + tx <- getBlock sto (coerce ha) + >>= orThrowUser "missed-block" + <&> deserialiseOrFail @(RefLogUpdate L4Proto) + >>= orThrowUser "invalid-tx" + + let bs = view refLogUpdData tx + let bs8 = BS8.unpack bs + + lift $ apply_ e [mkForm "blob" [mkStr bs8]] + + pure $ mkList rr + + _ -> throwIO (BadFormException @C nil) + + + + diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Sigil.hs b/hbs2-cli/lib/HBS2/CLI/Run/Sigil.hs new file mode 100644 index 00000000..81ca6b46 --- /dev/null +++ b/hbs2-cli/lib/HBS2/CLI/Run/Sigil.hs @@ -0,0 +1,82 @@ +module HBS2.CLI.Run.Sigil where + +import HBS2.CLI.Prelude +import HBS2.CLI.Run.Internal + +import HBS2.Base58 +import HBS2.Data.Types.SignedBox +import HBS2.Net.Auth.Credentials +import HBS2.Net.Auth.Credentials.Sigil + +import Data.List qualified as L +import Data.ByteString.Char8 qualified as BS8 +import Data.Text qualified as Text +import Lens.Micro.Platform + + +sigilEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m) => MakeDictM c m () +sigilEntries = do + + entry $ bindMatch "hbs2:sigil:sign-pubkey" $ \case + [ ListVal (SymbolVal sigil : (hasKey "sign-pubkey" -> Just s)) ] -> do + pure s + + _ -> throwIO $ BadFormException @C nil + + + entry $ bindMatch "hbs2:sigil:encrypt-pubkey" $ \case + [ ListVal (SymbolVal sigil : (hasKey "encrypt-pubkey" -> Just s)) ] -> do + pure s + + _ -> throwIO $ BadFormException @C nil + + entry $ bindMatch "hbs2:sigil:parse" $ \case + [StringLike s] -> do + + let bs = BS8.pack s + sigil <- pure (parseSerialisableFromBase58 @(Sigil 'HBS2Basic) bs) + `orDie` "parse sigil failed" + + (_,sd) <- pure (unboxSignedBox0 @(SigilData 'HBS2Basic) (sigilData sigil)) + `orDie` "signature check failed" + + pure (parseTop $ show $ parens ("sigil" <> line <> indent 2 (vcat $ [pretty sigil, pretty sd]))) + `orDie` "bad sigil" + <&> head + + _ -> throwIO $ BadFormException @C nil + + entry $ bindMatch "hbs2:sigil:create-from-keyring" $ \syn -> do + + args <- case syn of + [ 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 + + let lbs = BS8.pack (snd args) + + cred <- pure (parseCredentials @'HBS2Basic (AsCredFile lbs)) + `orDie` "bad keyring data" + + let es = zip [0..] + [ p | KeyringEntry p _ _ + <- view peerKeyring cred + ] + + enc <- pure (fst args es) + `orDie` "key not found" + + 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 [ k + | e@(_,k) <- xs + , L.isPrefixOf s (show $ pretty (AsBase58 k)) + ] + + diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index 1493aeec..680caf41 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -94,6 +94,7 @@ library , HBS2.Polling , HBS2.Hash , HBS2.Merkle + , HBS2.Merkle.MetaData , HBS2.Net.Auth.Schema , HBS2.Net.Auth.GroupKeyAsymm , HBS2.Net.Auth.GroupKeySymm @@ -105,6 +106,7 @@ library , HBS2.Net.Messaging.UDP , HBS2.Net.Messaging.TCP , HBS2.Net.Messaging.Unix + , HBS2.Net.Messaging.Pipe , HBS2.Net.Messaging.Stream , HBS2.Net.Messaging.Encrypted.RandomPrefix , HBS2.Net.Messaging.Encrypted.ByPass @@ -126,10 +128,6 @@ library , HBS2.System.Logger.Simple.ANSI , HBS2.System.Logger.Simple.Class , HBS2.System.Dir - , HBS2.Net.Dialog.Core - , HBS2.Net.Dialog.Client - , HBS2.Net.Dialog.Helpers.List - , HBS2.Net.Dialog.Helpers.Streaming , HBS2.Misc.PrettyStuff , HBS2.Version @@ -196,6 +194,7 @@ library , time , transformers , uniplate + , unix , unordered-containers , unliftio , unliftio-core @@ -216,7 +215,6 @@ test-suite test -- , TestUniqProtoId , FakeMessaging , HasProtocol - , DialogSpec , TestScheduled , TestDerivedKey diff --git a/hbs2-core/lib/HBS2/Data/Bundle.hs b/hbs2-core/lib/HBS2/Data/Bundle.hs index 58433b6b..a3bc2851 100644 --- a/hbs2-core/lib/HBS2/Data/Bundle.hs +++ b/hbs2-core/lib/HBS2/Data/Bundle.hs @@ -26,8 +26,8 @@ import Streaming() {- HLINT ignore "Use newtype instead of data" -} -data BundleRefValue e = - BundleRefValue (SignedBox BundleRef e) +data BundleRefValue s = + BundleRefValue (SignedBox BundleRef s) deriving stock (Generic) instance ForSignedBox e => Serialise (BundleRefValue e) @@ -39,13 +39,13 @@ data BundleRef = instance Serialise BundleRef -makeBundleRefValue :: forall e . (ForSignedBox e, Signatures (Encryption e)) - => PubKey 'Sign (Encryption e) - -> PrivKey 'Sign (Encryption e) +makeBundleRefValue :: forall s . (ForSignedBox s, Signatures s) + => PubKey 'Sign s + -> PrivKey 'Sign s -> BundleRef - -> BundleRefValue e + -> BundleRefValue s -makeBundleRefValue pk sk ref = BundleRefValue $ makeSignedBox @e pk sk ref +makeBundleRefValue pk sk ref = BundleRefValue $ makeSignedBox @s pk sk ref -- у нас может быть много способов хранить данные: -- сжимать целиком (эффективно, но медленно) diff --git a/hbs2-core/lib/HBS2/Data/Types/Refs.hs b/hbs2-core/lib/HBS2/Data/Types/Refs.hs index 1b4b564f..63f40b6e 100644 --- a/hbs2-core/lib/HBS2/Data/Types/Refs.hs +++ b/hbs2-core/lib/HBS2/Data/Types/Refs.hs @@ -23,6 +23,10 @@ newtype HashRef = HashRef { fromHashRef :: Hash HbSync } deriving newtype (Eq,Ord,IsString,Pretty,Hashable,Hashed HbSync) deriving stock (Data,Generic,Show) +newtype TaggedHashRef t = TaggedHashRef { fromTaggedHashRef :: HashRef } + deriving newtype (Eq,Ord,IsString,Pretty,Hashable,Hashed HbSync) + deriving stock (Data,Generic,Show) + instance Pretty (AsBase58 HashRef) where pretty (AsBase58 x) = pretty x @@ -38,6 +42,9 @@ newtype TheHashRef t = TheHashRef { fromTheHashRef :: Hash HbSync } instance Pretty (AsBase58 (TheHashRef t)) where pretty (AsBase58 x) = pretty x +instance Pretty (AsBase58 (TaggedHashRef t)) where + pretty (AsBase58 x) = pretty x + instance FromStringMaybe (TheHashRef t) where fromStringMay = fmap TheHashRef . fromStringMay @@ -65,6 +72,7 @@ data SequentialRef = instance Serialise AnnotatedHashRef instance Serialise SequentialRef instance Serialise HashRef +instance Serialise (TaggedHashRef e) type IsRefPubKey s = ( Eq (PubKey 'Sign s) diff --git a/hbs2-core/lib/HBS2/Data/Types/SignedBox.hs b/hbs2-core/lib/HBS2/Data/Types/SignedBox.hs index c50bb115..62f4e061 100644 --- a/hbs2-core/lib/HBS2/Data/Types/SignedBox.hs +++ b/hbs2-core/lib/HBS2/Data/Types/SignedBox.hs @@ -11,62 +11,62 @@ import Data.Hashable import Data.ByteString (ByteString) import Data.ByteString.Lazy qualified as LBS import Control.Monad.Trans.Maybe -import Data.Function import Control.Monad.Identity -data SignedBox p e = - SignedBox (PubKey 'Sign (Encryption e)) ByteString (Signature (Encryption e)) +data SignedBox p s = + SignedBox (PubKey 'Sign s) ByteString (Signature s) deriving stock (Generic) deriving stock instance - ( Eq (PubKey 'Sign (Encryption e)) - , Eq (Signature (Encryption e)) - ) => Eq (SignedBox p e) + ( Eq (PubKey 'Sign s) + , Eq (Signature s) + ) => Eq (SignedBox p s) -instance ( Eq (PubKey 'Sign (Encryption e)) - , Eq (Signature (Encryption e)) - , Serialise (SignedBox p e) - ) => Hashable (SignedBox p e) where +instance ( Eq (PubKey 'Sign s) + , Eq (Signature s) + , Serialise (SignedBox p s) + ) => Hashable (SignedBox p s) where hashWithSalt salt box = hashWithSalt salt (serialise box) -type ForSignedBox e = ( Serialise ( PubKey 'Sign (Encryption e)) - , FromStringMaybe (PubKey 'Sign (Encryption e)) - , Serialise (Signature (Encryption e)) - , Signatures (Encryption e) - , Hashable (PubKey 'Sign (Encryption e)) +type ForSignedBox s = ( Serialise ( PubKey 'Sign s) + , FromStringMaybe (PubKey 'Sign s) + , Serialise (Signature s) + , Signatures s + , Hashable (PubKey 'Sign s) ) -instance ForSignedBox e => Serialise (SignedBox p e) +instance ForSignedBox s => Serialise (SignedBox p s) -makeSignedBox :: forall e p . (Serialise p, ForSignedBox e, Signatures (Encryption e)) - => PubKey 'Sign (Encryption e) - -> PrivKey 'Sign (Encryption e) +makeSignedBox :: forall s p . (Serialise p, ForSignedBox s, Signatures s) + => PubKey 'Sign s + -> PrivKey 'Sign s -> p - -> SignedBox p e + -> SignedBox p s -makeSignedBox pk sk msg = SignedBox @p @e pk bs sign +makeSignedBox pk sk msg = SignedBox @p @s pk bs sign where bs = LBS.toStrict (serialise msg) - sign = makeSign @(Encryption e) sk bs + sign = makeSign @s sk bs -unboxSignedBox0 :: forall p e . (Serialise p, ForSignedBox e, Signatures (Encryption e)) - => SignedBox p e - -> Maybe (PubKey 'Sign (Encryption e), p) +unboxSignedBox0 :: forall p s . (Serialise p, ForSignedBox s, Signatures s) + => SignedBox p s + -> Maybe (PubKey 'Sign s, p) unboxSignedBox0 (SignedBox pk bs sign) = runIdentity $ runMaybeT do - guard $ verifySign @(Encryption e) pk sign bs + guard $ verifySign @s pk sign bs p <- MaybeT $ pure $ deserialiseOrFail @p (LBS.fromStrict bs) & either (const Nothing) Just pure (pk, p) -unboxSignedBox :: forall p e . (Serialise p, ForSignedBox e, Signatures (Encryption e)) +unboxSignedBox :: forall p s . (Serialise p, ForSignedBox s, Signatures s) => LBS.ByteString - -> Maybe (PubKey 'Sign (Encryption e), p) + -> Maybe (PubKey 'Sign s, p) unboxSignedBox bs = runIdentity $ runMaybeT do - box <- MaybeT $ pure $ deserialiseOrFail @(SignedBox p e) bs + box <- MaybeT $ pure $ deserialiseOrFail @(SignedBox p s) bs & either (pure Nothing) Just MaybeT $ pure $ unboxSignedBox0 box + diff --git a/hbs2-core/lib/HBS2/Merkle/MetaData.hs b/hbs2-core/lib/HBS2/Merkle/MetaData.hs new file mode 100644 index 00000000..59494f23 --- /dev/null +++ b/hbs2-core/lib/HBS2/Merkle/MetaData.hs @@ -0,0 +1,81 @@ +module HBS2.Merkle.MetaData where + +import HBS2.Prelude +import HBS2.OrDie +import HBS2.Data.Types.Refs +import HBS2.Merkle +import HBS2.Storage +import HBS2.Data.Types.SmallEncryptedBlock +import HBS2.Net.Auth.GroupKeySymm as G +import HBS2.Storage.Operations.Class + +import Data.Coerce +import Data.ByteString.Lazy qualified as LBS +import Codec.Serialise +import Data.Text.Encoding qualified as TE +import Control.Monad.Except +import Control.Monad.Trans.Maybe + +import UnliftIO + +{- HLINT ignore "Functor law" -} + +extractMetaData :: forall s m . (MonadIO m, ForGroupKeySymm s, MonadError OperationError m) + + => (GroupKey 'Symm s -> m (Maybe GroupSecret)) + -> AnyStorage + -> HashRef + -> m Text +extractMetaData fk sto hash = do + + headBlock <- getBlock sto (coerce hash) + >>= orThrowError MissedBlockError + <&> deserialiseOrFail @(MTreeAnn [HashRef]) + >>= orThrowError UnsupportedFormat + + case headBlock of + MTreeAnn { _mtaMeta = ShortMetadata s } -> do + pure s + + MTreeAnn { _mtaMeta = AnnHashRef h, _mtaCrypt = NullEncryption } -> do + getBlock sto h + >>= orThrowError MissedBlockError + <&> LBS.toStrict + <&> TE.decodeUtf8 + + MTreeAnn { _mtaMeta = AnnHashRef h } -> do + getBlock sto h + >>= orThrowError MissedBlockError + <&> deserialiseOrFail @(SmallEncryptedBlock AnnMetaData) + >>= orThrowError UnsupportedFormat + >>= G.decryptBlock @_ @s sto fk + >>= \case + ShortMetadata s -> pure s + _ -> throwError UnsupportedFormat + + _ -> throwError UnsupportedFormat + + +loadGroupKeyForTree :: ( ForGroupKeySymm s + , MonadIO m + ) + => AnyStorage + -> HashRef + -> m (Maybe (GroupKey 'Symm s)) + +loadGroupKeyForTree sto h = do + + runMaybeT do + + headBlock <- getBlock sto (fromHashRef h) + >>= toMPlus + <&> deserialiseOrFail @(MTreeAnn [HashRef]) + >>= toMPlus + + gkh <- case _mtaCrypt headBlock of + (EncryptGroupNaClSymm h1 _) -> pure (HashRef h1) + _ -> mzero + + G.loadGroupKeyMaybe sto gkh >>= toMPlus + + diff --git a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs b/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs index 2c9a5615..4f13c814 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs @@ -15,6 +15,7 @@ import HBS2.Net.Auth.Schema import HBS2.Base58 import HBS2.Hash +import Control.Applicative import Codec.Serialise import Crypto.Saltine.Core.Sign (Keypair(..)) import Crypto.Saltine.Core.Sign qualified as Sign @@ -28,14 +29,10 @@ import Data.List.Split (chunksOf) import Data.List qualified as List import Lens.Micro.Platform import Data.Kind +import Control.Monad -type instance PubKey 'Sign HBS2Basic = Sign.PublicKey -type instance PrivKey 'Sign HBS2Basic = Sign.SecretKey -type instance PubKey 'Encrypt HBS2Basic = Encrypt.PublicKey -type instance PrivKey 'Encrypt HBS2Basic = Encrypt.SecretKey - -instance Signatures HBS2Basic where - type Signature HBS2Basic = Sign.Signature +instance Signatures 'HBS2Basic where + type Signature 'HBS2Basic = Sign.Signature makeSign = Sign.signDetached verifySign = Sign.signVerifyDetached @@ -68,10 +65,10 @@ class AsymmPubKey e ~ PubKey 'Encrypt e => Asymm e where class HasCredentials s m where getCredentials :: m (PeerCredentials s) -data KeyringEntry e = +data KeyringEntry s = KeyringEntry - { _krPk :: PubKey 'Encrypt e - , _krSk :: PrivKey 'Encrypt e + { _krPk :: PubKey 'Encrypt s + , _krSk :: PrivKey 'Encrypt s , _krDesc :: Maybe Text } deriving stock (Generic) @@ -95,23 +92,24 @@ makeLenses 'KeyringEntry makeLenses 'PeerCredentials type ForHBS2Basic s = ( Signatures s - , PrivKey 'Sign s ~ Sign.SecretKey - , PubKey 'Sign s ~ Sign.PublicKey - , Eq (PubKey 'Encrypt HBS2Basic) - , IsEncoding (PubKey 'Encrypt s) - , Eq (PubKey 'Encrypt HBS2Basic) - , s ~ HBS2Basic - ) + , PrivKey 'Sign s ~ Sign.SecretKey + , PubKey 'Sign s ~ Sign.PublicKey + , Eq (PubKey 'Encrypt 'HBS2Basic) + , IsEncoding (PubKey 'Encrypt s) + , Eq (PubKey 'Encrypt 'HBS2Basic) + , s ~ 'HBS2Basic + ) -type SerialisedCredentials e = ( Serialise (PrivKey 'Sign e) - , Serialise (PubKey 'Sign e) - , Serialise (PubKey 'Encrypt e) - , Serialise (PrivKey 'Encrypt e) - ) +type SerialisedCredentials ( s :: CryptoScheme ) = + ( Serialise (PrivKey 'Sign s) + , Serialise (PubKey 'Sign s) + , Serialise (PubKey 'Encrypt s) + , Serialise (PrivKey 'Encrypt s) + ) -instance SerialisedCredentials e => Serialise (KeyringEntry e) +instance SerialisedCredentials s => Serialise (KeyringEntry s) -instance SerialisedCredentials e => Serialise (PeerCredentials e) +instance SerialisedCredentials s => Serialise (PeerCredentials s) newtype AsCredFile a = AsCredFile a @@ -130,6 +128,17 @@ newCredentials = do pure $ PeerCredentials @s (secretKey pair) (publicKey pair) mempty +newCredentialsEnc :: forall s m . ( MonadIO m + , Signatures s + , PrivKey 'Sign s ~ Sign.SecretKey + , PubKey 'Sign s ~ Sign.PublicKey + , PrivKey 'Encrypt s ~ Encrypt.SecretKey + , PubKey 'Encrypt s ~ Encrypt.PublicKey + ) => Int -> m (PeerCredentials s) +newCredentialsEnc n = do + cred0 <- newCredentials @s + foldM (\cred _ -> addKeyPair Nothing cred) cred0 [1..n] + newKeypair :: forall s m . ( MonadIO m , PrivKey 'Encrypt s ~ Encrypt.SecretKey , PubKey 'Encrypt s ~ Encrypt.PublicKey @@ -164,7 +173,13 @@ parseCredentials :: forall s . ( -- ForHBS2Basic s SerialisedCredentials s ) => AsCredFile ByteString -> Maybe (PeerCredentials s) -parseCredentials (AsCredFile bs) = parseSerialisableFromBase58 bs +parseCredentials (AsCredFile bs) = + parseSerialisableFromBase58 bs <|> parseSerialisableFromCbor (LBS.fromStrict bs) + +parseSerialisableFromCbor :: SerialisedCredentials s => LBS.ByteString -> Maybe (PeerCredentials s) +parseSerialisableFromCbor = fromCbor + where fromCbor s = deserialiseOrFail s + & either (const Nothing) Just parseSerialisableFromBase58 :: Serialise a => ByteString -> Maybe a parseSerialisableFromBase58 bs = maybe1 b58_1 Nothing fromCbor @@ -234,11 +249,11 @@ instance IsEncoding (PubKey 'Encrypt e) pretty ke = fill 10 "pub-key:" <+> pretty (AsBase58 (Crypto.encode (view krPk ke))) -instance Asymm HBS2Basic where - type AsymmKeypair HBS2Basic = Encrypt.Keypair - type AsymmPrivKey HBS2Basic = Encrypt.SecretKey - type AsymmPubKey HBS2Basic = Encrypt.PublicKey - type CommonSecret HBS2Basic = Encrypt.CombinedKey +instance Asymm 'HBS2Basic where + type AsymmKeypair 'HBS2Basic = Encrypt.Keypair + type AsymmPrivKey 'HBS2Basic = Encrypt.SecretKey + type AsymmPubKey 'HBS2Basic = Encrypt.PublicKey + type CommonSecret 'HBS2Basic = Encrypt.CombinedKey asymmNewKeypair = liftIO Encrypt.newKeypair privKeyFromKeypair = Encrypt.secretKey pubKeyFromKeypair = Encrypt.publicKey diff --git a/hbs2-core/lib/HBS2/Net/Auth/Credentials/Sigil.hs b/hbs2-core/lib/HBS2/Net/Auth/Credentials/Sigil.hs index 2f08a989..39926589 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/Credentials/Sigil.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/Credentials/Sigil.hs @@ -26,9 +26,9 @@ import Lens.Micro.Platform -- Contains an encryption public key, optional additional information, -- and a possible reference to an additional information block. -data SigilData e = +data SigilData s = SigilData - { sigilDataEncKey :: PubKey 'Encrypt (Encryption e) + { sigilDataEncKey :: PubKey 'Encrypt s , sigilDataInfo :: Maybe Text , sigilDataExt :: Maybe HashRef } @@ -40,34 +40,34 @@ data SigilData e = -- Includes a signature public key and signed 'SigilData', -- ensuring user authentication and verification. -data Sigil e = +data Sigil s = Sigil - { sigilSignPk :: PubKey 'Sign (Encryption e) - , sigilData :: SignedBox (SigilData e) e + { sigilSignPk :: PubKey 'Sign s + , sigilData :: SignedBox (SigilData s) s } deriving stock (Generic) -type ForSigil e = ( Serialise (PubKey 'Encrypt (Encryption e)) - , Serialise (PubKey 'Sign (Encryption e)) - , Serialise (Signature (Encryption e)) - , Signatures (Encryption e) - , Hashable (PubKey 'Sign (Encryption e)) - , IsEncoding (PubKey 'Encrypt (Encryption e)) - , Eq (PubKey 'Encrypt (Encryption e)) - , FromStringMaybe (PubKey 'Sign (Encryption e)) +type ForSigil s = ( Serialise (PubKey 'Encrypt s) + , Serialise (PubKey 'Sign s) + , Serialise (Signature s) + , Signatures s + , Hashable (PubKey 'Sign s) + , IsEncoding (PubKey 'Encrypt s) + , Eq (PubKey 'Encrypt s) + , FromStringMaybe (PubKey 'Sign s) ) -type ForPrettySigil e = - ( IsEncoding (PubKey 'Encrypt (Encryption e)) - , Pretty (AsBase58 (PubKey 'Sign (Encryption e))) +type ForPrettySigil s = + ( IsEncoding (PubKey 'Encrypt s) + , Pretty (AsBase58 (PubKey 'Sign s)) ) -instance ForSigil e => Serialise (SigilData e) -instance ForSigil e => Serialise (Sigil e) +instance ForSigil s => Serialise (SigilData s) +instance ForSigil s => Serialise (Sigil s) -instance ForPrettySigil e => Pretty (SigilData e) where +instance ForPrettySigil s => Pretty (SigilData s) where pretty s = vcat $ [ parens ("encrypt-pubkey" <+> dquotes epk) ] <> catMaybes [pinfo, pext] where @@ -75,7 +75,7 @@ instance ForPrettySigil e => Pretty (SigilData e) where pinfo = sigilDataInfo s >>= \x -> pure $ parens ("info" <+> dquotes (pretty x)) pext = sigilDataExt s >>= \x -> pure $ parens ("ext" <+> dquotes (pretty x)) -instance ForPrettySigil e => Pretty (Sigil e) where +instance ForPrettySigil s => Pretty (Sigil s) where pretty s = vcat [ parens ("sign-pubkey" <+> psk) ] @@ -83,12 +83,12 @@ instance ForPrettySigil e => Pretty (Sigil e) where psk = dquotes (pretty (AsBase58 (sigilSignPk s))) -- Nothing, если ключ отсутствует в Credentials -makeSigilFromCredentials :: forall e . ForSigil e - => PeerCredentials (Encryption e) - -> PubKey 'Encrypt (Encryption e) +makeSigilFromCredentials :: forall s . ForSigil s + => PeerCredentials s + -> PubKey 'Encrypt s -> Maybe Text -> Maybe HashRef - -> Maybe (Sigil e) + -> Maybe (Sigil s) makeSigilFromCredentials cred pk i ha = runIdentity $ runMaybeT do @@ -102,7 +102,7 @@ makeSigilFromCredentials cred pk i ha = runIdentity $ runMaybeT do let sd = SigilData ke i ha - let box = makeSignedBox @e ppk psk sd + let box = makeSignedBox @s ppk psk sd let sigil = Sigil { sigilSignPk = view peerSignPk cred @@ -112,7 +112,7 @@ makeSigilFromCredentials cred pk i ha = runIdentity $ runMaybeT do pure sigil -instance ForSigil e => Pretty (AsBase58 (Sigil e)) where +instance ForSigil s => Pretty (AsBase58 (Sigil s)) where pretty (AsBase58 s) = "# sigil file. public data" <> line <> sd where sd = vcat $ fmap pretty diff --git a/hbs2-core/lib/HBS2/Net/Auth/GroupKeyAsymm.hs b/hbs2-core/lib/HBS2/Net/Auth/GroupKeyAsymm.hs index 5c41f460..f1a23734 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/GroupKeyAsymm.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/GroupKeyAsymm.hs @@ -8,7 +8,6 @@ import HBS2.Base58 import HBS2.Data.Types import HBS2.Data.Types.EncryptedBox import HBS2.Net.Auth.Credentials -import HBS2.Net.Proto.Types import HBS2.Prelude.Plated import Codec.Serialise @@ -21,20 +20,18 @@ import Data.ByteString.Char8 (ByteString) import Data.List.Split (chunksOf) -type ForAccessKey s = ( Crypto.IsEncoding (PubKey 'Encrypt s) - , Serialise (PubKey 'Encrypt s) - , Serialise (PubKey 'Sign s) - , Serialise (PrivKey 'Sign s) - , Serialise (PrivKey 'Encrypt s) - ) +type ForAccessKey (s :: CryptoScheme) = ( Crypto.IsEncoding (PubKey 'Encrypt s) + , Serialise (PubKey 'Encrypt s) + , Serialise (PubKey 'Sign s) + , Serialise (PrivKey 'Sign s) + , Serialise (PrivKey 'Encrypt s) + ) ---- +data family AccessKey ( s :: CryptoScheme ) -data family AccessKey s - -newtype instance AccessKey s = +newtype instance AccessKey (s :: CryptoScheme) = AccessKeyNaClAsymm { permitted :: [(PubKey 'Encrypt s, EncryptedBox (KeyringEntry s))] } diff --git a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs index 16d4a24a..59404ee1 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/GroupKeySymm.hs @@ -13,11 +13,13 @@ import HBS2.Base58 import HBS2.Data.Types.EncryptedBox import HBS2.Data.Types.SmallEncryptedBlock import HBS2.Data.Types.Refs +import HBS2.Net.Auth.Schema import HBS2.Hash import HBS2.Merkle import HBS2.Data.Detect import HBS2.Net.Auth.Credentials import HBS2.Net.Proto.Types +import HBS2.Storage hiding (Key) import HBS2.Storage.Operations.Class import HBS2.Storage.Operations.ByteString import HBS2.Storage(Storage(..)) @@ -96,14 +98,17 @@ data instance ToEncrypt 'Symm s LBS.ByteString = } deriving (Generic) -type ForGroupKeySymm s = ( Eq (PubKey 'Encrypt s) - , PubKey 'Encrypt s ~ AK.PublicKey - , PrivKey 'Encrypt s ~ AK.SecretKey - , Serialise (PubKey 'Encrypt s) - , Serialise GroupSecret - , Serialise SK.Nonce - , FromStringMaybe (PubKey 'Encrypt s) - ) +type ForGroupKeySymm (s :: CryptoScheme ) = + ( + -- Eq (PubKey 'Encrypt s) + -- , PubKey 'Encrypt s + -- , PrivKey 'Encrypt s + Serialise (PubKey 'Encrypt s) + , Serialise GroupSecret + , Serialise SK.Nonce + , FromStringMaybe (PubKey 'Encrypt s) + , Hashable (PubKey 'Encrypt s) + ) instance ForGroupKeySymm s => Serialise (GroupKey 'Symm s) @@ -142,7 +147,7 @@ instance ( Serialise (GroupKey 'Symm s) pretty . B8.unpack . toBase58 . LBS.toStrict . serialise $ c -generateGroupKey :: forall s m . (ForGroupKeySymm s, MonadIO m) +generateGroupKey :: forall s m . (ForGroupKeySymm s, MonadIO m, PubKey 'Encrypt s ~ AK.PublicKey) => Maybe GroupSecret -> [PubKey 'Encrypt s] -> m (GroupKey 'Symm s) @@ -155,7 +160,10 @@ generateGroupKey mbk pks = GroupKeySymm <$> create box <- liftIO $ AK.boxSeal pk (LBS.toStrict $ serialise sk) <&> EncryptedBox pure (pk, box) -lookupGroupKey :: ForGroupKeySymm s +lookupGroupKey :: forall s . ( ForGroupKeySymm s + , PubKey 'Encrypt s ~ AK.PublicKey + , PrivKey 'Encrypt s ~ AK.SecretKey + ) => PrivKey 'Encrypt s -> PubKey 'Encrypt s -> GroupKey 'Symm s @@ -163,9 +171,7 @@ lookupGroupKey :: ForGroupKeySymm s lookupGroupKey sk pk gk = runIdentity $ runMaybeT do (EncryptedBox bs) <- MaybeT $ pure $ HashMap.lookup pk (recipients gk) - -- error "FOUND SHIT!" gkBs <- MaybeT $ pure $ AK.boxSealOpen pk sk bs - -- error $ "DECRYPTED SHIT!" MaybeT $ pure $ deserialiseOrFail (LBS.fromStrict gkBs) & either (const Nothing) Just @@ -278,8 +284,8 @@ instance ( MonadIO m , MonadError OperationError m , h ~ HbSync , Storage s h ByteString m + , sch ~ 'HBS2Basic -- TODO: why? - , sch ~ HBS2Basic ) => MerkleReader (ToDecrypt 'Symm sch ByteString) s h m where data instance TreeKey (ToDecrypt 'Symm sch ByteString) = @@ -394,16 +400,17 @@ decryptBlock :: forall t s sto h m . ( MonadIO m ) => sto - -> [KeyringEntry s] + -> (GroupKey 'Symm s -> m (Maybe GroupSecret)) -> SmallEncryptedBlock t -> m t -decryptBlock sto keys (SmallEncryptedBlock{..}) = do +decryptBlock sto findKey (SmallEncryptedBlock{..}) = do gkbs <- readFromMerkle sto (SimpleKey (fromHashRef sebGK0)) gk <- either (const $ throwError (GroupKeyNotFound 1)) pure (deserialiseOrFail @(GroupKey 'Symm s) gkbs) - let gksec' = [ lookupGroupKey sk pk gk | KeyringKeys pk sk <- keys ] & catMaybes & headMay + gksec' <- findKey gk + -- [ lookupGroupKey sk pk gk | KeyringKeys pk sk <- keys ] & catMaybes & headMay gksec <- maybe1 gksec' (throwError (GroupKeyNotFound 2)) pure @@ -425,3 +432,17 @@ deriveGroupSecret n bs = key0 prk = HKDF.extractSkip @_ @HbSyncHash bs key0 = HKDF.expand prk nonceS typicalKeyLength & Saltine.decode & fromJust + +loadGroupKeyMaybe :: ( ForGroupKeySymm s, MonadIO m + ) => AnyStorage -> HashRef -> m (Maybe (GroupKey 'Symm s)) +loadGroupKeyMaybe sto h = do + + runMaybeT do + + bs <- runExceptT (readFromMerkle sto (SimpleKey (fromHashRef h))) + <&> either (const Nothing) Just + >>= toMPlus + + deserialiseOrFail bs + & toMPlus + diff --git a/hbs2-core/lib/HBS2/Net/Auth/Schema.hs b/hbs2-core/lib/HBS2/Net/Auth/Schema.hs index 5c4150e2..6f4bc727 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/Schema.hs +++ b/hbs2-core/lib/HBS2/Net/Auth/Schema.hs @@ -5,7 +5,7 @@ module HBS2.Net.Auth.Schema , module HBS2.Net.Proto.Types ) where -import HBS2.Prelude +import HBS2.Prelude.Plated import HBS2.OrDie import HBS2.Net.Proto.Types import HBS2.Hash @@ -17,21 +17,36 @@ import Crypto.PubKey.Ed25519 qualified as Ed import Crypto.KDF.HKDF qualified as HKDF import Crypto.Saltine.Class qualified as Saltine import Crypto.Saltine.Class (IsEncoding(..)) +import Crypto.Saltine.Core.Sign qualified as Sign +import Crypto.Saltine.Core.Box qualified as Encrypt + import Codec.Serialise import Data.ByteString.Lazy qualified as LBS import Data.ByteString (ByteString) import Data.ByteArray ( convert) -data HBS2Basic -type instance Encryption L4Proto = HBS2Basic +-- type ForSignatures s = ( Serialise ( PubKey 'Sign s) +-- , FromStringMaybe (PubKey 'Sign s) +-- , Signatures s +-- ) -type instance Encryption UNIX = HBS2Basic +type instance Encryption L4Proto = 'HBS2Basic +type instance Encryption UNIX = 'HBS2Basic type ForDerivedKey s = (IsEncoding (PrivKey 'Sign s), IsEncoding (PubKey 'Sign s)) -instance (MonadIO m, ForDerivedKey s, s ~ HBS2Basic) => HasDerivedKey s 'Sign Word64 m where +type instance PubKey 'Sign 'HBS2Basic = Sign.PublicKey +type instance PrivKey 'Sign 'HBS2Basic = Sign.SecretKey +type instance PubKey 'Encrypt 'HBS2Basic = Encrypt.PublicKey +type instance PrivKey 'Encrypt 'HBS2Basic = Encrypt.SecretKey + +-- type PrivKey 'Encrypt s + +-- type instance PubKey 'Sign + +instance (MonadIO m, ForDerivedKey s, s ~ 'HBS2Basic) => HasDerivedKey s 'Sign Word64 m where derivedKey nonce sk = do sk0 <- liftIO $ throwCryptoErrorIO (Ed.secretKey k0) diff --git a/hbs2-core/lib/HBS2/Net/Dialog/Client.hs b/hbs2-core/lib/HBS2/Net/Dialog/Client.hs deleted file mode 100644 index dd4d2465..00000000 --- a/hbs2-core/lib/HBS2/Net/Dialog/Client.hs +++ /dev/null @@ -1,194 +0,0 @@ -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE ImpredicativeTypes #-} -module HBS2.Net.Dialog.Client where - --- import System.Clock --- import System.Timeout -import Codec.Serialise -import Control.Arrow -import Control.Exception qualified as Exception -import Control.Monad -import Control.Monad.Cont -import Control.Monad.Error.Class -import Control.Monad.Except (ExceptT(..), runExcept, runExceptT) -import Control.Monad.IO.Unlift -import Control.Monad.State.Class as State -import Control.Monad.State.Strict (evalState, evalStateT) -import Data.ByteString (ByteString) -import Data.ByteString qualified as BS -import Data.ByteString.Builder -import Data.ByteString.Lazy qualified as BSL -import Data.Default -import Data.Generics.Labels -import Data.Generics.Product.Fields -import Data.List qualified as List -import Data.Map.Strict as Map -import Data.String.Conversions (cs, ConvertibleStrings) -import Data.Time -import GHC.Generics(Generic) -import Lens.Micro.Platform -import Streaming as S -import Streaming.Prelude qualified as S -import UnliftIO.Exception -import UnliftIO.STM -import UnliftIO.Timeout - -import HBS2.Net.Dialog.Core -import HBS2.Net.Dialog.Helpers.Streaming - ---- - -dQuery_ :: MonadUnliftIO m - => RequestParams - -> DialogClient m peer - -> peer - -> Frames - -> m () -dQuery_ _par dcli peer rq = - withClientQuery dcli & \dialf -> - dialf peer rq' \_flow -> pure () - where - rq' = rq & #unFrames %~ ([serialiseS routerSignature] <>) - --- -dQuery1 :: (MonadUnliftIO m) - => RequestParams - -> DialogClient m peer - -> peer - -> Frames - -> m Frames - -dQuery1 par dcli peer rq = dQuery' par dcli peer rq \flow -> - either (throwIO . DQuery1Error) (pure . view _2) =<< headEither flow - -data DQuery1Error = DQuery1Error RequestResult - deriving (Show) - -instance Exception DQuery1Error - --- -dQuery' :: MonadUnliftIO m - => RequestParams - -> DialogClient m peer - -> peer - -> Frames - -> (Stream (Of (ResponseHeader, Frames)) m RequestResult -> m r) - -> m r - -dQuery' par dcli peer rq go = - withClientQuery dcli & \dialf -> do - dialf peer rq' \flow -> go $ - flow - & withEffectsMay RequestTimeout (timeout' (requestParamsTimeout par)) - & S.map decodeHeader - & stopAfterLeftMay (either - (\(merr, xs) -> Left (Nothing, RequestErrorBadResponse merr xs)) - processResponseHeader - ) - - where - - processResponseHeader :: (ResponseHeader, Frames) -> - Either - (Maybe (ResponseHeader, Frames), RequestResult) - (ResponseHeader, Frames) - - processResponseHeader rhxs@(rh, xs) = case ((responseStatusCode . respStatus) rh) of - Success200 -> Left (Just rhxs, RequestDone) - SuccessNoContent204 -> Left (Just rhxs, RequestDone) - SuccessMore -> Right rhxs - BadRequest400 -> Left (Nothing, (RequestFailure (respStatus rh) xs)) - Forbidden403 -> Left (Nothing, (RequestFailure (respStatus rh) xs)) - NotFound404 -> Left (Nothing, (RequestFailure (respStatus rh) xs)) - - rq' = rq & #unFrames %~ ([serialiseS routerSignature] <>) - -timeout' :: MonadUnliftIO m => NominalDiffTime -> m a -> m (Maybe a) -timeout' = timeout . round . (* 10^6) . nominalDiffTimeToSeconds - --- -decodeHeader :: Frames -> Either (BadResponse, Frames) (ResponseHeader, Frames) -decodeHeader = evalState do - ex <- runExceptT cutFrameDecode' - xs <- State.get - pure $ ex - & left ((, xs) . maybe ResponseInsufficientFrames ResponseParseError) - & right (, xs) - -data RequestParams = RequestParams - { requestParamsTimeout :: NominalDiffTime - } - deriving (Generic) - -instance Default RequestParams where - def = RequestParams - { requestParamsTimeout = 5 - } - -data DialogClient m p = DialogClient - { withClientQuery :: ClientQuery m p - } - -type ClientQuery m p = forall r . - p - -> Frames - -> (Stream (Of Frames) m RequestResult -> m r) - -> m r - -withClient :: forall m p i r . MonadUnliftIO m - => DClient m p i -> (DialogClient m p -> m r) -> m r -withClient dclient go = do - callerID <- newCallerID - - requestIDtvar <- newTVarIO 1 - - -- У обработчика получателя - своё окружение, в которое мы добавляем - -- обработчики ответов на запросы по requestID - requestResponseEnv <- newRequestResponseEnv - - let withClientQuery' :: ClientQuery m p - withClientQuery' = \pid xs handleStream -> do - requestID <- atomically $ stateTVar requestIDtvar (id &&& succ) - - ch <- newTQueueIO - let useResponse = RequestResponseHandler @m do - atomically . writeTQueue ch - let - -- flow :: Stream (Of Frames) m RequestResult - flow = S.repeatM (atomically (readTQueue ch)) - - bracket_ - (setupRepHandler requestResponseEnv requestID useResponse) - (clearRepHandler requestResponseEnv requestID) - (do - - clientSendProtoRequest dclient pid do - xs & addEnvelope - [ (BSL.toStrict . serialise) callerID - , (BSL.toStrict . serialise) requestID - ] - - handleStream flow - ) - - -- Установить в окружении обработчик получателя с callerID - let callerHandler = CallerHandler $ unFrames >>> \case - - requestIDRaw:xs -> do - case deserialiseOrFail (BSL.fromStrict requestIDRaw) of - Left _ -> - -- Если не нашли, ничего не предпринимать - -- На этот вопрос уже не ждут ответа - pure () - Right requestID -> do - mh <- findRepHandler requestResponseEnv requestID - forM_ mh \(RequestResponseHandler h) -> h (Frames xs) - - _ -> pure () - - bracket_ - (setupCallerEnv (clientCallerEnv dclient) callerID callerHandler) - (clearCallerEnv (clientCallerEnv dclient) callerID) - (go (DialogClient {withClientQuery = withClientQuery'})) - diff --git a/hbs2-core/lib/HBS2/Net/Dialog/Core.hs b/hbs2-core/lib/HBS2/Net/Dialog/Core.hs deleted file mode 100644 index 60aef062..00000000 --- a/hbs2-core/lib/HBS2/Net/Dialog/Core.hs +++ /dev/null @@ -1,831 +0,0 @@ -{-# Language AllowAmbiguousTypes #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- {-# LANGUAGE ConstraintKinds #-} --- {-# LANGUAGE OverloadedLists #-} - --- {-# LANGUAGE CPP #-} --- {-# LANGUAGE DataKinds #-} --- {-# LANGUAGE FlexibleContexts #-} --- {-# LANGUAGE FlexibleInstances #-} --- {-# LANGUAGE MultiParamTypeClasses #-} --- {-# LANGUAGE OverloadedStrings #-} --- {-# LANGUAGE RankNTypes #-} --- {-# LANGUAGE ScopedTypeVariables #-} --- {-# LANGUAGE TupleSections #-} --- {-# LANGUAGE TypeApplications #-} --- {-# LANGUAGE TypeFamilies #-} - - -module HBS2.Net.Dialog.Core where - -import Codec.Serialise -import Control.Arrow -import Control.Monad -import Control.Monad.Error.Class -import Control.Monad.Except (Except, ExceptT(..), runExcept, runExceptT) -import Control.Monad.IO.Class -import Control.Monad.State.Class as State -import Control.Monad.State.Strict as StateStrict (evalState, evalStateT, runStateT, StateT(..)) -import Control.Monad.Trans.Class -import Data.Binary.Get as Get -import Data.Binary.Put as Put -import Data.Bits -import Data.Bool -import Data.ByteString (ByteString) -import Data.ByteString qualified as BS -import Data.ByteString.Base16 qualified as B16 -import Data.ByteString.Char8 qualified as BS8 -import Data.ByteString.Lazy qualified as BSL -import Data.Constraint (Dict(..)) -import Data.Foldable as F -import Data.Function -import Data.Functor -import Data.Generics.Labels () -import Data.Generics.Product.Fields () -import Data.Generics.Sum.Constructors -import Data.Kind -import Data.List qualified as List -import Data.List.NonEmpty qualified as NE -import Data.Map.Strict as Map -import Data.Maybe -import Data.Proxy -import Data.String.Conversions as X (cs) -import Data.Text (Text) -import Data.Typeable -import Data.Word -import GHC.Generics ((:*:) (..), Generic (..), K1 (..), M1 (..)) -import GHC.Generics qualified as Generics -import GHC.TypeLits -import Lens.Micro.Platform -import Streaming -import System.Random.MWC -import UnliftIO.STM - -import HBS2.Net.Dialog.Helpers.List - -type Frames = Frames' ByteString -newtype Frames' a = Frames { unFrames :: [a] } - deriving stock (Generic,Eq) - deriving newtype (Functor, Foldable, Semigroup, Monoid - -- , IsList - ) - - -instance Show Frames where - show (Frames xs) = "Frames " <> show (BS.length <$> xs) - -- <> " " <> show (fmap B16.encode xs) - <> " " <> (show . fmap (limitSize 42)) xs - - where - limitSize n as = bool as (BS.take (n-3) as <> "...") (BS.length as > n) - -framesBodyPart :: Traversal' Frames [ByteString] -framesBodyPart = #unFrames . tailAfterP (== "") - -tailAfterP :: forall a . (a -> Bool) -> Traversal' [a] [a] -tailAfterP p focus = fix \go -> \case - x:xs -> (x :) <$> bool go focus (p x) xs - xs -> pure xs - ---- - -encodeFrames :: Frames -> ByteString --- encodeFrames :: Foldable t => t ByteString -> ByteString -encodeFrames = F.toList >>> BSL.toStrict . runPut . \case - - [] -> pure () - - xss -> flip fix xss \go -> \case - [] -> pure () - bs:xs -> do - let (flip shiftR 1 -> n1, ns) = unfoldSizeBytes @Word64 . flip shiftL 1 . fromIntegral . BS.length $ bs - - putWord8 $ n1 - & bool (sbit 7) id (List.null xs) - & bool (sbit 6) id (List.null ns) - - forM_ (markMore ns) \(n, isMoreBytesInSize) -> do - putWord8 $ n & bool (zbit 7) (sbit 7) isMoreBytesInSize - - putByteString bs - - go xs - - where - - markMore as = zip as ((True <$ List.drop 1 as) <> [False]) - - unfoldSizeBytes :: (Bits n, Integral n) => n -> (Word8, [Word8]) - unfoldSizeBytes = (\(a NE.:| as) -> (a, as)) . NE.unfoldr \w -> - ( (flip shiftR 1 . flip shiftL 1 . fromIntegral) w - , let w' = shiftR w 7 - in bool Nothing (Just w') (w' > 0) - ) - -decodeFrames :: MonadError String m => ByteString -> m Frames -decodeFrames = \case - "" -> pure mempty - - bs' -> (bs' &) $ BSL.fromStrict >>> either (throwError . view _3) (pure . Frames . view _3) - <$> runGetOrFail do - - fix \go -> do - - j <- getWord8 - - bsize <- - flip fix (6, j) \fu (b, j') -> do - let n = (fromIntegral . clearLeftBits (8-b)) j' - if tbit b j' - then (n +) . flip shiftL b <$> (fu . (7, ) =<< getWord8) - else pure n - - bs <- getByteString bsize - - let moreFrames = tbit 7 j - - if moreFrames - then (bs :) <$> go - else pure [bs] - - where - clearLeftBits n = flip shiftR n . flip shiftL n - tbit = flip testBit - - -devDialogCore :: IO () -devDialogCore = do - display (Frames []) - display (Frames [""]) - display (Frames [BS.replicate 32 0x55]) - display (Frames [BS.replicate 32 0x55, ""]) - display (Frames [BS.replicate 32 0x55, "\3\3"]) - display (Frames [BS.replicate 33 0x55, "\3\3"]) - display (Frames [BS.replicate 63 0x55]) - display (Frames [BS.replicate 64 0x55]) - -- display (Frames [BS.replicate 65 0x55]) - display (Frames ["\8\8\8","\4\4\4"]) - display (Frames ["","\1"]) - where - display a = do - putStrLn . cs . show . B16.encode . encodeFrames $ a - putStrLn "" - - - - -sbit :: (Bits n) => Int -> n -> n -sbit = flip setBit - -zbit :: (Bits n) => Int -> n -> n -zbit = flip clearBit - ---- - -decodeFramesFail :: (MonadFail m) => ByteString -> m Frames -decodeFramesFail = errorToFail . decodeFrames - ---- - -errorToFailT :: (MonadFail m) => ExceptT String m a -> m a -errorToFailT = either fail pure <=< runExceptT - -errorToFail :: MonadFail m => Except String a -> m a -errorToFail = either fail pure . runExcept - -errorShowToFail :: (MonadFail m, Show s) => Except s a -> m a -errorShowToFail = either (fail . show) pure . runExcept - --- - -data CallerID = CallerID - { unCallerIDV :: Word8 - , unCallerID :: Word32 - } - deriving stock (Generic, Eq, Ord) - -instance Serialise CallerID - -newCallerID :: forall m. MonadIO m => m CallerID -newCallerID = liftIO $ withSystemRandomST \g -> - CallerID <$> uniformM g <*> uniformM g - ---- - -newtype CallerHandler m = CallerHandler - { unCallerHandler :: Frames -> m () - } - -newtype CallerEnv m = CallerEnv - { unCallerEnv :: TVar (Map CallerID (CallerHandler m)) } - -newCallerEnv :: MonadIO m => m (CallerEnv m') -newCallerEnv = CallerEnv <$> newTVarIO mempty - ---- - -newtype RequestResponseHandler m = RequestResponseHandler - { unRequestResponseHandler :: Frames -> m () - } - -newtype RequestResponseEnv m = RequestResponseEnv - { unRequestResponseEnv :: TVar (Map RequestID (RequestResponseHandler m)) - } - -newRequestResponseEnv :: MonadIO m => m (RequestResponseEnv m') -newRequestResponseEnv = - RequestResponseEnv <$> newTVarIO mempty - ---- - -data DClient m p i = DClient - { clientCallerEnv :: CallerEnv m - , clientSendProtoRequest :: p -> Frames -> m () - , clientGetKnownPeers :: m [(p, i)] - } - ---- - -newtype RequestID = RequestID { unRequestID :: Word32 } - deriving stock (Generic, Eq, Ord) - deriving newtype (Serialise, Num, Enum) - -- deriving via TODO_GenericVLQ Put Get - -data RequestResult - = RequestDone - -- | RequestSuccessIncomplete - | RequestTimeout - | RequestFailure ResponseStatus Frames - | RequestErrorBadResponse BadResponse Frames - deriving stock (Generic, Eq, Show) - -data BadResponse - = ResponseErrorNoResponseHeader - | ResponseInsufficientFrames - | ResponseParseError DeserialiseFailure - deriving stock (Generic, Eq, Show) - ---- - -setupCallerEnv :: MonadIO m => CallerEnv m' -> CallerID -> CallerHandler m' -> m () -setupCallerEnv env callerID repHandleEnv = - (atomically . modifyTVar' (unCallerEnv env)) - (at callerID ?~ repHandleEnv) - -clearCallerEnv :: MonadIO m => CallerEnv m' -> CallerID -> m () -clearCallerEnv env callerID = - (atomically . modifyTVar' (unCallerEnv env)) - (at callerID .~ Nothing) - -findCallerHandler :: MonadIO m => CallerEnv m' -> CallerID -> m (Maybe (CallerHandler m')) -findCallerHandler CallerEnv{..} callerID = - readTVarIO unCallerEnv <&> preview (ix callerID) - ---- - -setupRepHandler :: MonadIO m => RequestResponseEnv m' -> RequestID -> RequestResponseHandler m' -> m () -setupRepHandler RequestResponseEnv{..} requestID useResponse = - (atomically . modifyTVar' unRequestResponseEnv) - (at requestID ?~ useResponse) - -clearRepHandler :: MonadIO m => RequestResponseEnv m' -> RequestID -> m () -clearRepHandler RequestResponseEnv{..} requestID = - (atomically . modifyTVar' unRequestResponseEnv) - (at requestID .~ Nothing) - -findRepHandler :: MonadIO m => RequestResponseEnv m' -> RequestID -> m (Maybe (RequestResponseHandler m')) -findRepHandler RequestResponseEnv{..} requestID = - readTVarIO unRequestResponseEnv <&> preview (ix requestID) - ---- - -data DialogRequestEnv m p pd = DialogRequestEnv - { dreqEnvPeer :: p - , dreqEnvGetPeerData :: m pd - } - --- data DialogRequestError --- = DialogRequestFailure String --- deriving stock (Show) --- instance Exception DialogRequestError - ---- - --- type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived -type DApp m = Frames -> (Frames -> m ()) -> m () - -mkDApp :: - forall spec ctx m io. - ( Monad m - , Monad io - , HasHandler m (NamedSpec spec) ctx - , HasHandler io (NamedSpec spec) ctx - ) - => Proxy (NamedSpec spec) - -> Ctx ctx - -> (forall x. m x -> DialHandlerT io x) - -> spec (ModeServerT m) - -> DApp io -mkDApp p ctx ntToDialHandlerTn hd = routeDialogRequest rr - where - rr :: DialogRequestRouter io - rr = route p ctx - $ hoistDialogWithContext p (Proxy @ctx) ntToDialHandlerTn - hd - -type DialogReplyHandler m = (Frames -> m ()) -> m () - -type DialogRequestRouter (m :: Type -> Type) = - DialogRequestRoutes (DialogReplyHandler m) - -data DialogRequestRoutes (h :: Type) - = DialogRequestPaths (Map ByteString (DialogRequestRoutes h)) - | DialogRequestPreparse (Frames -> Either Text (DialogRequestRoutes h, Frames)) - | DialogRequestEndpoint h - deriving (Generic, Functor) - -instance Semigroup (DialogRequestRoutes h) where - (<>) a b = case (a, b) of - (DialogRequestPaths p1, DialogRequestPaths p2) -> - DialogRequestPaths (p1 <> p2) - _ -> b - --- instance Monoid (DialogRequestRoutes h) where --- mempty = DialogRequestPaths mempty - -dialogRequestRoutes - :: ListBuilder - ([ByteString], Frames -> Either Text ((Frames -> m ()) -> m (), Frames)) - -> DialogRequestRouter m -dialogRequestRoutes = List.foldl1' (<>) - . fmap toPaths - . over (traverse . _2) (DialogRequestPreparse . (fmap . fmap) (over _1 DialogRequestEndpoint)) - . buildList - where - toPaths :: ([ByteString], DialogRequestRoutes ((Frames -> m ()) -> m ())) - -> DialogRequestRoutes (DialogReplyHandler m) - toPaths = fix \go (ps, rr) -> case ps of - [] -> rr - [p] -> DialogRequestPaths (Map.singleton p rr) - p:px' -> DialogRequestPaths (Map.singleton p (go (px', rr))) - -hand :: Monad m => a -> b -> ListBuilderT m (a, b) -hand = curry li - -handconv :: (Monad m, Monad m', Serialise req, Serialise resp) - => a - -> Text - -> (req -> ExceptT ResponseStatus m resp) - -> ListBuilderT m' (a, Frames -> Either Text ((Frames -> m ()) -> m (), Frames)) -handconv path msg h = - hand path $ processReply msg h - ---- - -processReply :: forall m m' req resp . - ( Monad m - , Serialise req - , Serialise resp - , m' ~ ExceptT ResponseStatus m - ) - => Text - -> (req -> m' resp) - -> Frames - -> Either Text ((Frames -> m ()) -> m (), Frames) -processReply msg h = runExcept . runStateT do - flip runReply . h <$> cutFrameDecode msg - -runReply :: - ( Monad m - , Serialise a - ) - => (Frames -> m r) - -> ExceptT ResponseStatus m a - -> m r -runReply reply = - either - (\e -> reply (Frames [serialiseS (ResponseHeader e 0)])) - (\a -> reply (Frames [serialiseS (ResponseHeader (ResponseStatus Success200 "") 0) - , serialiseS a - ]) - ) - <=< runExceptT - ---- - -dpath :: Text -> [ByteString] -> Frames -dpath path = Frames . (cs path :) - ---- - -addEnvelope :: Monoid a => [a] -> Frames' a -> Frames' a -addEnvelope en = over #unFrames ((en <> [mempty]) <>) - -splitEnvelope :: (Monoid a, Eq a) => Frames' a -> ([a], Frames' a) -splitEnvelope = fmap (Frames . List.drop 1) . List.break (== mempty) . unFrames - -data ResponseHeader = ResponseHeader - { respStatus :: ResponseStatus - , respSeqNumber :: Int - } - deriving (Generic, Show, Eq) - -instance Serialise ResponseHeader - -data ResponseStatus = ResponseStatus - { responseStatusCode :: ResponseStatusCode - , responseStatusMessage :: Text - } - deriving (Generic, Show, Eq) - -instance Serialise ResponseStatus - -data ResponseStatusCode - = Success200 - | SuccessNoContent204 - | SuccessMore - | BadRequest400 - | Forbidden403 - | NotFound404 - deriving (Generic, Show, Eq) - -instance Serialise ResponseStatusCode - -routerSignature :: Word8 -routerSignature = 1 - -routeDialogRequest :: forall m . - Monad m - => DialogRequestRouter m - -> Frames - -> (Frames -> m ()) - -> m () -routeDialogRequest router frames rawReplyToPeer = do - -- error $ show router - erun <- pure $ runExcept $ flip evalStateT req do - - signature <- cutFrameDecode - (ResponseStatus BadRequest400 "No signature in request") - - when (signature /= routerSignature) $ throwError - (ResponseStatus BadRequest400 "Wrong signature in request") - - path <- cutFrameOr - (ResponseStatus BadRequest400 "No path in request") - - lift . ExceptT . pure - -- Если не может разобрать параметры запроса, - -- то самим ответить этому пиру '404' - -- . left (ResponseStatus BadRequest400) - . travel (BS8.split '/' path) router - -- передать оставшуюся часть запроса в хэндлер - =<< get - - case erun of - Left rs -> replyToPeer (Frames [serialiseS (ResponseHeader rs 0)]) - Right go -> - -- передать хэндлеру продолжение чтобы ответить этому пиру - go replyToPeer - - where - (backPath, req) = splitEnvelope frames - - replyToPeer :: Frames -> m () - replyToPeer = rawReplyToPeer . over #unFrames (backPath <>) - -travel :: () - => [ByteString] - -> DialogRequestRouter m - -> Frames - -> Either ResponseStatus ((Frames -> m ()) -> m ()) -travel path'' router'' = evalStateT $ flipfix2 path'' router'' - \go path -> \case - DialogRequestPaths kv -> case path of - step:path' -> - maybe - (throwError (ResponseStatus BadRequest400 "Path not found")) - (go path') - (Map.lookup step kv) - _ -> throwError (ResponseStatus BadRequest400 "Path not found (too long)") - DialogRequestPreparse hfx -> - go path =<< StateT (left (ResponseStatus BadRequest400) . hfx) - DialogRequestEndpoint ep -> pure ep - -flipfix2 :: a -> b -> ((a -> b -> c) -> (a -> b -> c)) -> c -flipfix2 a b f = fix f a b - -cutFrameDecode :: (Serialise b, MonadState Frames m, MonadError e m) => e -> m b -cutFrameDecode e = - State.gets unFrames >>= \case - x:xs -> - (either (const (throwError e)) pure . deserialiseOrFailS) x - <* State.put (Frames xs) - _ -> throwError e - -cutFrameDecode' - :: (Serialise b, MonadState Frames m, MonadError (Maybe DeserialiseFailure) m) - => m b -cutFrameDecode' = - State.gets unFrames >>= \case - x:xs -> - (either (throwError . Just) pure . deserialiseOrFailS) x - <* State.put (Frames xs) - _ -> throwError Nothing - -cutFrameOr :: (MonadState (Frames' b) m, MonadError e m) => e -> m b -cutFrameOr e = - State.gets unFrames >>= \case - x:xs -> x <$ State.put (Frames xs) - _ -> throwError e - -serialiseS :: Serialise a => a -> ByteString -serialiseS = BSL.toStrict . serialise - -deserialiseOrFailS :: Serialise a => ByteString -> Either DeserialiseFailure a -deserialiseOrFailS = deserialiseOrFail . BSL.fromStrict - -fromMaybeM :: Applicative m => m a -> Maybe a -> m a -fromMaybeM ma = maybe ma pure - -fromJustThrowError :: MonadError e m => e -> Maybe a -> m a -fromJustThrowError = fromMaybeM . throwError - - - ------------------------------------------- ---- Type-level specification ------------- ------------------------------------------- - - -data ReqCBOR (a :: Type) -data SingleAck -data SingleRespCBOR (a :: Type) -data StreamingRespCBOR (a :: Type) - -data NamedSpec (spec :: Type -> Type) - -class DialMode mode where - type mode &- spec :: Type -infixl 0 &- - -data (path :: k) &/ (a :: Type) - deriving (Typeable) -infixr 4 &/ - -type path &// a = path &/ NamedSpec a -infixr 4 &// - ---- - -data ModePlain -instance DialMode ModePlain where - type ModePlain &- spec = spec - ---- - -data ModeServerT (m :: Type -> Type) - -instance DialMode (ModeServerT m) where - type ModeServerT m &- spec = HandlerD spec m - -class HasHandler m spec ctx where - type HandlerD spec (m' :: Type -> Type) :: Type - - route :: - Proxy spec - -> Ctx ctx - -> HandlerD spec (DialHandlerT m) - -> DialogRequestRouter m - - hoistDialogWithContext - :: Proxy spec - -> Proxy ctx - -> (forall x. m x -> n x) - -> HandlerD spec m - -> HandlerD spec n - -data EmptyCX -- '[] -data Ctx ctx where - EmptyCtx :: Ctx EmptyCX - -- (:&.) :: x -> Ctx xs -> Ctx (x ': xs) --- infixr 5 :&. - --- hoistTRouter :: forall t m n . --- (MonadTrans t, Monad m, Monad n, m ~ t n) --- => (forall a . m a -> n a) --- -> DialogRequestRouter m --- -> DialogRequestRouter n --- hoistTRouter nt = fmap nt' --- where --- nt' :: ((x -> m y) -> m y) --- -> ((x -> n y) -> n y) --- nt' xtmy_tmy = nt . xtmy_tmy . fmap lift - -hoistTRouter :: forall m n . - (Monad m, Monad n) - => (forall a . m a -> n a) - -> (forall a . n a -> m a) - -> DialogRequestRouter m - -> DialogRequestRouter n -hoistTRouter ntf ntb = fmap nt' - where - nt' :: ((x -> m y) -> m y) - -> ((x -> n y) -> n y) - nt' xtmy_tmy = ntf . xtmy_tmy . fmap ntb - - -type DialHandlerIO a = DialHandlerT IO a -newtype DialHandlerT m a = DialHandlerT { runDialHandlerT :: ExceptT ResponseStatus m a } - deriving - ( Generic, Functor, Applicative, Monad - , MonadIO - , MonadTrans - , MonadError ResponseStatus - -- , MonadUnliftIO - -- , MonadThrow, MonadCatch, MonadMask - ) - ---- - -instance (KnownSymbol path, HasHandler m spec ctx) => HasHandler m (path &/ spec) ctx where - type HandlerD (path &/ spec) m = HandlerD spec m - - route _ ctx h = DialogRequestPaths $ - Map.singleton (cs (symbolVal (Proxy @path))) (route (Proxy @spec) ctx h) - - hoistDialogWithContext _ = hoistDialogWithContext (Proxy @spec) - ---- - -instance - ( Serialise a - , Typeable a - , HasHandler m spec ctx - ) => - HasHandler m (ReqCBOR a &/ spec) ctx where - type HandlerD (ReqCBOR a &/ spec) m = a -> HandlerD spec m - - route _ ctx (ha :: a -> HandlerD spec (DialHandlerT m)) = - DialogRequestPreparse \fx -> do - (a, fx') - <- runExcept - $ flip runStateT fx - $ cutFrameDecode ((cs . show . typeRep) (Proxy @a)) - pure (route (Proxy @spec) ctx (ha a), fx') - - hoistDialogWithContext _ pc nt s = hoistDialogWithContext (Proxy @spec) pc nt . s - ---- - -instance - ( Applicative m - ) => - HasHandler m SingleAck ctx where - type HandlerD SingleAck m = m () - - route _ _ctx _mx = - DialogRequestEndpoint \reply -> do - reply (Frames [serialiseS (ResponseHeader (ResponseStatus SuccessNoContent204 "") 0)]) - - hoistDialogWithContext _ _ nt hdlM = nt hdlM - ---- - -instance - ( Monad m - , Serialise a - ) => - HasHandler m (SingleRespCBOR a) ctx where - type HandlerD (SingleRespCBOR a) m = m a - - route _ _ctx ma = - DialogRequestEndpoint \reply -> do - - ea <- runExceptT $ runDialHandlerT ma - - case ea of - Left e -> reply $ Frames [ serialiseS e ] - Right a -> reply $ Frames - [ serialiseS (ResponseHeader (ResponseStatus Success200 "") 0) - , serialiseS (a :: a) - ] - - hoistDialogWithContext _ _ nt hdlM = nt hdlM - ---- - -instance - ( Serialise a - ) => - HasHandler m (StreamingRespCBOR a) ctx where - type HandlerD (StreamingRespCBOR a) m = Stream (Of a) m () - - route = undefined - - -- hoistDialogWithContext = undefined - ---- - -type GServerConstraints spec m = - ( GToProduct (Rep (spec (ModeServerT m))) ~ HandlerD (GToProduct (Rep (spec ModePlain))) m - , GProduct (Rep (spec (ModeServerT m))) - ) - -class GServer (spec :: Type -> Type) (m :: Type -> Type) where - gServerProof :: Dict (GServerConstraints spec m) - -instance - ( GToProduct (Rep (spec (ModeServerT m))) ~ HandlerD (GToProduct (Rep (spec ModePlain))) m - , GProduct (Rep (spec (ModeServerT m))) - ) => GServer spec m where - gServerProof = Dict - - -instance - ( HasHandler m (GToProduct (Rep (spec ModePlain))) ctx - -- , HasHandler m (GToProduct (Rep (spec (ModeServerT m)))) ctx - -- , GProduct (Rep (spec ModePlain)) - , forall q . Generic (spec (ModeServerT q)) - , forall q . GServer spec q - ) => - HasHandler m (NamedSpec spec) ctx where - type HandlerD (NamedSpec spec) m = spec (ModeServerT m) - - route :: - Proxy (NamedSpec spec) - -> Ctx ctx - -> spec (ModeServerT (DialHandlerT m)) - -> DialogRequestRouter m - route _ ctx spec = - case gServerProof @spec @(DialHandlerT m) of - Dict -> route (Proxy @(GToProduct (Rep (spec ModePlain)))) ctx (toProduct spec) - - hoistDialogWithContext - :: forall n. Proxy (NamedSpec spec) - -> Proxy ctx - -> (forall x. m x -> n x) - -> spec (ModeServerT m) - -> spec (ModeServerT n) - hoistDialogWithContext _ pctx nat dl = - case (gServerProof @spec @m, gServerProof @spec @n) of - (Dict, Dict) -> - fromProduct dlN - where - dlM :: HandlerD (GToProduct (Rep (spec ModePlain))) m = - toProduct dl - dlN :: HandlerD (GToProduct (Rep (spec ModePlain))) n = - hoistDialogWithContext (Proxy @(GToProduct (Rep (spec ModePlain)))) pctx nat dlM - - -toProduct :: (Generic (spec mode), GProduct (Rep (spec mode))) - => spec mode -> GToProduct (Rep (spec mode)) -toProduct = gtoProduct . Generics.from - -fromProduct - :: (Generic (spec mode), GProduct (Rep (spec mode))) - => GToProduct (Rep (spec mode)) -> spec mode -fromProduct = Generics.to . gfromProduct - -instance - ( HasHandler m speca ctx - , HasHandler m specb ctx - ) => - HasHandler m (GP speca specb) ctx where - type HandlerD (GP speca specb) m = GP (HandlerD speca m) (HandlerD specb m) - route _ ctx (GP speca specb) = - route (Proxy @speca) ctx speca - <> route (Proxy @specb) ctx specb - - hoistDialogWithContext _ pc nt (GP speca specb) = - GP - (hoistDialogWithContext (Proxy @speca) pc nt speca) - (hoistDialogWithContext (Proxy @specb) pc nt specb) - -data GP a b = GP a b - -class GProduct f where - type GToProduct (f :: Type -> Type) - gtoProduct :: f p -> GToProduct f - gfromProduct :: GToProduct f -> f p - -instance (GProduct l, GProduct r) => GProduct (l :*: r) where - type GToProduct (l :*: r) = GP (GToProduct l) (GToProduct r) - gtoProduct (l :*: r) = GP (gtoProduct l) (gtoProduct r) - gfromProduct (GP l r) = gfromProduct l :*: gfromProduct r - -instance GProduct f => GProduct (M1 i c f) where - type GToProduct (M1 i c f) = GToProduct f - gtoProduct = gtoProduct . unM1 - gfromProduct = M1 . gfromProduct - -instance GProduct (K1 i c) where - type GToProduct (K1 i c) = c - gtoProduct = unK1 - gfromProduct = K1 diff --git a/hbs2-core/lib/HBS2/Net/Dialog/Helpers/List.hs b/hbs2-core/lib/HBS2/Net/Dialog/Helpers/List.hs deleted file mode 100644 index 2460b993..00000000 --- a/hbs2-core/lib/HBS2/Net/Dialog/Helpers/List.hs +++ /dev/null @@ -1,19 +0,0 @@ -module HBS2.Net.Dialog.Helpers.List where - -import Control.Monad.Trans.Writer.CPS qualified as W -import Data.Functor.Identity -import Data.Monoid - -type ListBuilder a = ListBuilderT Identity a - -type ListBuilderT m a = W.WriterT (Endo [a]) m () - -buildList :: ListBuilder a -> [a] -buildList = runIdentity . buildListT - -buildListT :: Monad m => ListBuilderT m a -> m [a] -buildListT = fmap (flip appEndo []) . W.execWriterT - -li :: Monad m => a -> ListBuilderT m a -li = W.tell . Endo . (:) - diff --git a/hbs2-core/lib/HBS2/Net/Dialog/Helpers/Streaming.hs b/hbs2-core/lib/HBS2/Net/Dialog/Helpers/Streaming.hs deleted file mode 100644 index 412928a4..00000000 --- a/hbs2-core/lib/HBS2/Net/Dialog/Helpers/Streaming.hs +++ /dev/null @@ -1,88 +0,0 @@ -module HBS2.Net.Dialog.Helpers.Streaming where - -import Control.Monad.Fix -import Data.ByteString qualified as BS -import Data.Int -import Data.Map.Strict qualified as Map -import Data.Maybe -import Data.Set qualified as Set -import Streaming as S -import Streaming.Internal -import Streaming.Prelude (cons) -import Streaming.Prelude qualified as S -import UnliftIO.Async -import UnliftIO.STM -import Prelude hiding (cons) - -withEffects - :: (Functor m, Functor f, s ~ Stream f m r) - => (forall a. m a -> m a) - -> s - -> s -withEffects trans = fix \go -> \case - Return r -> Return r - Effect m -> Effect (trans (fmap go m)) - Step f -> Step (fmap go f) -{-# INLINEABLE withEffects #-} - -withEffectsMay - :: (Monad m, Functor f, s ~ Stream f m r) - => r - -> (forall a. m a -> m (Maybe a)) - -> s - -> s -withEffectsMay d trans = fix \go -> \case - Return r -> Return r - Effect m -> Effect (fromMaybe (Return d) <$> trans (fmap go m)) - Step f -> Step (fmap go f) -{-# INLINEABLE withEffectsMay #-} - -stopOnLeft - :: (Monad m) - => (a -> Either r b) - -> Stream (Of a) m r - -> Stream (Of b) m r -stopOnLeft f = fix \go -> \case - Return r -> Return r - Effect m -> Effect (go <$> m) - Step (a :> s) -> either Return (\b -> Step (b :> go s)) (f a) -{-# INLINEABLE stopOnLeft #-} - -stopAfterLeftMay - :: (Monad m) - => (a -> Either (Maybe b, r) b) - -> Stream (Of a) m r - -> Stream (Of b) m r -stopAfterLeftMay f = fix \go -> \case - Return r -> Return r - Effect m -> Effect (go <$> m) - Step (a :> s) -> either - (\(mb, r) -> maybe - (Return r) - (\b -> Step (b :> Return r)) - mb) - (\b -> Step (b :> go s)) - (f a) -{-# INLINEABLE stopAfterLeftMay #-} - -stopAfter - :: (Monad m) - => (a -> Maybe r) - -> Stream (Of a) m r - -> Stream (Of a) m r -stopAfter f = fix \go -> \case - Return r -> Return r - Effect m -> Effect (go <$> m) - Step (a :> s) -> Step (a :> (maybe (go s) Return (f a))) -{-# INLINEABLE stopAfter #-} - -headEither - :: (Monad m) - => Stream (Of a) m r - -> m (Either r a) -headEither = fix \go -> \case - Return r -> pure (Left r) - Effect ms -> go =<< ms - Step (a :> _) -> pure (Right a) -{-# INLINEABLE headEither #-} - diff --git a/hbs2-core/lib/HBS2/Net/Messaging/Encrypted/ByPass.hs b/hbs2-core/lib/HBS2/Net/Messaging/Encrypted/ByPass.hs index 866d3332..bbaaa4da 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging/Encrypted/ByPass.hs +++ b/hbs2-core/lib/HBS2/Net/Messaging/Encrypted/ByPass.hs @@ -76,10 +76,10 @@ mySipHash s = BA.sipHash (SipKey a b) s -- -data ByPassOpts e = +data ByPassOpts s = ByPassOpts { byPassEnabled :: Bool - , byPassKeyAllowed :: PubKey 'Sign (Encryption e) -> IO Bool + , byPassKeyAllowed :: PubKey 'Sign s -> IO Bool , byPassTimeRange :: Maybe (Int, Int) } @@ -101,7 +101,7 @@ instance Serialise ByPassStat data ByPass e them = ByPass - { opts :: ByPassOpts e + { opts :: ByPassOpts (Encryption e) , self :: Peer e , pks :: PubKey 'Sign (Encryption e) , sks :: PrivKey 'Sign (Encryption e) @@ -128,7 +128,7 @@ type ForByPass e = ( Hashable (Peer e) , Serialise (PubKey 'Sign (Encryption e)) , PrivKey 'Encrypt (Encryption e) ~ PKE.SecretKey , PubKey 'Encrypt (Encryption e) ~ PKE.PublicKey - , ForSignedBox e + , ForSignedBox (Encryption e) ) @@ -136,12 +136,12 @@ data HEYBox e = HEYBox Int (PubKey 'Encrypt (Encryption e)) deriving stock Generic -instance ForByPass e => Serialise (HEYBox e) +instance ForByPass s => Serialise (HEYBox s) data EncryptHandshake e = HEY { heyNonceA :: NonceA - , heyBox :: SignedBox (HEYBox e) e + , heyBox :: SignedBox (HEYBox e) (Encryption e) } deriving stock (Generic) @@ -210,7 +210,7 @@ newByPassMessaging :: forall e w m . ( ForByPass e , MonadIO m , Messaging w e ByteString ) - => ByPassOpts e + => ByPassOpts (Encryption e) -> w -> Peer e -> PubKey 'Sign (Encryption e) @@ -370,10 +370,11 @@ makeKey a b = runIdentity do pure $ (f0 `shiftL` 16) .|. f1 -sendHey :: forall e w m . ( ForByPass e - , Messaging w e ByteString - , MonadIO m - ) +sendHey :: forall e w m s . ( ForByPass e + , Messaging w e ByteString + , MonadIO m + , s ~ Encryption e + ) => ByPass e w -> Peer e -> m () @@ -387,7 +388,7 @@ sendHey bus whom = do ts <- liftIO getPOSIXTime <&> round let hbox = HEYBox @e ts (pke bus) - let box = makeSignedBox @e (pks bus) (sks bus) hbox + let box = makeSignedBox @s (pks bus) (sks bus) hbox let hey = HEY @e (nonceA bus) box let msg = pref <> serialise hey diff --git a/hbs2-core/lib/HBS2/Net/Messaging/Pipe.hs b/hbs2-core/lib/HBS2/Net/Messaging/Pipe.hs new file mode 100644 index 00000000..4a132315 --- /dev/null +++ b/hbs2-core/lib/HBS2/Net/Messaging/Pipe.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE NumericUnderscores #-} +module HBS2.Net.Messaging.Pipe where + +import HBS2.Prelude.Plated +import HBS2.Net.Proto.Types +import HBS2.Actors.Peer.Types +import HBS2.Net.Messaging + +import Control.Concurrent.STM qualified as STM +import Control.Monad.Reader +import Data.ByteString.Builder qualified as B +import Data.ByteString.Lazy (ByteString) +import Data.ByteString.Lazy qualified as LBS +import Data.Hashable +import Network.ByteOrder hiding (ByteString) +import System.IO.Unsafe (unsafePerformIO) +import System.Posix.IO +import UnliftIO + +-- define new transport protocol type +data PIPE = PIPE + deriving (Eq,Ord,Show,Generic) + + +-- address for the new protocol +newtype PipeAddr = PipeAddr Handle + deriving newtype (Eq,Show) + +-- the protocol work data +data MessagingPipe = + MessagingPipe + { pipeIn :: Handle + , pipeOut :: Handle + , inQ :: TQueue ByteString + } + +remotePeer :: MessagingPipe -> Peer PIPE +remotePeer = PeerPIPE . PipeAddr . pipeOut + +localPeer :: MessagingPipe -> Peer PIPE +localPeer = PeerPIPE . PipeAddr . pipeIn + +newMessagingPipe :: MonadIO m => (Handle, Handle) -> m MessagingPipe +newMessagingPipe (pIn,pOut) = do + MessagingPipe pIn pOut + <$> newTQueueIO + +instance Hashable PipeAddr where + hashWithSalt salt (PipeAddr pip) = hashWithSalt salt ("pipe-addr", fd) + where + fd = unsafePerformIO (handleToFd pip <&> fromIntegral @_ @Word) + +instance HasPeer PIPE where + newtype instance Peer PIPE = PeerPIPE { _fromPeerPipe :: PipeAddr } + deriving stock (Eq,Show,Generic) + deriving newtype (Hashable) + +instance Pretty (Peer PIPE) where + pretty (PeerPIPE p) = parens ("pipe" <+> viaShow p) + +-- Messaging definition for protocol +instance Messaging MessagingPipe PIPE ByteString where + + sendTo bus _ _ msg = liftIO do + LBS.hPutStr (pipeOut bus) (B.toLazyByteString frame <> msg) + hFlush (pipeOut bus) + + where + frame = B.word32BE (fromIntegral $ LBS.length msg) + + receive bus _ = do + msg <- liftIO $ atomically $ peekTQueue q >> STM.flushTQueue q + for msg $ \m -> pure (From (PeerPIPE (PipeAddr who)), m) + + where + q = inQ bus + who = pipeIn bus + +runMessagingPipe :: MonadIO m => MessagingPipe -> m () +runMessagingPipe bus = liftIO do + fix \next -> do + frame <- LBS.hGet who 4 <&> word32 . LBS.toStrict + piece <- LBS.hGet who (fromIntegral frame) + atomically (writeTQueue (inQ bus) piece) + next + + where + who = pipeIn bus + +instance (MonadIO m, Messaging MessagingPipe PIPE (Encoded PIPE)) + => HasFabriq PIPE (ReaderT MessagingPipe m) where + getFabriq = asks Fabriq + +instance MonadIO m => HasOwnPeer PIPE (ReaderT MessagingPipe m) where + ownPeer = asks localPeer + + diff --git a/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs b/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs index 08d30384..08e5d423 100644 --- a/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs +++ b/hbs2-core/lib/HBS2/Net/Messaging/Unix.hs @@ -4,6 +4,7 @@ module HBS2.Net.Messaging.Unix ( module HBS2.Net.Messaging.Unix , module HBS2.Net.Messaging , module HBS2.Net.Proto.Types + , SocketClosedException ) where import HBS2.Prelude.Plated @@ -220,12 +221,23 @@ runMessagingUnix env = do atomically $ writeTVar seen now next + + clientLoop m = fix \next -> do + m + if not (MUDontRetry `elem` msgUnixOpts env) then do + debug "LOOP!" + next + else do + debug "LOOP EXIT" + handleClient | MUDontRetry `elem` msgUnixOpts env = \_ w -> handleAny throwStopped w - | otherwise = handleAny + | otherwise = handleAny throwStopped _ = throwIO UnixMessagingStopped - runClient = liftIO $ forever $ handleClient logAndRetry $ flip runContT pure $ do + runClient = liftIO $ clientLoop $ handleClient logAndRetry $ flip runContT pure $ do + + debug "HERE WE GO AGAIN!" let sa = SockAddrUnix (msgUnixSockPath env) let p = msgUnixSockPath env @@ -335,6 +347,7 @@ runMessagingUnix env = do pause (msgUnixRetryTime env) + logAndRetry :: SomeException -> IO () logAndRetry e = do warn $ "MessagingUnix. runClient failed, probably server is gone. Retrying:" <+> pretty (msgUnixSelf env) diff --git a/hbs2-core/lib/HBS2/Net/Proto/Types.hs b/hbs2-core/lib/HBS2/Net/Proto/Types.hs index 15d70133..994fddbf 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Types.hs +++ b/hbs2-core/lib/HBS2/Net/Proto/Types.hs @@ -9,7 +9,6 @@ module HBS2.Net.Proto.Types ) where import HBS2.Prelude.Plated -import HBS2.Clock import HBS2.Net.IP.Addr import Control.Applicative @@ -37,14 +36,19 @@ data CryptoAction = Sign | Encrypt data GroupKeyScheme = Symm | Asymm deriving stock (Eq,Ord,Show,Data,Generic) -type family PubKey (a :: CryptoAction) e :: Type -type family PrivKey (a :: CryptoAction) e :: Type +data CryptoScheme = HBS2Basic -type family Encryption e :: Type +type family PubKey (a :: CryptoAction) (s :: CryptoScheme) :: Type + +type family PrivKey (a :: CryptoAction) (s :: CryptoScheme) :: Type + +type family Encryption e :: CryptoScheme + +type instance Encryption L4Proto = 'HBS2Basic type family KeyActionOf k :: CryptoAction -data family GroupKey (scheme :: GroupKeyScheme) s +data family GroupKey (scheme :: GroupKeyScheme) (s :: CryptoScheme) -- NOTE: throws-error class MonadIO m => HasDerivedKey s (a :: CryptoAction) nonce m where @@ -53,9 +57,9 @@ class MonadIO m => HasDerivedKey s (a :: CryptoAction) nonce m where -- TODO: move-to-an-appropriate-place newtype AsGroupKeyFile a = AsGroupKeyFile a -data family ToEncrypt (scheme :: GroupKeyScheme) s a -- = ToEncrypt a +data family ToEncrypt (scheme :: GroupKeyScheme) (s :: CryptoScheme) a -- = ToEncrypt a -data family ToDecrypt (scheme :: GroupKeyScheme) s a +data family ToDecrypt (scheme :: GroupKeyScheme) (s :: CryptoScheme) a -- FIXME: move-to-a-crypto-definition-modules @@ -168,7 +172,6 @@ instance HasPeer L4Proto where } deriving stock (Eq,Ord,Show,Generic) - instance AddrPriority (Peer L4Proto) where addrPriority (PeerL4 _ sa) = addrPriority sa diff --git a/hbs2-core/lib/HBS2/OrDie.hs b/hbs2-core/lib/HBS2/OrDie.hs index 183c0c28..43f229a5 100644 --- a/hbs2-core/lib/HBS2/OrDie.hs +++ b/hbs2-core/lib/HBS2/OrDie.hs @@ -74,4 +74,9 @@ orThrowUser :: (OrThrow a1, MonadIO m) orThrowUser p = orThrow (userError (show p)) +orThrowPassIO :: (MonadIO m, Exception e) => Either e a -> m a +orThrowPassIO = \case + Left e -> throwIO e + Right x -> pure x + diff --git a/hbs2-core/lib/HBS2/Prelude.hs b/hbs2-core/lib/HBS2/Prelude.hs index ad203758..28d1d192 100644 --- a/hbs2-core/lib/HBS2/Prelude.hs +++ b/hbs2-core/lib/HBS2/Prelude.hs @@ -24,6 +24,7 @@ module HBS2.Prelude , (&), (<&>), for_, for , HasErrorStatus(..), ErrorStatus(..), SomeError(..), WithSomeError(..), mayE, someE , ByFirst(..) + , whenTrue, whenFalse ) where import HBS2.Clock @@ -95,6 +96,11 @@ instance Monad m => ToMPlus (MaybeT m) (Either x a) where toMPlus (Left{}) = mzero toMPlus (Right x) = MaybeT $ pure (Just x) +whenTrue :: forall m b a . (Monad m) => b -> Bool -> m a -> (b -> m a) -> m a +whenTrue b f fallback continue = if f then continue b else fallback + +whenFalse :: forall m b a . (Monad m) => b -> Bool -> m a -> (b -> m a) -> m a +whenFalse b f fallback continue = if not f then continue b else fallback data ErrorStatus = Complete | HasIssuesButOkay diff --git a/hbs2-core/lib/HBS2/Storage/Operations/Class.hs b/hbs2-core/lib/HBS2/Storage/Operations/Class.hs index 2ae0a6e6..f69eeacb 100644 --- a/hbs2-core/lib/HBS2/Storage/Operations/Class.hs +++ b/hbs2-core/lib/HBS2/Storage/Operations/Class.hs @@ -11,6 +11,7 @@ import Data.Kind data OperationError = StorageError | CryptoError + | SignCheckError | DecryptError | DecryptionError | MissedBlockError diff --git a/hbs2-core/lib/HBS2/System/Dir.hs b/hbs2-core/lib/HBS2/System/Dir.hs index 18f49514..18a79a1e 100644 --- a/hbs2-core/lib/HBS2/System/Dir.hs +++ b/hbs2-core/lib/HBS2/System/Dir.hs @@ -47,9 +47,7 @@ touch what = do when (not here || hard) do mkdir (takeDirectory fn) - liftIO $ print (takeDirectory fn) unless dir do - liftIO $ print fn liftIO $ LBS.appendFile fn mempty where @@ -71,4 +69,16 @@ expandPath = liftIO . D.canonicalizePath doesDirectoryExist :: MonadIO m => FilePath -> m Bool doesDirectoryExist = liftIO . D.doesDirectoryExist +fileSize :: MonadIO m => FilePath -> m Integer +fileSize = liftIO . D.getFileSize + +mv :: MonadIO m => FilePath -> FilePath -> m () +mv a b = liftIO $ D.renamePath a b + +rm :: MonadIO m => FilePath -> m () +rm fn = liftIO $ D.removePathForcibly fn + +home :: MonadIO m => m FilePath +home = liftIO D.getHomeDirectory + diff --git a/hbs2-core/test/DialogSpec.hs b/hbs2-core/test/DialogSpec.hs deleted file mode 100644 index 59222f5e..00000000 --- a/hbs2-core/test/DialogSpec.hs +++ /dev/null @@ -1,63 +0,0 @@ -module DialogSpec where - -import Test.QuickCheck -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck as TastyQ - -import Control.Concurrent.Async -import Control.Monad -import Control.Monad -import Data.ByteString (ByteString) -import Data.ByteString qualified as BS -import GHC.Generics (Generic) -import Lens.Micro.Platform -import System.IO - -import HBS2.Net.Dialog.Core -import HBS2.Net.Dialog.Helpers.List - -newtype BSA = BSA { unBSA :: ByteString } - deriving (Generic, Show) - -instance Arbitrary BSA where - arbitrary = BSA <$> randomSizedByteString - - -- shrink = \case - -- BSA bs | BS.length bs > 1 -> - -- let (bs1, bs2) = BS.splitAt (BS.length bs `div` 2) bs - -- in [BSA bs1, BSA bs2] - -- _ -> [] - - shrink = \case - BSA (BS.uncons -> Just (x, xs)) -> [BSA xs] - _ -> [] - -deriving via [BSA] instance Arbitrary Frames - -randomByteString :: Int -> Gen ByteString -randomByteString n = - vectorOf n arbitrary <&> BS.pack -{-# NOINLINE randomByteString #-} - -randomSizedByteString :: Gen ByteString -randomSizedByteString = do - let low = 0 - let high = 2^13 - size <- choose (low, high) - randomByteString size -{-# NOINLINE randomSizedByteString #-} - -property' name = li . (name, ) . property - -testDialog :: TestTree -testDialog = testGroup "dialog" $ buildList do - li . TastyQ.testProperties "props" $ buildList do - - property' "roundtrip encode Frames" \ xs -> - (decodeFrames . encodeFrames) xs == Right xs - - property' "encodeFrames is quasidistributive over mappend" \ (xs, ys) -> - BS.drop (BS.length (encodeFrames xs)) (encodeFrames (xs <> ys)) - == encodeFrames ys - diff --git a/hbs2-core/test/Main.hs b/hbs2-core/test/Main.hs index 372a83e1..1bff83a0 100644 --- a/hbs2-core/test/Main.hs +++ b/hbs2-core/test/Main.hs @@ -2,7 +2,6 @@ module Main where import TestFakeMessaging import TestActors -import DialogSpec import TestFileLogger import TestScheduled import TestDerivedKey @@ -20,9 +19,6 @@ main = , testCase "testFileLogger" testFileLogger , testCase "testScheduledActions" testScheduled , testCase "testDerivedKeys1" testDerivedKeys1 - - -- FIXME does-not-finish - -- , testDialog ] diff --git a/hbs2-core/test/TestDerivedKey.hs b/hbs2-core/test/TestDerivedKey.hs index 0360b014..b2116396 100644 --- a/hbs2-core/test/TestDerivedKey.hs +++ b/hbs2-core/test/TestDerivedKey.hs @@ -15,15 +15,15 @@ import Data.Word testDerivedKeys1 :: IO () testDerivedKeys1 = do - cred <- newCredentials @HBS2Basic + cred <- newCredentials @'HBS2Basic let _ = view peerSignPk cred let sk = view peerSignSk cred let nonce = 0x123456780928934 :: Word64 - (pk1,sk1) <- derivedKey @HBS2Basic @'Sign nonce sk + (pk1,sk1) <- derivedKey @'HBS2Basic @'Sign nonce sk - let box = makeSignedBox @L4Proto pk1 sk1 (42 :: Word32) + let box = makeSignedBox @'HBS2Basic pk1 sk1 (42 :: Word32) (pk, n) <- pure (unboxSignedBox0 box) `orDie` "can not unbox" diff --git a/hbs2-fixer/app/Main.hs b/hbs2-fixer/app/Main.hs index f246e39e..e454f681 100644 --- a/hbs2-fixer/app/Main.hs +++ b/hbs2-fixer/app/Main.hs @@ -56,14 +56,16 @@ import System.Exit qualified as Exit import Data.Cache qualified as Cache import Data.Cache (Cache) +import System.Exit + {- HLINT ignore "Functor law" -} type Config = [Syntax C] -type RLWW = LWWRefKey HBS2Basic -type RRefLog = RefLogKey HBS2Basic +type RLWW = LWWRefKey 'HBS2Basic +type RRefLog = RefLogKey 'HBS2Basic newtype Watcher = Watcher [Syntax C] @@ -79,7 +81,7 @@ instance Pretty Ref where pretty (RefLWW r) = parens $ "lwwref" <+> dquotes (pretty r) newtype AnyPolledRef = - AnyPolledRef (PubKey 'Sign HBS2Basic) + AnyPolledRef (PubKey 'Sign 'HBS2Basic) deriving (Eq,Generic) instance Hashable AnyPolledRef @@ -89,7 +91,7 @@ deriving newtype instance Hashable Id instance Pretty AnyPolledRef where pretty (AnyPolledRef r) = pretty (AsBase58 r) --- deriving newtype instance Pretty (PubKey 'Sign HBS2Basic) => Pretty AnyPolledRef +-- deriving newtype instance Pretty (PubKey 'Sign 'HBS2Basic) => Pretty AnyPolledRef instance FromStringMaybe AnyPolledRef where fromStringMay = fmap AnyPolledRef . fromStringMay @@ -133,7 +135,7 @@ instance MonadIO m => HasConf (FixerM m) where debugPrefix = toStdout . logPrefix "[debug] " -readConf :: MonadIO m => FilePath -> m [Syntax MegaParsec] +readConf :: MonadIO m => FilePath -> m [Syntax C] readConf fn = liftIO (readFile fn) <&> parseTop <&> fromRight mempty withConfig :: MonadUnliftIO m => Maybe FilePath -> FixerM m () -> FixerM m () @@ -158,67 +160,80 @@ withApp cfgPath action = do setLogging @WARN warnPrefix setLogging @NOTICE noticePrefix - soname <- detectRPC - `orDie` "can't detect RPC" + fix \next -> do - flip runContT pure do + flip runContT pure do - client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname) - >>= orThrowUser ("can't connect to" <+> pretty soname) + soname' <- lift detectRPC - void $ ContT $ withAsync $ runMessagingUnix client + soname <- ContT $ maybe1 soname' (pure ()) - peerAPI <- makeServiceCaller @PeerAPI (fromString soname) - refLogAPI <- makeServiceCaller @RefLogAPI (fromString soname) - storageAPI <- makeServiceCaller @StorageAPI (fromString soname) - lwwAPI <- makeServiceCaller @LWWRefAPI (fromString soname) + client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname) + >>= orThrowUser ("can't connect to" <+> pretty soname) - let endpoints = [ Endpoint @UNIX peerAPI - , Endpoint @UNIX refLogAPI - , Endpoint @UNIX lwwAPI - , Endpoint @UNIX storageAPI - ] + mess <- ContT $ withAsync $ runMessagingUnix client - void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client + peerAPI <- makeServiceCaller @PeerAPI (fromString soname) + refLogAPI <- makeServiceCaller @RefLogAPI (fromString soname) + storageAPI <- makeServiceCaller @StorageAPI (fromString soname) + lwwAPI <- makeServiceCaller @LWWRefAPI (fromString soname) - let o = [MUWatchdog 20, MUDontRetry] - clientN <- newMessagingUnixOpts o False 1.0 soname + let endpoints = [ Endpoint @UNIX peerAPI + , Endpoint @UNIX refLogAPI + , Endpoint @UNIX lwwAPI + , Endpoint @UNIX storageAPI + ] - void $ ContT $ withAsync $ runMessagingUnix clientN + mn <- ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client - sink <- newNotifySink + let o = [MUWatchdog 20,MUDontRetry] + clientN <- newMessagingUnixOpts o False 1.0 soname - void $ ContT $ withAsync $ flip runReaderT clientN $ do - debug $ red "notify restarted!" - runNotifyWorkerClient sink + notif <- ContT $ withAsync (runMessagingUnix clientN) - void $ ContT $ withAsync $ flip runReaderT clientN $ do - runProto @UNIX - [ makeResponse (makeNotifyClient @(RefLogEvents L4Proto) sink) - ] - env <- FixerEnv Nothing - lwwAPI - refLogAPI - sink - peerAPI - (AnyStorage (StorageClient storageAPI)) - <$> newTVarIO mempty - <*> newTVarIO 30 - <*> newTVarIO mempty - <*> newTVarIO mempty - <*> newTVarIO mempty - <*> newTVarIO 0 - <*> newTVarIO mempty - <*> newTQueueIO + sink <- newNotifySink - lift $ runReaderT (runFixerM $ withConfig cfgPath action) env - `finally` do - setLoggingOff @DEBUG - setLoggingOff @INFO - setLoggingOff @ERROR - setLoggingOff @WARN - setLoggingOff @NOTICE + void $ ContT $ withAsync $ flip runReaderT clientN $ do + debug $ red "notify restarted!" + runNotifyWorkerClient sink + + p1 <- ContT $ withAsync $ flip runReaderT clientN $ do + runProto @UNIX + [ makeResponse (makeNotifyClient @(RefLogEvents L4Proto) sink) + ] + + env <- FixerEnv Nothing + lwwAPI + refLogAPI + sink + peerAPI + (AnyStorage (StorageClient storageAPI)) + <$> newTVarIO mempty + <*> newTVarIO 30 + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO mempty + <*> newTVarIO 0 + <*> newTVarIO mempty + <*> newTQueueIO + + void $ ContT $ bracket (pure ()) $ \_ -> do + readTVarIO (_listeners env) <&> HM.elems >>= mapM_ cancel + + p3 <- ContT $ withAsync $ runReaderT (runFixerM $ withConfig cfgPath action) env + + void $ waitAnyCatchCancel [mess,mn,notif,p1,p3] + + debug $ red "respawning..." + pause @'Seconds 5 + next + + setLoggingOff @DEBUG + setLoggingOff @INFO + setLoggingOff @ERROR + setLoggingOff @WARN + setLoggingOff @NOTICE where errorPrefix = toStdout . logPrefix "[error] " @@ -232,16 +247,18 @@ data ConfWatch = | ConfUpdate [Syntax C] mainLoop :: FixerM IO () -mainLoop = forever $ do +mainLoop = do debug "hbs2-fixer. do stuff since 2024" conf <- getConf -- debug $ line <> vcat (fmap pretty conf) flip runContT pure do + debug $ red "Reloading..." + lift $ updateFromConfig conf - void $ ContT $ withAsync $ do + p1 <- ContT $ withAsync $ do cfg <- asks _configFile `orDie` "config file not specified" flip fix ConfRead $ \next -> \case @@ -271,7 +288,7 @@ mainLoop = forever $ do next ConfRead -- poll reflogs - void $ ContT $ withAsync do + p2 <- ContT $ withAsync do let w = asks _watchers >>= readTVarIO @@ -292,15 +309,20 @@ mainLoop = forever $ do pure () - jobs <- asks _pipeline - void $ ContT $ withAsync $ forever do - liftIO $ E.try @SomeException (join $ atomically $ readTQueue jobs) - >>= \case - Left e -> err (viaShow e) - _ -> pure () + p3 <- ContT $ withAsync $ fix \next -> do + r <- liftIO $ E.try @SomeException (join $ atomically $ readTQueue jobs) + case r of + Left e -> do + err (viaShow e) + let ee = fromException @AsyncCancelled e - forever $ pause @'Seconds 60 + unless (isJust ee) do + next + + _ -> next + + void $ waitAnyCatchCancel [p1,p2,p3] oneSec :: MonadUnliftIO m => m b -> m (Either () b) oneSec = race (pause @'Seconds 1) diff --git a/hbs2-fixer/hbs2-fixer.cabal b/hbs2-fixer/hbs2-fixer.cabal index e6aa884f..01beff6a 100644 --- a/hbs2-fixer/hbs2-fixer.cabal +++ b/hbs2-fixer/hbs2-fixer.cabal @@ -68,7 +68,6 @@ common shared-properties , streaming , streaming-bytestring , streaming-commons - , streaming-utils , cryptonite , directory , exceptions diff --git a/hbs2-git/git-hbs2-subscribe/Main.hs b/hbs2-git/git-hbs2-subscribe/Main.hs index d65fdaa5..00aa909a 100644 --- a/hbs2-git/git-hbs2-subscribe/Main.hs +++ b/hbs2-git/git-hbs2-subscribe/Main.hs @@ -28,7 +28,7 @@ main = do where - pLww :: ReadM (LWWRefKey HBS2Basic) + pLww :: ReadM (LWWRefKey 'HBS2Basic) pLww = maybeReader fromStringMay @@ -66,7 +66,7 @@ instance Monad m => HasAPI LWWRefAPI UNIX (MyApp m) where instance Monad m => HasAPI RefLogAPI UNIX (MyApp m) where getAPI = asks _refLogAPI -subscribe :: forall m . MonadUnliftIO m => Maybe String -> LWWRefKey HBS2Basic -> m () +subscribe :: forall m . MonadUnliftIO m => Maybe String -> LWWRefKey 'HBS2Basic -> m () subscribe soname' ref = do soname <- maybe1 soname' detectRPC (pure.Just) `orDie` "can't locate rpc" diff --git a/hbs2-git/git-hbs2/Main.hs b/hbs2-git/git-hbs2/Main.hs index 65a4d950..8040cc0f 100644 --- a/hbs2-git/git-hbs2/Main.hs +++ b/hbs2-git/git-hbs2/Main.hs @@ -7,17 +7,32 @@ import HBS2.Git.Client.Export import HBS2.Git.Client.Import import HBS2.Git.Client.State +import HBS2.Data.Types.SignedBox +import HBS2.Git.Data.RepoHead import HBS2.Git.Data.RefLog import HBS2.Git.Local.CLI qualified as Git -import HBS2.Git.Data.Tx qualified as TX -import HBS2.Git.Data.Tx (RepoHead(..)) +import HBS2.Git.Data.Tx.Git qualified as TX +import HBS2.Git.Data.Tx.Git (RepoHead(..)) +import HBS2.Git.Data.Tx.Index import HBS2.Git.Data.LWWBlock +import HBS2.Peer.Proto.RefChan.Types import HBS2.Git.Data.GK +import HBS2.KeyMan.Keys.Direct import HBS2.Storage.Operations.ByteString +import Data.Text qualified as Text +import Data.Text.IO qualified as Text +import Data.HashSet qualified as HS +import Data.Maybe +import Data.Coerce import Options.Applicative as O import Data.ByteString.Lazy qualified as LBS +import Data.ByteString (ByteString) +-- import Data.ByteString.Lazy (ByteString) +import Text.InterpolatedString.Perl6 (qc) + +import Streaming.Prelude qualified as S import System.Exit @@ -36,18 +51,22 @@ globalOptions = do commands :: GitPerks m => Parser (GitCLI m ()) commands = - hsubparser ( command "export" (info pExport (progDesc "export repo to hbs2-git")) - <> command "import" (info pImport (progDesc "import repo from reflog")) - <> command "key" (info pKey (progDesc "key management")) - <> command "tools" (info pTools (progDesc "misc tools")) + hsubparser ( command "export" (info pExport (progDesc "export repo to hbs2-git")) + <> command "import" (info pImport (progDesc "import repo from reflog")) + <> command "key" (info pKey (progDesc "key management")) + <> command "manifest" (info pManifest (progDesc "manifest commands")) + <> command "track" (info pTrack (progDesc "track tools")) + <> command "tools" (info pTools (progDesc "misc tools")) ) pRefLogId :: ReadM RefLogId pRefLogId = maybeReader (fromStringMay @RefLogId) +pRefChanId :: ReadM GitRefChanId +pRefChanId = maybeReader (fromStringMay @GitRefChanId) -pLwwKey :: ReadM (LWWRefKey HBS2Basic) +pLwwKey :: ReadM (LWWRefKey 'HBS2Basic) pLwwKey = maybeReader fromStringMay pHashRef :: ReadM HashRef @@ -150,9 +169,48 @@ pShowRef = do tx <- withState do selectMaxAppliedTx >>= lift . toMPlus <&> fst - rh <- TX.readRepoHeadFromTx sto tx >>= toMPlus + (_,rh) <- TX.readRepoHeadFromTx sto tx >>= toMPlus - liftIO $ print $ vcat (fmap formatRef (_repoHeadRefs rh)) + liftIO $ print $ vcat (fmap formatRef (view repoHeadRefs rh)) + + +pManifest :: GitPerks m => Parser (GitCLI m ()) +pManifest = hsubparser ( command "list" (info pManifestList (progDesc "list all manifest")) + <> command "show" (info pManifestShow (progDesc "show manifest")) + ) + +pManifestList :: GitPerks m => Parser (GitCLI m ()) +pManifestList = do + what <- argument pLwwKey (metavar "LWWREF") + pure do + heads <- withState $ selectRepoHeadsFor ASC what + sto <- getStorage + for_ heads $ \h -> runMaybeT do + + rhead <- runExceptT (readFromMerkle sto (SimpleKey (coerce h))) + >>= toMPlus + <&> deserialiseOrFail @RepoHead + >>= toMPlus + + let mfsize = maybe 0 Text.length (_repoManifest rhead) + let mf = parens ( "manifest" <+> pretty mfsize) + + liftIO $ print $ pretty (_repoHeadTime rhead) + <+> pretty h + <+> mf + +pManifestShow :: GitPerks m => Parser (GitCLI m ()) +pManifestShow = do + what <- argument pHashRef (metavar "HASH") + pure do + + sto <- getStorage + rhead <- runExceptT (readFromMerkle sto (SimpleKey (coerce what))) + >>= orThrowUser "repo head not found" + <&> deserialiseOrFail @RepoHead + >>= orThrowUser "repo head format not supported" + + liftIO $ for_ (_repoManifest rhead) Text.putStrLn pKey :: GitPerks m => Parser (GitCLI m ()) @@ -171,8 +229,8 @@ pKeyShow = do tx <- withState do selectMaxAppliedTx >>= lift . toMPlus <&> fst - rh <- TX.readRepoHeadFromTx sto tx - >>= toMPlus + (_,rh) <- TX.readRepoHeadFromTx sto tx + >>= toMPlus gkh <- toMPlus (_repoHeadGK0 rh) @@ -205,6 +263,90 @@ pKeyUpdate = do Nothing -> liftIO $ putStrLn "not added" >> exitFailure Just x -> liftIO $ print $ pretty x + +pTrack :: GitPerks m => Parser (GitCLI m ()) +pTrack = hsubparser ( command "send-repo-notify" (info pSendRepoNotify (progDesc "sends repository notification")) + <> command "show-repo-notify" (info pShowRepoNotify (progDesc "shows repository notification")) + <> command "gen-repo-index" (info pGenRepoIndex (progDesc "generates repo index tx")) + ) + +pSendRepoNotify :: GitPerks m => Parser (GitCLI m ()) +pSendRepoNotify = do + dry <- flag False True (short 'n' <> long "dry" <> help "don't post anything") + notifyChan <- argument pRefChanId (metavar "CHANNEL-KEY") + pure do + notice $ "test send-repo-notify" <+> pretty (AsBase58 notifyChan) + -- откуда мы берём ссылку, которую постим? их много. + + lwws <- withState selectAllLww + + -- берём те, для которых у нас есть приватный ключ (наши) + creds <- catMaybes <$> runKeymanClient do + for lwws $ \(lwref,_,_) -> do + loadCredentials (coerce @_ @(PubKey 'Sign 'HBS2Basic) lwref) + + sto <- getStorage + rchanAPI <- asks _refChanAPI + + hd <- getRefChanHead @L4Proto sto (RefChanHeadKey notifyChan) + `orDie` "refchan head not found" + + let notifiers = view refChanHeadNotifiers hd & HS.toList + + -- откуда мы берём ключ, которым подписываем? + -- ищем тоже в кеймане, берём тот, у которого выше weight + foundKey <- runKeymanClient ( + S.head_ do + for notifiers $ \n -> do + lift (loadCredentials n) >>= maybe none S.yield + ) `orDie` "signing key not found" + + for_ creds $ \c -> do + let lww = LWWRefKey @'HBS2Basic (view peerSignPk c) + let lwwSk = view peerSignSk c + let tx = makeNotificationTx @'HBS2Basic (NotifyCredentials foundKey) lww lwwSk Nothing + + notice $ "about to publish lwwref index entry:" + <+> pretty (AsBase58 $ view peerSignPk c) + + -- как мы постим ссылку + unless dry do + void $ callService @RpcRefChanNotify rchanAPI (notifyChan, tx) + + -- кто парсит ссылку и помещает в рефчан + + +pShowRepoNotify :: GitPerks m => Parser (GitCLI m ()) +pShowRepoNotify = do + href <- argument pHashRef (metavar "HASH") + pure do + sto <- asks _storage + + box <- getBlock sto (coerce href) + `orDie` "tx not found" + <&> deserialiseOrFail @(RefChanNotify L4Proto) + >>= orThrowUser "malformed announce tx 1" + >>= \case + Notify _ box -> pure box + _ -> throwIO (userError "malformed announce tx 2") + + ann <- runExceptT (unpackNotificationTx box) + >>= either (error . show) pure + + liftIO $ print $ pretty ann + + +pGenRepoIndex :: GitPerks m => Parser (GitCLI m ()) +pGenRepoIndex = do + what <- argument pLwwKey (metavar "LWWREF") + pure do + hd <- withState $ selectRepoIndexEntryFor what + >>= orThrowUser "no decent repo head data found" + + seq <- getEpoch + let tx = GitIndexTx what seq (GitIndexRepoDefine hd) + liftIO $ LBS.putStr (serialise tx) + main :: IO () main = do (o, action) <- customExecParser (prefs showHelpOnError) $ diff --git a/hbs2-git/git-remote-hbs2/Main.hs b/hbs2-git/git-remote-hbs2/Main.hs index 7bd78504..d600be82 100644 --- a/hbs2-git/git-remote-hbs2/Main.hs +++ b/hbs2-git/git-remote-hbs2/Main.hs @@ -9,9 +9,10 @@ import HBS2.Git.Client.Export import HBS2.Git.Client.State import HBS2.Git.Client.Progress import HBS2.Git.Client.Config +import HBS2.Git.Data.RepoHead import HBS2.Git.Data.RefLog -import HBS2.Git.Data.Tx qualified as TX -import HBS2.Git.Data.Tx (RepoHead(..)) +import HBS2.Git.Data.Tx.Git qualified as TX +import HBS2.Git.Data.Tx.Git (RepoHead(..)) import HBS2.Git.Data.LWWBlock import HBS2.System.Dir @@ -48,7 +49,7 @@ sendLine = liftIO . IO.putStrLn die :: (MonadIO m, Pretty a) => a -> m b die s = liftIO $ Exit.die (show $ pretty s) -parseURL :: String -> Maybe (LWWRefKey HBS2Basic) +parseURL :: String -> Maybe (LWWRefKey 'HBS2Basic) parseURL s = eitherToMaybe $ Atto.parseOnly p (BS8.pack s) where p = do @@ -56,7 +57,7 @@ parseURL s = eitherToMaybe $ Atto.parseOnly p (BS8.pack s) Atto.takeWhile1 (`elem` getAlphabet) <&> BS8.unpack - <&> fromStringMay @(LWWRefKey HBS2Basic) + <&> fromStringMay @(LWWRefKey 'HBS2Basic) >>= maybe (fail "invalid reflog key") pure parsePush :: String -> Maybe (Maybe GitRef, GitRef) @@ -177,8 +178,8 @@ main = do r' <- runMaybeT $ withState do tx <- selectMaxAppliedTx >>= lift . toMPlus <&> fst - rh <- TX.readRepoHeadFromTx sto tx >>= lift . toMPlus - pure (_repoHeadRefs rh) + (_,rh) <- TX.readRepoHeadFromTx sto tx >>= lift . toMPlus + pure (view repoHeadRefs rh) let r = fromMaybe mempty r' diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App.hs index adb2382c..adec00fa 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App.hs @@ -9,7 +9,7 @@ import HBS2.Git.Client.Config import HBS2.Git.Client.Progress import HBS2.Git.Client.State -import HBS2.Git.Data.Tx +import HBS2.Git.Data.Tx.Git import HBS2.Git.Local.CLI @@ -136,11 +136,13 @@ runGitCLI o m = do peerAPI <- makeServiceCaller @PeerAPI (fromString soname) refLogAPI <- makeServiceCaller @RefLogAPI (fromString soname) + refChanAPI <- makeServiceCaller @RefChanAPI (fromString soname) storageAPI <- makeServiceCaller @StorageAPI (fromString soname) lwwAPI <- makeServiceCaller @LWWRefAPI (fromString soname) let endpoints = [ Endpoint @UNIX peerAPI , Endpoint @UNIX refLogAPI + , Endpoint @UNIX refChanAPI , Endpoint @UNIX lwwAPI , Endpoint @UNIX storageAPI ] @@ -160,7 +162,7 @@ runGitCLI o m = do progress <- ContT $ withAsync (drawProgress q) - env <- lift $ newGitEnv ip o git cpath conf peerAPI refLogAPI lwwAPI storageAPI + env <- lift $ newGitEnv ip o git cpath conf peerAPI refLogAPI refChanAPI lwwAPI storageAPI lift $ runReaderT setupLogging env lift $ withGitEnv env (evolveDB >> m) `finally` do diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types.hs index 60dfa627..0e29200b 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types.hs @@ -13,7 +13,7 @@ import HBS2.Git.Client.Progress import HBS2.Git.Local import HBS2.Git.Client.App.Types.GitEnv -import HBS2.Git.Data.Tx +import HBS2.Git.Data.Tx.Git import HBS2.Git.Data.GK import HBS2.KeyMan.Keys.Direct @@ -85,11 +85,12 @@ newGitEnv :: GitPerks m -> Config -> ServiceCaller PeerAPI UNIX -> ServiceCaller RefLogAPI UNIX + -> ServiceCaller RefChanAPI UNIX -> ServiceCaller LWWRefAPI UNIX -> ServiceCaller StorageAPI UNIX -> m GitEnv -newGitEnv p opts path cpath conf peer reflog lww sto = do +newGitEnv p opts path cpath conf peer reflog rchan lww sto = do let dbfile = cpath "state.db" let dOpt = dbPipeOptsDef { dbLogger = \x -> debug ("state:" <+> pretty x) } db <- newDBPipeEnv dOpt dbfile @@ -105,6 +106,7 @@ newGitEnv p opts path cpath conf peer reflog lww sto = do conf peer reflog + rchan lww (AnyStorage (StorageClient sto)) db diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types/GitEnv.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types/GitEnv.hs index e6af7086..75b5c15d 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types/GitEnv.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/App/Types/GitEnv.hs @@ -42,11 +42,12 @@ data GitEnv = , _config :: Config , _peerAPI :: ServiceCaller PeerAPI UNIX , _refLogAPI :: ServiceCaller RefLogAPI UNIX + , _refChanAPI :: ServiceCaller RefChanAPI UNIX , _lwwRefAPI :: ServiceCaller LWWRefAPI UNIX , _storage :: AnyStorage -- ServiceCaller StorageAPI UNIX , _db :: DBPipeEnv , _progress :: AnyProgress - , _keyringCache :: TVar (HashMap HashRef [KeyringEntry HBS2Basic]) + , _keyringCache :: TVar (HashMap HashRef [KeyringEntry 'HBS2Basic]) } diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs index c48ee7b1..8bea1a4d 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Export.hs @@ -9,7 +9,7 @@ import HBS2.Git.Client.State import HBS2.Git.Client.Progress import HBS2.Git.Data.RefLog -import HBS2.Git.Data.Tx +import HBS2.Git.Data.Tx.Git import HBS2.Git.Data.LWWBlock import HBS2.Git.Data.GK @@ -109,9 +109,8 @@ refsForExport forPushL = do <&> mapMaybe \case [val,name] -> (GitRef (LBS8.toStrict name),) <$> fromStringMay @GitHash (LBS8.unpack val) _ -> Nothing - <&> filterPat incl excl <&> HashMap.fromList - <&> HashMap.filterWithKey (\k _ -> not (HashSet.member k deleted)) + <&> HashMap.mapWithKey (\k v -> if k `HashSet.member` deleted then gitHashTomb else v) <&> mappend forPush <&> mappend (HashMap.singleton currentBranch currentVal) <&> HashMap.toList @@ -153,7 +152,7 @@ export :: ( GitPerks m , GroupKeyOperations m , HasAPI PeerAPI UNIX m ) - => LWWRefKey HBS2Basic + => LWWRefKey 'HBS2Basic -> [(GitRef,Maybe GitHash)] -> m () export key refs = do @@ -177,7 +176,7 @@ export key refs = do >>= orThrowUser ("can't load credentials" <+> pretty (AsBase58 puk0)) pure ( view peerSignSk creds, view peerSignPk creds ) - (puk,sk) <- derivedKey @HBS2Basic @'Sign lwwRefSeed sk0 + (puk,sk) <- derivedKey @'HBS2Basic @'Sign lwwRefSeed sk0 subscribeRefLog puk @@ -191,7 +190,9 @@ export key refs = do tx0 <- getLastAppliedTx - rh0 <- runMaybeT ( toMPlus tx0 >>= readRepoHeadFromTx sto >>= toMPlus ) + rh <- runMaybeT ( toMPlus tx0 >>= readRepoHeadFromTx sto >>= toMPlus ) + + let rh0 = snd <$> rh (name,brief,mf) <- lift getManifest @@ -216,7 +217,7 @@ export key refs = do repohead <- makeRepoHeadSimple name brief mf gk0 myrefs - let oldRefs = maybe mempty _repoHeadRefs rh0 + let oldRefs = maybe mempty repoHeadRefs' rh0 trace $ "TX0" <+> pretty tx0 diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs index 1d150d23..3d61e28e 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Import.hs @@ -7,8 +7,9 @@ import HBS2.Git.Client.RefLog import HBS2.Git.Client.Progress import HBS2.Git.Data.RefLog -import HBS2.Git.Data.Tx +import HBS2.Git.Data.Tx.Git import HBS2.Git.Data.LWWBlock +import HBS2.Git.Data.RepoHead import Data.ByteString.Lazy qualified as LBS @@ -66,7 +67,7 @@ merelySubscribeRepo :: forall e s m . ( GitPerks m , e ~ L4Proto , s ~ Encryption e ) - => LWWRefKey HBS2Basic + => LWWRefKey 'HBS2Basic -> m (Maybe (PubKey 'Sign s)) merelySubscribeRepo lwwKey = do @@ -108,7 +109,7 @@ importRepoWait :: ( GitPerks m , HasAPI LWWRefAPI UNIX m , HasAPI RefLogAPI UNIX m ) - => LWWRefKey HBS2Basic + => LWWRefKey 'HBS2Basic -> m () importRepoWait lwwKey = do @@ -291,7 +292,7 @@ applyTx h = do applyHeads rh = do - let refs = _repoHeadRefs rh + let refs = view repoHeadRefs rh withGitFastImport $ \ps -> do let psin = getStdin ps diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Prelude.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Prelude.hs index 6f2df4f9..c3e7959a 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Prelude.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Prelude.hs @@ -17,6 +17,7 @@ module HBS2.Git.Client.Prelude , module HBS2.Peer.Proto.LWWRef , module HBS2.Peer.RPC.API.Peer , module HBS2.Peer.RPC.API.RefLog + , module HBS2.Peer.RPC.API.RefChan , module HBS2.Peer.RPC.API.LWWRef , module HBS2.Peer.RPC.API.Storage , module HBS2.Peer.RPC.Client.StorageClient @@ -33,6 +34,7 @@ module HBS2.Git.Client.Prelude , getSocketName , formatRef , deserialiseOrFail + , GitRefChanId ) where import HBS2.Prelude.Plated hiding (at) @@ -56,6 +58,7 @@ import HBS2.Net.Proto.Service import HBS2.Peer.Proto.LWWRef import HBS2.Peer.RPC.API.Peer import HBS2.Peer.RPC.API.RefLog +import HBS2.Peer.RPC.API.RefChan import HBS2.Peer.RPC.API.LWWRef import HBS2.Peer.RPC.API.Storage import HBS2.Peer.RPC.Client.StorageClient @@ -73,6 +76,9 @@ import System.Process.Typed import Lens.Micro.Platform import Codec.Serialise +-- FIXME: subject-to-change-signature +type GitRefChanId = RefChanId L4Proto + data RPCNotFoundError = RPCNotFoundError deriving stock (Show,Typeable) diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Progress.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Progress.hs index f865db30..a5de597a 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Progress.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/Progress.hs @@ -6,7 +6,7 @@ import HBS2.Git.Client.Prelude import HBS2.Git.Data.RefLog import HBS2.Git.Data.LWWBlock -import HBS2.Git.Data.Tx +import HBS2.Git.Data.Tx.Git data Progress a = Progress @@ -22,7 +22,7 @@ class HasProgress a where data ProgressEvent = ImportIdle - | ImportWaitLWW Int (LWWRefKey HBS2Basic) + | ImportWaitLWW Int (LWWRefKey 'HBS2Basic) | ImportRefLogStart RefLogId | ImportRefLogDone RefLogId (Maybe HashRef) | ImportWaitTx HashRef diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/RefLog.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/RefLog.hs index 428882f6..4c536ef3 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/RefLog.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/RefLog.hs @@ -27,12 +27,12 @@ subscribeRefLog puk = do api <- getAPI @PeerAPI @UNIX void $ callService @RpcPollAdd api (puk, "reflog", 13) -subscribeLWWRef :: forall m . (GitPerks m, HasAPI PeerAPI UNIX m) => LWWRefKey HBS2Basic -> m () +subscribeLWWRef :: forall m . (GitPerks m, HasAPI PeerAPI UNIX m) => LWWRefKey 'HBS2Basic -> m () subscribeLWWRef puk = do api <- getAPI @PeerAPI @UNIX void $ callService @RpcPollAdd api (fromLwwRefKey puk, "lwwref", 17) -fetchLWWRef :: forall m . (GitPerks m, HasAPI LWWRefAPI UNIX m) => LWWRefKey HBS2Basic -> m () +fetchLWWRef :: forall m . (GitPerks m, HasAPI LWWRefAPI UNIX m) => LWWRefKey 'HBS2Basic -> m () fetchLWWRef key = do api <- getAPI @LWWRefAPI @UNIX void $ race (pause @'Seconds 1) (callService @RpcLWWRefFetch api key) diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/State.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/State.hs index 502980c3..d1597beb 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/State.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Client/State.hs @@ -11,15 +11,32 @@ import HBS2.Git.Client.App.Types import HBS2.Git.Client.Config import HBS2.Peer.Proto.RefLog +import HBS2.Storage.Operations.ByteString +import HBS2.Git.Data.RepoHead import HBS2.Git.Data.RefLog import HBS2.Git.Data.LWWBlock +import HBS2.Git.Data.Tx.Index import DBPipe.SQLite import Data.Maybe import Data.List qualified as List import Text.InterpolatedString.Perl6 (qc) +import Data.Text qualified as Text import Data.Word +import Data.Coerce + +import Streaming.Prelude qualified as S + +data Limit = Limit Integer + +data SortOrder = ASC | DESC + +newtype SQL a = SQL a + +instance Pretty (SQL SortOrder) where + pretty (SQL ASC) = "ASC" + pretty (SQL DESC) = "DESC" newtype Base58Field a = Base58Field { fromBase58Field :: a } deriving stock (Eq,Ord,Generic) @@ -30,7 +47,7 @@ instance Pretty (AsBase58 a) => ToField (Base58Field a) where instance IsString a => FromField (Base58Field a) where fromField = fmap (Base58Field . fromString) . fromField @String -instance FromField (RefLogKey HBS2Basic) where +instance FromField (RefLogKey 'HBS2Basic) where fromField = fmap fromString . fromField @String instance ToField HashRef where @@ -39,6 +56,8 @@ instance ToField HashRef where instance FromField HashRef where fromField = fmap fromString . fromField @String +deriving newtype instance FromField (TaggedHashRef t) + instance ToField GitHash where toField h = toField (show $ pretty h) @@ -51,7 +70,7 @@ instance FromField GitRef where instance FromField GitHash where fromField = fmap fromString . fromField @String -instance FromField (LWWRefKey HBS2Basic) where +instance FromField (LWWRefKey 'HBS2Basic) where fromField = fmap fromString . fromField @String createStateDir :: (GitPerks m, MonadReader GitEnv m) => m () @@ -367,16 +386,73 @@ limit 1 |] (Only (Base58Field reflog)) <&> listToMaybe -insertLww :: MonadIO m => LWWRefKey HBS2Basic -> Word64 -> RefLogId -> DBPipeM m () +insertLww :: MonadIO m => LWWRefKey 'HBS2Basic -> Word64 -> RefLogId -> DBPipeM m () insertLww lww snum reflog = do insert [qc| INSERT INTO lww (hash, seq, reflog) VALUES (?, ?, ?) ON CONFLICT (hash,seq,reflog) DO NOTHING |] (Base58Field lww, snum, Base58Field reflog) -selectAllLww :: MonadIO m => DBPipeM m [(LWWRefKey HBS2Basic, Word64, RefLogId)] +selectAllLww :: MonadIO m => DBPipeM m [(LWWRefKey 'HBS2Basic, Word64, RefLogId)] selectAllLww = do select_ [qc| SELECT hash, seq, reflog FROM lww - |] <&> fmap (over _3 (fromRefLogKey @HBS2Basic)) + |] <&> fmap (over _3 (fromRefLogKey @'HBS2Basic)) + + + +selectRepoHeadsFor :: (MonadIO m, HasStorage m) + => SortOrder + -> LWWRefKey 'HBS2Basic + -> DBPipeM m [TaggedHashRef RepoHead] + +selectRepoHeadsFor order what = do + let q = [qc| +SELECT t.head +FROM lww l join tx t on l.reflog = t.reflog +WHERE l.hash = ? +ORDER BY t.seq {pretty (SQL order)} +|] + + select @(Only (TaggedHashRef RepoHead)) q (Only $ Base58Field what) + <&> fmap fromOnly + + +instance (Monad m, HasStorage m) => HasStorage (DBPipeM m) where + getStorage = lift getStorage + +selectRepoIndexEntryFor :: (MonadIO m, HasStorage m) + => LWWRefKey 'HBS2Basic + -> DBPipeM m (Maybe GitIndexRepoDefineData) + +selectRepoIndexEntryFor what = runMaybeT do + + headz <- lift $ selectRepoHeadsFor DESC what + + rhh <- S.head_ do + for_ headz $ \ha -> do + rh' <- lift $ loadRepoHead ha + for_ rh' $ \rh -> do + when (notEmpty $ _repoManifest rh) do + S.yield rh + + + repohead <- toMPlus rhh + + pure $ GitIndexRepoDefineData (GitIndexRepoName $ _repoHeadName repohead) + (GitIndexRepoBrief $ _repoHeadBrief repohead) + + + where + notEmpty s = maybe 0 Text.length s > 0 + +loadRepoHead :: (HasStorage m, MonadIO m) => TaggedHashRef RepoHead -> m (Maybe RepoHead) +loadRepoHead rh = do + sto <- getStorage + runMaybeT do + runExceptT (readFromMerkle sto (SimpleKey (coerce rh))) + >>= toMPlus + <&> deserialiseOrFail @RepoHead + >>= toMPlus + diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/GK.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/GK.hs index dccc1979..fee45a4c 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/GK.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/GK.hs @@ -7,7 +7,7 @@ import HBS2.Storage.Operations.ByteString import Data.ByteString.Lazy qualified as LBS -type GK0 = GroupKey 'Symm HBS2Basic +type GK0 = GroupKey 'Symm 'HBS2Basic readGK0 :: (MonadIO m, MonadError OperationError m) => AnyStorage -> HashRef -> m GK0 readGK0 sto h = do @@ -22,5 +22,5 @@ loadGK0FromFile fp = runMaybeT do content <- liftIO (try @_ @IOError (LBS.readFile fp)) >>= toMPlus - toMPlus $ parseGroupKey @HBS2Basic (AsGroupKeyFile content) + toMPlus $ parseGroupKey @'HBS2Basic (AsGroupKeyFile content) diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/LWWBlock.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/LWWBlock.hs index b4c45261..87990441 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/LWWBlock.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/LWWBlock.hs @@ -3,7 +3,6 @@ module HBS2.Git.Data.LWWBlock ( module HBS2.Git.Data.LWWBlock , module HBS2.Peer.Proto.LWWRef - , HBS2Basic ) where import HBS2.Prelude.Plated @@ -42,19 +41,19 @@ import Control.Monad.Trans.Maybe -- (LWWRef PK) -> (LWWBlockData) -> (RefLog : [TX]) -- -data LWWBlockData e = +data LWWBlockData s = LWWBlockData { lwwRefSeed :: Word64 - , lwwRefLogPubKey :: PubKey 'Sign (Encryption e) + , lwwRefLogPubKey :: PubKey 'Sign s } deriving stock Generic -data LWWBlock e = - LWWBlock1 { lwwBlockData :: LWWBlockData e } +data LWWBlock s = + LWWBlock1 { lwwBlockData :: LWWBlockData s } deriving stock Generic -instance Serialise (PubKey 'Sign (Encryption e)) => Serialise (LWWBlockData e) -instance Serialise (PubKey 'Sign (Encryption e)) => Serialise (LWWBlock e) +instance Serialise (PubKey 'Sign s) => Serialise (LWWBlockData s) +instance Serialise (PubKey 'Sign s) => Serialise (LWWBlock s) data LWWBlockOpError = @@ -67,38 +66,34 @@ instance Exception LWWBlockOpError {- HLINT ignore "Functor law" -} -readLWWBlock :: forall e s m . ( MonadIO m - , Signatures s - , s ~ Encryption e - , ForLWWRefProto e - , IsRefPubKey s - , e ~ L4Proto - ) +readLWWBlock :: forall s m . ( MonadIO m + , Signatures s + , ForLWWRefProto s + , IsRefPubKey s + ) => AnyStorage -> LWWRefKey s - -> m (Maybe (LWWRef e, LWWBlockData e)) + -> m (Maybe (LWWRef s, LWWBlockData s)) readLWWBlock sto k = runMaybeT do - w@LWWRef{..} <- runExceptT (readLWWRef @e sto k) + w@LWWRef{..} <- runExceptT (readLWWRef @s sto k) >>= toMPlus >>= toMPlus getBlock sto (fromHashRef lwwValue) >>= toMPlus - <&> deserialiseOrFail @(LWWBlock e) + <&> deserialiseOrFail @(LWWBlock s) >>= toMPlus <&> lwwBlockData <&> (w,) -initLWWRef :: forall e s m . ( MonadIO m +initLWWRef :: forall s m . ( MonadIO m , MonadError LWWBlockOpError m , IsRefPubKey s - , ForSignedBox e + , ForSignedBox s , HasDerivedKey s 'Sign Word64 m - , s ~ Encryption e , Signatures s - , e ~ L4Proto ) => AnyStorage -> Maybe Word64 @@ -116,7 +111,7 @@ initLWWRef sto seed' findSk lwwKey = do lww0 <- runMaybeT do getRef sto lwwKey >>= toMPlus >>= getBlock sto >>= toMPlus - <&> deserialiseOrFail @(SignedBox (LWWRef e) e) + <&> deserialiseOrFail @(SignedBox (LWWRef s) s) >>= toMPlus <&> unboxSignedBox0 >>= toMPlus @@ -124,7 +119,7 @@ initLWWRef sto seed' findSk lwwKey = do (pk1, _) <- derivedKey @s @'Sign seed sk0 - let newLwwData = LWWBlock1 (LWWBlockData @e seed pk1) + let newLwwData = LWWBlock1 @s (LWWBlockData seed pk1) hx <- putBlock sto (serialise newLwwData) >>= orThrowError LWWBlockOpStorageError diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/RefLog.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/RefLog.hs index 6d0cf3e0..c368d315 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/RefLog.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/RefLog.hs @@ -2,6 +2,6 @@ module HBS2.Git.Data.RefLog where import HBS2.Git.Client.Prelude -type RefLogId = PubKey 'Sign HBS2Basic +type RefLogId = PubKey 'Sign 'HBS2Basic diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/RepoHead.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/RepoHead.hs new file mode 100644 index 00000000..1d9a4bf4 --- /dev/null +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/RepoHead.hs @@ -0,0 +1,68 @@ +{-# Language TemplateHaskell #-} +module HBS2.Git.Data.RepoHead where + +import HBS2.Prelude.Plated +import HBS2.Data.Types.Refs + +import HBS2.Git.Local + +import Data.Text qualified as Text +import Data.ByteString.Char8 qualified as B8 +import Data.Word +import Codec.Serialise +import Lens.Micro.Platform +import Data.Coerce +import Safe +import Data.Maybe +import Data.Set qualified as Set + +data RepoHeadType = RepoHeadType1 + deriving stock (Enum,Generic) + +data RepoHeadExt = RepoHeadExt + deriving stock Generic + +data RepoHead = + RepoHeadSimple + { _repoHeadType :: RepoHeadType + , _repoHeadTime :: Word64 + , _repoHeadGK0 :: Maybe HashRef + , _repoHeadName :: Text + , _repoHeadBrief :: Text + , _repoManifest :: Maybe Text + , repoHeadRefs' :: [(GitRef, GitHash)] + , _repoHeadExt :: [RepoHeadExt] + } + deriving stock (Generic) + +makeLenses ''RepoHead + +repoHeadTags :: SimpleGetter RepoHead [(GitRef,GitHash)] +repoHeadTags = + to \h@RepoHeadSimple{} -> do + catMaybes [ (,v) <$> (lastMay (B8.split '/' s) <&> GitRef) + | (GitRef s, v) <- view repoHeadRefs h, B8.isPrefixOf "refs/tags" s + ] & Set.fromList & Set.toList + + +repoHeadHeads :: SimpleGetter RepoHead [(GitRef,GitHash)] +repoHeadHeads = + to \h@RepoHeadSimple{} -> do + catMaybes [ (,v) <$> (lastMay (B8.split '/' s) <&> GitRef) + | (GitRef s, v) <- view repoHeadRefs h, B8.isPrefixOf "refs/heads" s + ] & Set.fromList & Set.toList + + +repoHeadRefs :: Lens RepoHead + RepoHead + [(GitRef, GitHash)] + [(GitRef, GitHash)] + +repoHeadRefs = lens g s + where + s rh r = rh { repoHeadRefs' = r } + g rh = [ (r,v) | (r,v) <- repoHeadRefs' rh, v /= gitHashTomb ] + +instance Serialise RepoHeadType +instance Serialise RepoHeadExt +instance Serialise RepoHead diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx/Git.hs similarity index 91% rename from hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx.hs rename to hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx/Git.hs index 75172dd3..10be3b3a 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx/Git.hs @@ -1,6 +1,7 @@ -module HBS2.Git.Data.Tx - ( module HBS2.Git.Data.Tx +module HBS2.Git.Data.Tx.Git + ( module HBS2.Git.Data.Tx.Git , OperationError(..) + , RepoHead(..) ) where import HBS2.Git.Client.Prelude @@ -16,6 +17,7 @@ import HBS2.Storage.Operations.ByteString import HBS2.Storage.Operations.Missed import HBS2.Git.Data.GK +import HBS2.Git.Data.RepoHead import HBS2.Git.Local @@ -38,29 +40,6 @@ type LBS = LBS.ByteString type RepoTx = RefLogUpdate L4Proto -data RepoHeadType = RepoHeadType1 - deriving stock (Enum,Generic) - -data RepoHeadExt = RepoHeadExt - deriving stock Generic - -data RepoHead = - RepoHeadSimple - { _repoHeadType :: RepoHeadType - , _repoHeadTime :: Word64 - , _repoHeadGK0 :: Maybe HashRef - , _repoHeadName :: Text - , _repoHeadBrief :: Text - , _repoManifest :: Maybe Text - , _repoHeadRefs :: [(GitRef, GitHash)] - , _repoHeadExt :: [RepoHeadExt] - } - deriving stock (Generic) - - -instance Serialise RepoHeadType -instance Serialise RepoHeadExt -instance Serialise RepoHead data TxKeyringNotFound = TxKeyringNotFound deriving stock (Show, Typeable, Generic) @@ -69,7 +48,7 @@ instance Exception TxKeyringNotFound class GroupKeyOperations m where openGroupKey :: GK0 -> m (Maybe GroupSecret) - loadKeyrings :: HashRef -> m [KeyringEntry HBS2Basic] + loadKeyrings :: HashRef -> m [KeyringEntry 'HBS2Basic] makeRepoHeadSimple :: MonadIO m => Text @@ -85,7 +64,7 @@ makeRepoHeadSimple name brief manifest gk refs = do writeRepoHead :: MonadUnliftIO m => AnyStorage -> RepoHead -> m HashRef writeRepoHead sto rh = writeAsMerkle sto (serialise rh) <&> HashRef -makeTx :: forall s m . (MonadUnliftIO m, GroupKeyOperations m, s ~ HBS2Basic) +makeTx :: forall s m . (MonadUnliftIO m, GroupKeyOperations m, s ~ 'HBS2Basic) => AnyStorage -> Bool -- ^ rewrite bundle merkle tree with new gk0 -> Rank -- ^ tx rank @@ -98,7 +77,7 @@ makeTx :: forall s m . (MonadUnliftIO m, GroupKeyOperations m, s ~ HBS2Basic) makeTx sto rewrite r puk findSk rh prev lbss = do - let rfk = RefLogKey @HBS2Basic puk + let rfk = RefLogKey @'HBS2Basic puk privk <- findSk puk >>= orThrow TxKeyringNotFound @@ -140,7 +119,7 @@ makeTx sto rewrite r puk findSk rh prev lbss = do debug $ "update GK0 for existed block" <+> pretty bh let rcpt = HM.keys (recipients (wbeGk0 writeEnv)) - gk1 <- generateGroupKey @HBS2Basic (Just gks) rcpt + gk1 <- generateGroupKey @'HBS2Basic (Just gks) rcpt gk1h <- writeAsMerkle sto (serialise gk1) @@ -161,12 +140,21 @@ makeTx sto rewrite r puk findSk rh prev lbss = do let meRef = HashRef me + -- FIXME: ASAP-race-condition-on-seq-ref + -- При разборе транзакции, если по какой-то причине + -- голова сразу не подъезжает, то не подъедет уже никогда, + -- и бранчи не приедут (Import). + -- + -- Возможные решения: запатчить процедуру импорта (1) + -- Добавить ссылкун а RepoHead в блок, где приезжают + -- пулы + -- TODO: post-real-rank-for-tx let tx = SequentialRef r (AnnotatedHashRef (Just headRef) meRef) & serialise & LBS.toStrict - makeRefLogUpdate @L4Proto @HBS2Basic puk privk tx + makeRefLogUpdate @L4Proto @'HBS2Basic puk privk tx unpackTx :: MonadIO m @@ -209,10 +197,11 @@ readTx sto href = do pure (n, rhh, rh, blkh) + readRepoHeadFromTx :: MonadIO m => AnyStorage -> HashRef - -> m (Maybe RepoHead) + -> m (Maybe (HashRef, RepoHead)) readRepoHeadFromTx sto href = runMaybeT do @@ -226,6 +215,7 @@ readRepoHeadFromTx sto href = runMaybeT do >>= toMPlus <&> deserialiseOrFail @RepoHead >>= toMPlus + <&> (rhh,) data BundleMeta = diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx/Index.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx/Index.hs new file mode 100644 index 00000000..432ec254 --- /dev/null +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Data/Tx/Index.hs @@ -0,0 +1,128 @@ +{-# Language UndecidableInstances #-} +{-# Language AllowAmbiguousTypes #-} +module HBS2.Git.Data.Tx.Index where + +import HBS2.Git.Client.Prelude +import HBS2.Git.Data.RepoHead + +import HBS2.Data.Types.SignedBox +import HBS2.Storage.Operations.Class + +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as LBS +import Data.Coerce + +import Data.Word + +-- | +-- Module : HBS2.Git.Data.Tx.Index +-- Description : hbs2-git index data structures +-- + +-- FIXME: fix-all-this-constraint-absurde +type ForGitIndex s = ( ForSignedBox s + , IsRefPubKey s + ) + +data RepoForkInfo e = + RepoForkInfoNone + deriving stock (Generic) + +data GitRepoAnnounce s = + GitRepoAnnounce + { repoLwwRef :: LWWRefKey s + , repoForkInfo :: Maybe (RepoForkInfo s) + } + deriving stock (Generic) + + +instance ForGitIndex s => Serialise (RepoForkInfo s) +instance ForGitIndex s => Serialise (GitRepoAnnounce s) + +instance ForGitIndex s => Pretty (GitRepoAnnounce s) where + pretty GitRepoAnnounce{..} = parens $ "git-repo-announce" <+> pretty repoLwwRef + +newtype NotifyCredentials s = NotifyCredentials (PeerCredentials s) + +newtype GitIndexRepoName = GitIndexRepoName Text + deriving stock (Data,Generic,Show) + deriving newtype (Serialise) + +newtype GitIndexRepoBrief = GitIndexRepoBrief Text + deriving stock (Data,Generic,Show) + deriving newtype (Serialise) + +newtype GitIndexRepoManifest = GitIndexRepoManifest (Maybe Text) + deriving stock (Generic,Show) + deriving newtype (Serialise) + +data GitIndexRepoDefineData = + GitIndexRepoDefineData + { gitIndexRepoName :: GitIndexRepoName + , gitIndexRepoBrief :: GitIndexRepoBrief + } + deriving stock (Data,Generic,Show) + +data GitIndexEntry = + GitIndexRepoDefine GitIndexRepoDefineData + | GitIndexRepoTombEntry + | GitIndexRepoLikes Integer + deriving stock (Data,Generic) + +data GitIndexTx s = + GitIndexTx + { gitIndexTxRef :: LWWRefKey s -- ^ primary key + , gitIndexTxSeq :: Word64 -- ^ sequence ( set tomb / bring from tomb ) + , gitIndexTxPayload :: GitIndexEntry -- ^ statement + } + deriving stock (Generic) + +instance ForGitIndex s => Serialise (GitIndexTx s) +instance Serialise GitIndexRepoDefineData +instance Serialise GitIndexEntry + +instance ForGitIndex s => Pretty (GitIndexTx s) where + pretty GitIndexTx{..} = case gitIndexTxPayload of + GitIndexRepoDefine{} -> "git-repo-define" <+> pretty gitIndexTxRef + GitIndexRepoTombEntry -> "git-repo-tomb" <+> pretty gitIndexTxRef + GitIndexRepoLikes n -> "git-repo-likes" <+> pretty gitIndexTxRef <+> pretty n + +-- | makes notification tx +-- | it is signed by lwwref private key in order to proove authorship +-- | and signed with published notification private key in order +-- | to publish tx via rpc +makeNotificationTx :: forall s . (ForGitIndex s) + => NotifyCredentials s + -> LWWRefKey s + -> PrivKey 'Sign s + -> Maybe (RepoForkInfo s) + -> SignedBox ByteString s +makeNotificationTx ncred lww lwsk forkInfo = do + let creds = coerce ncred :: PeerCredentials s + let annData = GitRepoAnnounce @s lww forkInfo + let lwpk = coerce lww :: PubKey 'Sign s + let repoAnn = makeSignedBox @s lwpk lwsk (LBS.toStrict $ serialise annData) + makeSignedBox @s (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict $ serialise repoAnn) + + + + + +unpackNotificationTx :: forall s m . (ForGitIndex s, MonadError OperationError m) + => SignedBox ByteString s + -> m (GitRepoAnnounce s) +unpackNotificationTx box = do + (_, bs1) <- unboxSignedBox0 @_ @s box + & orThrowError SignCheckError + + bs2 <- deserialiseOrFail @(SignedBox ByteString s) (LBS.fromStrict bs1) + & orThrowError UnsupportedFormat + + (_, bs3) <- unboxSignedBox0 bs2 + & orThrowError SignCheckError + + deserialiseOrFail @(GitRepoAnnounce s) (LBS.fromStrict bs3) + & orThrowError UnsupportedFormat + + + diff --git a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Local.hs b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Local.hs index f1641cb3..b2658571 100644 --- a/hbs2-git/hbs2-git-client-lib/HBS2/Git/Local.hs +++ b/hbs2-git/hbs2-git-client-lib/HBS2/Git/Local.hs @@ -16,6 +16,9 @@ newtype GitHash = GitHash ByteString deriving stock (Eq,Ord,Data,Generic,Show) deriving newtype Hashable +gitHashTomb :: GitHash +gitHashTomb = fromString "0000000000000000000000000000000000" + instance Serialise GitHash instance IsString GitHash where diff --git a/hbs2-git/hbs2-git-dashboard-assets/HBS2/Git/Web/Assets.hs b/hbs2-git/hbs2-git-dashboard-assets/HBS2/Git/Web/Assets.hs new file mode 100644 index 00000000..d1b51804 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard-assets/HBS2/Git/Web/Assets.hs @@ -0,0 +1,179 @@ +{-# Language TemplateHaskell #-} +module HBS2.Git.Web.Assets where + +import Data.FileEmbed +import Data.ByteString +import Data.Text (Text) +import Text.InterpolatedString.Perl6 (qc) +import Lucid.Base + +version :: Int +version = 3 + +assetsDir :: [(FilePath, ByteString)] +assetsDir = $(embedDir "hbs2-git-dashboard-assets/assets") + +data IconType + = IconCopy + | IconCopyDone + | IconLockClosed + | IconGitCommit + | IconGitFork + | IconGitBranch + | IconTag + | IconFolderFilled + | IconHaskell + | IconMarkdown + | IconNix + | IconBash + | IconPython + | IconJavaScript + | IconSql + | IconSettingsFilled + | IconFileFilled + | IconRefresh + | IconArrowUturnLeft + | IconLicense + | IconPinned + +svgIcon :: Monad m => IconType -> HtmlT m () +svgIcon = toHtmlRaw . svgIconText + +svgIconText :: IconType -> Text + +svgIconText IconCopy = [qc| + + + +|] + +svgIconText IconCopyDone = [qc| + + + + +|] + +svgIconText IconLockClosed = [qc| + + + + +|] + +svgIconText IconGitCommit = [qc| + + + + +|] + +svgIconText IconGitFork = [qc| + + + + + + +|] + +svgIconText IconGitBranch = [qc| + + + + + + + +|] + +svgIconText IconTag = [qc| + + + +|] + +svgIconText IconFolderFilled = [qc| + + +|] + +svgIconText IconHaskell = [qc| + Haskell + + |] + +svgIconText IconMarkdown = [qc| + Markdown + + |] + +svgIconText IconNix = [qc| + Nix + + |] + +svgIconText IconBash = [qc| + + + + +|] + +svgIconText IconPython = [qc| + Python + +|] + +svgIconText IconJavaScript = [qc| + JavaScript + +|] + +svgIconText IconSql = [qc| + + + + + + + + +|] + +svgIconText IconSettingsFilled = [qc| + + +|] + +svgIconText IconFileFilled = [qc| + + + +|] + +svgIconText IconRefresh = [qc| + + + +|] + +svgIconText IconArrowUturnLeft = [qc| + + + +|] + +svgIconText IconLicense = [qc| + + + + +|] + +svgIconText IconPinned = [qc| + + + + +|] diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css b/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css new file mode 100644 index 00000000..049d23c4 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/css/custom.css @@ -0,0 +1,269 @@ +/* fastpok CSS start */ + +:root { + --pico-form-element-spacing-vertical: .5rem; + --pico-form-element-spacing-horizontal: .625rem; +} + +[type=search] { + --pico-border-radius: inherit; +} + +[role=search] { + --pico-border-radius: inherit; +} + +[role=search]>:first-child { + border-top-left-radius: var(--pico-border-radius); + border-bottom-left-radius: var(--pico-border-radius); +} + +[role=search]>:last-child { + border-top-right-radius: var(--pico-border-radius); + border-bottom-right-radius: var(--pico-border-radius); +} + +body>footer, body>header, body>main { + padding-block: 0; +} + +header>nav { + border-bottom: var(--pico-border-width) solid var(--pico-muted-border-color); +} + +.wrapper { + display: flex; +} + +.sidebar { + width: 20rem; + flex-shrink: 0; + padding-top: var(--pico-block-spacing-vertical); + padding-right: var(--pico-block-spacing-horizontal); + padding-bottom: var(--pico-block-spacing-vertical); + border-right: var(--pico-border-width) solid var(--pico-muted-border-color); + display: flex; + flex-direction: column; +} + +.content { + padding-top: var(--pico-block-spacing-vertical); + padding-bottom: var(--pico-block-spacing-vertical); + padding-left: var(--pico-block-spacing-horizontal); +} + +article { + border: var(--pico-border-width) solid var(--pico-card-border-color); + box-shadow: none; +} + +.repo-list-item { + display: flex; + justify-content: space-between; + gap: var(--pico-block-spacing-horizontal); +} + +.repo-list-item-link-wrapper { + display: flex; + align-items: center; + margin-bottom: var(--pico-typography-spacing-vertical); +} + +.copy-button { + margin-left: calc(var(--pico-spacing) * .5); + background-color: transparent; + border: none; + padding: 0; + border-radius: 0; + box-shadow: none; + color: var(--pico-secondary); + transition: color var(--pico-transition); +} + +.copy-button:hover { + color: var(--pico-secondary-hover); +} + +.copy-button .icon { + width: 1.125rem; + height: 1.125rem; +} + +.inline-icon-wrapper { + display: inline-block; +} + +.inline-icon-wrapper .icon { + margin-right: calc(var(--pico-spacing) * .25); + vertical-align: middle; +} + +.info-block { + margin-bottom: var(--pico-block-spacing-vertical); +} + +.mb-0 { + margin-bottom: 0; +} + +.py-0 { + padding-top: 0; + padding-bottom: 0; +} + +.text-nowrap { + text-wrap: nowrap; +} + +.repo-menu { + --pico-nav-breadcrumb-divider: '|'; +} + +.repo-menu li.active { + color: var(--pico-primary); +} + +aside li { + padding: 0; +} + +aside ul { + padding: 0; +} + +aside li :where(a,[role=link]):not(:hover) { + text-decoration: none; +} + +.sidebar-title { + margin-bottom: calc(var(--pico-typography-spacing-vertical) * .25); +} + +/* fastpok CSS end */ + + +ul.misc-menu { + margin: 0 0 0 0; + padding: 0 0 0 0; +} + +ul.misc-menu li { + padding: 0 0 0 0; + margin-right: 1em; + display: inline; +} + +.mono { + font-family: 'Courier New', Courier, monospace; +} + +.tree { + font-weight: 600; +} + +td.tree-locator { + border-bottom: none; +} + +td.tree-locator span { + margin-right: .5rem; +} + +tr.commit-brief-title td, +tr.commit-brief-title th { + border-bottom: none; + vertical-align: top; +} + +tr.commit-brief-details td, +tr.commit-brief-details th { + border-top: none; +} + +td.commit-brief-title { + text-align: left; +} + +tr.commit-brief-last td { + border: none; +} + +tr.commit-brief-last th { + border: none; +} + +td.commit-icon { + width: 4rem; + /* width: px; */ +} + +td.commit-hash { + width: 10rem; + text-align: left; +} + + +pre > code.sourceCode { white-space: pre; position: relative; } +pre > code.sourceCode > span { line-height: 1.25; } +pre > code.sourceCode > span:empty { height: 1.2em; } +.sourceCode { overflow: auto; } +code.sourceCode > span { color: inherit; text-decoration: inherit; overflow: auto; } +div.sourceCode { margin: 1em 0; overflow: auto; } +pre.sourceCode { margin: 0; } +@media screen { +div.sourceCode { overflow: auto; max-width: 120rem; } +} +@media print { +pre > code.sourceCode { white-space: pre-wrap; } +pre > code.sourceCode > span { display: inline-block; text-indent: -5em; padding-left: 5em; } +} +pre.numberSource code + { counter-reset: source-line 0; } +pre.numberSource code > span + { position: relative; left: -4em; counter-increment: source-line; } +pre.numberSource code > span > a:first-child::before + { content: counter(source-line); + position: relative; left: -1em; text-align: right; vertical-align: baseline; + border: none; display: inline-block; + -webkit-touch-callout: none; -webkit-user-select: none; + -khtml-user-select: none; -moz-user-select: none; + -ms-user-select: none; user-select: none; + padding: 0 4px; width: 4em; + color: #aaaaaa; + } +pre.numberSource { margin-left: 3em; border-left: 1px solid #aaaaaa; padding-left: 4px; } +@media screen { +pre > code.sourceCode > span > a:first-child::before { text-decoration: underline; } +} +code span.al { color: #ef2929; } /* Alert */ +code span.an { color: #8f5902; font-weight: bold; font-style: italic; } /* Annotation */ +code span.at { color: #204a87; } /* Attribute */ +code span.bn { color: #0000cf; } /* BaseN */ +code span.cf { color: #204a87; font-weight: bold; } /* ControlFlow */ +code span.ch { color: #4e9a06; } /* Char */ +code span.cn { color: #8f5902; } /* Constant */ +code span.co { color: #8f5902; font-style: italic; } /* Comment */ +code span.cv { color: #8f5902; font-weight: bold; font-style: italic; } /* CommentVar */ +code span.do { color: #8f5902; font-weight: bold; font-style: italic; } /* Documentation */ +code span.dt { color: #204a87; } /* DataType */ +code span.dv { color: #0000cf; } /* DecVal */ +code span.er { color: #a40000; font-weight: bold; } /* Error */ +code span.ex { } /* Extension */ +code span.fl { color: #0000cf; } /* Float */ +code span.fu { color: #204a87; font-weight: bold; } /* Function */ +code span.im { } /* Import */ +code span.in { color: #8f5902; font-weight: bold; font-style: italic; } /* Information */ +code span.kw { color: #204a87; font-weight: bold; } /* Keyword */ +code span.op { color: #ce5c00; font-weight: bold; } /* Operator */ +code span.ot { color: #8f5902; } /* Other */ +code span.pp { color: #8f5902; font-style: italic; } /* Preprocessor */ +code span.sc { color: #ce5c00; font-weight: bold; } /* SpecialChar */ +code span.ss { color: #4e9a06; } /* SpecialString */ +code span.st { color: #4e9a06; } /* String */ +code span.va { color: #000000; } /* Variable */ +code span.vs { color: #4e9a06; } /* VerbatimString */ +code span.wa { color: #8f5902; font-weight: bold; font-style: italic; } /* Warning */ + + + + diff --git a/hbs2-git/hbs2-git-dashboard-assets/assets/css/pico.min.css b/hbs2-git/hbs2-git-dashboard-assets/assets/css/pico.min.css new file mode 100644 index 00000000..5928ed78 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard-assets/assets/css/pico.min.css @@ -0,0 +1,4 @@ +@charset "UTF-8";/*! + * Pico CSS ✨ v2.0.6 (https://picocss.com) + * Copyright 2019-2024 - Licensed under MIT + */:root{--pico-font-family-emoji:"Apple Color Emoji","Segoe UI Emoji","Segoe UI Symbol","Noto Color Emoji";--pico-font-family-sans-serif:system-ui,"Segoe UI",Roboto,Oxygen,Ubuntu,Cantarell,Helvetica,Arial,"Helvetica Neue",sans-serif,var(--pico-font-family-emoji);--pico-font-family-monospace:ui-monospace,SFMono-Regular,"SF Mono",Menlo,Consolas,"Liberation Mono",monospace,var(--pico-font-family-emoji);--pico-font-family:var(--pico-font-family-sans-serif);--pico-line-height:1.5;--pico-font-weight:400;--pico-font-size:100%;--pico-text-underline-offset:0.1rem;--pico-border-radius:0.25rem;--pico-border-width:0.0625rem;--pico-outline-width:0.125rem;--pico-transition:0.2s ease-in-out;--pico-spacing:1rem;--pico-typography-spacing-vertical:1rem;--pico-block-spacing-vertical:var(--pico-spacing);--pico-block-spacing-horizontal:var(--pico-spacing);--pico-grid-column-gap:var(--pico-spacing);--pico-grid-row-gap:var(--pico-spacing);--pico-form-element-spacing-vertical:0.75rem;--pico-form-element-spacing-horizontal:1rem;--pico-group-box-shadow:0 0 0 rgba(0, 0, 0, 0);--pico-group-box-shadow-focus-with-button:0 0 0 var(--pico-outline-width) var(--pico-primary-focus);--pico-group-box-shadow-focus-with-input:0 0 0 0.0625rem var(--pico-form-element-border-color);--pico-modal-overlay-backdrop-filter:blur(0.375rem);--pico-nav-element-spacing-vertical:1rem;--pico-nav-element-spacing-horizontal:0.5rem;--pico-nav-link-spacing-vertical:0.5rem;--pico-nav-link-spacing-horizontal:0.5rem;--pico-nav-breadcrumb-divider:">";--pico-icon-checkbox:url("data:image/svg+xml,%3Csvg xmlns='http://www.w3.org/2000/svg' width='24' height='24' viewBox='0 0 24 24' fill='none' stroke='rgb(255, 255, 255)' stroke-width='4' stroke-linecap='round' stroke-linejoin='round'%3E%3Cpolyline points='20 6 9 17 4 12'%3E%3C/polyline%3E%3C/svg%3E");--pico-icon-minus:url("data:image/svg+xml,%3Csvg xmlns='http://www.w3.org/2000/svg' width='24' height='24' viewBox='0 0 24 24' fill='none' stroke='rgb(255, 255, 255)' stroke-width='4' stroke-linecap='round' stroke-linejoin='round'%3E%3Cline x1='5' y1='12' x2='19' y2='12'%3E%3C/line%3E%3C/svg%3E");--pico-icon-chevron:url("data:image/svg+xml,%3Csvg xmlns='http://www.w3.org/2000/svg' width='24' height='24' viewBox='0 0 24 24' fill='none' stroke='rgb(136, 145, 164)' stroke-width='2' stroke-linecap='round' stroke-linejoin='round'%3E%3Cpolyline points='6 9 12 15 18 9'%3E%3C/polyline%3E%3C/svg%3E");--pico-icon-date:url("data:image/svg+xml,%3Csvg xmlns='http://www.w3.org/2000/svg' width='24' height='24' viewBox='0 0 24 24' fill='none' stroke='rgb(136, 145, 164)' stroke-width='2' stroke-linecap='round' stroke-linejoin='round'%3E%3Crect x='3' y='4' width='18' height='18' rx='2' ry='2'%3E%3C/rect%3E%3Cline x1='16' y1='2' x2='16' y2='6'%3E%3C/line%3E%3Cline x1='8' y1='2' x2='8' y2='6'%3E%3C/line%3E%3Cline x1='3' y1='10' x2='21' y2='10'%3E%3C/line%3E%3C/svg%3E");--pico-icon-time:url("data:image/svg+xml,%3Csvg xmlns='http://www.w3.org/2000/svg' width='24' height='24' viewBox='0 0 24 24' fill='none' stroke='rgb(136, 145, 164)' stroke-width='2' stroke-linecap='round' stroke-linejoin='round'%3E%3Ccircle cx='12' cy='12' r='10'%3E%3C/circle%3E%3Cpolyline points='12 6 12 12 16 14'%3E%3C/polyline%3E%3C/svg%3E");--pico-icon-search:url("data:image/svg+xml,%3Csvg xmlns='http://www.w3.org/2000/svg' width='24' height='24' viewBox='0 0 24 24' fill='none' stroke='rgb(136, 145, 164)' stroke-width='1.5' stroke-linecap='round' stroke-linejoin='round'%3E%3Ccircle cx='11' cy='11' r='8'%3E%3C/circle%3E%3Cline x1='21' y1='21' x2='16.65' y2='16.65'%3E%3C/line%3E%3C/svg%3E");--pico-icon-close:url("data:image/svg+xml,%3Csvg xmlns='http://www.w3.org/2000/svg' width='24' height='24' viewBox='0 0 24 24' fill='none' stroke='rgb(136, 145, 164)' stroke-width='3' stroke-linecap='round' stroke-linejoin='round'%3E%3Cline x1='18' y1='6' x2='6' y2='18'%3E%3C/line%3E%3Cline x1='6' y1='6' x2='18' y2='18'%3E%3C/line%3E%3C/svg%3E");--pico-icon-loading:url("data:image/svg+xml,%3Csvg fill='none' height='24' width='24' viewBox='0 0 24 24' xmlns='http://www.w3.org/2000/svg' %3E%3Cstyle%3E g %7B animation: rotate 2s linear infinite; transform-origin: center center; %7D circle %7B stroke-dasharray: 75,100; stroke-dashoffset: -5; animation: dash 1.5s ease-in-out infinite; stroke-linecap: round; %7D @keyframes rotate %7B 0%25 %7B transform: rotate(0deg); %7D 100%25 %7B transform: rotate(360deg); %7D %7D @keyframes dash %7B 0%25 %7B stroke-dasharray: 1,100; stroke-dashoffset: 0; %7D 50%25 %7B stroke-dasharray: 44.5,100; stroke-dashoffset: -17.5; %7D 100%25 %7B stroke-dasharray: 44.5,100; stroke-dashoffset: -62; %7D %7D %3C/style%3E%3Cg%3E%3Ccircle cx='12' cy='12' r='10' fill='none' stroke='rgb(136, 145, 164)' stroke-width='4' /%3E%3C/g%3E%3C/svg%3E")}@media (min-width:576px){:root{--pico-font-size:106.25%}}@media (min-width:768px){:root{--pico-font-size:112.5%}}@media (min-width:1024px){:root{--pico-font-size:118.75%}}@media (min-width:1280px){:root{--pico-font-size:125%}}@media (min-width:1536px){:root{--pico-font-size:131.25%}}a{--pico-text-decoration:underline}a.contrast,a.secondary{--pico-text-decoration:underline}small{--pico-font-size:0.875em}h1,h2,h3,h4,h5,h6{--pico-font-weight:700}h1{--pico-font-size:2rem;--pico-line-height:1.125;--pico-typography-spacing-top:3rem}h2{--pico-font-size:1.75rem;--pico-line-height:1.15;--pico-typography-spacing-top:2.625rem}h3{--pico-font-size:1.5rem;--pico-line-height:1.175;--pico-typography-spacing-top:2.25rem}h4{--pico-font-size:1.25rem;--pico-line-height:1.2;--pico-typography-spacing-top:1.874rem}h5{--pico-font-size:1.125rem;--pico-line-height:1.225;--pico-typography-spacing-top:1.6875rem}h6{--pico-font-size:1rem;--pico-line-height:1.25;--pico-typography-spacing-top:1.5rem}tfoot td,tfoot th,thead td,thead th{--pico-font-weight:600;--pico-border-width:0.1875rem}code,kbd,pre,samp{--pico-font-family:var(--pico-font-family-monospace)}kbd{--pico-font-weight:bolder}:where(select,textarea),input:not([type=submit],[type=button],[type=reset],[type=checkbox],[type=radio],[type=file]){--pico-outline-width:0.0625rem}[type=search]{--pico-border-radius:5rem}[type=checkbox],[type=radio]{--pico-border-width:0.125rem}[type=checkbox][role=switch]{--pico-border-width:0.1875rem}details.dropdown summary:not([role=button]){--pico-outline-width:0.0625rem}nav details.dropdown summary:focus-visible{--pico-outline-width:0.125rem}[role=search]{--pico-border-radius:5rem}[role=group]:has(button.secondary:focus,[type=submit].secondary:focus,[type=button].secondary:focus,[role=button].secondary:focus),[role=search]:has(button.secondary:focus,[type=submit].secondary:focus,[type=button].secondary:focus,[role=button].secondary:focus){--pico-group-box-shadow-focus-with-button:0 0 0 var(--pico-outline-width) var(--pico-secondary-focus)}[role=group]:has(button.contrast:focus,[type=submit].contrast:focus,[type=button].contrast:focus,[role=button].contrast:focus),[role=search]:has(button.contrast:focus,[type=submit].contrast:focus,[type=button].contrast:focus,[role=button].contrast:focus){--pico-group-box-shadow-focus-with-button:0 0 0 var(--pico-outline-width) var(--pico-contrast-focus)}[role=group] [role=button],[role=group] [type=button],[role=group] [type=submit],[role=group] button,[role=search] [role=button],[role=search] [type=button],[role=search] [type=submit],[role=search] button{--pico-form-element-spacing-horizontal:2rem}details summary[role=button]:not(.outline)::after{filter:brightness(0) invert(1)}[aria-busy=true]:not(input,select,textarea):is(button,[type=submit],[type=button],[type=reset],[role=button]):not(.outline)::before{filter:brightness(0) invert(1)}:root:not([data-theme=dark]),[data-theme=light]{--pico-background-color:#fff;--pico-color:#373c44;--pico-text-selection-color:rgba(2, 154, 232, 0.25);--pico-muted-color:#646b79;--pico-muted-border-color:#e7eaf0;--pico-primary:#0172ad;--pico-primary-background:#0172ad;--pico-primary-border:var(--pico-primary-background);--pico-primary-underline:rgba(1, 114, 173, 0.5);--pico-primary-hover:#015887;--pico-primary-hover-background:#02659a;--pico-primary-hover-border:var(--pico-primary-hover-background);--pico-primary-hover-underline:var(--pico-primary-hover);--pico-primary-focus:rgba(2, 154, 232, 0.5);--pico-primary-inverse:#fff;--pico-secondary:#5d6b89;--pico-secondary-background:#525f7a;--pico-secondary-border:var(--pico-secondary-background);--pico-secondary-underline:rgba(93, 107, 137, 0.5);--pico-secondary-hover:#48536b;--pico-secondary-hover-background:#48536b;--pico-secondary-hover-border:var(--pico-secondary-hover-background);--pico-secondary-hover-underline:var(--pico-secondary-hover);--pico-secondary-focus:rgba(93, 107, 137, 0.25);--pico-secondary-inverse:#fff;--pico-contrast:#181c25;--pico-contrast-background:#181c25;--pico-contrast-border:var(--pico-contrast-background);--pico-contrast-underline:rgba(24, 28, 37, 0.5);--pico-contrast-hover:#000;--pico-contrast-hover-background:#000;--pico-contrast-hover-border:var(--pico-contrast-hover-background);--pico-contrast-hover-underline:var(--pico-secondary-hover);--pico-contrast-focus:rgba(93, 107, 137, 0.25);--pico-contrast-inverse:#fff;--pico-box-shadow:0.0145rem 0.029rem 0.174rem rgba(129, 145, 181, 0.01698),0.0335rem 0.067rem 0.402rem rgba(129, 145, 181, 0.024),0.0625rem 0.125rem 0.75rem rgba(129, 145, 181, 0.03),0.1125rem 0.225rem 1.35rem rgba(129, 145, 181, 0.036),0.2085rem 0.417rem 2.502rem rgba(129, 145, 181, 0.04302),0.5rem 1rem 6rem rgba(129, 145, 181, 0.06),0 0 0 0.0625rem rgba(129, 145, 181, 0.015);--pico-h1-color:#2d3138;--pico-h2-color:#373c44;--pico-h3-color:#424751;--pico-h4-color:#4d535e;--pico-h5-color:#5c6370;--pico-h6-color:#646b79;--pico-mark-background-color:#fde7c0;--pico-mark-color:#0f1114;--pico-ins-color:#1d6a54;--pico-del-color:#883935;--pico-blockquote-border-color:var(--pico-muted-border-color);--pico-blockquote-footer-color:var(--pico-muted-color);--pico-button-box-shadow:0 0 0 rgba(0, 0, 0, 0);--pico-button-hover-box-shadow:0 0 0 rgba(0, 0, 0, 0);--pico-table-border-color:var(--pico-muted-border-color);--pico-table-row-stripped-background-color:rgba(111, 120, 135, 0.0375);--pico-code-background-color:#f3f5f7;--pico-code-color:#646b79;--pico-code-kbd-background-color:var(--pico-color);--pico-code-kbd-color:var(--pico-background-color);--pico-form-element-background-color:#fbfcfc;--pico-form-element-selected-background-color:#dfe3eb;--pico-form-element-border-color:#cfd5e2;--pico-form-element-color:#23262c;--pico-form-element-placeholder-color:var(--pico-muted-color);--pico-form-element-active-background-color:#fff;--pico-form-element-active-border-color:var(--pico-primary-border);--pico-form-element-focus-color:var(--pico-primary-border);--pico-form-element-disabled-opacity:0.5;--pico-form-element-invalid-border-color:#b86a6b;--pico-form-element-invalid-active-border-color:#c84f48;--pico-form-element-invalid-focus-color:var(--pico-form-element-invalid-active-border-color);--pico-form-element-valid-border-color:#4c9b8a;--pico-form-element-valid-active-border-color:#279977;--pico-form-element-valid-focus-color:var(--pico-form-element-valid-active-border-color);--pico-switch-background-color:#bfc7d9;--pico-switch-checked-background-color:var(--pico-primary-background);--pico-switch-color:#fff;--pico-switch-thumb-box-shadow:0 0 0 rgba(0, 0, 0, 0);--pico-range-border-color:#dfe3eb;--pico-range-active-border-color:#bfc7d9;--pico-range-thumb-border-color:var(--pico-background-color);--pico-range-thumb-color:var(--pico-secondary-background);--pico-range-thumb-active-color:var(--pico-primary-background);--pico-accordion-border-color:var(--pico-muted-border-color);--pico-accordion-active-summary-color:var(--pico-primary-hover);--pico-accordion-close-summary-color:var(--pico-color);--pico-accordion-open-summary-color:var(--pico-muted-color);--pico-card-background-color:var(--pico-background-color);--pico-card-border-color:var(--pico-muted-border-color);--pico-card-box-shadow:var(--pico-box-shadow);--pico-card-sectioning-background-color:#fbfcfc;--pico-dropdown-background-color:#fff;--pico-dropdown-border-color:#eff1f4;--pico-dropdown-box-shadow:var(--pico-box-shadow);--pico-dropdown-color:var(--pico-color);--pico-dropdown-hover-background-color:#eff1f4;--pico-loading-spinner-opacity:0.5;--pico-modal-overlay-background-color:rgba(232, 234, 237, 0.75);--pico-progress-background-color:#dfe3eb;--pico-progress-color:var(--pico-primary-background);--pico-tooltip-background-color:var(--pico-contrast-background);--pico-tooltip-color:var(--pico-contrast-inverse);--pico-icon-valid:url("data:image/svg+xml,%3Csvg xmlns='http://www.w3.org/2000/svg' width='24' height='24' viewBox='0 0 24 24' fill='none' stroke='rgb(76, 155, 138)' stroke-width='2' stroke-linecap='round' stroke-linejoin='round'%3E%3Cpolyline points='20 6 9 17 4 12'%3E%3C/polyline%3E%3C/svg%3E");--pico-icon-invalid:url("data:image/svg+xml,%3Csvg xmlns='http://www.w3.org/2000/svg' width='24' height='24' viewBox='0 0 24 24' fill='none' stroke='rgb(200, 79, 72)' stroke-width='2' stroke-linecap='round' stroke-linejoin='round'%3E%3Ccircle cx='12' cy='12' r='10'%3E%3C/circle%3E%3Cline x1='12' y1='8' x2='12' y2='12'%3E%3C/line%3E%3Cline x1='12' y1='16' x2='12.01' y2='16'%3E%3C/line%3E%3C/svg%3E");color-scheme:light}:root:not([data-theme=dark]) input:is([type=submit],[type=button],[type=reset],[type=checkbox],[type=radio],[type=file]),[data-theme=light] input:is([type=submit],[type=button],[type=reset],[type=checkbox],[type=radio],[type=file]){--pico-form-element-focus-color:var(--pico-primary-focus)}@media only screen and (prefers-color-scheme:dark){:root:not([data-theme]){--pico-background-color:#13171f;--pico-color:#c2c7d0;--pico-text-selection-color:rgba(1, 170, 255, 0.1875);--pico-muted-color:#7b8495;--pico-muted-border-color:#202632;--pico-primary:#01aaff;--pico-primary-background:#0172ad;--pico-primary-border:var(--pico-primary-background);--pico-primary-underline:rgba(1, 170, 255, 0.5);--pico-primary-hover:#79c0ff;--pico-primary-hover-background:#017fc0;--pico-primary-hover-border:var(--pico-primary-hover-background);--pico-primary-hover-underline:var(--pico-primary-hover);--pico-primary-focus:rgba(1, 170, 255, 0.375);--pico-primary-inverse:#fff;--pico-secondary:#969eaf;--pico-secondary-background:#525f7a;--pico-secondary-border:var(--pico-secondary-background);--pico-secondary-underline:rgba(150, 158, 175, 0.5);--pico-secondary-hover:#b3b9c5;--pico-secondary-hover-background:#5d6b89;--pico-secondary-hover-border:var(--pico-secondary-hover-background);--pico-secondary-hover-underline:var(--pico-secondary-hover);--pico-secondary-focus:rgba(144, 158, 190, 0.25);--pico-secondary-inverse:#fff;--pico-contrast:#dfe3eb;--pico-contrast-background:#eff1f4;--pico-contrast-border:var(--pico-contrast-background);--pico-contrast-underline:rgba(223, 227, 235, 0.5);--pico-contrast-hover:#fff;--pico-contrast-hover-background:#fff;--pico-contrast-hover-border:var(--pico-contrast-hover-background);--pico-contrast-hover-underline:var(--pico-contrast-hover);--pico-contrast-focus:rgba(207, 213, 226, 0.25);--pico-contrast-inverse:#000;--pico-box-shadow:0.0145rem 0.029rem 0.174rem rgba(7, 9, 12, 0.01698),0.0335rem 0.067rem 0.402rem rgba(7, 9, 12, 0.024),0.0625rem 0.125rem 0.75rem rgba(7, 9, 12, 0.03),0.1125rem 0.225rem 1.35rem rgba(7, 9, 12, 0.036),0.2085rem 0.417rem 2.502rem rgba(7, 9, 12, 0.04302),0.5rem 1rem 6rem rgba(7, 9, 12, 0.06),0 0 0 0.0625rem rgba(7, 9, 12, 0.015);--pico-h1-color:#f0f1f3;--pico-h2-color:#e0e3e7;--pico-h3-color:#c2c7d0;--pico-h4-color:#b3b9c5;--pico-h5-color:#a4acba;--pico-h6-color:#8891a4;--pico-mark-background-color:#014063;--pico-mark-color:#fff;--pico-ins-color:#62af9a;--pico-del-color:#ce7e7b;--pico-blockquote-border-color:var(--pico-muted-border-color);--pico-blockquote-footer-color:var(--pico-muted-color);--pico-button-box-shadow:0 0 0 rgba(0, 0, 0, 0);--pico-button-hover-box-shadow:0 0 0 rgba(0, 0, 0, 0);--pico-table-border-color:var(--pico-muted-border-color);--pico-table-row-stripped-background-color:rgba(111, 120, 135, 0.0375);--pico-code-background-color:#1a1f28;--pico-code-color:#8891a4;--pico-code-kbd-background-color:var(--pico-color);--pico-code-kbd-color:var(--pico-background-color);--pico-form-element-background-color:#1c212c;--pico-form-element-selected-background-color:#2a3140;--pico-form-element-border-color:#2a3140;--pico-form-element-color:#e0e3e7;--pico-form-element-placeholder-color:#8891a4;--pico-form-element-active-background-color:#1a1f28;--pico-form-element-active-border-color:var(--pico-primary-border);--pico-form-element-focus-color:var(--pico-primary-border);--pico-form-element-disabled-opacity:0.5;--pico-form-element-invalid-border-color:#964a50;--pico-form-element-invalid-active-border-color:#b7403b;--pico-form-element-invalid-focus-color:var(--pico-form-element-invalid-active-border-color);--pico-form-element-valid-border-color:#2a7b6f;--pico-form-element-valid-active-border-color:#16896a;--pico-form-element-valid-focus-color:var(--pico-form-element-valid-active-border-color);--pico-switch-background-color:#333c4e;--pico-switch-checked-background-color:var(--pico-primary-background);--pico-switch-color:#fff;--pico-switch-thumb-box-shadow:0 0 0 rgba(0, 0, 0, 0);--pico-range-border-color:#202632;--pico-range-active-border-color:#2a3140;--pico-range-thumb-border-color:var(--pico-background-color);--pico-range-thumb-color:var(--pico-secondary-background);--pico-range-thumb-active-color:var(--pico-primary-background);--pico-accordion-border-color:var(--pico-muted-border-color);--pico-accordion-active-summary-color:var(--pico-primary-hover);--pico-accordion-close-summary-color:var(--pico-color);--pico-accordion-open-summary-color:var(--pico-muted-color);--pico-card-background-color:#181c25;--pico-card-border-color:var(--pico-card-background-color);--pico-card-box-shadow:var(--pico-box-shadow);--pico-card-sectioning-background-color:#1a1f28;--pico-dropdown-background-color:#181c25;--pico-dropdown-border-color:#202632;--pico-dropdown-box-shadow:var(--pico-box-shadow);--pico-dropdown-color:var(--pico-color);--pico-dropdown-hover-background-color:#202632;--pico-loading-spinner-opacity:0.5;--pico-modal-overlay-background-color:rgba(8, 9, 10, 0.75);--pico-progress-background-color:#202632;--pico-progress-color:var(--pico-primary-background);--pico-tooltip-background-color:var(--pico-contrast-background);--pico-tooltip-color:var(--pico-contrast-inverse);--pico-icon-valid:url("data:image/svg+xml,%3Csvg xmlns='http://www.w3.org/2000/svg' width='24' height='24' viewBox='0 0 24 24' fill='none' stroke='rgb(42, 123, 111)' stroke-width='2' stroke-linecap='round' stroke-linejoin='round'%3E%3Cpolyline points='20 6 9 17 4 12'%3E%3C/polyline%3E%3C/svg%3E");--pico-icon-invalid:url("data:image/svg+xml,%3Csvg xmlns='http://www.w3.org/2000/svg' width='24' height='24' viewBox='0 0 24 24' fill='none' stroke='rgb(150, 74, 80)' stroke-width='2' stroke-linecap='round' stroke-linejoin='round'%3E%3Ccircle cx='12' cy='12' r='10'%3E%3C/circle%3E%3Cline x1='12' y1='8' x2='12' y2='12'%3E%3C/line%3E%3Cline x1='12' y1='16' x2='12.01' y2='16'%3E%3C/line%3E%3C/svg%3E");color-scheme:dark}:root:not([data-theme]) input:is([type=submit],[type=button],[type=reset],[type=checkbox],[type=radio],[type=file]){--pico-form-element-focus-color:var(--pico-primary-focus)}:root:not([data-theme]) details summary[role=button].contrast:not(.outline)::after{filter:brightness(0)}:root:not([data-theme]) [aria-busy=true]:not(input,select,textarea).contrast:is(button,[type=submit],[type=button],[type=reset],[role=button]):not(.outline)::before{filter:brightness(0)}}[data-theme=dark]{--pico-background-color:#13171f;--pico-color:#c2c7d0;--pico-text-selection-color:rgba(1, 170, 255, 0.1875);--pico-muted-color:#7b8495;--pico-muted-border-color:#202632;--pico-primary:#01aaff;--pico-primary-background:#0172ad;--pico-primary-border:var(--pico-primary-background);--pico-primary-underline:rgba(1, 170, 255, 0.5);--pico-primary-hover:#79c0ff;--pico-primary-hover-background:#017fc0;--pico-primary-hover-border:var(--pico-primary-hover-background);--pico-primary-hover-underline:var(--pico-primary-hover);--pico-primary-focus:rgba(1, 170, 255, 0.375);--pico-primary-inverse:#fff;--pico-secondary:#969eaf;--pico-secondary-background:#525f7a;--pico-secondary-border:var(--pico-secondary-background);--pico-secondary-underline:rgba(150, 158, 175, 0.5);--pico-secondary-hover:#b3b9c5;--pico-secondary-hover-background:#5d6b89;--pico-secondary-hover-border:var(--pico-secondary-hover-background);--pico-secondary-hover-underline:var(--pico-secondary-hover);--pico-secondary-focus:rgba(144, 158, 190, 0.25);--pico-secondary-inverse:#fff;--pico-contrast:#dfe3eb;--pico-contrast-background:#eff1f4;--pico-contrast-border:var(--pico-contrast-background);--pico-contrast-underline:rgba(223, 227, 235, 0.5);--pico-contrast-hover:#fff;--pico-contrast-hover-background:#fff;--pico-contrast-hover-border:var(--pico-contrast-hover-background);--pico-contrast-hover-underline:var(--pico-contrast-hover);--pico-contrast-focus:rgba(207, 213, 226, 0.25);--pico-contrast-inverse:#000;--pico-box-shadow:0.0145rem 0.029rem 0.174rem rgba(7, 9, 12, 0.01698),0.0335rem 0.067rem 0.402rem rgba(7, 9, 12, 0.024),0.0625rem 0.125rem 0.75rem rgba(7, 9, 12, 0.03),0.1125rem 0.225rem 1.35rem rgba(7, 9, 12, 0.036),0.2085rem 0.417rem 2.502rem rgba(7, 9, 12, 0.04302),0.5rem 1rem 6rem rgba(7, 9, 12, 0.06),0 0 0 0.0625rem rgba(7, 9, 12, 0.015);--pico-h1-color:#f0f1f3;--pico-h2-color:#e0e3e7;--pico-h3-color:#c2c7d0;--pico-h4-color:#b3b9c5;--pico-h5-color:#a4acba;--pico-h6-color:#8891a4;--pico-mark-background-color:#014063;--pico-mark-color:#fff;--pico-ins-color:#62af9a;--pico-del-color:#ce7e7b;--pico-blockquote-border-color:var(--pico-muted-border-color);--pico-blockquote-footer-color:var(--pico-muted-color);--pico-button-box-shadow:0 0 0 rgba(0, 0, 0, 0);--pico-button-hover-box-shadow:0 0 0 rgba(0, 0, 0, 0);--pico-table-border-color:var(--pico-muted-border-color);--pico-table-row-stripped-background-color:rgba(111, 120, 135, 0.0375);--pico-code-background-color:#1a1f28;--pico-code-color:#8891a4;--pico-code-kbd-background-color:var(--pico-color);--pico-code-kbd-color:var(--pico-background-color);--pico-form-element-background-color:#1c212c;--pico-form-element-selected-background-color:#2a3140;--pico-form-element-border-color:#2a3140;--pico-form-element-color:#e0e3e7;--pico-form-element-placeholder-color:#8891a4;--pico-form-element-active-background-color:#1a1f28;--pico-form-element-active-border-color:var(--pico-primary-border);--pico-form-element-focus-color:var(--pico-primary-border);--pico-form-element-disabled-opacity:0.5;--pico-form-element-invalid-border-color:#964a50;--pico-form-element-invalid-active-border-color:#b7403b;--pico-form-element-invalid-focus-color:var(--pico-form-element-invalid-active-border-color);--pico-form-element-valid-border-color:#2a7b6f;--pico-form-element-valid-active-border-color:#16896a;--pico-form-element-valid-focus-color:var(--pico-form-element-valid-active-border-color);--pico-switch-background-color:#333c4e;--pico-switch-checked-background-color:var(--pico-primary-background);--pico-switch-color:#fff;--pico-switch-thumb-box-shadow:0 0 0 rgba(0, 0, 0, 0);--pico-range-border-color:#202632;--pico-range-active-border-color:#2a3140;--pico-range-thumb-border-color:var(--pico-background-color);--pico-range-thumb-color:var(--pico-secondary-background);--pico-range-thumb-active-color:var(--pico-primary-background);--pico-accordion-border-color:var(--pico-muted-border-color);--pico-accordion-active-summary-color:var(--pico-primary-hover);--pico-accordion-close-summary-color:var(--pico-color);--pico-accordion-open-summary-color:var(--pico-muted-color);--pico-card-background-color:#181c25;--pico-card-border-color:var(--pico-card-background-color);--pico-card-box-shadow:var(--pico-box-shadow);--pico-card-sectioning-background-color:#1a1f28;--pico-dropdown-background-color:#181c25;--pico-dropdown-border-color:#202632;--pico-dropdown-box-shadow:var(--pico-box-shadow);--pico-dropdown-color:var(--pico-color);--pico-dropdown-hover-background-color:#202632;--pico-loading-spinner-opacity:0.5;--pico-modal-overlay-background-color:rgba(8, 9, 10, 0.75);--pico-progress-background-color:#202632;--pico-progress-color:var(--pico-primary-background);--pico-tooltip-background-color:var(--pico-contrast-background);--pico-tooltip-color:var(--pico-contrast-inverse);--pico-icon-valid:url("data:image/svg+xml,%3Csvg xmlns='http://www.w3.org/2000/svg' width='24' height='24' viewBox='0 0 24 24' fill='none' stroke='rgb(42, 123, 111)' stroke-width='2' stroke-linecap='round' stroke-linejoin='round'%3E%3Cpolyline points='20 6 9 17 4 12'%3E%3C/polyline%3E%3C/svg%3E");--pico-icon-invalid:url("data:image/svg+xml,%3Csvg xmlns='http://www.w3.org/2000/svg' width='24' height='24' viewBox='0 0 24 24' fill='none' stroke='rgb(150, 74, 80)' stroke-width='2' stroke-linecap='round' stroke-linejoin='round'%3E%3Ccircle cx='12' cy='12' r='10'%3E%3C/circle%3E%3Cline x1='12' y1='8' x2='12' y2='12'%3E%3C/line%3E%3Cline x1='12' y1='16' x2='12.01' y2='16'%3E%3C/line%3E%3C/svg%3E");color-scheme:dark}[data-theme=dark] input:is([type=submit],[type=button],[type=reset],[type=checkbox],[type=radio],[type=file]){--pico-form-element-focus-color:var(--pico-primary-focus)}[data-theme=dark] details summary[role=button].contrast:not(.outline)::after{filter:brightness(0)}[data-theme=dark] [aria-busy=true]:not(input,select,textarea).contrast:is(button,[type=submit],[type=button],[type=reset],[role=button]):not(.outline)::before{filter:brightness(0)}[type=checkbox],[type=radio],[type=range],progress{accent-color:var(--pico-primary)}*,::after,::before{box-sizing:border-box;background-repeat:no-repeat}::after,::before{text-decoration:inherit;vertical-align:inherit}:where(:root){-webkit-tap-highlight-color:transparent;-webkit-text-size-adjust:100%;-moz-text-size-adjust:100%;text-size-adjust:100%;background-color:var(--pico-background-color);color:var(--pico-color);font-weight:var(--pico-font-weight);font-size:var(--pico-font-size);line-height:var(--pico-line-height);font-family:var(--pico-font-family);text-underline-offset:var(--pico-text-underline-offset);text-rendering:optimizeLegibility;overflow-wrap:break-word;-moz-tab-size:4;-o-tab-size:4;tab-size:4}body{width:100%;margin:0}main{display:block}body>footer,body>header,body>main{padding-block:var(--pico-block-spacing-vertical)}section{margin-bottom:var(--pico-block-spacing-vertical)}.container,.container-fluid{width:100%;margin-right:auto;margin-left:auto;padding-right:var(--pico-spacing);padding-left:var(--pico-spacing)}@media (min-width:576px){.container{max-width:510px;padding-right:0;padding-left:0}}@media (min-width:768px){.container{max-width:700px}}@media (min-width:1024px){.container{max-width:950px}}@media (min-width:1280px){.container{max-width:1200px}}@media (min-width:1536px){.container{max-width:1450px}}.grid{grid-column-gap:var(--pico-grid-column-gap);grid-row-gap:var(--pico-grid-row-gap);display:grid;grid-template-columns:1fr}@media (min-width:768px){.grid{grid-template-columns:repeat(auto-fit,minmax(0%,1fr))}}.grid>*{min-width:0}.overflow-auto{overflow:auto}b,strong{font-weight:bolder}sub,sup{position:relative;font-size:.75em;line-height:0;vertical-align:baseline}sub{bottom:-.25em}sup{top:-.5em}address,blockquote,dl,ol,p,pre,table,ul{margin-top:0;margin-bottom:var(--pico-typography-spacing-vertical);color:var(--pico-color);font-style:normal;font-weight:var(--pico-font-weight)}h1,h2,h3,h4,h5,h6{margin-top:0;margin-bottom:var(--pico-typography-spacing-vertical);color:var(--pico-color);font-weight:var(--pico-font-weight);font-size:var(--pico-font-size);line-height:var(--pico-line-height);font-family:var(--pico-font-family)}h1{--pico-color:var(--pico-h1-color)}h2{--pico-color:var(--pico-h2-color)}h3{--pico-color:var(--pico-h3-color)}h4{--pico-color:var(--pico-h4-color)}h5{--pico-color:var(--pico-h5-color)}h6{--pico-color:var(--pico-h6-color)}:where(article,address,blockquote,dl,figure,form,ol,p,pre,table,ul)~:is(h1,h2,h3,h4,h5,h6){margin-top:var(--pico-typography-spacing-top)}p{margin-bottom:var(--pico-typography-spacing-vertical)}hgroup{margin-bottom:var(--pico-typography-spacing-vertical)}hgroup>*{margin-top:0;margin-bottom:0}hgroup>:not(:first-child):last-child{--pico-color:var(--pico-muted-color);--pico-font-weight:unset;font-size:1rem}:where(ol,ul) li{margin-bottom:calc(var(--pico-typography-spacing-vertical) * .25)}:where(dl,ol,ul) :where(dl,ol,ul){margin:0;margin-top:calc(var(--pico-typography-spacing-vertical) * .25)}ul li{list-style:square}mark{padding:.125rem .25rem;background-color:var(--pico-mark-background-color);color:var(--pico-mark-color);vertical-align:baseline}blockquote{display:block;margin:var(--pico-typography-spacing-vertical) 0;padding:var(--pico-spacing);border-right:none;border-left:.25rem solid var(--pico-blockquote-border-color);border-inline-start:0.25rem solid var(--pico-blockquote-border-color);border-inline-end:none}blockquote footer{margin-top:calc(var(--pico-typography-spacing-vertical) * .5);color:var(--pico-blockquote-footer-color)}abbr[title]{border-bottom:1px dotted;text-decoration:none;cursor:help}ins{color:var(--pico-ins-color);text-decoration:none}del{color:var(--pico-del-color)}::-moz-selection{background-color:var(--pico-text-selection-color)}::selection{background-color:var(--pico-text-selection-color)}:where(a:not([role=button])),[role=link]{--pico-color:var(--pico-primary);--pico-background-color:transparent;--pico-underline:var(--pico-primary-underline);outline:0;background-color:var(--pico-background-color);color:var(--pico-color);-webkit-text-decoration:var(--pico-text-decoration);text-decoration:var(--pico-text-decoration);text-decoration-color:var(--pico-underline);text-underline-offset:0.125em;transition:background-color var(--pico-transition),color var(--pico-transition),box-shadow var(--pico-transition),-webkit-text-decoration var(--pico-transition);transition:background-color var(--pico-transition),color var(--pico-transition),text-decoration var(--pico-transition),box-shadow var(--pico-transition);transition:background-color var(--pico-transition),color var(--pico-transition),text-decoration var(--pico-transition),box-shadow var(--pico-transition),-webkit-text-decoration var(--pico-transition)}:where(a:not([role=button])):is([aria-current]:not([aria-current=false]),:hover,:active,:focus),[role=link]:is([aria-current]:not([aria-current=false]),:hover,:active,:focus){--pico-color:var(--pico-primary-hover);--pico-underline:var(--pico-primary-hover-underline);--pico-text-decoration:underline}:where(a:not([role=button])):focus-visible,[role=link]:focus-visible{box-shadow:0 0 0 var(--pico-outline-width) var(--pico-primary-focus)}:where(a:not([role=button])).secondary,[role=link].secondary{--pico-color:var(--pico-secondary);--pico-underline:var(--pico-secondary-underline)}:where(a:not([role=button])).secondary:is([aria-current]:not([aria-current=false]),:hover,:active,:focus),[role=link].secondary:is([aria-current]:not([aria-current=false]),:hover,:active,:focus){--pico-color:var(--pico-secondary-hover);--pico-underline:var(--pico-secondary-hover-underline)}:where(a:not([role=button])).contrast,[role=link].contrast{--pico-color:var(--pico-contrast);--pico-underline:var(--pico-contrast-underline)}:where(a:not([role=button])).contrast:is([aria-current]:not([aria-current=false]),:hover,:active,:focus),[role=link].contrast:is([aria-current]:not([aria-current=false]),:hover,:active,:focus){--pico-color:var(--pico-contrast-hover);--pico-underline:var(--pico-contrast-hover-underline)}a[role=button]{display:inline-block}button{margin:0;overflow:visible;font-family:inherit;text-transform:none}[type=button],[type=reset],[type=submit],button{-webkit-appearance:button}[role=button],[type=button],[type=file]::file-selector-button,[type=reset],[type=submit],button{--pico-background-color:var(--pico-primary-background);--pico-border-color:var(--pico-primary-border);--pico-color:var(--pico-primary-inverse);--pico-box-shadow:var(--pico-button-box-shadow, 0 0 0 rgba(0, 0, 0, 0));padding:var(--pico-form-element-spacing-vertical) var(--pico-form-element-spacing-horizontal);border:var(--pico-border-width) solid var(--pico-border-color);border-radius:var(--pico-border-radius);outline:0;background-color:var(--pico-background-color);box-shadow:var(--pico-box-shadow);color:var(--pico-color);font-weight:var(--pico-font-weight);font-size:1rem;line-height:var(--pico-line-height);text-align:center;text-decoration:none;cursor:pointer;-webkit-user-select:none;-moz-user-select:none;user-select:none;transition:background-color var(--pico-transition),border-color var(--pico-transition),color var(--pico-transition),box-shadow var(--pico-transition)}[role=button]:is(:hover,:active,:focus),[role=button]:is([aria-current]:not([aria-current=false])),[type=button]:is(:hover,:active,:focus),[type=button]:is([aria-current]:not([aria-current=false])),[type=file]::file-selector-button:is(:hover,:active,:focus),[type=file]::file-selector-button:is([aria-current]:not([aria-current=false])),[type=reset]:is(:hover,:active,:focus),[type=reset]:is([aria-current]:not([aria-current=false])),[type=submit]:is(:hover,:active,:focus),[type=submit]:is([aria-current]:not([aria-current=false])),button:is(:hover,:active,:focus),button:is([aria-current]:not([aria-current=false])){--pico-background-color:var(--pico-primary-hover-background);--pico-border-color:var(--pico-primary-hover-border);--pico-box-shadow:var(--pico-button-hover-box-shadow, 0 0 0 rgba(0, 0, 0, 0));--pico-color:var(--pico-primary-inverse)}[role=button]:focus,[role=button]:is([aria-current]:not([aria-current=false])):focus,[type=button]:focus,[type=button]:is([aria-current]:not([aria-current=false])):focus,[type=file]::file-selector-button:focus,[type=file]::file-selector-button:is([aria-current]:not([aria-current=false])):focus,[type=reset]:focus,[type=reset]:is([aria-current]:not([aria-current=false])):focus,[type=submit]:focus,[type=submit]:is([aria-current]:not([aria-current=false])):focus,button:focus,button:is([aria-current]:not([aria-current=false])):focus{--pico-box-shadow:var(--pico-button-hover-box-shadow, 0 0 0 rgba(0, 0, 0, 0)),0 0 0 var(--pico-outline-width) var(--pico-primary-focus)}[type=button],[type=reset],[type=submit]{margin-bottom:var(--pico-spacing)}:is(button,[type=submit],[type=button],[role=button]).secondary,[type=file]::file-selector-button,[type=reset]{--pico-background-color:var(--pico-secondary-background);--pico-border-color:var(--pico-secondary-border);--pico-color:var(--pico-secondary-inverse);cursor:pointer}:is(button,[type=submit],[type=button],[role=button]).secondary:is([aria-current]:not([aria-current=false]),:hover,:active,:focus),[type=file]::file-selector-button:is([aria-current]:not([aria-current=false]),:hover,:active,:focus),[type=reset]:is([aria-current]:not([aria-current=false]),:hover,:active,:focus){--pico-background-color:var(--pico-secondary-hover-background);--pico-border-color:var(--pico-secondary-hover-border);--pico-color:var(--pico-secondary-inverse)}:is(button,[type=submit],[type=button],[role=button]).secondary:focus,:is(button,[type=submit],[type=button],[role=button]).secondary:is([aria-current]:not([aria-current=false])):focus,[type=file]::file-selector-button:focus,[type=file]::file-selector-button:is([aria-current]:not([aria-current=false])):focus,[type=reset]:focus,[type=reset]:is([aria-current]:not([aria-current=false])):focus{--pico-box-shadow:var(--pico-button-hover-box-shadow, 0 0 0 rgba(0, 0, 0, 0)),0 0 0 var(--pico-outline-width) var(--pico-secondary-focus)}:is(button,[type=submit],[type=button],[role=button]).contrast{--pico-background-color:var(--pico-contrast-background);--pico-border-color:var(--pico-contrast-border);--pico-color:var(--pico-contrast-inverse)}:is(button,[type=submit],[type=button],[role=button]).contrast:is([aria-current]:not([aria-current=false]),:hover,:active,:focus){--pico-background-color:var(--pico-contrast-hover-background);--pico-border-color:var(--pico-contrast-hover-border);--pico-color:var(--pico-contrast-inverse)}:is(button,[type=submit],[type=button],[role=button]).contrast:focus,:is(button,[type=submit],[type=button],[role=button]).contrast:is([aria-current]:not([aria-current=false])):focus{--pico-box-shadow:var(--pico-button-hover-box-shadow, 0 0 0 rgba(0, 0, 0, 0)),0 0 0 var(--pico-outline-width) var(--pico-contrast-focus)}:is(button,[type=submit],[type=button],[role=button]).outline,[type=reset].outline{--pico-background-color:transparent;--pico-color:var(--pico-primary);--pico-border-color:var(--pico-primary)}:is(button,[type=submit],[type=button],[role=button]).outline:is([aria-current]:not([aria-current=false]),:hover,:active,:focus),[type=reset].outline:is([aria-current]:not([aria-current=false]),:hover,:active,:focus){--pico-background-color:transparent;--pico-color:var(--pico-primary-hover);--pico-border-color:var(--pico-primary-hover)}:is(button,[type=submit],[type=button],[role=button]).outline.secondary,[type=reset].outline{--pico-color:var(--pico-secondary);--pico-border-color:var(--pico-secondary)}:is(button,[type=submit],[type=button],[role=button]).outline.secondary:is([aria-current]:not([aria-current=false]),:hover,:active,:focus),[type=reset].outline:is([aria-current]:not([aria-current=false]),:hover,:active,:focus){--pico-color:var(--pico-secondary-hover);--pico-border-color:var(--pico-secondary-hover)}:is(button,[type=submit],[type=button],[role=button]).outline.contrast{--pico-color:var(--pico-contrast);--pico-border-color:var(--pico-contrast)}:is(button,[type=submit],[type=button],[role=button]).outline.contrast:is([aria-current]:not([aria-current=false]),:hover,:active,:focus){--pico-color:var(--pico-contrast-hover);--pico-border-color:var(--pico-contrast-hover)}:where(button,[type=submit],[type=reset],[type=button],[role=button])[disabled],:where(fieldset[disabled]) :is(button,[type=submit],[type=button],[type=reset],[role=button]){opacity:.5;pointer-events:none}:where(table){width:100%;border-collapse:collapse;border-spacing:0;text-indent:0}td,th{padding:calc(var(--pico-spacing)/ 2) var(--pico-spacing);border-bottom:var(--pico-border-width) solid var(--pico-table-border-color);background-color:var(--pico-background-color);color:var(--pico-color);font-weight:var(--pico-font-weight);text-align:left;text-align:start}tfoot td,tfoot th{border-top:var(--pico-border-width) solid var(--pico-table-border-color);border-bottom:0}table.striped tbody tr:nth-child(odd) td,table.striped tbody tr:nth-child(odd) th{background-color:var(--pico-table-row-stripped-background-color)}:where(audio,canvas,iframe,img,svg,video){vertical-align:middle}audio,video{display:inline-block}audio:not([controls]){display:none;height:0}:where(iframe){border-style:none}img{max-width:100%;height:auto;border-style:none}:where(svg:not([fill])){fill:currentColor}svg:not(:root){overflow:hidden}code,kbd,pre,samp{font-size:.875em;font-family:var(--pico-font-family)}pre code{font-size:inherit;font-family:inherit}pre{-ms-overflow-style:scrollbar;overflow:auto}code,kbd,pre{border-radius:var(--pico-border-radius);background:var(--pico-code-background-color);color:var(--pico-code-color);font-weight:var(--pico-font-weight);line-height:initial}code,kbd{display:inline-block;padding:.375rem}pre{display:block;margin-bottom:var(--pico-spacing);overflow-x:auto}pre>code{display:block;padding:var(--pico-spacing);background:0 0;line-height:var(--pico-line-height)}kbd{background-color:var(--pico-code-kbd-background-color);color:var(--pico-code-kbd-color);vertical-align:baseline}figure{display:block;margin:0;padding:0}figure figcaption{padding:calc(var(--pico-spacing) * .5) 0;color:var(--pico-muted-color)}hr{height:0;margin:var(--pico-typography-spacing-vertical) 0;border:0;border-top:1px solid var(--pico-muted-border-color);color:inherit}[hidden],template{display:none!important}canvas{display:inline-block}input,optgroup,select,textarea{margin:0;font-size:1rem;line-height:var(--pico-line-height);font-family:inherit;letter-spacing:inherit}input{overflow:visible}select{text-transform:none}legend{max-width:100%;padding:0;color:inherit;white-space:normal}textarea{overflow:auto}[type=checkbox],[type=radio]{padding:0}::-webkit-inner-spin-button,::-webkit-outer-spin-button{height:auto}[type=search]{-webkit-appearance:textfield;outline-offset:-2px}[type=search]::-webkit-search-decoration{-webkit-appearance:none}::-webkit-file-upload-button{-webkit-appearance:button;font:inherit}::-moz-focus-inner{padding:0;border-style:none}:-moz-focusring{outline:0}:-moz-ui-invalid{box-shadow:none}::-ms-expand{display:none}[type=file],[type=range]{padding:0;border-width:0}input:not([type=checkbox],[type=radio],[type=range]){height:calc(1rem * var(--pico-line-height) + var(--pico-form-element-spacing-vertical) * 2 + var(--pico-border-width) * 2)}fieldset{width:100%;margin:0;margin-bottom:var(--pico-spacing);padding:0;border:0}fieldset legend,label{display:block;margin-bottom:calc(var(--pico-spacing) * .375);color:var(--pico-color);font-weight:var(--pico-form-label-font-weight,var(--pico-font-weight))}fieldset legend{margin-bottom:calc(var(--pico-spacing) * .5)}button[type=submit],input:not([type=checkbox],[type=radio]),select,textarea{width:100%}input:not([type=checkbox],[type=radio],[type=range],[type=file]),select,textarea{-webkit-appearance:none;-moz-appearance:none;appearance:none;padding:var(--pico-form-element-spacing-vertical) var(--pico-form-element-spacing-horizontal)}input,select,textarea{--pico-background-color:var(--pico-form-element-background-color);--pico-border-color:var(--pico-form-element-border-color);--pico-color:var(--pico-form-element-color);--pico-box-shadow:none;border:var(--pico-border-width) solid var(--pico-border-color);border-radius:var(--pico-border-radius);outline:0;background-color:var(--pico-background-color);box-shadow:var(--pico-box-shadow);color:var(--pico-color);font-weight:var(--pico-font-weight);transition:background-color var(--pico-transition),border-color var(--pico-transition),color var(--pico-transition),box-shadow var(--pico-transition)}:where(select,textarea):not([readonly]):is(:active,:focus),input:not([type=submit],[type=button],[type=reset],[type=checkbox],[type=radio],[readonly]):is(:active,:focus){--pico-background-color:var(--pico-form-element-active-background-color)}:where(select,textarea):not([readonly]):is(:active,:focus),input:not([type=submit],[type=button],[type=reset],[role=switch],[readonly]):is(:active,:focus){--pico-border-color:var(--pico-form-element-active-border-color)}:where(select,textarea):not([readonly]):focus,input:not([type=submit],[type=button],[type=reset],[type=range],[type=file],[readonly]):focus{--pico-box-shadow:0 0 0 var(--pico-outline-width) var(--pico-form-element-focus-color)}:where(fieldset[disabled]) :is(input:not([type=submit],[type=button],[type=reset]),select,textarea),input:not([type=submit],[type=button],[type=reset])[disabled],label[aria-disabled=true],select[disabled],textarea[disabled]{opacity:var(--pico-form-element-disabled-opacity);pointer-events:none}label[aria-disabled=true] input[disabled]{opacity:1}:where(input,select,textarea):not([type=checkbox],[type=radio],[type=date],[type=datetime-local],[type=month],[type=time],[type=week],[type=range])[aria-invalid]{padding-right:calc(var(--pico-form-element-spacing-horizontal) + 1.5rem)!important;padding-left:var(--pico-form-element-spacing-horizontal);padding-inline-start:var(--pico-form-element-spacing-horizontal)!important;padding-inline-end:calc(var(--pico-form-element-spacing-horizontal) + 1.5rem)!important;background-position:center right .75rem;background-size:1rem auto;background-repeat:no-repeat}:where(input,select,textarea):not([type=checkbox],[type=radio],[type=date],[type=datetime-local],[type=month],[type=time],[type=week],[type=range])[aria-invalid=false]:not(select){background-image:var(--pico-icon-valid)}:where(input,select,textarea):not([type=checkbox],[type=radio],[type=date],[type=datetime-local],[type=month],[type=time],[type=week],[type=range])[aria-invalid=true]:not(select){background-image:var(--pico-icon-invalid)}:where(input,select,textarea)[aria-invalid=false]{--pico-border-color:var(--pico-form-element-valid-border-color)}:where(input,select,textarea)[aria-invalid=false]:is(:active,:focus){--pico-border-color:var(--pico-form-element-valid-active-border-color)!important}:where(input,select,textarea)[aria-invalid=false]:is(:active,:focus):not([type=checkbox],[type=radio]){--pico-box-shadow:0 0 0 var(--pico-outline-width) var(--pico-form-element-valid-focus-color)!important}:where(input,select,textarea)[aria-invalid=true]{--pico-border-color:var(--pico-form-element-invalid-border-color)}:where(input,select,textarea)[aria-invalid=true]:is(:active,:focus){--pico-border-color:var(--pico-form-element-invalid-active-border-color)!important}:where(input,select,textarea)[aria-invalid=true]:is(:active,:focus):not([type=checkbox],[type=radio]){--pico-box-shadow:0 0 0 var(--pico-outline-width) var(--pico-form-element-invalid-focus-color)!important}[dir=rtl] :where(input,select,textarea):not([type=checkbox],[type=radio]):is([aria-invalid],[aria-invalid=true],[aria-invalid=false]){background-position:center left .75rem}input::-webkit-input-placeholder,input::placeholder,select:invalid,textarea::-webkit-input-placeholder,textarea::placeholder{color:var(--pico-form-element-placeholder-color);opacity:1}input:not([type=checkbox],[type=radio]),select,textarea{margin-bottom:var(--pico-spacing)}select::-ms-expand{border:0;background-color:transparent}select:not([multiple],[size]){padding-right:calc(var(--pico-form-element-spacing-horizontal) + 1.5rem);padding-left:var(--pico-form-element-spacing-horizontal);padding-inline-start:var(--pico-form-element-spacing-horizontal);padding-inline-end:calc(var(--pico-form-element-spacing-horizontal) + 1.5rem);background-image:var(--pico-icon-chevron);background-position:center right .75rem;background-size:1rem auto;background-repeat:no-repeat}select[multiple] option:checked{background:var(--pico-form-element-selected-background-color);color:var(--pico-form-element-color)}[dir=rtl] select:not([multiple],[size]){background-position:center left .75rem}textarea{display:block;resize:vertical}textarea[aria-invalid]{--pico-icon-height:calc(1rem * var(--pico-line-height) + var(--pico-form-element-spacing-vertical) * 2 + var(--pico-border-width) * 2);background-position:top right .75rem!important;background-size:1rem var(--pico-icon-height)!important}:where(input,select,textarea,fieldset,.grid)+small{display:block;width:100%;margin-top:calc(var(--pico-spacing) * -.75);margin-bottom:var(--pico-spacing);color:var(--pico-muted-color)}:where(input,select,textarea,fieldset,.grid)[aria-invalid=false]+small{color:var(--pico-ins-color)}:where(input,select,textarea,fieldset,.grid)[aria-invalid=true]+small{color:var(--pico-del-color)}label>:where(input,select,textarea){margin-top:calc(var(--pico-spacing) * .25)}label:has([type=checkbox],[type=radio]){width:-moz-fit-content;width:fit-content;cursor:pointer}[type=checkbox],[type=radio]{-webkit-appearance:none;-moz-appearance:none;appearance:none;width:1.25em;height:1.25em;margin-top:-.125em;margin-inline-end:.5em;border-width:var(--pico-border-width);vertical-align:middle;cursor:pointer}[type=checkbox]::-ms-check,[type=radio]::-ms-check{display:none}[type=checkbox]:checked,[type=checkbox]:checked:active,[type=checkbox]:checked:focus,[type=radio]:checked,[type=radio]:checked:active,[type=radio]:checked:focus{--pico-background-color:var(--pico-primary-background);--pico-border-color:var(--pico-primary-border);background-image:var(--pico-icon-checkbox);background-position:center;background-size:.75em auto;background-repeat:no-repeat}[type=checkbox]~label,[type=radio]~label{display:inline-block;margin-bottom:0;cursor:pointer}[type=checkbox]~label:not(:last-of-type),[type=radio]~label:not(:last-of-type){margin-inline-end:1em}[type=checkbox]:indeterminate{--pico-background-color:var(--pico-primary-background);--pico-border-color:var(--pico-primary-border);background-image:var(--pico-icon-minus);background-position:center;background-size:.75em auto;background-repeat:no-repeat}[type=radio]{border-radius:50%}[type=radio]:checked,[type=radio]:checked:active,[type=radio]:checked:focus{--pico-background-color:var(--pico-primary-inverse);border-width:.35em;background-image:none}[type=checkbox][role=switch]{--pico-background-color:var(--pico-switch-background-color);--pico-color:var(--pico-switch-color);width:2.25em;height:1.25em;border:var(--pico-border-width) solid var(--pico-border-color);border-radius:1.25em;background-color:var(--pico-background-color);line-height:1.25em}[type=checkbox][role=switch]:not([aria-invalid]){--pico-border-color:var(--pico-switch-background-color)}[type=checkbox][role=switch]:before{display:block;aspect-ratio:1;height:100%;border-radius:50%;background-color:var(--pico-color);box-shadow:var(--pico-switch-thumb-box-shadow);content:"";transition:margin .1s ease-in-out}[type=checkbox][role=switch]:focus{--pico-background-color:var(--pico-switch-background-color);--pico-border-color:var(--pico-switch-background-color)}[type=checkbox][role=switch]:checked{--pico-background-color:var(--pico-switch-checked-background-color);--pico-border-color:var(--pico-switch-checked-background-color);background-image:none}[type=checkbox][role=switch]:checked::before{margin-inline-start:calc(2.25em - 1.25em)}[type=checkbox][role=switch][disabled]{--pico-background-color:var(--pico-border-color)}[type=checkbox][aria-invalid=false]:checked,[type=checkbox][aria-invalid=false]:checked:active,[type=checkbox][aria-invalid=false]:checked:focus,[type=checkbox][role=switch][aria-invalid=false]:checked,[type=checkbox][role=switch][aria-invalid=false]:checked:active,[type=checkbox][role=switch][aria-invalid=false]:checked:focus{--pico-background-color:var(--pico-form-element-valid-border-color)}[type=checkbox]:checked:active[aria-invalid=true],[type=checkbox]:checked:focus[aria-invalid=true],[type=checkbox]:checked[aria-invalid=true],[type=checkbox][role=switch]:checked:active[aria-invalid=true],[type=checkbox][role=switch]:checked:focus[aria-invalid=true],[type=checkbox][role=switch]:checked[aria-invalid=true]{--pico-background-color:var(--pico-form-element-invalid-border-color)}[type=checkbox][aria-invalid=false]:checked,[type=checkbox][aria-invalid=false]:checked:active,[type=checkbox][aria-invalid=false]:checked:focus,[type=checkbox][role=switch][aria-invalid=false]:checked,[type=checkbox][role=switch][aria-invalid=false]:checked:active,[type=checkbox][role=switch][aria-invalid=false]:checked:focus,[type=radio][aria-invalid=false]:checked,[type=radio][aria-invalid=false]:checked:active,[type=radio][aria-invalid=false]:checked:focus{--pico-border-color:var(--pico-form-element-valid-border-color)}[type=checkbox]:checked:active[aria-invalid=true],[type=checkbox]:checked:focus[aria-invalid=true],[type=checkbox]:checked[aria-invalid=true],[type=checkbox][role=switch]:checked:active[aria-invalid=true],[type=checkbox][role=switch]:checked:focus[aria-invalid=true],[type=checkbox][role=switch]:checked[aria-invalid=true],[type=radio]:checked:active[aria-invalid=true],[type=radio]:checked:focus[aria-invalid=true],[type=radio]:checked[aria-invalid=true]{--pico-border-color:var(--pico-form-element-invalid-border-color)}[type=color]::-webkit-color-swatch-wrapper{padding:0}[type=color]::-moz-focus-inner{padding:0}[type=color]::-webkit-color-swatch{border:0;border-radius:calc(var(--pico-border-radius) * .5)}[type=color]::-moz-color-swatch{border:0;border-radius:calc(var(--pico-border-radius) * .5)}input:not([type=checkbox],[type=radio],[type=range],[type=file]):is([type=date],[type=datetime-local],[type=month],[type=time],[type=week]){--pico-icon-position:0.75rem;--pico-icon-width:1rem;padding-right:calc(var(--pico-icon-width) + var(--pico-icon-position));background-image:var(--pico-icon-date);background-position:center right var(--pico-icon-position);background-size:var(--pico-icon-width) auto;background-repeat:no-repeat}input:not([type=checkbox],[type=radio],[type=range],[type=file])[type=time]{background-image:var(--pico-icon-time)}[type=date]::-webkit-calendar-picker-indicator,[type=datetime-local]::-webkit-calendar-picker-indicator,[type=month]::-webkit-calendar-picker-indicator,[type=time]::-webkit-calendar-picker-indicator,[type=week]::-webkit-calendar-picker-indicator{width:var(--pico-icon-width);margin-right:calc(var(--pico-icon-width) * -1);margin-left:var(--pico-icon-position);opacity:0}@-moz-document url-prefix(){[type=date],[type=datetime-local],[type=month],[type=time],[type=week]{padding-right:var(--pico-form-element-spacing-horizontal)!important;background-image:none!important}}[dir=rtl] :is([type=date],[type=datetime-local],[type=month],[type=time],[type=week]){text-align:right}[type=file]{--pico-color:var(--pico-muted-color);margin-left:calc(var(--pico-outline-width) * -1);padding:calc(var(--pico-form-element-spacing-vertical) * .5) 0;padding-left:var(--pico-outline-width);border:0;border-radius:0;background:0 0}[type=file]::file-selector-button{margin-right:calc(var(--pico-spacing)/ 2);padding:calc(var(--pico-form-element-spacing-vertical) * .5) var(--pico-form-element-spacing-horizontal)}[type=file]:is(:hover,:active,:focus)::file-selector-button{--pico-background-color:var(--pico-secondary-hover-background);--pico-border-color:var(--pico-secondary-hover-border)}[type=file]:focus::file-selector-button{--pico-box-shadow:var(--pico-button-hover-box-shadow, 0 0 0 rgba(0, 0, 0, 0)),0 0 0 var(--pico-outline-width) var(--pico-secondary-focus)}[type=range]{-webkit-appearance:none;-moz-appearance:none;appearance:none;width:100%;height:1.25rem;background:0 0}[type=range]::-webkit-slider-runnable-track{width:100%;height:.375rem;border-radius:var(--pico-border-radius);background-color:var(--pico-range-border-color);-webkit-transition:background-color var(--pico-transition),box-shadow var(--pico-transition);transition:background-color var(--pico-transition),box-shadow var(--pico-transition)}[type=range]::-moz-range-track{width:100%;height:.375rem;border-radius:var(--pico-border-radius);background-color:var(--pico-range-border-color);-moz-transition:background-color var(--pico-transition),box-shadow var(--pico-transition);transition:background-color var(--pico-transition),box-shadow var(--pico-transition)}[type=range]::-ms-track{width:100%;height:.375rem;border-radius:var(--pico-border-radius);background-color:var(--pico-range-border-color);-ms-transition:background-color var(--pico-transition),box-shadow var(--pico-transition);transition:background-color var(--pico-transition),box-shadow var(--pico-transition)}[type=range]::-webkit-slider-thumb{-webkit-appearance:none;width:1.25rem;height:1.25rem;margin-top:-.4375rem;border:2px solid var(--pico-range-thumb-border-color);border-radius:50%;background-color:var(--pico-range-thumb-color);cursor:pointer;-webkit-transition:background-color var(--pico-transition),transform var(--pico-transition);transition:background-color var(--pico-transition),transform var(--pico-transition)}[type=range]::-moz-range-thumb{-webkit-appearance:none;width:1.25rem;height:1.25rem;margin-top:-.4375rem;border:2px solid var(--pico-range-thumb-border-color);border-radius:50%;background-color:var(--pico-range-thumb-color);cursor:pointer;-moz-transition:background-color var(--pico-transition),transform var(--pico-transition);transition:background-color var(--pico-transition),transform var(--pico-transition)}[type=range]::-ms-thumb{-webkit-appearance:none;width:1.25rem;height:1.25rem;margin-top:-.4375rem;border:2px solid var(--pico-range-thumb-border-color);border-radius:50%;background-color:var(--pico-range-thumb-color);cursor:pointer;-ms-transition:background-color var(--pico-transition),transform var(--pico-transition);transition:background-color var(--pico-transition),transform var(--pico-transition)}[type=range]:active,[type=range]:focus-within{--pico-range-border-color:var(--pico-range-active-border-color);--pico-range-thumb-color:var(--pico-range-thumb-active-color)}[type=range]:active::-webkit-slider-thumb{transform:scale(1.25)}[type=range]:active::-moz-range-thumb{transform:scale(1.25)}[type=range]:active::-ms-thumb{transform:scale(1.25)}input:not([type=checkbox],[type=radio],[type=range],[type=file])[type=search]{padding-inline-start:calc(var(--pico-form-element-spacing-horizontal) + 1.75rem);background-image:var(--pico-icon-search);background-position:center left calc(var(--pico-form-element-spacing-horizontal) + .125rem);background-size:1rem auto;background-repeat:no-repeat}input:not([type=checkbox],[type=radio],[type=range],[type=file])[type=search][aria-invalid]{padding-inline-start:calc(var(--pico-form-element-spacing-horizontal) + 1.75rem)!important;background-position:center left 1.125rem,center right .75rem}input:not([type=checkbox],[type=radio],[type=range],[type=file])[type=search][aria-invalid=false]{background-image:var(--pico-icon-search),var(--pico-icon-valid)}input:not([type=checkbox],[type=radio],[type=range],[type=file])[type=search][aria-invalid=true]{background-image:var(--pico-icon-search),var(--pico-icon-invalid)}[dir=rtl] :where(input):not([type=checkbox],[type=radio],[type=range],[type=file])[type=search]{background-position:center right 1.125rem}[dir=rtl] :where(input):not([type=checkbox],[type=radio],[type=range],[type=file])[type=search][aria-invalid]{background-position:center right 1.125rem,center left .75rem}details{display:block;margin-bottom:var(--pico-spacing)}details summary{line-height:1rem;list-style-type:none;cursor:pointer;transition:color var(--pico-transition)}details summary:not([role]){color:var(--pico-accordion-close-summary-color)}details summary::-webkit-details-marker{display:none}details summary::marker{display:none}details summary::-moz-list-bullet{list-style-type:none}details summary::after{display:block;width:1rem;height:1rem;margin-inline-start:calc(var(--pico-spacing,1rem) * .5);float:right;transform:rotate(-90deg);background-image:var(--pico-icon-chevron);background-position:right center;background-size:1rem auto;background-repeat:no-repeat;content:"";transition:transform var(--pico-transition)}details summary:focus{outline:0}details summary:focus:not([role]){color:var(--pico-accordion-active-summary-color)}details summary:focus-visible:not([role]){outline:var(--pico-outline-width) solid var(--pico-primary-focus);outline-offset:calc(var(--pico-spacing,1rem) * 0.5);color:var(--pico-primary)}details summary[role=button]{width:100%;text-align:left}details summary[role=button]::after{height:calc(1rem * var(--pico-line-height,1.5))}details[open]>summary{margin-bottom:var(--pico-spacing)}details[open]>summary:not([role]):not(:focus){color:var(--pico-accordion-open-summary-color)}details[open]>summary::after{transform:rotate(0)}[dir=rtl] details summary{text-align:right}[dir=rtl] details summary::after{float:left;background-position:left center}article{margin-bottom:var(--pico-block-spacing-vertical);padding:var(--pico-block-spacing-vertical) var(--pico-block-spacing-horizontal);border-radius:var(--pico-border-radius);background:var(--pico-card-background-color);box-shadow:var(--pico-card-box-shadow)}article>footer,article>header{margin-right:calc(var(--pico-block-spacing-horizontal) * -1);margin-left:calc(var(--pico-block-spacing-horizontal) * -1);padding:calc(var(--pico-block-spacing-vertical) * .66) var(--pico-block-spacing-horizontal);background-color:var(--pico-card-sectioning-background-color)}article>header{margin-top:calc(var(--pico-block-spacing-vertical) * -1);margin-bottom:var(--pico-block-spacing-vertical);border-bottom:var(--pico-border-width) solid var(--pico-card-border-color);border-top-right-radius:var(--pico-border-radius);border-top-left-radius:var(--pico-border-radius)}article>footer{margin-top:var(--pico-block-spacing-vertical);margin-bottom:calc(var(--pico-block-spacing-vertical) * -1);border-top:var(--pico-border-width) solid var(--pico-card-border-color);border-bottom-right-radius:var(--pico-border-radius);border-bottom-left-radius:var(--pico-border-radius)}details.dropdown{position:relative;border-bottom:none}details.dropdown summary::after,details.dropdown>a::after,details.dropdown>button::after{display:block;width:1rem;height:calc(1rem * var(--pico-line-height,1.5));margin-inline-start:.25rem;float:right;transform:rotate(0) translateX(.2rem);background-image:var(--pico-icon-chevron);background-position:right center;background-size:1rem auto;background-repeat:no-repeat;content:""}nav details.dropdown{margin-bottom:0}details.dropdown summary:not([role]){height:calc(1rem * var(--pico-line-height) + var(--pico-form-element-spacing-vertical) * 2 + var(--pico-border-width) * 2);padding:var(--pico-form-element-spacing-vertical) var(--pico-form-element-spacing-horizontal);border:var(--pico-border-width) solid var(--pico-form-element-border-color);border-radius:var(--pico-border-radius);background-color:var(--pico-form-element-background-color);color:var(--pico-form-element-placeholder-color);line-height:inherit;cursor:pointer;-webkit-user-select:none;-moz-user-select:none;user-select:none;transition:background-color var(--pico-transition),border-color var(--pico-transition),color var(--pico-transition),box-shadow var(--pico-transition)}details.dropdown summary:not([role]):active,details.dropdown summary:not([role]):focus{border-color:var(--pico-form-element-active-border-color);background-color:var(--pico-form-element-active-background-color)}details.dropdown summary:not([role]):focus{box-shadow:0 0 0 var(--pico-outline-width) var(--pico-form-element-focus-color)}details.dropdown summary:not([role]):focus-visible{outline:0}details.dropdown summary:not([role])[aria-invalid=false]{--pico-form-element-border-color:var(--pico-form-element-valid-border-color);--pico-form-element-active-border-color:var(--pico-form-element-valid-focus-color);--pico-form-element-focus-color:var(--pico-form-element-valid-focus-color)}details.dropdown summary:not([role])[aria-invalid=true]{--pico-form-element-border-color:var(--pico-form-element-invalid-border-color);--pico-form-element-active-border-color:var(--pico-form-element-invalid-focus-color);--pico-form-element-focus-color:var(--pico-form-element-invalid-focus-color)}nav details.dropdown{display:inline;margin:calc(var(--pico-nav-element-spacing-vertical) * -1) 0}nav details.dropdown summary::after{transform:rotate(0) translateX(0)}nav details.dropdown summary:not([role]){height:calc(1rem * var(--pico-line-height) + var(--pico-nav-link-spacing-vertical) * 2);padding:calc(var(--pico-nav-link-spacing-vertical) - var(--pico-border-width) * 2) var(--pico-nav-link-spacing-horizontal)}nav details.dropdown summary:not([role]):focus-visible{box-shadow:0 0 0 var(--pico-outline-width) var(--pico-primary-focus)}details.dropdown summary+ul{display:flex;z-index:99;position:absolute;left:0;flex-direction:column;width:100%;min-width:-moz-fit-content;min-width:fit-content;margin:0;margin-top:var(--pico-outline-width);padding:0;border:var(--pico-border-width) solid var(--pico-dropdown-border-color);border-radius:var(--pico-border-radius);background-color:var(--pico-dropdown-background-color);box-shadow:var(--pico-dropdown-box-shadow);color:var(--pico-dropdown-color);white-space:nowrap;opacity:0;transition:opacity var(--pico-transition),transform 0s ease-in-out 1s}details.dropdown summary+ul[dir=rtl]{right:0;left:auto}details.dropdown summary+ul li{width:100%;margin-bottom:0;padding:calc(var(--pico-form-element-spacing-vertical) * .5) var(--pico-form-element-spacing-horizontal);list-style:none}details.dropdown summary+ul li:first-of-type{margin-top:calc(var(--pico-form-element-spacing-vertical) * .5)}details.dropdown summary+ul li:last-of-type{margin-bottom:calc(var(--pico-form-element-spacing-vertical) * .5)}details.dropdown summary+ul li a{display:block;margin:calc(var(--pico-form-element-spacing-vertical) * -.5) calc(var(--pico-form-element-spacing-horizontal) * -1);padding:calc(var(--pico-form-element-spacing-vertical) * .5) var(--pico-form-element-spacing-horizontal);overflow:hidden;border-radius:0;color:var(--pico-dropdown-color);text-decoration:none;text-overflow:ellipsis}details.dropdown summary+ul li a:active,details.dropdown summary+ul li a:focus,details.dropdown summary+ul li a:focus-visible,details.dropdown summary+ul li a:hover,details.dropdown summary+ul li a[aria-current]:not([aria-current=false]){background-color:var(--pico-dropdown-hover-background-color)}details.dropdown summary+ul li label{width:100%}details.dropdown summary+ul li:has(label):hover{background-color:var(--pico-dropdown-hover-background-color)}details.dropdown[open] summary{margin-bottom:0}details.dropdown[open] summary+ul{transform:scaleY(1);opacity:1;transition:opacity var(--pico-transition),transform 0s ease-in-out 0s}details.dropdown[open] summary::before{display:block;z-index:1;position:fixed;width:100vw;height:100vh;inset:0;background:0 0;content:"";cursor:default}label>details.dropdown{margin-top:calc(var(--pico-spacing) * .25)}[role=group],[role=search]{display:inline-flex;position:relative;width:100%;margin-bottom:var(--pico-spacing);border-radius:var(--pico-border-radius);box-shadow:var(--pico-group-box-shadow,0 0 0 transparent);vertical-align:middle;transition:box-shadow var(--pico-transition)}[role=group] input:not([type=checkbox],[type=radio]),[role=group] select,[role=group]>*,[role=search] input:not([type=checkbox],[type=radio]),[role=search] select,[role=search]>*{position:relative;flex:1 1 auto;margin-bottom:0}[role=group] input:not([type=checkbox],[type=radio]):not(:first-child),[role=group] select:not(:first-child),[role=group]>:not(:first-child),[role=search] input:not([type=checkbox],[type=radio]):not(:first-child),[role=search] select:not(:first-child),[role=search]>:not(:first-child){margin-left:0;border-top-left-radius:0;border-bottom-left-radius:0}[role=group] input:not([type=checkbox],[type=radio]):not(:last-child),[role=group] select:not(:last-child),[role=group]>:not(:last-child),[role=search] input:not([type=checkbox],[type=radio]):not(:last-child),[role=search] select:not(:last-child),[role=search]>:not(:last-child){border-top-right-radius:0;border-bottom-right-radius:0}[role=group] input:not([type=checkbox],[type=radio]):focus,[role=group] select:focus,[role=group]>:focus,[role=search] input:not([type=checkbox],[type=radio]):focus,[role=search] select:focus,[role=search]>:focus{z-index:2}[role=group] [role=button]:not(:first-child),[role=group] [type=button]:not(:first-child),[role=group] [type=reset]:not(:first-child),[role=group] [type=submit]:not(:first-child),[role=group] button:not(:first-child),[role=group] input:not([type=checkbox],[type=radio]):not(:first-child),[role=group] select:not(:first-child),[role=search] [role=button]:not(:first-child),[role=search] [type=button]:not(:first-child),[role=search] [type=reset]:not(:first-child),[role=search] [type=submit]:not(:first-child),[role=search] button:not(:first-child),[role=search] input:not([type=checkbox],[type=radio]):not(:first-child),[role=search] select:not(:first-child){margin-left:calc(var(--pico-border-width) * -1)}[role=group] [role=button],[role=group] [type=button],[role=group] [type=reset],[role=group] [type=submit],[role=group] button,[role=search] [role=button],[role=search] [type=button],[role=search] [type=reset],[role=search] [type=submit],[role=search] button{width:auto}@supports selector(:has(*)){[role=group]:has(button:focus,[type=submit]:focus,[type=button]:focus,[role=button]:focus),[role=search]:has(button:focus,[type=submit]:focus,[type=button]:focus,[role=button]:focus){--pico-group-box-shadow:var(--pico-group-box-shadow-focus-with-button)}[role=group]:has(button:focus,[type=submit]:focus,[type=button]:focus,[role=button]:focus) input:not([type=checkbox],[type=radio]),[role=group]:has(button:focus,[type=submit]:focus,[type=button]:focus,[role=button]:focus) select,[role=search]:has(button:focus,[type=submit]:focus,[type=button]:focus,[role=button]:focus) input:not([type=checkbox],[type=radio]),[role=search]:has(button:focus,[type=submit]:focus,[type=button]:focus,[role=button]:focus) select{border-color:transparent}[role=group]:has(input:not([type=submit],[type=button]):focus,select:focus),[role=search]:has(input:not([type=submit],[type=button]):focus,select:focus){--pico-group-box-shadow:var(--pico-group-box-shadow-focus-with-input)}[role=group]:has(input:not([type=submit],[type=button]):focus,select:focus) [role=button],[role=group]:has(input:not([type=submit],[type=button]):focus,select:focus) [type=button],[role=group]:has(input:not([type=submit],[type=button]):focus,select:focus) [type=submit],[role=group]:has(input:not([type=submit],[type=button]):focus,select:focus) button,[role=search]:has(input:not([type=submit],[type=button]):focus,select:focus) [role=button],[role=search]:has(input:not([type=submit],[type=button]):focus,select:focus) [type=button],[role=search]:has(input:not([type=submit],[type=button]):focus,select:focus) [type=submit],[role=search]:has(input:not([type=submit],[type=button]):focus,select:focus) button{--pico-button-box-shadow:0 0 0 var(--pico-border-width) var(--pico-primary-border);--pico-button-hover-box-shadow:0 0 0 var(--pico-border-width) var(--pico-primary-hover-border)}[role=group] [role=button]:focus,[role=group] [type=button]:focus,[role=group] [type=reset]:focus,[role=group] [type=submit]:focus,[role=group] button:focus,[role=search] [role=button]:focus,[role=search] [type=button]:focus,[role=search] [type=reset]:focus,[role=search] [type=submit]:focus,[role=search] button:focus{box-shadow:none}}[role=search]>:first-child{border-top-left-radius:5rem;border-bottom-left-radius:5rem}[role=search]>:last-child{border-top-right-radius:5rem;border-bottom-right-radius:5rem}[aria-busy=true]:not(input,select,textarea,html){white-space:nowrap}[aria-busy=true]:not(input,select,textarea,html)::before{display:inline-block;width:1em;height:1em;background-image:var(--pico-icon-loading);background-size:1em auto;background-repeat:no-repeat;content:"";vertical-align:-.125em}[aria-busy=true]:not(input,select,textarea,html):not(:empty)::before{margin-inline-end:calc(var(--pico-spacing) * .5)}[aria-busy=true]:not(input,select,textarea,html):empty{text-align:center}[role=button][aria-busy=true],[type=button][aria-busy=true],[type=reset][aria-busy=true],[type=submit][aria-busy=true],a[aria-busy=true],button[aria-busy=true]{pointer-events:none}:root{--pico-scrollbar-width:0px}dialog{display:flex;z-index:999;position:fixed;top:0;right:0;bottom:0;left:0;align-items:center;justify-content:center;width:inherit;min-width:100%;height:inherit;min-height:100%;padding:0;border:0;-webkit-backdrop-filter:var(--pico-modal-overlay-backdrop-filter);backdrop-filter:var(--pico-modal-overlay-backdrop-filter);background-color:var(--pico-modal-overlay-background-color);color:var(--pico-color)}dialog article{width:100%;max-height:calc(100vh - var(--pico-spacing) * 2);margin:var(--pico-spacing);overflow:auto}@media (min-width:576px){dialog article{max-width:510px}}@media (min-width:768px){dialog article{max-width:700px}}dialog article>header>*{margin-bottom:0}dialog article>header .close,dialog article>header :is(a,button)[rel=prev]{margin:0;margin-left:var(--pico-spacing);padding:0;float:right}dialog article>footer{text-align:right}dialog article>footer [role=button],dialog article>footer button{margin-bottom:0}dialog article>footer [role=button]:not(:first-of-type),dialog article>footer button:not(:first-of-type){margin-left:calc(var(--pico-spacing) * .5)}dialog article .close,dialog article :is(a,button)[rel=prev]{display:block;width:1rem;height:1rem;margin-top:calc(var(--pico-spacing) * -1);margin-bottom:var(--pico-spacing);margin-left:auto;border:none;background-image:var(--pico-icon-close);background-position:center;background-size:auto 1rem;background-repeat:no-repeat;background-color:transparent;opacity:.5;transition:opacity var(--pico-transition)}dialog article .close:is([aria-current]:not([aria-current=false]),:hover,:active,:focus),dialog article :is(a,button)[rel=prev]:is([aria-current]:not([aria-current=false]),:hover,:active,:focus){opacity:1}dialog:not([open]),dialog[open=false]{display:none}.modal-is-open{padding-right:var(--pico-scrollbar-width,0);overflow:hidden;pointer-events:none;touch-action:none}.modal-is-open dialog{pointer-events:auto;touch-action:auto}:where(.modal-is-opening,.modal-is-closing) dialog,:where(.modal-is-opening,.modal-is-closing) dialog>article{animation-duration:.2s;animation-timing-function:ease-in-out;animation-fill-mode:both}:where(.modal-is-opening,.modal-is-closing) dialog{animation-duration:.8s;animation-name:modal-overlay}:where(.modal-is-opening,.modal-is-closing) dialog>article{animation-delay:.2s;animation-name:modal}.modal-is-closing dialog,.modal-is-closing dialog>article{animation-delay:0s;animation-direction:reverse}@keyframes modal-overlay{from{-webkit-backdrop-filter:none;backdrop-filter:none;background-color:transparent}}@keyframes modal{from{transform:translateY(-100%);opacity:0}}:where(nav li)::before{float:left;content:"​"}nav,nav ul{display:flex}nav{justify-content:space-between;overflow:visible}nav ol,nav ul{align-items:center;margin-bottom:0;padding:0;list-style:none}nav ol:first-of-type,nav ul:first-of-type{margin-left:calc(var(--pico-nav-element-spacing-horizontal) * -1)}nav ol:last-of-type,nav ul:last-of-type{margin-right:calc(var(--pico-nav-element-spacing-horizontal) * -1)}nav li{display:inline-block;margin:0;padding:var(--pico-nav-element-spacing-vertical) var(--pico-nav-element-spacing-horizontal)}nav li :where(a,[role=link]){display:inline-block;margin:calc(var(--pico-nav-link-spacing-vertical) * -1) calc(var(--pico-nav-link-spacing-horizontal) * -1);padding:var(--pico-nav-link-spacing-vertical) var(--pico-nav-link-spacing-horizontal);border-radius:var(--pico-border-radius)}nav li :where(a,[role=link]):not(:hover){text-decoration:none}nav li [role=button],nav li [type=button],nav li button,nav li input:not([type=checkbox],[type=radio],[type=range],[type=file]),nav li select{height:auto;margin-right:inherit;margin-bottom:0;margin-left:inherit;padding:calc(var(--pico-nav-link-spacing-vertical) - var(--pico-border-width) * 2) var(--pico-nav-link-spacing-horizontal)}nav[aria-label=breadcrumb]{align-items:center;justify-content:start}nav[aria-label=breadcrumb] ul li:not(:first-child){margin-inline-start:var(--pico-nav-link-spacing-horizontal)}nav[aria-label=breadcrumb] ul li a{margin:calc(var(--pico-nav-link-spacing-vertical) * -1) 0;margin-inline-start:calc(var(--pico-nav-link-spacing-horizontal) * -1)}nav[aria-label=breadcrumb] ul li:not(:last-child)::after{display:inline-block;position:absolute;width:calc(var(--pico-nav-link-spacing-horizontal) * 4);margin:0 calc(var(--pico-nav-link-spacing-horizontal) * -1);content:var(--pico-nav-breadcrumb-divider);color:var(--pico-muted-color);text-align:center;text-decoration:none;white-space:nowrap}nav[aria-label=breadcrumb] a[aria-current]:not([aria-current=false]){background-color:transparent;color:inherit;text-decoration:none;pointer-events:none}aside li,aside nav,aside ol,aside ul{display:block}aside li{padding:calc(var(--pico-nav-element-spacing-vertical) * .5) var(--pico-nav-element-spacing-horizontal)}aside li a{display:block}aside li [role=button]{margin:inherit}[dir=rtl] nav[aria-label=breadcrumb] ul li:not(:last-child) ::after{content:"\\"}progress{display:inline-block;vertical-align:baseline}progress{-webkit-appearance:none;-moz-appearance:none;display:inline-block;appearance:none;width:100%;height:.5rem;margin-bottom:calc(var(--pico-spacing) * .5);overflow:hidden;border:0;border-radius:var(--pico-border-radius);background-color:var(--pico-progress-background-color);color:var(--pico-progress-color)}progress::-webkit-progress-bar{border-radius:var(--pico-border-radius);background:0 0}progress[value]::-webkit-progress-value{background-color:var(--pico-progress-color);-webkit-transition:inline-size var(--pico-transition);transition:inline-size var(--pico-transition)}progress::-moz-progress-bar{background-color:var(--pico-progress-color)}@media (prefers-reduced-motion:no-preference){progress:indeterminate{background:var(--pico-progress-background-color) linear-gradient(to right,var(--pico-progress-color) 30%,var(--pico-progress-background-color) 30%) top left/150% 150% no-repeat;animation:progress-indeterminate 1s linear infinite}progress:indeterminate[value]::-webkit-progress-value{background-color:transparent}progress:indeterminate::-moz-progress-bar{background-color:transparent}}@media (prefers-reduced-motion:no-preference){[dir=rtl] progress:indeterminate{animation-direction:reverse}}@keyframes progress-indeterminate{0%{background-position:200% 0}100%{background-position:-200% 0}}[data-tooltip]{position:relative}[data-tooltip]:not(a,button,input){border-bottom:1px dotted;text-decoration:none;cursor:help}[data-tooltip]::after,[data-tooltip]::before,[data-tooltip][data-placement=top]::after,[data-tooltip][data-placement=top]::before{display:block;z-index:99;position:absolute;bottom:100%;left:50%;padding:.25rem .5rem;overflow:hidden;transform:translate(-50%,-.25rem);border-radius:var(--pico-border-radius);background:var(--pico-tooltip-background-color);content:attr(data-tooltip);color:var(--pico-tooltip-color);font-style:normal;font-weight:var(--pico-font-weight);font-size:.875rem;text-decoration:none;text-overflow:ellipsis;white-space:nowrap;opacity:0;pointer-events:none}[data-tooltip]::after,[data-tooltip][data-placement=top]::after{padding:0;transform:translate(-50%,0);border-top:.3rem solid;border-right:.3rem solid transparent;border-left:.3rem solid transparent;border-radius:0;background-color:transparent;content:"";color:var(--pico-tooltip-background-color)}[data-tooltip][data-placement=bottom]::after,[data-tooltip][data-placement=bottom]::before{top:100%;bottom:auto;transform:translate(-50%,.25rem)}[data-tooltip][data-placement=bottom]:after{transform:translate(-50%,-.3rem);border:.3rem solid transparent;border-bottom:.3rem solid}[data-tooltip][data-placement=left]::after,[data-tooltip][data-placement=left]::before{top:50%;right:100%;bottom:auto;left:auto;transform:translate(-.25rem,-50%)}[data-tooltip][data-placement=left]:after{transform:translate(.3rem,-50%);border:.3rem solid transparent;border-left:.3rem solid}[data-tooltip][data-placement=right]::after,[data-tooltip][data-placement=right]::before{top:50%;right:auto;bottom:auto;left:100%;transform:translate(.25rem,-50%)}[data-tooltip][data-placement=right]:after{transform:translate(-.3rem,-50%);border:.3rem solid transparent;border-right:.3rem solid}[data-tooltip]:focus::after,[data-tooltip]:focus::before,[data-tooltip]:hover::after,[data-tooltip]:hover::before{opacity:1}@media (hover:hover) and (pointer:fine){[data-tooltip]:focus::after,[data-tooltip]:focus::before,[data-tooltip]:hover::after,[data-tooltip]:hover::before{--pico-tooltip-slide-to:translate(-50%, -0.25rem);transform:translate(-50%,.75rem);animation-duration:.2s;animation-fill-mode:forwards;animation-name:tooltip-slide;opacity:0}[data-tooltip]:focus::after,[data-tooltip]:hover::after{--pico-tooltip-caret-slide-to:translate(-50%, 0rem);transform:translate(-50%,-.25rem);animation-name:tooltip-caret-slide}[data-tooltip][data-placement=bottom]:focus::after,[data-tooltip][data-placement=bottom]:focus::before,[data-tooltip][data-placement=bottom]:hover::after,[data-tooltip][data-placement=bottom]:hover::before{--pico-tooltip-slide-to:translate(-50%, 0.25rem);transform:translate(-50%,-.75rem);animation-name:tooltip-slide}[data-tooltip][data-placement=bottom]:focus::after,[data-tooltip][data-placement=bottom]:hover::after{--pico-tooltip-caret-slide-to:translate(-50%, -0.3rem);transform:translate(-50%,-.5rem);animation-name:tooltip-caret-slide}[data-tooltip][data-placement=left]:focus::after,[data-tooltip][data-placement=left]:focus::before,[data-tooltip][data-placement=left]:hover::after,[data-tooltip][data-placement=left]:hover::before{--pico-tooltip-slide-to:translate(-0.25rem, -50%);transform:translate(.75rem,-50%);animation-name:tooltip-slide}[data-tooltip][data-placement=left]:focus::after,[data-tooltip][data-placement=left]:hover::after{--pico-tooltip-caret-slide-to:translate(0.3rem, -50%);transform:translate(.05rem,-50%);animation-name:tooltip-caret-slide}[data-tooltip][data-placement=right]:focus::after,[data-tooltip][data-placement=right]:focus::before,[data-tooltip][data-placement=right]:hover::after,[data-tooltip][data-placement=right]:hover::before{--pico-tooltip-slide-to:translate(0.25rem, -50%);transform:translate(-.75rem,-50%);animation-name:tooltip-slide}[data-tooltip][data-placement=right]:focus::after,[data-tooltip][data-placement=right]:hover::after{--pico-tooltip-caret-slide-to:translate(-0.3rem, -50%);transform:translate(-.05rem,-50%);animation-name:tooltip-caret-slide}}@keyframes tooltip-slide{to{transform:var(--pico-tooltip-slide-to);opacity:1}}@keyframes tooltip-caret-slide{50%{opacity:0}to{transform:var(--pico-tooltip-caret-slide-to);opacity:1}}[aria-controls]{cursor:pointer}[aria-disabled=true],[disabled]{cursor:not-allowed}[aria-hidden=false][hidden]{display:initial}[aria-hidden=false][hidden]:not(:focus){clip:rect(0,0,0,0);position:absolute}[tabindex],a,area,button,input,label,select,summary,textarea{-ms-touch-action:manipulation}[dir=rtl]{direction:rtl}@media (prefers-reduced-motion:reduce){:not([aria-busy=true]),:not([aria-busy=true])::after,:not([aria-busy=true])::before{background-attachment:initial!important;animation-duration:1ms!important;animation-delay:-1ms!important;animation-iteration-count:1!important;scroll-behavior:auto!important;transition-delay:0s!important;transition-duration:0s!important}} \ No newline at end of file diff --git a/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs new file mode 100644 index 00000000..d2851eb0 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard/GitDashBoard.hs @@ -0,0 +1,408 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language UndecidableInstances #-} +{-# Language AllowAmbiguousTypes #-} +module Main where + +import HBS2.Git.DashBoard.Prelude + +import HBS2.Net.Messaging.Unix +import HBS2.System.Dir +import HBS2.OrDie +import HBS2.Polling + +import HBS2.Peer.RPC.API.Storage +import HBS2.Peer.RPC.Client.StorageClient + +import HBS2.Git.Web.Assets +import HBS2.Git.DashBoard.State +import HBS2.Git.DashBoard.State.Index +import HBS2.Git.DashBoard.State.Commits +import HBS2.Git.DashBoard.Types +import HBS2.Git.Web.Html.Root + +import HBS2.Peer.CLI.Detect + +import Lucid (renderTextT,HtmlT(..),toHtml) +import Options.Applicative as O +import Data.Either +import Data.Text qualified as Text +import Data.Text.Lazy qualified as LT +import Data.ByteString.Lazy qualified as LBS +import Network.HTTP.Types.Status +import Network.Wai.Middleware.Static hiding ((<|>)) +import Network.Wai.Middleware.StaticEmbedded as E +import Network.Wai.Middleware.RequestLogger +import Web.Scotty.Trans as Scotty +import Control.Monad.Except +import System.Random +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HM +import Control.Concurrent.STM (flushTQueue) +import System.FilePath +import System.Process.Typed +import System.Directory (XdgDirectory(..),getXdgDirectory) +import Data.ByteString.Lazy.Char8 qualified as LBS8 + + +configParser :: DashBoardPerks m => Parser (m ()) +configParser = do + opts <- RunDashBoardOpts <$> optional (strOption + ( long "config" + <> short 'c' + <> metavar "FILEPATH" + <> help "Path to the configuration file" + <> completer (bashCompleter "file") + )) + + cmd <- subparser + ( command "web" (O.info pRunWeb (progDesc "Run the web interface")) + <> command "index" (O.info pRunIndex (progDesc "update index")) + ) + + pure $ cmd opts + + +pRunWeb :: DashBoardPerks m => Parser (RunDashBoardOpts -> m ()) +pRunWeb = pure $ \x -> runDashBoardM x runScotty + +pRunIndex :: DashBoardPerks m => Parser (RunDashBoardOpts -> m ()) +pRunIndex = pure $ \x -> runDashBoardM x do + updateIndex + +{- HLINT ignore "Eta reduce" -} +{- HLINT ignore "Functor law" -} + +getRPC :: Monad m => HasConf m => m (Maybe FilePath) +getRPC = pure Nothing + + +runDashBoardM :: DashBoardPerks m => RunDashBoardOpts -> DashBoardM m a -> m a +runDashBoardM cli m = do + + + let hbs2_git_dashboard = "hbs2-git-dashboard" + xdgConf <- liftIO $ getXdgDirectory XdgConfig hbs2_git_dashboard + xdgData <- liftIO $ getXdgDirectory XdgData hbs2_git_dashboard + + let cliConfPath = cli & configPath + + let confPath = fromMaybe xdgConf cliConfPath + let confFile = confPath "config" + + let dbFile = xdgData "state.db" + + when (isNothing cliConfPath) do + touch confFile + + conf <- runExceptT (liftIO $ readFile confFile) + <&> fromRight mempty + <&> parseTop + <&> fromRight mempty + + liftIO $ print (pretty conf) + + -- FIXME: unix-socket-from-config + soname <- detectRPC `orDie` "hbs2-peer rpc not found" + + let errorPrefix = toStderr . logPrefix "[error] " + let warnPrefix = toStderr . logPrefix "[warn] " + let noticePrefix = toStderr . logPrefix "" + let debugPrefix = toStderr . logPrefix "[debug] " + + setLogging @INFO defLog + setLogging @ERROR errorPrefix + setLogging @DEBUG debugPrefix + setLogging @WARN warnPrefix + setLogging @NOTICE noticePrefix + + flip runContT pure do + + + client <- liftIO $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname) + >>= orThrowUser ("can't connect to" <+> pretty soname) + + void $ ContT $ withAsync $ runMessagingUnix client + + peerAPI <- makeServiceCaller @PeerAPI (fromString soname) + refLogAPI <- makeServiceCaller @RefLogAPI (fromString soname) + refChanAPI <- makeServiceCaller @RefChanAPI (fromString soname) + storageAPI <- makeServiceCaller @StorageAPI (fromString soname) + lwwAPI <- makeServiceCaller @LWWRefAPI (fromString soname) + + let sto = AnyStorage (StorageClient storageAPI) + + let endpoints = [ Endpoint @UNIX peerAPI + , Endpoint @UNIX refLogAPI + , Endpoint @UNIX refChanAPI + , Endpoint @UNIX lwwAPI + , Endpoint @UNIX storageAPI + ] + + void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client + + env <- newDashBoardEnv + conf + dbFile + peerAPI + refLogAPI + refChanAPI + lwwAPI + sto + + void $ ContT $ withAsync do + q <- withDashBoardEnv env $ asks _pipeline + forever do + liftIO (atomically $ readTQueue q) & liftIO . join + + lift $ withDashBoardEnv env (withState evolveDB >> m) + `finally` do + setLoggingOff @DEBUG + setLoggingOff @INFO + setLoggingOff @ERROR + setLoggingOff @WARN + setLoggingOff @NOTICE + + +data WebOptions = + WebOptions + { _assetsOverride :: Maybe FilePath + } + +orFall :: m r -> Maybe a -> ContT r m a +orFall a mb = ContT $ maybe1 mb a + +renderHtml :: forall m a . MonadIO m => HtmlT (ActionT m) a -> ActionT m () +renderHtml m = renderTextT m >>= html + +runDashboardWeb :: WebOptions -> ScottyT (DashBoardM IO) () +runDashboardWeb wo = do + middleware logStdout + + let assets = _assetsOverride wo + + case assets of + Nothing -> do + middleware (E.static assetsDir) + Just f -> do + middleware $ staticPolicy (noDots >-> addBase f) + + get (routePattern RepoListPage) do + renderHtml dashboardRootPage + + + get "/:lww" do + lww <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic) + >>= orThrow (itemNotFound "repository key") + + redirect (LT.fromStrict $ toURL (RepoPage (CommitsTab Nothing) lww)) + + get (routePattern (RepoPage "tab" "lww")) do + lww <- captureParam @String "lww" <&> fromStringMay + >>= orThrow (itemNotFound "repository key") + + tab <- captureParam @String "tab" + <&> fromStringMay + <&> fromMaybe (CommitsTab Nothing) + + qp <- queryParams + + renderHtml (repoPage tab lww qp) + + get (routePattern (RepoManifest "lww")) do + lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic) + flip runContT pure do + lww <- lwws' & orFall (status status404) + + item <- lift (selectRepoList ( mempty + & set repoListByLww (Just lww) + & set repoListLimit (Just 1)) + ) + <&> listToMaybe + >>= orFall (status status404) + + lift $ html =<< renderTextT (thisRepoManifest item) + + + get (routePattern (RepoRefs "lww")) do + lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic) + + -- setHeader "HX-Push-Url" [qc|/{show $ pretty lwws'}|] + + flip runContT pure do + lww <- lwws' & orFall (status status404) + lift $ renderHtml (repoRefs lww) + + get (routePattern (RepoTree "lww" "co" "hash")) do + lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic) + hash' <- captureParam @String "hash" <&> fromStringMay @GitHash + co' <- captureParam @String "co" <&> fromStringMay @GitHash + + flip runContT pure do + lww <- lwws' & orFall (status status404) + hash <- hash' & orFall (status status404) + co <- co' & orFall (status status404) + lift $ renderHtml (repoTree lww co hash) + + get (routePattern (RepoBlob "lww" "co" "hash" "blob")) do + lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic) + hash' <- captureParam @String "hash" <&> fromStringMay @GitHash + co' <- captureParam @String "co" <&> fromStringMay @GitHash + blob' <- captureParam @String "blob" <&> fromStringMay @GitHash + + flip runContT pure do + lww <- lwws' & orFall (status status404) + hash <- hash' & orFall (status status404) + co <- co' & orFall (status status404) + blobHash <- blob' & orFall (status status404) + + blobInfo <- lift (selectBlobInfo (BlobHash blobHash)) + >>= orFall (status status404) + + lift $ renderHtml (repoBlob lww (TreeCommit co) (TreeTree hash) blobInfo) + + get (routePattern (RepoSomeBlob "lww" "syntax" "blob")) do + lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic) + syn <- captureParamMaybe @Text "syntax" <&> fromMaybe "default" + blob' <- captureParam @String "blob" <&> fromStringMay @GitHash + + flip runContT pure do + lww <- lwws' & orFall (status status404) + blob <- blob' & orFall (status status404) + lift $ renderHtml (repoSomeBlob lww syn blob) + + get (routePattern (RepoCommitDefault "lww" "hash")) (commitRoute RepoCommitSummary) + get (routePattern (RepoCommitSummaryQ "lww" "hash")) (commitRoute RepoCommitSummary) + get (routePattern (RepoCommitPatchQ "lww" "hash")) (commitRoute RepoCommitPatch) + + get (routePattern (RepoForksHtmx "lww")) do + lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic) + flip runContT pure do + lww <- lwws' & orFall (status status404) + lift $ renderHtml (repoForks lww) + -- lift $ renderHtml (toHtml $ show $ pretty lww) + + get (routePattern (RepoCommits "lww")) do + lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic) + + let pred = mempty & set commitPredOffset 0 + & set commitPredLimit 100 + + flip runContT pure do + lww <- lwws' & orFall (status status404) + lift $ renderHtml (repoCommits lww (Right pred)) + + get (routePattern (RepoCommitsQ "lww" "off" "lim")) do + lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey 'HBS2Basic) + off <- captureParam @Int "off" + lim <- captureParam @Int "lim" + + let pred = mempty & set commitPredOffset off + & set commitPredLimit lim + + flip runContT pure do + + lww <- lwws' & orFall (status status404) + + -- FIXME: this + referrer <- lift (Scotty.header "Referer") + >>= orFall (redirect $ LT.fromStrict $ toURL (RepoPage (CommitsTab Nothing) lww)) + + lift $ renderHtml (repoCommits lww (Left pred)) + + -- "pages" + + where + commitRoute style = do + lwws' <- captureParam @String "lww" <&> fromStringMay @(LWWRefKey HBS2Basic) + co <- captureParam @String "hash" <&> fromStringMay @GitHash + + referrer <- Scotty.header "Referer" + debug $ yellow "COMMIT-REFERRER" <+> pretty referrer + + flip runContT pure do + lww <- lwws' & orFall (status status404) + hash <- co & orFall (status status404) + lift $ renderHtml (repoCommit style lww hash) + + +runScotty :: DashBoardPerks m => DashBoardM m () +runScotty = do + pno <- cfgValue @HttpPortOpt @(Maybe Int) <&> fromMaybe 8090 + wo <- cfgValue @DevelopAssetsOpt @(Maybe FilePath) <&> WebOptions + + env <- ask + + flip runContT pure do + + void $ ContT $ withAsync updateIndexPeriodially + + scottyT pno (withDashBoardEnv env) (runDashboardWeb wo) + +updateIndexPeriodially :: DashBoardPerks m => DashBoardM m () +updateIndexPeriodially = do + + cached <- newTVarIO ( mempty :: HashMap MyRefLogKey HashRef ) + + changes <- newTQueueIO + + api <- asks _refLogAPI + + env <- ask + + let rlogs = selectRefLogs <&> fmap (over _1 (coerce @_ @MyRefLogKey)) . fmap (, 30) + + flip runContT pure do + + void $ ContT $ withAsync $ forever do + rs <- atomically $ peekTQueue changes >> flushTQueue changes + addJob (withDashBoardEnv env updateIndex) + pause @'Seconds 30 + + lift do + polling (Polling 1 10) rlogs $ \r -> do + + debug $ yellow "POLL REFLOG" <+> pretty r + + rv <- callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) api (coerce r) + <&> join + + old <- readTVarIO cached <&> HM.lookup r + + for_ rv $ \x -> do + + when (rv /= old) do + debug $ yellow "REFLOG UPDATED" <+> pretty r <+> pretty x + atomically $ modifyTVar cached (HM.insert r x) + atomically $ writeTQueue changes r + + flip runContT pure $ callCC $ \exit -> do + + lww <- lift (selectLwwByRefLog (RepoRefLog r)) + >>= maybe (exit ()) pure + + dir <- lift $ repoDataPath (coerce lww) + + here <- doesDirectoryExist dir + + unless here do + debug $ red "INIT DATA DIR" <+> pretty dir + mkdir dir + void $ runProcess $ shell [qc|git --git-dir {dir} init --bare|] + + let cmd = [qc|git --git-dir {dir} hbs2 import {show $ pretty lww}|] + debug $ red "SYNC" <+> pretty cmd + void $ runProcess $ shell cmd + + lift $ buildCommitTreeIndex (coerce lww) + + +main :: IO () +main = do + execParser opts & join + where + opts = O.info (configParser <**> helper) + ( fullDesc + <> progDesc "hbs2-git-dashboard" + <> O.header "hbs2-git-dashboard" ) + + diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Prelude.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Prelude.hs new file mode 100644 index 00000000..f845d206 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Prelude.hs @@ -0,0 +1,62 @@ +module HBS2.Git.DashBoard.Prelude + ( module HBS2.Git.DashBoard.Prelude + , module HBS2.Prelude.Plated + , module HBS2.Data.Types.Refs + , module HBS2.Base58 + , module HBS2.Merkle + , module HBS2.Net.Proto.Service + , module HBS2.Storage + , module API + , module Config + , module Logger + , module Maybe + , module Reader + , module Coerce + , module TransCont + , module TransMaybe + , module Lens.Micro.Platform + , module UnliftIO + , module Codec.Serialise + , GitRef(..), GitHash(..), GitObjectType(..) + , qc, q + ) where + +import HBS2.Data.Types.Refs +import HBS2.Base58 +import HBS2.Net.Proto.Service hiding (encode,decode) +import HBS2.Prelude.Plated +import HBS2.Storage +import HBS2.Merkle + +import HBS2.System.Logger.Simple.ANSI as Logger +import HBS2.Misc.PrettyStuff as Logger + + +import HBS2.Peer.RPC.API.RefChan as API +import HBS2.Peer.RPC.API.RefLog as API +import HBS2.Peer.RPC.API.Peer as API +import HBS2.Peer.RPC.API.LWWRef as API + +import HBS2.Peer.Proto.RefLog as API +import HBS2.Peer.Proto.LWWRef as API +import HBS2.Peer.Proto.RefChan.Types as API +import HBS2.Peer.Proto.RefChan.RefChanUpdate as API + +import HBS2.Git.Local + +import Data.Config.Suckless as Config + +import Text.InterpolatedString.Perl6 (qc,q) + +import Data.Maybe as Maybe +import Control.Monad.Reader as Reader +import Data.Coerce as Coerce +import Control.Monad.Trans.Cont as TransCont +import Control.Monad.Trans.Maybe as TransMaybe + +import Lens.Micro.Platform hiding (at) + +import UnliftIO + +import Codec.Serialise + diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs new file mode 100644 index 00000000..b72b30a7 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs @@ -0,0 +1,874 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +module HBS2.Git.DashBoard.State + ( module HBS2.Git.DashBoard.State + , Only(..) + , transactional + ) where + +import HBS2.Git.DashBoard.Prelude +import HBS2.Git.DashBoard.Types + +import HBS2.Hash + +import HBS2.Git.Data.RepoHead +import HBS2.Git.Data.Tx.Git +import HBS2.Git.Local +import HBS2.Git.Local.CLI + +import DBPipe.SQLite hiding (insert) +import DBPipe.SQLite qualified as S +import DBPipe.SQLite.Generic as G + + +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.ByteString.Lazy (ByteString) +import Lucid.Base +import Data.Text qualified as Text +import Data.Word +import Data.Either +import Data.List qualified as List +import Data.Map qualified as Map +import Data.Map (Map) +import System.FilePath + +import Skylighting.Core qualified as Sky +import Skylighting qualified as Sky + +data RepoListPred = + RepoListPred + { _repoListByLww :: Maybe (LWWRefKey 'HBS2Basic) + , _repoListLimit :: Maybe Int + } + +makeLenses 'RepoListPred + +instance Semigroup RepoListPred where + (<>) _ b = mempty & set repoListByLww (view repoListByLww b) + & set repoListLimit (view repoListLimit b) + +instance Monoid RepoListPred where + mempty = RepoListPred Nothing Nothing + +type MyRefChan = RefChanId L4Proto +type MyRefLogKey = RefLogKey 'HBS2Basic + +evolveDB :: DashBoardPerks m => DBPipeM m () +evolveDB = do + + ddl [qc| + create table if not exists repo + ( lww text not null + , primary key (lww) + ) + |] + + + ddl [qc| + create table if not exists repochannel + ( lww text not null + , channel text not null + , primary key (lww,channel) + ) + |] + + ddl [qc| + create table if not exists brief + ( lww text not null + , brief text not null + , primary key (lww) + ) + |] + + ddl [qc| + create table if not exists name + ( lww text not null + , name text not null + , primary key (lww) + ) + |] + + + createRepoHeadTable + createRepoListView + + ddl [qc| + create table if not exists processed + ( hash text not null + , primary key (hash) + ) + |] + + createRepoTreeIndexTable + createRepoBlobIndexTable + createRepoCommitTable + createForksTable + + +instance ToField GitHash where + toField x = toField $ show $ pretty x + +instance FromField GitHash where + fromField = fmap fromString . fromField @String + +instance ToField HashRef where + toField x = toField $ show $ pretty x + +instance FromField HashRef where + fromField = fmap (fromString @HashRef) . fromField @String + +instance Pretty (AsBase58 (PubKey 'Sign s)) => ToField (LWWRefKey s) where + toField x = toField $ show $ pretty (AsBase58 x) + +instance Pretty (AsBase58 (PubKey 'Sign s)) => ToField (RefLogKey s) where + toField x = toField $ show $ pretty (AsBase58 x) + +instance IsRefPubKey s => FromField (RefLogKey s) where + fromField = fmap (fromString @(RefLogKey s)) . fromField @String + +instance FromField (LWWRefKey HBS2Basic) where + fromField = fmap fromString . fromField @String + + +newtype TxHash = TxHash HashRef + deriving stock (Generic) + deriving newtype (ToField) + + +newtype RepoHeadTx = RepoHeadTx HashRef + deriving stock (Generic) + deriving newtype (ToField,FromField,Pretty) + +newtype RepoName = RepoName Text + deriving stock (Eq,Show,Generic) + deriving newtype (ToField,FromField,ToHtml,IsString) + +newtype RepoBrief = RepoBrief Text + deriving stock (Generic) + deriving newtype (ToField,FromField) + + +newtype RepoForks = RepoForks Int + deriving stock (Generic,Data) + deriving newtype (ToField,FromField,Show,Pretty,Num,Eq,Ord) + +newtype RepoCommitsNum = RepoCommitsNum Int + deriving stock (Generic,Data) + deriving newtype (ToField,FromField,Show,Pretty) + +newtype RepoLww = RepoLww (LWWRefKey 'HBS2Basic) + deriving stock (Generic) + deriving newtype (ToField,FromField,Pretty) + +newtype RepoLwwSeq = RepoLwwSeq Integer + deriving stock (Generic) + deriving newtype (ToField,FromField,Pretty) + +newtype RepoChannel = RepoChannel MyRefChan + + +newtype RepoHeadRef = RepoHeadRef HashRef + deriving stock (Generic) + deriving newtype (ToField,FromField) + + +newtype RepoHeadSeq = RepoHeadSeq Word64 + deriving stock (Generic) + deriving newtype (ToField,FromField,Integral,Real,Ord,Eq,Num,Enum) + +newtype RepoRefLog = RepoRefLog (RefLogKey 'HBS2Basic) + deriving stock (Generic) + deriving newtype (ToField,FromField,Pretty) + +newtype RepoHeadGK0 = RepoHeadGK0 (Maybe HashRef) + deriving stock (Generic) + deriving newtype (ToField,FromField) + +instance ToField RepoChannel where + toField (RepoChannel x) = toField $ show $ pretty (AsBase58 x) + +data TxProcessedTable +data RepoTable +data RepoChannelTable +data RepoNameTable +data RepoBriefTable +data RepoCommitTable + +instance HasTableName RepoChannelTable where + tableName = "repochannel" + +instance HasTableName RepoTable where + tableName = "repo" + +instance HasTableName RepoNameTable where + tableName = "name" + +instance HasTableName RepoBriefTable where + tableName = "brief" + +instance HasTableName TxProcessedTable where + tableName = "processed" + +instance HasTableName RepoCommitTable where + tableName = "repocommit" + +instance HasColumnName TxHash where + columnName = "hash" + +instance HasColumnName RepoLww where + columnName = "lww" + +instance HasColumnName RepoLwwSeq where + columnName = "lwwseq" + +instance HasColumnName RepoName where + columnName = "name" + +instance HasColumnName RepoBrief where + columnName = "brief" + +instance HasColumnName RepoForks where + columnName = "forks" + +instance HasColumnName RepoCommitsNum where + columnName = "kommits" + +instance HasColumnName RepoRefLog where + columnName = "reflog" + +instance HasColumnName RepoChannel where + columnName = "channel" + +instance HasColumnName RepoCommit where + columnName = "kommit" + +instance HasPrimaryKey TxProcessedTable where + primaryKey = [G.columnName @TxHash] + +instance HasPrimaryKey RepoChannelTable where + primaryKey = [G.columnName @RepoLww, G.columnName @RepoChannel] + +instance HasPrimaryKey RepoTable where + primaryKey = [G.columnName @RepoLww] + +instance HasPrimaryKey RepoNameTable where + primaryKey = [G.columnName @RepoLww] + +instance HasPrimaryKey RepoBriefTable where + primaryKey = [G.columnName @RepoLww] + +instance HasPrimaryKey RepoCommitTable where + primaryKey = [G.columnName @RepoLww, G.columnName @RepoCommit] + +pattern PRefChan :: MyRefChan -> Syntax C +pattern PRefChan s <- ListVal [ SymbolVal "refchan" , asRefChan -> Just s ] + +asRefChan :: Syntax C -> Maybe MyRefChan +asRefChan = \case + LitStrVal s -> fromStringMay @MyRefChan (Text.unpack s) + _ -> Nothing + +getIndexEntries :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m [MyRefChan] +getIndexEntries = do + conf <- getConf + pure [ s | ListVal [ SymbolVal "index", PRefChan s] <- conf ] + + +data NiceTS = NiceTS + +data RepoListItem = + RepoListItem + { rlRepoLww :: RepoLww + , rlRepoSeq :: RepoHeadSeq + , rlRepoHead :: RepoHeadRef + , rlRepoTx :: RepoHeadTx + , rlRepoName :: RepoName + , rlRepoBrief :: RepoBrief + , rlRepoGK0 :: RepoHeadGK0 + , rlRepoForks :: RepoForks + , rlRepoCommits :: RepoCommitsNum + } + deriving stock (Generic) + +-- deriving instance Data RepoListItem via Generically RepoListItem + +rlRepoLwwAsText :: SimpleGetter RepoListItem Text +rlRepoLwwAsText = + to \RepoListItem{..} -> do + Text.pack $ show $ pretty $ rlRepoLww + +instance FromRow RepoListItem + + + +selectRepoList :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListPred -> m [RepoListItem] +selectRepoList pred = fmap fixName <$> withState do + + let onLww = maybe1 (view repoListByLww pred) mempty $ \w -> [("r.lww = ?", w)] + let claus = onLww + + let where_ | List.null claus = "true" + | otherwise = Text.intercalate " and " (fmap fst claus) + + let limit_ = case view repoListLimit pred of + Nothing -> mempty + Just n -> show $ "limit" <+> pretty n + + let params = fmap snd claus + + let sql = [qc| + select r.lww + , r.seq + , r.repohead + , r.tx + , r.name + , r.brief + , r.gk0 + , r.forks + , r.kommits + from repolistview r + where {where_} + {limit_} + |] + + debug $ yellow "selectRepoList" <+> pretty sql + + select @RepoListItem sql params + where + fixName x@RepoListItem{..} | Text.length (coerce rlRepoName) < 3 = x { rlRepoName = fixed } + | otherwise = x + where fixed = Text.pack (show $ pretty (coerce @_ @(LWWRefKey 'HBS2Basic) rlRepoLww) ) & RepoName + +createRepoListView :: DashBoardPerks m => DBPipeM m () +createRepoListView = do + ddl [qc| +drop view if exists repolistview + |] + + ddl [qc| +create view repolistview as + +with repolist as ( + select + r.lww, + 0 as lwwseq, + null as reflog, + 0 as seq, + null as repohead, + null as tx, + coalesce(n.name, r.lww) as name, + coalesce(b.brief, '') as brief, + null as gk0 + from repo r + left join name n on r.lww = n.lww + left join brief b on r.lww = b.lww + union + select + lww, + lwwseq, + reflog, + seq, + repohead, + tx, + name, + brief, + gk0 + from repohead +), +ranked_repos as ( + select + lww, + lwwseq, + reflog, + seq, + repohead, + tx, + name, + brief, + gk0, + row_number() over (partition by lww order by lwwseq desc, seq desc) as rn + from repolist + order by seq desc +) + +select lww + , lwwseq + , reflog + , seq + , repohead + , tx + , name + , brief + , gk0 + , (select count(1) from fork f where f.a = ranked_repos.lww) as forks + , (select count(distinct(kommit)) from repocommit r where r.lww = ranked_repos.lww) as kommits +from ranked_repos +where rn = 1; + |] + + +createForksTable :: DashBoardPerks m => DBPipeM m () +createForksTable = do + ddl [qc| + create table if not exists fork + ( a text not null + , b text not null + , primary key (a,b) + ) + |] + +createRepoHeadTable :: DashBoardPerks m => DBPipeM m () +createRepoHeadTable = do + ddl [qc| + create table if not exists repohead + ( lww text not null + , lwwseq integer not null + , reflog text not null + , repohead text not null + , tx text not null + , seq integer not null + , gk0 text null + , name text + , brief text + , primary key (lww,lwwseq,repohead) + ) + |] + +data RepoHeadTable + +instance HasTableName RepoHeadTable where + tableName = "repohead" + +instance HasPrimaryKey RepoHeadTable where + primaryKey = ["lww", "lwwseq", "repohead"] + +instance HasColumnName RepoHeadRef where + columnName = "repohead" + +instance HasColumnName RepoHeadSeq where + columnName = "seq" + +instance HasColumnName RepoHeadGK0 where + columnName = "gk0" + +instance HasColumnName RepoHeadTx where + columnName = "tx" + + +insertRepoHead :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> RepoLwwSeq + -> RepoRefLog + -> RepoHeadTx + -> RepoHeadRef + -> RepoHead + -> DBPipeM m () +insertRepoHead lww lwwseq rlog tx rf rh = do + insert @RepoHeadTable $ onConflictIgnore @RepoHeadTable + ( RepoLww lww + , lwwseq + , rlog + , rf + , tx + , RepoHeadSeq (_repoHeadTime rh) + , RepoHeadGK0 (_repoHeadGK0 rh) + , RepoName (_repoHeadName rh) + , RepoBrief (_repoHeadBrief rh) + ) + + pure () + +-- FIXME: what-if-two-repo-shares-one-reflog? +selectLwwByRefLog :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoRefLog -> m (Maybe RepoLww) +selectLwwByRefLog rlog = withState do + select [qc|select lww from repolistview where reflog = ?|] (Only rlog) + <&> listToMaybe . fmap fromOnly + +selectRefLogs :: (DashBoardPerks m, MonadReader DashBoardEnv m) => m [RepoRefLog] +selectRefLogs = withState do + select_ [qc|select distinct(reflog) from repolistview|] <&> fmap fromOnly + +-- TODO: too-much-data-in-tree-index +-- для навигации по дереву, если нам не нужно +-- выходить на верхний уровень -- нам не нужно +-- знать коммит для каждого дерева. таким образом, +-- если убрать коммит -- вариативность будет на порядок +-- меньше, но это повлечёт последствия для навигации. +-- сейчас уже 200K записей на 4K коммитов, нехорошо. +-- ОЧЕНЬ НЕХОРОШО. Однако, если удалить kommit из +-- таблицы tree, там начинает выполняться большой рекурсивный +-- запрос. С колонкой kommit мы сокращаем там выборку. +-- В принципе, можно туда ввести ключ lww, тогда выборка +-- будет ограничиваться только всеми деревьями проекта. +-- С этим полем в таблице будет гораздо меньше ключей, чем +-- с каждым коммитом. +createRepoTreeIndexTable :: (DashBoardPerks m) => DBPipeM m () +createRepoTreeIndexTable = do + ddl [qc| + create table if not exists tree + ( parent text not null + , tree text not null + , kommit text not null + , level int not null + , path text not null + , primary key (parent,tree,kommit) + ) + |] + + +createRepoCommitTable :: (DashBoardPerks m) => DBPipeM m () +createRepoCommitTable = do + ddl [qc| + create table if not exists repocommit + ( lww text not null + , kommit text not null + , primary key (lww,kommit) + ) + |] + + +isProcessed :: (DashBoardPerks m) => HashRef -> DBPipeM m Bool +isProcessed href = do + select @(Only Int) [qc|select 1 from processed where hash = ? limit 1|] (Only href) + <&> not . List.null + +insertProcessed :: (DashBoardPerks m) => HashRef -> DBPipeM m () +insertProcessed href = do + S.insert [qc| + insert into processed (hash) + values(?) + on conflict(hash) do nothing + |] (Only href) + + +newtype RepoCommit = RepoCommit GitHash + deriving newtype (FromField,ToField,Pretty) + +newtype TreeCommit = TreeCommit GitHash + deriving newtype (FromField,ToField,Pretty) + +newtype TreeParent = TreeParent GitHash + deriving newtype (FromField,ToField,Pretty) + + +newtype TreeTree = TreeTree GitHash + deriving newtype (FromField,ToField,Pretty) + +newtype TreeLevel = TreeLevel Int + deriving newtype (FromField,ToField,Pretty,Num,Enum,Real,Integral,Ord,Eq) + +newtype TreePath = TreePath FilePath + deriving newtype (FromField,ToField,Pretty) + +insertTree :: (DashBoardPerks m) + => (TreeCommit,TreeParent,TreeTree,TreeLevel,TreePath) + -> DBPipeM m () +insertTree (commit,parent,tree,level,path) = do + S.insert [qc| + insert into tree (parent,tree,kommit,level,path) + values (?,?,?,?,?) + on conflict (parent,tree,kommit) + do nothing + |] (parent,tree,commit,level,path) + +selectParentTree :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => TreeCommit + -> TreeTree + -> m (Maybe TreeParent) +selectParentTree co me = withState do + select [qc|select parent from tree where tree = ? and kommit = ?|] (me,co) + <&> listToMaybe . fmap fromOnly + +{- HLINT ignore "Functor law" -} + + + +createRepoBlobIndexTable :: (DashBoardPerks m) => DBPipeM m () +createRepoBlobIndexTable = do + ddl [qc| + create table if not exists blob + ( hash text not null + , name text not null + , size int not null + , syntax text + , primary key (hash) + ) + |] + + +newtype BlobSyn = BlobSyn (Maybe Text) + deriving newtype (FromField,ToField,Pretty,Eq,Ord) + +newtype BlobName = BlobName FilePath + deriving newtype (FromField,ToField,Pretty) + +newtype BlobHash = BlobHash GitHash + deriving newtype (FromField,ToField,Pretty) + +newtype BlobSize = BlobSize Integer + deriving newtype (FromField,ToField,Pretty,Num,Enum,Eq,Ord) + + +data BlobInfo = + BlobInfo + { blobHash :: BlobHash + , blobName :: BlobName + , blobSize :: BlobSize + , blobSyn :: BlobSyn + } + deriving stock (Generic) + +instance FromRow BlobInfo + +type TreeLocator = [(TreeParent, TreeTree, TreeLevel, TreePath)] + +insertBlob :: DashBoardPerks m + => (BlobHash, BlobName, BlobSize, BlobSyn) + -> DBPipeM m () +insertBlob (h,n,size,syn) = do + S.insert [qc| + insert into blob (hash,name,size,syntax) + values (?,?,?,?) + on conflict (hash) + do update set name = excluded.name + , size = excluded.size + , syntax = excluded.syntax + |] (h,n,size,syn) + + +selectBlobInfo :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => BlobHash + -> m (Maybe BlobInfo) +selectBlobInfo what = withState do + select [qc| + select hash,name,size,syntax + from blob + where hash = ? + |] (Only what) + <&> listToMaybe + +selectTreeLocator :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => TreeCommit + -> TreeTree + -> m TreeLocator + +selectTreeLocator kommit tree = withState do + + let sql = [qc| +WITH RECURSIVE ParentTree AS ( + SELECT parent, tree, kommit, level, path + FROM tree + WHERE tree = ? AND kommit = ? + + UNION ALL + + SELECT t.parent, t.tree, t.kommit, t.level, t.path + FROM tree t + JOIN ParentTree pt ON t.tree = pt.parent AND t.kommit = pt.kommit + WHERE t.kommit = ? +) +SELECT parent, tree, level, path FROM ParentTree +ORDER BY level +|] + + select sql (tree, kommit, kommit) + + +pattern TreeHash :: GitHash -> LBS8.ByteString +pattern TreeHash hash <- (LBS8.words -> (_ : (fromStringMay . LBS8.unpack -> Just hash) : _)) + +readBlob :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> BlobHash + -> m ByteString + +readBlob repo hash = do + + dir <- repoDataPath repo + + gitRunCommand [qc|git --git-dir {dir} cat-file blob {pretty hash}|] + <&> fromRight mempty + + +buildCommitTreeIndex :: ( MonadUnliftIO m + , DashBoardPerks m + , MonadReader DashBoardEnv m + ) + => LWWRefKey 'HBS2Basic + -> m () +buildCommitTreeIndex lww = do + + commits <- listCommits + env <- ask + + for_ commits $ \co -> void $ runMaybeT do + checkCommitProcessed co >>= guard . not + updateRepoData env co + + updateForks + + where + + syntaxMap = Sky.defaultSyntaxMap + + updateForks = withState do + + S.insert [qc| + insert into fork (a,b) + select distinct r0.lww + , r1.lww + from repocommit r0 join repocommit r1 on r0.kommit = r1.kommit and r0.lww <> r1.lww + where r0.lww = ? + on conflict (a,b) do nothing + |] (Only lww) + + pure () + + updateRepoData env co = do + + root <- getRootTree co >>= toMPlus + (trees, blobs) <- getTreeRecursive co + + lift $ addJob $ liftIO $ withDashBoardEnv env do + + withState $ transactional do + + insert @RepoCommitTable $ + onConflictIgnore @RepoCommitTable (RepoLww lww, RepoCommit co) + + for_ blobs $ \(fn, (hash, size, syn)) -> do + insertBlob (BlobHash hash, BlobName fn, BlobSize size, BlobSyn syn) + + for_ (Map.toList trees) $ \(t,h0) -> do + + case t of + [x] -> insertTree (TreeCommit co,TreeParent root,TreeTree h0,1,TreePath x) + _ -> pure () + + let child = tailSafe t + debug $ red "TREE-REL:" <+> pretty t + let parent = Map.lookup child trees + + for_ parent $ \p -> do + debug $ red "FOUND SHIT:" <+> pretty (h0,p) + insertTree ( TreeCommit co + , TreeParent p + , TreeTree h0 + , TreeLevel (length t) + , TreePath (headDef "" t) + ) + + + getTreeRecursive co = lift do + dir <- repoDataPath lww + items <- gitRunCommand [qc|git --git-dir {dir} ls-tree -l -r -t {pretty co}|] + <&> fromRight mempty + <&> fmap LBS8.words . LBS8.lines + <&> mapMaybe \case + [_,"tree",h,_,n] -> + (reverse $ splitDirectories $ LBS8.unpack n,) <$> fmap Right (fromStringMay @GitHash (LBS8.unpack h)) + + [_,"blob",h,size,n] -> do + let fn = headMay (reverse $ splitDirectories $ LBS8.unpack n) + <&> List.singleton + + let ha = fromStringMay @GitHash (LBS8.unpack h) + let sz = readMay @Integer (LBS8.unpack size) + + let syn = Sky.syntaxesByFilename syntaxMap (LBS8.unpack n) + & headMay + <&> Text.toLower . Sky.sName + + (,) <$> fn <*> fmap Left ( (,,) <$> ha <*> sz <*> pure syn ) + + _ -> Nothing + + let trees = Map.fromList [ (k,v) | (k,Right v) <- items ] + let blobs = [ (k,v) | ([k],Left v) <- items ] + pure (trees, blobs) + + getRootTree co = lift do + dir <- repoDataPath lww + let cmd = [qc|git --git-dir {dir} cat-file commit {pretty co}|] + + gitRunCommand cmd + <&> fromRight mempty + <&> LBS8.lines + <&> \case + (TreeHash ha : _) -> Just ha + _ -> Nothing + + checkCommitProcessed co = lift $ withState do + select [qc|select 1 from repocommit where lww = ? and kommit = ?|] (lww, co) + <&> listToMaybe @(Only Int) <&> isJust + + listCommits = do + dir <- repoDataPath lww + gitRunCommand [qc|git --git-dir {dir} rev-list --all|] + <&> fromRight mempty + <&> mapMaybe (headMay . LBS8.words) . LBS8.lines + <&> mapMaybe (fromStringMay @GitHash . LBS8.unpack) + + -- FIXME: check-names-with-spaces + +selectRepoForks :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> m [RepoListItem] +selectRepoForks lww = withState do + let cols = columnListPart (AllColumns @RepoListItem) & fromSQL + let sql = [qc| select {cols} + from repolistview v join fork f on v.lww = f.b + where f.a = ? + |] + + debug $ yellow "selectRepoForks" <+> pretty sql <+> pretty lww + select sql (Only (RepoLww lww)) + +gitShowTree :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> GitHash + -> m [(GitObjectType, GitHash, Text)] +gitShowTree what hash = do + path <- repoDataPath what + let cmd = [qc|git --git-dir {path} ls-tree {show $ pretty hash}|] + + -- FIXME: extract-method + gitRunCommand cmd + <&> fromRight mempty + <&> LBS8.lines + <&> fmap LBS8.words + <&> mapMaybe \case + [_,tp,h,name] -> do + (,,) <$> fromStringMay (LBS8.unpack tp) + <*> fromStringMay (LBS8.unpack h) + <*> pure (fromString (LBS8.unpack name)) + + _ -> Nothing + + +gitShowRefs :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> m [(GitRef, GitHash)] + +gitShowRefs what = do + path <- repoDataPath what + let cmd = [qc|git --git-dir {path} show-ref|] + + sto <- asks _sto + + fromMaybe mempty <$> runMaybeT do + + (_,hd) <- lift (selectRepoList (mempty & set repoListByLww (Just what) & set repoListLimit (Just 1))) + <&> listToMaybe + >>= toMPlus + <&> rlRepoTx + >>= readRepoHeadFromTx sto . coerce + >>= toMPlus + + pure $ view repoHeadRefs hd + + diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Commits.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Commits.hs new file mode 100644 index 00000000..91fc1cd7 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Commits.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE TemplateHaskell #-} +module HBS2.Git.DashBoard.State.Commits where + +import HBS2.Git.DashBoard.Prelude +import HBS2.Git.DashBoard.Types + +import HBS2.Git.Local +import HBS2.Git.Local.CLI + +import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.Text.Encoding qualified as Text +import Data.Text qualified as Text +import Data.Time (UTCTime,LocalTime) +import Data.Time.Clock.POSIX (posixSecondsToUTCTime) +import Data.Either + +import Streaming.Prelude qualified as S + +{- HLINT ignore "Functor law" -} + +class Monoid a => FromQueryParams a where + fromQueryParams :: [(Text,Text)] -> a + +data CommitListStyle = CommitListBrief + +data SelectCommitsPred = + SelectCommitsPred + { _commitListStyle :: CommitListStyle + , _commitPredOffset :: Int + , _commitPredLimit :: Int + , _commitRef :: Maybe GitRef + } + +makeLenses ''SelectCommitsPred + +instance Semigroup SelectCommitsPred where + (<>) _ b = mempty & set commitListStyle (view commitListStyle b) + & set commitPredOffset (view commitPredOffset b) + & set commitPredLimit (view commitPredLimit b) + & set commitRef (view commitRef b) + +instance Monoid SelectCommitsPred where + mempty = SelectCommitsPred CommitListBrief 0 100 Nothing + +briefCommits :: SelectCommitsPred +briefCommits = mempty + + +instance FromQueryParams SelectCommitsPred where + fromQueryParams args = do + let val = headMay [ GitRef (fromString (Text.unpack v)) | ("ref", v) <- args ] + mempty & set commitRef val + +newtype Author = Author Text + deriving stock (Generic,Data) + deriving newtype (Show) + + +newtype CommitListItemHash = CommitListItemHash GitHash + deriving stock (Generic,Data) + deriving newtype (Show,Pretty) + +newtype CommitListItemTime = CommitListItemTime Integer + deriving stock (Generic,Data) + deriving newtype (Show) + +newtype CommitListItemTitle = CommitListItemTitle Text + deriving stock (Generic,Data) + deriving newtype (Show) + +newtype CommitListItemAuthor = CommitListItemAuthor Author + deriving stock (Generic,Data) + deriving newtype (Show) + +data CommitListItem = + CommitListItemBrief + { commitListHash :: CommitListItemHash + , commitListTime :: CommitListItemTime + , commitListTitle :: CommitListItemTitle + , commitListAuthor :: CommitListItemAuthor + } + deriving stock (Generic,Data) + +selectCommits :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> SelectCommitsPred + -> m [CommitListItem] + +selectCommits lww SelectCommitsPred{..} = do + let lim = _commitPredLimit + let off = _commitPredOffset + let delim = "|||" :: Text + dir <- repoDataPath lww + + let what = maybe "--all" (show . pretty) _commitRef + + let cmd = case _commitListStyle of + CommitListBrief -> do + let fmt = [qc|--pretty=format:"%H{delim}%at{delim}%an{delim}%s"|] :: String + [qc|git --git-dir={dir} log {what} --max-count {lim} --skip {off} {fmt}|] + + debug $ red "selectCommits" <+> pretty cmd + + ls <- gitRunCommand cmd + <&> fromRight mempty + <&> LBS8.lines + <&> fmap (Text.decodeUtf8 . LBS8.toStrict) + + S.toList_ do + for_ ls $ \l -> do + case Text.splitOn "|||" l of + z@[cohash,ts,au,msg] -> do + + let utc = readMay @Integer (Text.unpack ts) + <&> CommitListItemTime + + let hash = fromStringMay @GitHash (Text.unpack cohash) + <&> CommitListItemHash + + let co = CommitListItemBrief + <$> hash + <*> utc + <*> pure (CommitListItemTitle msg) + <*> pure (CommitListItemAuthor (Author au)) + + maybe1 co none S.yield + + _ -> none + +getCommitRawBrief :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> GitHash + -> m Text + +getCommitRawBrief lww hash = do + + dir <- repoDataPath lww + + let cmd = [qc|git --git-dir={dir} show --stat {pretty hash}|] + + debug $ red "getCommitRawBrief" <+> viaShow cmd + + gitRunCommand cmd + <&> fromRight mempty + <&> Text.decodeUtf8 . LBS8.toStrict + +getCommitRawPatch :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> GitHash + -> m Text + +getCommitRawPatch lww hash = do + + dir <- repoDataPath lww + + let cmd = [qc|git --git-dir={dir} show {pretty hash}|] + + debug $ red "getCommitRawPatch" <+> viaShow cmd + + gitRunCommand cmd + <&> fromRight mempty + <&> Text.decodeUtf8 . LBS8.toStrict diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index.hs new file mode 100644 index 00000000..183c30cd --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index.hs @@ -0,0 +1,20 @@ +module HBS2.Git.DashBoard.State.Index + ( module HBS2.Git.DashBoard.State.Index + , module HBS2.Git.DashBoard.State.Index.Channels + , module HBS2.Git.DashBoard.State.Index.Peer + + ) where + +import HBS2.Git.DashBoard.Prelude +import HBS2.Git.DashBoard.Types +import HBS2.Git.DashBoard.State.Index.Channels +import HBS2.Git.DashBoard.State.Index.Peer + +updateIndex :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m () +updateIndex = do + debug "updateIndex" + updateIndexFromPeer + updateIndexFromChannels + + + diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Channels.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Channels.hs new file mode 100644 index 00000000..ba7fd839 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Channels.hs @@ -0,0 +1,75 @@ +module HBS2.Git.DashBoard.State.Index.Channels where + +import HBS2.Git.DashBoard.Prelude +import HBS2.Git.DashBoard.Types +import HBS2.Git.DashBoard.State + +import DBPipe.SQLite hiding (insert) +import DBPipe.SQLite.Generic as G + +import Streaming.Prelude qualified as S + +updateIndexFromChannels :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m () +updateIndexFromChannels = do + debug "updateIndexChannels" + + rchanAPI <- asks _refChanAPI + sto <- asks _sto + + flip runContT pure do + + es <- lift getIndexEntries + + for_ es $ \rc -> do + callCC \next -> do + debug $ red (pretty (AsBase58 rc)) + + h <- lift (callRpcWaitMay @RpcRefChanGet (1 :: Timeout 'Seconds) rchanAPI rc) + <&> join + >>= maybe (next ()) pure + + debug $ "rechan val" <+> red (pretty h) + + txs <- S.toList_ do + walkMerkle @[HashRef] (coerce h) (getBlock sto) $ \case + Left{} -> pure () + Right hs -> mapM_ S.yield hs + + for_ txs $ \txh -> void $ runMaybeT do + + done <- lift $ lift $ withState do + select @(Only Int) + [qc|select 1 from processed where hash = ? limit 1|] + (Only (TxHash txh)) <&> isJust . listToMaybe + + guard (not done) + + tx@GitIndexTx{..} <- getBlock sto (coerce txh) + >>= toMPlus + >>= readProposeTranMay @(GitIndexTx 'HBS2Basic) @L4Proto + >>= toMPlus + + lift $ lift $ withState $ transactional do + let nm = [ RepoName n | GitIndexRepoName n <- universeBi gitIndexTxPayload ] & headMay + let bri = [ RepoBrief n | GitIndexRepoBrief n <- universeBi gitIndexTxPayload ] & headMay + + insert @RepoTable $ onConflictIgnore @RepoTable (Only (RepoLww gitIndexTxRef)) + + insert @RepoChannelTable $ + onConflictIgnore @RepoChannelTable (RepoLww gitIndexTxRef, RepoChannel rc) + + -- FIXME: on-conflict-update! + for_ nm $ \n -> do + insert @RepoNameTable $ + onConflictIgnore @RepoNameTable (RepoLww gitIndexTxRef, n) + + for_ bri $ \n -> do + insert @RepoBriefTable $ + onConflictIgnore @RepoBriefTable (RepoLww gitIndexTxRef, n) + + lift $ withState $ transactional do + for_ txs $ \t -> do + insert @TxProcessedTable $ onConflictIgnore @TxProcessedTable (Only (TxHash t)) + + + diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Peer.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Peer.hs new file mode 100644 index 00000000..c30d8eb6 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State/Index/Peer.hs @@ -0,0 +1,73 @@ +module HBS2.Git.DashBoard.State.Index.Peer where + +import HBS2.Git.DashBoard.Prelude +import HBS2.Git.DashBoard.Types +import HBS2.Git.DashBoard.State +import HBS2.Git.Data.LWWBlock +import HBS2.Git.Data.Tx.Git + +import Streaming.Prelude qualified as S + +{- HLINT ignore "Functor law" -} + +seconds = TimeoutSec + +updateIndexFromPeer :: (DashBoardPerks m, HasConf m, MonadReader DashBoardEnv m) => m () +updateIndexFromPeer = do + debug "updateIndexFromPeer" + + peer <- asks _peerAPI + reflog <- asks _refLogAPI + lwwAPI <- asks _lwwRefAPI + sto <- asks _sto + + + polls <- callRpcWaitMay @RpcPollList2 (TimeoutSec 1) peer (Just "lwwref", Nothing) + <&> join . maybeToList + <&> fmap (LWWRefKey @HBS2Basic . view _1) + + repos <- S.toList_ $ forM_ polls $ \r -> void $ runMaybeT do + + lwval <- liftIO (callRpcWaitMay @RpcLWWRefGet (seconds 1) lwwAPI r) + >>= toMPlus >>= toMPlus + + (lw,blk) <- readLWWBlock sto r >>= toMPlus + let rk = lwwRefLogPubKey blk + + lift $ S.yield (r,lwval,RefLogKey @'HBS2Basic rk,blk) + + for_ repos $ \(lw,wv,rk,LWWBlockData{..}) -> do + + mhead <- callRpcWaitMay @RpcRefLogGet (TimeoutSec 1) reflog (coerce rk) + <&> join + + for_ mhead $ \mh -> do + + txs <- S.toList_ $ do + walkMerkle @[HashRef] (fromHashRef mh) (getBlock sto) $ \case + Left{} -> do + pure () + + Right hxs -> do + for_ hxs $ \htx -> void $ runMaybeT do + -- done <- liftIO $ withDB db (isTxProcessed (HashVal htx)) + -- done1 <- liftIO $ withDB db (isTxProcessed (processedRepoTx (gitLwwRef,htx))) + -- guard (not done && not done1) + getBlock sto (fromHashRef htx) >>= toMPlus + <&> deserialiseOrFail @(RefLogUpdate L4Proto) + >>= toMPlus + >>= unpackTx + >>= \(n,h,blk) -> lift (S.yield (n,htx,blk)) + + + headz <- S.toList_ do + for_ txs $ \(n,tx,blk) -> void $ runMaybeT do + (rhh, rhead) <- readRepoHeadFromTx sto tx >>= toMPlus + debug $ yellow "found repo head" <+> pretty rhh <+> pretty "for" <+> pretty lw + lift $ S.yield (lw, RepoHeadTx tx, RepoHeadRef rhh, rhead) + + withState $ transactional do + for_ headz $ \(l, tx, rh, rhead) -> do + let rlwwseq = RepoLwwSeq (fromIntegral $ lwwSeq wv) + insertRepoHead l rlwwseq (RepoRefLog rk) tx rh rhead + diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs new file mode 100644 index 00000000..fb6d2117 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/Types.hs @@ -0,0 +1,107 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language UndecidableInstances #-} +{-# Language AllowAmbiguousTypes #-} +{-# Language TemplateHaskell #-} +module HBS2.Git.DashBoard.Types + ( module HBS2.Git.DashBoard.Types + , module HBS2.Git.Data.Tx.Index + ) where + +import HBS2.Git.DashBoard.Prelude + +import HBS2.Git.Data.Tx.Index + +import HBS2.Net.Messaging.Unix + +import DBPipe.SQLite + +import HBS2.System.Dir + +import System.FilePath + +data HttpPortOpt + +data DevelopAssetsOpt + +instance HasCfgKey HttpPortOpt a where + key = "port" + + +instance HasCfgKey DevelopAssetsOpt a where + key = "develop-assets" + +data RunDashBoardOpts = RunDashBoardOpts + { configPath :: Maybe FilePath } + +instance Monoid RunDashBoardOpts where + mempty = RunDashBoardOpts Nothing + +instance Semigroup RunDashBoardOpts where + (<>) _ b = RunDashBoardOpts { configPath = configPath b } + + +data DashBoardEnv = + DashBoardEnv + { _peerAPI :: ServiceCaller PeerAPI UNIX + , _refLogAPI :: ServiceCaller RefLogAPI UNIX + , _refChanAPI :: ServiceCaller RefChanAPI UNIX + , _lwwRefAPI :: ServiceCaller LWWRefAPI UNIX + , _sto :: AnyStorage + , _dashBoardConf :: TVar [Syntax C] + , _db :: DBPipeEnv + , _dataDir :: FilePath + , _pipeline :: TQueue (IO ()) + } + +makeLenses 'DashBoardEnv + +repoDataPath :: (DashBoardPerks m, MonadReader DashBoardEnv m) => LWWRefKey 'HBS2Basic -> m FilePath +repoDataPath lw = asks _dataDir <&> ( (show $ pretty lw)) >>= canonicalizePath + +type DashBoardPerks m = MonadUnliftIO m + +newtype DashBoardM m a = DashBoardM { fromDashBoardM :: ReaderT DashBoardEnv m a } + deriving newtype + ( Applicative + , Functor + , Monad + , MonadIO + , MonadUnliftIO + , MonadTrans + , MonadReader DashBoardEnv + ) + +instance (MonadIO m, Monad m, MonadReader DashBoardEnv m) => HasConf m where + getConf = do + asks _dashBoardConf >>= readTVarIO + +newDashBoardEnv :: MonadIO m + => [Syntax C] + -> FilePath + -> ServiceCaller PeerAPI UNIX + -> ServiceCaller RefLogAPI UNIX + -> ServiceCaller RefChanAPI UNIX + -> ServiceCaller LWWRefAPI UNIX + -> AnyStorage + -> m DashBoardEnv +newDashBoardEnv cfg dbFile peer rlog rchan lww sto = do + let ddir = takeDirectory dbFile + DashBoardEnv peer rlog rchan lww sto + <$> newTVarIO cfg + <*> newDBPipeEnv dbPipeOptsDef dbFile + <*> pure ddir + <*> newTQueueIO + +withDashBoardEnv :: Monad m => DashBoardEnv -> DashBoardM m a -> m a +withDashBoardEnv env m = runReaderT (fromDashBoardM m) env + +withState :: (MonadIO m, MonadReader DashBoardEnv m) => DBPipeM m a -> m a +withState f = do + asks _db >>= flip withDB f + + +addJob :: (DashBoardPerks m, MonadReader DashBoardEnv m) => IO () -> m () +addJob f = do + q <- asks _pipeline + atomically $ writeTQueue q f + diff --git a/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs new file mode 100644 index 00000000..c0cbe5c0 --- /dev/null +++ b/hbs2-git/hbs2-git-dashboard/src/HBS2/Git/Web/Html/Root.hs @@ -0,0 +1,1075 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# Language PatternSynonyms #-} +{-# Language ViewPatterns #-} +{-# Language MultiWayIf #-} +module HBS2.Git.Web.Html.Root where + +import HBS2.Git.DashBoard.Prelude +import HBS2.Git.DashBoard.Types +import HBS2.Git.DashBoard.State +import HBS2.Git.DashBoard.State.Commits + +import HBS2.OrDie + +import HBS2.Git.Data.Tx.Git +import HBS2.Git.Data.RepoHead +import HBS2.Git.Web.Assets + +-- import Data.Text.Fuzzy.Tokenize as Fuzz + +import Data.ByteString.Lazy qualified as LBS +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Lucid.Base +import Lucid.Html5 hiding (for_) +import Lucid.Htmx + +import Skylighting qualified as Sky +import Skylighting.Tokenizer +import Skylighting.Format.HTML.Lucid as Lucid + +import Control.Applicative +import Text.Pandoc hiding (getPOSIXTime) +import System.FilePath +import Data.Word +import Data.Either +import Data.List qualified as List +import Data.List (sortOn) + +import Web.Scotty.Trans as Scotty + +import Data.Kind + +import Streaming.Prelude qualified as S + +import Network.HTTP.Types.Status + +rootPath :: [String] -> [String] +rootPath = ("/":) + +class Path a where + path :: [a] -> Text + +instance Path String where + path = Text.pack . joinPath . rootPath + +class ToRoutePattern a where + routePattern :: a -> RoutePattern + +class ToURL a where + toURL :: a -> Text + +data family Tabs a :: Type + +data RepoListPage = RepoListPage + +data RepoPageTabs = CommitsTab (Maybe GitHash) + | ManifestTab + | TreeTab (Maybe GitHash) + | ForksTab + deriving stock (Eq,Ord,Show) + +data RepoPage s a = RepoPage s a + +data RepoRefs repo = RepoRefs repo + +data RepoTree repo commit tree = RepoTree repo commit tree + +data RepoTreeEmbedded repo commit tree = RepoTreeEmbedded repo commit tree + +data RepoBlob repo commit tree blob = RepoBlob repo commit tree blob + +data RepoSomeBlob repo blob tp = RepoSomeBlob repo blob tp + +data RepoForksHtmx repo = RepoForksHtmx repo + +newtype RepoManifest repo = RepoManifest repo + +newtype RepoCommits repo = RepoCommits repo + +data RepoCommitsQ repo off lim = RepoCommitsQ repo off lim + +data RepoCommitDefault repo commit = RepoCommitDefault repo commit + +data RepoCommitSummaryQ repo commit = RepoCommitSummaryQ repo commit + +data RepoCommitPatchQ repo commit = RepoCommitPatchQ repo commit + +isActiveTab :: RepoPageTabs -> RepoPageTabs -> Bool +isActiveTab a b = case (a,b) of + (CommitsTab{},CommitsTab{}) -> True + (ManifestTab{},ManifestTab{}) -> True + (TreeTab{},TreeTab{}) -> True + _ -> False + +toArg :: (Semigroup a, IsString a) => a -> a +toArg s = ":" <> s + +toPattern :: Text -> RoutePattern +toPattern = fromString . Text.unpack + +instance Pretty RepoPageTabs where + pretty = \case + CommitsTab{} -> "commits" + ManifestTab{} -> "manifest" + TreeTab{} -> "tree" + ForksTab{} -> "forks" + +instance FromStringMaybe RepoPageTabs where + fromStringMay = \case + "commits" -> pure (CommitsTab Nothing) + "manifest" -> pure ManifestTab + "tree" -> pure (TreeTab Nothing) + "forks" -> pure ForksTab + _ -> pure (CommitsTab Nothing) + +instance ToRoutePattern RepoListPage where + routePattern = \case + RepoListPage -> "/" + +instance ToURL (RepoPage RepoPageTabs (LWWRefKey 'HBS2Basic)) where + toURL (RepoPage s w) = path @String [ "/", show (pretty s), show (pretty w)] + <> pred_ + where + pred_ = case s of + CommitsTab (Just p) -> Text.pack $ "?ref=" <> show (pretty p) + TreeTab (Just p) -> Text.pack $ "?tree=" <> show (pretty p) + _ -> mempty + +instance ToRoutePattern (RepoPage String String) where + routePattern (RepoPage s w) = path ["/", toArg s, toArg w] & toPattern + +instance ToURL RepoListPage where + toURL _ = "/" + +instance ToURL (RepoRefs (LWWRefKey 'HBS2Basic)) where + toURL (RepoRefs repo') = path ["/", "htmx", "refs", repo] + where + repo = show $ pretty repo' + +instance ToRoutePattern (RepoRefs String) where + routePattern (RepoRefs s) = path ["/", "htmx", "refs", toArg s] & toPattern + + +instance ToURL (RepoTree (LWWRefKey 'HBS2Basic) GitHash GitHash) where + toURL (RepoTree k co tree') = path ["/", "htmx", "tree", repo, commit, tree] + where + repo = show $ pretty k + commit = show $ pretty co + tree = show $ pretty tree' + +instance ToRoutePattern (RepoTree String String String) where + routePattern (RepoTree r co tree) = + path ["/", "htmx", "tree", toArg r, toArg co, toArg tree] & toPattern + +instance ToURL (RepoBlob (LWWRefKey 'HBS2Basic) GitHash GitHash GitHash) where + toURL (RepoBlob k co t bo) = path ["/", "htmx", "blob", repo, commit, tree, blob] + where + repo = show $ pretty k + commit = show $ pretty co + tree = show $ pretty t + blob = show $ pretty bo + +instance ToRoutePattern (RepoBlob String String String String) where + routePattern (RepoBlob r c t b) = + path ["/", "htmx", "blob", toArg r, toArg c, toArg t, toArg b] & toPattern + + +instance ToURL (RepoSomeBlob (LWWRefKey 'HBS2Basic) Text GitHash) where + toURL (RepoSomeBlob k tp' blo) = path ["/", "htmx", "some-blob", repo, tp, blob] + where + repo = show $ pretty k + tp = Text.unpack tp' + blob = show $ pretty blo + +instance ToRoutePattern (RepoSomeBlob String String String) where + routePattern (RepoSomeBlob r t b) = + path ["/", "htmx", "some-blob", toArg r, toArg t, toArg b] & toPattern + +instance ToURL (RepoManifest (LWWRefKey 'HBS2Basic)) where + toURL (RepoManifest repo') = path ["/", "htmx", "manifest", repo] + where + repo = show $ pretty repo' + +instance ToRoutePattern (RepoManifest String) where + routePattern (RepoManifest s) = path ["/", "htmx", "manifest", toArg s] & toPattern + +instance ToURL (RepoCommits (LWWRefKey 'HBS2Basic)) where + toURL (RepoCommits repo') = path ["/", "htmx", "commits", repo] + where + repo = show $ pretty repo' + +instance ToRoutePattern (RepoCommits String) where + routePattern (RepoCommits s) = path ["/", "htmx", "commits", toArg s] & toPattern + +instance ToURL (RepoCommitsQ (LWWRefKey 'HBS2Basic) Int Int) where + toURL (RepoCommitsQ repo' off lim) = path ["/", "htmx", "commits", repo, show off, show lim] + where + repo = show $ pretty repo' + +instance ToRoutePattern (RepoCommitsQ String String String) where + routePattern (RepoCommitsQ r o l) = + path ["/", "htmx", "commits", toArg r, toArg o, toArg l] & toPattern + +instance ToURL (RepoCommitDefault (LWWRefKey 'HBS2Basic) GitHash) where + toURL (RepoCommitDefault repo' h) = toURL (RepoCommitSummaryQ repo' h) + +instance ToRoutePattern (RepoCommitDefault String String) where + routePattern (RepoCommitDefault r h) = routePattern (RepoCommitSummaryQ r h) + +instance ToURL (RepoCommitSummaryQ (LWWRefKey 'HBS2Basic) GitHash) where + toURL (RepoCommitSummaryQ repo' h) = path ["/", "htmx", "commit", "summary", repo, ha] + where + repo = show $ pretty repo' + ha = show $ pretty h + +instance ToRoutePattern (RepoCommitSummaryQ String String) where + routePattern (RepoCommitSummaryQ r h) = + path ["/", "htmx", "commit", "summary", toArg r, toArg h] & toPattern + +instance ToURL (RepoCommitPatchQ (LWWRefKey 'HBS2Basic) GitHash) where + toURL (RepoCommitPatchQ repo' h) = path ["/", "htmx", "commit", "patch", repo, ha] + where + repo = show $ pretty repo' + ha = show $ pretty h + +instance ToRoutePattern (RepoCommitPatchQ String String) where + routePattern (RepoCommitPatchQ r h) = + path ["/", "htmx", "commit", "patch", toArg r, toArg h] & toPattern + + +instance ToURL (RepoTreeEmbedded (LWWRefKey 'HBS2Basic) GitHash GitHash) where + toURL (RepoTreeEmbedded k co tree') = path ["/", "htmx", "tree", "embedded", repo, commit, tree] + where + repo = show $ pretty k + commit = show $ pretty co + tree = show $ pretty tree' + +instance ToRoutePattern (RepoTreeEmbedded String String String) where + routePattern (RepoTreeEmbedded r co tree) = + path ["/", "htmx", "tree", "embedded", toArg r, toArg co, toArg tree] & toPattern + + +instance ToURL (RepoForksHtmx (LWWRefKey 'HBS2Basic)) where + toURL (RepoForksHtmx k) = path ["/", "htmx", "forks", repo] + where + repo = show $ pretty k + +instance ToRoutePattern (RepoForksHtmx String) where + routePattern (RepoForksHtmx r) = + path ["/", "htmx", "forks", toArg r] & toPattern + +myCss :: Monad m => HtmlT m () +myCss = do + link_ [rel_ "stylesheet", href_ (path ["css/custom.css"])] + +hyper_ :: Text -> Attribute +hyper_ = makeAttribute "_" + +ariaLabel_ :: Text -> Attribute +ariaLabel_ = makeAttribute "aria-label" + +onClickCopy :: Text -> Attribute +onClickCopy s = + hyper_ [qc|on click writeText('{s}') into the navigator's clipboard +set my innerHTML to '{svgIconText IconCopyDone}' +set @data-tooltip to 'Copied!' +wait 2s +set my innerHTML to '{svgIconText IconCopy}' +set @data-tooltip to 'Copy' +|] + +markdownToHtml :: Text -> Either PandocError String +markdownToHtml markdown = runPure $ do + doc <- readMarkdown def {readerExtensions = pandocExtensions} markdown + html <- writeHtml5String def {writerExtensions = pandocExtensions} doc + return $ Text.unpack html + +renderMarkdown' :: Text -> Text +renderMarkdown' markdown = case markdownToHtml markdown of + Left{} -> markdown + Right html -> Text.pack html + +renderMarkdown :: Text -> Html () +renderMarkdown markdown = case markdownToHtml markdown of + Left{} -> blockquote_ (toHtml markdown) + Right html -> toHtmlRaw $ Text.pack html + +instance ToHtml RepoBrief where + toHtml (RepoBrief txt) = toHtmlRaw (renderMarkdown' txt) + toHtmlRaw (RepoBrief txt) = toHtmlRaw (renderMarkdown' txt) + +data WithTime a = WithTime Integer a + +agePure :: forall a b . (Integral a,Integral b) => a -> b -> Text +agePure t0 t = do + let sec = fromIntegral @_ @Word64 t - fromIntegral t0 + fromString $ show $ + if | sec > 86400 -> pretty (sec `div` 86400) <+> "days ago" + | sec > 3600 -> pretty (sec `div` 3600) <+> "hours ago" + | otherwise -> pretty (sec `div` 60) <+> "minutes ago" + + +instance ToHtml GitRef where + toHtml (GitRef s)= toHtml s + toHtmlRaw (GitRef s)= toHtmlRaw s + +rootPage :: Monad m => HtmlT m () -> HtmlT m () +rootPage content = do + doctypehtml_ do + head_ do + meta_ [charset_ "UTF-8"] + meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0"] + -- FIXME: static-local-loading + link_ [rel_ "stylesheet", href_ "https://cdn.jsdelivr.net/npm/@picocss/pico@2.0.6/css/pico.min.css"] + script_ [src_ "https://unpkg.com/hyperscript.org@0.9.12"] "" + script_ [src_ "https://unpkg.com/htmx.org@1.9.11"] "" + myCss + + body_ do + + header_ [class_ "container-fluid"] do + nav_ do + ul_ $ li_ $ a_ [href_ (toURL RepoListPage)] $ strong_ "hbs2-peer dashboard" + + content + + +dashboardRootPage :: (DashBoardPerks m, MonadReader DashBoardEnv m) => HtmlT m () +dashboardRootPage = rootPage do + + items <- lift $ selectRepoList mempty + + now <- liftIO getPOSIXTime <&> fromIntegral . round + + main_ [class_ "container-fluid"] $ do + div_ [class_ "wrapper"] $ do + aside_ [class_ "sidebar"] $ do + div_ [class_ "info-block"] $ small_ "Всякая разная рандомная информация хрен знает, что тут пока выводить" + div_ [class_ "info-block"] $ small_ "Всякая разная рандомная информация хрен знает, что тут пока выводить" + + div_ [class_ "content"] do + + section_ do + h2_ "Git repositories" + form_ [role_ "search"] do + input_ [name_ "search", type_ "search"] + input_ [type_ "submit", value_ "Search"] + + section_ do + + for_ items $ \it@RepoListItem{..} -> do + + let locked = isJust $ coerce @_ @(Maybe HashRef) rlRepoGK0 + + let url = toURL (RepoPage (CommitsTab Nothing) (coerce @_ @(LWWRefKey 'HBS2Basic) rlRepoLww)) + -- path ["repo", Text.unpack $ view rlRepoLwwAsText it] + let t = fromIntegral $ coerce @_ @Word64 rlRepoSeq + + let updated = agePure t now + + article_ [class_ "repo-list-item"] do + div_ do + + h5_ do + toHtml rlRepoName + + div_ [class_ "repo-list-item-link-wrapper"] $ do + a_ [href_ url] (toHtml $ view rlRepoLwwAsText it) + button_ [class_ "copy-button", onClickCopy (view rlRepoLwwAsText it), data_ "tooltip" "Copy"] do + svgIcon IconCopy + + toHtml rlRepoBrief + + div_ do + + div_ [class_ "text-nowrap"] do + small_ $ "Updated " <> toHtml updated + + when locked do + div_ do + small_ do + span_ [class_ "inline-icon-wrapper"] $ svgIcon IconLockClosed + "Encrypted" + + div_ do + small_ do + span_ [class_ "inline-icon-wrapper"] $ svgIcon IconGitCommit + strong_ $ toHtml $ show rlRepoCommits + " commits" + + div_ do + small_ do + span_ [class_ "inline-icon-wrapper"] $ svgIcon IconGitFork + strong_ $ toHtml $ show rlRepoForks + " forks" + + + +tabClick :: Attribute +tabClick = + hyper_ "on click take .contrast from .tab for event's target" + +parsedManifest :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> m ([Syntax C], Text) +parsedManifest RepoListItem{..} = do + + sto <- asks _sto + mhead <- readRepoHeadFromTx sto (coerce rlRepoTx) + + let rawManifest = (_repoManifest . snd =<< mhead) + & fromMaybe (coerce rlRepoBrief) + & Text.lines + + w <- S.toList_ do + flip fix rawManifest $ \next ss -> do + case ss of + ( "" : rest ) -> S.yield (Right (Text.stripStart (Text.unlines rest))) + ( a : rest ) -> S.yield (Left a ) >> next rest + [] -> pure () + + let meta = Text.unlines (lefts w) + & Text.unpack + & parseTop + & fromRight mempty + + let manifest = mconcat $ rights w + + pure (meta, manifest) + + +thisRepoManifest :: (DashBoardPerks m, MonadReader DashBoardEnv m) => RepoListItem -> HtmlT m () +thisRepoManifest it@RepoListItem{..} = do + (_, manifest) <- lift $ parsedManifest it + toHtmlRaw (renderMarkdown' manifest) + +repoRefs :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> HtmlT m () +repoRefs lww = do + + refs <- lift $ gitShowRefs lww + table_ [] do + for_ refs $ \(r,h) -> do + let r_ = Text.pack $ show $ pretty r + let co = show $ pretty h + let uri = toURL (RepoTree lww h h) + + let showRef = Text.isPrefixOf "refs" r_ + + when showRef do + tr_ do + td_ do + + if | Text.isPrefixOf "refs/heads" r_ -> do + svgIcon IconGitBranch + | Text.isPrefixOf "refs/tags" r_ -> do + svgIcon IconTag + | otherwise -> mempty + + td_ (toHtml r_) + td_ [class_ "mono"] $ do + a_ [ href_ "#" + , hxGet_ uri + , hxTarget_ "#repo-tab-data" + ] (toHtml $ show $ pretty h) + + +treeLocator :: DashBoardPerks m + => LWWRefKey 'HBS2Basic + -> GitHash + -> TreeLocator + -> HtmlT m () + -> HtmlT m () + +treeLocator lww co locator next = do + + let repo = show $ pretty $ lww + + let co_ = show $ pretty co + + let prefixSlash x = if fromIntegral x > 1 then span_ "/" else "" + let showRoot = + [ hxGet_ (toURL (RepoTree lww co co)) + , hxTarget_ "#repo-tab-data" + , href_ "#" + ] + + span_ [] $ a_ [ hxGet_ (toURL (RepoRefs lww)) + , hxTarget_ "#repo-tab-data" + , href_ "#" + ] $ toHtml (take 10 repo <> "..") + span_ [] "/" + span_ [] $ a_ showRoot $ toHtml (take 10 co_ <> "..") + unless (List.null locator) do + span_ [] "/" + for_ locator $ \(_,this,level,name) -> do + prefixSlash level + let uri = toURL (RepoTree lww co (coerce @_ @GitHash this)) + span_ [] do + a_ [ href_ "#" + , hxGet_ uri + , hxTarget_ "#repo-tab-data" + ] (toHtml (show $ pretty name)) + next + + +repoTreeEmbedded :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> GitHash -- ^ this + -> GitHash -- ^ this + -> HtmlT m () + +repoTreeEmbedded = repoTree_ True + + +repoTree :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> GitHash -- ^ this + -> GitHash -- ^ this + -> HtmlT m () + +repoTree = repoTree_ False + +repoTree_ :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => Bool + -> LWWRefKey 'HBS2Basic + -> GitHash -- ^ this + -> GitHash -- ^ this + -> HtmlT m () + +repoTree_ embed lww co root = do + + tree <- lift $ gitShowTree lww root + back' <- lift $ selectParentTree (TreeCommit co) (TreeTree root) + + let syntaxMap = Sky.defaultSyntaxMap + + let sorted = sortOn (\(tp, _, name) -> (tpOrder tp, name)) tree + where + tpOrder Tree = (0 :: Int) + tpOrder Blob = 1 + tpOrder _ = 2 + + locator <- lift $ selectTreeLocator (TreeCommit co) (TreeTree root) + + let target = if embed then "#repo-tab-data-embedded" else "#repo-tab-data" + + table_ [] do + + unless embed do + + tr_ do + td_ [class_ "tree-locator", colspan_ "3"] do + treeLocator lww co locator none + + tr_ mempty do + + for_ back' $ \r -> do + let rootLink = toURL (RepoTree lww co (coerce @_ @GitHash r)) + td_ $ svgIcon IconArrowUturnLeft + td_ ".." + td_ do a_ [ href_ "#" + , hxGet_ rootLink + , hxTarget_ target + ] (toHtml $ show $ pretty r) + + for_ sorted $ \(tp,h,name) -> do + let itemClass = pretty tp & show & Text.pack + let hash_ = show $ pretty h + let uri = toURL $ RepoTree lww co h + tr_ mempty do + td_ $ case tp of + Commit -> mempty + Tree -> svgIcon IconFolderFilled + Blob -> do + let syn = Sky.syntaxesByFilename syntaxMap (Text.unpack name) + & headMay + <&> Text.toLower . Sky.sName + + let icon = case syn of + Just "haskell" -> IconHaskell + Just "markdown" -> IconMarkdown + Just "nix" -> IconNix + Just "bash" -> IconBash + Just "python" -> IconPython + Just "javascript" -> IconJavaScript + Just "sql" -> IconSql + Just s | s `elem` ["cabal","makefile","toml","ini","yaml"] + -> IconSettingsFilled + _ -> IconFileFilled + + svgIcon icon + + -- debug $ red "PUSH URL" <+> pretty (path ["back", wtf]) + + td_ [class_ itemClass] (toHtml $ show $ pretty name) + td_ [class_ "mono"] do + case tp of + Blob -> do + let blobUri = toURL $ RepoBlob lww co root h + a_ [ href_ "#" + , hxGet_ blobUri + , hxTarget_ target + ] (toHtml hash_) + + Tree -> do + a_ [ href_ "#" + , hxGet_ uri + , hxTarget_ target + ] (toHtml hash_) + + _ -> mempty + + +{- HLINT ignore "Functor law" -} + +data RepoCommitStyle = RepoCommitSummary | RepoCommitPatch + deriving (Eq,Ord,Show) + +repoCommit :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => RepoCommitStyle + -> LWWRefKey 'HBS2Basic + -> GitHash + -> HtmlT m () + +repoCommit style lww hash = do + let syntaxMap = Sky.defaultSyntaxMap + + txt <- lift $ getCommitRawBrief lww hash + + let header = Text.lines txt & takeWhile (not . Text.null) + & fmap Text.words + + let au = [ Text.takeWhile (/= '<') (Text.unwords a) + | ("Author:" : a) <- header + ] & headMay + + table_ [class_ "item-attr"] do + + tr_ do + th_ [width_ "16rem"] $ strong_ "back" + td_ $ a_ [ href_ (toURL (RepoPage (CommitsTab (Just hash)) lww)) + ] $ toHtml $ show $ pretty hash + + for_ au $ \author -> do + tr_ do + th_ $ strong_ "author" + td_ $ toHtml author + + tr_ $ do + th_ $ strong_ "view" + td_ do + ul_ [class_ "misc-menu"]do + li_ $ a_ [ href_ "#" + , hxGet_ (toURL (RepoCommitSummaryQ lww hash)) + , hxTarget_ "#repo-tab-data" + ] "summary" + + li_ $ a_ [ href_ "#" + , hxGet_ (toURL (RepoCommitPatchQ lww hash)) + , hxTarget_ "#repo-tab-data" + ] "patch" + + li_ $ a_ [ href_ (toURL (RepoPage (TreeTab (Just hash)) lww)) + ] "tree" + + case style of + RepoCommitSummary -> do + + let msyn = Sky.syntaxByName syntaxMap "default" + + for_ msyn $ \syn -> do + + let config = TokenizerConfig { traceOutput = False, syntaxMap = syntaxMap } + + case tokenize config syn txt of + Left _ -> mempty + Right tokens -> do + let fo = Sky.defaultFormatOpts { Sky.numberLines = False, Sky.ansiColorLevel = Sky.ANSI256Color } + let code = renderText (Lucid.formatHtmlBlock fo tokens) + toHtmlRaw code + + RepoCommitPatch -> do + + let msyn = Sky.syntaxByName syntaxMap "diff" + + for_ msyn $ \syn -> do + + txt <- lift $ getCommitRawPatch lww hash + + let config = TokenizerConfig { traceOutput = False, syntaxMap = syntaxMap } + + case tokenize config syn txt of + Left _ -> mempty + Right tokens -> do + let fo = Sky.defaultFormatOpts { Sky.numberLines = False, Sky.ansiColorLevel = Sky.ANSI256Color } + let code = renderText (Lucid.formatHtmlBlock fo tokens) + toHtmlRaw code + + +repoForks :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> HtmlT m () + +repoForks lww = do + forks <- lift $ selectRepoForks lww + now <- getEpoch + + unless (List.null forks) do + table_ $ do + tr_ $ th_ [colspan_ "3"] mempty + for_ forks $ \it@RepoListItem{..} -> do + let lwwTo = coerce @_ @(LWWRefKey 'HBS2Basic) rlRepoLww + tr_ [class_ "commit-brief-title"] do + td_ $ svgIcon IconGitFork + td_ [class_ "mono"] $ + a_ [ href_ (toURL (RepoPage (CommitsTab Nothing) lwwTo)) + ] do + toHtmlRaw $ view rlRepoLwwAsText it + td_ $ small_ $ toHtml (agePure rlRepoSeq now) + + +repoCommits :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> Either SelectCommitsPred SelectCommitsPred + -> HtmlT m () + +repoCommits lww predicate' = do + now <- getEpoch + + let predicate = either id id predicate' + + co <- lift $ selectCommits lww predicate + + let off = view commitPredOffset predicate + let lim = view commitPredLimit predicate + let noff = off + lim + + let query = RepoCommitsQ lww noff lim --) path ["repo", repo, "commits", show noff, show lim] + + let normalizeText s = l $ (Text.take 60 . Text.unwords . Text.words) s + where l x | Text.length x < 60 = x + | otherwise = x <> "..." + + let rows = do + tr_ $ th_ [colspan_ "5"] mempty + for_ co $ \case + CommitListItemBrief{..} -> do + tr_ [class_ "commit-brief-title"] do + td_ [class_ "commit-icon"] $ svgIcon IconGitCommit + + td_ [class_ "commit-hash mono"] do + let hash = coerce @_ @GitHash commitListHash + a_ [ href_ "#" + , hxGet_ (toURL (RepoCommitDefault lww hash)) + , hxTarget_ "#repo-tab-data" + , hxPushUrl_ (toURL query) + ] $ toHtml (ShortRef hash) + + td_ [class_ "commit-brief-title"] do + toHtml $ normalizeText $ coerce @_ @Text commitListTitle + + tr_ [class_ "commit-brief-details"] do + td_ [colspan_ "3"] do + small_ do + toHtml (agePure (coerce @_ @Integer commitListTime) now) + toHtml " by " + toHtml $ coerce @_ @Text commitListAuthor + + unless (List.null co) do + tr_ [ class_ "commit-brief-last" + , hxGet_ (toURL query) + , hxTrigger_ "revealed" + , hxSwap_ "afterend" + ] do + td_ [colspan_ "4"] do + mempty + + if isRight predicate' then do + table_ rows + else do + rows + + +repoSomeBlob :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> Text + -> GitHash + -> HtmlT m () + +repoSomeBlob lww syn hash = do + + bi <- lift (selectBlobInfo (BlobHash hash)) + >>= orThrow (itemNotFound hash) + + doRenderBlob (pure mempty) lww bi + +repoBlob :: (DashBoardPerks m, MonadReader DashBoardEnv m) + => LWWRefKey 'HBS2Basic + -> TreeCommit + -> TreeTree + -> BlobInfo + -> HtmlT m () + +repoBlob lww co tree bi@BlobInfo{..} = do + locator <- lift $ selectTreeLocator co tree + + table_ [] do + tr_ do + td_ [class_ "tree-locator", colspan_ "3"] do + treeLocator lww (coerce co) locator do + span_ "/" + span_ $ toHtml (show $ pretty blobName) + + + table_ [class_ "item-attr"] do + tr_ do + th_ $ strong_ "hash" + td_ [colspan_ "7"] do + span_ [class_ "mono"] $ toHtml $ show $ pretty blobHash + + tr_ do + th_ $ strong_ "syntax" + td_ $ toHtml $ show $ pretty blobSyn + + th_ $ strong_ "size" + td_ $ toHtml $ show $ pretty blobSize + + td_ [colspan_ "3"] mempty + + doRenderBlob (pure mempty) lww bi + +doRenderBlob fallback lww BlobInfo{..} = do + fromMaybe mempty <$> runMaybeT do + + guard (blobSize < 10485760) + + let fn = blobName & coerce + let syntaxMap = Sky.defaultSyntaxMap + + syn <- ( Sky.syntaxesByFilename syntaxMap fn + & headMay + ) <|> Sky.syntaxByName syntaxMap "default" + & toMPlus + + lift do + + txt <- lift (readBlob lww blobHash) + <&> LBS.toStrict + <&> Text.decodeUtf8 + + case blobSyn of + BlobSyn (Just "markdown") -> do + + toHtmlRaw (renderMarkdown' txt) + + _ -> do + + txt <- lift (readBlob lww blobHash) + <&> LBS.toStrict + <&> Text.decodeUtf8 + + let config = TokenizerConfig { traceOutput = False, syntaxMap = syntaxMap } + + case tokenize config syn txt of + Left _ -> fallback txt + Right tokens -> do + let fo = Sky.defaultFormatOpts { Sky.numberLines = False, Sky.ansiColorLevel = Sky.ANSI256Color } + let code = renderText (Lucid.formatHtmlBlock fo tokens) + toHtmlRaw code + +raiseStatus :: forall m . MonadIO m => Status -> Text -> m () +raiseStatus s t = throwIO (StatusError s t) + +itemNotFound s = StatusError status404 (Text.pack $ show $ pretty s) + +newtype ShortRef a = ShortRef a + +shortRef :: Int -> Int -> String -> String +shortRef n k a = if k > 0 then [qc|{b}..{r}|] else [qc|{b}|] + where + b = take n a + r = reverse $ take k (reverse a) + +instance ToHtml (ShortRef GitHash) where + toHtml (ShortRef a) = toHtml (shortRef 10 0 (show $ pretty a)) + toHtmlRaw (ShortRef a) = toHtml (shortRef 10 0 (show $ pretty a)) + +instance ToHtml (ShortRef (LWWRefKey 'HBS2Basic)) where + toHtml (ShortRef a) = toHtml (shortRef 14 3 (show $ pretty a)) + toHtmlRaw (ShortRef a) = toHtml (shortRef 14 3 (show $ pretty a)) + + +pattern PinnedRefBlob :: forall {c}. Text -> Text -> GitHash -> Syntax c +pattern PinnedRefBlob syn name hash <- ListVal [ SymbolVal "blob" + , SymbolVal (Id syn) + , LitStrVal name + , asGitHash -> Just hash + ] +{-# COMPLETE PinnedRefBlob #-} + +asGitHash :: forall c . Syntax c -> Maybe GitHash +asGitHash = \case + LitStrVal s -> fromStringMay (Text.unpack s) + _ -> Nothing + +repoPage :: (MonadIO m, DashBoardPerks m, MonadReader DashBoardEnv m) + => RepoPageTabs + -> LWWRefKey 'HBS2Basic + -> [(Text,Text)] + -> HtmlT m () +repoPage tab lww params = rootPage do + + it@RepoListItem{..} <- lift (selectRepoList ( mempty + & set repoListByLww (Just lww) + & set repoListLimit (Just 1)) + <&> listToMaybe + ) >>= orThrow (itemNotFound lww) + + sto <- asks _sto + mhead <- lift $ readRepoHeadFromTx sto (coerce rlRepoTx) + + let mbHead = snd <$> mhead + + (meta, manifest) <- lift $ parsedManifest it + + let author = headMay [ s | ListVal [ SymbolVal "author:", LitStrVal s ] <- meta ] + let public = headMay [ s | ListVal [ SymbolVal "public:", SymbolVal (Id s) ] <- meta ] + let pinned = [ (name,r) | ListVal [ SymbolVal "pinned:", r@(PinnedRefBlob _ name _) ] <- meta ] & take 5 + + debug $ red "META" <+> pretty meta + + main_ [class_ "container-fluid"] do + div_ [class_ "wrapper"] do + aside_ [class_ "sidebar"] do + + div_ [class_ "info-block" ] do + toHtml (ShortRef lww) + + -- div_ [class_ "info-block" ] do + -- a_ [ href_ "/"] do + -- span_ [class_ "inline-icon-wrapper"] $ svgIcon IconArrowUturnLeft + -- "back to projects" + + div_ [class_ "info-block" ] do + + summary_ [class_ "sidebar-title"] $ small_ $ strong_ "About" + ul_ [class_ "mb-0"] do + for_ author $ \a -> do + li_ $ small_ do + "Author: " + toHtml a + + for_ public $ \p -> do + li_ $ small_ do + "Public: " + toHtml p + + when (Text.length manifest > 100) do + li_ $ small_ do + a_ [class_ "secondary", href_ (toURL (RepoPage ManifestTab lww))] do + span_ [class_ "inline-icon-wrapper"] $ svgIcon IconLicense + "Manifest" + + when (rlRepoForks > 0) do + li_ $ small_ do + a_ [class_ "secondary" + , href_ "#" + , hxGet_ (toURL (RepoForksHtmx lww)) + , hxTarget_ "#repo-tab-data" + ] do + span_ [class_ "inline-icon-wrapper"] $ svgIcon IconGitFork + toHtml $ show rlRepoForks + " forks" + + li_ $ small_ do + a_ [class_ "secondary" + , href_ (toURL (RepoPage (CommitsTab Nothing) lww)) + ] do + span_ [class_ "inline-icon-wrapper"] $ svgIcon IconGitCommit + toHtml $ show rlRepoCommits + " commits" + + for_ pinned $ \(_,ref) -> do + case ref of + PinnedRefBlob s n hash -> small_ do + li_ $ a_ [class_ "secondary" + , href_ "#" + , hxGet_ (toURL (RepoSomeBlob lww s hash)) + , hxTarget_ "#repo-tab-data" + ] do + span_ [class_ "inline-icon-wrapper"] $ svgIcon IconPinned + toHtml (Text.take 12 n) + " " + toHtml $ ShortRef hash + + for_ mbHead $ \rh -> do + + let theHead = headMay [ v | (GitRef "HEAD", v) <- view repoHeadRefs rh ] + + let checkHead v what | v == theHead = strong_ what + | otherwise = what + + div_ [class_ "info-block" ] do + summary_ [class_ "sidebar-title"] $ small_ $ strong_ "Heads" + ul_ [class_ "mb-0"] $ do + for_ (view repoHeadHeads rh) $ \(branch,v) -> do + li_ $ small_ do + a_ [class_ "secondary", href_ (toURL (RepoPage (CommitsTab (Just v)) lww ))] do + checkHead (Just v) $ toHtml branch + + div_ [class_ "info-block" ] do + summary_ [class_ "sidebar-title"] $ small_ $ strong_ "Tags" + ul_ [class_ "mb-0"] $ do + for_ (view repoHeadTags rh) $ \(tag,v) -> do + li_ $ small_ do + a_ [class_ "secondary", href_ (toURL (RepoPage (CommitsTab (Just v)) lww ))] do + checkHead (Just v) $ toHtml tag + + div_ [class_ "content"] $ do + + article_ [class_ "py-0"] $ nav_ [ariaLabel_ "breadcrumb", class_ "repo-menu"] $ ul_ do + + let menuTabClasses isActive = if isActive then "tab contrast" else "tab" + menuTab t misc name = li_ do + a_ ([class_ $ menuTabClasses $ isActiveTab tab t] <> misc <> [tabClick]) do + name + + menuTab (CommitsTab Nothing) + [ href_ "#" + , hxGet_ (toURL (RepoCommits lww)) + , hxTarget_ "#repo-tab-data" + ] "commits" + + menuTab (TreeTab Nothing) + [ href_ "#" + , hxGet_ (toURL (RepoRefs lww)) + , hxTarget_ "#repo-tab-data" + ] "tree" + + section_ do + strong_ $ toHtml rlRepoName + + div_ [id_ "repo-tab-data"] do + + case tab of + + TreeTab{} -> do + + let tree = [ fromStringMay @GitHash (Text.unpack v) + | ("tree", v) <- params + ] & catMaybes & headMay + + maybe (repoRefs lww) (\t -> repoTree lww t t) tree + + ManifestTab -> do + thisRepoManifest it + + CommitsTab{} -> do + let predicate = Right (fromQueryParams params) + repoCommits lww predicate + + ForksTab -> do + repoForks lww + + div_ [id_ "repo-tab-data-embedded"] mempty diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index e309a75c..7b052e7a 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -6,7 +6,6 @@ version: 0.24.1.2 license: BSD-3-Clause license-file: LICENSE author: Dmitry Zuikov -maintainer: dzuikov@gmail.com -- copyright: category: System build-type: Simple @@ -100,7 +99,9 @@ library HBS2.Git.Local HBS2.Git.Local.CLI - HBS2.Git.Data.Tx + HBS2.Git.Data.Tx.Git + HBS2.Git.Data.Tx.Index + HBS2.Git.Data.RepoHead HBS2.Git.Data.GK HBS2.Git.Data.RefLog HBS2.Git.Data.LWWBlock @@ -124,6 +125,66 @@ library hs-source-dirs: hbs2-git-client-lib +library hbs2-git-dashboard-assets + import: shared-properties + + build-depends: + base, file-embed, lucid, text + + exposed-modules: + HBS2.Git.Web.Assets + + hs-source-dirs: hbs2-git-dashboard-assets + + default-language: GHC2021 + + +executable hbs2-git-dashboard + import: shared-properties + main-is: GitDashBoard.hs + + other-modules: + HBS2.Git.DashBoard.Prelude + HBS2.Git.DashBoard.Types + HBS2.Git.DashBoard.State + HBS2.Git.DashBoard.State.Commits + HBS2.Git.DashBoard.State.Index + HBS2.Git.DashBoard.State.Index.Channels + HBS2.Git.DashBoard.State.Index.Peer + HBS2.Git.Web.Html.Root + + -- other-extensions: + build-depends: + base, hbs2-git-dashboard-assets, hbs2-peer, hbs2-git, suckless-conf + , fuzzy-parse + , binary + , generic-deriving + , generic-data + , deriving-compat + , vector + , optparse-applicative + , http-types + , file-embed + , network-uri + , wai + , wai-extra + , wai-middleware-static + , wai-middleware-static-embedded + , lucid + , lucid-htmx + , pandoc + , skylighting + , skylighting-core + , skylighting-lucid + , scotty >= 0.21 + + hs-source-dirs: + hbs2-git-dashboard + hbs2-git-dashboard/src + + default-language: GHC2021 + + executable hbs2-git-subscribe import: shared-properties main-is: Main.hs diff --git a/hbs2-keyman/app/Main.hs b/hbs2-keyman/app/Main.hs index bff2be16..78eadea5 100644 --- a/hbs2-keyman/app/Main.hs +++ b/hbs2-keyman/app/Main.hs @@ -33,13 +33,15 @@ type Command m = m () globalOptions :: Parser GlobalOptions globalOptions = pure GlobalOptions -type AppPerks m = (MonadIO m, MonadUnliftIO m, MonadReader AppEnv m, HasConf m, SerialisedCredentials HBS2Basic) +type AppPerks m = (MonadIO m, MonadUnliftIO m, MonadReader AppEnv m, HasConf m, SerialisedCredentials 'HBS2Basic) + +-- TODO: key-mamagement-command-about-to-move-here --- Парсер для команд commands :: (AppPerks m) => Parser (Command m) commands = hsubparser ( command "update" (O.info (updateKeys <**> helper) (progDesc "update keys" )) <> command "list" (O.info (listKeysCmd <**> helper) (progDesc "list keys" )) + <> command "disclose" (O.info (discloseKeyCmd <**> helper) (progDesc "disclose credentials" )) <> command "set-weight" (O.info (setWeightCmd <**> helper) (progDesc "set weight for a key")) <> command "add-mask" (O.info (addPath <**> helper) (progDesc "add path/mask to search keys, ex. '/home/user/keys/*.key'")) <> command "config" (O.info (showConfig <**> helper) (progDesc "show hbs2-keyman config")) @@ -93,7 +95,7 @@ updateKeys = do bs <- liftIO $ BS.readFile fn - krf <- parseCredentials @HBS2Basic (AsCredFile bs) & toMPlus + krf <- parseCredentials @'HBS2Basic (AsCredFile bs) & toMPlus let skp = view peerSignPk krf @@ -116,6 +118,12 @@ setWeightCmd = do pure do withState $ updateKeyWeight k v +discloseKeyCmd :: (AppPerks m) => Parser (Command m) +discloseKeyCmd = do + -- k <- argument str (metavar "KEY" <> help "Key identifier") + -- v <- argument auto (metavar "WEIGHT" <> help "Weight value") + pure do + notice "WIP" main :: IO () main = do diff --git a/hbs2-keyman/hbs2-keyman.cabal b/hbs2-keyman/hbs2-keyman.cabal index d80897a2..f983c78f 100644 --- a/hbs2-keyman/hbs2-keyman.cabal +++ b/hbs2-keyman/hbs2-keyman.cabal @@ -115,9 +115,9 @@ executable hbs2-keyman -- other-modules: -- other-extensions: build-depends: - base, - hbs2-keyman, - optparse-applicative + base + , hbs2-keyman + , optparse-applicative hs-source-dirs: app default-language: GHC2021 diff --git a/hbs2-keyman/src/HBS2/KeyMan/Config.hs b/hbs2-keyman/src/HBS2/KeyMan/Config.hs index 6d71bc8d..c2089ef1 100644 --- a/hbs2-keyman/src/HBS2/KeyMan/Config.hs +++ b/hbs2-keyman/src/HBS2/KeyMan/Config.hs @@ -14,6 +14,7 @@ import Data.Config.Suckless import System.Directory import System.FilePath import Control.Exception +import Data.Text.IO qualified as Text import Data.Either import Data.Set (Set) @@ -32,12 +33,12 @@ getStatePath = liftIO (getXdgDirectory XdgData keymanAppName) <&> ( "state.db readConfig :: MonadIO m => m [Syntax C] readConfig = do - liftIO $ try @IOError (getConfigPath >>= readFile) + liftIO $ try @IOError (getConfigPath >>= Text.readFile) <&> fromRight "" <&> parseTop <&> fromRight mempty -instance HasConf m => HasCfgKey KeyFilesOpt (Set String) m where +instance HasCfgKey KeyFilesOpt (Set String) where key = "key-files" diff --git a/hbs2-keyman/src/HBS2/KeyMan/Keys/Direct.hs b/hbs2-keyman/src/HBS2/KeyMan/Keys/Direct.hs index e7ed852f..c06d6a1a 100644 --- a/hbs2-keyman/src/HBS2/KeyMan/Keys/Direct.hs +++ b/hbs2-keyman/src/HBS2/KeyMan/Keys/Direct.hs @@ -7,6 +7,7 @@ import HBS2.KeyMan.Config import HBS2.Prelude.Plated import HBS2.Net.Auth.Credentials +import HBS2.Net.Auth.GroupKeySymm as Symm import HBS2.Net.Proto.Types @@ -17,10 +18,12 @@ import UnliftIO import DBPipe.SQLite import Text.InterpolatedString.Perl6 (qc) import Data.Maybe +import Data.HashMap.Strict qualified as HM import Control.Monad.Trans.Maybe import Data.List qualified as List import Data.ByteString qualified as BS import Data.Ord +import Streaming.Prelude qualified as S data KeyManClientError = KeyManClientSomeError @@ -51,16 +54,19 @@ runKeymanClient action = do loadCredentials :: forall a m . ( MonadIO m , SomePubKeyPerks a - , SerialisedCredentials HBS2Basic + , SerialisedCredentials 'HBS2Basic ) => a - -> KeyManClient m (Maybe (PeerCredentials HBS2Basic)) + -> KeyManClient m (Maybe (PeerCredentials 'HBS2Basic)) loadCredentials k = KeyManClient do fnames <- select @(Only FilePath) [qc| select f.file - from keytype t join keyfile f on t.key = f.key + from keytype t + join keyfile f on t.key = f.key + left join keyweight w on w.key = f.key where t.key = ? and t.type = 'sign' + order by w.weight desc nulls last limit 1 |] (Only (SomePubKey k)) runMaybeT do @@ -71,10 +77,10 @@ loadCredentials k = KeyManClient do loadKeyRingEntry :: forall m . ( MonadIO m - , SerialisedCredentials HBS2Basic + , SerialisedCredentials 'HBS2Basic ) - => PubKey 'Encrypt HBS2Basic - -> KeyManClient m (Maybe (KeyringEntry HBS2Basic)) + => PubKey 'Encrypt 'HBS2Basic + -> KeyManClient m (Maybe (KeyringEntry 'HBS2Basic)) loadKeyRingEntry pk = KeyManClient do runMaybeT do fn <- toMPlus =<< lift (selectKeyFile pk) @@ -87,10 +93,10 @@ loadKeyRingEntry pk = KeyManClient do loadKeyRingEntries :: forall m . ( MonadIO m - , SerialisedCredentials HBS2Basic + , SerialisedCredentials 'HBS2Basic ) - => [PubKey 'Encrypt HBS2Basic] - -> KeyManClient m [(Word, KeyringEntry HBS2Basic)] + => [PubKey 'Encrypt 'HBS2Basic] + -> KeyManClient m [(Word, KeyringEntry 'HBS2Basic)] loadKeyRingEntries pks = KeyManClient do r <- for pks $ \pk -> runMaybeT do fn <- lift (selectKeyFile pk) >>= toMPlus @@ -103,3 +109,16 @@ loadKeyRingEntries pks = KeyManClient do ] pure $ catMaybes r & List.sortOn (Down . fst) + +extractGroupKeySecret :: MonadIO m + => GroupKey 'Symm 'HBS2Basic + -> KeyManClient m (Maybe GroupSecret) +extractGroupKeySecret gk = do + r <- S.toList_ do + forM_ (HM.toList $ recipients gk) $ \(pk,box) -> runMaybeT do + (KeyringEntry ppk ssk _) <- MaybeT $ lift $ loadKeyRingEntry pk + let s = Symm.lookupGroupKey @'HBS2Basic ssk ppk gk + for_ s $ lift . S.yield + + pure $ headMay r + diff --git a/hbs2-peer/app/BlockDownload.hs b/hbs2-peer/app/BlockDownload.hs index d67f2472..d730ac0f 100644 --- a/hbs2-peer/app/BlockDownload.hs +++ b/hbs2-peer/app/BlockDownload.hs @@ -730,12 +730,13 @@ blockDownloadLoop env0 = do updatePeerInfo False p pinfo -processBlock :: forall e m . ( MonadIO m - , HasStorage m - , MyPeer e - , ForSignedBox e - , HasPeerLocator e (BlockDownloadM e m) - ) +processBlock :: forall e s m . ( MonadIO m + , HasStorage m + , MyPeer e + , ForSignedBox s + , s ~ Encryption e + , HasPeerLocator e (BlockDownloadM e m) + ) => Hash HbSync -> BlockDownloadM e m () @@ -820,7 +821,7 @@ processBlock h = do bs <- MaybeT $ pure block -- TODO: check-if-we-somehow-trust-this-key - (pk, BundleRefSimple ref) <- MaybeT $ pure $ deserialiseOrFail @(BundleRefValue e) bs + (pk, BundleRefSimple ref) <- MaybeT $ pure $ deserialiseOrFail @(BundleRefValue s) bs & either (const Nothing) unboxBundleRef debug $ "GOT BundleRefValue" <+> parens (pretty ref) diff --git a/hbs2-peer/app/Bootstrap.hs b/hbs2-peer/app/Bootstrap.hs index 5122f115..601a20b7 100644 --- a/hbs2-peer/app/Bootstrap.hs +++ b/hbs2-peer/app/Bootstrap.hs @@ -28,10 +28,10 @@ data PeerDnsBootStrapKey data PeerKnownPeer -instance Monad m => HasCfgKey PeerDnsBootStrapKey (Set String) m where +instance HasCfgKey PeerDnsBootStrapKey (Set String) where key = "bootstrap-dns" -instance Monad m => HasCfgKey PeerKnownPeer (Set String) m where +instance HasCfgKey PeerKnownPeer (Set String) where key = "known-peer" -- FIXME: tcp-addr-support-bootstrap diff --git a/hbs2-peer/app/Brains.hs b/hbs2-peer/app/Brains.hs index 2348788a..abb40bbd 100644 --- a/hbs2-peer/app/Brains.hs +++ b/hbs2-peer/app/Brains.hs @@ -68,7 +68,7 @@ instance FromField HashRef where fromField = fmap fromString . fromField @String -instance Monad m => HasCfgKey PeerBrainsDb (Maybe String) m where +instance HasCfgKey PeerBrainsDb (Maybe String) where key = "brains" newtype CommitCmd = CommitCmd { onCommited :: IO () } @@ -256,6 +256,22 @@ instance ( Hashable (Peer e) where postprocess = mapMaybe (\(r,t,i) -> (,t,i) <$> fromStringMay r ) + listPolledRefsFiltered brains (t, p) = liftIO do + debug $ red "brains: listPolledRefsFiltered" <+> pretty (t,p) + let conn = view brainsDb brains + let sql = [qc| + select ref, type, interval + from {poll_table} + where coalesce(type = ?, true) + limit ? + offset ? + |] + query conn sql (t, lim, off ) <&> postprocess + where + postprocess = mapMaybe (\(r,t1,i) -> (,t1,i) <$> fromStringMay r ) + off = maybe 0 fst p + lim = maybe 1000 snd p + isPolledRef brains tp ref = do cached <- liftIO $ readTVarIO (_brainsPolled brains) <&> HashSet.member (ref,tp) @@ -921,7 +937,7 @@ newBasicBrains cfg = liftIO do data PeerDownloadsDelOnStart -instance Monad m => HasCfgKey PeerDownloadsDelOnStart b m where +instance HasCfgKey PeerDownloadsDelOnStart b where key = "downloads-del-on-start" {- HLINT ignore "Use camelCase" -} diff --git a/hbs2-peer/app/CLI/Common.hs b/hbs2-peer/app/CLI/Common.hs index ca1345ad..fc0be486 100644 --- a/hbs2-peer/app/CLI/Common.hs +++ b/hbs2-peer/app/CLI/Common.hs @@ -61,5 +61,5 @@ pRpcCommon = do RPCOpt <$> optional confOpt <*> optional rpcOpt -pPubKey :: ReadM (PubKey 'Sign HBS2Basic) +pPubKey :: ReadM (PubKey 'Sign 'HBS2Basic) pPubKey = maybeReader fromStringMay diff --git a/hbs2-peer/app/CLI/LWWRef.hs b/hbs2-peer/app/CLI/LWWRef.hs index ab97e95b..19fb55fc 100644 --- a/hbs2-peer/app/CLI/LWWRef.hs +++ b/hbs2-peer/app/CLI/LWWRef.hs @@ -5,7 +5,6 @@ import HBS2.OrDie import HBS2.Net.Proto.Service import HBS2.Net.Auth.Credentials import HBS2.Data.Types.SignedBox -import HBS2.Net.Auth.Schema import HBS2.Peer.Proto.LWWRef import HBS2.Peer.RPC.API.LWWRef @@ -35,8 +34,8 @@ pLwwRefFetch = do Left e -> err (viaShow e) >> exitFailure Right{} -> pure () -lwwRef :: ReadM (LWWRefKey HBS2Basic) -lwwRef = maybeReader (fromStringMay @(LWWRefKey HBS2Basic)) +lwwRef :: ReadM (LWWRefKey 'HBS2Basic) +lwwRef = maybeReader (fromStringMay @(LWWRefKey 'HBS2Basic)) pLwwRefGet :: Parser (IO ()) pLwwRefGet = do @@ -69,7 +68,7 @@ pLwwRefUpdate = do Right Nothing -> err ("not found value for" <+> pretty ref) >> exitFailure Right (Just r) -> pure $ succ (lwwSeq r) - let box = makeSignedBox @L4Proto pk sk (LWWRef @L4Proto seq val Nothing) + let box = makeSignedBox pk sk (LWWRef seq val Nothing) callService @RpcLWWRefUpdate caller box >>= \case Left e -> err (viaShow e) >> exitFailure Right r -> print $ pretty r diff --git a/hbs2-peer/app/CLI/RefChan.hs b/hbs2-peer/app/CLI/RefChan.hs index eac1cf77..807dc7f9 100644 --- a/hbs2-peer/app/CLI/RefChan.hs +++ b/hbs2-peer/app/CLI/RefChan.hs @@ -3,11 +3,11 @@ module CLI.RefChan where import HBS2.Prelude.Plated import HBS2.Hash +import HBS2.Base58 import HBS2.Net.Auth.Credentials import HBS2.Net.Auth.Credentials.Sigil import HBS2.Merkle import HBS2.Peer.Proto.RefChan -import HBS2.Net.Proto.Types import HBS2.Data.Types.Refs import HBS2.Actors.Peer.Types import HBS2.Data.Types.SignedBox @@ -38,6 +38,7 @@ import Data.ByteString.Lazy qualified as LBS import Data.ByteString qualified as BS import Data.HashSet qualified as HashSet import Data.Maybe +import Data.Coerce import Lens.Micro.Platform import Options.Applicative import System.Exit @@ -47,7 +48,7 @@ import UnliftIO pRefChan :: Parser (IO ()) -pRefChan = hsubparser ( command "head" (info pRefChanHead (progDesc "head commands" )) +pRefChan = hsubparser ( command "head" (info pRefChanHead (progDesc "head commands" )) <> command "propose" (info pRefChanPropose (progDesc "post propose transaction")) <> command "notify" (info pRefChanNotify (progDesc "post notify message")) <> command "fetch" (info pRefChanFetch (progDesc "fetch and sync refchan value")) @@ -76,16 +77,54 @@ pRefChanHeadGen = do s <- maybe1 fn getContents readFile hd <- pure (fromStringMay @(RefChanHeadBlock L4Proto) s) `orDie` "can't generate head block" - let qq = makeSignedBox @L4Proto @(RefChanHeadBlock L4Proto) (view peerSignPk creds) (view peerSignSk creds) hd + let qq = makeSignedBox @'HBS2Basic (view peerSignPk creds) (view peerSignSk creds) hd LBS.putStr (serialise qq) +data HeadDumpOpts = HeadDumpRef (RefChanId L4Proto) + | HeadDumpFile FilePath + pRefChanHeadDump :: Parser (IO ()) pRefChanHeadDump= do - fn <- optional $ strArgument (metavar "refchan head blob") - pure $ do - lbs <- maybe1 fn LBS.getContents LBS.readFile - (_, hdblk) <- pure (unboxSignedBox @(RefChanHeadBlock L4Proto) @L4Proto lbs) `orDie` "can't unbox signed box" - print $ pretty hdblk + opts <- pRpcCommon + + what <- optional $ HeadDumpRef <$> argument pRefChanId (metavar "REFCHAN-KEY") + <|> HeadDumpFile <$> strOption (short 'f' <> long "file" + <> metavar "FILE" + <> help "read from file") + + pure $ flip runContT pure do + + lbs <- case what of + Nothing -> lift $ LBS.getContents + Just (HeadDumpFile f) -> lift $ LBS.readFile f + Just (HeadDumpRef r) -> do + + client <- ContT $ withRPCMessaging opts + + self <- runReaderT (ownPeer @UNIX) client + refChanAPI <- makeServiceCaller @RefChanAPI self + storageAPI <- makeServiceCaller @StorageAPI self + + let endpoints = [ Endpoint @UNIX refChanAPI + , Endpoint @UNIX storageAPI + ] + + void $ ContT $ bracket (async $ runReaderT (runServiceClientMulti endpoints) client) cancel + + rv <- lift (callRpcWaitMay @RpcRefChanHeadGet (TimeoutSec 1) refChanAPI r) + >>= orThrowUser "rpc error" + >>= orThrowUser "refchan head value not found" + + liftIO $ print (pretty rv) + + let sto = AnyStorage (StorageClient storageAPI) + runExceptT (readFromMerkle sto (SimpleKey (coerce rv))) + >>= orThrowUser "can't decode refchan head " + + + (pk, hdblk) <- pure (unboxSignedBox @(RefChanHeadBlock L4Proto) @'HBS2Basic lbs) `orDie` "can't unbox signed box" + liftIO $ print $ + (semi <+> "refchan" <+> pretty (AsBase58 pk)) <> line <> pretty hdblk pRefChanHeadPost :: Parser (IO ()) @@ -130,7 +169,7 @@ pRefChanPropose = do lbs <- maybe1 fn LBS.getContents LBS.readFile - let box = makeSignedBox @L4Proto @BS.ByteString (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict lbs) + let box = makeSignedBox (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict lbs) if dry then do LBS.putStr (serialise box) @@ -178,15 +217,15 @@ pRefChanNotifyPost = do -- caller <- ContT $ withMyRPC @RefChanAPI opts - sigil <- liftIO $ (BS.readFile si <&> parseSerialisableFromBase58 @(Sigil L4Proto)) + sigil <- liftIO $ (BS.readFile si <&> parseSerialisableFromBase58) `orDie` "parse sigil failed" - (auPk, sd) <- pure (unboxSignedBox0 @(SigilData L4Proto) (sigilData sigil)) + (auPk, sd) <- pure (unboxSignedBox0 (sigilData sigil)) >>= orThrowUser "malformed sigil/bad signature" keys <- liftIO $ runKeymanClient do creds <- loadCredentials auPk >>= orThrowUser "can't load credentials" - encKey <- loadKeyRingEntry (sigilDataEncKey sd) + encKey <- loadKeyRingEntry (sigilDataEncKey @'HBS2Basic sd) pure (creds,encKey) let creds = view _1 keys @@ -253,7 +292,7 @@ pRefChanNotifyPost = do gks <- runExceptT (readFromMerkle sto (SimpleKey gkv)) >>= toMPlus - gk <- deserialiseOrFail @(GroupKey 'Symm HBS2Basic) gks + gk <- deserialiseOrFail @(GroupKey 'Symm 'HBS2Basic) gks & toMPlus notice $ "found GK0" <+> pretty gkv @@ -263,7 +302,7 @@ pRefChanNotifyPost = do gk <- case mgk of Just x -> pure x Nothing -> do - gknew <- generateGroupKey @HBS2Basic Nothing (HashSet.toList rcpts) + gknew <- generateGroupKey @'HBS2Basic Nothing (HashSet.toList rcpts) gkh <- writeAsMerkle sto (serialise gknew) @@ -281,7 +320,7 @@ pRefChanNotifyPost = do -- FIXME: use-deterministic-nonce lift $ encryptBlock sto gks (Right gk) Nothing lbs <&> serialise - let box = makeSignedBox @L4Proto @BS.ByteString (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict ss) + let box = makeSignedBox (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict ss) void $ callService @RpcRefChanNotify refChanAPI (puk, box) where @@ -368,7 +407,7 @@ pRefChanGK = do let readers = view refChanHeadReaders' hd - gk <- generateGroupKey @HBS2Basic Nothing (HashSet.toList readers) + gk <- generateGroupKey @'HBS2Basic Nothing (HashSet.toList readers) liftIO $ print $ pretty (AsGroupKeyFile gk) diff --git a/hbs2-peer/app/CheckBlockAnnounce.hs b/hbs2-peer/app/CheckBlockAnnounce.hs index ffcde038..2450de35 100644 --- a/hbs2-peer/app/CheckBlockAnnounce.hs +++ b/hbs2-peer/app/CheckBlockAnnounce.hs @@ -13,8 +13,8 @@ import HBS2.Net.Proto.Types import PeerTypes import PeerConfig import CheckPeer (peerBanned) -import BlockDownload -import DownloadQ +import BlockDownload() +import DownloadQ() import Control.Monad.Trans.Maybe import Control.Monad.Reader @@ -38,7 +38,7 @@ instance Pretty AcceptAnnounce where -instance Monad m => HasCfgKey PeerAcceptAnnounceKey AcceptAnnounce m where +instance HasCfgKey PeerAcceptAnnounceKey AcceptAnnounce where key = "accept-block-announce" instance (Monad m, HasConf m) => HasCfgValue PeerAcceptAnnounceKey AcceptAnnounce m where @@ -51,7 +51,7 @@ instance (Monad m, HasConf m) => HasCfgValue PeerAcceptAnnounceKey AcceptAnnounc catMaybes [ fromStringMay @(PubKey 'Sign (Encryption L4Proto)) (Text.unpack e) | ListVal (Key s [LitStrVal e]) <- syn, s == kk ] - kk = key @PeerAcceptAnnounceKey @AcceptAnnounce @m + kk = key @PeerAcceptAnnounceKey @AcceptAnnounce acceptAnnouncesFromPeer :: forall e m . ( MonadIO m diff --git a/hbs2-peer/app/CheckPeer.hs b/hbs2-peer/app/CheckPeer.hs index c5edf61e..53af1fc9 100644 --- a/hbs2-peer/app/CheckPeer.hs +++ b/hbs2-peer/app/CheckPeer.hs @@ -16,10 +16,10 @@ import Lens.Micro.Platform data PeerBlackListKey data PeerWhiteListKey -instance Monad m => HasCfgKey PeerBlackListKey (Set String) m where +instance HasCfgKey PeerBlackListKey (Set String) where key = "blacklist" -instance Monad m => HasCfgKey PeerWhiteListKey (Set String) m where +instance HasCfgKey PeerWhiteListKey (Set String) where key = "whitelist" peerBanned :: forall e m . ( Monad m diff --git a/hbs2-peer/app/HttpWorker.hs b/hbs2-peer/app/HttpWorker.hs index eb5ce9f7..6677f4e9 100644 --- a/hbs2-peer/app/HttpWorker.hs +++ b/hbs2-peer/app/HttpWorker.hs @@ -34,11 +34,14 @@ import Data.Either import Codec.Serialise (deserialiseOrFail) import Data.Aeson (object, (.=)) import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.Text qualified as Text import Control.Monad.Reader import Lens.Micro.Platform (view) import System.FilePath import Control.Monad.Except +import Control.Monad.Trans.Maybe import Control.Monad.Trans.Cont +import Data.Coerce import UnliftIO (async) @@ -46,11 +49,29 @@ import UnliftIO (async) -- TODO: introduce-http-of-off-feature -extractMetadataHash :: Hash HbSync -> LBS.ByteString -> Maybe (Hash HbSync) -extractMetadataHash what blob = - case tryDetect what blob of - MerkleAnn (MTreeAnn {_mtaMeta = AnnHashRef h, _mtaCrypt = NullEncryption}) -> Just h - _ -> Nothing +extractMetadataHash :: MonadIO m + => AnyStorage + -> HashRef + -> m (Maybe [Syntax C]) + +extractMetadataHash sto what = runMaybeT do + + blob <- getBlock sto (coerce what) + >>= toMPlus + + case tryDetect (coerce what) blob of + MerkleAnn (MTreeAnn {_mtaMeta = AnnHashRef h, _mtaCrypt = NullEncryption}) -> do + + getBlock sto h + >>= toMPlus + <&> LBS8.unpack + <&> fromRight mempty . parseTop + + + MerkleAnn (MTreeAnn {_mtaMeta = ShortMetadata txt, _mtaCrypt = NullEncryption}) -> do + parseTop (Text.unpack txt) & toMPlus + + _ -> mzero orElse :: m r -> Maybe a -> ContT r m a orElse a mb = ContT $ maybe1 mb a @@ -76,8 +97,8 @@ httpWorker (PeerConfig syn) pmeta e = do scotty port $ do middleware logStdout - defaultHandler $ const do - status status500 + -- defaultHandler do + -- status status500 get "/size/:hash" do @@ -93,16 +114,16 @@ httpWorker (PeerConfig syn) pmeta e = do get "/ref/:key" do void $ flip runContT pure do - what <- lift (param @String "key" <&> fromStringMay @(LWWRefKey HBS2Basic)) + what <- lift (param @String "key" <&> fromStringMay @(LWWRefKey s)) >>= orElse (status status404) rv <- getRef sto what >>= orElse (status status404) >>= getBlock sto >>= orElse (status status404) - <&> either (const Nothing) Just . deserialiseOrFail @(SignedBox (LWWRef e) e) + <&> either (const Nothing) Just . deserialiseOrFail @(SignedBox (LWWRef s) s) >>= orElse (status status404) - <&> unboxSignedBox0 @(LWWRef e) + <&> unboxSignedBox0 @(LWWRef s) >>= orElse (status status404) <&> lwwValue . snd @@ -174,15 +195,10 @@ httpWorker (PeerConfig syn) pmeta e = do getTreeHash :: AnyStorage -> HashRef -> ActionM () getTreeHash sto what' = void $ flip runContT pure do - blob <- liftIO (getBlock sto what) + + meta <- extractMetadataHash sto what' >>= orElse (status status404) - mh <- orElse (status status404) (extractMetadataHash what blob) - - meta <- lift (getBlock sto mh) >>= orElse (status status404) - <&> LBS8.unpack - <&> fromRight mempty . parseTop - let tp = headDef "application/octet-stream" [ show (pretty w) | ListVal [SymbolVal "mime-type:", LitStrVal w] <- meta diff --git a/hbs2-peer/app/PeerConfig.hs b/hbs2-peer/app/PeerConfig.hs index be90ff3a..49bbe8d1 100644 --- a/hbs2-peer/app/PeerConfig.hs +++ b/hbs2-peer/app/PeerConfig.hs @@ -42,35 +42,35 @@ data PeerBrainsDBPath instance Monad m => HasConf (ReaderT PeerConfig m) where getConf = asks (\(PeerConfig syn) -> syn) -instance Monad m => HasCfgKey PeerListenTCPKey (Maybe String) m where +instance HasCfgKey PeerListenTCPKey (Maybe String) where key = "listen-tcp" -instance Monad m => HasCfgKey PeerHttpPortKey (Maybe Integer) m where +instance HasCfgKey PeerHttpPortKey (Maybe Integer) where key = "http-port" -instance Monad m => HasCfgKey PeerTcpProbeWaitKey (Maybe Integer) m where +instance HasCfgKey PeerTcpProbeWaitKey (Maybe Integer) where key = "tcp-probe-wait" -instance Monad m => HasCfgKey PeerUseHttpDownload b m where +instance HasCfgKey PeerUseHttpDownload b where key = "http-download" -instance Monad m => HasCfgKey PeerBrainsDBPath b m where +instance HasCfgKey PeerBrainsDBPath b where key = "brains-db" -instance Monad m => HasCfgKey PeerDownloadLogKey (Maybe String) m where +instance HasCfgKey PeerDownloadLogKey (Maybe String) where key = "download-log" data PeerKnownPeersFile -instance Monad m => HasCfgKey PeerKnownPeersFile (Set String) m where +instance HasCfgKey PeerKnownPeersFile (Set String) where key = "known-peers-file" -instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a b m) => HasCfgValue a FeatureSwitch m where +instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a b) => HasCfgValue a FeatureSwitch m where cfgValue = lastDef FeatureOff . val <$> getConf where val syn = [ if e == "on" then FeatureOn else FeatureOff - | ListVal (Key s [SymbolVal e]) <- syn, s == key @a @b @m + | ListVal (Key s [SymbolVal e]) <- syn, s == key @a @b ] cfgName :: FilePath @@ -126,7 +126,7 @@ peerConfigInit mbfp = liftIO do appendFile cfgPath ";; hbs2-peer config file" appendFile cfgPath defConfigData - cred0 <- newCredentials @HBS2Basic + cred0 <- newCredentials @'HBS2Basic let keyname = "default.key" let keypath = dirkeyname diff --git a/hbs2-peer/app/PeerInfo.hs b/hbs2-peer/app/PeerInfo.hs index 952d8ebf..f2c5940f 100644 --- a/hbs2-peer/app/PeerInfo.hs +++ b/hbs2-peer/app/PeerInfo.hs @@ -41,7 +41,7 @@ import UnliftIO data PeerPingIntervalKey -- TODO: ping-interval-specifically-for-peer -instance Monad m => HasCfgKey PeerPingIntervalKey (Maybe Integer) m where +instance HasCfgKey PeerPingIntervalKey (Maybe Integer) where key = "ping-interval" diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 9d85bd0d..f5e8106c 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -145,34 +145,34 @@ data PeerTcpSOCKS5 data PeerDownloadThreadKey -instance Monad m => HasCfgKey PeerDebugKey a m where +instance HasCfgKey PeerDebugKey a where key = "debug" -instance Monad m => HasCfgKey PeerTraceKey a m where +instance HasCfgKey PeerTraceKey a where key = "trace" -instance Monad m => HasCfgKey PeerTrace1Key a m where +instance HasCfgKey PeerTrace1Key a where key = "trace1" -instance Monad m => HasCfgKey PeerListenKey (Maybe String) m where +instance HasCfgKey PeerListenKey (Maybe String) where key = "listen" -instance Monad m => HasCfgKey PeerKeyFileKey (Maybe String) m where +instance HasCfgKey PeerKeyFileKey (Maybe String) where key = "key" -instance Monad m => HasCfgKey PeerStorageKey (Maybe String) m where +instance HasCfgKey PeerStorageKey (Maybe String) where key = "storage" -instance Monad m => HasCfgKey PeerProxyFetchKey (Set String) m where +instance HasCfgKey PeerProxyFetchKey (Set String) where key = "proxy-fetch-for" -- NOTE: socks5-auth -- Network.Simple.TCP does not support -- SOCKS5 authentification -instance Monad m => HasCfgKey PeerTcpSOCKS5 (Maybe String) m where +instance HasCfgKey PeerTcpSOCKS5 (Maybe String) where key = "tcp.socks5" -instance Monad m => HasCfgKey PeerDownloadThreadKey (Maybe Int) m where +instance HasCfgKey PeerDownloadThreadKey (Maybe Int) where key = "download-threads" data PeerOpts = @@ -284,7 +284,7 @@ runCLI = do pVersion = pure do LBS.putStr $ Aeson.encode $(inlineBuildVersion Pkg.version) - pPubKeySign = maybeReader (fromStringMay @(PubKey 'Sign HBS2Basic)) + pPubKeySign = maybeReader (fromStringMay @(PubKey 'Sign 'HBS2Basic)) pRun = do runPeer <$> common @@ -586,7 +586,7 @@ runCLI = do void $ runMaybeT do void $ callService @RpcPerformGC caller () - refP :: ReadM (PubKey 'Sign HBS2Basic) + refP :: ReadM (PubKey 'Sign 'HBS2Basic) refP = maybeReader fromStringMay hashP :: ReadM HashRef @@ -1124,7 +1124,7 @@ runPeer opts = Exception.handle (\e -> myException e blk1 <- liftIO $ getBlock sto ha maybe1 blk1 none S.yield - let box = deserialiseOrFail @(SignedBox (RefChanHeadBlock e) e) (LBS.concat chunks) + let box = deserialiseOrFail @(SignedBox (RefChanHeadBlock e) s) (LBS.concat chunks) case box of -- FIXME: proper-error-handling diff --git a/hbs2-peer/app/PeerMain/DialogCliCommand.hs b/hbs2-peer/app/PeerMain/DialogCliCommand.hs deleted file mode 100644 index 18fd279a..00000000 --- a/hbs2-peer/app/PeerMain/DialogCliCommand.hs +++ /dev/null @@ -1,255 +0,0 @@ -{-# LANGUAGE StrictData #-} - -module PeerMain.DialogCliCommand where - -import Data.Generics.Labels -import Data.Generics.Product.Fields -import HBS2.Actors.Peer -import HBS2.Hash -import HBS2.Net.IP.Addr -import HBS2.Net.Messaging.UDP -import HBS2.Net.Proto -import HBS2.Net.Proto.Dialog -import HBS2.OrDie -import HBS2.Prelude -import HBS2.System.Logger.Simple hiding (info) - -import PeerConfig -import RPC (PeerRpcKey, RpcM, runRPC) - -import Control.Monad.Except (Except(..), ExceptT(..), runExcept, runExceptT) -import Control.Monad.State.Strict (evalStateT) -import Control.Monad.Trans.Cont -import Data.Default -import Data.Function -import Data.Functor -import Data.Kind -import Data.List qualified as List -import Data.String.Conversions as X (cs) -import Data.Void (absurd, Void) -import Lens.Micro.Platform -import Network.Socket -import Options.Applicative -import Streaming.Prelude qualified as S -import System.IO -import UnliftIO.Async -import UnliftIO.Concurrent -import UnliftIO.Exception as U -import UnliftIO.Resource - - -pDialog :: Parser (IO ()) -pDialog = hsubparser $ mempty - <> command "ping" (info pPing (progDesc "ping hbs2 node via dialog inteface") ) - <> command "debug" (info pDebug (progDesc "debug call different dialog inteface routes") ) - <> command "reflog" (info pReflog (progDesc "reflog commands") ) - -pReflog :: Parser (IO ()) -pReflog = hsubparser $ mempty - <> command "get" (info pRefLogGet (progDesc "get own reflog from all" )) - <> command "fetch" (info pRefLogFetch (progDesc "fetch reflog from all" )) - -confOpt :: Parser FilePath -confOpt = strOption ( long "config" <> short 'c' <> help "config" ) - -newtype OptInitial (f :: Type -> Type) a b = OptInitial { unOptInitial :: f a } - deriving (Generic, Show) - -newtype OptResolved (f :: Type -> Type) a b = OptResolved { unOptResolved :: b } - deriving (Generic, Show) - -type DialOptInitial = DialOpt OptInitial -type DialOptResolved = DialOpt OptResolved - -data DialOpt (f :: (Type -> Type) -> Type -> Type -> Type) = DialOpt - { dialOptConf :: f Maybe FilePath PeerConfig - , dialOptAddr :: f Maybe String (Peer L4Proto) - } - deriving (Generic) - -deriving instance Show DialOptInitial - -pDialCommon :: Parser DialOptInitial -pDialCommon = do - - dialOptConf <- OptInitial <$> optional do - strOption ( long "config" <> short 'c' <> help "config" ) - - dialOptAddr <- OptInitial <$> optional do - strOption ( short 'r' <> long "dial" <> help "addr:port" ) - - pure DialOpt {..} - -resolveDialOpt :: DialOptInitial -> IO DialOptResolved -resolveDialOpt dopt = do - config <- peerConfigRead (dopt ^. #dialOptConf . #unOptInitial) - - let dialConf = cfgValue @PeerRpcKey config :: Maybe String - - saddr <- (dopt ^. #dialOptAddr . #unOptInitial <|> dialConf) - `orDieM` "Dial endpoint not set" - - as <- parseAddrUDP (cs saddr) <&> fmap (fromSockAddr @'UDP . addrAddress) - peer <- headMay (List.sortBy (compare `on` addrPriority) as) - `orDieM` "Can't parse Dial endpoint" - - pure DialOpt - { dialOptConf = OptResolved config - , dialOptAddr = OptResolved peer - } - -pPing :: Parser (IO ()) -pPing = do - dopt <- pDialCommon - pure $ withDial dopt \peer dclient -> - withClient dclient \cli -> do - liftIO . print =<< do - dQuery1 def cli peer (dpath "ping" []) - -reflogKeyP :: ReadM (PubKey 'Sign (Encryption L4Proto)) -reflogKeyP = eitherReader $ - maybe (Left "invalid REFLOG-KEY") pure . fromStringMay - -pRefLogGet :: Parser (IO ()) -pRefLogGet = do - dopt <- pDialCommon - rkey <- argument reflogKeyP ( metavar "REFLOG-KEY" ) - pure do - withDial dopt \peer dclient -> - withClient dclient \cli -> do - xs <- dQuery1 def cli peer (dpath "reflog/get" [serialiseS rkey]) - - hash <- either (lift . lift . fail) pure $ runExcept $ flip evalStateT xs do - cutFrameDecode @(Hash HbSync) do - "No hash in response: " <> show xs - - liftIO . print $ pretty hash - -pRefLogFetch :: Parser (IO ()) -pRefLogFetch = do - dopt <- pDialCommon - rkey <- argument reflogKeyP ( metavar "REFLOG-KEY" ) - pure do - withDial dopt \peer dclient -> - withClient dclient \cli -> do - xs <- dQuery1 def cli peer (dpath "reflog/fetch" [serialiseS rkey]) - - liftIO . print $ "Response: " <> show xs - -pDebug :: Parser (IO ()) -pDebug = do - dopt <- pDialCommon - - pure $ withDial dopt \peer dclient -> - withClient dclient \cli -> do - - threadDelay 100 - liftIO $ putStrLn "" - liftIO $ putStrLn "ping" - liftIO . print =<< do - dQuery' def cli peer (dpath "ping" []) \flow -> do - S.print flow - - threadDelay 100 - liftIO $ putStrLn "" - liftIO $ putStrLn "ping1" - liftIO . print =<< do - dQuery1 def cli peer (dpath "ping" []) - - threadDelay 100 - liftIO $ putStrLn "" - liftIO $ putStrLn "undefined-route" - liftIO . print =<< do - dQuery' def cli peer (dpath "undefined-rout" []) \flow -> do - S.print flow - - threadDelay 100 - liftIO $ putStrLn "" - liftIO $ putStrLn "debug/timeout" - liftIO . print =<< do - dQuery' (def & #requestParamsTimeout .~ 0.1) - cli peer (dpath "debug/timeout" []) \flow -> do - S.print flow - - threadDelay 100 - liftIO $ putStrLn "" - liftIO $ putStrLn "debug/no-response-header" - liftIO . print =<< do - dQuery' def cli peer (dpath "debug/no-response-header" []) \flow -> do - S.print flow - - threadDelay 100 - liftIO $ putStrLn "" - liftIO $ putStrLn "debug/wrong-header" - liftIO . print =<< do - dQuery' def cli peer (dpath "debug/wrong-header" []) \flow -> do - S.print flow - - threadDelay 100 - liftIO $ putStrLn "" - liftIO $ putStrLn "undefined-route-1" - (U.handleAny \e -> liftIO (print e)) do - liftIO . print =<< do - dQuery1 def cli peer (dpath "undefined-route-1" []) - - threadDelay 100 - liftIO $ putStrLn "" - liftIO $ putStrLn "spec" - liftIO . print =<< do - dQuery' def cli peer (dpath "spec" []) \flow -> do - S.print flow - - -evalContT' :: ContT r m Void -> m r -evalContT' = flip runContT absurd - -withDial :: forall e i . - ( e ~ L4Proto - ) - => DialOptInitial - -> ( Peer e - -> DClient (ResponseM e (RpcM (ResourceT IO))) (Peer e) i - -> (ResponseM e (RpcM (ResourceT IO))) () - ) - -> IO () -withDial dopt' cmd = do - dopt <- resolveDialOpt dopt' - setLoggingOff @DEBUG - hSetBuffering stdout LineBuffering - - runResourceT do - udp1 <- newMessagingUDP False Nothing `orDie` "Can't start Dial" - - evalContT' do - - dialProtoEnv :: DialogProtoEnv (ResponseM L4Proto (RpcM (ResourceT IO))) L4Proto - <- newDialogProtoEnv - - amessaging <- ContT $ withAsync do - runMessagingUDP udp1 - - aprotos <- ContT $ withAsync $ runRPC udp1 do - - runProto @e - [ makeResponse do - dialRespProto (DialRespProtoAdapter dialProtoEnv) - ] - - aclient <- ContT $ withAsync $ - runRPC udp1 do - let p = dopt ^. #dialOptAddr . #unOptResolved - runResponseM p $ - cmd p - DClient - { clientCallerEnv = dialogProtoEnvCallerEnv dialProtoEnv - , clientSendProtoRequest = \peer frames -> do - request peer (DialReq @e frames) - - -- , clientGetKnownPeers :: m [(p, i)] - , clientGetKnownPeers = pure [] - } - - ContT \_ -> waitAnyCancel [amessaging, aprotos, aclient] - - pure () - diff --git a/hbs2-peer/app/PeerTypes.hs b/hbs2-peer/app/PeerTypes.hs index f422fb5c..695ac2b2 100644 --- a/hbs2-peer/app/PeerTypes.hs +++ b/hbs2-peer/app/PeerTypes.hs @@ -131,7 +131,7 @@ type MyPeer e = ( Eq (Peer e) , Hashable (Peer e) , Pretty (Peer e) , HasPeer e - , ForSignedBox e + , ForSignedBox (Encryption e) ) data DownloadReq e @@ -162,7 +162,7 @@ instance Expires (EventKey e (DownloadReq e)) where type DownloadFromPeerStuff e m = ( MyPeer e , MonadIO m , MonadUnliftIO m - , ForSignedBox e + , ForSignedBox (Encryption e) , Request e (BlockInfo e) m , Request e (BlockChunks e) m , MonadReader (PeerEnv e ) m diff --git a/hbs2-peer/app/RPC2/LWWRef.hs b/hbs2-peer/app/RPC2/LWWRef.hs index 3c607605..df11bbe3 100644 --- a/hbs2-peer/app/RPC2/LWWRef.hs +++ b/hbs2-peer/app/RPC2/LWWRef.hs @@ -41,7 +41,7 @@ instance (LWWRefContext m) => HandleMethod m RpcLWWRefGet where runMaybeT do rv <- getRef sto key >>= toMPlus val <- getBlock sto rv >>= toMPlus - <&> unboxSignedBox @(LWWRef L4Proto) @L4Proto + <&> unboxSignedBox @(LWWRef 'HBS2Basic) @HBS2Basic >>= toMPlus pure $ snd val @@ -72,6 +72,6 @@ instance LWWRefContext m => HandleMethod m RpcLWWRefUpdate where liftIO $ withPeerM penv do me <- ownPeer @L4Proto runResponseM me $ do - lwwRefProto nada (LWWRefProto1 (LWWProtoSet @L4Proto (LWWRefKey puk) box)) + lwwRefProto nada (LWWRefProto1 @L4Proto (LWWProtoSet (LWWRefKey puk) box)) diff --git a/hbs2-peer/app/RPC2/Poll.hs b/hbs2-peer/app/RPC2/Poll.hs index 2d0082b2..a10ff85a 100644 --- a/hbs2-peer/app/RPC2/Poll.hs +++ b/hbs2-peer/app/RPC2/Poll.hs @@ -18,6 +18,12 @@ instance (MonadIO m, HasRpcContext PeerAPI RPC2Context m) => HandleMethod m RpcP debug $ "rpc.pollList" listPolledRefs @L4Proto brains Nothing +instance (MonadIO m, HasRpcContext PeerAPI RPC2Context m) => HandleMethod m RpcPollList2 where + + handleMethod filt = do + brains <- getRpcContext @PeerAPI <&> rpcBrains + debug $ "rpc.pollList2" <+> pretty filt + listPolledRefsFiltered @L4Proto brains filt instance (MonadIO m, HasRpcContext PeerAPI RPC2Context m) => HandleMethod m RpcPollAdd where diff --git a/hbs2-peer/app/RPC2/RefChan.hs b/hbs2-peer/app/RPC2/RefChan.hs index 43a78df7..7a0078e5 100644 --- a/hbs2-peer/app/RPC2/RefChan.hs +++ b/hbs2-peer/app/RPC2/RefChan.hs @@ -37,7 +37,7 @@ instance RefChanContext m => HandleMethod m RpcRefChanHeadGet where debug $ "rpc.refchanHeadGet:" <+> pretty (AsBase58 puk) liftIO $ withPeerM penv $ do sto <- getStorage - liftIO $ getRef sto (RefChanHeadKey @HBS2Basic puk) <&> fmap HashRef + liftIO $ getRef sto (RefChanHeadKey @'HBS2Basic puk) <&> fmap HashRef instance (RefChanContext m) => HandleMethod m RpcRefChanHeadFetch where @@ -63,7 +63,7 @@ instance RefChanContext m => HandleMethod m RpcRefChanGet where debug $ "rpc.refchanGet:" <+> pretty (AsBase58 puk) liftIO $ withPeerM penv $ do sto <- getStorage - liftIO $ getRef sto (RefChanLogKey @HBS2Basic puk) <&> fmap HashRef + liftIO $ getRef sto (RefChanLogKey @'HBS2Basic puk) <&> fmap HashRef instance RefChanContext m => HandleMethod m RpcRefChanPropose where diff --git a/hbs2-peer/app/RPC2/RefLog.hs b/hbs2-peer/app/RPC2/RefLog.hs index 5c318ac9..bf27213b 100644 --- a/hbs2-peer/app/RPC2/RefLog.hs +++ b/hbs2-peer/app/RPC2/RefLog.hs @@ -37,11 +37,11 @@ instance (RefLogContext m) => HandleMethod m RpcRefLogGet where handleMethod pk = do co <- getRpcContext @RefLogAPI debug $ "rpc.reflogGet:" <+> pretty (AsBase58 pk) - <+> pretty (hashObject @HbSync (RefLogKey @HBS2Basic pk)) + <+> pretty (hashObject @HbSync (RefLogKey @'HBS2Basic pk)) liftIO $ withPeerM (rpcPeerEnv co) $ do let sto = rpcStorage co - liftIO (getRef sto (RefLogKey @HBS2Basic pk)) <&> fmap HashRef + liftIO (getRef sto (RefLogKey @'HBS2Basic pk)) <&> fmap HashRef instance (RefLogContext m) => HandleMethod m RpcRefLogFetch where diff --git a/hbs2-peer/app/RefChan.hs b/hbs2-peer/app/RefChan.hs index eb19d8e9..d1b134f5 100644 --- a/hbs2-peer/app/RefChan.hs +++ b/hbs2-peer/app/RefChan.hs @@ -656,8 +656,8 @@ refChanWorker env brains = do let byChan = HashMap.fromListWith (<>) [ (x, [y]) | (x,y) <- catMaybes trans ] - -- FIXME: process-in-parallel - forM_ (HashMap.toList byChan) $ \(c,new) -> do + -- FIXME: thread-num-hardcode-to-remove + pooledForConcurrentlyN_ 4 (HashMap.toList byChan) $ \(c,new) -> do mbLog <- liftIO $ getRef sto c hashes <- maybe1 mbLog (pure mempty) $ readLog (getBlock sto) . HashRef @@ -721,7 +721,7 @@ refChanWorker env brains = do trace $ "BLOCK IS HERE" <+> pretty hr -- читаем блок lbs <- readBlobFromTree (getBlock sto) hr <&> fromMaybe mempty - let what = unboxSignedBox @(RefChanHeadBlock e) @e lbs + let what = unboxSignedBox @(RefChanHeadBlock e) @s lbs notify <- atomically $ do no <- readTVar (_refChanWorkerEnvNotify env) <&> HashMap.member chan @@ -742,7 +742,7 @@ refChanWorker env brains = do lbss <- MaybeT $ readBlobFromTree (getBlock sto) (HashRef cur) - (_, blkOur) <- MaybeT $ pure $ unboxSignedBox @(RefChanHeadBlock e) @e lbss + (_, blkOur) <- MaybeT $ pure $ unboxSignedBox @(RefChanHeadBlock e) @s lbss pure $ view refChanHeadVersion blkOur @@ -863,7 +863,7 @@ logMergeProcess penv env q = withPeerM penv do Just x -> pure (Just x) Nothing -> runMaybeT do hdblob <- MaybeT $ readBlobFromTree ( liftIO . getBlock sto ) h - (_, headblk) <- MaybeT $ pure $ unboxSignedBox @(RefChanHeadBlock e) @e hdblob + (_, headblk) <- MaybeT $ pure $ unboxSignedBox @_ @s hdblob atomically $ modifyTVar (mergeHeads e) (HashMap.insert h headblk) pure headblk @@ -945,7 +945,7 @@ logMergeProcess penv env q = withPeerM penv do hd <- MaybeT $ lift $ getHead menv headRef let quo = view refChanHeadQuorum hd & fromIntegral - guard $ checkACL hd (Just pk) ak + guard $ checkACL ACLUpdate hd (Just pk) ak pure [(href, (quo,mempty))] Accept _ box -> do diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 94860f98..2373b4b3 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -18,7 +18,7 @@ common warnings common common-deps build-depends: - base, hbs2-core, hbs2-storage-simple, hbs2-keyman + base, hbs2-core, hbs2-storage-simple , aeson , async , bytestring @@ -30,6 +30,7 @@ common common-deps , dns , filepath , generic-lens + , generic-data , hashable , microlens-platform , mtl @@ -160,6 +161,11 @@ library HBS2.Peer.Proto.AnyRef HBS2.Peer.Proto.LWWRef HBS2.Peer.Proto.LWWRef.Internal + HBS2.Peer.Proto.BrowserPlugin + + HBS2.Peer.RPC.Client + HBS2.Peer.RPC.Client.Internal + HBS2.Peer.RPC.Client.RefChan HBS2.Peer.RPC.Class HBS2.Peer.RPC.API.Peer diff --git a/hbs2-peer/lib/HBS2/Peer/Brains.hs b/hbs2-peer/lib/HBS2/Peer/Brains.hs index 49a1caa2..8c16d230 100644 --- a/hbs2-peer/lib/HBS2/Peer/Brains.hs +++ b/hbs2-peer/lib/HBS2/Peer/Brains.hs @@ -18,6 +18,13 @@ class HasBrains e a where listPolledRefs :: MonadIO m => a -> Maybe String -> m [(PubKey 'Sign (Encryption e), String, Int)] listPolledRefs _ _ = pure mempty + listPolledRefsFiltered :: MonadIO m + => a + -> (Maybe String, Maybe (Int, Int)) + -> m [(PubKey 'Sign (Encryption e), String, Int)] + + listPolledRefsFiltered _ _ = pure mempty + isPolledRef :: MonadIO m => a -> String -> PubKey 'Sign (Encryption e) -> m Bool isPolledRef _ _ _ = pure False @@ -159,6 +166,7 @@ data SomeBrains e = forall a . HasBrains e a => SomeBrains a instance HasBrains e (SomeBrains e) where listPolledRefs (SomeBrains a) = listPolledRefs @e a + listPolledRefsFiltered (SomeBrains a) = listPolledRefsFiltered @e a isPolledRef (SomeBrains a) = isPolledRef @e a delPolledRef (SomeBrains a) = delPolledRef @e a addPolledRef (SomeBrains a) = addPolledRef @e a diff --git a/hbs2-peer/lib/HBS2/Peer/CLI/Detect.hs b/hbs2-peer/lib/HBS2/Peer/CLI/Detect.hs index 4a351243..f5134b04 100644 --- a/hbs2-peer/lib/HBS2/Peer/CLI/Detect.hs +++ b/hbs2-peer/lib/HBS2/Peer/CLI/Detect.hs @@ -7,12 +7,11 @@ import Data.Config.Suckless import System.Process.Typed import Data.Text qualified as Text import Data.Either -import UnliftIO -detectRPC :: (MonadUnliftIO m) => m (Maybe FilePath) +detectRPC :: MonadIO m => m (Maybe FilePath) detectRPC = do (_, o, _) <- readProcess (shell "hbs2-peer poke") - let answ = parseTop (LBS.unpack o) & fromRight mempty + let answ = parseTop (fromString $ LBS.unpack o) & fromRight mempty pure (headMay [ Text.unpack r | ListVal (Key "rpc:" [LitStrVal r]) <- answ ]) diff --git a/hbs2-peer/lib/HBS2/Peer/Notify.hs b/hbs2-peer/lib/HBS2/Peer/Notify.hs index e2bb6292..a73cffcf 100644 --- a/hbs2-peer/lib/HBS2/Peer/Notify.hs +++ b/hbs2-peer/lib/HBS2/Peer/Notify.hs @@ -49,7 +49,7 @@ deriving newtype instance ForRefChans e => Hashable (NotifyKey (RefChanEvents e) deriving newtype instance ForRefChans e => Eq (NotifyKey (RefChanEvents e)) data instance NotifyData (RefChanEvents e) = - RefChanNotifyData (RefChanId e) (SignedBox BS.ByteString e) + RefChanNotifyData (RefChanId e) (SignedBox BS.ByteString (Encryption e)) deriving Generic instance ForRefChans e => Serialise (NotifyKey (RefChanEvents e)) diff --git a/hbs2-peer/lib/HBS2/Peer/Proto.hs b/hbs2-peer/lib/HBS2/Peer/Proto.hs index 915ff408..bba28dd4 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto.hs @@ -148,7 +148,7 @@ instance HasProtocol L4Proto (RefChanNotify L4Proto) where -- возьмем пока 10 секунд requestPeriodLim = NoLimit -instance ForLWWRefProto L4Proto => HasProtocol L4Proto (LWWRefProto L4Proto) where +instance HasProtocol L4Proto (LWWRefProto L4Proto) where type instance ProtocolId (LWWRefProto L4Proto) = 12001 type instance Encoded L4Proto = ByteString decode = either (const Nothing) Just . deserialiseOrFail diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/BrowserPlugin.hs b/hbs2-peer/lib/HBS2/Peer/Proto/BrowserPlugin.hs new file mode 100644 index 00000000..82ea068b --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/Proto/BrowserPlugin.hs @@ -0,0 +1,81 @@ +{-# Language TemplateHaskell #-} +{-# Language AllowAmbiguousTypes #-} +{-# Language PatternSynonyms #-} +module HBS2.Peer.Proto.BrowserPlugin + ( module HBS2.Net.Proto.Service + , PIPE + , getPath + , getArgs + , RpcChannelQuery + , BrowserPluginAPI + , PluginMethod + , CreatePluginMethod(..) + , filterKW + , pattern Method + ) where + +import HBS2.Prelude.Plated +import HBS2.Net.Messaging.Pipe +import HBS2.Net.Proto.Service + +import Data.Kind +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HM +import Data.ByteString.Lazy (ByteString) +import Data.Text qualified as Text +import Codec.Serialise +import Lens.Micro.Platform + +data RpcChannelQuery + +-- API definition +type BrowserPluginAPI = '[ RpcChannelQuery ] + +pattern Method :: [Text] -> HashMap Text Text -> PluginMethod +pattern Method p a = Get p a +{-# COMPLETE Method #-} + +data PluginMethod = + Get { _getPath :: [Text] + , _getArgs :: HashMap Text Text + } + deriving stock (Show,Generic) + +makeLenses 'Get + +instance Serialise PluginMethod + +-- API endpoint definition +type instance Input RpcChannelQuery = PluginMethod +type instance Output RpcChannelQuery = Maybe ByteString + + +-- Codec for protocol +instance HasProtocol PIPE (ServiceProto BrowserPluginAPI PIPE) where + type instance ProtocolId (ServiceProto BrowserPluginAPI PIPE) = 3103959867 + type instance Encoded PIPE = ByteString + decode = either (const Nothing) Just . deserialiseOrFail + encode = serialise + + +class CreatePluginMethod a where + type family Dict a :: Type + createPluginMethod :: [a] -> Dict a -> PluginMethod + + +filterKW :: [Text] -> PluginMethod -> PluginMethod +filterKW kw = over getArgs (HM.filterWithKey filt) + where + filt k _ = k `elem` kw + +instance CreatePluginMethod String where + type instance Dict String = [(String,String)] + createPluginMethod path dict = + Get (fmap Text.pack path) + (HM.fromList (fmap (over _1 Text.pack . over _2 Text.pack) dict)) + +instance CreatePluginMethod Text where + type instance Dict Text = [(Text,Text)] + createPluginMethod path dict = + Get path (HM.fromList dict) + diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs b/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs index e3239467..f9914c68 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef.hs @@ -8,13 +8,10 @@ import HBS2.Base58 import HBS2.Storage import HBS2.Hash import HBS2.Net.Auth.Credentials -import HBS2.Net.Proto.Types import HBS2.Data.Types.SignedBox import HBS2.Data.Types.Refs -import HBS2.Net.Proto.Types import HBS2.Net.Auth.Schema() -import Data.ByteString (ByteString) import Data.Hashable hiding (Hashed) import Data.Maybe import Data.Word @@ -22,17 +19,17 @@ import Control.Monad.Trans.Maybe import Control.Monad.Except import Codec.Serialise -data LWWRefProtoReq e = - LWWProtoGet (LWWRefKey (Encryption e)) - | LWWProtoSet (LWWRefKey (Encryption e)) (SignedBox (LWWRef e) e) +data LWWRefProtoReq (s :: CryptoScheme) = + LWWProtoGet (LWWRefKey s) + | LWWProtoSet (LWWRefKey s) (SignedBox (LWWRef s) s) deriving stock Generic data LWWRefProto e = - LWWRefProto1 (LWWRefProtoReq e) + LWWRefProto1 (LWWRefProtoReq (Encryption e)) deriving stock (Generic) -data LWWRef e = +data LWWRef (s :: CryptoScheme) = LWWRef { lwwSeq :: Word64 , lwwValue :: HashRef @@ -40,12 +37,14 @@ data LWWRef e = } deriving stock (Generic) +-- FIXME: move-to-a-right-place +-- deriving instance Data e => Data (LWWRef e) -type ForLWWRefProto e = (ForSignedBox e, Serialise (LWWRefKey (Encryption e))) +type ForLWWRefProto (s :: CryptoScheme) = (ForSignedBox s, Serialise (LWWRefKey s)) -instance ForLWWRefProto e => Serialise (LWWRefProtoReq e) -instance ForLWWRefProto e => Serialise (LWWRefProto e) -instance ForLWWRefProto e => Serialise (LWWRef e) +instance ForLWWRefProto s => Serialise (LWWRefProtoReq s) +instance ForLWWRefProto (Encryption e) => Serialise (LWWRefProto e) +instance ForLWWRefProto s => Serialise (LWWRef s) newtype LWWRefKey s = LWWRefKey @@ -96,42 +95,40 @@ data ReadLWWRefError = | ReadLWWSignatureError deriving stock (Show,Typeable) -readLWWRef :: forall e s m . ( MonadIO m - , MonadError ReadLWWRefError m - , Encryption e ~ s - , ForLWWRefProto e - , Signatures s - , IsRefPubKey s - ) +readLWWRef :: forall s m . ( MonadIO m + , MonadError ReadLWWRefError m + , ForLWWRefProto s + , Signatures s + , IsRefPubKey s + ) => AnyStorage -> LWWRefKey s - -> m (Maybe (LWWRef e)) + -> m (Maybe (LWWRef s)) readLWWRef sto key = runMaybeT do getRef sto key >>= toMPlus >>= getBlock sto >>= toMPlus - <&> deserialiseOrFail @(SignedBox (LWWRef e) e) + <&> deserialiseOrFail @(SignedBox (LWWRef s) s) >>= orThrowError ReadLWWFormatError <&> unboxSignedBox0 >>= orThrowError ReadLWWSignatureError <&> snd -updateLWWRef :: forall s e m . ( Encryption e ~ s - , ForLWWRefProto e - , MonadIO m - , Signatures s - , IsRefPubKey s - ) +updateLWWRef :: forall s m . ( ForLWWRefProto s + , MonadIO m + , Signatures s + , IsRefPubKey s + ) => AnyStorage -> LWWRefKey s -> PrivKey 'Sign s - -> LWWRef e + -> LWWRef s -> m (Maybe HashRef) updateLWWRef sto k sk v = do - let box = makeSignedBox @e (fromLwwRefKey k) sk v + let box = makeSignedBox @s (fromLwwRefKey k) sk v runMaybeT do hx <- putBlock sto (serialise box) >>= toMPlus updateRef sto k hx diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef/Internal.hs b/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef/Internal.hs index 7866f0cf..1eb3fc26 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef/Internal.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/LWWRef/Internal.hs @@ -35,7 +35,7 @@ data LWWRefProtoAdapter e m = } lwwRefProto :: forall e s m proto . ( MonadIO m - , ForLWWRefProto e + , ForLWWRefProto s , Request e proto m , Response e proto m , HasDeferred proto e m @@ -66,7 +66,7 @@ lwwRefProto adapter pkt@(LWWRefProto1 req) = do <&> deserialiseOrFail >>= toMPlus - lift $ response (LWWRefProto1 (LWWProtoSet @e key box)) + lift $ response (LWWRefProto1 @e (LWWProtoSet key box)) LWWProtoSet key box -> void $ runMaybeT do @@ -97,7 +97,7 @@ lwwRefProto adapter pkt@(LWWRefProto1 req) = do blk' <- getBlock sto rv maybe1 blk' (forcedUpdateLwwRef sto key bs) $ \blk -> do - let lww0 = deserialiseOrFail @(SignedBox (LWWRef e) e) blk + let lww0 = deserialiseOrFail @(SignedBox (LWWRef s) s) blk & either (const Nothing) Just >>= unboxSignedBox0 <&> snd diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanNotify.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanNotify.hs index e43145c7..97a00541 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanNotify.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanNotify.hs @@ -79,7 +79,7 @@ refChanNotifyProto self adapter msg@(Notify rchan box) = do let refchanKey = RefChanHeadKey @s rchan headBlock <- MaybeT $ getActualRefChanHead @e refchanKey - guard $ checkACL headBlock Nothing authorKey + guard $ checkACL ACLNotify headBlock Nothing authorKey -- FIXME: garbage-collection-required liftIO $ putBlock sto (serialise msg) diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs index 2773c2b9..d949074c 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/RefChanUpdate.hs @@ -29,6 +29,7 @@ import Codec.Serialise import Control.Monad.Identity import Control.Monad.Trans.Maybe import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as LBS import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap import Data.HashSet (HashSet) @@ -42,7 +43,7 @@ import Data.Time.Clock.POSIX (getPOSIXTime) import UnliftIO -data ProposeTran e = ProposeTran HashRef (SignedBox ByteString e) -- произвольная бинарная транзакция, +data ProposeTran e = ProposeTran HashRef (SignedBox ByteString (Encryption e)) -- произвольная бинарная транзакция, deriving stock (Generic) -- подписанная ключом **АВТОРА**, который её рассылает newtype AcceptTime = AcceptTime Word64 @@ -70,6 +71,7 @@ pattern AcceptTran t a b <- (unpackAcceptTran -> (t, a, b)) where AcceptTran Nothing a b = AcceptTran1 a b AcceptTran (Just t) a b = AcceptTran2 (Just t) a b +{-# COMPLETE AcceptTran #-} instance ForRefChans e => Serialise (ProposeTran e) instance ForRefChans e => Serialise (AcceptTran e) @@ -126,8 +128,8 @@ instance Expires (EventKey e (RefChanRound e)) where -- черт его знает, какой там останется пайлоад. -- надо посмотреть. байт, небось, 400 data RefChanUpdate e = - Propose (RefChanId e) (SignedBox (ProposeTran e) e) -- подписано ключом пира - | Accept (RefChanId e) (SignedBox (AcceptTran e) e) -- подписано ключом пира + Propose (RefChanId e) (SignedBox (ProposeTran e) (Encryption e)) -- подписано ключом пира + | Accept (RefChanId e) (SignedBox (AcceptTran e) (Encryption e)) -- подписано ключом пира deriving stock (Generic) instance ForRefChans e => Serialise (RefChanUpdate e) @@ -295,7 +297,7 @@ refChanUpdateProto self pc adapter msg = do let pips = view refChanHeadPeers headBlock - guard $ checkACL headBlock (Just peerKey) authorKey + guard $ checkACL ACLUpdate headBlock (Just peerKey) authorKey debug $ "OMG!!! TRANS AUTHORIZED" <+> pretty (AsBase58 peerKey) <+> pretty (AsBase58 authorKey) @@ -381,7 +383,7 @@ refChanUpdateProto self pc adapter msg = do let tran = AcceptTran ts headRef (HashRef hash) -- -- генерируем Accept - let accept = Accept chan (makeSignedBox @e pk sk tran) + let accept = Accept chan (makeSignedBox @s pk sk tran) -- -- и рассылаем всем debug "GOSSIP ACCEPT TRANSACTION" @@ -443,7 +445,7 @@ refChanUpdateProto self pc adapter msg = do _ -> Nothing - (_, ptran) <- MaybeT $ pure $ unboxSignedBox0 @(ProposeTran e) @e proposed + (_, ptran) <- MaybeT $ pure $ unboxSignedBox0 @(ProposeTran e) @s proposed debug $ "ACCEPT FROM:" <+> pretty (AsBase58 peerKey) <+> pretty h0 @@ -453,7 +455,7 @@ refChanUpdateProto self pc adapter msg = do (authorKey, _) <- MaybeT $ pure $ unboxSignedBox0 pbox -- может, и не надо второй раз проверять - guard $ checkACL headBlock (Just peerKey) authorKey + guard $ checkACL ACLUpdate headBlock (Just peerKey) authorKey debug $ "JUST GOT TRANSACTION FROM STORAGE! ABOUT TO CHECK IT" <+> pretty hashRef @@ -563,6 +565,33 @@ refChanRequestProto self adapter msg = do lift $ emit RefChanRequestEventKey (RefChanRequestEvent @e chan val) debug $ "RefChanResponse" <+> pretty peer <+> pretty (AsBase58 chan) <+> pretty val + -- case s of + -- Accept{} -> pure () + -- Propose _ box -> do + -- (_, ProposeTran _ pbox :: ProposeTran L4Proto) <- toMPlus $ unboxSignedBox0 box + -- (_, bs2) <- toMPlus $ unboxSignedBox0 pbox + -- liftIO $ BS.putStr bs2 + +readProposeTranMay :: forall p e s m . ( Monad m + , ForRefChans e + , Signatures (Encryption e) + , s ~ Encryption e + , Serialise p + ) + => LBS.ByteString + -> m (Maybe p) +readProposeTranMay lbs = runMaybeT do + + updTx <- deserialiseOrFail @(RefChanUpdate e) lbs & toMPlus + + box <- case updTx of + Accept{} -> mzero + Propose _ box -> pure box + + (_, ProposeTran _ pbox :: ProposeTran e) <- toMPlus $ unboxSignedBox0 @_ @s box + (_, bs2) <- toMPlus $ unboxSignedBox0 pbox + + deserialiseOrFail @p (LBS.fromStrict bs2) & toMPlus makeProposeTran :: forall e s m . ( MonadIO m , ForRefChans e @@ -572,8 +601,8 @@ makeProposeTran :: forall e s m . ( MonadIO m ) => PeerCredentials s -> RefChanId e - -> SignedBox ByteString e - -> m (Maybe (SignedBox (ProposeTran e) e)) + -> SignedBox ByteString s + -> m (Maybe (SignedBox (ProposeTran e) s)) makeProposeTran creds chan box1 = do sto <- getStorage @@ -582,7 +611,7 @@ makeProposeTran creds chan box1 = do let tran = ProposeTran @e (HashRef h) box1 let pk = view peerSignPk creds let sk = view peerSignSk creds - pure $ makeSignedBox @e pk sk tran + pure $ makeSignedBox @s pk sk tran -- FIXME: reconnect-validator-client-after-restart -- почему-то сейчас если рестартовать пира, diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs index 1397ef06..42dbcaaa 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/RefChan/Types.hs @@ -4,7 +4,10 @@ {-# Language FunctionalDependencies #-} {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE PatternSynonyms, ViewPatterns #-} -module HBS2.Peer.Proto.RefChan.Types where +module HBS2.Peer.Proto.RefChan.Types + ( module HBS2.Peer.Proto.RefChan.Types + , L4Proto + ) where import HBS2.Prelude.Plated import HBS2.Hash @@ -27,16 +30,20 @@ import HBS2.System.Logger.Simple import Control.Monad.Trans.Maybe import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as LBS import Data.Either import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap import Data.HashSet (HashSet) import Data.HashSet qualified as HashSet import Data.Maybe +import Data.Either import Data.Text qualified as Text import Lens.Micro.Platform import Data.Hashable hiding (Hashed) - +import Data.Coerce +import Data.List qualified as List +import Codec.Serialise {- HLINT ignore "Use newtype instead of data" -} @@ -46,6 +53,9 @@ type RefChanAuthor e = PubKey 'Sign (Encryption e) type Weight = Integer +data ACLType = ACLUpdate | ACLNotify + deriving stock (Eq,Ord,Generic,Data,Show) + data RefChanHeadBlock e = RefChanHeadBlockSmall { _refChanHeadVersion :: Integer @@ -63,6 +73,16 @@ data RefChanHeadBlock e = , _refChanHeadReaders' :: HashSet (PubKey 'Encrypt (Encryption e)) , _refChanHeadExt :: ByteString } + | RefChanHeadBlock2 + { _refChanHeadVersion :: Integer + , _refChanHeadQuorum :: Integer + , _refChanHeadWaitAccept :: Integer + , _refChanHeadPeers :: HashMap (PubKey 'Sign (Encryption e)) Weight + , _refChanHeadAuthors :: HashSet (PubKey 'Sign (Encryption e)) + , _refChanHeadReaders' :: HashSet (PubKey 'Encrypt (Encryption e)) + , _refChanHeadNotifiers' :: HashSet (PubKey 'Sign (Encryption e)) + , _refChanHeadExt :: ByteString + } deriving stock (Generic) makeLenses ''RefChanHeadBlock @@ -74,8 +94,29 @@ data RefChanActionRequest = instance Serialise RefChanActionRequest +type DisclosedCredentialsRef e = PeerCredentials (Encryption e) + +newtype RefChanHeadExt e = + RefChanHeadExt [LBS.ByteString] + deriving stock Generic + deriving newtype (Semigroup, Monoid) + +newtype RefChanDisclosedCredentialsRef e = + RefChanDisclosedCredentialsRef (TaggedHashRef (DisclosedCredentialsRef e)) + deriving stock (Eq,Generic) + +instance Pretty (AsBase58 (RefChanDisclosedCredentialsRef e)) where + pretty (AsBase58 (RefChanDisclosedCredentialsRef x)) = pretty x + +instance Pretty (RefChanDisclosedCredentialsRef e) where + pretty (RefChanDisclosedCredentialsRef x) = pretty x + +instance Serialise (RefChanHeadExt e) + +instance SerialisedCredentials (Encryption e) => Serialise (RefChanDisclosedCredentialsRef e) + data RefChanNotify e = - Notify (RefChanId e) (SignedBox ByteString e) -- подписано ключом автора + Notify (RefChanId e) (SignedBox ByteString (Encryption e)) -- подписано ключом автора -- довольно уместно будет добавить эти команды сюда - -- они постоянно нужны, и это сильно упростит коммуникации | ActionRequest (RefChanId e) RefChanActionRequest @@ -84,6 +125,7 @@ data RefChanNotify e = instance ForRefChans e => Serialise (RefChanNotify e) + newtype instance EventKey e (RefChanNotify e) = RefChanNotifyEventKey (RefChanId e) @@ -103,19 +145,20 @@ instance Expires (EventKey e (RefChanNotify e)) where -type ForRefChans e = ( Serialise ( PubKey 'Sign (Encryption e)) +type ForRefChans e = ( Serialise (PubKey 'Sign (Encryption e)) + , Serialise (PrivKey 'Sign (Encryption e)) + , Serialise (Signature (Encryption e)) + , Serialise (PubKey 'Encrypt (Encryption e)) + , Serialise (PrivKey 'Encrypt (Encryption e)) , Pretty (AsBase58 (PubKey 'Sign (Encryption e))) , FromStringMaybe (PubKey 'Sign (Encryption e)) , FromStringMaybe (PubKey 'Encrypt (Encryption e)) , Signatures (Encryption e) - , Serialise (Signature (Encryption e)) - , Serialise (PubKey 'Encrypt (Encryption e)) , Hashable (PubKey 'Encrypt (Encryption e)) , Hashable (PubKey 'Sign (Encryption e)) ) - refChanHeadReaders :: ForRefChans e => Lens (RefChanHeadBlock e) (RefChanHeadBlock e) @@ -126,9 +169,48 @@ refChanHeadReaders = lens g s where g (RefChanHeadBlockSmall{}) = mempty g (RefChanHeadBlock1{..}) = _refChanHeadReaders' + g (RefChanHeadBlock2{..}) = _refChanHeadReaders' s v@(RefChanHeadBlock1{}) x = v { _refChanHeadReaders' = x } + s v@(RefChanHeadBlock2{}) x = v { _refChanHeadReaders' = x } s x _ = x + +refChanHeadDefault :: ForRefChans e => RefChanHeadBlock e +refChanHeadDefault = + RefChanHeadBlock2 1 1 10 mempty mempty mempty mempty mempty + +refChanHeadNotifiers :: ForRefChans e + => Lens (RefChanHeadBlock e) + (RefChanHeadBlock e) + (HashSet (PubKey 'Sign (Encryption e))) + (HashSet (PubKey 'Sign (Encryption e))) + +refChanHeadNotifiers = lens g s + where + g (RefChanHeadBlockSmall{}) = mempty + g (RefChanHeadBlock1{}) = mempty + g (RefChanHeadBlock2{..}) = _refChanHeadNotifiers' + + s v@(RefChanHeadBlock2{}) x = v { _refChanHeadNotifiers' = x } + s x _ = x + +refChanHeadDisclosed :: forall e . ForRefChans e + => SimpleGetter (RefChanHeadBlock e) [RefChanDisclosedCredentialsRef e] + +refChanHeadDisclosed = to getDisclosed + where + getDisclosed :: ForRefChans e => RefChanHeadBlock e -> [RefChanDisclosedCredentialsRef e] + getDisclosed blk = case blk of + RefChanHeadBlockSmall{} -> [] + RefChanHeadBlock1{} -> [] + RefChanHeadBlock2{..} -> extractDisclosed _refChanHeadExt + + extractDisclosed :: ByteString -> [RefChanDisclosedCredentialsRef e] + extractDisclosed ext = case deserialiseOrFail @(RefChanHeadExt e) (LBS.fromStrict ext) of + Right (RefChanHeadExt exts) -> rights $ fmap (deserialiseOrFail @(RefChanDisclosedCredentialsRef e)) exts + Left _ -> [] + + instance ForRefChans e => Serialise (RefChanHeadBlock e) type instance SessionData e (RefChanHeadBlock e) = RefChanHeadBlock e @@ -197,24 +279,19 @@ instance Pretty (AsBase58 (PubKey 'Sign s )) => Pretty (RefChanLogKey s) where instance ForRefChans e => FromStringMaybe (RefChanHeadBlock e) where + -- NOTE: we-dont-support-old-head-formats-anymore fromStringMay str = - case readers of - [] -> RefChanHeadBlockSmall <$> version - <*> quorum - <*> wait - <*> pure (HashMap.fromList peers) - <*> pure (HashSet.fromList authors) - - rs -> RefChanHeadBlock1 <$> version - <*> quorum - <*> wait - <*> pure (HashMap.fromList peers) - <*> pure (HashSet.fromList authors) - <*> pure (HashSet.fromList rs) - <*> pure mempty + RefChanHeadBlock2 <$> version + <*> quorum + <*> wait + <*> pure (HashMap.fromList peers) + <*> pure (HashSet.fromList authors) + <*> pure (HashSet.fromList readers) + <*> pure (HashSet.fromList notifiers) + <*> pure (LBS.toStrict ext) where - parsed = parseTop str & fromRight mempty + parsed = parseTop (fromString str) & fromRight mempty version = lastMay [ n | (ListVal [SymbolVal "version", LitIntVal n] ) <- parsed ] quorum = lastMay [ n | (ListVal [SymbolVal "quorum", LitIntVal n] ) <- parsed ] wait = lastMay [ n | (ListVal [SymbolVal "wait", LitIntVal n] ) <- parsed ] @@ -231,6 +308,18 @@ instance ForRefChans e => FromStringMaybe (RefChanHeadBlock e) where | (ListVal [SymbolVal "reader", LitStrVal s] ) <- parsed ] + + notifiers = catMaybes [ fromStringMay @(PubKey 'Sign (Encryption e)) (Text.unpack s) + | (ListVal [SymbolVal "notifier", LitStrVal s] ) <- parsed + ] + + disclosed = catMaybes [ fromStringMay @HashRef (Text.unpack s) + | (ListVal [SymbolVal "disclosed", LitStrVal s] ) <- parsed + ] + + ext1 = fmap serialise [ RefChanDisclosedCredentialsRef @L4Proto (coerce c) | c <- disclosed ] + ext = RefChanHeadExt ext1 & serialise + instance (ForRefChans e , Pretty (AsBase58 (PubKey 'Sign (Encryption e))) , Pretty (AsBase58 (PubKey 'Encrypt (Encryption e))) @@ -241,16 +330,41 @@ instance (ForRefChans e <> parens ("wait" <+> pretty (view refChanHeadWaitAccept blk)) <> line <> - vcat (fmap peer (HashMap.toList $ view refChanHeadPeers blk)) <> line + lstOf peer (HashMap.toList $ view refChanHeadPeers blk) <> - vcat (fmap author (HashSet.toList $ view refChanHeadAuthors blk)) <> line + lstOf author (HashSet.toList $ view refChanHeadAuthors blk) <> - vcat (fmap reader (HashSet.toList $ view refChanHeadReaders blk)) <> line + lstOf reader (HashSet.toList $ view refChanHeadReaders blk) + <> + lstOf notifier (HashSet.toList $ view refChanHeadNotifiers blk) + <> + lstOf disclosed_ disclosed + <> semi <+> parens ("head-extensions:" + <+> parens ("count:" <+> pretty (length exs)) + <+> parens ("size" <+> pretty (LBS.length extLbs)) + ) where + + extLbs = LBS.fromStrict $ view refChanHeadExt blk + + RefChanHeadExt exs = deserialiseOrFail @(RefChanHeadExt L4Proto) extLbs + & fromRight mempty + + disclosed = [ deserialiseOrFail @(RefChanDisclosedCredentialsRef L4Proto) s + | s <- exs + ] & rights + peer (p,w) = parens ("peer" <+> dquotes (pretty (AsBase58 p)) <+> pretty w) author p = parens ("author" <+> dquotes (pretty (AsBase58 p))) reader p = parens ("reader" <+> dquotes (pretty (AsBase58 p))) + notifier p = parens ("notifier" <+> dquotes (pretty (AsBase58 p))) + disclosed_ p = parens ("disclosed" <+> dquotes (pretty (AsBase58 p))) + + -- disclosed p = + + lstOf f e | null e = mempty + | otherwise = vcat (fmap f e) <> line -- блок головы может быть довольно большой. @@ -310,13 +424,10 @@ getActualRefChanHead key = do case mbHead of Just hd -> do - debug "HEAD DISCOVERED" pure hd Nothing -> do - headblk <- MaybeT $ getRefChanHead sto key - debug "HEAD FOUND" - pure headblk + MaybeT $ getRefChanHead sto key getRefChanHead :: forall e s m . ( MonadIO m , s ~ Encryption e @@ -330,20 +441,24 @@ getRefChanHead :: forall e s m . ( MonadIO m getRefChanHead sto k = runMaybeT do h <- MaybeT $ liftIO $ getRef sto k hdblob <- MaybeT $ readBlobFromTree ( getBlock sto ) (HashRef h) - (_, headblk) <- MaybeT $ pure $ unboxSignedBox @(RefChanHeadBlock e) @e hdblob + (_, headblk) <- MaybeT $ pure $ unboxSignedBox @(RefChanHeadBlock e) @s hdblob pure headblk checkACL :: forall e s . (Encryption e ~ s, ForRefChans e) - => RefChanHeadBlock e + => ACLType + -> RefChanHeadBlock e -> Maybe (PubKey 'Sign s) -> PubKey 'Sign s -> Bool -checkACL theHead mbPeerKey authorKey = match +checkACL acl theHead mbPeerKey authorKey = match where pips = view refChanHeadPeers theHead aus = view refChanHeadAuthors theHead + notifiers = view refChanHeadNotifiers theHead match = maybe True (`HashMap.member` pips) mbPeerKey - && authorKey `HashSet.member` aus + && ( authorKey `HashSet.member` aus + || acl == ACLNotify && authorKey `HashSet.member` notifiers + ) diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/RefLog.hs b/hbs2-peer/lib/HBS2/Peer/Proto/RefLog.hs index 31f6503c..2dde982d 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/RefLog.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/RefLog.hs @@ -157,6 +157,8 @@ verifyRefLogUpdate msg = do let sign = view refLogUpdSign msg pure $ verifySign @s pubk sign noncebs +-- unpackRef + data RefLogRequestI e m = RefLogRequestI { onRefLogRequest :: (Peer e, PubKey 'Sign (Encryption e)) -> m (Maybe (Hash HbSync)) diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/API/LWWRef.hs b/hbs2-peer/lib/HBS2/Peer/RPC/API/LWWRef.hs index bf949eba..14561ba4 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/API/LWWRef.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/API/LWWRef.hs @@ -4,9 +4,7 @@ import HBS2.Peer.Prelude import HBS2.Peer.Proto.LWWRef import HBS2.Data.Types.SignedBox import HBS2.Net.Messaging.Unix -import HBS2.Data.Types.Refs (HashRef(..)) import HBS2.Net.Proto.Service -import HBS2.Peer.Proto.RefLog (RefLogUpdate) import Data.ByteString.Lazy (ByteString) import Codec.Serialise @@ -26,13 +24,13 @@ instance HasProtocol UNIX (ServiceProto LWWRefAPI UNIX) where decode = either (const Nothing) Just . deserialiseOrFail encode = serialise -type instance Input RpcLWWRefGet = LWWRefKey HBS2Basic -type instance Output RpcLWWRefGet = Maybe (LWWRef L4Proto) +type instance Input RpcLWWRefGet = LWWRefKey 'HBS2Basic +type instance Output RpcLWWRefGet = Maybe (LWWRef 'HBS2Basic) -type instance Input RpcLWWRefFetch = LWWRefKey HBS2Basic +type instance Input RpcLWWRefFetch = LWWRefKey 'HBS2Basic type instance Output RpcLWWRefFetch = () -type instance Input RpcLWWRefUpdate = SignedBox (LWWRef L4Proto) L4Proto +type instance Input RpcLWWRefUpdate = SignedBox (LWWRef 'HBS2Basic) 'HBS2Basic type instance Output RpcLWWRefUpdate = () diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/API/Peer.hs b/hbs2-peer/lib/HBS2/Peer/RPC/API/Peer.hs index 3a012a30..e95a40a9 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/API/Peer.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/API/Peer.hs @@ -25,6 +25,7 @@ data RpcLogLevel data RpcDie data RpcPollList +data RpcPollList2 data RpcPollAdd data RpcPollDel @@ -50,6 +51,7 @@ type PeerAPI = '[ RpcPoke , RpcDownloadDel , RpcByPassInfo , RpcPerformGC + , RpcPollList2 ] instance HasProtocol UNIX (ServiceProto PeerAPI UNIX) where @@ -79,13 +81,16 @@ type instance Input RpcPexInfo = () type instance Output RpcPexInfo = [PeerAddr L4Proto] type instance Input RpcPeers = () -type instance Output RpcPeers = [(PubKey 'Sign HBS2Basic, PeerAddr L4Proto)] +type instance Output RpcPeers = [(PubKey 'Sign 'HBS2Basic, PeerAddr L4Proto)] type instance Input RpcFetch = HashRef type instance Output RpcFetch = () type instance Input RpcPollList= () -type instance Output RpcPollList = [(PubKey 'Sign HBS2Basic, String, Int)] +type instance Output RpcPollList = [(PubKey 'Sign 'HBS2Basic, String, Int)] + +type instance Input RpcPollList2 = (Maybe String, Maybe (Int,Int)) +type instance Output RpcPollList2 = [(PubKey 'Sign 'HBS2Basic, String, Int)] type instance Input RpcDownloadList = () type instance Output RpcDownloadList = [(HashRef, Integer)] @@ -93,10 +98,10 @@ type instance Output RpcDownloadList = [(HashRef, Integer)] type instance Input RpcDownloadDel = HashRef type instance Output RpcDownloadDel = () -type instance Input RpcPollAdd = (PubKey 'Sign HBS2Basic, String, Int) +type instance Input RpcPollAdd = (PubKey 'Sign 'HBS2Basic, String, Int) type instance Output RpcPollAdd = () -type instance Input RpcPollDel = PubKey 'Sign HBS2Basic +type instance Input RpcPollDel = PubKey 'Sign 'HBS2Basic type instance Output RpcPollDel = () type instance Input RpcLogLevel = SetLogging diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/API/RefChan.hs b/hbs2-peer/lib/HBS2/Peer/RPC/API/RefChan.hs index c6158915..f8018cc6 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/API/RefChan.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/API/RefChan.hs @@ -43,22 +43,22 @@ instance HasProtocol UNIX (ServiceProto RefChanAPI UNIX) where encode = serialise -type instance Input RpcRefChanHeadGet = PubKey 'Sign HBS2Basic +type instance Input RpcRefChanHeadGet = PubKey 'Sign 'HBS2Basic type instance Output RpcRefChanHeadGet = Maybe HashRef -type instance Input RpcRefChanHeadFetch = PubKey 'Sign HBS2Basic +type instance Input RpcRefChanHeadFetch = PubKey 'Sign 'HBS2Basic type instance Output RpcRefChanHeadFetch = () -type instance Input RpcRefChanFetch = PubKey 'Sign HBS2Basic +type instance Input RpcRefChanFetch = PubKey 'Sign 'HBS2Basic type instance Output RpcRefChanFetch = () -type instance Input RpcRefChanGet = PubKey 'Sign HBS2Basic +type instance Input RpcRefChanGet = PubKey 'Sign 'HBS2Basic type instance Output RpcRefChanGet = Maybe HashRef -type instance Input RpcRefChanPropose = (PubKey 'Sign HBS2Basic, SignedBox BS.ByteString L4Proto) +type instance Input RpcRefChanPropose = (PubKey 'Sign 'HBS2Basic, SignedBox BS.ByteString 'HBS2Basic) type instance Output RpcRefChanPropose = () -type instance Input RpcRefChanNotify = (PubKey 'Sign HBS2Basic, SignedBox BS.ByteString L4Proto) +type instance Input RpcRefChanNotify = (PubKey 'Sign 'HBS2Basic, SignedBox BS.ByteString 'HBS2Basic) type instance Output RpcRefChanNotify = () type instance Input RpcRefChanHeadPost = HashRef diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/API/RefLog.hs b/hbs2-peer/lib/HBS2/Peer/RPC/API/RefLog.hs index ed49c79d..857fdbe8 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/API/RefLog.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/API/RefLog.hs @@ -27,10 +27,10 @@ instance HasProtocol UNIX (ServiceProto RefLogAPI UNIX) where decode = either (const Nothing) Just . deserialiseOrFail encode = serialise -type instance Input RpcRefLogGet = PubKey 'Sign HBS2Basic +type instance Input RpcRefLogGet = PubKey 'Sign 'HBS2Basic type instance Output RpcRefLogGet = Maybe HashRef -type instance Input RpcRefLogFetch = PubKey 'Sign HBS2Basic +type instance Input RpcRefLogFetch = PubKey 'Sign 'HBS2Basic type instance Output RpcRefLogFetch = () type instance Input RpcRefLogPost = RefLogUpdate L4Proto diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Client.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Client.hs new file mode 100644 index 00000000..da9f334a --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Client.hs @@ -0,0 +1,12 @@ +module HBS2.Peer.RPC.Client + ( module HBS2.Peer.RPC.Client + , module Exported + ) where + +import HBS2.Net.Proto.Service as Exported +import HBS2.Peer.RPC.Client.Internal as Exported + + + + + diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Client/Internal.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Client/Internal.hs new file mode 100644 index 00000000..3cb41159 --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Client/Internal.hs @@ -0,0 +1,25 @@ +module HBS2.Peer.RPC.Client.Internal + ( module HBS2.Peer.RPC.Client.Internal + , module Exported + ) where + +import HBS2.Peer.Prelude + +import HBS2.Hash as Exported +import HBS2.Data.Types.Refs as Exported + +import HBS2.Net.Proto.Service as Exported + +import Data.Kind +import Control.Exception + +data RpcClientError = + RpcNotConnectedError + | RpcTimeoutError + deriving (Eq,Typeable,Show) + +instance Exception RpcClientError + +class Monad m => HasClientAPI (api :: [Type]) proto m where + getClientAPI :: m (ServiceCaller api proto) + diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs new file mode 100644 index 00000000..fba1344f --- /dev/null +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Client/RefChan.hs @@ -0,0 +1,185 @@ +{-# Language AllowAmbiguousTypes #-} +module HBS2.Peer.RPC.Client.RefChan where + +import HBS2.OrDie +import HBS2.Storage +import HBS2.Merkle +import HBS2.Storage.Operations.ByteString +import HBS2.Data.Types.SignedBox + +import HBS2.Peer.Proto.RefChan +import HBS2.Peer.Prelude +import HBS2.Peer.RPC.API.RefChan +import HBS2.Peer.RPC.API.Storage +import HBS2.Peer.RPC.Client.Internal +import HBS2.Peer.RPC.Client.StorageClient + +import Data.ByteString (ByteString) +import Data.Coerce +import Control.Monad.Except +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Cont +import Control.Monad.Reader +import Codec.Serialise +import UnliftIO + + +getRefChanHeadHash :: forall proto m . ( MonadUnliftIO m + , HasClientAPI RefChanAPI proto m + , HasProtocol proto (ServiceProto RefChanAPI proto) + ) + => PubKey 'Sign 'HBS2Basic + -> m (Maybe HashRef) +getRefChanHeadHash puk = do + api <- getClientAPI @RefChanAPI @proto + callRpcWaitMay @RpcRefChanHeadGet (TimeoutSec 1) api puk >>= \case + Nothing -> throwIO RpcTimeoutError + Just e -> pure e + + +getRefChanHead :: forall proto m . ( MonadUnliftIO m + , HasClientAPI RefChanAPI proto m + , HasClientAPI StorageAPI proto m + , HasProtocol proto (ServiceProto RefChanAPI proto) + , HasProtocol proto (ServiceProto StorageAPI proto) + ) + => PubKey 'Sign 'HBS2Basic + -> m (Maybe (RefChanHeadBlock L4Proto)) +getRefChanHead puk = do + + sto <- getClientAPI @StorageAPI @proto <&> AnyStorage . StorageClient + + runMaybeT do + hx <- lift (getRefChanHeadHash @proto puk) >>= toMPlus + lbs <- runExceptT (readFromMerkle sto (SimpleKey (coerce hx))) + >>= orThrowPassIO + + -- FIXME: error-on-bad-signature + (_, hdblk) <- unboxSignedBox @(RefChanHeadBlock L4Proto) @'HBS2Basic lbs + & toMPlus + + pure hdblk + +postRefChanTx :: forall proto s m . ( MonadUnliftIO m + , HasClientAPI RefChanAPI proto m + , HasClientAPI StorageAPI proto m + , HasProtocol proto (ServiceProto RefChanAPI proto) + , HasProtocol proto (ServiceProto StorageAPI proto) + , ForSignedBox s + , s ~ HBS2Basic + ) + => PubKey 'Sign s + -> SignedBox ByteString s + -> m () +postRefChanTx puk box = do + api <- getClientAPI @RefChanAPI @proto + callRpcWaitMay @RpcRefChanPropose (TimeoutSec 1) api (puk, box) >>= \case + Nothing -> throwIO RpcTimeoutError + Just e -> pure e + +fetchRefChanHead :: forall proto m . ( MonadUnliftIO m + , HasClientAPI RefChanAPI proto m + , HasProtocol proto (ServiceProto RefChanAPI proto) + ) + => PubKey 'Sign 'HBS2Basic + -> m () +fetchRefChanHead puk = do + api <- getClientAPI @RefChanAPI @proto + callRpcWaitMay @RpcRefChanHeadFetch (TimeoutSec 1) api puk >>= \case + Nothing -> throwIO RpcTimeoutError + _ -> pure () + +fetchRefChan :: forall proto m . ( MonadUnliftIO m + , HasClientAPI RefChanAPI proto m + , HasProtocol proto (ServiceProto RefChanAPI proto) + ) + => PubKey 'Sign 'HBS2Basic + -> m () +fetchRefChan puk = do + api <- getClientAPI @RefChanAPI @proto + callRpcWaitMay @RpcRefChanFetch (TimeoutSec 1) api puk >>= \case + Nothing -> throwIO RpcTimeoutError + _ -> pure () + + +getRefChanValue :: forall proto m . ( MonadUnliftIO m + , HasClientAPI RefChanAPI proto m + , HasProtocol proto (ServiceProto RefChanAPI proto) + ) + => PubKey 'Sign 'HBS2Basic + -> m (Maybe HashRef) +getRefChanValue puk = do + api <- getClientAPI @RefChanAPI @proto + callRpcWaitMay @RpcRefChanGet (TimeoutSec 1) api puk >>= \case + Nothing -> throwIO RpcTimeoutError + Just e -> pure e + + + + +-- this is not MonadUnliftIO to be compatible with +-- streaming +-- + +data RScanEnv proto = + RScanEnv { + rchanAPI :: ServiceCaller RefChanAPI proto + } + + +instance Monad m => HasClientAPI RefChanAPI proto (ReaderT (RScanEnv proto) m) where + getClientAPI = asks rchanAPI + +data RefChanUpdateUnpacked e = + A (AcceptTran e) | P HashRef (ProposeTran e) + deriving stock (Generic) + +{-# COMPLETE A,P #-} + +walkRefChanTx :: forall proto m . ( MonadIO m + , HasClientAPI RefChanAPI proto m + , HasProtocol proto (ServiceProto RefChanAPI proto) + , HasStorage m + ) + => (HashRef -> m Bool) + -> PubKey 'Sign 'HBS2Basic + -> (HashRef -> RefChanUpdateUnpacked L4Proto -> m ()) + -> m () +walkRefChanTx filt puk action = do + sto <- getStorage + api <- getClientAPI @RefChanAPI @proto + + let env = RScanEnv api + + flip runContT pure $ callCC $ \exit -> do + + rcv' <- liftIO (runReaderT (getRefChanValue @proto puk) env) + + rcv <- ContT $ maybe1 rcv' none + + walkMerkle (coerce rcv) (getBlock sto) $ \case + -- FIXME: error-handling + Left _ -> exit () + + Right (hs :: [HashRef]) -> do + for_ hs $ \h -> do + want <- lift (filt h) + when want do + lbs' <- getBlock sto (coerce h) + lbs <- ContT $ maybe1 lbs' none + + let txraw = deserialiseOrFail @(RefChanUpdate L4Proto) lbs + & either (const Nothing) Just + + tx <- ContT $ maybe1 txraw none + + case tx of + + Accept _ box -> do + (_, txx) <- ContT $ maybe1 (unboxSignedBox0 box) none + lift $ action h (A txx) + + Propose _ box -> do + (_, txx) <- ContT $ maybe1 (unboxSignedBox0 box) none + lift $ action h (P h txx) + diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Client/Unix.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Client/Unix.hs index 7ff2189e..83a765f9 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/Client/Unix.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Client/Unix.hs @@ -19,13 +19,13 @@ import Data.Kind import Control.Monad.Reader import UnliftIO -withRPC2 :: forall (api :: [Type]) e m . ( e ~ UNIX +withRPC2 :: forall (api :: [Type]) e m r . ( e ~ UNIX , HasProtocol e (ServiceProto api e) , MonadUnliftIO m ) => FilePath - -> ( ServiceCaller api e -> m () ) - -> m () + -> ( ServiceCaller api e -> m r ) + -> m r withRPC2 soname action = do @@ -39,10 +39,13 @@ withRPC2 soname action = do caller <- makeServiceCaller @api @UNIX (fromString soname) p2 <- liftIO $ async $ runReaderT (runServiceClient @api @e caller) client1 - action caller + r <- action caller pause @'Seconds 0.05 cancel p2 void $ waitAnyCatchCancel [m1, p2] + pure r + + diff --git a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs index d5fcc9d1..d67e0608 100644 --- a/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs +++ b/hbs2-peer/lib/HBS2/Peer/RPC/Internal/Types.hs @@ -26,7 +26,7 @@ import UnliftIO data RPC2Context = RPC2Context - { rpcConfig :: [Syntax MegaParsec] + { rpcConfig :: [Syntax C] , rpcMessaging :: MessagingUnix , rpcPokeAnswer :: String , rpcPeerEnv :: PeerEnv L4Proto @@ -36,8 +36,8 @@ data RPC2Context = , rpcByPassInfo :: IO ByPassStat , rpcDoFetch :: HashRef -> IO () , rpcDoRefChanHeadPost :: HashRef -> IO () - , rpcDoRefChanPropose :: (PubKey 'Sign HBS2Basic, SignedBox ByteString L4Proto) -> IO () - , rpcDoRefChanNotify :: (PubKey 'Sign HBS2Basic, SignedBox ByteString L4Proto) -> IO () + , rpcDoRefChanPropose :: (PubKey 'Sign 'HBS2Basic, SignedBox ByteString 'HBS2Basic) -> IO () + , rpcDoRefChanNotify :: (PubKey 'Sign 'HBS2Basic, SignedBox ByteString 'HBS2Basic) -> IO () } instance (Monad m, Messaging MessagingUnix UNIX (Encoded UNIX)) => HasFabriq UNIX (ReaderT RPC2Context m) where diff --git a/hbs2-peer/test/TestSuite.hs b/hbs2-peer/test/TestSuite.hs index d0208a39..8f588210 100644 --- a/hbs2-peer/test/TestSuite.hs +++ b/hbs2-peer/test/TestSuite.hs @@ -50,17 +50,17 @@ testVersionedKeysHashes = do & orThrowUser "bad base58" <&> LBS.fromStrict - pk <- fromStringMay @(PubKey 'Sign HBS2Basic) "BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP" + pk <- fromStringMay @(PubKey 'Sign 'HBS2Basic) "BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP" & orThrowUser "key decode" let pks = serialise pk - pks2 <- deserialiseOrFail @(PubKey 'Sign HBS2Basic) (pks <> "12345") + pks2 <- deserialiseOrFail @(PubKey 'Sign 'HBS2Basic) (pks <> "12345") & orThrowUser "key decode error" - let rfk = serialise (RefLogKey @HBS2Basic pk) - let wrfk = serialise $ W (RefLogKey @HBS2Basic pk) - let xrfk = serialise $ X (RefLogKey @HBS2Basic pk) + let rfk = serialise (RefLogKey @'HBS2Basic pk) + let wrfk = serialise $ W (RefLogKey @'HBS2Basic pk) + let xrfk = serialise $ X (RefLogKey @'HBS2Basic pk) print $ pretty (AsHexSparse keypart) print $ pretty (AsHexSparse pks) diff --git a/hbs2-share/app/Main.hs b/hbs2-share/app/Main.hs deleted file mode 100644 index 1f31f166..00000000 --- a/hbs2-share/app/Main.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Main where - -import HBS2.Share.App - -import Options.Applicative as O - --- Парсер для глобальных опций -globalOptions :: Parser [AppOption] -globalOptions = do - dry <- optional (flag' True (long "dry" <> short 'n' <> help "dont post anything")) - <&> maybe mempty (const [AppDontPostOpt]) - - debug <- optional (flag' True (long "debug" <> short 'v' <> help "allow debug output")) - <&> maybe mempty (const [AppDebugOpt]) - - trace <- optional (flag' True (long "trace" <> help "allow more debug output")) - <&> maybe mempty (const [AppTraceOpt]) - - - replica <- optional (flag' True (long "replica" <> help "replica (slave) mode")) - <&> maybe mempty (const [AppReplicaOpt]) - - pure (replica <> debug <> dry <> trace ) - --- Парсер для команд -commands :: AppPerks m => Parser (ShareCLI m ()) -commands = defCmd - -defCmd :: AppPerks m => Parser (ShareCLI m ()) -defCmd = pure $ runSync - -opts :: AppPerks m => ParserInfo ([AppOption], ShareCLI m ()) -opts = O.info (liftA2 (,) globalOptions commands <**> helper) - ( fullDesc - -- <> progDesc "An application with global options and subcommands" - <> header "hbs2-share" ) - -main :: IO () -main = do - (o, action) <- execParser opts - runApp o action - - diff --git a/hbs2-share/src/HBS2/Share/App.hs b/hbs2-share/src/HBS2/Share/App.hs deleted file mode 100644 index b0532f9c..00000000 --- a/hbs2-share/src/HBS2/Share/App.hs +++ /dev/null @@ -1,851 +0,0 @@ -{-# Language MultiWayIf #-} -module HBS2.Share.App - ( module HBS2.Share.App.Types - , AppOption(..) - , Command - , AppPerks - , runApp - , runSync - ) where - -import HBS2.Prelude.Plated -import HBS2.Base58 -import HBS2.Merkle -import HBS2.Data.Detect -import HBS2.Defaults (defBlockSize) -import HBS2.Hash -import HBS2.Clock -import HBS2.OrDie -import HBS2.Peer.Proto.RefChan.Types -import HBS2.Net.Auth.Credentials -import HBS2.Net.Auth.Credentials.Sigil -import HBS2.Data.Types.SignedBox -import HBS2.Net.Auth.GroupKeySymm -import HBS2.Net.Auth.GroupKeySymm qualified as Symm -import HBS2.Peer.Proto.RefChan - -import HBS2.Net.Messaging.Unix -import HBS2.Net.Proto.Service -import HBS2.Storage -import HBS2.Storage.Operations.ByteString -import HBS2.Storage.Operations.Missed (findMissedBlocks,findMissedBlocks2) - -import HBS2.Peer.CLI.Detect (detectRPC) -import HBS2.Peer.RPC.Client.StorageClient - -import HBS2.KeyMan.Keys.Direct - -import HBS2.Share.App.Types -import HBS2.Share.Config hiding (key) -import HBS2.Share.State -import HBS2.Share.Files qualified as F -import HBS2.Share.Keys -import HBS2.Share.MetaData -import HBS2.Share.LocalHash - -import HBS2.System.Logger.Simple.ANSI -import DBPipe.SQLite - -import Control.Applicative -import Control.Concurrent.STM (flushTQueue) -import Control.Monad.Except (runExceptT) -import Control.Monad.Trans.Maybe -import Data.ByteArray.Hash qualified as BA -import Data.ByteArray.Hash (SipHash(..), SipKey(..)) -import Data.ByteString.Lazy qualified as LBS -import Data.ByteString qualified as BS -import Data.HashSet qualified as HashSet -import Data.HashMap.Strict qualified as HashMap -import Data.List qualified as List -import Data.Maybe -import Data.Set qualified as Set -import Data.Set (Set) -import Data.Either -import System.Directory -import System.FilePath - -import Codec.Serialise -import Codec.Compression.GZip as GZip -import System.AtomicWrite.Writer.LazyByteString qualified as AwL - -import System.TimeIt - -import Streaming.Prelude qualified as S - - -type Command m = m () - - -runApp :: MonadUnliftIO m => [AppOption] -> ShareCLI m () -> m () -runApp opts action = do - - getLocalConfigDir' >>= - liftIO . createDirectoryIfMissing True - - getLocalConfigFile >>= \fn -> do - here <- liftIO $ doesFileExist fn - - unless here do - liftIO $ appendFile fn "" - - env <- liftIO (newAppEnv opts) - let db = view appDb env - - setLogging @INFO defLog - setLogging @ERROR (logPrefix "" . toStderr) - setLogging @WARN (logPrefix "" . toStdout) - setLogging @NOTICE (logPrefix "" . toStdout) - - when ( AppDebugOpt `elem` opts || AppTraceOpt `elem` opts) do - setLogging @DEBUG (logPrefix "" . toStderr) - - when (AppTraceOpt `elem` opts) do - setLogging @TRACE (logPrefix "" . toStderr) - - flip runContT pure $ do - void $ ContT $ bracket (async (runPipe db)) cancel - - lift $ withAppEnv env do - withState populateState - loadAllEncryptionStuff - action - - setLoggingOff @INFO - setLoggingOff @ERROR - setLoggingOff @WARN - setLoggingOff @NOTICE - setLoggingOff @DEBUG - setLoggingOff @TRACE - - -withAppEnv :: MonadIO m => AppEnv -> ShareCLI m a -> m a -withAppEnv env action = do - runReaderT (fromShareCLI action) env - - -newAppEnv :: forall m . MonadUnliftIO m => [AppOption] -> m AppEnv -newAppEnv opts = do - let dbOpts = dbPipeOptsDef - - w <- getWorkingDir - - conf <- readConfig - - let sonameOpt = runReader (cfgValue @RpcUnixOpt @(Maybe String) @(Reader [Syntax C])) conf - - rchan <- orThrowUser "refchan not set" (runReader (cfgValue @RefChanOpt @(Maybe RChan)) conf) - - sonameDetect <- detectRPC - - soname <- orThrowUser "rpc not detected" (sonameOpt <|> sonameDetect) - - AppEnv opts conf rchan - <$> (getLocalStatePath >>= newDBPipeEnv dbOpts) - <*> pure w - <*> pure soname - <*> newIORef Nothing - -withState :: (MonadReader AppEnv m, MonadIO m) - => DBPipeM m b - -> m b - -withState m = do - d <- asks (view appDb) - withDB d m - - -makeGK0Key :: forall e s m . ( AppPerks m - , HasProtocol e (ServiceProto StorageAPI e) - , s ~ Encryption L4Proto - ) - => RpcEndpoints e - -> ShareCLI m (Maybe GK0Key) - -makeGK0Key rpc = runMaybeT do - lift (getOwnRefChanHeadRef rpc) - >>= toMPlus - <&> GK0Key - - -getGK0 :: forall e s m . ( AppPerks m - , HasProtocol e (ServiceProto StorageAPI e) - , ForGroupKeySymm HBS2Basic - , s ~ HBS2Basic - ) - => RpcEndpoints e - -> ShareCLI m (GK0 s) -getGK0 rpc = do - - rchan <- asks (view appRefChan) - - let sto = AnyStorage (StorageClient (rpcStorage rpc)) - - gk0key <- makeGK0Key @e rpc - >>= orThrowUser "makeGK0Key(1): refchan not available" - - mgk <- runMaybeT do - gkh <- toMPlus =<< lift (withState $ selectGK0 gk0key) - - debug $ "found gk!" <+> pretty gkh - - runExceptT (readFromMerkle sto (SimpleKey (fromHashRef gkh))) - >>= toMPlus - <&> deserialiseOrFail @(GK0 s) - >>= toMPlus - - case mgk of - Just x -> do - pure x - - Nothing -> do - hd <- getRefChanHead @L4Proto sto (RefChanHeadKey (toRefChanId rchan)) - >>= orThrowUser "makeGK0Key(2): refchan not available" - - let readers = view refChanHeadReaders hd & HashSet.toList - gk <- generateGroupKey @s Nothing readers - href <- writeAsMerkle sto (serialise gk) <&> HashRef - - withState (insertGK0 gk0key href >> commitAll) - - debug $ "generated gk0!" <+> pretty href - - pure gk - -getOwnRefChanHeadRef :: forall e s m . ( AppPerks m - , HasProtocol e (ServiceProto StorageAPI e) - , s ~ Encryption L4Proto - ) - => RpcEndpoints e - -> ShareCLI m (Maybe HashRef) -getOwnRefChanHeadRef rpc = do - - let sto = AnyStorage (StorageClient (rpcStorage rpc)) - - runMaybeT do - rchan <- toMPlus =<< lift (cfgValue @RefChanOpt @(Maybe RChan)) - let puk = toRefChanId rchan - getRef sto (RefChanHeadKey @s puk) - >>= toMPlus - <&> HashRef - -withRpcClientUnix :: forall a e m . ( MonadUnliftIO m - , HasProtocol e (ServiceProto PeerAPI e) - , HasProtocol e (ServiceProto StorageAPI e) - , HasProtocol e (ServiceProto RefChanAPI e) - , e ~ UNIX - , MonadReader AppEnv m - ) - => ( RpcEndpoints e -> m a ) - -> m a - -withRpcClientUnix action = do - - -- FIXME: use-ContT - - soname <- asks (view appRpcSock) - - client <- race ( pause @'Seconds 1) (newMessagingUnix False 1.0 soname) `orDie` "hbs2-peer rpc timeout!" - - messaging <- async $ runMessagingUnix client - link messaging - - rpcPeer <- makeServiceCaller @PeerAPI @e (fromString soname) - rpcStorage <- makeServiceCaller @StorageAPI @e (fromString soname) - rpcRefChan <- makeServiceCaller @RefChanAPI @e (fromString soname) - - let endpoints = [ Endpoint @e rpcPeer - , Endpoint @e rpcStorage - , Endpoint @e rpcRefChan - ] - - c1 <- async $ liftIO $ runReaderT (runServiceClientMulti endpoints) client - - link c1 - - r <- action $ RpcEndpoints rpcPeer rpcStorage rpcRefChan - - pause @'Seconds 0.1 - - cancel c1 - - void $ waitAnyCatchCancel [c1, messaging] - - pure r - - -loadSigil :: forall e s m . ( s ~ Encryption e - , ForSigil e - , AppPerks m - ) => ShareCLI m (PubKey 'Sign s, SigilData e) -loadSigil = do - - dir <- getLocalConfigDir - - path' <- cfgValue @SigilPathOpt @(Maybe String) - >>= orThrowUser "sigil not set" - - let nonLocalPath = List.isPrefixOf "./" path' || List.isPrefixOf "/" path' - - path <- if not nonLocalPath then do - pure $ dir path' - else do - pure path' - - trace $ "SIGIL PATH" <+> pretty path - - sigil <- liftIO $ (BS.readFile path <&> parseSerialisableFromBase58 @(Sigil e)) - >>= orThrowUser ("invalid sigil format" <+> pretty path) - - w@(_,sd) <- orThrowUser "malformed sigil" (unboxSignedBox0 @(SigilData e) (sigilData sigil)) - - pure w - -loadAllEncryptionStuff :: AppPerks m => ShareCLI m () -loadAllEncryptionStuff = do - - -- 1. загружаем sigil - (pk, sd) <- loadSigil @L4Proto - - trace $ "sigil loaded" <+> pretty (AsBase58 pk) - - enc <- runKeymanClient do - cr <- loadCredentials pk - >>= orThrowUser "can't find credentials" - - enc <- loadKeyRingEntry (sigilDataEncKey sd) - >>= orThrowUser "can't find keyring entry" - - pure $ EncryptionStuff cr enc - - encIO <- asks (view appEnc) - - writeIORef encIO (Just enc) - debug "encryption data loaded ok" - - -data UpdateFileMethod = UpdateFileForce - | UpdateFileSync - -updateFile :: (AppPerks m, HasProtocol e (ServiceProto StorageAPI e)) - => RpcEndpoints e - -> RemoteFile - -> ShareCLI m () -updateFile rpc fe = do - dir <- asks (view appWorkDir) - replica <- isReplica - if replica then do - updateFileMethod UpdateFileForce rpc fe - else do - updateFileMethod UpdateFileSync rpc fe - -updateFileMethod :: (AppPerks m, HasProtocol e (ServiceProto StorageAPI e)) - => UpdateFileMethod - -> RpcEndpoints e - -> RemoteFile - -> ShareCLI m () -updateFileMethod UpdateFileForce rpc fe = do - - dir <- asks (view appWorkDir) - - let key = _remoteFileKey fe - - let fn = dir toFilePath key - - let sto = AnyStorage (StorageClient (rpcStorage rpc)) - - encStuff <- asks (view appEnc) - >>= readIORef - >>= orThrowUser "credentials not available" - - let kr = [view kre encStuff] - - for_ (getDirs key) $ \d -> do - let fpath = dir d - here <- liftIO $ doesFileExist fpath - when here do - liftIO (removeFile fpath) - liftIO $ createDirectoryIfMissing True fpath - - here <- liftIO $ doesFileExist fn - - l <- withState (selectLocalFile key) - - let lh = view localFileHash <$> l - - when (lh /= Just (_remoteLocalHash fe) || not here) do - info $ "update file" <+> pretty key - - let h = view remoteTree fe & fromHashRef - - lbs <- runExceptT (readFromMerkle sto (ToDecryptBS kr h)) - >>= orThrowUser ("can't read file" <+> pretty h <+> pretty key) - - liftIO $ AwL.atomicWriteFile fn lbs - -updateFileMethod UpdateFileSync rpc fe = do - w <- asks (view appWorkDir) - let sto = AnyStorage (StorageClient (rpcStorage rpc)) - - encStuff <- asks (view appEnc) - >>= readIORef - >>= orThrowUser "credentials not available" - - let kr = [view kre encStuff] - - let key = _remoteFileKey fe - - (doUpdate, mt) <- withState do - let fn = _remoteFileKey fe - lf <- selectLocalFile (_remoteFileKey fe) - -- floc <- selectLocalFile (_remoteFileKey fe) - let tLoc = _localFileModTime <$> lf - let tRem = Just (_remoteFileTime fe) - - let rhash = Just $ _remoteLocalHash fe - let lhash = _localFileHash <$> lf - - pure (tRem > tLoc && rhash /= lhash, tRem) - - dont <- dontPost - - when (doUpdate && not dont) do - - let dirs = getDirs key - - info $ "U" <+> pretty key <+> pretty (_remoteTree fe) - - for_ dirs $ \d -> do - let fpath = w d - isFile <- liftIO $ doesFileExist fpath - - when isFile do - -- TODO: unique-rename? - fnew <- renameFileUniq fpath - info $ "renamed" <+> pretty fpath <+> pretty fnew - - debug $ "create dir" <+> pretty fpath - liftIO $ createDirectoryIfMissing True fpath - - let h = view remoteTree fe & fromHashRef - - lbs <- runExceptT (readFromMerkle sto (ToDecryptBS kr h)) - >>= orThrowUser ("can't read file" <+> pretty h <+> pretty key) - - let fn = w toFilePath key - - liftIO $ AwL.atomicWriteFile fn lbs - forM_ mt (liftIO . setModificationTime fn) - -renameFileUniq :: MonadUnliftIO m => FilePath -> m FilePath -renameFileUniq fs = do - - fnew' <- S.head_ do - for_ [1..] $ \i -> do - let new = fs <> "~" <> show i - here <- liftIO (doesFileExist new) - unless here do - S.yield new - - fnew <- orThrowUser ("can't rename file" <> pretty fs) fnew' - - liftIO $ renameFile fs fnew - - pure fnew - -isMissed :: (AppPerks m, MonadReader AppEnv m) - => AnyStorage - -> HashRef - -> m Bool - -isMissed sto h = do - miss <- withState (selectMissed h) - case miss of - Just False -> pure False - _ -> do - missed <- S.head_ (findMissedBlocks2 sto h) <&> isJust - withState (insertMissed h missed) - pure missed - -scanState :: forall e m . ( AppPerks m - , HasProtocol e (ServiceProto StorageAPI e) - , HasProtocol e (ServiceProto RefChanAPI e) - ) - => RpcEndpoints e - -> ShareCLI m HashRef - -scanState rpc = do - - debug "scanState" - - encStuff <- asks (view appEnc) - >>= readIORef - >>= orThrowUser "credentials not available" - - let kr = view kre encStuff - - let sto = AnyStorage (StorageClient (rpcStorage rpc)) - refchan <- asks (toRefChanId . view appRefChan) - - debug $ "scan state for" <+> pretty (AsBase58 refchan) - - rv <- callService @RpcRefChanGet (rpcRefChan rpc) refchan - >>= orThrowUser "getRefchan: rpc failure" - >>= orThrowUser "refchan not found" - - debug $ "refchan value" <+> pretty rv - - withState do - seen <- selectSeen rv - unless seen do - scanTx sto rv - commitAll - - props <- withState selectProposes - - -- FIXME: cache-somehow - ((px,e), meta) <- findGoodNewBlock kr sto props - >>= orThrowUser "no meta block found" - - withState do - for_ (mdFiles meta) $ \fe -> do - insertRemoteFile px (realToFrac e) meta fe - commitAll - - rfs <- withState $ selectRemoteFiles px - - for_ rfs $ \rf -> do - updateFile rpc rf - - withState $ insertSeen rv - - pure px - - where - - findGoodNewBlock kr sto props = do - runMaybeT (go props) - - where - - go [] = mzero - go (p:ps) = do - - let btx = fst p - missed <- lift $ isMissed sto btx - if missed then - go ps - else do - - what <- S.head_ do - walkMerkle (fromHashRef btx) (getBlock sto) $ \case - Right ( (hx:_) :: [HashRef] ) -> do - S.yield hx - - _ -> pure () - - hmeta <- toMPlus what - - meta <- runExceptT (readFromMerkle sto (ToDecryptBS [kr] (fromHashRef hmeta))) - >>= toMPlus - <&> GZip.decompress - <&> deserialiseOrFail @MetaData - >>= toMPlus - - if List.null (mdFiles meta) then do - go ps - else - pure (p,meta) - - scanTx sto rv = - -- FIXME: dont-process-twice - walkMerkle (fromHashRef rv) (getBlock sto) $ \case - Left h -> warn $ "missed block" <+> pretty h - - Right (hs ::[HashRef]) -> void $ runMaybeT do - trace $ "got some" <+> pretty (length hs) - - for_ hs $ \htx -> void $ runMaybeT do - - seen <- lift $ lift $ selectSeen htx - - -- debug $ "SEEN" <+> pretty seen <+> pretty htx - guard (not seen) - - bs <- toMPlus =<< getBlock sto (fromHashRef htx) - tx <- toMPlus $ deserialiseOrFail @(RefChanUpdate L4Proto) bs - - case tx of - Accept _ box -> do - (_, txx@(AcceptTran mt _ hp)) <- toMPlus $ unboxSignedBox0 box - trace $ "tx accept" <+> pretty htx <+> pretty hp <+> pretty mt - t <- toMPlus mt - lift $ lift $ insertAccept htx hp (fromIntegral t) - - Propose _ box -> do - (_, ProposeTran _ pbox :: ProposeTran L4Proto) <- toMPlus $ unboxSignedBox0 box - (_, bs2) <- toMPlus $ unboxSignedBox0 pbox - - let wtf = [ tryDetect (hashObject bs) (LBS.fromStrict bs2) ] - - mytx <- [ ha | AnnotatedHashRef _ ha <- universeBi wtf ] & listToMaybe & toMPlus - - trace $ "tx propose" <+> pretty htx <+> pretty mytx - lift $ lift $ insertPropose htx mytx - - lift $ lift $ insertSeen htx - -dontPost :: AppPerks m => ShareCLI m Bool -dontPost = do - opts <- asks ( view appOpts ) - replica <- isReplica - pure $ replica || or [ True | AppDontPostOpt <- opts ] - -isReplica :: AppPerks m => ShareCLI m Bool -isReplica = do - re <- asks _appOpts <&> (AppReplicaOpt `elem`) - conf <- getConf - pure $ re || or [ True | ListVal [SymbolVal "replica"] <- conf ] - -updateLocalState :: AppPerks m => ShareCLI m () -updateLocalState = do - - debug "updateLocalState" - - skip <- cfgValue @IgnoreOpt @(Set String) <&> Set.toList - - dir <- asks (view appWorkDir) - - let d = makeEntryKey mempty dir - - q <- newTQueueIO - - es <- liftIO (F.listFiles skip dir (atomically . writeTQueue q . makeEntryKey d)) - >> atomically (flushTQueue q) - - withState do - for_ es $ \e -> do - let fn = toFilePath e - t <- liftIO $ getModificationTime fn - - lf <- selectLocalFile e - - let newF = isNothing lf || (view localFileModTime <$> lf) /= Just t - - when newF do - h <- localHash (toFilePath e) - insertLocalFile e t h - - commitAll - -postState :: forall e s m . ( AppPerks m - , HasProtocol e (ServiceProto RefChanAPI e) - , HasProtocol e (ServiceProto StorageAPI e) - , s ~ HBS2Basic - ) - - => RpcEndpoints e - -> HashRef -- ^ current state - -> ShareCLI m () -postState rpc px = do - - debug "postState" - - encStuff <- asks (view appEnc) - >>= readIORef - >>= orThrowUser "credentials not available" - - let kr = view kre encStuff - - let (KeyringKeys pk sk) = view kre encStuff - - let sto = AnyStorage (StorageClient (rpcStorage rpc)) - refchan <- asks (toRefChanId . view appRefChan) - - -- генерим gk0 если нету: - gk0key <- makeGK0Key rpc - >>= orThrowUser "can't make gk0key (perhaps refchan is not available)" - - debug $ "gk0 key" <+> pretty gk0key - - gk0 <- getGK0 rpc - gkh <- writeAsMerkle sto (serialise gk0) - - debug $ "got GK0, okay" - - gks <- Symm.lookupGroupKey sk pk gk0 - & orThrow (userError $ show ("*** Can't decrypt group key" <+> pretty gkh)) - - w <- asks (view appWorkDir) - locals <- withState selectLocalFiles - - withState do - fee <- S.toList_ $ for_ locals $ \l -> do - let key = _localFileKey l - let fpath = w toFilePath key - r <- lift $ selectRemoteFile px key - - let rhash = _remoteLocalHash <$> r - let rtree = _remoteTree <$> r - let lhash = _localFileHash l - - here <- liftIO $ doesFileExist fpath - - when here do - if Just lhash == rhash && isJust r then do - - -- FIXME: only-if-readers-are-chanhed - -- делать только если поменялись читатели, - -- иначе будет тормозить на большом числе файлов - override <- genTreeOverride sto encStuff gk0 (fromJust rtree) - - case override of - Just (Left{}) -> do - -- nothing happen, no action required - S.yield $ Left $ FileEntry key lhash (fromJust rtree) - - Just (Right new) -> do - -- tree is overriden with new gk0 - S.yield $ Right $ FileEntry key lhash new - - Nothing -> do - -- errors during tree overriding, post new file - warn $ "errors while overriding tree" <+> pretty rtree - tree <- writeEncryptedFile gks gk0 sto fpath lhash - S.yield $ Right $ FileEntry key lhash tree - - else do - tree <- writeEncryptedFile gks gk0 sto fpath lhash - S.yield $ Right $ FileEntry key lhash tree - - let fe = List.sortOn (view feKey) (lefts fee <> rights fee) - - let updated = not $ List.null (rights fee) - - when updated do - - let gk1 = mempty - - let base = Just px - - let md = MetaData base gk1 fe - - -- можно брать только правые - let hashes = [ t | FileEntry _ _ t <- fe ] - - for_ (rights fee) $ \f -> do - info $ "M" <+> pretty (_feTree f) <+> pretty (_feKey f) - - let metabs = serialise md - & GZip.compressWith (defaultCompressParams { compressLevel = bestCompression }) - - manifest <- getLocalConfigDir <&> ( "manifest") - liftIO $ AwL.atomicWriteFile manifest metabs - - lh <- localHash manifest - mfhash <- writeEncryptedFile gks gk0 sto manifest lh - - let pt = toPTree (MaxSize 1024) (MaxNum 1024) (mfhash : hashes) -- FIXME: settings - - metaHash <- makeMerkle 0 pt $ \(_,_,bss) -> do - void $ liftIO (putBlock sto bss) - - info $ "entries:" <+> pretty (length hashes) <+> pretty metaHash - - let tx = AnnotatedHashRef Nothing (HashRef metaHash) - let ssk = view (creds . peerSignSk) encStuff - let spk = view (creds . peerSignPk) encStuff - - let box = makeSignedBox @L4Proto @BS.ByteString spk ssk (LBS.toStrict $ serialise tx) - - dont <- lift dontPost - - unless dont do - debug "POST TX" - r <- callService @RpcRefChanPropose (rpcRefChan rpc) (refchan, box) - pure () - - where - -- genTreeOverride :: AnyStorage -> EncryptionStuff -> GK0 HBS2Basic -> HashRef -> m () - genTreeOverride sto enc gk0 tree = do - let (KeyringKeys pk sk) = view kre enc - runMaybeT do - obj <- MaybeT $ getBlock sto (fromHashRef tree) - case tryDetect (fromHashRef tree) obj of - MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm2 o gkh0 nonce}) -> do - - gk0old <- runExceptT (readFromMerkle sto (SimpleKey gkh0)) - >>= toMPlus - <&> deserialiseOrFail @(GroupKey 'Symm s) - >>= toMPlus - - let rcptOld = HashMap.keysSet (recipients gk0old) - let rcptNew = HashMap.keysSet (recipients gk0) - - if rcptOld == rcptNew then do - pure (Left tree) - else do - - gksOld <- toMPlus $ Symm.lookupGroupKey sk pk gk0old - - gk1 <- generateGroupKey @s (Just gksOld) (HashSet.toList rcptNew) - - gk1h <- writeAsMerkle sto (serialise gk1) - - let newCrypt = EncryptGroupNaClSymm2 o gk1h nonce - let newTreeBlock = ann { _mtaCrypt = newCrypt } - - newTree <- enqueueBlock sto (serialise newTreeBlock) - >>= toMPlus - <&> HashRef - - pure (Right newTree) - - _ -> mzero - - -runSync :: AppPerks m => ShareCLI m () -runSync = do - - replica <- isReplica - info $ "replica:" <+> pretty replica - - flip runContT pure $ do - - rpc <- ContT $ withRpcClientUnix - - lift do - updateLocalState - px <- scanState rpc - updateLocalState - postState rpc px - -writeEncryptedFile :: forall m s nonce . (MonadIO m, Serialise nonce, s ~ HBS2Basic) - => GroupSecret - -> GroupKey 'Symm s - -> AnyStorage - -> FilePath - -> nonce - -> m HashRef -writeEncryptedFile gks gk0 sto fn h = do - let nonce = LBS.drop 1 (serialise h) & LBS.toStrict - - let sk1 = SipKey 2716310006254639645 507093936407764973 - let sk2 = SipKey 9209724780415729085 2720900864410773155 - let (SipHash a) = BA.sipHash sk1 nonce - let (SipHash b) = BA.sipHash sk2 nonce - - let bsStream = flip readChunkedBS defBlockSize =<< liftIO (LBS.readFile fn) - - -- TODO: fix-metadata - let source = ToEncryptSymmBS @s gks - (Right gk0) - nonce - bsStream - NoMetaData - (Just (EncryptGroupNaClSymmBlockSIP (a,b))) - - th <- runExceptT (writeAsMerkle sto source) - >>= orThrowUser "can't encrypt data" - - pure $ HashRef th - diff --git a/hbs2-share/src/HBS2/Share/App/Types.hs b/hbs2-share/src/HBS2/Share/App/Types.hs deleted file mode 100644 index 78215446..00000000 --- a/hbs2-share/src/HBS2/Share/App/Types.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# Language UndecidableInstances #-} -{-# Language TemplateHaskell #-} -module HBS2.Share.App.Types - ( module HBS2.Share.App.Types - , module HBS2.Data.Types.Refs - , module Data.Config.Suckless - , module HBS2.Peer.RPC.API.Peer - , module HBS2.Peer.RPC.API.Storage - , module HBS2.Peer.RPC.API.RefChan - , module UnliftIO - , module Control.Monad.Trans.Cont - , module Control.Monad.Reader - , module Lens.Micro.Platform - ) where - -import HBS2.Prelude.Plated -import HBS2.Base58 -import HBS2.Data.Types.Refs -import HBS2.Peer.Proto.RefChan -import HBS2.Net.Proto.Types -import HBS2.Net.Proto.Service -import HBS2.Net.Auth.Credentials - -import HBS2.Peer.RPC.API.Peer -import HBS2.Peer.RPC.API.Storage -import HBS2.Peer.RPC.API.RefChan - -import Data.Config.Suckless -import DBPipe.SQLite - -import Control.Monad.Trans.Cont -import Control.Monad.Reader -import Data.Maybe -import Lens.Micro.Platform -import UnliftIO - -newtype RChan = RChan { toRefChanId :: RefChanId L4Proto } - -deriving newtype instance FromStringMaybe RChan - -instance Pretty RChan where - pretty (RChan x) = pretty (AsBase58 x) - -instance IsString RChan where - fromString s = fromMaybe (error "invalid refchan") $ fromStringMay s - -data RpcEndpoints e = - RpcEndpoints - { rpcPeer :: ServiceCaller PeerAPI e - , rpcStorage :: ServiceCaller StorageAPI e - , rpcRefChan :: ServiceCaller RefChanAPI e - } - - -data EncryptionStuff = - EncryptionStuff - { _creds :: PeerCredentials HBS2Basic - , _kre :: KeyringEntry HBS2Basic - } - -makeLenses ''EncryptionStuff - - -data AppOption = AppDontPostOpt - | AppDebugOpt - | AppTraceOpt - | AppReplicaOpt - deriving stock (Eq,Ord,Show,Data,Generic) - -data AppEnv = - AppEnv - { _appOpts :: [AppOption] - , _appConf :: [Syntax C] - , _appRefChan :: RChan - , _appDb :: DBPipeEnv - , _appWorkDir :: FilePath - , _appRpcSock :: FilePath - , _appEnc :: IORef (Maybe EncryptionStuff) - } - -makeLenses ''AppEnv - - -newtype ShareCLI m a = ShareCLI { fromShareCLI :: ReaderT AppEnv m a } - deriving newtype - ( Applicative - , Functor - , Monad - , MonadIO - , MonadUnliftIO - , MonadReader AppEnv - ) - -type AppPerks m = MonadUnliftIO m - -instance (Monad m) => HasConf (ShareCLI m) where - getConf = asks (view appConf) - -instance Monad m => HasConf (ContT a (ShareCLI m)) where - getConf = lift getConf - - --- instance FromField HashRef - - diff --git a/hbs2-share/src/HBS2/Share/Config.hs b/hbs2-share/src/HBS2/Share/Config.hs deleted file mode 100644 index cc7e0b67..00000000 --- a/hbs2-share/src/HBS2/Share/Config.hs +++ /dev/null @@ -1,109 +0,0 @@ -module HBS2.Share.Config - ( module Data.Config.Suckless.KeyValue - , appName - , confDirName - , getWorkingDir - , getLocalConfigDir' - , getLocalConfigDir - , getLocalStatePath - , getLocalConfigDir' - , getLocalConfigFile' - , getLocalConfigFile - , readConfig - , IgnoreOpt - , RefChanOpt - , RpcUnixOpt - , SigilPathOpt - ) where - -import HBS2.Prelude.Plated -import HBS2.OrDie - -import HBS2.Share.App.Types - -import Data.Config.Suckless -import Data.Config.Suckless.KeyValue - -import System.Directory -import System.FilePath -import Data.Either -import Data.Set (Set) -import UnliftIO - - -data IgnoreOpt - -data RefChanOpt - -data RpcUnixOpt - -data SigilPathOpt - -instance Monad m => HasCfgKey IgnoreOpt (Set String) m where - key = "ignore" - -instance Monad m => HasCfgKey RefChanOpt (Maybe RChan) m where - key = "refchan" - -instance Monad m => HasCfgKey RpcUnixOpt (Maybe String) m where - key = "rpc.unix" - -instance Monad m => HasCfgKey SigilPathOpt (Maybe String) m where - key = "sigil" - -appName :: FilePath -appName = "hbs2-share" - -confDirName :: FilePath -confDirName = "." <> appName - -getWorkingDir :: MonadUnliftIO m => m FilePath -getWorkingDir = getLocalConfigDir <&> takeDirectory - -getLocalConfigDir' :: MonadIO m => m FilePath -getLocalConfigDir' = pure confDirName - - -getLocalConfigDir :: MonadIO m => m FilePath -getLocalConfigDir = findLocalConfDir confDirName - >>= orThrowUser "config not found" - -getLocalConfigFile' :: MonadIO m => m FilePath -getLocalConfigFile' = getLocalConfigDir' <&> ( "config") - -getLocalConfigFile :: MonadIO m => m FilePath -getLocalConfigFile = do - dir <- findLocalConfDir confDirName - >>= orThrowUser "config not found" - pure $ dir "config" - -getLocalStatePath :: MonadIO m => m FilePath -getLocalStatePath = do - path <- findLocalConfDir confDirName - >>= orThrowUser "config not found" - pure ( path "state.db" ) - -readConfig :: MonadIO m => m [Syntax C] -readConfig = do - liftIO $ try @_ @IOError (getLocalConfigFile >>= readFile) - <&> fromRight "" - <&> parseTop - <&> fromRight mempty - - -findLocalConfDir :: MonadIO m => FilePath -> m (Maybe FilePath) -findLocalConfDir filename = liftIO $ do - homeDir <- getHomeDirectory - currentDir <- getCurrentDirectory - findRecursively ( filename) currentDir homeDir - where - findRecursively _ currentDir homeDir - | currentDir == homeDir = return Nothing - | otherwise = do - let searchDir = currentDir filename - dirExists <- doesDirectoryExist searchDir - if dirExists - then return $ Just searchDir - else findRecursively ( filename) (takeDirectory currentDir) homeDir - - diff --git a/hbs2-share/src/HBS2/Share/Files.hs b/hbs2-share/src/HBS2/Share/Files.hs deleted file mode 100644 index 0cd61827..00000000 --- a/hbs2-share/src/HBS2/Share/Files.hs +++ /dev/null @@ -1,33 +0,0 @@ -module HBS2.Share.Files where - -import HBS2.Prelude.Plated - -import System.Directory -import System.FilePath -import Data.List qualified as List -import System.FilePattern -import Data.Function -import UnliftIO - - -listFiles :: MonadUnliftIO m => [FilePattern] -> FilePath -> (FilePath -> m ()) -> m () -listFiles ignore dir action = go dir - where - matches p f = or [ i ?== f | i <- p ] - - go fn = do - - let skip = or [ i ?== fn | i <- ignore ] - - unless skip do - isF <- liftIO $ doesFileExist fn - if isF then do - action fn - else do - isD <- liftIO $ doesDirectoryExist fn - when isD do - content <- liftIO $ listDirectory fn - forConcurrently_ [ fn x | x <- content, not (matches ignore x) ] $ \e -> do - go e - - diff --git a/hbs2-share/src/HBS2/Share/Keys.hs b/hbs2-share/src/HBS2/Share/Keys.hs deleted file mode 100644 index d6183b5b..00000000 --- a/hbs2-share/src/HBS2/Share/Keys.hs +++ /dev/null @@ -1,14 +0,0 @@ -module HBS2.Share.Keys where - -import HBS2.Prelude.Plated -import HBS2.Hash -import HBS2.Data.Types.Refs -import HBS2.Net.Proto.Types - -type GK0 s = GroupKey 'Symm s - -newtype GK0Key = GK0Key HashRef - deriving stock (Generic,Data) - deriving newtype (Pretty, Hashed HbSync) - - diff --git a/hbs2-share/src/HBS2/Share/LocalHash.hs b/hbs2-share/src/HBS2/Share/LocalHash.hs deleted file mode 100644 index 652c9aa6..00000000 --- a/hbs2-share/src/HBS2/Share/LocalHash.hs +++ /dev/null @@ -1,38 +0,0 @@ -module HBS2.Share.LocalHash where - -import HBS2.Prelude.Plated -import HBS2.Defaults (defBlockSize) -import HBS2.Hash -import HBS2.Data.Types.Refs -import HBS2.Storage.Operations.ByteString - -import HBS2.Share.App.Types - -import Data.ByteArray.Hash (SipHash(..), SipKey(..)) -import Data.ByteArray.Hash qualified as BA -import Streaming.Prelude qualified as S -import Data.ByteString.Lazy qualified as LBS -import Codec.Serialise - -newtype LocalHash = LocalHash { fromLocalHash :: Hash HbSync } - deriving stock (Eq,Ord,Data,Generic,Show) - -instance Serialise LocalHash - -instance Pretty LocalHash where - pretty (LocalHash h) = pretty h - -localHash :: MonadUnliftIO m => FilePath -> m LocalHash -localHash fp = do - liftIO $ withBinaryFile fp ReadMode $ \h -> do - lbs <- LBS.hGetContents h - readChunkedBS lbs defBlockSize - & S.map LBS.toStrict - & S.map (\z -> let (SipHash w) = BA.sipHash sk0 z in w) - & S.toList_ - <&> serialise - <&> LocalHash . hashObject @HbSync - where - sk0 = SipKey 5401424299739428297 3116460833428128256 - - diff --git a/hbs2-share/src/HBS2/Share/MetaData.hs b/hbs2-share/src/HBS2/Share/MetaData.hs deleted file mode 100644 index f64dc64d..00000000 --- a/hbs2-share/src/HBS2/Share/MetaData.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# Language TemplateHaskell #-} -module HBS2.Share.MetaData where - -import HBS2.Prelude.Plated -import HBS2.Data.Types.Refs - -import HBS2.Share.LocalHash - -import Data.HashMap.Strict qualified as HashMap -import Data.HashMap.Strict (HashMap) -import Codec.Serialise -import System.FilePath -import Data.List qualified as List -import Data.Maybe -import Data.Text qualified as Text -import Lens.Micro.Platform - -newtype PathEntry = PathEntry Text - deriving stock (Eq,Ord,Data,Generic,Show) - deriving newtype (Hashable,Pretty) - -newtype EntryKey = EntryKey { entryKey :: [PathEntry] } - deriving stock (Eq,Ord,Data,Generic,Show) - deriving newtype (Hashable,Semigroup,Monoid) - - -data FileEntry = - FileEntry - { _feKey :: EntryKey - , _feLocalHash :: LocalHash - , _feTree :: HashRef - } - deriving stock (Show,Data,Generic) - -makeLenses ''FileEntry - -instance IsString EntryKey where - fromString p = EntryKey [ PathEntry (fromString s) | s <- splitDirectories p ] - -instance Pretty EntryKey where - pretty (EntryKey ps) = pretty $ joinPath [ Text.unpack p | PathEntry p <- ps ] - - -toFilePath :: EntryKey -> FilePath -toFilePath = show . pretty - -data MetaData = - MetaData - { mdBase :: Maybe HashRef -- ^ reference to state TX - , mdGK1 :: HashMap HashRef HashRef - , mdFiles :: [FileEntry] - } - deriving stock (Show,Generic) - -instance Serialise PathEntry -instance Serialise EntryKey -instance Serialise FileEntry -instance Serialise MetaData - - -makeEntryKey :: EntryKey -> FilePath -> EntryKey -makeEntryKey (EntryKey prefix) path = EntryKey pnew - where - pp = entryKey $ fromString path - pnew = List.stripPrefix prefix pp & fromMaybe pp - -getDirs :: EntryKey -> [FilePath] -getDirs ek = fmap (joinPath . fmap unPathEntry) $ init $ tailSafe $ List.inits $ entryKey ek - where - unPathEntry (PathEntry p) = Text.unpack p - diff --git a/hbs2-share/src/HBS2/Share/State.hs b/hbs2-share/src/HBS2/Share/State.hs deleted file mode 100644 index f6bbcb97..00000000 --- a/hbs2-share/src/HBS2/Share/State.hs +++ /dev/null @@ -1,379 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# Language TemplateHaskell #-} -module HBS2.Share.State where - -import HBS2.Prelude -import HBS2.Hash -import HBS2.Share.App.Types -import HBS2.Share.Keys -import HBS2.Share.LocalHash -import HBS2.Share.MetaData - -import DBPipe.SQLite - -import Text.InterpolatedString.Perl6 (qc) -import Data.Maybe -import Data.Time (UTCTime) -import Data.Time.Clock.POSIX (posixSecondsToUTCTime) -import Data.List qualified as List - -data LocalFile = - LocalFile - { _localFileKey :: EntryKey - , _localFileModTime :: UTCTime - , _localFileHash :: LocalHash - } - deriving stock (Generic) - -makeLenses 'LocalFile - -data RemoteFile = - RemoteFile - { _remoteFileKey :: EntryKey - , _remoteFileTime :: UTCTime - , _remoteLocalHash :: LocalHash - , _remoteTree :: HashRef - } - deriving stock (Generic) - -makeLenses 'RemoteFile - -instance FromRow LocalFile - -instance FromRow RemoteFile - -class HasHash a where - toHash :: a -> Hash HbSync - -instance HasHash (Hash HbSync) where - toHash = id - -instance HasHash HashRef where - toHash = fromHashRef - -newtype HashVal = HashVal { fromHashVal :: HashRef } - deriving newtype (IsString) - -wrapHash :: HasHash hx => hx -> HashVal -wrapHash hx = HashVal (HashRef (toHash hx)) - -instance ToField GK0Key where - toField (GK0Key hs) = toField (show (pretty hs)) - -instance ToField HashVal where - toField (HashVal v) = toField (show (pretty v)) - -instance FromField HashVal where - fromField = fmap fromString . fromField @String - -instance ToField EntryKey where - toField p = toField (show $ pretty p) - -instance FromField EntryKey where - fromField = fmap (makeEntryKey mempty) . fromField @String - -instance ToField LocalHash where - toField (LocalHash l) = toField (HashVal (HashRef l)) - -instance FromField LocalHash where - fromField = fmap (LocalHash . fromHashRef . fromHashVal) . fromField @HashVal - -instance FromField HashRef where - fromField = fmap fromHashVal . fromField @HashVal - -populateState :: MonadUnliftIO m => DBPipeM m () -populateState = do - ddl [qc|create table if not exists gk0 - ( hash text not null - , gk0 text not null - , ts datetime default current_timestamp - , primary key (hash) - ) - |] - - ddl [qc|create table if not exists localfile - ( key text not null - , modtime datetime not null - , localhash text not null - , primary key (key) - ) - |] - - ddl [qc|create table if not exists localtree - ( key text not null - , tree text not null - , primary key (key) - ) - |] - - ddl [qc|create table if not exists accept - ( accept text not null - , propose text not null - , epoch int not null - , primary key (accept) - ) - |] - - ddl [qc|create table if not exists propose - ( propose text not null - , tx text not null - , primary key (propose) - ) - |] - - - ddl [qc|create table if not exists missed - ( hash text not null - , missed bool not null - , primary key (hash) - ) - |] - - createRemoteFileTable - createSeenTable - - commitAll - - -insertGK0 :: MonadUnliftIO m => GK0Key -> HashRef -> DBPipeM m () -insertGK0 gk0 val = do - insert [qc| - insert into gk0 (hash, gk0) values (?,?) - on conflict do update set gk0 = excluded.gk0 - |] (gk0, HashVal val) - - -selectGK0 :: MonadUnliftIO m => GK0Key -> DBPipeM m (Maybe HashRef) -selectGK0 gk0 = do - -- FIXME: time-hardcode - select [qc| - select gk0 from gk0 - where hash = ? and ts > datetime('now', '-30 days'); - limit 1 - |] (Only gk0) - <&> listToMaybe . fmap (fromHashVal . fromOnly) - -insertLocalFile :: MonadUnliftIO m - => EntryKey - -> UTCTime - -> LocalHash - -> DBPipeM m () - -insertLocalFile fkey modtime localhash = do - insert [qc| - insert into localfile (key, modtime, localhash) values (?,?,?) - on conflict (key) do update set modtime = excluded.modtime - , localhash = excluded.localhash - |] (fkey, modtime, localhash) - - -selectLocalFile :: MonadUnliftIO m => EntryKey -> DBPipeM m (Maybe LocalFile) -selectLocalFile fkey = do - select [qc| - select key - , modtime - , localhash - from localfile - where key = ?; - limit 1 - |] (Only fkey) - <&> listToMaybe - -selectLocalFiles :: MonadUnliftIO m => DBPipeM m [LocalFile] -selectLocalFiles = do - select_ [qc| - select key, modtime, localhash - from localfile - |] - -insertLocalTree :: forall hx m . (MonadUnliftIO m, HasHash hx) - => EntryKey - -> hx - -> DBPipeM m () -insertLocalTree fkey tree = do - insert [qc| - insert into localtree (key, tree) values (?,?) - on conflict (key) do update set tree = excluded.tree - |] (fkey, HashVal (HashRef (toHash tree))) - - -selectLocalTrees :: forall m . ( MonadUnliftIO m ) - => DBPipeM m [(EntryKey, LocalHash, HashRef)] -selectLocalTrees = do - select_ [qc| select t.key - , f.localhash - , t.tree - from localtree t join localfile f on t.key = f.key|] - <&> fmap (over _3 fromHashVal) - - -insertAccept :: forall hx m . ( MonadUnliftIO m, HasHash hx ) - => hx - -> hx - -> Integer - -> DBPipeM m () - -insertAccept k p t = do - insert [qc| - insert into accept (accept,propose,epoch) values (?,?,?) - on conflict (accept) do nothing - |] (HashVal (HashRef $ toHash k), HashVal (HashRef $ toHash p), t) - -insertPropose :: forall hx m . ( MonadUnliftIO m, HasHash hx ) - => hx - -> hx - -> DBPipeM m () - -insertPropose k tx = do - insert [qc| - insert into propose (propose,tx) values (?,?) - on conflict (propose) do nothing - |] (HashVal (HashRef $ toHash k), HashVal (HashRef $ toHash tx)) - - -selectProposes :: forall m . MonadUnliftIO m => DBPipeM m [(HashRef, Integer)] -selectProposes = do - let q = [qc| -WITH RankedAccept AS ( - SELECT a.propose, - a.epoch, - ROW_NUMBER() OVER (PARTITION BY a.propose ORDER BY a.epoch) AS rn, - COUNT(*) OVER (PARTITION BY a.propose) AS cnt - FROM accept a -), -T0 AS ( -SELECT p.propose, - p.tx, - cast(AVG(a.epoch) as int) AS epoch -FROM propose p -JOIN RankedAccept a ON p.propose = a.propose -WHERE a.rn IN ((a.cnt + 1) / 2, (a.cnt / 2) + 1) -GROUP BY p.propose, p.tx ) - -SELECT T0.tx, T0.epoch -FROM T0 -ORDER BY T0.epoch DESC|] - - select_ q <&> fmap (over _1 fromHashVal) - -selectMissed :: MonadUnliftIO m => HashRef -> DBPipeM m (Maybe Bool) -selectMissed hash = do - select [qc| - select missed from missed where hash = ? limit 1 - |] (Only (HashVal hash)) <&> fmap fromOnly . listToMaybe - -insertMissed :: MonadUnliftIO m => HashRef -> Bool -> DBPipeM m () -insertMissed hash miss = do - insert [qc| - insert into missed (hash,missed) values (?,?) - on conflict (hash) do update set missed = excluded.missed - |] (HashVal hash, miss) - -deleteMissed :: MonadUnliftIO m => HashRef -> DBPipeM m () -deleteMissed hash = do - insert [qc| - delete from missed where hash = ? - |] (Only (HashVal hash)) - - -createRemoteFileTable :: MonadUnliftIO m => DBPipeM m () -createRemoteFileTable = do - ddl [qc|create table if not exists remotefile - ( propose text not null - , key text not null - , localhash text not null - , tree text not null - , time datetime not null - , primary key (propose,key) - ) - |] - -insertRemoteFile :: ( MonadUnliftIO m - , Real epoch - , Fractional epoch - ) - => HashRef - -> epoch - -> MetaData - -> FileEntry - -> DBPipeM m () -insertRemoteFile px epoch _ fe = do - insert [qc| - insert into remotefile - ( propose - , key - , localhash - , tree - , time - ) - values (?,?,?,?,?) - on conflict (propose,key) - do update - set localhash = excluded.localhash - , tree = excluded.tree - , time = excluded.time - - |] ( HashVal px - , _feKey fe - , _feLocalHash fe - , HashVal (_feTree fe) - , posixSecondsToUTCTime $ realToFrac epoch - ) - -selectRemoteFiles :: (MonadUnliftIO m) - => HashRef - -> DBPipeM m [RemoteFile] -selectRemoteFiles px = do - select [qc| - select key - , time - , localhash - , tree - from remotefile where propose = ? - |] (Only (HashVal px)) - - -selectRemoteFile :: (MonadUnliftIO m) - => HashRef - -> EntryKey - -> DBPipeM m (Maybe RemoteFile) -selectRemoteFile px k = do - select [qc| - select key - , time - , localhash - , tree - from remotefile where propose = ? and key = ? - limit 1 - |] (HashVal px, k) <&> listToMaybe - - -createSeenTable :: MonadUnliftIO m => DBPipeM m () -createSeenTable = do - ddl [qc|create table if not exists seen - ( hash text not null - , primary key (hash) - ) - |] - - -insertSeen :: (MonadUnliftIO m, HasHash hx) - => hx - -> DBPipeM m () -insertSeen hx = do - insert [qc| - insert into seen (hash) - values (?) - on conflict (hash) - do nothing - |] (Only $ wrapHash hx) - -selectSeen :: (MonadUnliftIO m, HasHash hx) - => hx - -> DBPipeM m Bool -selectSeen hx = do - select [qc| - select 1 from seen where hash = ? limit 1 - |] (Only $ wrapHash hx) - <&> (maybe False fromOnly . listToMaybe) - diff --git a/hbs2-storage-simple/benchmarks/Main.hs b/hbs2-storage-simple/benchmarks/Main.hs index 6b635c41..da0f8806 100644 --- a/hbs2-storage-simple/benchmarks/Main.hs +++ b/hbs2-storage-simple/benchmarks/Main.hs @@ -6,6 +6,7 @@ import HBS2.Hash import HBS2.Data.Types.Refs import HBS2.Storage import HBS2.Storage.Simple +import HBS2.Storage.Compact import System.TimeIt @@ -13,12 +14,14 @@ import DBPipe.SQLite import System.Environment import System.FilePath +import System.IO.Temp import System.Random (randomRIO) import Control.Monad (replicateM) import Data.ByteString.Lazy qualified as LBS import Data.Word (Word8) +import Data.Coerce import Data.Function import Text.InterpolatedString.Perl6 (qc) import Control.Monad @@ -27,6 +30,7 @@ import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap import Data.Map (Map) import Data.Map qualified as Map +import Data.List.Split (chunksOf) import Streaming.Prelude (Of,Stream) import Streaming.Prelude qualified as S @@ -63,9 +67,7 @@ main = do let s = readDef @Int 256 ss let p = pref - -- let bss = randomByteStrings n s - let bss2 = randomByteStrings n s - let bss3 = randomByteStrings n s + bss <- S.toList_ $ randomByteStrings n s -- let bss41 = randomByteStrings (n `div` 2) s -- let bss42 = randomByteStrings (n`div` 2) s -- let bss43 = randomByteStrings (n`div`4) s @@ -91,27 +93,28 @@ main = do print $ "preparing to write" <+> pretty n <+> "chunks" - -- timeItNamed "write chunks test" do - -- S.mapM_ (enqueueBlock storage) bss - - timeItNamed "write chunks to sqlite test" do - withDB env $ transactional do - flip S.mapM_ bss2 $ \bs -> do - let h = hashObject @HbSync bs & pretty & show - insert [qc|insert into wtf (hash,val) values(?,?)|] (h,bs) - timeItNamed "write chunks to log" do fh <- openFile (path "lsm") AppendMode - flip S.mapM_ bss3 $ \bs -> do + forM_ bss $ \bs -> do let h = hashObject @HbSync bs & pretty & show LBS.hPut fh (serialise (h,bs)) hClose fh + timeItNamed "write chunks to simple storage" do + mapM_ (enqueueBlock storage) bss + + timeItNamed "write chunks to sqlite test" do + withDB env $ transactional do + forM_ bss $ \bs -> do + let h = hashObject @HbSync bs & pretty & show + insert [qc|insert into wtf (hash,val) values(?,?)|] (h,bs) + + timeItNamed "write chunks to log 2" do buf <- newIORef (mempty, 0 :: Int) fh <- openFile (path "lsm2") AppendMode - flip S.mapM_ bss3 $ \bs -> do + forM_ bss $ \bs -> do let h = hashObject @HbSync bs & pretty & show num <- atomicModifyIORef buf (\(chunks,sz) -> ((serialise (h,bs) : chunks,sz+1),sz+1)) @@ -124,6 +127,24 @@ main = do hClose fh + let cn = length bss `div` 2 + let chu = chunksOf cn bss + + timeItNamed "write chunks to compact-storage" do + + temp <- liftIO $ emptyTempFile "." "compact-storage" + + sto <- compactStorageOpen mempty temp + + w <- for chu $ \css -> do + async do + for_ css $ \bs -> do + let h = hashObject @HbSync bs + compactStoragePut sto (coerce h) (LBS.toStrict bs) + + mapM_ wait w + compactStorageClose sto + timeItNamed "write chunks to LSM-mock" do if n*s > 1073741824 then do diff --git a/hbs2-storage-simple/hbs2-storage-simple.cabal b/hbs2-storage-simple/hbs2-storage-simple.cabal index 4eccfd58..59aa71ec 100644 --- a/hbs2-storage-simple/hbs2-storage-simple.cabal +++ b/hbs2-storage-simple/hbs2-storage-simple.cabal @@ -59,6 +59,7 @@ library import: shared-properties exposed-modules: HBS2.Storage.Simple , HBS2.Storage.Simple.Extra + , HBS2.Storage.Compact -- other-modules: -- other-extensions: build-depends: base, hbs2-core @@ -66,14 +67,18 @@ library , atomic-write , bytestring , bytestring-mmap + , binary , cache , containers , directory , filepath + , memory , microlens-platform , mtl + , mmap , prettyprinter , random + , safe , stm , stm-chans , streaming @@ -84,6 +89,9 @@ library , unordered-containers , temporary , filepattern + , unliftio + , unix + , vector hs-source-dirs: lib @@ -96,6 +104,7 @@ test-suite test other-modules: TestSimpleStorage + TestCompactStorage -- other-extensions: @@ -119,6 +128,7 @@ test-suite test , random , safe , serialise + , streaming , tasty , tasty-hunit , temporary @@ -167,6 +177,7 @@ executable hbs2-storage-simple-benchmarks , safe , serialise , streaming + , split , text , temporary , transformers diff --git a/hbs2-storage-simple/lib/HBS2/Storage/Compact.hs b/hbs2-storage-simple/lib/HBS2/Storage/Compact.hs new file mode 100644 index 00000000..049308f2 --- /dev/null +++ b/hbs2-storage-simple/lib/HBS2/Storage/Compact.hs @@ -0,0 +1,728 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# Language ViewPatterns #-} +{-# Language UndecidableInstances #-} +module HBS2.Storage.Compact + ( Storage(..) + , CompactStorageOpenError(..) + , CompactStorage + , CompactStorageOpenOpt(..) + , CompactStorageError(..) + , readonly + , compactStorageOpen + , compactStorageClose + , compactStorageCommit + , compactStoragePut + , compactStorageGet + , compactStorageDel + , compactStorageSize + , compactStorageFindLiveHeads + , compactStorageRun + , HBS2.Storage.Compact.keys + , HBS2.Storage.Compact.member + , HBS2.Storage.Compact.put + , HBS2.Storage.Compact.putVal + , HBS2.Storage.Compact.get + , HBS2.Storage.Compact.getValEither + , HBS2.Storage.Compact.del + , HBS2.Storage.Compact.commit + ) where + +import HBS2.Clock +import HBS2.Hash +import HBS2.Storage + +import Data.Word +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Internal qualified as BS +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Builder as B +import Data.Binary.Get +import Data.Coerce +import Data.Function +import Data.List qualified as List +import Data.Maybe +import Data.HashMap.Strict (HashMap) +import Data.HashMap.Strict qualified as HM +import Data.Foldable +import Data.Traversable +import Data.Vector (Vector,(!)) +import Data.Vector qualified as V +import Codec.Serialise +import GHC.Generics +import Lens.Micro.Platform +import Control.Monad.Except +import Control.Monad.Trans.Maybe +import UnliftIO + +import Foreign +import System.IO.MMap + +import Debug.Trace + +-- compact storage +-- for the off-tree data representation +-- may be it will be faster, than Simple storage +-- who knows + +newtype EntryOffset = EntryOffset Word64 + deriving newtype (Ord,Eq,Num,Enum,Real,Integral,Show) + deriving stock Generic + +newtype FwdEntryOffset = FwdEntryOffset Word64 + deriving newtype (Ord,Eq,Num,Enum,Real,Integral,Show) + deriving stock Generic + +newtype EntrySize = EntrySize Word64 + deriving newtype (Ord,Eq,Num,Enum,Real,Integral,Show) + deriving stock Generic + + +newtype EntryNum = EntryNum Word32 + deriving newtype (Ord,Eq,Num,Enum,Real,Integral,Show) + deriving stock Generic + +data IndexEntry = + IndexEntry + { idxEntryOffset :: !EntryOffset + , idxEntrySize :: !EntrySize + , idxEntrySeq :: !Word64 + , idxEntryTomb :: !Bool + , idxEntryKey :: !ByteString + } + deriving stock (Show,Generic) + + +instance Serialise EntryOffset +instance Serialise EntrySize +instance Serialise EntryNum +instance Serialise IndexEntry + +data Header = + Header + { hdrMagic :: Word16 + , hdrVersion :: Word16 + , hdrFwdOffset :: FwdEntryOffset + , hdrIndexOffset :: EntryOffset + , hdrIndexEntries :: EntryNum + , hdrPrev :: EntryOffset + } + deriving stock (Show,Generic) + +data E = New ByteString + | Upd ByteString IndexEntry + | Off IndexEntry + | Del IndexEntry + +data Entry = Entry Integer E + +pattern Fresh :: Entry -> Entry +pattern Fresh e <- e@(Entry _ ( isFresh -> True )) + +pattern Tomb :: Entry -> Entry +pattern Tomb e <- e@(Entry _ ( isTomb -> True )) + +pattern Existed :: Entry -> IndexEntry -> Entry +pattern Existed e w <- e@(Entry _ (existed -> Just w)) + +-- {-# COMPLETE Existed #-} + +isAlive :: Entry -> Bool +isAlive = \case + Entry _ New{} -> True + Entry _ Upd{} -> True + Entry _ e@(Off{}) -> not (isTomb e) + _ -> False + +isTomb :: E -> Bool +isTomb (Off e) = idxEntryTomb e +isTomb _ = False + +existed :: E -> Maybe IndexEntry +existed = \case + Off e -> Just e + Upd _ e -> Just e + Del e -> Just e + _ -> Nothing + +isFresh :: E -> Bool +isFresh e = case e of + New{} -> True + Del{} -> True + Upd{} -> True + _ -> False + +type Bucket = TVar (HashMap ByteString Entry) + +type MMaped = (ForeignPtr Word8, Int, Int) + +data CompactStorage k = + CompactStorage + { csBuckets :: Int + , csFile :: FilePath + , csOpts :: CompactStorageOpenOpt + , csHandle :: MVar Handle + , csHeaderOff :: TVar EntryOffset + , csSeq :: TVar Integer + , csKeys :: Vector Bucket + , csUncommitted :: TVar Integer + , csMMapped :: TVar MMaped + } + +type ForCompactStorage m = MonadIO m + +data CompactStorageOpenOpt = + CompactStorageOpenOpt + { csReadOnly :: Bool + } + + +instance Monoid CompactStorageOpenOpt where + mempty = CompactStorageOpenOpt False + +instance Semigroup CompactStorageOpenOpt where + (<>) _ b = CompactStorageOpenOpt (csReadOnly b) + +readonly :: CompactStorageOpenOpt +readonly = CompactStorageOpenOpt True + +data CompactStorageOpenError = + InvalidHeader + | BrokenIndex + | InvalidFwdSection + deriving stock (Typeable,Show) + +instance Exception CompactStorageOpenError + +getBucket :: CompactStorage k -> ByteString -> Bucket +getBucket sto bs = do + let i = maybe 0 (fromIntegral.fst) (BS.uncons bs) `mod` csBuckets sto + csKeys sto ! i +{-# INLINE getBucket #-} + + +compactStorageOpen :: forall k m . (ForCompactStorage m) + => CompactStorageOpenOpt + -> FilePath + -> m (CompactStorage k) + +compactStorageOpen opt fp = do + + let buck = 8 + + ha <- openFile fp ReadWriteMode + + sz <- hFileSize ha + mha <- newMVar ha + + hoff0 <- newTVarIO 0 + + keys0 <- replicateM buck (newTVarIO mempty) <&> V.fromList + uncommitted <- newTVarIO 0 + + ss <- newTVarIO 0 + + mmapped <- liftIO (mmapFileForeignPtr fp ReadOnly Nothing) + >>= newTVarIO + + if sz == 0 then + pure $ CompactStorage buck fp opt mha hoff0 ss keys0 uncommitted mmapped + else do + (p,header) <- readHeader mha Nothing >>= maybe (throwIO InvalidHeader) pure + hoff <- newTVarIO p + let sto = CompactStorage buck fp opt mha hoff ss keys0 uncommitted mmapped + readIndex sto (hdrIndexOffset header) (hdrIndexEntries header) + + flip fix (hdrPrev header) $ \next -> \case + 0 -> pure () + off -> do + (_,pHeader) <- readHeader mha (Just off) >>= maybe (throwIO InvalidHeader) pure + readIndex sto (hdrIndexOffset pHeader) (hdrIndexEntries pHeader) + next (hdrPrev pHeader) + + pure sto + + +readIndex :: ForCompactStorage m + => CompactStorage k + -> EntryOffset + -> EntryNum + -> m () +readIndex sto offset num = liftIO do + withMVar (csHandle sto) $ \ha -> do + hSeek ha AbsoluteSeek (fromIntegral offset) + (rn,entries) <- flip fix (num, mempty, 0) $ \next left -> do + case left of + (0,acc,n) -> pure (n,acc) + (n,acc,rn) -> do + what <- runMaybeT do + + slen <- liftIO (try @_ @IOException (BS.hGet ha 2)) + <&> either (const Nothing) Just + & MaybeT + <&> LBS.fromStrict + + len <- either (const Nothing) (Just . view _3) (runGetOrFail getWord16be slen) + & MaybeT . pure + + sIdx <- liftIO (try @_ @IOException (BS.hGet ha (fromIntegral len))) + >>= either (const mzero) pure + <&> LBS.fromStrict + + deserialiseOrFail @IndexEntry sIdx + & either (const mzero) pure + + case what of + Nothing -> pure (0,mempty :: [IndexEntry]) + Just idx -> next (pred n, idx : acc, succ rn) + + when (rn /= num) do + throwIO BrokenIndex + + let new = [ (idxEntryKey e,Entry 0 (Off e)) | e <- entries ] + -- readIndex from newer to older + -- so we keep only the newer values in map + atomically do + for_ new $ \(k,v) -> do + let tv = getBucket sto k + modifyTVar tv (HM.insertWith (\_ o -> o) k v) + +compactStorageCommit :: ForCompactStorage m => CompactStorage k -> m () +compactStorageCommit sto = liftIO do + withMVar (csHandle sto) $ \ha -> do + hSeek ha SeekFromEnd 0 + + mma <- readTVarIO (csMMapped sto) + + kv <- atomically do + mapM readTVar (csKeys sto) <&> mconcat . V.toList . fmap HM.toList + + let items = [ (k, e) + | (k, e@Fresh{}) <- kv + , reallyUpdated mma e + ] + + unless (List.null items) do + + -- write fwd + offFwd <- hTell ha + BS.hPut ha (LBS.toStrict $ toLazyByteString $ word64BE 0) + + let off0 = offFwd + 8 + + -- write data + idxEntries <- flip fix (off0, items, mempty) $ \next (off, what, idx) -> do + case what of + [] -> pure idx + + ((_,Entry i (Del e)):rest) | not (idxEntryTomb e) -> do + next (off + 0, rest, (e { idxEntryTomb = True },i) : idx) + + ((k,Entry i (Upd v e)):rest) -> do + BS.hPut ha v + let sz = fromIntegral $ BS.length v + next (off + sz, rest, (IndexEntry (fromIntegral off) (fromIntegral sz) 0 False k,i) : idx) + + ((k,Entry i (New v)):rest) -> do + BS.hPut ha v + let sz = fromIntegral $ BS.length v + next (off + sz, rest, (IndexEntry (fromIntegral off) (fromIntegral sz) 0 False k,i) : idx) + + ((_,Entry _ _):rest) -> do + next (off + 0, rest, idx) + + + offIdx0 <- hTell ha <&> fromIntegral + + -- write index + for_ idxEntries $ \(e,_) -> do + let lbs = serialise e + BS.hPut ha $ LBS.toStrict (B.toLazyByteString $ + word16BE (fromIntegral $ LBS.length lbs) + <> B.lazyByteString lbs) + + offPrev <- readTVarIO (csHeaderOff sto) + + offCommitHead <- hTell ha + + -- FIXME: maybe-slow-length-calc + appendHeader ha (fromIntegral offFwd) (Just offPrev) offIdx0 (fromIntegral $ length idxEntries) + + hSeek ha AbsoluteSeek offFwd + + BS.hPut ha (LBS.toStrict $ toLazyByteString $ word64BE (fromIntegral offCommitHead)) + + hFlush ha + + hSeek ha SeekFromEnd 0 + + offLast <- hTell ha <&> fromIntegral + + remapFile + + atomically do + writeTVar (csHeaderOff sto) (offLast - headerSize 1) + for_ idxEntries $ \(e,i) -> do + let k = idxEntryKey e + let tv = getBucket sto k + modifyTVar tv (HM.alter (doAlter (Entry i (Off e))) k) + resetUncommitedSTM sto + + where + + doAlter y@(Entry i (Off e)) v0 = case v0 of + -- deleted-during-commit + Nothing -> Just (Entry i (Del e)) + + Just x | getSeq x > getSeq y -> Just x + | otherwise -> Just y + + doAlter _ v = v + + getSeq = \case + Entry i _ -> i + + remapFile :: ForCompactStorage m => m () + remapFile = do + let fp = csFile sto + unmapFile sto + mmapped <- liftIO (mmapFileForeignPtr fp ReadOnly Nothing) + atomically (writeTVar (csMMapped sto) mmapped) + + -- NOTE: this-might-be-slow + -- но это правильно, поскольку + -- у нас **compact** storage и мы не хотим, + -- что бы его раздувало одинаковыми значениями + -- Можно попробовать использовать siphash + -- при загрузке (?)... да ну нахрен, капец долго + -- будет. если только его не хранить (это можно) + reallyUpdated mma = \case + Entry _ (Upd v e) -> readValue mma e /= v + + _ -> True + + +compactStorageDel :: ForCompactStorage m => CompactStorage k -> ByteString -> m () +compactStorageDel sto key = do + + let tvar = getBucket sto key + val <- readTVarIO tvar <&> HM.lookup key + + case val of + Nothing -> pure () + + Just (Entry i (Del _)) -> pure () + + Just (Entry _ (New _)) -> do + -- FIXME: if-commit-in-progress-then-put-tomb + atomically do + modifyTVar tvar (HM.delete key) + succUncommitedSTM sto 1 + + Just (Existed e what) -> do + atomically do + j <- newSequenceSTM sto + modifyTVar tvar (HM.insert key (Entry j (Del what))) + succUncommitedSTM sto 1 + + -- FIXME: fix-incomplete-pattern-warning + _ -> pure () + +newSequenceSTM :: CompactStorage k -> STM Integer +newSequenceSTM sto = stateTVar (csSeq sto) (\n -> (n+1,n)) + +succUncommitedSTM :: CompactStorage k -> Integer -> STM () +succUncommitedSTM sto k = modifyTVar (csUncommitted sto) (+k) + +resetUncommitedSTM :: CompactStorage k -> STM () +resetUncommitedSTM sto = writeTVar (csUncommitted sto) 0 + +compactStorageSize :: ForCompactStorage m => CompactStorage k -> m Integer +compactStorageSize sto = liftIO $ withMVar (csHandle sto) hFileSize + +compactStoragePut :: ForCompactStorage m => CompactStorage k -> ByteString -> ByteString -> m () +compactStoragePut sto k v = do + let tvar = getBucket sto k + + atomically $ do + c <- newSequenceSTM sto + modifyTVar tvar (HM.insertWith check k (Entry c (New v))) + + where + check (Entry i (New v1)) (Entry _ (Off e)) = Entry i (Upd v1 e) + check (Entry i (New v1)) (Entry _ (Upd v0 e)) = Entry i (Upd v1 e) + check x _ = x + +readValue :: MMaped -> IndexEntry -> ByteString +readValue what e = do + let ptr = what & view _1 + BS.fromForeignPtr ptr (fromIntegral $ idxEntryOffset e) + (fromIntegral $ idxEntrySize e) +{-# INLINE readValue #-} + +compactStorageGet :: ForCompactStorage m => CompactStorage k -> ByteString -> m (Maybe ByteString) +compactStorageGet sto key = do + let tvar = getBucket sto key + val <- readTVarIO tvar <&> HM.lookup key + + case val of + Nothing -> pure Nothing + Just (Tomb{}) -> pure Nothing + Just (Entry _ (Del _)) -> pure Nothing + Just (Entry _ (New s)) -> pure (Just s) + Just (Entry _ (Upd s _)) -> pure (Just s) + Just (Entry _ (Off e)) -> Just <$> (readTVarIO (csMMapped sto) <&> flip readValue e) + +compactStorageExists :: ForCompactStorage m => CompactStorage k -> ByteString -> m (Maybe Integer) +compactStorageExists sto key = do + let tvar = getBucket sto key + val <- readTVarIO tvar <&> HM.lookup key + + case val of + Just (Entry _ (New s)) -> pure (Just (fromIntegral (BS.length s))) + Just (Entry _ (Off e)) -> pure (Just (fromIntegral $ idxEntrySize e)) + Just (Entry _ (Upd v e)) -> pure (Just (fromIntegral $ BS.length v)) + _ -> pure Nothing + +unmapFile :: ForCompactStorage m => CompactStorage sto -> m () +unmapFile sto = do + mmapped <- readTVarIO (csMMapped sto) + liftIO $ finalizeForeignPtr (view _1 mmapped) + -- NOTE: mmapped-is-invalid-now + -- если теперь позвать что-то, что + -- читает из этого мапинга -- то всё грохнется + + +compactStorageClose :: ForCompactStorage m => CompactStorage k -> m () +compactStorageClose sto = do + + unless (csOpts sto & csReadOnly) do + compactStorageCommit sto + + -- FIXME: hangs-forever-on-io-exception + liftIO $ do + unmapFile sto + withMVar (csHandle sto) hClose + +compactStorageFindLiveHeads :: ForCompactStorage m + => FilePath + -> m [(EntryOffset, Header)] + +compactStorageFindLiveHeads path = liftIO do + withFile path ReadMode $ \ha -> do + + mv <- newMVar ha + + flip fix (mempty :: [(EntryOffset, Header)]) $ \next acc -> do + + what <- runMaybeT do + + fwdOff <- hTell ha + + -- fwd section + fwd <- lift (LBS.fromStrict <$> BS.hGet ha 8) + <&> runGetOrFail getWord64be + >>= either (const mzero) pure + <&> view _3 + + h@(o,header) <- MaybeT $ readHeader mv (Just $ fromIntegral fwd) + + let magicOk = hdrMagic header == headerMagic + let fwdOk = hdrFwdOffset header == fromIntegral fwdOff + + if magicOk && fwdOk then + pure h + else + mzero + + maybe (pure acc) (\h -> next ( h : acc) ) what + + +compactStorageRun :: ForCompactStorage m => m () +compactStorageRun = forever do + pause @'Seconds 1 + +appendHeader :: ForCompactStorage m + => Handle + -> FwdEntryOffset -- fwd section offset + -> Maybe EntryOffset -- prev. header + -> EntryOffset + -> EntryNum + -> m () +appendHeader ha fwdOff poffset ioffset num = do + let bs = word16BE headerMagic -- 2 + <> word16BE headerVersion -- 4 + <> word64BE (coerce fwdOff) -- 12 + <> word64BE (coerce ioffset) -- 20 + <> word32BE (coerce num) -- 24 + <> word64BE (coerce $ fromMaybe 0 poffset) -- 32 + liftIO $ BS.hPut ha (LBS.toStrict $ B.toLazyByteString bs) + +readHeader :: ForCompactStorage m + => MVar Handle + -> Maybe EntryOffset + -> m (Maybe (EntryOffset, Header)) + +readHeader mha moff = do + (off,bs) <- liftIO $ withMVar mha $ \ha -> do + + case moff of + Nothing -> do + hSeek ha SeekFromEnd (negate $ headerSize 1) + Just off -> do + hSeek ha AbsoluteSeek (fromIntegral off) + + p <- hTell ha <&> fromIntegral + (p,) <$> BS.hGet ha (headerSize 1) + + let what = flip runGetOrFail (LBS.fromStrict bs) do + Header <$> getWord16be + <*> getWord16be + <*> getFwdOffset + <*> getOffset + <*> getNum + <*> getOffset + + pure $ either (const Nothing) (fmap (off,) . Just . view _3) what + + where + getOffset = EntryOffset <$> getWord64be + getNum = EntryNum <$> getWord32be + getFwdOffset = FwdEntryOffset <$> getWord64be + +headerMagic :: Word16 +headerMagic = 32264 + +headerVersion :: Word16 +headerVersion = 1 + +headerSize :: Integral a => Word16 -> a +headerSize 1 = fromIntegral (32 :: Integer) +headerSize _ = error "unsupported header version" + + +-- Map-like interface + +keys :: ForCompactStorage m => CompactStorage k -> m [ ByteString ] +keys sto = do + what <- atomically $ mapM readTVar (csKeys sto) + let w = foldMap HM.toList (V.toList what) + pure [ k | (k,x) <- w, isAlive x ] + +member :: ForCompactStorage m + => CompactStorage k + -> ByteString + -> m Bool +member s k = isJust <$> compactStorageExists s k + +put :: ForCompactStorage m + => CompactStorage k + -> ByteString + -> ByteString + -> m () + +put = compactStoragePut + +putVal :: forall k v m h . (ForCompactStorage m, Serialise k, Serialise v) + => CompactStorage h + -> k + -> v + -> m () +putVal sto k v = do + put sto (LBS.toStrict $ serialise k) (LBS.toStrict $ serialise v) + +get :: ForCompactStorage m + => CompactStorage k + -> ByteString + -> m (Maybe ByteString) + +get = compactStorageGet + +data CompactStorageError = + DeserealiseError + deriving (Typeable,Show) + +instance Exception CompactStorageError + +getValEither :: forall v k m h . ( ForCompactStorage m + , Serialise k, Serialise v + ) + => CompactStorage h + -> k + -> m (Either CompactStorageError (Maybe v)) + +getValEither sto k = do + bs <- get sto (LBS.toStrict (serialise k)) + let v = fmap (deserialiseOrFail @v . LBS.fromStrict) bs + case v of + Just (Left _) -> pure $ Left DeserealiseError + Just (Right x) -> pure $ Right (Just x) + Nothing -> pure (Right Nothing) + +del :: ForCompactStorage m + => CompactStorage k + -> ByteString + -> m () + +del = compactStorageDel + +commit :: ForCompactStorage m + => CompactStorage sto + -> m () +commit = compactStorageCommit + +-- Storage instance + +translateKey :: Coercible (Hash hash) ByteString + => ByteString + -> Hash hash + -> ByteString +translateKey prefix hash = prefix <> coerce hash + +{-# INLINE translateKey #-} + +instance ( MonadIO m, IsKey hash + , Hashed hash LBS.ByteString + , Coercible (Hash hash) ByteString + , Serialise (Hash hash) + , Key hash ~ Hash hash + , Eq (Key hash) + ) + => Storage (CompactStorage hash) hash LBS.ByteString m where + + putBlock = enqueueBlock + + enqueueBlock s lbs = do + let hash = hashObject @hash lbs + compactStoragePut s (translateKey "V" hash) (LBS.toStrict lbs) + pure (Just hash) + + getBlock s hash = do + compactStorageGet s (translateKey "V" hash) <&> fmap LBS.fromStrict + + getChunk s hash off size = runMaybeT do + bs <- MaybeT $ compactStorageGet s (translateKey "V" hash) + pure $ LBS.fromStrict $ BS.take (fromIntegral size) $ BS.drop (fromIntegral off) bs + + hasBlock sto k = do + compactStorageExists sto (translateKey "V" k) + + updateRef sto ref v = do + let hash = hashObject @hash ref + -- TODO: figure-out-what-to-do-with-metadata + compactStoragePut sto (translateKey "R" hash) (LBS.toStrict (serialise v)) + + getRef sto ref = do + let hash = hashObject @hash ref + runMaybeT do + v <- MaybeT $ compactStorageGet sto (translateKey "R" hash) + deserialiseOrFail @(Hash hash) (LBS.fromStrict v) + & either (const mzero) pure + + delBlock sto h = do + compactStorageDel sto (translateKey "V" h) + + delRef sto ref = do + compactStorageDel sto (translateKey "R" (hashObject @hash ref)) + + diff --git a/hbs2-storage-simple/test/Main.hs b/hbs2-storage-simple/test/Main.hs index c9f12f04..d7876420 100644 --- a/hbs2-storage-simple/test/Main.hs +++ b/hbs2-storage-simple/test/Main.hs @@ -4,10 +4,11 @@ import Test.Tasty import Test.Tasty.HUnit import TestSimpleStorage +import TestCompactStorage main :: IO () main = - defaultMain $ + defaultMain do testGroup "root" [ testCase "testSimpleStorageRandomReadWrite" testSimpleStorageRandomReadWrite @@ -15,6 +16,8 @@ main = , testCase "testSimpleStorageRefs" testSimpleStorageRefs , testCase "testSimpleStorageBundles" testSimpleStorageBundles , testCase "testSimpleStorageSymmEncryption" testSimpleStorageSymmEncryption + , testCase "testCompactStorage" testCompactStorageBasic + , testCase "testCompactStorageNoDupes" testCompactStorageNoDupes ] diff --git a/hbs2-storage-simple/test/TestCompactStorage.hs b/hbs2-storage-simple/test/TestCompactStorage.hs new file mode 100644 index 00000000..3bb0cd46 --- /dev/null +++ b/hbs2-storage-simple/test/TestCompactStorage.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE NumericUnderscores #-} +module TestCompactStorage where + +import HBS2.Prelude.Plated +import HBS2.Merkle +import HBS2.OrDie +import HBS2.Hash +import HBS2.Clock +import HBS2.Data.Types.Refs +import HBS2.Storage +import HBS2.Storage.Compact +import HBS2.Data.Bundle + +import Control.Monad.Except +import Control.Monad +import Control.Concurrent.Async +import Control.Concurrent +import Data.ByteString.Lazy qualified as LBS +import Data.Maybe +import Data.Word +import Lens.Micro.Platform +import Prettyprinter +import System.Directory +import System.FilePath.Posix +import System.IO.Temp +import Test.QuickCheck +import System.TimeIt +import System.IO + +import Streaming.Prelude qualified as S + +import Test.Tasty.HUnit + + +testCompactStorageBasic :: IO () +testCompactStorageBasic = do + + let elems = [ 0 .. 100_000 :: Int ] + + let pt = toPTree (MaxSize 1000) (MaxNum 256) elems + + withSystemTempDirectory "simpleStorageTest1" $ \dir -> do + let db = dir "storage" + sto <- compactStorageOpen @HbSync mempty db + + root <- makeMerkle 0 pt $ \(_,_,bss) -> do + void $ putBlock sto bss + + compactStorageClose sto + + sto2 <- compactStorageOpen @HbSync mempty db + + elems2 <- S.toList_ $ walkMerkle @[Int] root ( getBlock sto2 ) $ \case + Left{} -> error "missed block" + Right xs -> mapM_ S.yield xs + + assertEqual "elems-read-from-storage" elems elems2 + +testCompactStorageNoDupes :: IO () +testCompactStorageNoDupes = do + + let elems = [ 0 .. 1_000 :: Int ] + + withSystemTempDirectory "simpleStorageTest2" $ \dir -> do + let db = dir "storage" + sto <- compactStorageOpen @HbSync mempty db + + for_ elems $ \k -> do + put sto (LBS.toStrict $ serialise k) (LBS.toStrict $ serialise $ show $ pretty k) + + commit sto + + size1 <- compactStorageSize sto + + here <- for elems $ \e -> do + let k = LBS.toStrict $ serialise e + member sto k + + assertBool "all-members-here" (and here) + + for_ elems $ \k -> do + put sto (LBS.toStrict $ serialise k) (LBS.toStrict $ serialise $ show $ pretty k) + commit sto + + size2 <- compactStorageSize sto + + assertEqual "no-dupes" size1 size2 + + here2 <- for elems $ \e -> do + let k = LBS.toStrict $ serialise e + member sto k + + assertBool "all-members-here" (and here2) + + diff --git a/hbs2-share/CHANGELOG.md b/hbs2-sync/CHANGELOG.md similarity index 100% rename from hbs2-share/CHANGELOG.md rename to hbs2-sync/CHANGELOG.md diff --git a/hbs2-share/LICENSE b/hbs2-sync/LICENSE similarity index 100% rename from hbs2-share/LICENSE rename to hbs2-sync/LICENSE diff --git a/hbs2-sync/app/Main.hs b/hbs2-sync/app/Main.hs new file mode 100644 index 00000000..3fc49dca --- /dev/null +++ b/hbs2-sync/app/Main.hs @@ -0,0 +1,65 @@ +{-# Language ViewPatterns #-} +{-# Language PatternSynonyms #-} +module Main where + +import HBS2.Sync.Prelude +import HBS2.System.Dir + +import System.Environment +import System.Directory +import UnliftIO + + +helpEntries :: forall c m . (MonadUnliftIO m, IsContext c) => MakeDictM c m () +helpEntries = do + + entry $ bindMatch "help" $ nil_ $ \syn -> do + + display_ $ "hbs2-sync tool" <> line + + case syn of + + (StringLike p : _) -> do + helpList False (Just p) + + HelpEntryBound what -> helpEntry what + + _ -> helpList False Nothing + + quit + + entry $ bindMatch "--help" $ nil_ \case + HelpEntryBound what -> helpBanner >> helpEntry what >> quit + [StringLike s] -> helpBanner >> helpList False (Just s) >> quit + _ -> helpBanner >> helpList False Nothing >> quit + +helpBanner :: MonadUnliftIO m => m () +helpBanner = liftIO do + print $ + "hbs2-sync tool" <> line + +main :: IO () +main = do + + cli <- liftIO getArgs <&> unlines . fmap unwords . splitForms + >>= either (error.show) pure . parseTop + <&> \case + [] -> [mkList [mkSym "run-config"]] + xs -> xs + + let dict = makeDict do + helpEntries + syncEntries + + entry $ bindMatch "debug:cli:show" $ nil_ \case + _ -> display cli + + dir <- pwd + here <- liftIO $ doesFileExist (dir ".hbs2-sync/config") + + void $ runSyncApp $ recover $ do + when here $ runM dict do + void $ evalTop [ mkList [mkSym "dir", mkStr dir] ] + + run dict cli + diff --git a/hbs2-share/hbs2-share.cabal b/hbs2-sync/hbs2-sync.cabal similarity index 87% rename from hbs2-share/hbs2-share.cabal rename to hbs2-sync/hbs2-sync.cabal index 2ab9d413..a4c0abc3 100644 --- a/hbs2-share/hbs2-share.cabal +++ b/hbs2-sync/hbs2-sync.cabal @@ -1,5 +1,5 @@ cabal-version: 3.0 -name: hbs2-share +name: hbs2-sync version: 0.24.1.2 -- synopsis: -- description: @@ -70,6 +70,7 @@ common shared-properties , memory , microlens-platform , mtl + , prettyprinter , serialise , streaming , stm @@ -85,31 +86,24 @@ common shared-properties library import: shared-properties + exposed-modules: - HBS2.Share.App - HBS2.Share.App.Types - HBS2.Share.Config - HBS2.Share.State - HBS2.Share.Files - HBS2.Share.Keys - HBS2.Share.LocalHash - HBS2.Share.MetaData + HBS2.Sync.Prelude other-modules: -- other-modules: -- other-extensions: - build-depends: base, hbs2-peer + build-depends: base, hbs2-peer, hbs2-cli hs-source-dirs: src -executable hbs2-share +executable hbs2-sync import: shared-properties main-is: Main.hs -- other-modules: -- other-extensions: build-depends: - base, hbs2-share, hbs2-peer - , optparse-applicative + base, hbs2-sync, hbs2-peer hs-source-dirs: app default-language: GHC2021 diff --git a/hbs2-sync/src/HBS2/Sync/Prelude.hs b/hbs2-sync/src/HBS2/Sync/Prelude.hs new file mode 100644 index 00000000..7999e765 --- /dev/null +++ b/hbs2-sync/src/HBS2/Sync/Prelude.hs @@ -0,0 +1,1269 @@ +{-# Language UndecidableInstances #-} +{-# Language AllowAmbiguousTypes #-} +{-# Language TemplateHaskell #-} +{-# Language MultiWayIf #-} +{-# Language PatternSynonyms #-} +{-# Language ViewPatterns #-} +module HBS2.Sync.Prelude + ( module HBS2.Sync.Prelude + , module Exported + ) where + + +import HBS2.Prelude.Plated as Exported +import HBS2.Clock +import HBS2.Base58 +import HBS2.Data.Detect +import HBS2.Merkle +import HBS2.Merkle.MetaData +import HBS2.OrDie as Exported +import HBS2.Data.Types.Refs as Exported +import HBS2.Data.Types.SignedBox +import HBS2.Net.Auth.Credentials +import HBS2.Net.Auth.GroupKeySymm as Symm +import HBS2.Net.Proto.Service +import HBS2.Storage +import HBS2.Storage.Compact as Compact +import HBS2.Storage.Operations.Class +import HBS2.Storage.Operations.ByteString +import HBS2.Peer.Proto.RefChan +import HBS2.Peer.CLI.Detect +import HBS2.Peer.RPC.Client +import HBS2.Peer.RPC.Client.Unix +import HBS2.Peer.RPC.Client.RefChan as Client +import HBS2.Peer.RPC.Client.StorageClient +import HBS2.Peer.RPC.API.Peer +import HBS2.Peer.RPC.API.RefChan +import HBS2.Peer.RPC.API.Storage +import HBS2.System.Logger.Simple.ANSI as Exported +import HBS2.System.Dir +import HBS2.Misc.PrettyStuff as Exported + +import HBS2.CLI.Run hiding (PeerException(..)) +import HBS2.CLI.Run.MetaData +-- import HBS2.CLI.Run.GroupKey + +import HBS2.KeyMan.Keys.Direct + +import Data.Config.Suckless as Exported +import Data.Config.Suckless.Script as Exported +import Data.Config.Suckless.Script.File + +import Codec.Serialise as Exported +import Control.Applicative +import Control.Concurrent.STM (flushTQueue) +import Control.Monad.Reader as Exported +import Control.Monad.Trans.Cont as Exported +import Control.Monad.Trans.Maybe +import Control.Monad.Except +import Data.Ord +import Data.ByteString.Char8 qualified as BS8 +import Data.ByteString.Lazy qualified as LBS +import Data.Coerce +import Data.Either +import Data.HashMap.Strict qualified as HM +import Data.HashSet qualified as HS +import Data.List qualified as L +import Data.List (stripPrefix) +import Data.Map (Map) +import Data.Map qualified as Map +import Data.Maybe +import Data.Text qualified as Text +import Data.Set qualified as Set +import Data.Time.Clock.POSIX +import Data.Word +import Lens.Micro.Platform +import Streaming.Prelude qualified as S +import System.Directory (getModificationTime,setModificationTime,doesFileExist,listDirectory) +import System.Directory (XdgDirectory(..),getXdgDirectory) +import System.Exit qualified as Exit + +import UnliftIO.IO.File qualified as UIO + +{- HLINT ignore "Functor law" -} +{- HLINT ignore "Eta reduce" -} + +type MyRefChan = PubKey 'Sign 'HBS2Basic + +data DirSyncEnv = + DirSyncEnv + { _dirSyncPath :: Maybe FilePath + , _dirSyncRefChan :: Maybe MyRefChan + , _dirSyncCreds :: Maybe (PeerCredentials 'HBS2Basic) + , _dirSyncInclude :: [FilePattern] + , _dirSyncExclude :: [FilePattern] + } + deriving stock (Generic) + +makeLenses 'DirSyncEnv + +instance Monoid DirSyncEnv where + mempty = DirSyncEnv Nothing Nothing Nothing mempty ["**/*.hbs2-sync/state"] + +instance Semigroup DirSyncEnv where + (<>) a b = DirSyncEnv ( view dirSyncPath b <|> view dirSyncPath a ) + ( view dirSyncRefChan b <|> view dirSyncRefChan a ) + ( view dirSyncCreds b <|> view dirSyncCreds a ) + (L.nub $ view dirSyncInclude a <> view dirSyncInclude b ) + (L.nub $ view dirSyncExclude a <> view dirSyncExclude b ) + +instance Pretty DirSyncEnv where + pretty e = do + vcat $ catMaybes + [ pure ("; path" <+> pretty (view dirSyncPath e)) + , view dirSyncRefChan e >>= \x -> pure $ pretty $ mkList @C [mkSym "refchan", mkSym (show $ pretty (AsBase58 x))] + , view dirSyncCreds e >>= + \x -> pure $ pretty + $ mkList @C [mkSym "sign", mkSym (show $ pretty $ AsBase58 $ view peerSignPk x)] + , pure $ vcat (fmap (mkPattern "include") (view dirSyncInclude e)) + , pure $ vcat (fmap (mkPattern "exclude") (view dirSyncExclude e)) + ] + + where + mkPattern name p = pretty $ mkList @C [mkSym name, mkSym p] + +data SyncEnv = + SyncEnv + { refchanAPI :: ServiceCaller RefChanAPI UNIX + , storageAPI :: ServiceCaller StorageAPI UNIX + , peerAPI :: ServiceCaller PeerAPI UNIX + , dirSyncEnv :: TVar (Map FilePath DirSyncEnv) + , dirThis :: TVar (Maybe FilePath) + , dirTombs :: TVar (Map FilePath (CompactStorage HbSync)) + } + +newtype SyncApp m a = + SyncApp { fromSyncApp :: ReaderT (Maybe SyncEnv) m a } + deriving newtype ( Applicative + , Functor + , Monad + , MonadUnliftIO + , MonadIO + , MonadReader (Maybe SyncEnv)) + + +type SyncAppPerks m = MonadUnliftIO m + +class Monad m => HasTombs m where + getTombs :: m (CompactStorage HbSync) + closeTombs :: m () + +instance MonadUnliftIO m => HasTombs (SyncApp m) where + getTombs = do + SyncEnv{..} <- ask >>= orThrow PeerNotConnectedException + path <- getRunDir + + mbTomb <- dirTombs & readTVarIO + <&> Map.lookup path + + case mbTomb of + Just tomb -> pure tomb + Nothing -> do + -- FIXME: path-hardcode + let tombsPath = path ".hbs2-sync" "state" "tombs" + mkdir (dropFileName tombsPath) + stoTombs <- compactStorageOpen mempty tombsPath + atomically (modifyTVar dirTombs (Map.insert path stoTombs)) + pure stoTombs + + closeTombs = do + path <- getRunDir + + void $ runMaybeT do + + SyncEnv{..} <- lift ask >>= toMPlus + + tombs <- dirTombs & readTVarIO + <&> Map.lookup path + >>= toMPlus + + compactStorageClose tombs + +instance MonadIO m => HasClientAPI StorageAPI UNIX (SyncApp m) where + getClientAPI = ask >>= orThrow PeerNotConnectedException + <&> storageAPI + +instance MonadIO m => HasClientAPI RefChanAPI UNIX (SyncApp m) where + getClientAPI = ask >>= orThrow PeerNotConnectedException + <&> refchanAPI + +instance MonadIO m => HasClientAPI PeerAPI UNIX (SyncApp m) where + getClientAPI = ask >>= orThrow PeerNotConnectedException + <&> peerAPI + +instance MonadIO m => HasStorage (SyncApp m) where + getStorage = do + api <- getClientAPI @StorageAPI @UNIX + pure $ AnyStorage (StorageClient api) + +withSyncApp :: SyncAppPerks m => Maybe SyncEnv -> SyncApp m a -> m a +withSyncApp env action = runReaderT (fromSyncApp action) env + +runSyncApp :: SyncAppPerks m => SyncApp m a -> m a +runSyncApp m = do + setupLogger + withSyncApp Nothing m `finally` flushLoggers + +recover :: SyncApp IO a -> SyncApp IO a +recover what = do + catch what $ \case + PeerNotConnectedException -> do + + soname <- detectRPC + `orDie` "can't locate hbs2-peer rpc" + + flip runContT pure do + + client <- lift $ race (pause @'Seconds 1) (newMessagingUnix False 1.0 soname) + >>= orThrowUser ("can't connect to" <+> pretty soname) + + void $ ContT $ withAsync $ runMessagingUnix client + + peerAPI <- makeServiceCaller @PeerAPI (fromString soname) + refChanAPI <- makeServiceCaller @RefChanAPI (fromString soname) + storageAPI <- makeServiceCaller @StorageAPI (fromString soname) + + -- let sto = AnyStorage (StorageClient storageAPI) + + let endpoints = [ Endpoint @UNIX peerAPI + , Endpoint @UNIX refChanAPI + , Endpoint @UNIX storageAPI + ] + + void $ ContT $ withAsync $ liftIO $ runReaderT (runServiceClientMulti endpoints) client + + dsync <- newTVarIO mempty + this <- newTVarIO Nothing + tombs <- newTVarIO mempty + + let env = Just (SyncEnv refChanAPI storageAPI peerAPI dsync this tombs) + + liftIO $ withSyncApp env what + +data PeerException = + PeerNotConnectedException + deriving stock (Show, Typeable) + +instance Exception PeerException + +data RunDirectoryException = + RefChanNotSetException + | RefChanHeadNotFoundException + | EncryptionKeysNotDefined + | SignKeyNotSet + | DirNotSet + deriving stock (Show,Typeable) + +instance Exception RunDirectoryException + +removePrefix :: FilePath -> FilePath -> FilePath +removePrefix prefix path = + let prefixDirs = splitDirectories $ normalise prefix + pathDirs = splitDirectories $ normalise path + in joinPath $ fromMaybe pathDirs (stripPrefix prefixDirs pathDirs) + +getFileTimestamp :: MonadUnliftIO m => FilePath -> m Word64 +getFileTimestamp filePath = do + t0 <- liftIO $ getModificationTime filePath + pure (round $ utcTimeToPOSIXSeconds t0) + +-- FIXME: move-to-suckless-conf +class IsContext c => ToSexp c a where + toSexp :: a -> Syntax c + + +data EntryType = File | Dir | Tomb + deriving stock (Eq,Ord,Show,Data,Generic) + +data EntryDesc = + EntryDesc + { entryType :: EntryType + , entryTimestamp :: Word64 + , entryRemoteHash :: Maybe HashRef + } + deriving stock (Eq,Ord,Show,Data,Generic) + +newtype AsSexp c a = AsSexp a + +pattern TombLikeOpt :: forall {c} . Syntax c +pattern TombLikeOpt <- ListVal [StringLike "tomb:", tombLikeValue -> True] + +tombLikeValue :: Syntax c -> Bool +tombLikeValue = \case + StringLike "#t" -> True + StringLike "true" -> True + StringLike "yes" -> True + StringLike "tomb" -> True + LitBoolVal True -> True + _ -> False + +pattern WithRemoteHash :: Entry -> HashRef -> Entry +pattern WithRemoteHash e h <- e@(DirEntry (EntryDesc {entryRemoteHash = Just h}) _) + +pattern TombEntry :: Entry -> Entry +pattern TombEntry e <- e@(DirEntry (EntryDesc { entryType = Tomb }) _) + +pattern FileEntry :: Entry -> Entry +pattern FileEntry e <- e@(DirEntry (EntryDesc { entryType = File }) _) + +pattern UpdatedFileEntry :: Word64 -> Entry -> Entry +pattern UpdatedFileEntry t e <- e@(DirEntry (EntryDesc { entryType = File + , entryRemoteHash = Nothing + , entryTimestamp = t }) _) + +instance (IsContext c, ToSexp c w) => Pretty (AsSexp c w) where + pretty (AsSexp s) = pretty (toSexp @c s) + +data Entry = + DirEntry EntryDesc FilePath + deriving stock (Eq,Ord,Show,Data,Generic) + +instance IsContext c => ToSexp c EntryType where + toSexp a = mkStr @c $ Text.toLower $ Text.pack $ show a + +instance IsContext c => ToSexp c EntryDesc where + toSexp EntryDesc{..} = case entryType of + File -> mkForm @c "F" [mkInt entryTimestamp, hash] + Dir -> mkForm @c "D " [mkInt entryTimestamp, hash] + Tomb -> mkForm @c "T " [mkInt entryTimestamp, hash] + + where + hash = case entryRemoteHash of + Nothing -> nil + Just x -> mkStr (show $ pretty x) + +instance IsContext c => ToSexp c Entry where + toSexp (DirEntry w p) = mkForm @c "entry" [toSexp w, mkStr p] + + +makeTomb :: Word64 -> FilePath -> Maybe HashRef -> Entry +makeTomb t n h = DirEntry (EntryDesc Tomb t h) n + +entryPath :: Entry -> FilePath +entryPath (DirEntry _ p) = p + +getEntryTimestamp :: Entry -> Word64 +getEntryTimestamp (DirEntry d _) = entryTimestamp d + +getEntryHash :: Entry -> Maybe HashRef +getEntryHash (DirEntry d _) = entryRemoteHash d + +isFile :: Entry -> Bool +isFile = \case + DirEntry (EntryDesc { entryType = File}) _ -> True + _ -> False + +isTomb :: Entry -> Bool +isTomb = \case + DirEntry (EntryDesc { entryType = Tomb}) _ -> True + _ -> False + +isDir :: Entry -> Bool +isDir = \case + DirEntry (EntryDesc { entryType = Dir}) _ -> True + _ -> False + +entriesFromLocalFile :: MonadUnliftIO m => FilePath -> FilePath -> m (Map FilePath Entry) +entriesFromLocalFile prefix fn' = do + let fn0 = removePrefix prefix fn + ts <- getFileTimestamp fn + pure $ entriesFromFile Nothing ts fn0 + where + fn = normalise fn' + +entriesFromFile :: Maybe HashRef -> Word64 -> FilePath -> Map FilePath Entry +entriesFromFile h ts fn0 = do + let dirs = splitDirectories (dropFileName fn0) + & dropWhile (== ".") + let es = flip L.unfoldr ("",dirs) $ \case + (_,[]) -> Nothing + (p,d:ds) -> Just (dirEntry (p d), (p d, ds) ) + + Map.fromList [ (p, e) + | e@(DirEntry _ p) <- fileEntry fn0 : es + ] + where + dirEntry p = DirEntry (EntryDesc Dir ts Nothing) p + fileEntry p = DirEntry (EntryDesc File ts h) p + +runDirectory :: ( IsContext c + , SyncAppPerks m + , HasClientAPI RefChanAPI UNIX m + , HasClientAPI StorageAPI UNIX m + , HasStorage m + , HasRunDir m + , HasTombs m + , Exception (BadFormException c) + ) => RunM c m () +runDirectory = do + + path <- getRunDir + + runDir + `catch` \case + RefChanNotSetException -> do + err $ "no refchan set for" <+> pretty path + RefChanHeadNotFoundException -> do + err $ "no refchan head found for" <+> pretty path + EncryptionKeysNotDefined -> do + err $ "no readers defined in the refchan for " <+> pretty path + SignKeyNotSet -> do + err $ "sign key not set or not found " <+> pretty path + DirNotSet -> do + err $ "directory not set" + + `catch` \case + (e :: OperationError) -> do + err $ viaShow e + + `finally` do + closeTombs + + where + + + writeEntry path e = do + + let p = entryPath e + let filePath = path p + + sto <- getStorage + + tombs <- getTombs + + void $ runMaybeT do + h <- getEntryHash e & toMPlus + + notice $ green "write" <+> pretty h <+> pretty p + + lbs <- lift (runExceptT (getTreeContents sto h)) + >>= toMPlus + + mkdir (dropFileName filePath) + + liftIO $ UIO.withBinaryFileAtomic filePath WriteMode $ \fh -> do + LBS.hPutStr fh lbs >> hFlush fh + + let ts = getEntryTimestamp e + let timestamp = posixSecondsToUTCTime (fromIntegral ts) + + liftIO $ setModificationTime (path p) timestamp + + lift $ Compact.putVal tombs p (0 :: Integer) + + runDir = do + + sto <- getStorage + + path <- getRunDir + + env <- getRunDirEnv path >>= orThrow DirNotSet + + refchan <- view dirSyncRefChan env & orThrow RefChanNotSetException + + fetchRefChan @UNIX refchan + + -- FIXME: multiple-directory-scans + + local <- getStateFromDir0 True + + let hasRemoteHash = [ (p, h) | (p, WithRemoteHash e h) <- local] + + hasGK0 <- HM.fromList <$> S.toList_ do + for_ hasRemoteHash $ \(p,h) -> do + mgk0 <- lift $ loadGroupKeyForTree @HBS2Basic sto h + for_ mgk0 $ \gk0 -> S.yield (p,gk0) + + deleted <- findDeleted + + merged <- mergeState deleted local + + rch <- Client.getRefChanHead @UNIX refchan + >>= orThrow RefChanHeadNotFoundException + + let filesLast m = case mergedEntryType m of + Tomb -> 0 + Dir -> 1 + File -> 2 + + for_ (L.sortOn filesLast merged) $ \w -> do + case w of + N (p,TombEntry e) -> do + notice $ green "removed" <+> pretty p + + D (p,e) _ -> do + notice $ "deleted locally" <+> pretty p + + tombs <- getTombs + + n <- Compact.getValEither @Integer tombs p + <&> fromRight (Just 0) + + when (n < Just 2) do + postEntryTx (HM.lookup p hasGK0) refchan path e + Compact.putVal tombs p (maybe 0 succ n) + + N (p,_) -> do + notice $ "?" <+> pretty p + + M (f,t,e) -> do + notice $ green "move" <+> pretty f <+> pretty t + mv (path f) (path t) + notice $ green "post renamed entry tx" <+> pretty f + postEntryTx (HM.lookup f hasGK0) refchan path e + + E (p,UpdatedFileEntry _ e) -> do + let fullPath = path p + here <- liftIO $ doesFileExist fullPath + writeEntry path e + notice $ red "updated" <+> pretty here <+> pretty p + postEntryTx (HM.lookup p hasGK0) refchan path e + + E (p,e@(FileEntry _)) -> do + let fullPath = path p + here <- liftIO $ doesFileExist fullPath + d <- liftIO $ doesDirectoryExist fullPath + + older <- if here then do + s <- getFileTimestamp fullPath + pure $ s < getEntryTimestamp e + else + pure False + + when (not here || older) do + writeEntry path e + + void $ runMaybeT do + gk0 <- HM.lookup p hasGK0 & toMPlus + let rcpt = recipients gk0 & HM.keys + let members = view refChanHeadReaders rch & HS.toList + when (rcpt /= members) do + notice $ red "update group key" <+> pretty p + lift $ postEntryTx (Just gk0) refchan path e + + E (p,TombEntry e) -> do + let fullPath = path p + here <- liftIO $ doesFileExist fullPath + when here do + + tombs <- getTombs + postEntryTx (HM.lookup p hasGK0) refchan path e + + n <- Compact.getValEither @Integer tombs p + <&> fromRight (Just 0) + + Compact.putVal tombs p (maybe 0 succ n) + + notice $ red "deleted" <+> pretty p + rm fullPath + + E (p,_) -> do + notice $ "skip entry" <+> pretty p + + +findDeleted :: (MonadIO m, HasRunDir m, HasTombs m) => m [Merged] +findDeleted = do + + dir <- getRunDir + + now <- liftIO $ getPOSIXTime <&> round + + tombs <- getTombs + -- TODO: check-if-non-latin-filenames-work + -- resolved: ok + seen <- Compact.keys tombs + <&> fmap (deserialiseOrFail @FilePath . LBS.fromStrict) + <&> rights + + S.toList_ do + for_ seen $ \f0 -> do + + let path = dir f0 + + here <- liftIO $ doesFileExist path + + n <- Compact.getValEither @Integer tombs f0 + <&> fromRight (Just 0) + + when (not here && isJust n) do + S.yield (D (f0, makeTomb now f0 Nothing) n) + trace $ "found deleted" <+> pretty n <+> pretty f0 + + +postEntryTx :: ( MonadUnliftIO m + , HasStorage m + , HasRunDir m + , HasClientAPI StorageAPI UNIX m + , HasClientAPI RefChanAPI UNIX m + ) + => Maybe (GroupKey 'Symm 'HBS2Basic) + -> MyRefChan + -> FilePath + -> Entry + -> m () +postEntryTx mgk refchan path entry = do + + sto <- getStorage + + env <- getRunDirEnv path >>= orThrow DirNotSet + + creds <- view dirSyncCreds env & orThrow DirNotSet + + rch <- Client.getRefChanHead @UNIX refchan + >>= orThrow RefChanHeadNotFoundException + + void $ runMaybeT do + + guard (isFile entry || isTomb entry) + + let p = entryPath entry + lbs <- if isTomb entry then do pure mempty + else + -- FIXME: dangerous! + liftIO (LBS.readFile (path p)) + + let (dir,file) = splitFileName p + + let meta = HM.fromList [ ("file-name", fromString file) + ] + <> case dir of + "./" -> mempty + d -> HM.singleton "location" (fromString d) + <> if not (isTomb entry) then HM.empty + else HM.singleton "tomb" "#t" + + let members = view refChanHeadReaders rch & HS.toList + + -- FIXME: support-unencrypted? + when (L.null members) do + throwIO EncryptionKeysNotDefined + + let rcpt = maybe mempty (HM.keys . recipients) mgk + + gk <- case (members == rcpt, mgk) of + (True, Just g) -> pure g + (False,_) -> do + sec <- runMaybeT $ + toMPlus mgk >>= liftIO . runKeymanClient . extractGroupKeySecret >>= toMPlus + + case sec of + Just s -> Symm.generateGroupKey @'HBS2Basic (Just s) members + Nothing -> Symm.generateGroupKey @'HBS2Basic Nothing members + + _ -> Symm.generateGroupKey @'HBS2Basic Nothing members + + -- FIXME: survive-this-error? + href <- lift $ createTreeWithMetadata sto (Just gk) meta lbs + >>= orThrowPassIO + + let tx = AnnotatedHashRef Nothing href + let spk = view peerSignPk creds + let ssk = view peerSignSk creds + + -- FIXME: remove-nonce + -- пока что будем постить транзакцию всегда. + -- в дальнейшем стоит избавиться от нонса + nonce <- liftIO getPOSIXTime <&> serialise . take 4 . reverse . show + let box = makeSignedBox @HBS2Basic spk ssk (LBS.toStrict $ serialise tx <> nonce) + + notice $ red "post tree tx" <+> pretty p <+> pretty href + + lift $ postRefChanTx @UNIX refchan box + + +merge :: Entry -> Entry -> Entry +merge a b = do + if | getEntryTimestamp a > getEntryTimestamp b -> a + + | isFile a && isDir b -> a + + | isFile b && isDir a -> b + + | getEntryTimestamp a == getEntryTimestamp b -> + case (getEntryHash a, getEntryHash b) of + (Nothing,Nothing) -> b + (Just _,Nothing) -> a + (Nothing,Just _) -> b + (Just _, Just _) -> b + + | otherwise -> b + + +data Merged = N (FilePath, Entry) + | E (FilePath, Entry) + | D (FilePath, Entry) (Maybe Integer) + | M (FilePath,FilePath,Entry) +{-# COMPLETE N,E,M,D #-} + +pattern MergedEntryType :: EntryType -> Merged +pattern MergedEntryType t <- ( mergedEntryType -> t ) + +mergedEntryType :: Merged -> EntryType +mergedEntryType = \case + N (_,DirEntry d _) -> entryType d + E (_,DirEntry d _) -> entryType d + D (_,DirEntry d _) _ -> entryType d + M (_,_,DirEntry d _) -> entryType d + +instance (IsContext c) => ToSexp c Integer where + toSexp i = mkInt i + +instance (IsContext c, ToSexp c a) => ToSexp c (Maybe a) where + toSexp = \case + Nothing -> nil + Just x -> toSexp x + +instance IsContext c => ToSexp c Merged where + toSexp = \case + N (_, e) -> mkForm @c "N" [toSexp e] + E (_, e) -> mkForm @c "E" [toSexp e] + D (_, e) i -> mkForm @c "D" [toSexp e, toSexp i] + M (o, t, e) -> mkForm @c "M" [toSexp e,mkSym o,mkSym t] + +mergeState :: MonadUnliftIO m + => [Merged] + -> [(FilePath, Entry)] + -> m [Merged] + +mergeState seed orig = do + + let deleted = [ (p,d) | d@(D (p,e) c) <- seed, isTomb e, c < Just 1 ] & Map.fromList + + let dirs = [ (p,e) | (p,e) <- orig, isDir e ] & Map.fromListWith merge + + let files = [ (p, e) | D (p,e) _ <- Map.elems deleted] + <> [ (p,e) | (p,e) <- orig, isFile e ] + & Map.fromListWith merge + -- & Map.filterWithKey (\k ( -> not (Map.member k deleted)) + + let tombs = [ (p,e) | (p,e) <- orig, isTomb e ] & Map.fromListWith merge + + let names = Map.keysSet (dirs <> files) + + now <- liftIO $ getPOSIXTime <&> round + + S.toList_ do + for_ (Map.toList files) $ \(p,e@(DirEntry d _)) -> do + if + | Map.member p deleted -> do + for_ (Map.lookup p deleted) S.yield + + | Map.member p dirs -> do + let new = uniqName names p + S.yield $ M (p, new, DirEntry d new) + S.yield $ N (p, makeTomb now p Nothing) + + | Map.member p tombs -> do + let tomb = Map.lookup p tombs + case tomb of + Just t | getEntryTimestamp t >= getEntryTimestamp e -> do + S.yield $ E (p,t) + + _ -> S.yield $ E (p,e) + + | not (Map.member p deleted) -> do + S.yield $ E (p,e) + + | otherwise -> none + + where + uniqName names0 name = do + + flip fix (names0,0) $ \next (names,n) -> do + let suff = hashObject @HbSync (serialise (names, name, n)) + & pretty & show & drop 2 & take 4 + let new = name <> "~" <> suff + if Set.member new names then + next (Set.insert new names, succ n) + else + new + +-- NOTE: getStateFromDir +-- что бы устранить противоречия в "удалённом" стейте и +-- локальном, мы должны о них узнать +-- +-- Основное противоречие это file <=> dir +-- Так как мы не сохраняем каталоги, а только файлы +-- Каталоги выводим из файлов (таким образом, пустые каталоги будут игнорироваться) +-- +-- Допустим, у нас есть файл, совпадающий по имени с каталогом в remote state +-- Мы должны тогда вывести этот каталог из remote state и проверить, +-- чем он является тут (каталогом или файлом) +-- +-- Тогда функция устранения противоречий сможет что-то с этим сделать +-- впоследствии +-- + +getStateFromDir0 :: ( MonadIO m + , HasClientAPI RefChanAPI UNIX m + , HasClientAPI StorageAPI UNIX m + , HasStorage m + , HasRunDir m + ) + => Bool + -> m [(FilePath, Entry)] +getStateFromDir0 seed = do + + dir <- getRunDir + + env <- getRunDirEnv dir >>= orThrow DirNotSet + + let excl = view dirSyncExclude env + let incl = view dirSyncInclude env + + getStateFromDir seed dir incl excl + +getStateFromDir :: ( MonadIO m + , HasClientAPI RefChanAPI UNIX m + , HasClientAPI StorageAPI UNIX m + , HasStorage m + , HasRunDir m + ) + => Bool -- ^ use remote state as seed + -> FilePath -- ^ dir + -> [FilePattern] -- ^ include pattern + -> [FilePattern] -- ^ exclude pattern + -> m [(FilePath, Entry)] +getStateFromDir seed path incl excl = do + es' <- S.toList_ $ do + glob incl excl path $ \fn -> do + let fn0 = removePrefix path fn + es <- liftIO (entriesFromLocalFile path fn) + -- debug $ yellow "file" <+> viaShow ts <+> pretty fn0 + S.each es + pure True + + let es0 = [ (entryPath e, e) | e <- es' ] + + if not seed then do + pure es0 + else do + dir <- getRunDir + fromMaybe es0 <$> runMaybeT do + env <- getRunDirEnv dir >>= toMPlus + rchan <- view dirSyncRefChan env & toMPlus + es2 <- lift $ getStateFromRefChan rchan + + S.toList_ do + S.each es0 + for_ es2 $ \(p, e) -> do + d <- liftIO $ doesDirectoryExist (path p) + when d do + ts <- liftIO $ getFileTimestamp (path p) + S.yield (p, DirEntry (EntryDesc Dir ts mzero) p) + + S.yield (p,e) + + +getStateFromRefChan :: forall m . ( MonadIO m + , HasClientAPI RefChanAPI UNIX m + , HasClientAPI StorageAPI UNIX m + , HasStorage m + ) + => MyRefChan + -> m [(FilePath, Entry)] +getStateFromRefChan rchan = do + + debug $ red "getStateFromRefChan" <+> pretty (AsBase58 rchan) + + sto <- getStorage + + outq <- newTQueueIO + tss <- newTVarIO mempty + + -- FIXME: may-be-slow + walkRefChanTx @UNIX (const $ pure True) rchan $ \txh -> \case + A (AcceptTran ts _ what) -> do + -- debug $ red "ACCEPT" <+> pretty ts <+> pretty what + for_ ts $ \w -> do + atomically $ modifyTVar tss (HM.insertWith max what (coerce @_ @Word64 w)) + + P orig (ProposeTran _ box) -> void $ runMaybeT do + (_, bs) <- unboxSignedBox0 box & toMPlus + AnnotatedHashRef w href <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs) + & toMPlus . either (const Nothing) Just + + let findKey gk = liftIO (runKeymanClient (extractGroupKeySecret gk)) + + runExceptT (extractMetaData @'HBS2Basic findKey sto href) + >>= either (const none) ( \meta -> atomically $ writeTQueue outq (orig, (href, meta)) ) + + trees <- atomically (flushTQueue outq) + + tsmap <- readTVarIO tss + + ess0 <- S.toList_ do + for_ trees $ \(txh, (tree, meta)) -> do + let what = parseTop meta & fromRight mempty + let loc = headDef "" [ l | ListVal [StringLike "location:", StringLike l] <- what ] + + void $ runMaybeT do + fn <- toMPlus $ headMay [ l | ListVal [StringLike "file-name:", StringLike l] <- what ] + ts <- toMPlus $ HM.lookup txh tsmap + let tomb = or [ True | TombLikeOpt <- what ] + let fullPath = loc fn + + trace $ red "META" <+> pretty what + + if tomb then do + lift $ S.yield $ + Map.singleton fullPath (makeTomb ts fullPath (Just tree)) + else do + let r = entriesFromFile (Just tree) ts fullPath + lift $ S.yield r + + pure $ Map.toList $ Map.unionsWith merge ess0 + + +getTreeContents :: ( MonadUnliftIO m + , MonadError OperationError m + ) + => AnyStorage + -> HashRef + -> m LBS.ByteString + +getTreeContents sto href = do + + blk <- getBlock sto (coerce href) + >>= orThrowError MissedBlockError + + let q = tryDetect (coerce href) blk + + case q of + + MerkleAnn (MTreeAnn {_mtaCrypt = NullEncryption }) -> do + readFromMerkle sto (SimpleKey (coerce href)) + + MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm gkh _}) -> do + + rcpts <- Symm.loadGroupKeyMaybe @'HBS2Basic sto (HashRef gkh) + >>= orThrowError (GroupKeyNotFound 11) + <&> HM.keys . Symm.recipients + + kre <- runKeymanClient do + loadKeyRingEntries rcpts <&> fmap snd + + readFromMerkle sto (ToDecryptBS kre (coerce href)) + + _ -> throwError UnsupportedFormat + +class MonadIO m => HasRunDir m where + getRunDir :: m FilePath + getRunDirEnv :: FilePath -> m (Maybe DirSyncEnv) + alterRunDirEnv :: FilePath -> ( Maybe DirSyncEnv -> Maybe DirSyncEnv ) -> m () + +instance (MonadUnliftIO m) => HasRunDir (SyncApp m) where + getRunDir = ask >>= orThrow PeerNotConnectedException + >>= readTVarIO . dirThis + >>= orThrow DirNotSet + + getRunDirEnv dir = do + env <- ask >>= orThrow PeerNotConnectedException + >>= readTVarIO . dirSyncEnv + pure $ Map.lookup dir env + + alterRunDirEnv dir action = do + tenv <- ask >>= orThrow PeerNotConnectedException + <&> dirSyncEnv + atomically $ modifyTVar tenv (Map.alter action dir) + +instance HasRunDir m => HasRunDir (RunM c m) where + getRunDir = lift getRunDir + getRunDirEnv d = lift (getRunDirEnv d) + alterRunDirEnv d a = lift (alterRunDirEnv d a) + +instance HasRunDir m => HasRunDir (MaybeT m) where + getRunDir = lift getRunDir + getRunDirEnv d = lift (getRunDirEnv d) + alterRunDirEnv d a = lift (alterRunDirEnv d a) + +instance HasRunDir m => HasRunDir (ContT r m) where + getRunDir = lift getRunDir + getRunDirEnv d = lift (getRunDirEnv d) + alterRunDirEnv d a = lift (alterRunDirEnv d a) + + +instance HasTombs m => HasTombs (ContT r m) where + getTombs = lift getTombs + closeTombs = lift closeTombs + +instance HasTombs m => HasTombs (MaybeT m) where + getTombs = lift getTombs + closeTombs = lift closeTombs + +instance (Monad m, HasTombs m) => HasTombs (RunM c m) where + getTombs = lift getTombs + closeTombs = lift closeTombs + +syncEntries :: forall c m . ( MonadUnliftIO m + , IsContext c + , Exception (BadFormException c) + , HasClientAPI RefChanAPI UNIX m + , HasClientAPI StorageAPI UNIX m + , HasStorage m + , HasRunDir m + , HasTombs m + , MonadReader (Maybe SyncEnv) m + ) + => MakeDictM c m () +syncEntries = do + + entry $ bindMatch "--debug" $ nil_ $ \case + [SymbolVal "off"] -> do + setLoggingOff @DEBUG + + _ -> do + setLogging @DEBUG debugPrefix + + entry $ bindMatch "init" $ nil_ $ const do + pure () + + entry $ bindMatch "sync" $ nil_ $ \case + [StringLike d] -> do + + void $ evalTop [ mkList [mkSym "dir", mkStr d] + , mkList [mkSym "run"] + ] + + [] -> do + + void $ evalTop [ mkList [mkSym "dir", mkStr "."] + , mkList [mkSym "run"] + ] + + _ -> pure () + + brief "sets current directory" + $ args [ arg "string" "dir" ] + $ desc "useful for debugging" + $ entry $ bindMatch "dir" $ nil_ $ \case + [StringLike d] -> do + debug $ "set current directory" <+> pretty d + t <- lift ask >>= orThrow PeerNotConnectedException + atomically $ writeTVar (dirThis t) (Just d) + + alterRunDirEnv d $ \case + Nothing -> Just (mempty & set dirSyncPath (Just d)) + Just x -> Just (x & set dirSyncPath (Just d)) + + ins <- try @_ @IOError (liftIO $ readFile (d ".hbs2-sync/config")) + <&> fromRight mempty + <&> parseTop + <&> either mempty (fmap fixContext) + + void $ evalTop ins + + _ -> do + err "current dir not set" + + entry $ bindMatch "refchan" $ nil_ $ \case + [SignPubKeyLike puk] -> do + dir <- getRunDir + debug $ red "refchan" <+> pretty dir <+> pretty (AsBase58 puk) + alterRunDirEnv dir $ \case + Nothing -> Just (mempty & set dirSyncRefChan (Just puk)) + Just x -> Just (x & set dirSyncRefChan (Just puk)) + + x -> err $ "invalid refchan" <+> pretty (mkList x) + + entry $ bindMatch "exclude" $ nil_ $ \case + [StringLike excl] -> do + dir <- getRunDir + debug $ red "exclude" <+> pretty dir <+> pretty excl + alterRunDirEnv dir $ \case + Nothing -> Just (mempty & set dirSyncExclude [excl]) + Just x -> Just (x & over dirSyncExclude (mappend [excl])) + + _ -> pure () + + entry $ bindMatch "include" $ nil_ $ \case + [StringLike pat] -> do + dir <- getRunDir + debug $ red "include" <+> pretty dir <+> pretty pat + alterRunDirEnv dir $ \case + Nothing -> Just (mempty & set dirSyncInclude [pat]) + Just x -> Just (x & over dirSyncInclude (mappend [pat])) + + _ -> pure () + + entry $ bindMatch "sign" $ nil_ $ \case + [SignPubKeyLike s] -> do + dir <- getRunDir + debug $ red "sign" <+> pretty (AsBase58 s) + creds <- liftIO (runKeymanClient $ loadCredentials s) + alterRunDirEnv dir $ \case + Nothing -> Just (mempty & set dirSyncCreds creds) + Just x -> Just (x & set dirSyncCreds creds) + + w -> err $ "invalid sign key" <+> pretty (mkList w) + + + entry $ bindMatch "dir:state:merged:show" $ nil_ $ \_ -> do + state <- getStateFromDir0 True + + deleted <- findDeleted + merged <- mergeState deleted state + + liftIO $ print $ vcat (fmap (pretty . AsSexp @C) merged) + + + entry $ bindMatch "ls" $ nil_ $ \case + (StringLikeList _) -> do + state <- getStateFromDir0 False <&> Map.fromList + + for_ (Map.toList state) $ \(f,e) -> do + when (isFile e || isDir e ) do + liftIO $ putStrLn f + + _ -> pure () + + entry $ bindMatch "dir:state:local:show" $ nil_ $ \sy -> do + + let f = case sy of + [StringLike "F"] -> isFile + [StringLike "D"] -> isDir + _ -> const True + + state <- getStateFromDir0 True + + liftIO $ print $ vcat (fmap (pretty . AsSexp @C . snd) (filter (f . snd) state)) + + entry $ bindMatch "dir:state:remote:show" $ nil_ $ \syn -> do + + let f = case syn of + [StringLike "F"] -> isFile + [StringLike "D"] -> isDir + _ -> const True + + dir <- getRunDir + + + env <- getRunDirEnv dir >>= orThrow DirNotSet + + runMaybeT do + + rchan <- view dirSyncRefChan env + & toMPlus + + state <- lift $ getStateFromRefChan rchan + + liftIO $ print $ vcat (fmap (pretty . AsSexp @C . snd) (filter (f.snd) state)) + + + entry $ bindMatch "dir:config:show" $ nil_ $ const do + dir <- getRunDir + + void $ runMaybeT do + env <- getRunDirEnv dir >>= toMPlus + liftIO $ print $ pretty env + + entry $ bindMatch "run" $ nil_ \case + _ -> runDirectory + + entry $ bindMatch "prune" $ nil_ \case + [] -> do + + + path <- getRunDir + + env <- getRunDirEnv path >>= orThrow DirNotSet + + let excl = view dirSyncExclude env + + let skip p = or [ i ?== p | i <- excl ] + + dirs <- S.toList_ do + flip fix [path] $ \next -> \case + (d:ds) -> do + dirs <- liftIO (listDirectory d) + let es = [ path d x | x <- dirs, not (skip x) ] + dd <- liftIO $ filterM doesDirectoryExist es + S.each dd + next (ds <> dd) + + [] -> pure () + + for_ (L.sortBy (comparing Down) dirs) $ \d -> do + pu <- liftIO (listDirectory d) <&> L.null + when pu do + notice $ red "prune" <+> pretty d + rm d + + _ -> pure () + + + brief "posts tomb transaction for the current dir" + $ args [arg "string" "entry-path"] + $ desc ( "working dir must be set first" <> line + <> "see: dir, sync" + ) + $ entry $ bindMatch "tomb" $ nil_ \case + [StringLike p] -> do + + path <- getRunDir + env <- getRunDirEnv path >>= orThrow DirNotSet + + void $ runMaybeT do + + let fullPath = path p + + rchan <- view dirSyncRefChan env + & toMPlus + + here <- liftIO (doesFileExist fullPath) + guard here + + now <- liftIO getPOSIXTime <&> round + + notice $ red "ABOUT TO POST TOMB TX" <+> pretty p + lift $ postEntryTx Nothing rchan path (makeTomb now p mzero) + + _ -> pure () + + entry $ bindMatch "run-config" $ nil_ $ const do + cpath <- liftIO $ getXdgDirectory XdgConfig "hbs2-sync" <&> ( "config") + debug $ "run-config" <+> pretty cpath + try @_ @IOError (liftIO $ readFile cpath) + <&> fromRight mempty + <&> parseTop + <&> either mempty (fmap fixContext) + >>= evalTop + + entry $ bindMatch "timestamp" $ nil_ $ \case + [StringLike fn] -> do + liftIO (getFileTimestamp fn >>= print) + _ -> do + liftIO $ getPOSIXTime <&> round >>= print + +-- debugPrefix :: LoggerEntry -> LoggerEntry +debugPrefix = toStderr . logPrefix "[debug] " + +setupLogger :: MonadIO m => m () +setupLogger = do + -- setLogging @DEBUG $ toStderr . logPrefix "[debug] " + setLogging @ERROR $ toStderr . logPrefix "[error] " + setLogging @WARN $ toStderr . logPrefix "[warn] " + setLogging @NOTICE $ toStdout . logPrefix "" + pure () + +flushLoggers :: MonadIO m => m () +flushLoggers = do + silence + +silence :: MonadIO m => m () +silence = do + setLoggingOff @DEBUG + setLoggingOff @ERROR + setLoggingOff @WARN + setLoggingOff @NOTICE + + +quit :: forall m . MonadUnliftIO m => m () +quit = liftIO Exit.exitSuccess + +die :: forall a m . (MonadUnliftIO m, Pretty a) => a -> m () +die what = liftIO do + hPutDoc stderr (pretty what) + Exit.exitFailure + + diff --git a/hbs2-tests/hbs2-tests.cabal b/hbs2-tests/hbs2-tests.cabal index 424e10a5..8e607b09 100644 --- a/hbs2-tests/hbs2-tests.cabal +++ b/hbs2-tests/hbs2-tests.cabal @@ -19,6 +19,7 @@ common warnings common common-deps build-depends: base, hbs2-core, hbs2-storage-simple, hbs2-peer + , fuzzy-parse , async , bytestring , cache @@ -914,6 +915,7 @@ executable test-playground main-is: Main.hs build-depends: base, hbs2-core + , fuzzy-parse , async , bytestring , cache @@ -946,4 +948,137 @@ executable test-playground , unordered-containers , resourcet , text-icu >= 0.8.0.3 + , skylighting-core + , skylighting + , skylighting-lucid + , lucid + , text + + +executable test-pipe-mess + import: shared-properties + default-language: Haskell2010 + + -- other-extensions: + + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: TestPipeMessaging.hs + build-depends: + base, hbs2-core + , async + , bytestring + , cache + , containers + , directory + , hashable + , microlens-platform + , mtl + , network-byte-order + , prettyprinter + , QuickCheck + , quickcheck-instances + , random + , safe + , serialise + , stm + , streaming + , tasty + , tasty-quickcheck + , tasty-hunit + , tasty-quickcheck + , transformers + , uniplate + , vector + , saltine + , simple-logger + , string-conversions + , filepath + , temporary + , unliftio + , unordered-containers + , unix + , timeit + + + +executable test-merge-limits + import: shared-properties + default-language: Haskell2010 + + -- other-extensions: + + hs-source-dirs: test + main-is: TestMergeLimits.hs + build-depends: + base, hbs2-core, hbs2-storage-simple + , async + , bytestring + , cache + , containers + , hashable + , microlens-platform + , mtl + , prettyprinter + , QuickCheck + , quickcheck-instances + , random + , safe + , serialise + , stm + , streaming + , tasty + , tasty-quickcheck + , tasty-hunit + , tasty-quickcheck + , transformers + , uniplate + , vector + , filepath + , temporary + , unliftio + , unordered-containers + , unix + , timeit + + +executable test-lsw-write + import: shared-properties + default-language: Haskell2010 + + -- other-extensions: + + hs-source-dirs: test + main-is: TestLSMWrite.hs + build-depends: + base, hbs2-core, hbs2-storage-simple + , async + , bytestring + , cache + , containers + , hashable + , microlens-platform + , mtl + , prettyprinter + , QuickCheck + , quickcheck-instances + , random + , safe + , serialise + , stm + , streaming + , tasty + , tasty-quickcheck + , tasty-hunit + , tasty-quickcheck + , transformers + , uniplate + , vector + , filepath + , temporary + , unliftio + , unordered-containers + , unix + , timeit + diff --git a/hbs2-tests/test/PrototypeGenericService.hs b/hbs2-tests/test/PrototypeGenericService.hs index ea8e62c0..74f1e20a 100644 --- a/hbs2-tests/test/PrototypeGenericService.hs +++ b/hbs2-tests/test/PrototypeGenericService.hs @@ -60,9 +60,9 @@ type instance Output Method2 = () instance MonadIO m => HandleMethod m Method2 where handleMethod _ = pure () -instance (HasProtocol UNIX (ServiceProto api UNIX), MonadUnliftIO m) - => HasDeferred UNIX (ServiceProto api UNIX) m where - deferred _ m = void (async m) +-- instance (HasProtocol UNIX (ServiceProto api UNIX), MonadUnliftIO m) +-- => HasDeferred UNIX (ServiceProto api UNIX) m where +-- deferred m = void (async m) main :: IO () main = do diff --git a/hbs2-tests/test/TestLSMWrite.hs b/hbs2-tests/test/TestLSMWrite.hs new file mode 100644 index 00000000..724aa0f6 --- /dev/null +++ b/hbs2-tests/test/TestLSMWrite.hs @@ -0,0 +1,36 @@ +{-# Language NumericUnderscores #-} +module Main where + +import HBS2.Prelude.Plated + +import HBS2.Hash +import HBS2.Data.Types.Refs +import HBS2.Storage.Compact + +import Data.ByteString.Builder qualified as B +import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Char8 qualified as BS8 +import Data.Function +import Streaming.Prelude qualified as S +import System.TimeIt +import Data.HashSet qualified as HS +import Data.HashSet (HashSet) +import Data.List qualified as List +import UnliftIO +import System.Random +import Data.Word +import Control.Monad +import System.Environment + +main :: IO () +main = do + [f] <- getArgs + sto <- compactStorageOpen @HbSync mempty f + + for_ [0..10_000_000] $ \i -> do + let k = B.toLazyByteString (B.word64BE i) & LBS.toStrict + let v = BS8.pack (show k) + put sto k v + + compactStorageClose sto + diff --git a/hbs2-tests/test/TestMergeLimits.hs b/hbs2-tests/test/TestMergeLimits.hs new file mode 100644 index 00000000..4b8eae60 --- /dev/null +++ b/hbs2-tests/test/TestMergeLimits.hs @@ -0,0 +1,67 @@ +{-# Language NumericUnderscores #-} +module Main where + +import HBS2.Prelude.Plated + +import HBS2.Hash +import HBS2.Data.Types.Refs + +import Data.ByteString.Lazy qualified as LBS +import Data.Function +import Streaming.Prelude qualified as S +import System.TimeIt +import Data.HashSet qualified as HS +import Data.HashSet (HashSet) +import Data.List qualified as List +import UnliftIO +import System.Random +import Data.Word +import Control.Monad + +rndHash :: IO HashRef +rndHash = do + w1 <- replicateM 4 $ randomIO @Word64 + pure $ HashRef $ hashObject @HbSync (serialise w1) + +main :: IO () +main = do + rnd <- openFile "/dev/random" ReadMode + + lbs <- LBS.hGetNonBlocking rnd $ 32_000_000 * 10 + + hashList <- S.toList_ do + flip fix lbs $ \next rest -> do + let (a,rest') = LBS.splitAt 32 rest + S.yield $ HashRef $! HbSyncHash (LBS.toStrict a) + unless (LBS.null rest') $ next rest' + + chunks <- S.toList_ do + flip fix hashList $ \next rest -> do + let (c, rest') = List.splitAt 1_000_000 rest + S.yield c + unless (List.null rest') $ next rest' + + pieces <- forConcurrently chunks (pure . HS.fromList) + + hs <- timeItNamed "rebuild index" do + let hashSet = HS.unions pieces + print $ length hashSet + pure hashSet + + void $ timeItNamed "calculate hash" do + let bs = serialise hs + let hx = hashObject @HbSync bs + print $ pretty hx + + putStrLn "now we have partially sorted index" + + hashes <- replicateM 100 rndHash + + timeItNamed "add new items" do + let hs2 = HS.union hs (HS.fromList hashes) + -- let hx = hashObject @HbSync (serialise hs2) + print $ pretty (HS.size hs2) -- <+> pretty hx + + pure () + + diff --git a/hbs2-tests/test/TestPipeMessaging.hs b/hbs2-tests/test/TestPipeMessaging.hs new file mode 100644 index 00000000..88a0f04a --- /dev/null +++ b/hbs2-tests/test/TestPipeMessaging.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE NumericUnderscores #-} +module Main where + +import HBS2.Prelude.Plated + +import HBS2.Net.Messaging +import HBS2.Net.Messaging.Pipe +import HBS2.Net.Proto.Service +import HBS2.Actors.Peer + +import HBS2.System.Logger.Simple.ANSI + +import Data.ByteString.Lazy (ByteString) +import System.Posix.IO +import UnliftIO +import Control.Monad.Trans.Cont +import Control.Monad.Reader +import Codec.Serialise +import Data.Fixed + +import System.TimeIt + +-- protocol's data +data Ping = + Ping Int + | Pong Int + deriving stock (Eq,Show,Generic) + +instance Pretty Ping where + pretty = viaShow + +instance Serialise Ping + +-- API definition +type MyServiceMethods1 = '[ Ping ] + +-- API endpoint definition +type instance Input Ping = Ping +type instance Output Ping = Maybe Ping + +-- API handler +instance MonadIO m => HandleMethod m Ping where + handleMethod = \case + Ping n -> pure (Just (Pong n)) + Pong _ -> pure Nothing + +-- Codec for protocol +instance HasProtocol PIPE (ServiceProto MyServiceMethods1 PIPE) where + type instance ProtocolId (ServiceProto MyServiceMethods1 PIPE) = 0xDEADF00D1 + type instance Encoded PIPE = ByteString + decode = either (const Nothing) Just . deserialiseOrFail + encode = serialise + +-- Some "deferred" implementation for our monad +-- note -- plain asyncs may cause to resource leak +instance (MonadUnliftIO m, HasProtocol PIPE (ServiceProto api PIPE)) + => HasDeferred (ServiceProto api PIPE) PIPE m where + deferred m = void (async m) + +mainLoop :: IO () +mainLoop = do + + flip runContT pure do + + -- pipe for server + (i1,o1) <- liftIO $ createPipe + >>= \(i,o) -> (,) <$> fdToHandle i <*> fdToHandle o + + -- pipe for client + (i2,o2) <- liftIO $ createPipe + >>= \(i,o) -> (,) <$> fdToHandle i <*> fdToHandle o + + -- interwire client and server by pipes + server <- newMessagingPipe (i2,o1) + client <- newMessagingPipe (i1,o2) + + -- run messaging workers + void $ ContT $ withAsync $ runMessagingPipe server + void $ ContT $ withAsync $ runMessagingPipe client + + -- make server protocol responder + void $ ContT $ withAsync $ flip runReaderT server do + runProto @PIPE + [ makeResponse (makeServer @MyServiceMethods1) + ] + + -- make client's "caller" + caller <- lift $ makeServiceCaller @MyServiceMethods1 @PIPE (localPeer client) + + -- make client's endpoint worker + void $ ContT $ withAsync $ runReaderT (runServiceClient caller) client + + let n = 20_000 + + (a, _) <- timeItT do + for_ [1..n] $ \i -> do + void $ callService @Ping caller (Ping i) + + debug $ "sent" <+> pretty n <+> "messages in" <+> pretty (realToFrac a :: Fixed E3) <> "sec" + <> line + <> "rps:" <+> pretty (realToFrac n / realToFrac a :: Fixed E2) + +main :: IO () +main = do + + setLogging @DEBUG defLog + mainLoop + `finally` do + setLoggingOff @DEBUG + + diff --git a/hbs2-tests/test/TestRawTx.hs b/hbs2-tests/test/TestRawTx.hs index 1474b2a9..67d8c07d 100644 --- a/hbs2-tests/test/TestRawTx.hs +++ b/hbs2-tests/test/TestRawTx.hs @@ -48,7 +48,7 @@ main = do <> header "Raw tx test" ) krData <- BS.readFile $ credentialsFile options - creds <- pure (parseCredentials @HBS2Basic (AsCredFile krData)) `orDie` "bad keyring file" + creds <- pure (parseCredentials @'HBS2Basic (AsCredFile krData)) `orDie` "bad keyring file" let pubk = view peerSignPk creds let privk = view peerSignSk creds bs <- pure (fromBase58 $ BS8.pack $ tx options) `orDie` "transaction is not in Base58 format" diff --git a/hbs2-tests/test/playground/Main.hs b/hbs2-tests/test/playground/Main.hs index 284e3f91..b16c2658 100644 --- a/hbs2-tests/test/playground/Main.hs +++ b/hbs2-tests/test/playground/Main.hs @@ -10,6 +10,24 @@ import Data.ByteString.Lazy qualified as LBS import Data.ByteString qualified as BS import Codec.Serialise import Lens.Micro.Platform +import Control.Monad.Trans.Cont + +import Control.Monad +import UnliftIO + +import Skylighting.Core +import Skylighting.Types +import Skylighting.Syntax +import Skylighting.Tokenizer +import Skylighting.Format.HTML.Lucid as Lucid +import Lucid qualified as Lucid + +import Skylighting +import Data.Text (Text) +import Data.Text qualified as Text +import qualified Data.Text.IO as Text +import qualified Data.Text.Lazy.IO as LT + -- желаемое поведение: добавить в новую версию A какое-нибудь поле так, -- что бы предыдущие записи продолжали десериализоваться без этого поля, @@ -65,8 +83,77 @@ test w = case w of A -> "Match A" +runWithAsync :: IO () +runWithAsync = do + + hSetBuffering stdout LineBuffering + + flip runContT pure do + + t1 <- ContT $ withAsync do + forever do + print "PIU" + pause @'Seconds 1 + + q <- ContT $ withAsync do + pause @'Seconds 10 + print "FUCKIG QUIT" + + pysh <- ContT $ withAsync $ forever do + pause @'Seconds 2 + print "PYSHPYSH" + + void $ waitAnyCatchCancel [t1,q,pysh] + + +testCont :: IO () +testCont = do + + flip runContT pure do + for_ [1..10] $ \i -> do + callCC \next -> do + + when (even i) do + next () + + liftIO $ print i + +-- Функция для вывода токенов +printTokens :: [SourceLine] -> IO () +printTokens = mapM_ printSourceLine + +-- Вспомогательная функция для печати одной строки токенов +printSourceLine :: SourceLine -> IO () +printSourceLine = mapM_ (putStrLn . show . tokenToText) + +-- Преобразование токена в текст +tokenToText :: Token -> Text.Text +tokenToText (_,t) = t + + main :: IO () main = do + let syntaxMap = defaultSyntaxMap + let maybeSyntax = lookupSyntax "haskell" syntaxMap + case maybeSyntax of + Nothing -> putStrLn "Синтаксис для Haskell не найден." + Just syntax -> do + -- Чтение кода из stdin или файла + code <- Text.getContents + -- Конфигурация токенизатора + let config = TokenizerConfig { traceOutput = False, syntaxMap = syntaxMap } + -- Токенизация кода + case tokenize config syntax code of + Left err -> putStrLn $ "Ошибка токенизации: " ++ show err + Right tokens -> do + let fo = defaultFormatOpts { numberLines = False, ansiColorLevel = ANSI256Color } + let code = Lucid.formatHtmlBlock fo tokens + let txt = Lucid.renderText code + LT.putStrLn txt + + +main' :: IO () +main' = do print "1" let a1 = serialise (A0 22) & deserialiseOrFail @A1 let a2 = serialise (A11 22) & deserialiseOrFail @A0 @@ -86,6 +173,5 @@ main = do print $ a1 <&> set a1Str (Just "JOPAKITA") print $ a4 <&> set a1Str (Just "JOPAKITA") - pure () diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 416dbc25..98873d3f 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -8,6 +8,10 @@ import HBS2.Data.KeyRing as KeyRing import HBS2.Defaults import HBS2.Merkle import HBS2.Peer.Proto +import HBS2.Peer.CLI.Detect +import HBS2.Peer.RPC.Client.Unix +import HBS2.Peer.RPC.API.Storage +import HBS2.Peer.RPC.Client.StorageClient import HBS2.Net.Auth.GroupKeyAsymm as Asymm import HBS2.Net.Auth.GroupKeySymm qualified as Symm import HBS2.Net.Auth.GroupKeySymm @@ -52,6 +56,7 @@ import Data.Either import Data.List qualified as List import Data.Maybe import Data.Text qualified as Text +import Data.Text.IO qualified as TIO import Lens.Micro.Platform import Options.Applicative import Streaming.Prelude qualified as S @@ -110,7 +115,7 @@ newtype OptGroupkeyFile = OptGroupkeyFile { unOptGroupkeyFile :: FilePath } deriving newtype (Eq,Ord,IsString) deriving stock (Data) -newtype OptEncPubKey = OptEncPubKey { unOptEncPk :: PubKey 'Encrypt HBS2Basic } +newtype OptEncPubKey = OptEncPubKey { unOptEncPk :: PubKey 'Encrypt 'HBS2Basic } deriving newtype (Eq,Ord) deriving stock (Data) @@ -151,8 +156,8 @@ newtype NewRefOpts = deriving stock (Data) -data EncSchema = EncSymm (GroupKey 'Symm HBS2Basic) - | EncAsymm (GroupKey 'Asymm HBS2Basic) +data EncSchema = EncSymm (GroupKey 'Symm 'HBS2Basic) + | EncAsymm (GroupKey 'Asymm 'HBS2Basic) hPrint :: (MonadIO m, Show a) => Handle -> a -> m () @@ -161,6 +166,11 @@ hPrint h s = liftIO $ IO.hPrint h s hGetContents :: MonadIO m => Handle -> m String hGetContents h = liftIO $ IO.hGetContents h +{- HLINT ignore "Use getChar" -} + +hGetChar :: MonadIO m => Handle -> m Char +hGetChar = liftIO . IO.hGetChar + hPutStrLn :: MonadIO m => Handle -> String -> m () hPutStrLn h s = liftIO $ IO.hPutStrLn h s @@ -178,8 +188,11 @@ exitFailure = do die :: MonadIO m => String -> m a die = liftIO . Exit.die -runHash :: HashOpts -> SimpleStorage HbSync -> IO () -runHash opts _ = do +runHash :: Maybe HashOpts -> SimpleStorage HbSync -> IO () +runHash Nothing _ = do + LBS.getContents >>= print . pretty . hashObject @HbSync + +runHash (Just opts) _ = do withBinaryFile (hashFp opts) ReadMode $ \h -> do LBS.hGetContents h >>= print . pretty . hashObject @HbSync @@ -242,7 +255,7 @@ runCat opts ss = do keyring <- case uniLastMay @OptKeyringFile opts of Just krf -> do s <- BS.readFile (unOptKeyringFile krf) - cred <- pure (parseCredentials @HBS2Basic (AsCredFile s)) `orDie` "bad keyring file" + cred <- pure (parseCredentials @'HBS2Basic (AsCredFile s)) `orDie` "bad keyring file" pure $ view peerKeyring cred Nothing -> fromMaybe mempty <$> runMaybeT do @@ -260,7 +273,7 @@ runCat opts ss = do Right lbs -> LBS.putStr lbs Left e -> die (show e) - MerkleAnn ann -> die "asymmetric gropup encryption is deprecated" + MerkleAnn ann -> die "asymmetric group encryption is deprecated" -- FIXME: what-if-multiple-seq-ref-? SeqRef (SequentialRef _ (AnnotatedHashRef _ h)) -> do @@ -319,7 +332,7 @@ runStore opts ss = runResourceT do Just gkfile -> do - gkSymm <- liftIO $ Symm.parseGroupKey @HBS2Basic . AsGroupKeyFile <$> LBS.readFile (unOptGroupkeyFile gkfile) + gkSymm <- liftIO $ Symm.parseGroupKey @'HBS2Basic . AsGroupKeyFile <$> LBS.readFile (unOptGroupkeyFile gkfile) let mbGk = EncSymm <$> gkSymm @@ -331,7 +344,7 @@ runStore opts ss = runResourceT do krf <- pure (uniLastMay @OptKeyringFile opts) `orDie` "keyring file not set" s <- liftIO $ BS.readFile (unOptKeyringFile krf) - cred <- pure (parseCredentials @HBS2Basic (AsCredFile s)) `orDie` "bad keyring file" + cred <- pure (parseCredentials @'HBS2Basic (AsCredFile s)) `orDie` "bad keyring file" sk <- pure (headMay [ (view krPk k, view krSk k) | k <- view peerKeyring cred @@ -380,7 +393,7 @@ runStore opts ss = runResourceT do hPrint stdout $ "merkle-ann-root: " <+> pretty mannh -runNewGroupKeyAsymm :: forall s . (s ~ HBS2Basic) => FilePath -> IO () +runNewGroupKeyAsymm :: forall s . (s ~ 'HBS2Basic) => FilePath -> IO () runNewGroupKeyAsymm pubkeysFile = do s <- BS.readFile pubkeysFile pubkeys <- pure (parsePubKeys @s s) `orDie` "bad pubkeys file" @@ -389,20 +402,20 @@ runNewGroupKeyAsymm pubkeysFile = do List.sort pubkeys `forM` \pk -> (pk, ) <$> mkEncryptedKey keypair pk print $ pretty $ AsGroupKeyFile $ AsBase58 $ GroupKeyNaClAsymm (_krPk keypair) accesskey -runNewKey :: forall s . (s ~ HBS2Basic) => Int -> IO () +runNewKey :: forall s . (s ~ 'HBS2Basic) => Int -> IO () runNewKey n = do cred0 <- newCredentials @s cred <- foldM (\cred _ -> addKeyPair Nothing cred) cred0 [1..n] print $ pretty $ AsCredFile $ AsBase58 cred -runListKeys :: forall s . (s ~ HBS2Basic) => FilePath -> IO () +runListKeys :: forall s . (s ~ 'HBS2Basic) => FilePath -> IO () runListKeys fp = do s <- BS.readFile fp cred <- pure (parseCredentials @s (AsCredFile s)) `orDie` "bad keyring file" print $ pretty (ListKeyringKeys cred) -runKeyAdd :: forall s . (s ~ HBS2Basic) => FilePath -> IO () +runKeyAdd :: forall s . (s ~ 'HBS2Basic) => FilePath -> IO () runKeyAdd fp = do hPrint stderr $ "adding a key into keyring" <+> pretty fp s <- BS.readFile fp @@ -410,7 +423,7 @@ runKeyAdd fp = do credNew <- addKeyPair Nothing cred print $ pretty $ AsCredFile $ AsBase58 credNew -runKeyDel :: forall s . (s ~ HBS2Basic) => String -> FilePath -> IO () +runKeyDel :: forall s . (s ~ 'HBS2Basic) => String -> FilePath -> IO () runKeyDel n fp = do hPrint stderr $ "removing key" <+> pretty n <+> "from keyring" <+> pretty fp s <- BS.readFile fp @@ -419,7 +432,7 @@ runKeyDel n fp = do print $ pretty $ AsCredFile $ AsBase58 credNew -runShowPeerKey :: forall s . ( s ~ HBS2Basic) => Maybe FilePath -> IO () +runShowPeerKey :: forall s . ( s ~ 'HBS2Basic) => Maybe FilePath -> IO () runShowPeerKey fp = do handle <- maybe (pure stdin) (`openFile` ReadMode) fp bs <- LBS.hGet handle 4096 <&> LBS.toStrict @@ -510,10 +523,10 @@ main = join . customExecParser (prefs showHelpOnError) $ <> command "deps" (info pDeps (progDesc "print dependencies")) <> command "del" (info pDel (progDesc "del block")) <> command "keyring" (info pKeyRing (progDesc "keyring commands")) - <> command "keyring-new" (info pNewKey (progDesc "generates a new keyring")) - <> command "keyring-list" (info pKeyList (progDesc "list public keys from keyring")) - <> command "keyring-key-add" (info pKeyAdd (progDesc "adds a new keypair into the keyring")) - <> command "keyring-key-del" (info pKeyDel (progDesc "removes a keypair from the keyring")) + <> command "keyring-new" iNewKey + <> command "keyring-list" iKeyList + <> command "keyring-key-add" iKeyAdd + <> command "keyring-key-del" iKeyDel <> command "sigil" (info pSigil (progDesc "sigil functions")) <> command "show-peer-key" (info pShowPeerKey (progDesc "show peer key from credential file")) <> command "groupkey" (info pGroupKey (progDesc "group key commands")) @@ -541,7 +554,7 @@ main = join . customExecParser (prefs showHelpOnError) $ epk :: ReadM OptEncPubKey epk = eitherReader $ \arg -> do - let mpk = fromStringMay @(PubKey 'Encrypt HBS2Basic) arg + let mpk = fromStringMay @(PubKey 'Encrypt 'HBS2Basic) arg maybe1 mpk (Left "invalid public key") (pure . OptEncPubKey) pCat = do @@ -566,6 +579,9 @@ main = join . customExecParser (prefs showHelpOnError) $ void $ runMaybeT do bs <- getBlock sto h >>= toMPlus case tryDetect h bs of + MerkleAnn (MTreeAnn { _mtaMeta = ShortMetadata s } ) -> do + liftIO $ TIO.putStr s + MerkleAnn (MTreeAnn { _mtaMeta = AnnHashRef mh } ) -> do bs <- getBlock sto mh @@ -635,30 +651,29 @@ main = join . customExecParser (prefs showHelpOnError) $ <> command "update" (info pGroupKeySymmUpdate (progDesc "update") ) ) - pGroupKeyFromSigils = do fns <- many $ strArgument ( metavar "SIGIL-FILES" <> help "sigil file list" ) pure $ do members <- for fns $ \fn -> do - sigil <- (BS.readFile fn <&> parseSerialisableFromBase58 @(Sigil L4Proto)) + sigil <- (BS.readFile fn <&> parseSerialisableFromBase58 @(Sigil 'HBS2Basic)) `orDie` "parse sigil failed" - (_,sd) <- pure (unboxSignedBox0 @(SigilData L4Proto) (sigilData sigil)) + (_,sd) <- pure (unboxSignedBox0 @(SigilData 'HBS2Basic) (sigilData sigil)) `orDie` ("signature check failed " <> fn) pure (sigilDataEncKey sd) - gk <- Symm.generateGroupKey @HBS2Basic Nothing members + gk <- Symm.generateGroupKey @'HBS2Basic Nothing members print $ pretty (AsGroupKeyFile gk) pGroupKeyFromKeys = do pure $ do input <- getContents <&> words members <- for input $ \s -> do - fromStringMay @(PubKey 'Encrypt HBS2Basic) s + fromStringMay @(PubKey 'Encrypt 'HBS2Basic) s & maybe (die "invalid public key") pure - gk <- Symm.generateGroupKey @HBS2Basic Nothing members + gk <- Symm.generateGroupKey @'HBS2Basic Nothing members print $ pretty (AsGroupKeyFile gk) @@ -667,18 +682,18 @@ main = join . customExecParser (prefs showHelpOnError) $ pure $ do syn <- maybe1 fn getContents readFile <&> parseTop <&> fromRight mempty - let members = [ fromStringMay @(PubKey 'Encrypt HBS2Basic) (Text.unpack s) + let members = [ fromStringMay @(PubKey 'Encrypt 'HBS2Basic) (Text.unpack s) | (ListVal (Key "member" [LitStrVal s]) ) <- syn ] & catMaybes - gk <- Symm.generateGroupKey @HBS2Basic Nothing members + gk <- Symm.generateGroupKey @'HBS2Basic Nothing members print $ pretty (AsGroupKeyFile gk) pGroupKeySymmDump = do fn <- optional $ strArgument ( metavar "FILE" <> help "group key file" ) pure $ do gk <- ( maybe1 fn LBS.getContents LBS.readFile - <&> Symm.parseGroupKey @HBS2Basic . AsGroupKeyFile ) `orDie` "Invalid group key file" + <&> Symm.parseGroupKey @'HBS2Basic . AsGroupKeyFile ) `orDie` "Invalid group key file" print $ pretty gk @@ -695,7 +710,7 @@ main = join . customExecParser (prefs showHelpOnError) $ creds <- pure (parseCredentials @(Encryption L4Proto) (AsCredFile sc)) `orDie` "bad keyring file" gk <- ( LBS.readFile fn - <&> Symm.parseGroupKey @HBS2Basic . AsGroupKeyFile ) `orDie` "Invalid group key file" + <&> Symm.parseGroupKey @'HBS2Basic . AsGroupKeyFile ) `orDie` "Invalid group key file" let keys = [ (view krPk x, view krSk x) | x <- view peerKeyring creds ] @@ -706,19 +721,21 @@ main = join . customExecParser (prefs showHelpOnError) $ syn <- readFile dsl <&> parseTop <&> fromRight mempty -- FIXME: fix-code-dup-members - let members = [ fromStringMay @(PubKey 'Encrypt HBS2Basic) (Text.unpack s) + let members = [ fromStringMay @(PubKey 'Encrypt 'HBS2Basic) (Text.unpack s) | (ListVal (Key "member" [LitStrVal s]) ) <- syn ] & catMaybes debug $ vcat (fmap (pretty.AsBase58) members) - gkNew <- Symm.generateGroupKey @HBS2Basic (Just gsec) members + gkNew <- Symm.generateGroupKey @'HBS2Basic (Just gsec) members print $ pretty (AsGroupKeyFile gkNew) pHash = do o <- common - hash <- strArgument ( metavar "HASH" ) - pure $ withStore o $ runHash $ HashOpts hash + what <- optional $ HashOpts <$> strArgument ( metavar "FILE" ) + pure $ withStore o $ runHash what + + iNewKey = info pNewKey (progDesc "generates a new keyring") pNewKey = do n <- optional $ option auto ( short 'n' <> long "number") @@ -728,21 +745,79 @@ main = join . customExecParser (prefs showHelpOnError) $ fp <- optional $ strArgument ( metavar "FILE" ) pure $ runShowPeerKey fp + iKeyList = info pKeyList (progDesc "list public keys from keyring") + pKeyList = do f <- strArgument ( metavar "KEYRING-FILE" ) pure (runListKeys f) + iKeyAdd = info pKeyAdd (progDesc "adds a new keypair into the keyring") + pKeyAdd = do f <- strArgument ( metavar "KEYRING-FILE" ) pure (runKeyAdd f) + iKeyDel = info pKeyDel (progDesc "removes a keypair from the keyring") pKeyDel = do s <- strArgument ( metavar "PUB-KEY-BASE58" ) f <- strArgument ( metavar "KEYRING-FILE" ) pure (runKeyDel s f) - pKeyRing = hsubparser ( command "find" (info pKeyRingFind (progDesc "find keyring")) + + iKeyDisclose = info pKeyDisclose (progDesc "disclose private key") + + pKeyDisclose = do + pks <- argument pPubKey ( metavar "PUB-KEY-ID" ) + + pure $ flip runContT pure $ callCC \_ -> do + + soname <- lift detectRPC `orDie` "peer rpc not found" + + y <- lift do + hSetBuffering stdin NoBuffering + hPutDoc stderr $ yellow "Note: you are about to disclose private signing key" + <+> pretty (AsBase58 pks) <> line + <> "Probably, you wish to enable unsolicited notifications for some channel" <> line + <> "Anyway, make sure you know what you doing before proceeding" <> line + <> yellow "Proceed?" <+> "[y/n]: " + hFlush stderr + hGetChar stdin + + + void $ ContT $ whenTrue () + ( y `elem` "yY") + (hPutStrLn stderr "" >> hPutDoc stderr "wise. see you!") + + mcreds <- lift do + hPutDoc stderr $ line + <> yellow "Note:" <+> "the key will be safe until you publish its hash" + <+> "somewhere" <> line + <> "so if you have changed your mind --- you may delete it with hbs2 del" + <> line <> line + + runKeymanClient $ loadCredentials pks + + creds <- ContT $ maybe1 mcreds exitFailure + + -- NOTE: only-sign-key-disclosed-yet + let creds1 = set peerKeyring mempty creds + + rpc <- ContT $ withRPC2 @StorageAPI soname + + let sto = AnyStorage (StorageClient rpc) + + h <- putBlock sto (serialise creds1) + + liftIO $ print $ pretty h + + -- TODO: all-keyring-management-to-keyman + pKeyRing = hsubparser ( command "find" (info pKeyRingFind (progDesc "find keyring")) + <> command "new" iNewKey + <> command "list" iKeyList + <> command "add" iKeyAdd + <> command "del" iKeyDel + <> command "disclose" iKeyDisclose ) pKeyRingFind = do @@ -758,7 +833,7 @@ main = join . customExecParser (prefs showHelpOnError) $ pRefLogGet = do o <- common reflogs <- strArgument ( metavar "REFLOG" ) - pure $ withStore o (runRefLogGet @HBS2Basic reflogs) + pure $ withStore o (runRefLogGet @'HBS2Basic reflogs) pAnyRef = hsubparser ( command "get" (info pAnyRefGet (progDesc "get anyref value") ) @@ -768,7 +843,7 @@ main = join . customExecParser (prefs showHelpOnError) $ pAnyRefGet = do o <- common anyref <- strArgument ( metavar "ANYREF" ) - pure $ withStore o (runAnyRefGet @HBS2Basic anyref) + pure $ withStore o (runAnyRefGet @'HBS2Basic anyref) pAnyRefSet = do o <- common @@ -776,7 +851,7 @@ main = join . customExecParser (prefs showHelpOnError) $ val <- strArgument ( metavar "HASHREF" ) pure $ do hr <- pure (fromStringMay val) `orDie` "bad HASHREF" - withStore o (runAnyRefSet @HBS2Basic anyref hr) + withStore o (runAnyRefSet @'HBS2Basic anyref hr) pFsck = do o <- common @@ -793,7 +868,7 @@ main = join . customExecParser (prefs showHelpOnError) $ deepScan ScanDeep (const none) h (getBlock sto) $ \ha -> do print $ pretty ha - -- TODO: reflog-del-command-- TODO: reflog-del-command + -- TODO: reflog-del-command pDel = do o <- common recurse <- optional (flag' True ( short 'r' <> long "recursive" <> help "try to delete all blocks recursively" ) @@ -871,7 +946,7 @@ main = join . customExecParser (prefs showHelpOnError) $ ref <- pure (fromStringMay hash) `orDie` "invalid HASHREF" - let refval = makeBundleRefValue @L4Proto pk sk (BundleRefSimple ref) + let refval = makeBundleRefValue @'HBS2Basic pk sk (BundleRefSimple ref) mh <- putBlock sto (serialise refval) @@ -927,9 +1002,9 @@ main = join . customExecParser (prefs showHelpOnError) $ fn <- optional $ strArgument ( metavar "SIGIL-FILE" ) pure $ do handle <- maybe1 fn (pure stdin) (flip openFile ReadMode) - sigil <- (BS.hGetContents handle <&> parseSerialisableFromBase58 @(Sigil L4Proto)) + sigil <- (BS.hGetContents handle <&> parseSerialisableFromBase58 @(Sigil 'HBS2Basic)) `orDie` "parse sigil failed" - (_,sd) <- pure (unboxSignedBox0 @(SigilData L4Proto) (sigilData sigil)) + (_,sd) <- pure (unboxSignedBox0 @(SigilData 'HBS2Basic) (sigilData sigil)) `orDie` "signature check failed" print $ parens ("sigil" <> line <> indent 2 (vcat $ [pretty sigil, pretty sd])) @@ -941,8 +1016,8 @@ main = join . customExecParser (prefs showHelpOnError) $ pk <- argument ppk (metavar "PUBKEY") pure $ do sc <- BS.readFile krf - creds <- pure (parseCredentials @(Encryption L4Proto) (AsCredFile sc)) `orDie` "bad keyring file" - sigil <- pure (makeSigilFromCredentials @L4Proto creds pk txt href) + creds <- pure (parseCredentials @'HBS2Basic (AsCredFile sc)) `orDie` "bad keyring file" + sigil <- pure (makeSigilFromCredentials @'HBS2Basic creds pk txt href) `orDie` "public key not found in credentials file" print $ pretty (AsBase58 sigil) @@ -950,9 +1025,6 @@ main = join . customExecParser (prefs showHelpOnError) $ phref = maybeReader fromStringMay - pPubKey = maybeReader (fromStringMay @(PubKey 'Sign HBS2Basic)) - - - + pPubKey = maybeReader (fromStringMay @(PubKey 'Sign 'HBS2Basic)) diff --git a/nix/peer/flake.lock b/nix/peer/flake.lock index 1c4dd190..663c7a50 100644 --- a/nix/peer/flake.lock +++ b/nix/peer/flake.lock @@ -172,6 +172,21 @@ "type": "github" } }, + "flake-utils_8": { + "locked": { + "lastModified": 1644229661, + "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, "haskell-flake-utils": { "inputs": { "flake-utils": "flake-utils_2" @@ -268,6 +283,24 @@ "inputs": { "flake-utils": "flake-utils_7" }, + "locked": { + "lastModified": 1698938553, + "narHash": "sha256-oXpTKXioqFbl2mhhvpJIAvgNd+wYyv4ekI+YnJHEJ6s=", + "owner": "ivanovs-4", + "repo": "haskell-flake-utils", + "rev": "19b273b5dc401a0a565e7f75cf50a593871b80c9", + "type": "github" + }, + "original": { + "owner": "ivanovs-4", + "repo": "haskell-flake-utils", + "type": "github" + } + }, + "haskell-flake-utils_7": { + "inputs": { + "flake-utils": "flake-utils_8" + }, "locked": { "lastModified": 1672412555, "narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=", @@ -288,6 +321,7 @@ "fixme": "fixme", "haskell-flake-utils": "haskell-flake-utils_4", "hspup": "hspup", + "lsm": "lsm", "nixpkgs": [ "nixpkgs" ], @@ -295,16 +329,17 @@ "suckless-conf": "suckless-conf_2" }, "locked": { - "lastModified": 1710646368, - "narHash": "sha256-0ayUFjOSX4UqSRBbLJeqPMBAn+qSAlFRoICVABliF80=", - "ref": "lwwrepo", - "rev": "16b5b6220a4be96e30c65f34d631445c28676feb", - "revCount": 1002, + "lastModified": 1713159635, + "narHash": "sha256-iXf8qcJxePLM65E0fsAK2kj69/YIyQdNMrZ5yULzVGc=", + "ref": "hbs2-git-index", + "rev": "2289845078ba839bade83a1daf5234435e6e631e", + "revCount": 997, "type": "git", "url": "http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP" }, "original": { - "ref": "lwwrepo", + "ref": "hbs2-git-index", + "rev": "2289845078ba839bade83a1daf5234435e6e631e", "type": "git", "url": "http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP" } @@ -351,6 +386,28 @@ "type": "github" } }, + "lsm": { + "inputs": { + "haskell-flake-utils": "haskell-flake-utils_6", + "nixpkgs": [ + "hbs2", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1711033804, + "narHash": "sha256-z9cb5yuWfuZmGukxsZebXhc6KUZoPVT60oXxQ6j6ML8=", + "ref": "refs/heads/master", + "rev": "0e8286a43da5b9e54c4f3ecdb994173fe77351db", + "revCount": 26, + "type": "git", + "url": "https://git.hbs2.net/5BCaH95cWsVKBmWaDNLWQr2umxzzT5kqRRKNTm2J15Ls" + }, + "original": { + "type": "git", + "url": "https://git.hbs2.net/5BCaH95cWsVKBmWaDNLWQr2umxzzT5kqRRKNTm2J15Ls" + } + }, "nixpkgs": { "locked": { "lastModified": 1685566663, @@ -433,7 +490,7 @@ }, "suckless-conf_2": { "inputs": { - "haskell-flake-utils": "haskell-flake-utils_6", + "haskell-flake-utils": "haskell-flake-utils_7", "nixpkgs": [ "hbs2", "nixpkgs" diff --git a/nix/peer/flake.nix b/nix/peer/flake.nix index c320d6f8..32a67549 100644 --- a/nix/peer/flake.nix +++ b/nix/peer/flake.nix @@ -7,7 +7,7 @@ extra-container.url = "github:erikarvstedt/extra-container"; nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable"; hbs2.url = - "git+http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP?ref=lwwrepo"; + "git+http://git.hbs2/BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP?rev=3b8f3d48f486043c7fa2df5990e5ab96b71996e1"; hbs2.inputs.nixpkgs.follows = "nixpkgs"; home-manager.url = "github:nix-community/home-manager";