mirror of https://github.com/voidlizard/hbs2
basic key manager
This commit is contained in:
Dmitry Zuikov
parent
2ef2bb493c
commit
09f9eed01f
75
flake.lock
75
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"
|
||||
]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
@ -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
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -0,0 +1,5 @@
|
|||
# Revision history for hbs2-keyman
|
||||
|
||||
## 0.1.0.0 -- YYYY-mm-dd
|
||||
|
||||
* First version. Released on an unsuspecting world.
|
||||
|
|
@ -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.
|
||||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
@ -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"
|
||||
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
module HBS2.KeyMan.Keys where
|
||||
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
]
|
||||
|
||||
|
|
@ -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
|
||||
|]
|
||||
|
||||
|
||||
Loading…
Reference in New Issue