diff --git a/flake.nix b/flake.nix index 40633486..bf04e032 100644 --- a/flake.nix +++ b/flake.nix @@ -103,6 +103,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs: hoogle htags text-icu + magic pkgs.icu72 pkgs.openssl weeder diff --git a/hbs2/Main.hs b/hbs2/Main.hs index 50a66cde..3b2586ac 100644 --- a/hbs2/Main.hs +++ b/hbs2/Main.hs @@ -22,11 +22,12 @@ import HBS2.Storage.Simple.Extra import HBS2.Data.Bundle import HBS2.OrDie import HBS2.Version +import HBS2.Misc.PrettyStuff import Paths_hbs2 qualified as Pkg import HBS2.KeyMan.Keys.Direct -import HBS2.System.Logger.Simple hiding (info) +import HBS2.System.Logger.Simple.ANSI hiding (info) import Data.Config.Suckless @@ -36,11 +37,13 @@ import Control.Monad import Control.Monad.Except import Control.Monad.Trans.Maybe import Control.Monad.Trans.Resource +import Control.Monad.Trans.Cont import Crypto.Saltine.Core.Box qualified as Encrypt import Data.Aeson qualified as Aeson import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Lazy (ByteString) import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Lazy.Char8 qualified as LBS8 import Data.ByteString qualified as BS import Data.ByteArray.Hash (SipHash(..), SipKey(..)) import Data.ByteArray.Hash qualified as BA @@ -54,9 +57,15 @@ import Options.Applicative import Streaming.Prelude qualified as S import Streaming.ByteString qualified as SB import System.Directory +import System.FilePath import System.Exit qualified as Exit import System.IO qualified as IO import System.IO.Temp (emptySystemTempFile) + +import Magic.Data +import Magic.Init (magicLoadDefault,magicOpen) +import Magic.Operations (magicFile) + import UnliftIO tracePrefix :: SetLoggerEntry @@ -75,6 +84,9 @@ noticePrefix :: SetLoggerEntry noticePrefix = logPrefix "[notice] " . toStderr +data MetadataMethod = MetaDataAuto FilePath + deriving stock (Eq,Generic,Show) + newtype CommonOpts = CommonOpts { _coPref :: Maybe StoragePrefix @@ -221,6 +233,11 @@ runCat opts ss = do Left hx -> err $ "missed block" <+> pretty hx Right hr -> print $ vcat (fmap pretty hr) + MerkleAnn (MTreeAnn {_mtaCrypt = NullEncryption }) -> do + bs <- runExceptT (readFromMerkle (AnyStorage ss) (SimpleKey mhash)) + >>= orThrowUser "can't read/decode tree" + LBS.putStr bs + MerkleAnn ann@(MTreeAnn {_mtaCrypt = EncryptGroupNaClSymm gkh _}) -> do keyring <- case uniLastMay @OptKeyringFile opts of Just krf -> do @@ -310,38 +327,7 @@ runStore opts ss = runResourceT do Nothing -> die "unknown or invalid group key" Just (EncSymm gk) -> do - pk <- unOptEncPk <$> pure (uniLastMay @OptEncPubKey opts) `orDie` "public key not specified" - krf <- pure (uniLastMay @OptKeyringFile opts) `orDie` "keyring file not set" - - s <- liftIO $ BS.readFile (unOptKeyringFile krf) - cred <- pure (parseCredentials @HBS2Basic (AsCredFile s)) `orDie` "bad keyring file" - - sk <- pure (headMay [ (view krPk k, view krSk k) - | k <- view peerKeyring cred - , view krPk k == pk - ]) `orDie` "secret key not found" - - gks <- pure (Symm.lookupGroupKey (snd sk) pk gk) `orDie` ("can't find secret key for " <> show (pretty (AsBase58 (fst sk)))) - - void $ liftIO $ IO.withFile inputFile IO.ReadMode $ \fh -> do - let reader = readChunked fh (fromIntegral defBlockSize) - qqq <- S.toList_ $ reader - & S.map (BA.sipHash (SipKey 2716310006254639645 507093936407764973) . LBS.toStrict) - & S.map \(SipHash w) -> w - - let (HbSyncHash nonce) = hashObject @HbSync (serialise qqq) - - IO.hSeek fh IO.AbsoluteSeek 0 - - let segments = readChunked fh (fromIntegral defBlockSize) - - let source = ToEncryptSymmBS gks (Right gk) nonce segments NoMetaData Nothing - - r <- runExceptT $ writeAsMerkle ss source - - case r of - Left e -> die (show e) - Right h -> hPrint stdout (pretty h) + die "symmetric group keys are deprecated" Just (EncAsymm gk) -> liftIO $ IO.withFile inputFile IO.ReadMode $ \ha -> do @@ -487,6 +473,7 @@ main = join . customExecParser (prefs showHelpOnError) $ parser :: Parser (IO ()) parser = hsubparser ( command "store" (info pStore (progDesc "store block")) <> command "cat" (info pCat (progDesc "cat block")) + <> command "metadata" (info pMetadata (progDesc "tree metadata manipulation")) <> command "hash" (info pHash (progDesc "calculates hash")) <> command "fsck" (info pFsck (progDesc "check storage constistency")) <> command "deps" (info pDeps (progDesc "print dependencies")) @@ -535,6 +522,78 @@ main = join . customExecParser (prefs showHelpOnError) $ pure $ withStore o $ runCat $ CatOpts hash (CatHashesOnly <$> onlyh) (OptKeyringFile <$> keyringFile) raw + pMetadata = hsubparser ( command "dump" (info pMetadataDump (progDesc "dump metadata")) + <> command "create" (info pMetadataCreate (progDesc "create tree with metadata")) + ) + + pMetadataDump = do + o <- common + h <- argument (maybeReader (fromStringMay @HashRef)) (metavar "HASH") <&> fromHashRef + pure $ flip runContT pure do + sto <- ContT (withStore o) + + void $ runMaybeT do + bs <- getBlock sto h >>= toMPlus + case tryDetect h bs of + MerkleAnn (MTreeAnn { _mtaMeta = AnnHashRef mh } ) -> do + + bs <- getBlock sto mh + `orDie` "cant' read metadata" + + liftIO $ LBS.putStr bs + + _ -> exitFailure + + pMetadataCreate = do + o <- common + how <- MetaDataAuto <$> strOption ( long "auto" <> metavar "FILENAME" <> help "automatic metadata from file name") + dry <- flag False True (long "dry" <> short 'n' <> help "don't write to storage") + + pure $ flip runContT pure do + + sto <- ContT $ withStore o + + void $ runMaybeT do + + case how of + MetaDataAuto fn -> do + + meta <- liftIO do + magic <- magicOpen [MagicMimeType,MagicMime,MagicMimeEncoding] + magicLoadDefault magic + mime <- magicFile magic fn + + pure [ "file-name:" <+> pretty (takeFileName fn) + , "mime-type:" <+> pretty mime + ] + + let s = LBS8.pack $ show $ vcat meta + + liftIO $ LBS8.putStr s + + guard (not dry) + + mth <- putBlock sto s >>= toMPlus + + bs <- liftIO $ LBS.readFile fn + + root <- writeAsMerkle sto bs + + mt <- getBlock sto root `orDie` "can't read merkle tree just written" + <&> deserialiseOrFail @(MTree [HashRef]) + >>= orThrowUser "corrupted merkle tree -- should never happen" + + delBlock sto root + + let mtann = MTreeAnn (AnnHashRef mth) NullEncryption mt + + hnew <- putBlock sto (serialise mtann) + `orDie` "can't write merkle tree" + + liftIO $ putStrLn "" + liftIO $ putStrLn "" + liftIO $ print $ pretty hnew + pGroupKey = pGroupKeySymm pGroupKeySymm = hsubparser ( command "gen" (info pGroupKeySymmGen (progDesc "generate") ) diff --git a/hbs2/hbs2.cabal b/hbs2/hbs2.cabal index 99124598..10545c31 100644 --- a/hbs2/hbs2.cabal +++ b/hbs2/hbs2.cabal @@ -79,6 +79,7 @@ executable hbs2 , filepath , hashable , interpolatedstring-perl6 + , magic , memory , microlens-platform , mtl