mirror of https://github.com/voidlizard/hbs2
indexed keys, hbs2-keyman and hbs2-sync updated
This commit is contained in:
Dmitry Zuikov
parent
f7119564fb
commit
58fecd442b
|
|
@ -1,9 +1,10 @@
|
|||
packages: **/*.cabal
|
||||
examples/*/*.cabal
|
||||
**/*/*.cabal
|
||||
|
||||
allow-newer: all
|
||||
|
||||
constraints: pandoc >=3.1.11, suckless-conf >= 0.1.2.6
|
||||
constraints: pandoc >=3.1.11, suckless-conf >= 0.1.2.7
|
||||
|
||||
|
||||
-- executable-static: True
|
||||
|
|
|
|||
|
|
@ -55,10 +55,10 @@ common shared-properties
|
|||
hbs2-core
|
||||
, hbs2-peer
|
||||
, hbs2-storage-simple
|
||||
, hbs2-keyman
|
||||
, hbs2-keyman-direct-lib
|
||||
, hbs2-git
|
||||
, db-pipe
|
||||
, suckless-conf >= 0.1.2.6
|
||||
, suckless-conf
|
||||
, fuzzy-parse
|
||||
|
||||
, aeson
|
||||
|
|
|
|||
|
|
@ -36,12 +36,6 @@ 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)
|
||||
|
||||
|
|
|
|||
15
flake.lock
15
flake.lock
|
|
@ -519,18 +519,17 @@
|
|||
]
|
||||
},
|
||||
"locked": {
|
||||
"lastModified": 1715919707,
|
||||
"narHash": "sha256-lbvrCqJHC//NJgfvsy15+Evup5CS+CE50NolDwPIh94=",
|
||||
"ref": "refs/heads/master",
|
||||
"rev": "41830ea2f2e9bb589976f0433207a8f1b73b0b01",
|
||||
"revCount": 35,
|
||||
"lastModified": 1724324873,
|
||||
"narHash": "sha256-FfhaOF/22/QRwGe2lHr8a2kl5nGSJiHIFA1J5KLqIAI=",
|
||||
"rev": "6802f96076ffc984c9b9f44adbf3e9648bb369a0",
|
||||
"revCount": 36,
|
||||
"type": "git",
|
||||
"url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ?tag=0.1.2.6"
|
||||
"url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ"
|
||||
},
|
||||
"original": {
|
||||
"rev": "41830ea2f2e9bb589976f0433207a8f1b73b0b01",
|
||||
"rev": "6802f96076ffc984c9b9f44adbf3e9648bb369a0",
|
||||
"type": "git",
|
||||
"url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ?tag=0.1.2.6"
|
||||
"url": "https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ"
|
||||
}
|
||||
}
|
||||
},
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ inputs = {
|
|||
fixme.inputs.nixpkgs.follows = "nixpkgs";
|
||||
|
||||
suckless-conf.url =
|
||||
"git+https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ?rev=41830ea2f2e9bb589976f0433207a8f1b73b0b01&tag=0.1.2.6";
|
||||
"git+https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ?rev=6802f96076ffc984c9b9f44adbf3e9648bb369a0";
|
||||
|
||||
suckless-conf.inputs.nixpkgs.follows = "nixpkgs";
|
||||
|
||||
|
|
@ -44,6 +44,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
|
|||
"hbs2-git"
|
||||
"hbs2-qblf"
|
||||
"hbs2-keyman"
|
||||
"hbs2-keyman-direct-lib"
|
||||
"hbs2-fixer"
|
||||
"hbs2-cli"
|
||||
"hbs2-sync"
|
||||
|
|
@ -68,7 +69,8 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
|
|||
"hbs2-core" = "./hbs2-core";
|
||||
"hbs2-storage-simple" = "./hbs2-storage-simple";
|
||||
"hbs2-peer" = "./hbs2-peer";
|
||||
"hbs2-keyman" = "./hbs2-keyman";
|
||||
"hbs2-keyman" = "./hbs2-keyman/hbs2-keyman";
|
||||
"hbs2-keyman-direct-lib" = "./hbs2-keyman/hbs2-keyman-direct-lib";
|
||||
"hbs2-git" = "./hbs2-git";
|
||||
"hbs2-fixer" = "./hbs2-fixer";
|
||||
"hbs2-cli" = "./hbs2-cli";
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ common shared-properties
|
|||
hbs2-core
|
||||
, hbs2-peer
|
||||
, hbs2-storage-simple
|
||||
, hbs2-keyman
|
||||
, hbs2-keyman-direct-lib
|
||||
, db-pipe
|
||||
, suckless-conf
|
||||
|
||||
|
|
@ -120,10 +120,6 @@ library
|
|||
|
||||
HBS2.CLI.Run.Help
|
||||
|
||||
Data.Config.Suckless.Script
|
||||
Data.Config.Suckless.Script.Internal
|
||||
Data.Config.Suckless.Script.File
|
||||
|
||||
build-depends: base
|
||||
, magic
|
||||
|
||||
|
|
|
|||
|
|
@ -1,48 +0,0 @@
|
|||
{-# 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 : _ )]
|
||||
|
||||
|
|
@ -1,85 +0,0 @@
|
|||
{-# 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
|
||||
|
||||
-- FIXME: skip-symlink
|
||||
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)
|
||||
|
||||
|
|
@ -1,975 +0,0 @@
|
|||
{-# 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)
|
||||
|
||||
|
||||
|
|
@ -9,12 +9,14 @@ module HBS2.CLI.Prelude
|
|||
, module HBS2.Misc.PrettyStuff
|
||||
, qc,qq,q
|
||||
, Generic
|
||||
, pattern SignPubKeyLike
|
||||
) where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.OrDie
|
||||
import HBS2.System.Logger.Simple.ANSI
|
||||
import HBS2.Misc.PrettyStuff
|
||||
import HBS2.Net.Auth.Credentials
|
||||
|
||||
import Data.HashMap.Strict
|
||||
import Data.Config.Suckless
|
||||
|
|
|
|||
|
|
@ -14,6 +14,7 @@ import HBS2.CLI.Run.Internal.GroupKey as G
|
|||
import HBS2.Net.Auth.GroupKeySymm as Symm
|
||||
import HBS2.Storage
|
||||
|
||||
import HBS2.KeyMan.Keys.Direct
|
||||
|
||||
import HBS2.Peer.RPC.API.Storage
|
||||
import HBS2.Peer.RPC.Client
|
||||
|
|
@ -32,6 +33,7 @@ import Codec.Serialise
|
|||
|
||||
groupKeyEntries :: forall c m . ( MonadUnliftIO m
|
||||
, IsContext c
|
||||
, Exception (BadFormException c)
|
||||
, HasClientAPI StorageAPI UNIX m
|
||||
, HasStorage m
|
||||
) => MakeDictM c m ()
|
||||
|
|
@ -48,17 +50,40 @@ groupKeyEntries = do
|
|||
|
||||
_ -> 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)
|
||||
brief "stores groupkey to the peer's storage" $
|
||||
args [arg "string" "groupkey"] $
|
||||
returns "string" "hash" $
|
||||
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"
|
||||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
sto <- getStorage
|
||||
ha <- writeAsMerkle sto (serialise gk)
|
||||
pure $ mkStr (show $ pretty ha)
|
||||
|
||||
_ -> throwIO $ BadFormException @c nil
|
||||
|
||||
|
||||
brief "publish groupkey to the given refchan" $
|
||||
args [arg "string" "refchan", arg "string" "groupkey-blob|groupkey-hash"] $
|
||||
desc "groupkey may be also hash of te stored groupkey" $
|
||||
entry $ bindMatch "hbs2:groupkey:publish" $ nil_ $ \case
|
||||
|
||||
[SignPubKeyLike rchan, LitStrVal gk] -> do
|
||||
-- get
|
||||
-- check
|
||||
-- store
|
||||
-- find refchan
|
||||
-- post tx as metadata
|
||||
notice $ red "not implemented yet"
|
||||
|
||||
[SignPubKeyLike rchan, HashLike gkh] -> do
|
||||
notice $ red "not implemented yet"
|
||||
|
||||
_ -> throwIO $ BadFormException @c nil
|
||||
|
||||
|
||||
-- $ hbs2-cli print [hbs2:groupkey:update [hbs2:groupkey:load 6XJGpJszP6f68fmhF17AtJ9PTgE7BKk8RMBHWQ2rXu6N] \
|
||||
|
|
@ -99,6 +124,17 @@ groupKeyEntries = do
|
|||
_ -> throwIO $ BadFormException @C nil
|
||||
|
||||
|
||||
entry $ bindMatch "hbs2:groupkey:dump" $ nil_ $ \syn -> do
|
||||
case syn of
|
||||
-- TODO: from-file
|
||||
-- TODO: from-stdin
|
||||
-- TODO: base58 file
|
||||
[HashLike gkh] -> do
|
||||
gk <- loadGroupKey gkh
|
||||
liftIO $ print $ pretty gk
|
||||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
|
||||
entry $ bindMatch "hbs2:groupkey:list-public-keys" $ \syn -> do
|
||||
case syn of
|
||||
[LitStrVal s] -> do
|
||||
|
|
@ -113,6 +149,25 @@ groupKeyEntries = do
|
|||
|
||||
_ -> throwIO $ BadFormException @C nil
|
||||
|
||||
brief "find groupkey secret in hbs2-keyman" $
|
||||
args [arg "string" "group-key-hash"] $
|
||||
returns "secret-key-id" "string" $
|
||||
entry $ bindMatch "hbs2:groupkey:find-secret" $ \case
|
||||
[HashLike gkh] -> do
|
||||
|
||||
sto <- getStorage
|
||||
|
||||
gk <- loadGroupKey gkh >>= orThrowUser "can't load groupkey"
|
||||
|
||||
what <- runKeymanClient $ findMatchedGroupKeySecret sto gk
|
||||
>>= orThrowUser "groupkey secret not found"
|
||||
|
||||
let gid = generateGroupKeyId GroupKeyIdBasic1 what
|
||||
|
||||
pure $ mkStr (show $ pretty gid)
|
||||
|
||||
_ -> throwIO $ BadFormException @c nil
|
||||
|
||||
|
||||
entry $ bindMatch "hbs2:groupkey:decrypt-block" $ \case
|
||||
[BlobLike bs] -> do
|
||||
|
|
|
|||
|
|
@ -32,20 +32,6 @@ 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
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@ decryptBlock :: (MonadUnliftIO m, Serialise t)
|
|||
-> SmallEncryptedBlock t
|
||||
-> m t
|
||||
decryptBlock sto seb = do
|
||||
let find gk = runKeymanClient (extractGroupKeySecret gk)
|
||||
let find gk = runKeymanClientRO (findMatchedGroupKeySecret sto gk)
|
||||
|
||||
-- FIXME: improve-error-diagnostics
|
||||
runExceptT (Symm.decryptBlock sto find seb)
|
||||
|
|
|
|||
|
|
@ -43,6 +43,10 @@ import Data.HashSet qualified as HS
|
|||
import Data.Coerce
|
||||
import Control.Monad.Trans.Cont
|
||||
import Control.Monad.Except
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
||||
import Data.Text qualified as Text
|
||||
import Codec.Serialise
|
||||
|
||||
import Text.InterpolatedString.Perl6 (qc)
|
||||
|
||||
|
|
@ -293,5 +297,29 @@ HucjFUznHJeA2UYZCdUFHtnE3pTwhCW5Dp7LV3ArZBcr
|
|||
|
||||
<> pretty rch
|
||||
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
|
||||
brief "creates RefChanUpdate/AnnotatedHashRef transaction for refchan" $
|
||||
args [arg "string" "sign-key", arg "string" "payload-tree-hash"] $
|
||||
entry $ bindMatch "hbs2:refchan:tx:annref:create" $ \case
|
||||
[SignPubKeyLike signpk, HashLike hash] -> do
|
||||
sto <- getStorage
|
||||
void $ hasBlock sto (fromHashRef hash) `orDie` "no block found"
|
||||
let lbs = AnnotatedHashRef Nothing hash & serialise
|
||||
creds <- runKeymanClient $ loadCredentials signpk >>= orThrowUser "can't find credentials"
|
||||
let box = makeSignedBox @HBS2Basic (view peerSignPk creds) (view peerSignSk creds) (LBS.toStrict lbs) & serialise
|
||||
pure $ mkForm @c "blob" [mkStr (LBS8.unpack box)]
|
||||
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
brief "posts Propose transaction to the refchan" $
|
||||
args [arg "string" "refchan", arg "blob" "signed-box"] $
|
||||
entry $ bindMatch "hbs2:refchan:tx:propose" $ nil_ $ \case
|
||||
[SignPubKeyLike rchan, ListVal [SymbolVal "blob", LitStrVal box]] -> do
|
||||
api <- getClientAPI @RefChanAPI @UNIX
|
||||
bbox <- Text.unpack box & LBS8.pack & deserialiseOrFail & orThrowUser "bad transaction"
|
||||
void $ callService @RpcRefChanPropose api (rchan, bbox)
|
||||
|
||||
_ -> throwIO (BadFormException @c nil)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,10 @@
|
|||
{-# Language DuplicateRecordFields #-}
|
||||
{-# Language UndecidableInstances #-}
|
||||
{-# Language PatternSynonyms #-}
|
||||
module HBS2.Data.Types.Refs
|
||||
( module HBS2.Data.Types.Refs
|
||||
, serialise
|
||||
, pattern HashLike
|
||||
) where
|
||||
|
||||
import HBS2.Base58
|
||||
|
|
@ -10,10 +12,13 @@ import HBS2.Hash
|
|||
import HBS2.Net.Proto.Types
|
||||
import HBS2.Prelude
|
||||
|
||||
import Data.Config.Suckless.Syntax
|
||||
|
||||
import Codec.Serialise(serialise)
|
||||
import Data.Map (Map)
|
||||
import Data.Map qualified as Map
|
||||
import Data.Data
|
||||
import Data.Text qualified as Text
|
||||
|
||||
class RefMetaData a where
|
||||
refMetaData :: a -> [(String, String)]
|
||||
|
|
@ -126,3 +131,15 @@ instance RefMetaData RefAlias2 where
|
|||
|
||||
type LoadedRef a = Either HashRef a
|
||||
|
||||
|
||||
-- TODO: move-outta-here
|
||||
pattern HashLike:: forall {c} . HashRef -> Syntax c
|
||||
pattern HashLike x <- (
|
||||
\case
|
||||
LitStrVal s -> fromStringMay @HashRef (Text.unpack s)
|
||||
SymbolVal (Id s) -> fromStringMay @HashRef (Text.unpack s)
|
||||
_ -> Nothing
|
||||
-> Just x )
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -15,6 +15,8 @@ import HBS2.Net.Auth.Schema
|
|||
import HBS2.Base58
|
||||
import HBS2.Hash
|
||||
|
||||
import Data.Config.Suckless
|
||||
|
||||
import Control.Applicative
|
||||
import Codec.Serialise
|
||||
import Crypto.Saltine.Core.Sign (Keypair(..))
|
||||
|
|
@ -263,4 +265,10 @@ instance Hashed HbSync Sign.PublicKey where
|
|||
hashObject pk = hashObject (Crypto.encode pk)
|
||||
|
||||
|
||||
pattern SignPubKeyLike :: forall {c} . PubKey 'Sign 'HBS2Basic -> Syntax c
|
||||
pattern SignPubKeyLike x <- (
|
||||
\case
|
||||
StringLike s -> fromStringMay s
|
||||
_ -> Nothing
|
||||
-> Just x )
|
||||
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
{-# Language UndecidableInstances #-}
|
||||
{-# Language AllowAmbiguousTypes #-}
|
||||
{-# Language ConstraintKinds #-}
|
||||
{-# Language FunctionalDependencies #-}
|
||||
module HBS2.Net.Auth.GroupKeySymm
|
||||
( module HBS2.Net.Auth.GroupKeySymm
|
||||
, module HBS2.Net.Proto.Types
|
||||
|
|
@ -26,9 +27,11 @@ import HBS2.Storage(Storage(..))
|
|||
import HBS2.Defaults
|
||||
|
||||
|
||||
import Control.Applicative
|
||||
import Data.ByteArray.Hash qualified as BA
|
||||
import Data.ByteArray.Hash (SipHash(..), SipKey(..))
|
||||
import Codec.Serialise
|
||||
import Codec.Serialise as Serialise
|
||||
import Codec.Serialise.Decoding qualified as Serialise
|
||||
import Crypto.KDF.HKDF qualified as HKDF
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
|
|
@ -39,6 +42,7 @@ import Crypto.Saltine.Class qualified as Saltine
|
|||
import Crypto.Saltine.Core.Box qualified as AK
|
||||
import Crypto.Saltine.Core.SecretBox (Key)
|
||||
import Crypto.Saltine.Core.SecretBox qualified as SK
|
||||
import Data.ByteString qualified as N
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.ByteString.Char8 qualified as B8
|
||||
import Data.ByteString qualified as BS
|
||||
|
|
@ -53,6 +57,9 @@ import Data.ByteArray()
|
|||
import Network.ByteOrder qualified as N
|
||||
import Streaming.Prelude qualified as S
|
||||
import Lens.Micro.Platform
|
||||
import Data.Coerce
|
||||
import Data.Typeable (TypeRep, typeRep)
|
||||
import Type.Reflection (SomeTypeRep(..), someTypeRep)
|
||||
|
||||
import Streaming qualified as S
|
||||
import Streaming (Stream(..), Of(..))
|
||||
|
|
@ -63,18 +70,52 @@ import Data.Bits (xor)
|
|||
|
||||
type GroupSecret = Key
|
||||
|
||||
-- NOTE: non-breaking-change
|
||||
-- Что тут произошло: нам нужно добавить уникальный идентификатор
|
||||
-- секрета, что автоматически публиковать и искать секреты
|
||||
-- Мы добавляем его в тип ключа, однако хотим оставить совместимость
|
||||
-- в обе стороны -- что бы старые версии могли работать с новыми
|
||||
-- ключами. Таким образом, этот идентификатор является опциональным.
|
||||
-- Для этого мы оставляем конструктор "без всего", который структурно
|
||||
-- эквивалентен "старому" типу ключа. При сериализации мы пишем
|
||||
-- сначала "старый" конструктор, потом в эту строку дописываем новый (без реципиентов)
|
||||
-- Поскольку ключ является моноидом, при десереализации мы складываем "старый" и "новый"
|
||||
-- конструктор и получаем "новый", с Id и всеми делами (если они не Nothing).
|
||||
-- Таким образом, старые ключи не будут индексироваться (но будут работать в старых версиях),
|
||||
-- а "новые" ключи будут иметь возможность индексации и валидации.
|
||||
|
||||
type Recipients s = HashMap (PubKey 'Encrypt s) (EncryptedBox GroupSecret)
|
||||
|
||||
-- NOTE: breaking-change
|
||||
|
||||
data GroupKeyIdScheme = GroupKeyIdBasic1 -- encrypt zeroes then hash
|
||||
deriving stock (Eq,Ord,Generic,Show)
|
||||
|
||||
newtype GroupKeyId = GroupKeyId N.ByteString
|
||||
deriving stock (Eq,Ord,Generic,Show)
|
||||
|
||||
instance Pretty GroupKeyId where
|
||||
pretty what = pretty (AsBase58 (coerce @_ @N.ByteString what))
|
||||
|
||||
instance Pretty GroupKeyIdScheme where
|
||||
pretty = \case
|
||||
GroupKeyIdBasic1 -> "basic1"
|
||||
|
||||
-- NOTE: not-a-monoid
|
||||
-- это моноид, но опасный, потому, что секретные ключи у двух разных
|
||||
-- групповых ключей могут быть разными, и если
|
||||
-- просто объединить два словаря - какой-то секретный
|
||||
-- ключ может быть потерян. а что делать-то, с другой стороны?
|
||||
data instance GroupKey 'Symm s =
|
||||
GroupKeySymm
|
||||
{ recipients :: HashMap (PubKey 'Encrypt s) (EncryptedBox GroupSecret)
|
||||
}
|
||||
GroupKeySymmPlain
|
||||
{ recipients :: Recipients s
|
||||
}
|
||||
| GroupKeySymmFancy
|
||||
{ recipients :: Recipients s
|
||||
, groupKeyIdScheme :: Maybe GroupKeyIdScheme
|
||||
, groupKeyId :: Maybe GroupKeyId
|
||||
, groupKeyTimestamp :: Maybe Word64
|
||||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
deriving instance
|
||||
|
|
@ -83,15 +124,37 @@ deriving instance
|
|||
)
|
||||
=> Eq (GroupKey 'Symm s)
|
||||
|
||||
|
||||
getGroupKeyIdScheme :: GroupKey 'Symm s -> Maybe GroupKeyIdScheme
|
||||
getGroupKeyIdScheme = \case
|
||||
GroupKeySymmPlain{} -> Nothing
|
||||
GroupKeySymmFancy{..} -> groupKeyIdScheme
|
||||
|
||||
getGroupKeyId :: GroupKey 'Symm s -> Maybe GroupKeyId
|
||||
getGroupKeyId = \case
|
||||
GroupKeySymmPlain{} -> Nothing
|
||||
GroupKeySymmFancy{..} -> groupKeyId
|
||||
|
||||
getGroupKeyTimestamp :: GroupKey 'Symm s -> Maybe Word64
|
||||
getGroupKeyTimestamp = \case
|
||||
GroupKeySymmPlain{} -> Nothing
|
||||
GroupKeySymmFancy{..} -> groupKeyTimestamp
|
||||
|
||||
instance ForGroupKeySymm s => Monoid (GroupKey 'Symm s) where
|
||||
mempty = GroupKeySymm mempty
|
||||
mempty = GroupKeySymmFancy mempty mzero mzero mzero
|
||||
|
||||
instance ForGroupKeySymm s => Semigroup (GroupKey 'Symm s) where
|
||||
(<>) (GroupKeySymm a) (GroupKeySymm b) = GroupKeySymm (a <> b)
|
||||
(<>) (GroupKeySymmPlain a) (GroupKeySymmPlain b) = GroupKeySymmFancy (a <> b) mzero mzero mzero
|
||||
(<>) (GroupKeySymmPlain r0) (GroupKeySymmFancy r s k t) = GroupKeySymmFancy (r0 <> r) s k t
|
||||
(<>) (GroupKeySymmFancy r s k t) (GroupKeySymmPlain r0) = GroupKeySymmFancy (r0 <> r) s k t
|
||||
(<>) (GroupKeySymmFancy r0 s0 k0 t0) (GroupKeySymmFancy r1 s1 k1 t1) = GroupKeySymmFancy (r0 <> r1) (s1 <|> s0) (k1 <|> k0) (max t0 t1)
|
||||
|
||||
instance Serialise GroupKeyIdScheme
|
||||
instance Serialise GroupKeyId
|
||||
instance Serialise Key
|
||||
instance Serialise SK.Nonce
|
||||
|
||||
|
||||
-- NOTE: hardcoded-hbs2-basic-auth-type
|
||||
data instance ToEncrypt 'Symm s LBS.ByteString =
|
||||
ToEncryptSymmBS
|
||||
|
|
@ -116,12 +179,54 @@ type ForGroupKeySymm (s :: CryptoScheme ) =
|
|||
, Hashable (PubKey 'Encrypt s)
|
||||
)
|
||||
|
||||
instance ForGroupKeySymm s => Serialise (GroupKey 'Symm s)
|
||||
|
||||
instance Pretty (AsBase58 (PubKey 'Encrypt s)) => Pretty (GroupKey 'Symm s) where
|
||||
pretty g = vcat (fmap prettyEntry (HashMap.toList (recipients g)))
|
||||
newtype GroupKeyExtension s = GroupKeyExtension (GroupKey 'Symm s)
|
||||
deriving stock (Generic)
|
||||
|
||||
data GroupKeySymmV1 s = GroupKeySymmV1 { recipientsV1 :: Recipients s }
|
||||
deriving stock Generic
|
||||
|
||||
instance ForGroupKeySymm s => Serialise (GroupKeyExtension s)
|
||||
|
||||
instance ForGroupKeySymm s => Serialise (GroupKeySymmV1 s)
|
||||
|
||||
instance (ForGroupKeySymm s) => Serialise (GroupKey 'Symm s) where
|
||||
|
||||
encode x = do
|
||||
let compat = GroupKeySymmV1 @s (recipients x)
|
||||
let compatEncoded = Serialise.encode compat
|
||||
let version = 2
|
||||
let ext = (getGroupKeyIdScheme x, getGroupKeyId x, getGroupKeyTimestamp x)
|
||||
compatEncoded <> Serialise.encode version <> Serialise.encode ext
|
||||
|
||||
decode = do
|
||||
GroupKeySymmV1{..} <- Serialise.decode @(GroupKeySymmV1 s)
|
||||
|
||||
avail <- Serialise.peekAvailable
|
||||
|
||||
if avail == 0 then
|
||||
pure $ GroupKeySymmPlain recipientsV1
|
||||
else do
|
||||
version <- Serialise.decode @Int
|
||||
|
||||
case version of
|
||||
2 -> do
|
||||
(s,kid, t) <- Serialise.decode @(Maybe GroupKeyIdScheme, Maybe GroupKeyId, Maybe Word64)
|
||||
pure $ GroupKeySymmFancy recipientsV1 s kid t
|
||||
|
||||
_ -> pure $ GroupKeySymmPlain recipientsV1
|
||||
|
||||
|
||||
instance (Pretty (AsBase58 (PubKey 'Encrypt s)) ) => Pretty (GroupKey 'Symm s) where
|
||||
pretty g = gkType <> line <> vcat (fmap prettyEntry (HashMap.toList (recipients @s g)))
|
||||
where
|
||||
prettyEntry (pk, _) = "member" <+> dquotes (pretty (AsBase58 pk))
|
||||
gkType = case g of
|
||||
GroupKeySymmPlain{} -> ";" <+> "plain group key" <> line
|
||||
GroupKeySymmFancy{} -> ";" <+> "fancy group key" <> line
|
||||
<> "group-key-id" <+> pretty (getGroupKeyId g) <> line
|
||||
<> "group-key-id-scheme" <+> pretty (getGroupKeyIdScheme g) <> line
|
||||
<> "group-key-timestamp" <+> pretty (getGroupKeyTimestamp g) <> line
|
||||
|
||||
|
||||
instance ForGroupKeySymm s => FromStringMaybe (GroupKey 'Symm s) where
|
||||
|
|
@ -130,7 +235,7 @@ instance ForGroupKeySymm s => FromStringMaybe (GroupKey 'Symm s) where
|
|||
toMPlus $ deserialiseOrFail @(GroupKey 'Symm s) (LBS.fromStrict bs)
|
||||
|
||||
instance ForGroupKeySymm s => Pretty (AsGroupKeyFile (GroupKey 'Symm s)) where
|
||||
pretty (AsGroupKeyFile pc) = "# hbs2 symmetric group key file"
|
||||
pretty (AsGroupKeyFile pc) = "# hbs2 symmetric group key file v2"
|
||||
<> line <> co
|
||||
where
|
||||
co = vcat $ fmap pretty
|
||||
|
|
@ -158,13 +263,47 @@ generateGroupKey :: forall s m . (ForGroupKeySymm s, MonadIO m, PubKey 'Encrypt
|
|||
-> [PubKey 'Encrypt s]
|
||||
-> m (GroupKey 'Symm s)
|
||||
|
||||
generateGroupKey mbk pks = GroupKeySymm <$> create
|
||||
generateGroupKey = generateGroupKeyFancy
|
||||
|
||||
|
||||
generateGroupKeyPlain :: forall s m . (ForGroupKeySymm s, MonadIO m, PubKey 'Encrypt s ~ AK.PublicKey)
|
||||
=> Maybe GroupSecret
|
||||
-> [PubKey 'Encrypt s]
|
||||
-> m (GroupKey 'Symm s)
|
||||
|
||||
generateGroupKeyPlain mbk rcpt = do
|
||||
what <- generateGroupKeyFancy @s mbk rcpt
|
||||
pure $ GroupKeySymmPlain (recipients what)
|
||||
|
||||
groupKeyCheckSeed :: N.ByteString
|
||||
groupKeyCheckSeed = BS.replicate 32 0
|
||||
|
||||
generateGroupKeyId :: GroupKeyIdScheme -> GroupSecret -> GroupKeyId
|
||||
generateGroupKeyId _ sk = do
|
||||
let enc = SK.secretbox sk (nonceFrom (mempty :: ByteString)) groupKeyCheckSeed
|
||||
let ha = hashObject @HbSync enc
|
||||
GroupKeyId (coerce ha)
|
||||
|
||||
generateGroupKeyFancy :: forall s m . (ForGroupKeySymm s, MonadIO m, PubKey 'Encrypt s ~ AK.PublicKey)
|
||||
=> Maybe GroupSecret
|
||||
-> [PubKey 'Encrypt s]
|
||||
-> m (GroupKey 'Symm s)
|
||||
|
||||
generateGroupKeyFancy mbk pks = create
|
||||
where
|
||||
create = HashMap.fromList <$> do
|
||||
scheme = GroupKeyIdBasic1
|
||||
create = do
|
||||
now <- liftIO getPOSIXTime <&> Just . round
|
||||
sk <- maybe1 mbk (liftIO SK.newKey) pure
|
||||
forM pks $ \pk -> do
|
||||
box <- liftIO $ AK.boxSeal pk (LBS.toStrict $ serialise sk) <&> EncryptedBox
|
||||
pure (pk, box)
|
||||
rcpt <- forM pks $ \pk -> do
|
||||
box <- liftIO $ AK.boxSeal pk (LBS.toStrict $ serialise sk) <&> EncryptedBox
|
||||
pure (pk, box)
|
||||
let theId = generateGroupKeyId scheme sk
|
||||
pure $ GroupKeySymmFancy
|
||||
(HashMap.fromList rcpt)
|
||||
(Just scheme)
|
||||
(Just theId)
|
||||
now
|
||||
|
||||
lookupGroupKey :: forall s . ( ForGroupKeySymm s
|
||||
, PubKey 'Encrypt s ~ AK.PublicKey
|
||||
|
|
@ -176,7 +315,7 @@ lookupGroupKey :: forall s . ( ForGroupKeySymm s
|
|||
-> Maybe GroupSecret
|
||||
|
||||
lookupGroupKey sk pk gk = runIdentity $ runMaybeT do
|
||||
(EncryptedBox bs) <- MaybeT $ pure $ HashMap.lookup pk (recipients gk)
|
||||
(EncryptedBox bs) <- MaybeT $ pure $ HashMap.lookup pk (recipients @s gk)
|
||||
gkBs <- MaybeT $ pure $ AK.boxSealOpen pk sk bs
|
||||
MaybeT $ pure $ deserialiseOrFail (LBS.fromStrict gkBs) & either (const Nothing) Just
|
||||
|
||||
|
|
@ -286,6 +425,17 @@ instance ( MonadIO m
|
|||
|
||||
data EncMethod = Method1 | Method2
|
||||
|
||||
-- findSecretDefault :: MonadIO m =>
|
||||
|
||||
|
||||
findSecretDefault :: forall s m . (s ~ 'HBS2Basic, Monad m)
|
||||
=> [KeyringEntry s]
|
||||
-> GroupKey 'Symm s
|
||||
-> m (Maybe GroupSecret)
|
||||
|
||||
findSecretDefault keys gk = do
|
||||
pure $ [ lookupGroupKey sk pk gk | KeyringEntry pk sk _ <- keys ] & catMaybes & headMay
|
||||
|
||||
instance ( MonadIO m
|
||||
, MonadError OperationError m
|
||||
, h ~ HbSync
|
||||
|
|
@ -295,17 +445,20 @@ instance ( MonadIO m
|
|||
) => MerkleReader (ToDecrypt 'Symm sch ByteString) s h m where
|
||||
|
||||
data instance TreeKey (ToDecrypt 'Symm sch ByteString) =
|
||||
ToDecryptBS [KeyringEntry sch] (Hash HbSync)
|
||||
| ToDecryptBS2 (GroupKey 'Symm sch) B8.ByteString [KeyringEntry sch] (MTreeAnn [HashRef])
|
||||
-- ToDecryptBS [KeyringEntry sch] (Hash HbSync)
|
||||
ToDecryptBS { treeHash :: Hash HbSync
|
||||
, findSecret :: forall m1 . MonadIO m1 => GroupKey 'Symm sch -> m1 (Maybe GroupSecret)
|
||||
}
|
||||
|
||||
type instance ToBlockR (ToDecrypt 'Symm sch ByteString) = ByteString
|
||||
type instance ReadResult (ToDecrypt 'Symm sch ByteString) = ByteString
|
||||
|
||||
readFromMerkle sto decrypt = do
|
||||
readFromMerkle sto decrypt@ToDecryptBS{..} = do
|
||||
|
||||
(keys, gk, nonceS, tree) <- decryptDataFrom decrypt
|
||||
(gk, nonceS, tree) <- decryptDataFrom decrypt
|
||||
|
||||
let gksec' = [ lookupGroupKey sk pk gk | (pk,sk) <- keys ] & catMaybes & headMay
|
||||
gksec' <- findSecret gk
|
||||
-- [ lookupGroupKey sk pk gk | (pk,sk) <- keys ] & catMaybes & headMay
|
||||
|
||||
gksec <- maybe1 gksec' (throwError (GroupKeyNotFound 2)) pure
|
||||
|
||||
|
|
@ -344,12 +497,8 @@ instance ( MonadIO m
|
|||
where
|
||||
|
||||
decryptDataFrom = \case
|
||||
ToDecryptBS2 gk nonce ke tree -> do
|
||||
let keys = [ (view krPk x, view krSk x) | x <- ke ]
|
||||
pure (keys, gk, nonce, tree)
|
||||
|
||||
ToDecryptBS ke h -> do
|
||||
let keys = [ (view krPk x, view krSk x) | x <- ke ]
|
||||
ToDecryptBS h _ -> do
|
||||
|
||||
bs <- getBlock sto h >>= maybe (throwError MissedBlockError) pure
|
||||
let what = tryDetect h bs
|
||||
|
|
@ -364,8 +513,7 @@ instance ( MonadIO m
|
|||
|
||||
gk <- either (const $ throwError (GroupKeyNotFound 1)) pure (deserialiseOrFail @(GroupKey 'Symm sch) gkbs)
|
||||
|
||||
pure (keys, gk, nonceS, tree)
|
||||
|
||||
pure (gk, nonceS, tree)
|
||||
|
||||
|
||||
encryptBlock :: ( MonadIO m
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# Language UndecidableInstances #-}
|
||||
{-# Language PatternSynonyms #-}
|
||||
module HBS2.Net.Auth.Schema
|
||||
( module HBS2.Net.Auth.Schema
|
||||
, module HBS2.Net.Proto.Types
|
||||
|
|
@ -11,6 +12,8 @@ import HBS2.Net.Proto.Types
|
|||
import HBS2.Hash
|
||||
import HBS2.Net.Messaging.Unix
|
||||
|
||||
import Data.Config.Suckless
|
||||
|
||||
import Data.Word
|
||||
import Crypto.Error
|
||||
import Crypto.PubKey.Ed25519 qualified as Ed
|
||||
|
|
@ -69,3 +72,6 @@ instance (MonadIO m, ForDerivedKey s, s ~ 'HBS2Basic) => HasDerivedKey s 'Sign W
|
|||
prk = HKDF.extract @(HashType HbSync) salt ikm
|
||||
k0 = HKDF.expand @_ @_ @ByteString prk salt Ed.secretKeySize
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -225,10 +225,10 @@ runMessagingUnix env = do
|
|||
clientLoop m = fix \next -> do
|
||||
m
|
||||
if not (MUDontRetry `elem` msgUnixOpts env) then do
|
||||
debug "LOOP!"
|
||||
trace "LOOP!"
|
||||
next
|
||||
else do
|
||||
debug "LOOP EXIT"
|
||||
trace "LOOP EXIT"
|
||||
|
||||
handleClient | MUDontRetry `elem` msgUnixOpts env = \_ w -> handleAny throwStopped w
|
||||
| otherwise = handleAny
|
||||
|
|
@ -237,8 +237,6 @@ runMessagingUnix env = do
|
|||
|
||||
runClient = liftIO $ clientLoop $ handleClient logAndRetry $ flip runContT pure $ do
|
||||
|
||||
debug "HERE WE GO AGAIN!"
|
||||
|
||||
let sa = SockAddrUnix (msgUnixSockPath env)
|
||||
let p = msgUnixSockPath env
|
||||
let who = PeerUNIX p
|
||||
|
|
|
|||
|
|
@ -1,4 +1,6 @@
|
|||
{-# Language FunctionalDependencies #-}
|
||||
{-# Language PatternSynonyms #-}
|
||||
{-# Language ViewPatterns #-}
|
||||
module HBS2.Prelude
|
||||
( module Data.String
|
||||
, module Safe
|
||||
|
|
@ -171,3 +173,8 @@ instance Hashable a => Hashable (ByFirst a b) where
|
|||
|
||||
-- asyncLinked :: forall m . MonadUnliftIO m =>
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -244,6 +244,8 @@ readBundle sto rh ref = do
|
|||
|
||||
let q = tryDetect (fromHashRef ref) obj
|
||||
|
||||
let findSec = runKeymanClientRO . findMatchedGroupKeySecret sto
|
||||
|
||||
case q of
|
||||
Merkle t -> do
|
||||
let meta = BundleMeta ref False
|
||||
|
|
@ -251,9 +253,8 @@ readBundle sto rh ref = do
|
|||
readFromMerkle sto (SimpleKey key)
|
||||
|
||||
MerkleAnn (MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm gkh _}) -> do
|
||||
ke <- loadKeyrings (HashRef gkh)
|
||||
let meta = BundleMeta ref True
|
||||
BundleWithMeta meta <$> readFromMerkle sto (ToDecryptBS ke key)
|
||||
BundleWithMeta meta <$> readFromMerkle sto (ToDecryptBS key (liftIO . findSec))
|
||||
|
||||
_ -> throwError UnsupportedFormat
|
||||
|
||||
|
|
|
|||
|
|
@ -55,7 +55,7 @@ common shared-properties
|
|||
hbs2-core
|
||||
, hbs2-peer
|
||||
, hbs2-storage-simple
|
||||
, hbs2-keyman
|
||||
, hbs2-keyman-direct-lib
|
||||
, db-pipe
|
||||
, suckless-conf
|
||||
|
||||
|
|
|
|||
|
|
@ -1,133 +0,0 @@
|
|||
module Main where
|
||||
|
||||
import HBS2.KeyMan.Prelude
|
||||
import HBS2.KeyMan.App.Types
|
||||
import HBS2.KeyMan.Config
|
||||
import HBS2.KeyMan.State
|
||||
|
||||
import HBS2.Net.Auth.Credentials
|
||||
|
||||
import HBS2.Data.KeyRing qualified as KeyRing
|
||||
|
||||
import HBS2.System.Dir
|
||||
import HBS2.System.Logger.Simple
|
||||
|
||||
import Data.Config.Suckless.KeyValue
|
||||
|
||||
import Options.Applicative qualified as O
|
||||
import Data.Text qualified as Text
|
||||
import Options.Applicative hiding (info)
|
||||
import Data.Set qualified as Set
|
||||
import Data.ByteString qualified as BS
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Reader
|
||||
|
||||
|
||||
data GlobalOptions = GlobalOptions
|
||||
{
|
||||
}
|
||||
|
||||
type Command m = m ()
|
||||
|
||||
-- Парсер для глобальных опций
|
||||
globalOptions :: Parser GlobalOptions
|
||||
globalOptions = pure GlobalOptions
|
||||
|
||||
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"))
|
||||
)
|
||||
|
||||
opts :: (AppPerks m) => ParserInfo (GlobalOptions, Command m)
|
||||
opts = O.info (liftA2 (,) globalOptions commands <**> helper)
|
||||
( fullDesc
|
||||
<> header "hbs2-keyman" )
|
||||
|
||||
|
||||
showConfig :: (AppPerks m) => Parser (Command m)
|
||||
showConfig = do
|
||||
pure do
|
||||
readConfig >>= liftIO . print . vcat . fmap pretty
|
||||
|
||||
addPath :: (AppPerks m) => Parser (Command m)
|
||||
addPath = do
|
||||
masks <- many $ strArgument (metavar "KEYFILE-MASK")
|
||||
pure do
|
||||
cfg <- getConfigPath <&> takeDirectory
|
||||
mkdir cfg
|
||||
for_ masks $ \m -> do
|
||||
liftIO $ appendFile (cfg </> "config") (show $ "key-files" <+> dquotes (pretty m) <> line)
|
||||
|
||||
listKeysCmd :: (AppPerks m) => Parser (Command m)
|
||||
listKeysCmd = pure do
|
||||
kw <- withState listKeys
|
||||
liftIO $ print $ vcat (fmap pretty kw)
|
||||
|
||||
updateKeys :: (AppPerks m) => Parser (Command m)
|
||||
updateKeys = do
|
||||
prune <- flag False True ( long "prune" <> short 'p' <> help "prune keys for missed files")
|
||||
pure do
|
||||
|
||||
masks <- cfgValue @KeyFilesOpt @(Set String) <&> Set.toList
|
||||
files <- KeyRing.findFilesBy masks
|
||||
|
||||
when prune do
|
||||
-- here <- doesPathExist fn
|
||||
--
|
||||
keys <- withState listKeys
|
||||
for_ keys $ \k -> void $ runMaybeT do
|
||||
fn <- keyFile k & toMPlus <&> Text.unpack
|
||||
here <- doesPathExist fn
|
||||
unless here do
|
||||
info $ "prune" <+> pretty fn
|
||||
lift $ withState $ deleteKey (keyId k)
|
||||
|
||||
for_ files $ \fn -> runMaybeT do
|
||||
|
||||
bs <- liftIO $ BS.readFile fn
|
||||
|
||||
krf <- parseCredentials @'HBS2Basic (AsCredFile bs) & toMPlus
|
||||
|
||||
let skp = view peerSignPk krf
|
||||
|
||||
withState do
|
||||
-- info $ pretty (AsBase58 skp) <+> pretty "sign" <+> pretty fn
|
||||
updateKeyFile (SomePubKey @'Sign skp) fn
|
||||
updateKeyType (SomePubKey @'Sign skp)
|
||||
|
||||
for_ (view peerKeyring krf) $ \(KeyringEntry pk _ _) -> do
|
||||
-- info $ pretty (AsBase58 pk) <+> pretty "encrypt" <+> pretty fn
|
||||
updateKeyFile (SomePubKey @'Encrypt pk) fn
|
||||
updateKeyType (SomePubKey @'Encrypt pk)
|
||||
|
||||
commitAll
|
||||
|
||||
setWeightCmd :: (AppPerks m) => Parser (Command m)
|
||||
setWeightCmd = do
|
||||
k <- argument str (metavar "KEY" <> help "Key identifier")
|
||||
v <- argument auto (metavar "WEIGHT" <> help "Weight value")
|
||||
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
|
||||
(_, action) <- execParser opts
|
||||
runApp action
|
||||
|
||||
|
||||
|
|
@ -17,8 +17,7 @@ import HBS2.Base58
|
|||
import HBS2.Net.Auth.Credentials()
|
||||
import HBS2.Net.Proto.Types
|
||||
|
||||
|
||||
import HBS2.System.Logger.Simple
|
||||
import HBS2.System.Logger.Simple.ANSI
|
||||
import Data.Config.Suckless
|
||||
import DBPipe.SQLite
|
||||
|
||||
|
|
@ -5,28 +5,31 @@ import HBS2.KeyMan.Prelude
|
|||
import HBS2.KeyMan.State
|
||||
import HBS2.KeyMan.Config
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.Storage
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Net.Auth.GroupKeySymm as Symm
|
||||
import HBS2.Net.Proto.Types
|
||||
|
||||
|
||||
import HBS2.System.Dir
|
||||
|
||||
import Control.Monad.Cont
|
||||
import UnliftIO
|
||||
import DBPipe.SQLite
|
||||
import Text.InterpolatedString.Perl6 (qc)
|
||||
import Data.Maybe
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import Data.HashSet qualified as HS
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Data.List qualified as List
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.Ord
|
||||
import Data.Coerce
|
||||
import Streaming.Prelude qualified as S
|
||||
|
||||
data KeyManClientError = KeyManClientSomeError
|
||||
|
||||
newtype KeyManClientEnv = KeyManClientEnv AppEnv
|
||||
|
||||
newtype KeyManClient m a = KeyManClient { fromKeyManClient :: DBPipeM m a }
|
||||
deriving newtype ( Applicative
|
||||
, Functor
|
||||
|
|
@ -35,22 +38,38 @@ newtype KeyManClient m a = KeyManClient { fromKeyManClient :: DBPipeM m a }
|
|||
, MonadUnliftIO
|
||||
)
|
||||
|
||||
newKeymanClientEnv :: MonadUnliftIO m => m KeyManClientEnv
|
||||
newKeymanClientEnv = KeyManClientEnv <$> liftIO newAppEnv
|
||||
|
||||
withKeymanClientRO :: MonadUnliftIO m => KeyManClientEnv -> KeyManClient m a -> m a
|
||||
withKeymanClientRO env action = do
|
||||
let db = appDb (coerce env)
|
||||
withDB db (fromKeyManClient action)
|
||||
|
||||
runKeymanClientRO :: MonadUnliftIO m => KeyManClient m a -> m a
|
||||
runKeymanClientRO action = do
|
||||
env <- newKeymanClientEnv
|
||||
withKeymanClientRO env action
|
||||
|
||||
runKeymanClient :: MonadUnliftIO m => KeyManClient m a -> m a
|
||||
runKeymanClient action = do
|
||||
KeyManClientEnv env <- newKeymanClientEnv
|
||||
-- FIXME: dbpath-to-appstatenv
|
||||
-- сейчас dbPath берётся из конфига, а db из стейта
|
||||
-- и хотя они должны быть одинаковы, это не гарантируется
|
||||
dbPath <- getStatePath
|
||||
env <- liftIO newAppEnv
|
||||
|
||||
let db = appDb env
|
||||
|
||||
here <- doesPathExist dbPath
|
||||
|
||||
unless here do
|
||||
withDB db $ populateState
|
||||
|
||||
flip runContT pure $ do
|
||||
void $ ContT $ bracket (async (runPipe db)) cancel
|
||||
|
||||
here <- doesPathExist dbPath
|
||||
|
||||
unless here do
|
||||
withDB db $ populateState
|
||||
|
||||
lift $ withDB db (fromKeyManClient action)
|
||||
|
||||
|
||||
loadCredentials :: forall a m .
|
||||
( MonadIO m
|
||||
, SomePubKeyPerks a
|
||||
|
|
@ -122,3 +141,70 @@ extractGroupKeySecret gk = do
|
|||
|
||||
pure $ headMay r
|
||||
|
||||
|
||||
type TrackGroupKeyView = ( SomeHash GroupKeyId
|
||||
, SomeHash HashRef
|
||||
, String
|
||||
, FilePath
|
||||
, Int)
|
||||
|
||||
findMatchedGroupKeySecret :: forall s m . ( MonadIO m
|
||||
, SerialisedCredentials 'HBS2Basic
|
||||
, s ~ 'HBS2Basic
|
||||
)
|
||||
=> AnyStorage
|
||||
-> GroupKey 'Symm s
|
||||
-> KeyManClient m (Maybe GroupSecret)
|
||||
|
||||
findMatchedGroupKeySecret sto gk = do
|
||||
|
||||
let sql = [qc|
|
||||
select t.secret
|
||||
, t.gkhash
|
||||
, f.key
|
||||
, f.file
|
||||
, coalesce(kw.weight, 0) as weight
|
||||
from gkaccess gka
|
||||
join gktrack t on gka.gkhash = t.gkhash
|
||||
join keyfile f on f.key = gka.key
|
||||
left join keyweight kw on kw.key = f.key
|
||||
where t.secret = ?
|
||||
order by kw.weight desc nulls last
|
||||
|]
|
||||
|
||||
let pks = recipients gk & HM.keysSet
|
||||
|
||||
flip runContT pure $ callCC $ \exit -> do
|
||||
|
||||
kre0 <- lift $ loadKeyRingEntries (HS.toList pks) <&> fmap snd
|
||||
|
||||
sec0 <- findSecretDefault kre0 gk
|
||||
|
||||
-- возвращаем первый, который нашли
|
||||
maybe1 sec0 none (exit . Just)
|
||||
|
||||
-- если старый формат ключа -- то ничего не найдём
|
||||
secId <- ContT $ maybe1 (getGroupKeyId gk) (pure Nothing)
|
||||
|
||||
rows <- lift $ KeyManClient $ select @TrackGroupKeyView sql (Only (SomeHash secId))
|
||||
|
||||
let gkss = HS.fromList (fmap (coerce @_ @HashRef . view _2) rows) & HS.toList
|
||||
|
||||
-- TODO: memoize
|
||||
|
||||
-- ищем такой же
|
||||
-- если нашли -- хорошо бы проверить пруф, но как?
|
||||
-- для исходного ключа -- мы оказались здесь потому,
|
||||
-- что не смогли достать секрет из него и ищем такой же,
|
||||
-- но доступный нам. соответственно, мы не можем убедиться,
|
||||
-- что исходный ключ с правильным Id / правильным секретом.
|
||||
-- можем только обломаться при расшифровке и записать этот факт
|
||||
for_ gkss $ \gkh -> void $ runMaybeT do
|
||||
gkx <- loadGroupKeyMaybe @s sto gkh >>= toMPlus
|
||||
sec' <- lift $ lift $ extractGroupKeySecret gkx
|
||||
maybe1 sec' none $ (lift . exit . Just)
|
||||
|
||||
pure Nothing
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
module HBS2.KeyMan.Prelude
|
||||
( module HBS2.Prelude.Plated
|
||||
, module Exported
|
||||
) where
|
||||
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.Misc.PrettyStuff as Exported
|
||||
import HBS2.System.Logger.Simple.ANSI as Exported
|
||||
|
||||
|
|
@ -4,12 +4,16 @@
|
|||
module HBS2.KeyMan.State
|
||||
( module HBS2.KeyMan.State
|
||||
, commitAll
|
||||
, transactional
|
||||
, module Exported
|
||||
) where
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
import HBS2.Base58
|
||||
import HBS2.Hash
|
||||
import HBS2.Net.Auth.Credentials
|
||||
import HBS2.Net.Proto.Types
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Net.Auth.GroupKeySymm as Exported
|
||||
|
||||
import HBS2.KeyMan.Config
|
||||
|
||||
|
|
@ -19,17 +23,39 @@ import DBPipe.SQLite
|
|||
-- import Crypto.Saltine.Core.Box qualified as Encrypt
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Text.InterpolatedString.Perl6 (qc)
|
||||
import Data.Maybe
|
||||
import Data.HashSet (HashSet)
|
||||
import Data.HashSet qualified as HS
|
||||
import Data.HashMap.Strict qualified as HM
|
||||
import Data.Coerce
|
||||
|
||||
import UnliftIO
|
||||
|
||||
|
||||
newtype SomeHash a = SomeHash a
|
||||
deriving stock Generic
|
||||
|
||||
instance ToField (SomeHash HashRef) where
|
||||
toField (SomeHash x) = toField $ show $ pretty x
|
||||
|
||||
instance FromField (SomeHash HashRef) where
|
||||
fromField = fmap (SomeHash . fromString @HashRef) . fromField @String
|
||||
|
||||
instance ToField (SomeHash GroupKeyId) where
|
||||
toField (SomeHash x) = toField $ show $ pretty x
|
||||
|
||||
instance FromField (SomeHash GroupKeyId) where
|
||||
fromField = do
|
||||
fmap (SomeHash . convert . fromString @HashRef) . fromField @String
|
||||
where
|
||||
convert ha = GroupKeyId (coerce ha)
|
||||
|
||||
-- newtype ToDB a = ToDB a
|
||||
class SomePubKeyType a where
|
||||
somePubKeyType :: a -> String
|
||||
|
||||
type SomePubKeyPerks a = (Pretty (AsBase58 a))
|
||||
type SomePubKeyPerks a = (Pretty (AsBase58 a), FromStringMaybe a)
|
||||
|
||||
data SomePubKey (c :: CryptoAction) = forall a . SomePubKeyPerks a => SomePubKey a
|
||||
|
||||
|
|
@ -84,12 +110,36 @@ populateState = do
|
|||
)
|
||||
|]
|
||||
|
||||
|
||||
ddl [qc|
|
||||
create table if not exists gkseentx
|
||||
( hash text not null
|
||||
, primary key (hash)
|
||||
)
|
||||
|]
|
||||
|
||||
ddl [qc|
|
||||
create table if not exists gktrack
|
||||
( secret text not null
|
||||
, gkhash text not null
|
||||
, primary key (secret,gkhash)
|
||||
)
|
||||
|]
|
||||
|
||||
ddl [qc|
|
||||
create table if not exists gkaccess
|
||||
( gkhash text not null
|
||||
, key text not null
|
||||
, primary key (gkhash,key)
|
||||
)
|
||||
|]
|
||||
|
||||
|
||||
commitAll
|
||||
|
||||
instance ToField (SomePubKey a) where
|
||||
toField (SomePubKey s) = toField $ show $ pretty (AsBase58 s)
|
||||
|
||||
|
||||
updateKeyFile :: forall a m . (SomePubKeyType (SomePubKey a), MonadIO m)
|
||||
=> SomePubKey a
|
||||
-> FilePath
|
||||
|
|
@ -204,3 +254,42 @@ selectKeyWeight key = do
|
|||
limit 1
|
||||
|] (Only (SomePubKey key)) <&> maybe 0 fromOnly . listToMaybe
|
||||
|
||||
|
||||
deleteAllSeenGKTx :: MonadIO m => DBPipeM m ()
|
||||
deleteAllSeenGKTx = do
|
||||
insert_ [qc|delete from gkseentx|]
|
||||
|
||||
insertSeenGKTx :: (MonadIO m) => HashRef -> DBPipeM m ()
|
||||
insertSeenGKTx hash = do
|
||||
insert [qc|
|
||||
insert into gkseentx (hash) values(?)
|
||||
on conflict (hash) do nothing
|
||||
|] (Only (SomeHash hash))
|
||||
|
||||
selectAllSeenGKTx :: (MonadIO m) => DBPipeM m (HashSet HashRef)
|
||||
selectAllSeenGKTx = do
|
||||
select_ [qc|select hash from gkseentx|] <&> HS.fromList . fmap (coerce . fromOnly @(SomeHash HashRef))
|
||||
|
||||
|
||||
insertGKTrack :: MonadIO m => GroupKeyId -> HashRef -> DBPipeM m ()
|
||||
insertGKTrack s g = do
|
||||
insert [qc|
|
||||
insert into gktrack (secret,gkhash)
|
||||
values(?,?)
|
||||
on conflict (secret,gkhash) do nothing
|
||||
|] (SomeHash s, SomeHash g)
|
||||
|
||||
insertGKAccess:: MonadIO m => HashRef -> GroupKey 'Symm 'HBS2Basic -> DBPipeM m ()
|
||||
insertGKAccess gkh gk = do
|
||||
let rcpt = recipients gk & HM.keys
|
||||
for_ rcpt $ \k -> do
|
||||
insert [qc|
|
||||
insert into gkaccess (gkhash,key)
|
||||
values(?,?)
|
||||
on conflict (gkhash,key) do nothing
|
||||
|] (SomeHash gkh, SomePubKey k)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
Copyright (c) 2023, 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.
|
||||
|
|
@ -0,0 +1,109 @@
|
|||
cabal-version: 3.0
|
||||
name: hbs2-keyman-direct-lib
|
||||
version: 0.24.1.2
|
||||
-- synopsis:
|
||||
-- description:
|
||||
license: BSD-3-Clause
|
||||
license-file: LICENSE
|
||||
author: Dmitry Zuikov
|
||||
maintainer: dzuikov@gmail.com
|
||||
-- copyright:
|
||||
category: Data
|
||||
build-type: Simple
|
||||
-- extra-doc-files: CHANGELOG.md
|
||||
-- extra-source-files:
|
||||
|
||||
common warnings
|
||||
ghc-options: -Wall -fno-warn-type-defaults
|
||||
|
||||
common common-deps
|
||||
build-depends:
|
||||
base, hbs2-core, hbs2-storage-simple, suckless-conf, db-pipe
|
||||
, async
|
||||
, bytestring
|
||||
, cache
|
||||
, containers
|
||||
, data-default
|
||||
, deepseq
|
||||
, directory
|
||||
, filepath
|
||||
, filepattern
|
||||
, generic-lens
|
||||
, hashable
|
||||
, heaps
|
||||
, microlens-platform
|
||||
, mtl
|
||||
, mwc-random
|
||||
, prettyprinter
|
||||
, QuickCheck
|
||||
, random
|
||||
, random-shuffle
|
||||
, resourcet
|
||||
, safe
|
||||
, serialise
|
||||
, split
|
||||
, stm
|
||||
, streaming
|
||||
, tasty
|
||||
, tasty-hunit
|
||||
, temporary
|
||||
, text
|
||||
, timeit
|
||||
, transformers
|
||||
, uniplate
|
||||
, unordered-containers
|
||||
, vector
|
||||
, prettyprinter-ansi-terminal
|
||||
, interpolatedstring-perl6
|
||||
, unliftio
|
||||
|
||||
default-extensions:
|
||||
ApplicativeDo
|
||||
, BangPatterns
|
||||
, BlockArguments
|
||||
, ConstraintKinds
|
||||
, DataKinds
|
||||
, DeriveDataTypeable
|
||||
, DeriveGeneric
|
||||
, DerivingStrategies
|
||||
, DerivingVia
|
||||
, ExtendedDefaultRules
|
||||
, FlexibleContexts
|
||||
, FlexibleInstances
|
||||
, GADTs
|
||||
, GeneralizedNewtypeDeriving
|
||||
, ImportQualifiedPost
|
||||
, LambdaCase
|
||||
, MultiParamTypeClasses
|
||||
, OverloadedStrings
|
||||
, OverloadedLabels
|
||||
, QuasiQuotes
|
||||
, RankNTypes
|
||||
, RecordWildCards
|
||||
, RecursiveDo
|
||||
, ScopedTypeVariables
|
||||
, StandaloneDeriving
|
||||
, TupleSections
|
||||
, TypeApplications
|
||||
, TypeFamilies
|
||||
, TypeOperators
|
||||
|
||||
|
||||
|
||||
library
|
||||
import: warnings
|
||||
import: common-deps
|
||||
|
||||
exposed-modules:
|
||||
HBS2.KeyMan.App.Types
|
||||
HBS2.KeyMan.Prelude
|
||||
HBS2.KeyMan.Config
|
||||
HBS2.KeyMan.State
|
||||
HBS2.KeyMan.Keys.Direct
|
||||
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
build-depends: base
|
||||
hs-source-dirs: .
|
||||
default-language: GHC2021
|
||||
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
Copyright (c) 2023, 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.
|
||||
|
|
@ -0,0 +1,255 @@
|
|||
module Main where
|
||||
|
||||
import HBS2.KeyMan.Prelude
|
||||
import HBS2.KeyMan.App.Types
|
||||
import HBS2.KeyMan.Config
|
||||
import HBS2.KeyMan.State
|
||||
|
||||
import HBS2.Net.Auth.Credentials
|
||||
|
||||
import HBS2.Data.KeyRing qualified as KeyRing
|
||||
|
||||
import HBS2.System.Dir
|
||||
|
||||
import HBS2.Storage
|
||||
import HBS2.Storage.Operations.ByteString
|
||||
import HBS2.Data.Types.SignedBox
|
||||
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
|
||||
import HBS2.Peer.RPC.API.RefChan
|
||||
import HBS2.Peer.RPC.API.Storage
|
||||
import HBS2.Peer.RPC.Client.StorageClient
|
||||
|
||||
import Data.Config.Suckless.KeyValue
|
||||
import Data.Config.Suckless
|
||||
|
||||
import Data.List qualified as List
|
||||
import Options.Applicative qualified as O
|
||||
import Data.Text qualified as Text
|
||||
import Options.Applicative hiding (info,action)
|
||||
import Data.Set qualified as Set
|
||||
import Data.HashSet qualified as HS
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString qualified as LBS
|
||||
import Data.Maybe
|
||||
import Data.Either
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.Trans.Cont
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Except
|
||||
import Codec.Serialise
|
||||
import Data.Coerce
|
||||
|
||||
import Streaming.Prelude qualified as S
|
||||
|
||||
data GlobalOptions = GlobalOptions
|
||||
{
|
||||
}
|
||||
|
||||
type Command m = m ()
|
||||
|
||||
-- Парсер для глобальных опций
|
||||
globalOptions :: Parser GlobalOptions
|
||||
globalOptions = pure GlobalOptions
|
||||
|
||||
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"))
|
||||
)
|
||||
|
||||
opts :: (AppPerks m) => ParserInfo (GlobalOptions, Command m)
|
||||
opts = O.info (liftA2 (,) globalOptions commands <**> helper)
|
||||
( fullDesc
|
||||
<> header "hbs2-keyman" )
|
||||
|
||||
|
||||
showConfig :: (AppPerks m) => Parser (Command m)
|
||||
showConfig = do
|
||||
pure do
|
||||
readConfig >>= liftIO . print . vcat . fmap pretty
|
||||
|
||||
addPath :: (AppPerks m) => Parser (Command m)
|
||||
addPath = do
|
||||
masks <- many $ strArgument (metavar "KEYFILE-MASK")
|
||||
pure do
|
||||
cfg <- getConfigPath <&> takeDirectory
|
||||
mkdir cfg
|
||||
for_ masks $ \m -> do
|
||||
liftIO $ appendFile (cfg </> "config") (show $ "key-files" <+> dquotes (pretty m) <> line)
|
||||
|
||||
listKeysCmd :: (AppPerks m) => Parser (Command m)
|
||||
listKeysCmd = pure do
|
||||
kw <- withState listKeys
|
||||
liftIO $ print $ vcat (fmap pretty kw)
|
||||
|
||||
|
||||
data RChanScanEnv =
|
||||
RChanScanEnv
|
||||
{ storage :: AnyStorage
|
||||
, refchanAPI :: ServiceCaller RefChanAPI UNIX
|
||||
}
|
||||
|
||||
newtype ScanRefChansM m a = ScanRefChansM { fromScanRefChansM :: ReaderT RChanScanEnv m a }
|
||||
deriving newtype ( Applicative
|
||||
, Functor
|
||||
, Monad
|
||||
, MonadIO
|
||||
, MonadUnliftIO
|
||||
, MonadReader RChanScanEnv
|
||||
, MonadTrans
|
||||
)
|
||||
|
||||
runScan :: Monad m => RChanScanEnv -> ScanRefChansM m a -> m a
|
||||
runScan env action = runReaderT ( fromScanRefChansM action ) env
|
||||
|
||||
|
||||
instance Monad m => HasClientAPI RefChanAPI UNIX (ScanRefChansM m) where
|
||||
getClientAPI = asks refchanAPI
|
||||
|
||||
instance Monad m => HasStorage (ScanRefChansM m) where
|
||||
getStorage = asks storage
|
||||
|
||||
|
||||
updateKeys :: forall proto m . (AppPerks m, proto ~ UNIX) => Parser (Command m)
|
||||
updateKeys = do
|
||||
prune <- flag False True ( long "prune" <> short 'p' <> help "prune keys for missed files")
|
||||
pure do
|
||||
updateLocalKeys prune
|
||||
updateGroupKeys
|
||||
|
||||
where
|
||||
|
||||
updateGroupKeys = do
|
||||
-- scanning refchans for group keys
|
||||
conf <- getConf
|
||||
let rchans = [ r | ListVal [SymbolVal "refchan", SignPubKeyLike r] <- conf ]
|
||||
|
||||
seen <- withState selectAllSeenGKTx
|
||||
|
||||
flip runContT pure $ callCC \exit -> do
|
||||
when (List.null rchans) $ exit ()
|
||||
so' <- detectRPC
|
||||
so <- ContT $ maybe1 so' (warn $ yellow "peer is down")
|
||||
|
||||
rpc <- ContT $ withRPC2 @RefChanAPI so
|
||||
sto <- ContT (withRPC2 @StorageAPI so) <&> AnyStorage . StorageClient
|
||||
|
||||
|
||||
txs <- S.toList_ do
|
||||
runScan (RChanScanEnv sto rpc) do
|
||||
|
||||
for_ rchans $ \r -> do
|
||||
|
||||
walkRefChanTx @proto (pure . not . flip HS.member seen) r $ \tx0 -> \case
|
||||
P _ (ProposeTran _ box) -> do
|
||||
|
||||
trace $ "got the fucking tx" <+> pretty tx0
|
||||
|
||||
void $ runMaybeT do
|
||||
(_,bs) <- unboxSignedBox0 box & toMPlus
|
||||
|
||||
AnnotatedHashRef _ gkh <- deserialiseOrFail @AnnotatedHashRef (LBS.fromStrict bs)
|
||||
& toMPlus . either (const Nothing) Just
|
||||
|
||||
-- FIXME: request-download-for-missed-groupkeys
|
||||
-- FIXME: implement-download-with-timeout
|
||||
gkbs <- runExceptT (readFromMerkle sto (SimpleKey (coerce gkh)))
|
||||
>>= toMPlus
|
||||
|
||||
-- FIXME: do-it-right
|
||||
-- если смогли скачать -- то уже потом не будем обрабатывать
|
||||
-- потенциальная проблема -- мусорная транзакция, которая так и
|
||||
-- будет болтаться, если она не AnnotatedHashRef
|
||||
lift $ lift $ S.yield (Left tx0)
|
||||
|
||||
gk <- deserialiseOrFail @(GroupKey 'Symm HBS2Basic) gkbs & toMPlus
|
||||
|
||||
gkId <- getGroupKeyId gk & toMPlus
|
||||
|
||||
--TODO: verify-group-key-id-if-possible
|
||||
|
||||
notice $ green "found new gk0" <+> pretty gkId <+> pretty gkh
|
||||
|
||||
lift $ lift $ S.yield (Right (gkId, gkh, gk) )
|
||||
|
||||
_ -> do
|
||||
lift $ S.yield (Left tx0)
|
||||
|
||||
lift $ withState $ transactional do
|
||||
for_ (lefts txs) insertSeenGKTx
|
||||
for_ (rights txs) $ \(gkId, h, gh) -> do
|
||||
insertGKTrack gkId h
|
||||
insertGKAccess h gh
|
||||
|
||||
pure ()
|
||||
|
||||
updateLocalKeys prune = do
|
||||
|
||||
masks <- cfgValue @KeyFilesOpt @(Set String) <&> Set.toList
|
||||
files <- KeyRing.findFilesBy masks
|
||||
|
||||
when prune do
|
||||
-- here <- doesPathExist fn
|
||||
--
|
||||
keys <- withState listKeys
|
||||
for_ keys $ \k -> void $ runMaybeT do
|
||||
fn <- keyFile k & toMPlus <&> Text.unpack
|
||||
here <- doesPathExist fn
|
||||
unless here do
|
||||
info $ "prune" <+> pretty fn
|
||||
lift $ withState $ deleteKey (keyId k)
|
||||
|
||||
for_ files $ \fn -> runMaybeT do
|
||||
|
||||
bs <- liftIO $ BS.readFile fn
|
||||
|
||||
krf <- parseCredentials @'HBS2Basic (AsCredFile bs) & toMPlus
|
||||
|
||||
let skp = view peerSignPk krf
|
||||
|
||||
withState do
|
||||
-- info $ pretty (AsBase58 skp) <+> pretty "sign" <+> pretty fn
|
||||
updateKeyFile (SomePubKey @'Sign skp) fn
|
||||
updateKeyType (SomePubKey @'Sign skp)
|
||||
|
||||
for_ (view peerKeyring krf) $ \(KeyringEntry pk _ _) -> do
|
||||
-- info $ pretty (AsBase58 pk) <+> pretty "encrypt" <+> pretty fn
|
||||
updateKeyFile (SomePubKey @'Encrypt pk) fn
|
||||
updateKeyType (SomePubKey @'Encrypt pk)
|
||||
|
||||
commitAll
|
||||
|
||||
|
||||
|
||||
setWeightCmd :: (AppPerks m) => Parser (Command m)
|
||||
setWeightCmd = do
|
||||
k <- argument str (metavar "KEY" <> help "Key identifier")
|
||||
v <- argument auto (metavar "WEIGHT" <> help "Weight value")
|
||||
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
|
||||
(_, action) <- execParser opts
|
||||
runApp action
|
||||
|
||||
|
||||
|
|
@ -90,23 +90,6 @@ common common-deps
|
|||
|
||||
|
||||
|
||||
library
|
||||
import: warnings
|
||||
import: common-deps
|
||||
|
||||
exposed-modules:
|
||||
HBS2.KeyMan.App.Types
|
||||
HBS2.KeyMan.Prelude
|
||||
HBS2.KeyMan.Config
|
||||
HBS2.KeyMan.State
|
||||
HBS2.KeyMan.Keys.Direct
|
||||
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
build-depends: base
|
||||
hs-source-dirs: src
|
||||
default-language: GHC2021
|
||||
|
||||
executable hbs2-keyman
|
||||
import: warnings
|
||||
import: common-deps
|
||||
|
|
@ -116,9 +99,10 @@ executable hbs2-keyman
|
|||
-- other-extensions:
|
||||
build-depends:
|
||||
base
|
||||
, hbs2-keyman
|
||||
, hbs2-keyman-direct-lib
|
||||
, hbs2-peer
|
||||
, optparse-applicative
|
||||
|
||||
hs-source-dirs: app
|
||||
hs-source-dirs: .
|
||||
default-language: GHC2021
|
||||
|
||||
|
|
@ -1,8 +0,0 @@
|
|||
module HBS2.KeyMan.Prelude
|
||||
( module HBS2.Prelude.Plated
|
||||
) where
|
||||
|
||||
|
||||
import HBS2.Prelude.Plated
|
||||
|
||||
|
||||
|
|
@ -284,7 +284,7 @@ executable hbs2-peer
|
|||
, Paths_hbs2_peer
|
||||
|
||||
-- other-extensions:
|
||||
build-depends: base, hbs2-peer, hbs2-keyman, vty
|
||||
build-depends: base, hbs2-peer, hbs2-keyman-direct-lib, vty
|
||||
|
||||
hs-source-dirs: app
|
||||
|
||||
|
|
|
|||
|
|
@ -190,3 +190,5 @@ walkRefChanTx filt puk action = do
|
|||
tx <- ContT $ maybe1 (unpackRefChanUpdate h lbs) none
|
||||
lift $ action h tx
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -18,6 +18,7 @@ import HBS2.System.Logger.Simple
|
|||
import Data.Kind
|
||||
import Control.Monad.Reader
|
||||
import UnliftIO
|
||||
import Control.Monad.Trans.Cont
|
||||
|
||||
withRPC2 :: forall (api :: [Type]) e m r . ( e ~ UNIX
|
||||
, HasProtocol e (ServiceProto api e)
|
||||
|
|
@ -29,23 +30,24 @@ withRPC2 :: forall (api :: [Type]) e m r . ( e ~ UNIX
|
|||
|
||||
withRPC2 soname action = do
|
||||
|
||||
debug $ "withRPC2" <+> pretty soname
|
||||
flip runContT pure do
|
||||
|
||||
client1 <- newMessagingUnix False 1.0 soname
|
||||
trace $ "withRPC2" <+> pretty soname
|
||||
|
||||
m1 <- async $ runMessagingUnix client1
|
||||
-- link m1
|
||||
client1 <- newMessagingUnix False 1.0 soname
|
||||
|
||||
caller <- makeServiceCaller @api @UNIX (fromString soname)
|
||||
p2 <- liftIO $ async $ runReaderT (runServiceClient @api @e caller) client1
|
||||
m1 <- ContT $ withAsync (runMessagingUnix client1)
|
||||
-- link m1
|
||||
|
||||
r <- action caller
|
||||
caller <- makeServiceCaller @api @UNIX (fromString soname)
|
||||
p2 <- ContT $ withAsync (liftIO $ runReaderT (runServiceClient @api @e caller) client1)
|
||||
|
||||
pause @'Seconds 0.05
|
||||
cancel p2
|
||||
r <- lift $ action caller
|
||||
|
||||
void $ waitAnyCatchCancel [m1, p2]
|
||||
pause @'Seconds 0.05
|
||||
cancel p2
|
||||
|
||||
pure r
|
||||
void $ waitAnyCatchCancel [m1, p2]
|
||||
|
||||
pure r
|
||||
|
||||
|
|
|
|||
|
|
@ -56,7 +56,7 @@ common shared-properties
|
|||
hbs2-core
|
||||
, hbs2-peer
|
||||
, hbs2-storage-simple
|
||||
, hbs2-keyman
|
||||
, hbs2-keyman-direct-lib
|
||||
, db-pipe
|
||||
, suckless-conf
|
||||
|
||||
|
|
|
|||
|
|
@ -35,6 +35,7 @@ syncEntries :: forall c m . ( MonadUnliftIO m
|
|||
, HasRunDir m
|
||||
, HasTombs m
|
||||
, HasCache m
|
||||
, HasKeyManClient m
|
||||
, MonadReader (Maybe SyncEnv) m
|
||||
)
|
||||
=> MakeDictM c m ()
|
||||
|
|
|
|||
|
|
@ -37,8 +37,11 @@ import HBS2.KeyMan.Keys.Direct as Exported ( runKeymanClient
|
|||
, loadCredentials
|
||||
, loadKeyRingEntries
|
||||
, extractGroupKeySecret
|
||||
, KeyManClientEnv
|
||||
)
|
||||
|
||||
import HBS2.KeyMan.Keys.Direct qualified as KE
|
||||
|
||||
import Data.Config.Suckless as Exported
|
||||
import Data.Config.Suckless.Script as Exported
|
||||
|
||||
|
|
@ -112,13 +115,14 @@ instance Pretty DirSyncEnv where
|
|||
|
||||
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))
|
||||
, dirCache :: TVar (Map FilePath (CompactStorage HbSync))
|
||||
{ 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))
|
||||
, dirCache :: TVar (Map FilePath (CompactStorage HbSync))
|
||||
, keymanClientEnv :: TVar (Maybe KeyManClientEnv)
|
||||
}
|
||||
|
||||
newtype SyncApp m a =
|
||||
|
|
@ -142,6 +146,9 @@ class Monad m => HasCache m where
|
|||
getCache :: m (CompactStorage HbSync)
|
||||
closeCache :: m ()
|
||||
|
||||
class Monad m => HasKeyManClient m where
|
||||
getKeyManClientEnv :: m KeyManClientEnv
|
||||
|
||||
instance MonadUnliftIO m => HasTombs (SyncApp m) where
|
||||
getTombs = do
|
||||
SyncEnv{..} <- ask >>= orThrow PeerNotConnectedException
|
||||
|
|
@ -205,6 +212,23 @@ instance MonadUnliftIO m => HasCache (SyncApp m) where
|
|||
compactStorageClose cache
|
||||
|
||||
|
||||
instance MonadUnliftIO m => HasKeyManClient (SyncApp m) where
|
||||
getKeyManClientEnv = do
|
||||
SyncEnv{..} <- ask >>= orThrow PeerNotConnectedException
|
||||
e <- readTVarIO keymanClientEnv
|
||||
|
||||
case e of
|
||||
Just env -> pure env
|
||||
-- NOTE: race-but-harmless
|
||||
-- если у нас в двух потоках позовут этот метод,
|
||||
-- то будет открыто два соединения, и сохранено
|
||||
-- последнее. Поскольку соединение readonly это
|
||||
-- безобидно. В целом, надо навести с этим порядок
|
||||
Nothing -> do
|
||||
env <- KE.newKeymanClientEnv
|
||||
atomically $ writeTVar keymanClientEnv (Just env)
|
||||
pure env
|
||||
|
||||
instance MonadIO m => HasClientAPI StorageAPI UNIX (SyncApp m) where
|
||||
getClientAPI = ask >>= orThrow PeerNotConnectedException
|
||||
<&> storageAPI
|
||||
|
|
@ -262,8 +286,9 @@ recover what = do
|
|||
this <- newTVarIO Nothing
|
||||
tombs <- newTVarIO mempty
|
||||
cache <- newTVarIO mempty
|
||||
dummyKeyman <- newTVarIO Nothing
|
||||
|
||||
let env = Just (SyncEnv refChanAPI storageAPI peerAPI dsync this tombs cache)
|
||||
let env = Just (SyncEnv refChanAPI storageAPI peerAPI dsync this tombs cache dummyKeyman)
|
||||
|
||||
liftIO $ withSyncApp env what
|
||||
|
||||
|
|
@ -391,7 +416,8 @@ instance (Monad m, HasCache m) => HasCache (RunM c m) where
|
|||
getCache = lift getCache
|
||||
closeCache = lift closeCache
|
||||
|
||||
|
||||
instance (MonadUnliftIO m, HasKeyManClient m) => HasKeyManClient (RunM c m) where
|
||||
getKeyManClientEnv = lift getKeyManClientEnv
|
||||
|
||||
-- debugPrefix :: LoggerEntry -> LoggerEntry
|
||||
debugPrefix = toStderr . logPrefix "[debug] "
|
||||
|
|
|
|||
|
|
@ -22,6 +22,8 @@ import HBS2.Peer.RPC.Client.Unix (UNIX)
|
|||
import HBS2.Peer.RPC.Client
|
||||
import HBS2.Peer.RPC.Client.RefChan as Client
|
||||
|
||||
import HBS2.KeyMan.Keys.Direct
|
||||
|
||||
import HBS2.CLI.Run.MetaData (createTreeWithMetadata)
|
||||
|
||||
import DBPipe.SQLite
|
||||
|
|
@ -180,6 +182,7 @@ getStateFromDir0 :: ( MonadUnliftIO m
|
|||
, HasStorage m
|
||||
, HasRunDir m
|
||||
, HasCache m
|
||||
, HasKeyManClient m
|
||||
)
|
||||
=> Bool
|
||||
-> m [(FilePath, Entry)]
|
||||
|
|
@ -200,6 +203,7 @@ getStateFromDir :: ( MonadUnliftIO m
|
|||
, HasStorage m
|
||||
, HasRunDir m
|
||||
, HasCache m
|
||||
, HasKeyManClient m
|
||||
)
|
||||
=> Bool -- ^ use remote state as seed
|
||||
-> FilePath -- ^ dir
|
||||
|
|
@ -243,6 +247,7 @@ getStateFromRefChan :: forall m . ( MonadUnliftIO m
|
|||
, HasStorage m
|
||||
, HasRunDir m
|
||||
, HasCache m
|
||||
, HasKeyManClient m
|
||||
)
|
||||
=> MyRefChan
|
||||
-> m [(FilePath, Entry)]
|
||||
|
|
@ -259,6 +264,12 @@ getStateFromRefChan rchan = do
|
|||
|
||||
db <- newDBPipeEnv dbPipeOptsDef (statePath </> "state.db")
|
||||
|
||||
here <- doesDirectoryExist statePath
|
||||
|
||||
unless here $ mkdir statePath
|
||||
|
||||
keEnv <- getKeyManClientEnv
|
||||
|
||||
flip runContT pure do
|
||||
|
||||
void $ ContT $ bracket (async (runPipe db)) cancel
|
||||
|
|
@ -276,19 +287,15 @@ getStateFromRefChan rchan = do
|
|||
|
||||
let members = view refChanHeadReaders rch & HS.toList
|
||||
|
||||
krl <- liftIO $ runKeymanClient $ loadKeyRingEntries members
|
||||
krl <- liftIO $ withKeymanClientRO keEnv $ loadKeyRingEntries members
|
||||
<&> L.sortOn (Down . fst)
|
||||
<&> fmap snd
|
||||
|
||||
let krs = HM.fromList [ (pk,e) | e@(KeyringEntry pk _ _) <- krl ]
|
||||
|
||||
let findKey gk = do
|
||||
r <- S.toList_ do
|
||||
forM_ (HM.toList $ recipients gk) $ \(pk,box) -> runMaybeT do
|
||||
(KeyringEntry ppk ssk _) <- toMPlus $ HM.lookup pk krs
|
||||
let s = Symm.lookupGroupKey @'HBS2Basic ssk ppk gk
|
||||
for_ s $ lift . S.yield
|
||||
pure $ headMay r
|
||||
-- FIXME: asap-insert-findMatchedGroupKey
|
||||
let findKey gk = lift $ lift $ withKeymanClientRO keEnv do
|
||||
findMatchedGroupKeySecret sto gk
|
||||
|
||||
-- let check hx = pure True
|
||||
hseen <- withDB db (select_ [qc|select txhash from seen|])
|
||||
|
|
@ -592,8 +599,9 @@ mergeState seed orig = do
|
|||
else
|
||||
new
|
||||
|
||||
getTreeContents :: ( MonadUnliftIO m
|
||||
, MonadError OperationError m
|
||||
getTreeContents :: forall m . ( MonadUnliftIO m
|
||||
, MonadIO m
|
||||
, MonadError OperationError m
|
||||
)
|
||||
=> AnyStorage
|
||||
-> HashRef
|
||||
|
|
@ -617,10 +625,10 @@ getTreeContents sto href = do
|
|||
>>= orThrowError (GroupKeyNotFound 11)
|
||||
<&> HM.keys . Symm.recipients
|
||||
|
||||
kre <- runKeymanClient do
|
||||
loadKeyRingEntries rcpts <&> fmap snd
|
||||
let findStuff g = do
|
||||
runKeymanClientRO @IO $ findMatchedGroupKeySecret sto g
|
||||
|
||||
readFromMerkle sto (ToDecryptBS kre (coerce href))
|
||||
readFromMerkle sto (ToDecryptBS (coerce href) (liftIO . findStuff))
|
||||
|
||||
_ -> throwError UnsupportedFormat
|
||||
|
||||
|
|
@ -633,6 +641,7 @@ runDirectory :: ( IsContext c
|
|||
, HasRunDir m
|
||||
, HasTombs m
|
||||
, HasCache m
|
||||
, HasKeyManClient m
|
||||
, Exception (BadFormException c)
|
||||
) => RunM c m ()
|
||||
runDirectory = do
|
||||
|
|
|
|||
|
|
@ -268,7 +268,8 @@ runCat opts ss = do
|
|||
lift $ runKeymanClient do
|
||||
loadKeyRingEntries rcpts <&> fmap snd
|
||||
|
||||
elbs <- runExceptT $ readFromMerkle ss (ToDecryptBS keyring mhash)
|
||||
let sto = AnyStorage ss
|
||||
elbs <- runExceptT $ readFromMerkle ss (ToDecryptBS mhash (liftIO . runKeymanClientRO . findMatchedGroupKeySecret sto))
|
||||
case elbs of
|
||||
Right lbs -> LBS.putStr lbs
|
||||
Left e -> die (show e)
|
||||
|
|
|
|||
|
|
@ -64,7 +64,7 @@ executable hbs2
|
|||
other-modules:
|
||||
Paths_hbs2
|
||||
-- other-extensions:
|
||||
build-depends: base, hbs2-core, hbs2-peer, hbs2-storage-simple, hbs2-keyman
|
||||
build-depends: base, hbs2-core, hbs2-peer, hbs2-storage-simple, hbs2-keyman-direct-lib
|
||||
, aeson
|
||||
, async
|
||||
, base58-bytestring
|
||||
|
|
|
|||
Loading…
Reference in New Issue