diff --git a/flake.lock b/flake.lock index 092cba84..d6a04171 100644 --- a/flake.lock +++ b/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, - "narHash": "sha256-Kaa8F7nQFR3KuS6Y9WRUxeJeZlp6CCubyrRfmiEsW4k=", + "lastModified": 1698938553, + "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" ] diff --git a/flake.nix b/flake.nix index 319776c7..ac0f43d3 100644 --- a/flake.nix +++ b/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 diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index b8a1ec1c..ba329c75 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/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 diff --git a/hbs2-core/lib/HBS2/Data/KeyRing.hs b/hbs2-core/lib/HBS2/Data/KeyRing.hs new file mode 100644 index 00000000..ec9db965 --- /dev/null +++ b/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) + diff --git a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs b/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs index 8d7fbcd5..aaef42e3 100644 --- a/hbs2-core/lib/HBS2/Net/Auth/Credentials.hs +++ b/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 ) diff --git a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs b/hbs2-core/lib/HBS2/Net/Proto/Definition.hs index 7c365324..9502bd4b 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Definition.hs +++ b/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 diff --git a/hbs2-core/lib/HBS2/Net/Proto/Types.hs b/hbs2-core/lib/HBS2/Net/Proto/Types.hs index cfb7e755..bef1f08d 100644 --- a/hbs2-core/lib/HBS2/Net/Proto/Types.hs +++ b/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 diff --git a/hbs2-keyman/CHANGELOG.md b/hbs2-keyman/CHANGELOG.md new file mode 100644 index 00000000..e0de2101 --- /dev/null +++ b/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. diff --git a/hbs2-keyman/LICENSE b/hbs2-keyman/LICENSE new file mode 100644 index 00000000..3086ee5d --- /dev/null +++ b/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. diff --git a/hbs2-keyman/app/Main.hs b/hbs2-keyman/app/Main.hs new file mode 100644 index 00000000..5f8c2646 --- /dev/null +++ b/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 + + diff --git a/hbs2-keyman/hbs2-keyman.cabal b/hbs2-keyman/hbs2-keyman.cabal new file mode 100644 index 00000000..3bcd3618 --- /dev/null +++ b/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 + diff --git a/hbs2-keyman/src/HBS2/KeyMan/App/Types.hs b/hbs2-keyman/src/HBS2/KeyMan/App/Types.hs new file mode 100644 index 00000000..bcd189de --- /dev/null +++ b/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 + + diff --git a/hbs2-keyman/src/HBS2/KeyMan/Config.hs b/hbs2-keyman/src/HBS2/KeyMan/Config.hs new file mode 100644 index 00000000..6d71bc8d --- /dev/null +++ b/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" + diff --git a/hbs2-keyman/src/HBS2/KeyMan/Keys.hs b/hbs2-keyman/src/HBS2/KeyMan/Keys.hs new file mode 100644 index 00000000..a96e8b67 --- /dev/null +++ b/hbs2-keyman/src/HBS2/KeyMan/Keys.hs @@ -0,0 +1,4 @@ +module HBS2.KeyMan.Keys where + + + diff --git a/hbs2-keyman/src/HBS2/KeyMan/Keys/Direct.hs b/hbs2-keyman/src/HBS2/KeyMan/Keys/Direct.hs new file mode 100644 index 00000000..4b679f49 --- /dev/null +++ b/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 + ] + diff --git a/hbs2-keyman/src/HBS2/KeyMan/State.hs b/hbs2-keyman/src/HBS2/KeyMan/State.hs new file mode 100644 index 00000000..3074f89a --- /dev/null +++ b/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 + |] + +