hbs2/hbs2-cli/lib/HBS2/CLI/Run/MetaData.hs

{-# Language MultiWayIf #-}

module HBS2.CLI.Run.MetaData (metaDataEntries) where

import HBS2.CLI.Prelude
import HBS2.CLI.Run.Internal

import HBS2.Data.Types.Refs
import HBS2.Merkle
import HBS2.System.Logger.Simple.ANSI as All
import HBS2.System.Dir
import HBS2.Storage
import HBS2.Storage.Operations.ByteString
import HBS2.Peer.CLI.Detect
import HBS2.Peer.RPC.Client.Unix
import HBS2.Peer.RPC.API.Storage
import HBS2.Peer.RPC.Client.StorageClient

import HBS2.Net.Auth.Schema()

import Codec.Serialise
import Control.Monad.Trans.Maybe
import Data.ByteString.Lazy qualified as LBS
import Data.Either
import Data.Set qualified as Set
import Data.HashMap.Strict qualified as HM
import Data.Maybe
import Data.Text.Encoding qualified as TE
import Data.Text qualified as Text

import Magic.Data
import Magic.Init       (magicLoadDefault,magicOpen)
import Magic.Operations (magicFile)

{- HLINT ignore "Functor law" -}

data CreateMetaDataOpt =
    Auto
  | Stdin
  | Encrypted String
  | MetaDataEntry Id String
  | MetaDataFile FilePath
  deriving stock (Eq,Ord,Show,Data,Generic)

txt :: Pretty  a => a -> Text
txt a = Text.pack (show $ pretty a)

metaFromSyntax :: [Syntax c] -> HashMap Text Text
metaFromSyntax syn =
  HM.fromList [ (t k, t v) | (ListVal [ k, v ]) <- syn ]
  where
    t x = Text.pack (show $ pretty x)

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 <> ":" <+> dquotes (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


metaDataEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m) => MakeDictM c m ()
metaDataEntries = do

  entry $ bindMatch "hbs2:tree:metadata:get" $ \case
    [ SymbolVal how, StringLike hash ] -> do

      -- FIXME: put-to-the-state
      so <- detectRPC `orDie` "hbs2-peer not found"

      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 s

            MTreeAnn { _mtaMeta = AnnHashRef h } -> do
              getBlock sto h
                 >>= toMPlus
                 <&> LBS.toStrict
                 <&> TE.decodeUtf8
                 <&> mkStr

            _ -> mzero

      case (how, r) of
        ("parsed", Just (LitStrVal r0)) -> do


          let xs = parseTop r0
                     & fromRight mempty

          pure $ mkForm  "dict" xs

        _ -> pure $ fromMaybe nil r

    _ -> throwIO (BadFormException @c nil)

  entry $ bindMatch "hbs2:tree:metadata:create" $ \syn -> do

    case syn of

      args -> do
        opts' <- for args $ \case
          SymbolVal "stdin"     -> pure [Stdin]

          SymbolVal "auto"      -> pure [Auto]

          ListVal (SymbolVal "dict" : [ListVal [SymbolVal "encrypted", StringLike key]])
            -> pure [Encrypted key]

          ListVal (SymbolVal "dict" : [ListVal [SymbolVal x, StringLike y]])  -> do
            pure [MetaDataEntry x y]

          StringLike rest  -> do
            pure [MetaDataFile rest]

          _ -> pure mempty

        let opts = mconcat opts' & Set.fromList
        let inFile = headMay [ x | MetaDataFile x <- universeBi opts ]

        lbs <- case (Set.member Stdin opts, inFile) of
                 (True, _) -> liftIO LBS.getContents
                 (False, Just fn) -> liftIO (LBS.readFile fn)
                 (_, Nothing) -> liftIO LBS.getContents

        meta0 <- if not (Set.member Auto opts) || isNothing inFile then
                   pure (mempty :: HashMap Text Text)
                 else liftIO do
                    let fn = fromJust inFile
                    magic <- magicOpen [MagicMimeType,MagicMime,MagicMimeEncoding]
                    magicLoadDefault magic
                    mime <- magicFile magic fn
                    pure $ HM.fromList [ ("file-name", Text.pack (takeFileName fn))
                                       , ("mime-type", Text.pack mime)
                                       ]

        let meta1  = HM.fromList [  (txt n, txt e) | MetaDataEntry n e <- universeBi opts ]

        href <- createTreeWithMetadata (meta0 <> meta1) lbs

        pure $ mkStr (show $ pretty href)

  entry $ bindMatch "cbor:base58" $ \case
    [ LitStrVal x ] -> do
      pure $ mkForm "cbor:base58" [mkStr x]

    _ -> throwIO (BadFormException @c nil)