mirror of https://github.com/voidlizard/hbs2
136 lines
4.3 KiB
Haskell
136 lines
4.3 KiB
Haskell
{-# OPTIONS_GHC -Wno-name-shadowing #-}
|
|
module HBS2.CLI.Run.Sigil where
|
|
|
|
import HBS2.CLI.Prelude
|
|
import HBS2.CLI.Run.Internal
|
|
|
|
import HBS2.Data.Types.Refs
|
|
import HBS2.Base58
|
|
import HBS2.Storage
|
|
import HBS2.Data.Types.SignedBox
|
|
import HBS2.Net.Auth.Credentials
|
|
import HBS2.Net.Auth.Credentials.Sigil
|
|
|
|
import Data.List qualified as L
|
|
import Data.ByteString.Char8 qualified as BS8
|
|
import Data.ByteString.Lazy qualified as LBS
|
|
import Lens.Micro.Platform
|
|
|
|
|
|
sigilEntries :: forall c m . (c ~ C, IsContext c, MonadUnliftIO m, HasStorage m)
|
|
=> MakeDictM c m ()
|
|
sigilEntries = do
|
|
|
|
entry $ bindMatch "hbs2:sigil:sign-pubkey" $ \case
|
|
[ ListVal (SymbolVal sigil : (hasKey "sign-pubkey" -> Just s)) ] -> do
|
|
pure s
|
|
|
|
_ -> throwIO $ BadFormException @C nil
|
|
|
|
|
|
entry $ bindMatch "hbs2:sigil:encrypt-pubkey" $ \case
|
|
[ ListVal (SymbolVal sigil : (hasKey "encrypt-pubkey" -> Just s)) ] -> do
|
|
pure s
|
|
|
|
_ -> throwIO $ BadFormException @C nil
|
|
|
|
brief "parses sigil"
|
|
$ args [ arg "sigil" "string" ]
|
|
$ examples [qc|hbs2:sigil:parse [str:read-file some.sigil]|]
|
|
$ entry $ bindMatch "hbs2:sigil:parse" $ \case
|
|
[StringLike s] -> do
|
|
|
|
let bs = BS8.pack s
|
|
sigil <- pure (parseSerialisableFromBase58 @(Sigil 'HBS2Basic) bs)
|
|
`orDie` "parse sigil failed"
|
|
|
|
(_,sd) <- pure (unboxSignedBox0 @(SigilData 'HBS2Basic) (sigilData sigil))
|
|
`orDie` "signature check failed"
|
|
|
|
pure (parseTop $ show $ parens ("sigil" <> line <> indent 2 (vcat $ [pretty sigil, pretty sd])))
|
|
`orDie` "bad sigil"
|
|
<&> head
|
|
|
|
_ -> throwIO $ BadFormException @C nil
|
|
|
|
|
|
brief "loads sigil from hbs2 store as base58 string"
|
|
$ args [arg "hash" "string" ]
|
|
$ returns "sigil" "string"
|
|
$ entry $ bindMatch "hbs2:sigil:load:base58" $ \case
|
|
[HashLike key] -> lift do
|
|
sto <- getStorage
|
|
r <- loadSigil @HBS2Basic sto key >>= orThrowUser "no sigil found"
|
|
pure $ mkStr @c ( show $ pretty $ AsBase58 r )
|
|
|
|
_ -> throwIO $ BadFormException @c nil
|
|
|
|
brief "stores sigil to hbs2 store"
|
|
$ args [arg "string" "file" ]
|
|
$ returns "string" "hash"
|
|
$ entry $ bindMatch "hbs2:sigil:store:file" $ \case
|
|
[StringLike fn] -> lift do
|
|
sto <- getStorage
|
|
lbs <- liftIO (LBS.readFile fn)
|
|
sigil <- decodeSigil @HBS2Basic lbs & orThrowUser "invalid sigil file"
|
|
href <- storeSigil sto sigil
|
|
pure $ mkStr ( show $ pretty href )
|
|
|
|
_ -> throwIO $ BadFormException @c nil
|
|
|
|
|
|
brief "create sigil from keyring" $
|
|
desc [qc|
|
|
|
|
;; creates from keyring, uses first encryption key if found
|
|
|
|
hbs2:sigil:create:from-keyring KEYRING-FILE
|
|
|
|
;; creates from keyring, uses n-th encryption key if found, N starts from 1
|
|
|
|
hbs2:sigil:create:from-keyring KEYRING-FILE N
|
|
|
|
;; creates from keyring, uses encryption key wit prefix S if found
|
|
|
|
hbs2:sigil:create:from-keyring KEYRING-FILE S
|
|
|
|
|]
|
|
$ entry $ bindMatch "hbs2:sigil:create:from-keyring" $ \syn -> do
|
|
|
|
let readKeyring fn = liftIO (BS8.readFile fn)
|
|
<&> parseCredentials @'HBS2Basic . AsCredFile
|
|
>>= orThrowUser "malformed keyring file"
|
|
|
|
|
|
(cred, KeyringEntry enc _ _) <- case syn of
|
|
[ StringLike fn ] -> do
|
|
s <- readKeyring fn
|
|
kr <- headMay (view peerKeyring s) & orThrowUser "encryption key missed"
|
|
pure (s,kr)
|
|
|
|
[ StringLike fn, LitIntVal n ] -> do
|
|
s <- readKeyring fn
|
|
kr <- headMay (drop (fromIntegral (max 0 (n-1))) (view peerKeyring s))
|
|
& orThrowUser "encryption key not found"
|
|
pure (s,kr)
|
|
|
|
[ StringLike fn, StringLike p ] -> do
|
|
|
|
s <- readKeyring fn
|
|
kr <- findKey p (view peerKeyring s) & orThrowUser "encryption key not found"
|
|
pure (s,kr)
|
|
|
|
_ -> throwIO $ BadFormException @c nil
|
|
|
|
sigil <- pure (makeSigilFromCredentials @'HBS2Basic cred enc Nothing Nothing)
|
|
`orDie` "can't create a sigil"
|
|
|
|
pure $ mkStr (show $ pretty $ AsBase58 sigil)
|
|
|
|
where
|
|
findKey s xs = headMay [ e
|
|
| e@(KeyringEntry k _ _) <- xs
|
|
, L.isPrefixOf s (show $ pretty (AsBase58 k))
|
|
]
|
|
|