basic key manager

flake.lock

@@ -1,8 +1,29 @@
 {
   "nodes": {
-    "fixme": {
+    "db-pipe": {
       "inputs": {
         "haskell-flake-utils": "haskell-flake-utils",
+        "nixpkgs": [
+          "nixpkgs"
+        ]
+      },
+      "locked": {
+        "lastModified": 1700834043,
+        "narHash": "sha256-VDExjkJ2maIP+Baw5V3fhmRtJ4nHpQV/Fxg1H8g69ME=",
+        "ref": "refs/heads/master",
+        "rev": "6050d7949f390c4717293d1d410123439e0fda67",
+        "revCount": 6,
+        "type": "git",
+        "url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"
+      },
+      "original": {
+        "type": "git",
+        "url": "https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft"
+      }
+    },
+    "fixme": {
+      "inputs": {
+        "haskell-flake-utils": "haskell-flake-utils_2",
         "nixpkgs": [
           "nixpkgs"
         ],
@@ -97,16 +118,31 @@
         "type": "github"
       }
     },
+    "flake-utils_6": {
+      "locked": {
+        "lastModified": 1644229661,
+        "narHash": "sha256-1YdnJAsNy69bpcjuoKdOYQX0YxZBiCYZo4Twxerqv7k=",
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "rev": "3cecb5b042f7f209c56ffd8371b2711a290ec797",
+        "type": "github"
+      },
+      "original": {
+        "owner": "numtide",
+        "repo": "flake-utils",
+        "type": "github"
+      }
+    },
     "haskell-flake-utils": {
       "inputs": {
         "flake-utils": "flake-utils"
       },
       "locked": {
-        "lastModified": 1672412555,
+        "lastModified": 1698938553,
-        "narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=",
+        "narHash": "sha256-oXpTKXioqFbl2mhhvpJIAvgNd+wYyv4ekI+YnJHEJ6s=",
         "owner": "ivanovs-4",
         "repo": "haskell-flake-utils",
-        "rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
+        "rev": "19b273b5dc401a0a565e7f75cf50a593871b80c9",
         "type": "github"
       },
       "original": {
@@ -147,7 +183,6 @@
       },
       "original": {
         "owner": "ivanovs-4",
-        "ref": "master",
         "repo": "haskell-flake-utils",
         "type": "github"
       }
@@ -166,8 +201,8 @@
       },
       "original": {
         "owner": "ivanovs-4",
+        "ref": "master",
         "repo": "haskell-flake-utils",
-        "rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
         "type": "github"
       }
     },
@@ -183,6 +218,25 @@
         "rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
         "type": "github"
       },
+      "original": {
+        "owner": "ivanovs-4",
+        "repo": "haskell-flake-utils",
+        "rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
+        "type": "github"
+      }
+    },
+    "haskell-flake-utils_6": {
+      "inputs": {
+        "flake-utils": "flake-utils_6"
+      },
+      "locked": {
+        "lastModified": 1672412555,
+        "narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=",
+        "owner": "ivanovs-4",
+        "repo": "haskell-flake-utils",
+        "rev": "896219e5bde6efac72198550454e9dd9b5ed9ac9",
+        "type": "github"
+      },
       "original": {
         "owner": "ivanovs-4",
         "repo": "haskell-flake-utils",
@@ -191,7 +245,7 @@
     },
     "hspup": {
       "inputs": {
-        "haskell-flake-utils": "haskell-flake-utils_4",
+        "haskell-flake-utils": "haskell-flake-utils_5",
         "nixpkgs": [
           "nixpkgs"
         ]
@@ -228,8 +282,9 @@
     },
     "root": {
       "inputs": {
+        "db-pipe": "db-pipe",
         "fixme": "fixme",
-        "haskell-flake-utils": "haskell-flake-utils_3",
+        "haskell-flake-utils": "haskell-flake-utils_4",
         "hspup": "hspup",
         "nixpkgs": "nixpkgs",
         "saltine": "saltine",
@@ -255,7 +310,7 @@
     },
     "suckless-conf": {
       "inputs": {
-        "haskell-flake-utils": "haskell-flake-utils_2",
+        "haskell-flake-utils": "haskell-flake-utils_3",
         "nixpkgs": [
           "fixme",
           "nixpkgs"
@@ -277,7 +332,7 @@
     },
     "suckless-conf_2": {
       "inputs": {
-        "haskell-flake-utils": "haskell-flake-utils_5",
+        "haskell-flake-utils": "haskell-flake-utils_6",
         "nixpkgs": [
           "nixpkgs"
         ]

flake.nix

@@ -15,6 +15,9 @@ inputs = {
     suckless-conf.url = "git+https://git.hbs2.net/JAuk1UJzZfbDGKVazSQU5yYQ3NGfk4gVeZzBCduf5TgQ";
     suckless-conf.inputs.nixpkgs.follows = "nixpkgs";
 
+    db-pipe.url = "git+https://git.hbs2.net/5xrwbTzzweS9yeJQnrrUY9gQJfhJf84pbyHhF2MMmSft";
+    db-pipe.inputs.nixpkgs.follows = "nixpkgs";
+
     saltine = {
       url = "github:tel/saltine/3d3a54cf46f78b71b4b55653482fb6f4cee6b77d";
       flake = false;
@@ -31,6 +34,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
 
    haskellFlakes = with inputs; [
      suckless-conf
+     db-pipe
    ];
 
    packageNames = [
@@ -40,6 +44,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
      "hbs2-storage-simple"
      "hbs2-git"
      "hbs2-qblf"
+     "hbs2-keyman"
    ];
 
    packageDirs = {
@@ -48,6 +53,7 @@ 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";
    };
 
    hpPreOverrides = {pkgs, ...}: final: prev: with pkgs; {
@@ -72,6 +78,7 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
    shellExtBuildInputs = {pkgs}: with pkgs;  [
      haskellPackages.haskell-language-server
      haskellPackages.htags
+     haskellPackages.hoogle
      pkg-config
      inputs.hspup.packages.${pkgs.system}.default
      inputs.fixme.packages.${pkgs.system}.default

hbs2-core/hbs2-core.cabal

@@ -80,6 +80,7 @@ library
                     , HBS2.Clock
                     , HBS2.Crypto
                     , HBS2.ScheduledAction
+                    , HBS2.Data.KeyRing
                     , HBS2.Data.Detect
                     , HBS2.Data.Types
                     , HBS2.Data.Types.Crypto
@@ -165,6 +166,7 @@ library
                     , fast-logger
                     , filelock
                     , filepath
+                    , filepattern
                     , exceptions
                     , generic-lens
                     , hashable

hbs2-core/lib/HBS2/Data/KeyRing.hs

@@ -0,0 +1,85 @@
+module HBS2.Data.KeyRing where
+
+import HBS2.Prelude
+import HBS2.Net.Proto.Types
+import HBS2.Net.Auth.Credentials
+
+import System.FilePattern.Directory
+import System.FilePath
+import System.Directory
+import Data.List as L
+import Data.Maybe
+import Data.ByteString.Lazy qualified as LBS
+import Data.ByteString qualified as BS
+import Lens.Micro.Platform
+import UnliftIO
+import Control.Monad.Trans.Maybe
+
+
+splitPattern :: FilePath -> (FilePath, FilePath)
+splitPattern fp = (pref, flt)
+  where
+    pref = joinPath pref'
+    flt = case flt' of
+      [] -> "*"
+      xs -> joinPath flt'
+    (pref', flt') = L.span isNotP (splitDirectories fp)
+    isNotP s = isNothing (find isP s)
+    isP c = c `elem` ("?*" :: [Char])
+
+findFilesBy :: MonadIO m => [FilePath] -> m [FilePath]
+findFilesBy fp = liftIO do
+  fs <- forConcurrently fp $ \p -> do
+    isF <- liftIO $ doesFileExist p
+    if isF then do
+      pure [p]
+    else do
+      let (dir, pat) = splitPattern p
+      fs <- liftIO $ getDirectoryFiles dir [pat]
+      pure $ fmap (dir </>) fs
+
+  pure $ nub $ mconcat fs
+
+findKeyRing :: forall s m . ( MonadUnliftIO m
+                            , SerialisedCredentials s
+                            , ForHBS2Basic s
+                            )
+            => [FilePattern]
+            -> PubKey 'Sign s
+            -> m [FilePath]
+
+findKeyRing fp kr = do
+
+  allFiles <- findFilesBy fp
+
+  kf <- forConcurrently allFiles $ \f -> do
+    bs <- liftIO $ BS.readFile f
+    let krf = parseCredentials @s (AsCredFile bs)
+    let sk = view peerSignPk <$> krf
+
+    if sk == Just kr then
+      pure (Just f)
+    else
+      pure Nothing
+
+  pure (catMaybes kf)
+
+findKeyRingEntry :: forall s m . ( MonadUnliftIO m
+                                 , SerialisedCredentials s
+                                 , ForHBS2Basic s
+                                 )
+                 => [FilePattern]
+                 -> PubKey 'Encrypt s
+                 -> m (Maybe (KeyringEntry s))
+
+findKeyRingEntry fp pk0 = do
+  fs <- findFilesBy fp
+
+  w <- for fs $ \f -> runMaybeT do
+    bs <- liftIO (try @_ @IOException (BS.readFile f))
+           >>= toMPlus
+    krf <- parseCredentials (AsCredFile bs) & toMPlus
+    MaybeT $ pure $ headMay [ e | e@(KeyringEntry pk _ _) <- _peerKeyring krf, pk == pk0 ]
+
+  pure $ headMay (catMaybes w)
+

hbs2-core/lib/HBS2/Net/Auth/Credentials.hs

@@ -3,7 +3,9 @@
 {-# Language UndecidableInstances #-}
 {-# Language AllowAmbiguousTypes #-}
 {-# Language ConstraintKinds #-}
-module HBS2.Net.Auth.Credentials where
+module HBS2.Net.Auth.Credentials
+  ( module HBS2.Net.Auth.Credentials
+  ) where
 
 import HBS2.Prelude.Plated
 import HBS2.Net.Proto.Types
@@ -18,7 +20,6 @@ import Crypto.Saltine.Class (IsEncoding)
 import Data.ByteString.Lazy.Char8 qualified as LBS
 import Data.ByteString.Char8 qualified as B8
 import Data.ByteString.Char8 (ByteString)
-import Data.Function
 import Data.List.Split (chunksOf)
 import Data.List qualified as List
 import Lens.Micro.Platform
@@ -72,6 +73,7 @@ type ForHBS2Basic s = ( Signatures s
                       , PrivKey 'Sign s ~ Sign.SecretKey
                       , PubKey 'Sign s ~ Sign.PublicKey
                       , IsEncoding (PubKey 'Encrypt s)
+                      , Eq (PubKey 'Encrypt HBS2Basic)
                       , s ~ HBS2Basic
                       )
 

hbs2-core/lib/HBS2/Net/Proto/Definition.hs

@@ -53,6 +53,8 @@ type instance PrivKey 'Sign HBS2Basic = Sign.SecretKey
 type instance PubKey  'Encrypt HBS2Basic = Encrypt.PublicKey
 type instance PrivKey 'Encrypt HBS2Basic = Encrypt.SecretKey
 
+type instance KeyActionOf Sign.PublicKey = 'Sign
+type instance KeyActionOf Encrypt.PublicKey = 'Encrypt
 
 -- FIXME: proper-serialise-for-keys
 --   Возможно, нужно написать ручные инстансы Serialise

hbs2-core/lib/HBS2/Net/Proto/Types.hs

@@ -42,6 +42,8 @@ type family PrivKey (a :: CryptoAction) e  :: Type
 
 type family Encryption e :: Type
 
+type family KeyActionOf k :: CryptoAction
+
 data family GroupKey (scheme :: GroupKeyScheme) s
 
 -- TODO: move-to-an-appropriate-place

hbs2-keyman/CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for hbs2-keyman
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

hbs2-keyman/LICENSE

@@ -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.

hbs2-keyman/app/Main.hs

@@ -0,0 +1,85 @@
+module Main where
+
+import HBS2.Prelude
+import HBS2.Net.Auth.Credentials
+
+import HBS2.KeyMan.App.Types
+import HBS2.KeyMan.Config
+import HBS2.KeyMan.State
+import HBS2.Data.KeyRing qualified as KeyRing
+
+import HBS2.System.Logger.Simple
+
+import Data.Config.Suckless.KeyValue
+
+
+import Options.Applicative qualified as O
+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
+import UnliftIO
+
+
+data GlobalOptions = GlobalOptions
+  {
+  }
+
+type Command m = m ()
+
+-- Парсер для глобальных опций
+globalOptions :: Parser GlobalOptions
+globalOptions = pure GlobalOptions
+
+type AppPerks m = (MonadIO m, MonadReader AppEnv m, HasConf m)
+
+-- Парсер для команд
+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" ))
+  )
+
+opts :: (AppPerks m) => ParserInfo (GlobalOptions, Command m)
+opts = O.info (liftA2 (,) globalOptions commands <**> helper)
+  ( fullDesc
+ -- <> progDesc "An application with global options and subcommands"
+ <> header "hbs2-keyman" )
+
+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
+  pure do
+    masks <- cfgValue @KeyFilesOpt @(Set String) <&> Set.toList
+    files <- KeyRing.findFilesBy masks
+
+    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
+
+main :: IO ()
+main = do
+  (_, action) <- execParser opts
+  runApp action
+
+

hbs2-keyman/hbs2-keyman.cabal

@@ -0,0 +1,123 @@
+cabal-version:      3.0
+name:               hbs2-keyman
+version:            0.1.0.0
+-- 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
+        , 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.Config
+      HBS2.KeyMan.State
+      HBS2.KeyMan.Keys
+      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
+
+    main-is:          Main.hs
+    -- other-modules:
+    -- other-extensions:
+    build-depends:
+        base,
+        hbs2-keyman,
+        optparse-applicative
+
+    hs-source-dirs:   app
+    default-language: GHC2021
+

hbs2-keyman/src/HBS2/KeyMan/App/Types.hs

@@ -0,0 +1,94 @@
+module HBS2.KeyMan.App.Types
+  ( module HBS2.KeyMan.App.Types
+  , module HBS2.Base58
+  , module HBS2.Net.Proto.Types
+  , module Lens.Micro.Platform
+  , module Prettyprinter
+  ) where
+
+import HBS2.Prelude
+import HBS2.Base58
+
+-- FIXME: remove-this
+import HBS2.Net.Proto.Definition ()
+import HBS2.Net.Proto.Types
+
+import HBS2.KeyMan.Config
+import HBS2.KeyMan.State
+
+import HBS2.System.Logger.Simple
+import Data.Config.Suckless
+import DBPipe.SQLite
+
+import Control.Monad.Cont
+import Control.Monad.Reader
+import Prettyprinter
+import Lens.Micro.Platform
+import UnliftIO
+
+data AppEnv =
+  AppEnv
+  { appConf :: [Syntax C]
+  , appDb   :: DBPipeEnv
+  }
+
+newtype KeyManCLI m a = KeyManCLI { fromKeyManCLI :: ReaderT AppEnv m a }
+                        deriving newtype
+                        ( Applicative
+                        , Functor
+                        , Monad
+                        , MonadIO
+                        , MonadUnliftIO
+                        , MonadReader AppEnv
+                        )
+
+newAppEnv :: MonadUnliftIO m => m AppEnv
+newAppEnv = do
+  let dbOpts = dbPipeOptsDef
+  AppEnv <$> readConfig
+         <*> (getStatePath >>= newDBPipeEnv dbOpts)
+
+runApp :: MonadUnliftIO m => KeyManCLI m () -> m ()
+runApp action = do
+  env <- liftIO newAppEnv
+  let db = appDb env
+
+  setLogging @INFO   defLog
+  setLogging @ERROR  (logPrefix "" . toStderr)
+  setLogging @WARN   (logPrefix "" . toStdout)
+  setLogging @NOTICE (logPrefix "" . toStdout)
+  setLogging @DEBUG  (logPrefix "" . toStderr)
+
+  setLoggingOff @TRACE
+
+  flip runContT pure $ do
+    void $ ContT $ bracket (async (runPipe db)) cancel
+    lift $ withAppEnv env do
+      withState populateState
+      action
+
+  setLoggingOff @INFO
+  setLoggingOff @ERROR
+  setLoggingOff @WARN
+  setLoggingOff @NOTICE
+
+
+withAppEnv :: MonadIO m => AppEnv -> KeyManCLI m a -> m a
+withAppEnv env action = do
+  runReaderT (fromKeyManCLI action) env
+
+withState :: (MonadReader AppEnv m, MonadIO m)
+          => DBPipeM m b
+          -> m b
+
+withState m = do
+  d <- asks appDb
+  withDB d m
+
+instance MonadIO m => HasConf (ReaderT AppEnv m) where
+  getConf = asks appConf
+
+instance MonadIO m => HasConf (KeyManCLI m) where
+  getConf = asks appConf
+
+

hbs2-keyman/src/HBS2/KeyMan/Config.hs

@@ -0,0 +1,43 @@
+module HBS2.KeyMan.Config
+  ( keymanAppName
+  , getConfigPath
+  , getStatePath
+  , readConfig
+  , KeyFilesOpt
+  , Set
+  ) where
+
+import HBS2.Prelude.Plated
+
+import Data.Config.Suckless
+
+import System.Directory
+import System.FilePath
+import Control.Exception
+import Data.Either
+import Data.Set (Set)
+
+
+data KeyFilesOpt
+
+keymanAppName :: FilePath
+keymanAppName = "hbs2-keyman"
+
+getConfigPath :: MonadIO m => m FilePath
+getConfigPath = liftIO (getXdgDirectory XdgConfig keymanAppName) <&> (</> "config")
+
+
+getStatePath :: MonadIO m => m FilePath
+getStatePath = liftIO (getXdgDirectory XdgData keymanAppName) <&> (</> "state.db")
+
+readConfig :: MonadIO m => m [Syntax C]
+readConfig = do
+ liftIO $ try @IOError (getConfigPath >>= readFile)
+  <&> fromRight ""
+  <&> parseTop
+  <&> fromRight mempty
+
+
+instance HasConf m => HasCfgKey KeyFilesOpt (Set String) m where
+  key = "key-files"
+

hbs2-keyman/src/HBS2/KeyMan/Keys.hs

@@ -0,0 +1,4 @@
+module HBS2.KeyMan.Keys where
+
+
+

hbs2-keyman/src/HBS2/KeyMan/Keys/Direct.hs

@@ -0,0 +1,73 @@
+module HBS2.KeyMan.Keys.Direct where
+
+import HBS2.Prelude.Plated
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Proto.Types
+
+import HBS2.KeyMan.App.Types
+import HBS2.KeyMan.State
+
+import Control.Monad.Cont
+import Control.Monad.Reader
+import Control.Monad.Except
+import UnliftIO
+import DBPipe.SQLite
+import Text.InterpolatedString.Perl6 (qc)
+import Data.Maybe
+import Control.Monad.Trans.Maybe
+import Data.ByteString qualified as BS
+
+data KeyManClientError = KeyManClientSomeError
+
+newtype KeyManClient m a = KeyManClient { fromKeyManClient :: DBPipeM m a }
+                           deriving newtype ( Applicative
+                                            , Functor
+                                            , Monad
+                                            , MonadIO
+                                            , MonadUnliftIO
+                                            )
+
+runKeymanClient :: MonadUnliftIO m => KeyManClient m a -> m a
+runKeymanClient action = do
+  env <- liftIO newAppEnv
+  let db = appDb env
+  flip runContT pure $ do
+    void $ ContT $ bracket (async (runPipe db)) cancel
+    lift $ withDB db (fromKeyManClient action)
+
+
+loadCredentials :: forall a m .
+                     ( MonadIO m
+                     , SomePubKeyPerks a
+                     )
+                  => a
+                  -> KeyManClient m (Maybe (PeerCredentials HBS2Basic))
+loadCredentials k = KeyManClient do
+
+  fnames <- select @(Only FilePath) [qc|
+    select f.file
+    from keytype t join keyfile f on t.key = f.key
+    where t.key = ? and t.type = 'sign'
+    limit 1 |]  (Only (SomePubKey k))
+
+  runMaybeT do
+    fn <- toMPlus $ fmap fromOnly fnames & listToMaybe
+    -- FIXME: throwError?
+    bs <- liftIO (try @_ @IOException $ BS.readFile fn) >>= toMPlus
+    toMPlus $ parseCredentials (AsCredFile bs)
+
+loadKeyRingEntry :: forall m .
+                    ( MonadIO m
+                    )
+                 => PubKey 'Encrypt HBS2Basic
+                 -> KeyManClient m (Maybe (KeyringEntry HBS2Basic))
+loadKeyRingEntry pk = KeyManClient do
+  runMaybeT do
+    fn <- toMPlus =<< lift (selectKeyFile pk)
+    bs <- liftIO (try @_ @IOException $ BS.readFile fn) >>= toMPlus
+    creds <- toMPlus $ parseCredentials (AsCredFile bs)
+    toMPlus $ headMay [ e
+                      | e@(KeyringEntry p _ _) <- view peerKeyring creds
+                      , p == pk
+                      ]
+

hbs2-keyman/src/HBS2/KeyMan/State.hs

@@ -0,0 +1,160 @@
+{-# Language UndecidableInstances #-}
+{-# Language AllowAmbiguousTypes #-}
+
+module HBS2.KeyMan.State
+  ( module HBS2.KeyMan.State
+  , commitAll
+  ) where
+
+import HBS2.Prelude.Plated
+import HBS2.Base58
+import HBS2.Net.Auth.Credentials
+import HBS2.Net.Proto.Types
+
+import HBS2.KeyMan.Config
+
+import DBPipe.SQLite
+
+-- import Crypto.Saltine.Core.Sign qualified as Sign
+-- 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
+
+-- newtype ToDB a = ToDB a
+class SomePubKeyType a where
+  somePubKeyType :: a -> String
+
+type SomePubKeyPerks a = (Pretty (AsBase58 a))
+
+data SomePubKey (c :: CryptoAction) = forall a . SomePubKeyPerks a => SomePubKey a
+
+newtype PubKeyAlias = PubKeyAlias { fromPubKeyAlias :: Text }
+                      deriving newtype (Eq,Ord,IsString)
+                      deriving stock (Generic)
+
+deriving newtype instance FromField PubKeyAlias
+deriving newtype instance ToField PubKeyAlias
+
+instance SomePubKeyType (SomePubKey 'Sign) where
+  somePubKeyType _ = "sign"
+
+instance SomePubKeyType (SomePubKey 'Encrypt) where
+  somePubKeyType _ = "encrypt"
+
+populateState :: MonadIO m => DBPipeM m ()
+populateState = do
+
+  getStatePath <&> takeDirectory
+    >>= liftIO . createDirectoryIfMissing True
+
+  ddl [qc|
+    create table if not exists keyfile
+    ( key   text not null
+    , file  text not null
+    , primary key (key)
+    )
+    |]
+
+  ddl [qc|
+    create table if not exists keytype
+    ( key   text not null
+    , type  text not null
+    , primary key (key)
+    )
+    |]
+
+  ddl [qc|
+    create table if not exists keyalias
+    ( alias text not null
+    , key   text not null
+    , primary key (alias)
+    )
+    |]
+
+  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
+              -> DBPipeM m ()
+
+updateKeyFile pk fp = do
+  insert [qc|
+  insert into keyfile (key,file)
+  values (?,?)
+  on conflict (key) do update set file = excluded.file
+  |] (pk, fp)
+  pure ()
+
+
+updateKeyType :: forall a m . (SomePubKeyType (SomePubKey a), MonadIO m)
+              => SomePubKey a
+              -> DBPipeM m ()
+updateKeyType pk = do
+  insert [qc|
+  insert into keytype (key, type)
+  values (?, ?)
+  on conflict (key) do update set type = excluded.type
+  |] (pk, somePubKeyType pk)
+  pure ()
+
+updateKeyAlias :: forall a m . (SomePubKeyType (SomePubKey a), MonadIO m)
+               => PubKeyAlias
+               -> SomePubKey a
+               -> DBPipeM m ()
+updateKeyAlias alias pk = do
+  insert [qc|
+  insert into keyalias (alias, key)
+  values (?, ?)
+  on conflict (alias) do update set key = excluded.key
+  |] (alias, pk)
+  pure ()
+
+
+
+selectKeyFile :: (MonadIO m, SomePubKeyPerks a)
+              => a
+              -> DBPipeM m (Maybe FilePath)
+selectKeyFile pk = do
+  listToMaybe . fmap fromOnly
+    <$> select @(Only FilePath) [qc|
+          select f.file
+          from  keyfile f
+          where f.key = ?
+          limit 1
+          |]  (Only (SomePubKey pk))
+
+
+data KeyListView =
+  KeyListView
+  { keyId    :: Text
+  , keyType  :: Text
+  , keyAlias :: Maybe Text
+  , keyFile  :: Maybe Text
+  }
+  deriving stock (Show,Generic)
+
+instance FromRow KeyListView
+
+instance Pretty KeyListView where
+  pretty KeyListView{..} =   fill (-32) (pretty keyId)
+                             <+>
+                             fill 10 (pretty keyType)
+                             <+>
+                             pretty keyFile
+
+listKeys :: MonadIO m
+         => DBPipeM m [KeyListView]
+listKeys = select_ [qc|
+  select t.key, t.type, a.alias, f.file
+    from keytype t left join keyalias a on a.key = t.key
+                   left join keyfile f on f.key = t.key
+  |]
+
+