mirror of https://github.com/voidlizard/hbs2
140 lines
4.2 KiB
Haskell
140 lines
4.2 KiB
Haskell
{-# Language TemplateHaskell #-}
|
|
{-# Language PatternSynonyms #-}
|
|
{-# Language UndecidableInstances #-}
|
|
module HBS2.Net.Proto.ACB where
|
|
|
|
import HBS2.Prelude.Plated
|
|
import HBS2.Net.Auth.Credentials
|
|
import HBS2.Data.Types.Refs (HashRef)
|
|
import HBS2.Base58
|
|
import HBS2.Data.Types
|
|
import HBS2.Net.Proto.Definition
|
|
import HBS2.Net.Auth.AccessKey
|
|
|
|
import Data.Config.Suckless
|
|
|
|
import Control.Applicative
|
|
import Lens.Micro.Platform
|
|
import Codec.Serialise()
|
|
import Prettyprinter
|
|
import Data.List qualified as L
|
|
import Data.Text qualified as Text
|
|
import Data.Text (Text)
|
|
import Data.Maybe
|
|
import Data.Either
|
|
|
|
|
|
data family ACB ( s :: EncryptionSchema ) e
|
|
|
|
data DefineACB s e = DefineACB Text (ACB s e)
|
|
|
|
type ACBSimple = ACB 'NaClAsymm
|
|
|
|
data instance ACB 'NaClAsymm e =
|
|
ACB1
|
|
{ _acbRoot :: !(Maybe (PubKey 'Sign e)) -- it's monoid. no choice but Maybe
|
|
, _acbOwners :: ![PubKey 'Sign e]
|
|
, _acbReaders :: ![PubKey 'Encrypt e]
|
|
, _acbWriters :: ![PubKey 'Sign e]
|
|
, _acbPrev :: !(Maybe HashRef)
|
|
}
|
|
deriving stock (Generic)
|
|
|
|
|
|
makeLenses 'ACB1
|
|
|
|
type IsACB e = ( Serialise (PubKey 'Sign e)
|
|
, Serialise (PubKey 'Encrypt e)
|
|
, Eq (PubKey 'Sign e)
|
|
, Eq (PubKey 'Encrypt e)
|
|
)
|
|
|
|
deriving instance IsACB e => Eq (ACBSimple e)
|
|
|
|
instance IsACB e => Serialise (ACBSimple e)
|
|
|
|
instance IsACB e => Monoid (ACBSimple e) where
|
|
mempty = ACB1 Nothing mempty mempty mempty Nothing
|
|
|
|
instance IsACB e => Semigroup (ACBSimple e) where
|
|
(<>) a b = ACB1 (view acbRoot a <|> view acbRoot b)
|
|
(L.nub (view acbOwners a <> view acbOwners b))
|
|
(L.nub (view acbReaders a <> view acbReaders b))
|
|
(L.nub (view acbWriters a <> view acbWriters b))
|
|
(view acbPrev a <|> view acbPrev b)
|
|
|
|
|
|
instance ( Pretty (AsBase58 (PubKey 'Sign e))
|
|
, Pretty (AsBase58 (PubKey 'Encrypt e) )
|
|
) => Pretty (AsSyntax (DefineACB 'NaClAsymm e)) where
|
|
pretty (AsSyntax (DefineACB nacb' acb)) = vcat [
|
|
"define-acb" <+> nacb
|
|
, prev
|
|
, root
|
|
, owners
|
|
, readers
|
|
, writers
|
|
, line
|
|
]
|
|
|
|
where
|
|
|
|
nacb = pretty nacb'
|
|
|
|
wacb = (<+> nacb)
|
|
|
|
prev = maybe mempty (dquotes . pretty . AsBase58) (view acbPrev acb)
|
|
|
|
root = maybe mempty ( (acbR <+>) . dquotes . pretty . AsBase58 ) (view acbRoot acb)
|
|
owners = vcat $ fmap owner (view acbOwners acb)
|
|
acbR = "acb-root" <+> nacb
|
|
readers = vcat $ fmap reader (view acbReaders acb)
|
|
writers = vcat $ fmap writer (view acbWriters acb)
|
|
|
|
owner = (wacb "acb-owner" <+>) . dquotes . pretty . AsBase58
|
|
reader = (wacb "acb-reader" <+>) . dquotes . pretty . AsBase58
|
|
writer = (wacb "acb-writer" <+>) . dquotes . pretty . AsBase58
|
|
|
|
|
|
pattern Key :: forall {c}. Id -> [Syntax c] -> [Syntax c]
|
|
pattern Key n ns <- SymbolVal n : ns
|
|
|
|
instance FromStringMaybe (ACB 'NaClAsymm e) where
|
|
fromStringMay s = Just $ ACB1 root owners readers writers prev
|
|
|
|
where
|
|
parsed = parseTop s & fromRight mempty
|
|
defAcb = headMay [ acb | (ListVal (Key "define-acb" [SymbolVal acb]) ) <- parsed ]
|
|
|
|
root = lastMay $ catMaybes $
|
|
[ fromStringMay (Text.unpack e)
|
|
| (ListVal (Key "acb-root" [SymbolVal a, LitStrVal e]) ) <- parsed
|
|
, Just a == defAcb
|
|
]
|
|
|
|
owners = catMaybes
|
|
[ fromStringMay (Text.unpack e)
|
|
| (ListVal (Key "acb-owner" [SymbolVal a, LitStrVal e]) ) <- parsed
|
|
, Just a == defAcb
|
|
]
|
|
|
|
readers = catMaybes
|
|
[ fromStringMay (Text.unpack e)
|
|
| (ListVal (Key "acb-reader" [SymbolVal a, LitStrVal e]) ) <- parsed
|
|
, Just a == defAcb
|
|
]
|
|
|
|
writers = catMaybes
|
|
[ fromStringMay (Text.unpack e)
|
|
| (ListVal (Key "acb-writer" [SymbolVal a, LitStrVal e]) ) <- parsed
|
|
, Just a == defAcb
|
|
]
|
|
|
|
prev =lastMay $ catMaybes $
|
|
[ fromStringMay (Text.unpack e)
|
|
| (ListVal (Key "acb-prev" [SymbolVal a, LitStrVal e]) ) <- parsed
|
|
, Just a == defAcb
|
|
]
|
|
|
|
|