mirror of https://github.com/voidlizard/hbs2
296 lines
7.3 KiB
Haskell
296 lines
7.3 KiB
Haskell
{-# Language UndecidableInstances #-}
|
|
{-# Language AllowAmbiguousTypes #-}
|
|
|
|
module HBS2.KeyMan.State
|
|
( module HBS2.KeyMan.State
|
|
, commitAll
|
|
, transactional
|
|
, module Exported
|
|
) where
|
|
|
|
import HBS2.Prelude.Plated
|
|
import HBS2.Base58
|
|
import HBS2.Hash
|
|
import HBS2.Net.Auth.Credentials
|
|
import HBS2.Data.Types.Refs
|
|
import HBS2.Net.Auth.GroupKeySymm as Exported
|
|
|
|
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 Text.InterpolatedString.Perl6 (qc)
|
|
import Data.Maybe
|
|
import Data.HashSet (HashSet)
|
|
import Data.HashSet qualified as HS
|
|
import Data.HashMap.Strict qualified as HM
|
|
import Data.Coerce
|
|
|
|
import UnliftIO
|
|
|
|
|
|
newtype SomeHash a = SomeHash a
|
|
deriving stock Generic
|
|
|
|
instance ToField (SomeHash HashRef) where
|
|
toField (SomeHash x) = toField $ show $ pretty x
|
|
|
|
instance FromField (SomeHash HashRef) where
|
|
fromField = fmap (SomeHash . fromString @HashRef) . fromField @String
|
|
|
|
instance ToField (SomeHash GroupKeyId) where
|
|
toField (SomeHash x) = toField $ show $ pretty x
|
|
|
|
instance FromField (SomeHash GroupKeyId) where
|
|
fromField = do
|
|
fmap (SomeHash . convert . fromString @HashRef) . fromField @String
|
|
where
|
|
convert ha = GroupKeyId (coerce ha)
|
|
|
|
-- newtype ToDB a = ToDB a
|
|
class SomePubKeyType a where
|
|
somePubKeyType :: a -> String
|
|
|
|
type SomePubKeyPerks a = (Pretty (AsBase58 a), FromStringMaybe 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)
|
|
)
|
|
|]
|
|
|
|
ddl [qc|
|
|
create table if not exists keyweight
|
|
( key text not null
|
|
, weight int not null
|
|
, primary key (key)
|
|
)
|
|
|]
|
|
|
|
|
|
ddl [qc|
|
|
create table if not exists gkseentx
|
|
( hash text not null
|
|
, primary key (hash)
|
|
)
|
|
|]
|
|
|
|
ddl [qc|
|
|
create table if not exists gktrack
|
|
( secret text not null
|
|
, gkhash text not null
|
|
, primary key (secret,gkhash)
|
|
)
|
|
|]
|
|
|
|
ddl [qc|
|
|
create table if not exists gkaccess
|
|
( gkhash text not null
|
|
, key text not null
|
|
, primary key (gkhash,key)
|
|
)
|
|
|]
|
|
|
|
|
|
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
|
|
, keyWeight :: Maybe Word
|
|
, keyAlias :: Maybe Text
|
|
, keyFile :: Maybe Text
|
|
}
|
|
deriving stock (Show,Generic)
|
|
|
|
instance FromRow KeyListView
|
|
|
|
instance Pretty KeyListView where
|
|
pretty KeyListView{..} = fill 44 (pretty keyId)
|
|
<+> fill 5 (pretty keyWeight)
|
|
<+>
|
|
fill 10 (pretty keyType)
|
|
<+>
|
|
pretty keyFile
|
|
|
|
listKeys :: MonadIO m => DBPipeM m [KeyListView]
|
|
listKeys = select_ [qc|
|
|
select t.key, t.type, w.weight, 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
|
|
left join keyweight w on w.key = t.key
|
|
order by w.weight ASC, f.file ASC
|
|
|]
|
|
|
|
|
|
deleteKey :: (MonadUnliftIO m, ToField a) => a -> DBPipeM m ()
|
|
deleteKey keyId = transactional do
|
|
insert [qc|delete from keyfile where key = ?|] (Only keyId)
|
|
insert [qc|delete from keytype where key = ?|] (Only keyId)
|
|
insert [qc|delete from keyalias where key = ?|] (Only keyId)
|
|
insert [qc|delete from keyweight where key = ?|] (Only keyId)
|
|
commitAll
|
|
|
|
|
|
|
|
updateKeyWeight :: (MonadIO m, ToField a) => a -> Int -> DBPipeM m ()
|
|
updateKeyWeight key weight = do
|
|
insert [qc|
|
|
insert into keyweight (key, weight)
|
|
values (?, ?)
|
|
on conflict (key) do update set weight = excluded.weight
|
|
|] (key, weight)
|
|
pure ()
|
|
|
|
selectKeyWeight :: (MonadIO m, SomePubKeyPerks a)
|
|
=> a
|
|
-> DBPipeM m Word
|
|
|
|
selectKeyWeight key = do
|
|
select [qc|
|
|
select coalesce(weight,0) as weight
|
|
from keyweight
|
|
where key = ?
|
|
limit 1
|
|
|] (Only (SomePubKey key)) <&> maybe 0 fromOnly . listToMaybe
|
|
|
|
|
|
deleteAllSeenGKTx :: MonadIO m => DBPipeM m ()
|
|
deleteAllSeenGKTx = do
|
|
insert_ [qc|delete from gkseentx|]
|
|
|
|
insertSeenGKTx :: (MonadIO m) => HashRef -> DBPipeM m ()
|
|
insertSeenGKTx hash = do
|
|
insert [qc|
|
|
insert into gkseentx (hash) values(?)
|
|
on conflict (hash) do nothing
|
|
|] (Only (SomeHash hash))
|
|
|
|
selectAllSeenGKTx :: (MonadIO m) => DBPipeM m (HashSet HashRef)
|
|
selectAllSeenGKTx = do
|
|
select_ [qc|select hash from gkseentx|] <&> HS.fromList . fmap (coerce . fromOnly @(SomeHash HashRef))
|
|
|
|
|
|
insertGKTrack :: MonadIO m => GroupKeyId -> HashRef -> DBPipeM m ()
|
|
insertGKTrack s g = do
|
|
insert [qc|
|
|
insert into gktrack (secret,gkhash)
|
|
values(?,?)
|
|
on conflict (secret,gkhash) do nothing
|
|
|] (SomeHash s, SomeHash g)
|
|
|
|
insertGKAccess:: MonadIO m => HashRef -> GroupKey 'Symm 'HBS2Basic -> DBPipeM m ()
|
|
insertGKAccess gkh gk = do
|
|
let rcpt = recipients gk & HM.keys
|
|
for_ rcpt $ \k -> do
|
|
insert [qc|
|
|
insert into gkaccess (gkhash,key)
|
|
values(?,?)
|
|
on conflict (gkhash,key) do nothing
|
|
|] (SomeHash gkh, SomePubKey k)
|
|
|
|
|
|
|
|
|
|
|