mirror of https://github.com/voidlizard/hbs2
wip
This commit is contained in:
Dmitry Zuikov
parent
9f45b7a8f8
commit
127d3cf62b
|
|
@ -5,6 +5,8 @@ module Main where
|
|||
import HBS2.Prelude.Plated
|
||||
import HBS2.OrDie
|
||||
|
||||
import HBS2.Data.Types.Refs
|
||||
import HBS2.Merkle
|
||||
import HBS2.Misc.PrettyStuff as All
|
||||
import HBS2.System.Logger.Simple.ANSI as All
|
||||
|
||||
|
|
@ -30,8 +32,6 @@ import HBS2.KeyMan.Keys.Direct
|
|||
import HBS2.KeyMan.State
|
||||
import HBS2.KeyMan.App.Types
|
||||
|
||||
import HBS2.Misc.PrettyStuff
|
||||
|
||||
import Data.Coerce
|
||||
import Data.Config.Suckless
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
|
|
@ -40,16 +40,20 @@ import Data.Kind
|
|||
import Data.List (isPrefixOf)
|
||||
import Data.List qualified as List
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.Char8 qualified as BS8
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.ByteString.Lazy qualified as LBS
|
||||
import Data.ByteString.Lazy.Char8 qualified as LBS8
|
||||
import Data.Text qualified as Text
|
||||
import Data.Text.Encoding qualified as TE
|
||||
import Data.Text.IO qualified as TIO
|
||||
import Data.Either
|
||||
import Data.Maybe
|
||||
import Codec.Serialise
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.Writer
|
||||
import Control.Monad.Identity
|
||||
import Control.Monad.Trans.Maybe
|
||||
import UnliftIO
|
||||
import System.Environment
|
||||
import System.IO (hPrint)
|
||||
|
|
@ -65,6 +69,14 @@ pattern StringLike e <- (stringLike -> Just e)
|
|||
pattern StringLikeList :: forall {c} . [String] -> [Syntax c]
|
||||
pattern StringLikeList e <- (stringLikeList -> e)
|
||||
|
||||
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
|
||||
|
||||
stringLike :: Syntax c -> Maybe String
|
||||
stringLike = \case
|
||||
LitStrVal s -> Just $ Text.unpack s
|
||||
|
|
@ -99,6 +111,10 @@ instance Exception NotLambda
|
|||
|
||||
data BadFormException c = BadFormException (Syntax c)
|
||||
|
||||
newtype TypeCheckError c = TypeCheckError (Syntax c)
|
||||
|
||||
instance Exception (TypeCheckError C)
|
||||
|
||||
newtype BadValueException = BadValueException String
|
||||
deriving stock Show
|
||||
deriving newtype (Generic,Typeable)
|
||||
|
|
@ -108,6 +124,9 @@ instance Exception NameNotBoundException
|
|||
instance IsContext c => Show (BadFormException c) where
|
||||
show (BadFormException sy) = show $ "BadFormException" <+> pretty sy
|
||||
|
||||
instance IsContext c => Show (TypeCheckError c) where
|
||||
show (TypeCheckError sy) = show $ "TypeCheckError" <+> pretty sy
|
||||
|
||||
instance Exception (BadFormException C)
|
||||
|
||||
instance Exception BadValueException
|
||||
|
|
@ -137,27 +156,32 @@ splitForms s0 = runIdentity $ S.toList_ (go mempty s0)
|
|||
|
||||
emit = S.yield . reverse
|
||||
|
||||
|
||||
run :: forall c m . ( IsContext c
|
||||
apply :: 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 runExpr sy)) tvd
|
||||
where
|
||||
runExpr :: Syntax c -> RunM c m (Syntax c)
|
||||
)
|
||||
=> Id
|
||||
-> [Syntax c]
|
||||
-> RunM c m (Syntax c)
|
||||
apply name args' = do
|
||||
what <- ask >>= readTVarIO <&> HM.lookup name . fromDict
|
||||
case bindAction <$> what of
|
||||
Just (BindLambda e) -> mapM runExpr args' >>= e
|
||||
Just (BindValue v) -> throwIO (NotLambda name)
|
||||
Nothing -> throwIO (NameNotBound name)
|
||||
|
||||
|
||||
runExpr :: forall c m . ( IsContext c
|
||||
, MonadUnliftIO m
|
||||
, Exception (BadFormException c)
|
||||
) => Syntax c -> RunM c m (Syntax c)
|
||||
runExpr syn = handle (handleForm syn) $ case syn of
|
||||
|
||||
ListVal [ w, SymbolVal ".", b] -> do
|
||||
pure $ mkList [w, b]
|
||||
|
||||
ListVal (SymbolVal name : args') -> do
|
||||
what <- ask >>= readTVarIO <&> HM.lookup name . fromDict
|
||||
case bindAction <$> what of
|
||||
Just (BindLambda e) -> mapM runExpr args' >>= e
|
||||
Just (BindValue v) -> throwIO (NotLambda name)
|
||||
Nothing -> throwIO (NameNotBound name)
|
||||
apply name args'
|
||||
|
||||
SymbolVal (Id s) | Text.isPrefixOf ":" s -> do
|
||||
pure (mkSym @c (Text.drop 1 s))
|
||||
|
|
@ -169,13 +193,23 @@ run d sy = do
|
|||
|
||||
case what of
|
||||
BindValue e -> pure e
|
||||
BindLambda e -> pure $ mkForm "lambda" [mkSym "..."]
|
||||
BindLambda e -> pure $ mkForm "lambda" [mkSym name, mkSym "..."]
|
||||
|
||||
e -> pure e
|
||||
|
||||
handleForm syn (BadFormException _ :: BadFormException c) = do
|
||||
where
|
||||
handleForm syn = \case
|
||||
(BadFormException _ :: BadFormException c) -> do
|
||||
throwIO (BadFormException syn)
|
||||
|
||||
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 runExpr sy)) tvd
|
||||
|
||||
bindMatch :: Id -> ([Syntax c] -> RunM c m (Syntax c)) -> Dict c m
|
||||
bindMatch n fn = Dict (HM.singleton n (Bind (BindLambda fn) n ""))
|
||||
|
||||
|
|
@ -195,7 +229,7 @@ bind name expr = do
|
|||
|
||||
setupLogger :: MonadIO m => m ()
|
||||
setupLogger = do
|
||||
setLogging @DEBUG $ toStderr . logPrefix "[debug] "
|
||||
-- setLogging @DEBUG $ toStderr . logPrefix "[debug] "
|
||||
setLogging @ERROR $ toStderr . logPrefix "[error] "
|
||||
setLogging @WARN $ toStderr . logPrefix "[warn] "
|
||||
setLogging @NOTICE $ toStdout . logPrefix ""
|
||||
|
|
@ -278,6 +312,53 @@ mkRefLogUpdateFrom mbs reflog = do
|
|||
pure $ mkForm "cbor:base58" [ mkStr s ]
|
||||
|
||||
|
||||
metaFromSyntax :: [Syntax c] -> HashMap Text Text
|
||||
metaFromSyntax syn =
|
||||
HM.fromList [ (t k, t v) | (ListVal [ k, v ]) <- syn ]
|
||||
where
|
||||
t x = Text.pack (show $ pretty x)
|
||||
|
||||
createTreeWithMetadata :: (MonadUnliftIO m)
|
||||
=> HashMap Text Text
|
||||
-> LBS.ByteString
|
||||
-> m HashRef
|
||||
createTreeWithMetadata meta lbs = do
|
||||
debug "create fucking metadata"
|
||||
-- TODO: set-hbs2-peer
|
||||
so <- detectRPC `orDie` "hbs2-peer not found"
|
||||
|
||||
let mt = vcat [ pretty k <> ":" <+> pretty v | (k,v) <- HM.toList meta ]
|
||||
& show & Text.pack
|
||||
|
||||
withRPC2 @StorageAPI @UNIX so $ \caller -> do
|
||||
let sto = AnyStorage (StorageClient caller)
|
||||
|
||||
t0 <- writeAsMerkle sto lbs
|
||||
>>= getBlock sto
|
||||
>>= orThrowUser "can't read merkle tree just written"
|
||||
<&> deserialiseOrFail @(MTree [HashRef])
|
||||
>>= orThrowUser "merkle tree corrupted/invalid"
|
||||
|
||||
-- FIXME: support-encryption
|
||||
let mann = MTreeAnn (ShortMetadata mt) NullEncryption t0
|
||||
|
||||
putBlock sto (serialise mann)
|
||||
>>= orThrowUser "can't write tree"
|
||||
<&> HashRef
|
||||
|
||||
|
||||
helpList :: MonadUnliftIO m => Maybe String -> RunM c m ()
|
||||
helpList p = do
|
||||
|
||||
let match = maybe (const True) (Text.isPrefixOf . Text.pack) p
|
||||
|
||||
d <- ask >>= readTVarIO <&> fromDict
|
||||
let ks = [k | Id k <- List.sort (HM.keys d)
|
||||
, match k
|
||||
]
|
||||
|
||||
display_ $ vcat (fmap pretty ks)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
|
||||
|
|
@ -288,29 +369,60 @@ main = do
|
|||
|
||||
let dict = execWriter do
|
||||
|
||||
tell $ bindMatch "help" $ nil_ \case
|
||||
[] -> do
|
||||
d <- ask >>= readTVarIO <&> fromDict
|
||||
let ks = List.sort (HM.keys d)
|
||||
display_ $ vcat (fmap pretty ks)
|
||||
tell $ bindMatch "help" $ nil_ $ \syn -> do
|
||||
|
||||
_ -> pure ()
|
||||
display_ $ "hbs2-cli tool" <> line
|
||||
|
||||
tell $ bindMatch "concat" $ \case
|
||||
StringLikeList xs@(_:_) -> do
|
||||
case syn of
|
||||
(StringLike p : _) -> do
|
||||
helpList (Just p)
|
||||
|
||||
[ListVal (SymbolVal "lambda" : SymbolVal what : _ )] -> do
|
||||
liftIO $ hPutDoc stdout $
|
||||
"function" <+> ul (pretty what)
|
||||
<> line
|
||||
|
||||
_ -> helpList Nothing
|
||||
|
||||
|
||||
tell $ bindMatch "concat" $ \syn -> do
|
||||
|
||||
case syn of
|
||||
[ListVal (StringLikeList xs)] -> do
|
||||
pure $ mkStr @C ( mconcat xs )
|
||||
|
||||
StringLikeList xs -> do
|
||||
pure $ mkStr ( mconcat xs )
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
tell $ bindMatch "list" $ \case
|
||||
es -> do
|
||||
pure $ mkList es
|
||||
pure $ mkList @C es
|
||||
|
||||
tell $ bindMatch "dict" $ \case
|
||||
es -> do
|
||||
pure $ mkForm "dict" es
|
||||
|
||||
-- _ -> pure nil
|
||||
|
||||
tell $ bindMatch "map" $ \syn -> do
|
||||
case syn of
|
||||
[ListVal (SymbolVal "lambda" : SymbolVal fn : _), ListVal rs] -> do
|
||||
mapM (apply fn . List.singleton) rs
|
||||
<&> mkList
|
||||
|
||||
w -> do
|
||||
throwIO (BadFormException @C nil)
|
||||
|
||||
tell $ bindMatch "head" $ \case
|
||||
[ ListVal es ] -> pure (head es)
|
||||
_ -> throwIO (TypeCheckError @C nil)
|
||||
|
||||
tell $ bindMatch "tail" $ \case
|
||||
[] -> pure nil
|
||||
[ListVal []] -> pure nil
|
||||
[ListVal es] -> pure $ mkList @C (tail es)
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
tell $ bindMatch "lookup" $ \case
|
||||
[s, ListVal (SymbolVal "dict" : es) ] -> do
|
||||
|
|
@ -326,7 +438,7 @@ main = do
|
|||
[ sy ] -> display sy
|
||||
ss -> display (mkList ss)
|
||||
|
||||
tell $ bindMatch "internal:show-cli" $ nil_ \case
|
||||
tell $ bindMatch "debug:show-cli" $ nil_ \case
|
||||
_ -> display cli
|
||||
|
||||
tell $ bindMatch "hbs2:peer:detect" $ nil_ \case
|
||||
|
|
@ -349,6 +461,34 @@ main = do
|
|||
|
||||
readTVarIO r
|
||||
|
||||
tell $ bindMatch "hbs2:keyring:list-encryption" $ \syn -> do
|
||||
lbs <- case syn of
|
||||
|
||||
[ ListVal [ SymbolVal "file", StringLike fn ] ] -> do
|
||||
liftIO $ BS.readFile fn
|
||||
|
||||
[ LitStrVal s ] -> do
|
||||
pure (BS8.pack (Text.unpack s))
|
||||
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
cred <- pure (parseCredentials @'HBS2Basic (AsCredFile lbs))
|
||||
`orDie` "bad keyring file"
|
||||
|
||||
let e = [ mkStr @C (show (pretty (AsBase58 p))) | KeyringEntry p _ _ <- view peerKeyring cred ]
|
||||
|
||||
pure $ mkList @C e
|
||||
|
||||
tell $ bindMatch "hbs2:keyring:new" $ \syn -> do
|
||||
n <- case syn of
|
||||
[LitIntVal k] -> pure k
|
||||
[] -> pure 1
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
cred0 <- newCredentials @'HBS2Basic
|
||||
cred <- foldM (\cred _ -> addKeyPair Nothing cred) cred0 [1..n]
|
||||
pure $ mkStr @C $ show $ pretty $ AsCredFile $ AsBase58 cred
|
||||
|
||||
tell $ bindMatch "hbs2:keyman:list" $ nil_ \case
|
||||
_ -> do
|
||||
void $ runKeymanClient $ KeyManClient $ do
|
||||
|
|
@ -369,19 +509,79 @@ main = do
|
|||
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
tell $ bindMatch "hbs2:tree:metadata:create" $ \case
|
||||
(LitStrVal s : _) -> do
|
||||
debug "create fucking metadata"
|
||||
tell $ bindMatch "str:read-file" $ \case
|
||||
[StringLike fn] -> liftIO (readFile fn) <&> mkStr @C
|
||||
|
||||
-- TODO: set-hbs2-peer
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
tell $ bindMatch "str:save" $ nil_ \case
|
||||
[StringLike fn, StringLike what] ->
|
||||
liftIO (writeFile fn what)
|
||||
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
|
||||
tell $ bindMatch "hbs2:tree:metadata:get" $ \case
|
||||
[ SymbolVal how, StringLike hash ] -> do
|
||||
|
||||
-- FIXME: put-to-the-state
|
||||
so <- detectRPC `orDie` "hbs2-peer not found"
|
||||
withRPC2 @StorageAPI @UNIX so $ \caller -> do
|
||||
let sto = AnyStorage (StorageClient caller)
|
||||
let lbs = fromString (Text.unpack s) :: LBS.ByteString
|
||||
root <- liftIO $ writeAsMerkle sto lbs
|
||||
display root
|
||||
|
||||
pure nil
|
||||
r <- withRPC2 @StorageAPI @UNIX so $ \caller -> do
|
||||
let sto = AnyStorage (StorageClient caller)
|
||||
|
||||
runMaybeT do
|
||||
|
||||
headBlock <- getBlock sto (fromString hash)
|
||||
>>= toMPlus
|
||||
<&> deserialiseOrFail @(MTreeAnn [HashRef])
|
||||
>>= toMPlus
|
||||
|
||||
case headBlock of
|
||||
MTreeAnn { _mtaMeta = ShortMetadata s } -> do
|
||||
pure $ mkStr @C s
|
||||
|
||||
MTreeAnn { _mtaMeta = AnnHashRef h } -> do
|
||||
getBlock sto h
|
||||
>>= toMPlus
|
||||
<&> LBS.toStrict
|
||||
<&> TE.decodeUtf8
|
||||
<&> mkStr @C
|
||||
|
||||
_ -> mzero
|
||||
|
||||
|
||||
case (how, r) of
|
||||
("parsed", Just (LitStrVal r0)) -> do
|
||||
|
||||
|
||||
let xs = parseTop r0
|
||||
& fromRight mempty
|
||||
|
||||
pure $ mkForm @C "dict" xs
|
||||
|
||||
_ -> pure $ fromMaybe nil r
|
||||
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
tell $ bindMatch "hbs2:tree:metadata:create" $ \syn -> do
|
||||
|
||||
case syn of
|
||||
|
||||
(LitStrVal s : meta) -> do
|
||||
let lbs = fromString (Text.unpack s) :: LBS.ByteString
|
||||
h <- createTreeWithMetadata (metaFromSyntax meta) lbs
|
||||
pure $ mkStr (show $ pretty h)
|
||||
|
||||
(ListVal [SymbolVal "from-file", StringLike fn ] : meta) -> do
|
||||
lbs <- liftIO $ LBS.readFile fn
|
||||
h <- createTreeWithMetadata (metaFromSyntax meta) lbs
|
||||
pure $ mkStr (show $ pretty h)
|
||||
|
||||
(ListVal [SymbolVal "from-stdin"] : meta) -> do
|
||||
lbs <- liftIO $ LBS.getContents
|
||||
h <- createTreeWithMetadata (metaFromSyntax meta) lbs
|
||||
pure $ mkStr (show $ pretty h)
|
||||
|
||||
_ -> throwIO (BadFormException @C nil)
|
||||
|
||||
|
|
@ -398,6 +598,9 @@ main = do
|
|||
>>= either (error.show) pure . parseTop
|
||||
void $ run dict what
|
||||
|
||||
[] -> do
|
||||
void $ run dict [mkForm "help" []]
|
||||
|
||||
_ -> do
|
||||
void $ run dict cli
|
||||
|
||||
|
|
|
|||
|
|
@ -19,13 +19,13 @@ import Data.Kind
|
|||
import Control.Monad.Reader
|
||||
import UnliftIO
|
||||
|
||||
withRPC2 :: forall (api :: [Type]) e m . ( e ~ UNIX
|
||||
withRPC2 :: forall (api :: [Type]) e m r . ( e ~ UNIX
|
||||
, HasProtocol e (ServiceProto api e)
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> FilePath
|
||||
-> ( ServiceCaller api e -> m () )
|
||||
-> m ()
|
||||
-> ( ServiceCaller api e -> m r )
|
||||
-> m r
|
||||
|
||||
withRPC2 soname action = do
|
||||
|
||||
|
|
@ -39,10 +39,13 @@ withRPC2 soname action = do
|
|||
caller <- makeServiceCaller @api @UNIX (fromString soname)
|
||||
p2 <- liftIO $ async $ runReaderT (runServiceClient @api @e caller) client1
|
||||
|
||||
action caller
|
||||
r <- action caller
|
||||
|
||||
pause @'Seconds 0.05
|
||||
cancel p2
|
||||
|
||||
void $ waitAnyCatchCancel [m1, p2]
|
||||
|
||||
pure r
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -56,6 +56,7 @@ import Data.Either
|
|||
import Data.List qualified as List
|
||||
import Data.Maybe
|
||||
import Data.Text qualified as Text
|
||||
import Data.Text.IO qualified as TIO
|
||||
import Lens.Micro.Platform
|
||||
import Options.Applicative
|
||||
import Streaming.Prelude qualified as S
|
||||
|
|
@ -578,6 +579,9 @@ main = join . customExecParser (prefs showHelpOnError) $
|
|||
void $ runMaybeT do
|
||||
bs <- getBlock sto h >>= toMPlus
|
||||
case tryDetect h bs of
|
||||
MerkleAnn (MTreeAnn { _mtaMeta = ShortMetadata s } ) -> do
|
||||
liftIO $ TIO.putStr s
|
||||
|
||||
MerkleAnn (MTreeAnn { _mtaMeta = AnnHashRef mh } ) -> do
|
||||
|
||||
bs <- getBlock sto mh
|
||||
|
|
|
|||
Loading…
Reference in New Issue