diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs index 12f117b3..623b92f3 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Internal.hs @@ -151,6 +151,23 @@ internalEntries :: forall c m . (IsContext c, Exception (BadFormException c), Mo internalEntries = do SC.internalEntries + entry $ bindMatch "--run" $ \case + [] -> do + liftIO getContents + <&> parseTop + >>= either (error.show) (pure . fmap (fixContext @_ @c)) + >>= evalTop + + [StringLike fn] -> do + liftIO (readFile fn) + <&> parseTop + >>= either (error.show) (pure . fmap (fixContext @_ @c)) + >>= evalTop + + _ -> throwIO (BadFormException @c nil) + + -- TODO: re-implement-all-on-top-of-opaque + entry $ bindMatch "blob:base58" $ \case [LitStrVal t] -> do bs <- pure (Text.unpack t & BS8.pack & fromBase58) diff --git a/hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs b/hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs index 81f010a8..2b5f54a1 100644 --- a/hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs +++ b/hbs2-cli/lib/HBS2/CLI/Run/Mailbox.hs @@ -103,7 +103,14 @@ mailboxEntries = do _ -> throwIO (BadFormException @c nil) - entry $ bindMatch "hbs2:mailbox:policy:basic:create:file" $ nil_ \case + entry $ bindMatch "hbs2:mailbox:policy:basic:read:syntax" $ \case + [ListVal syn] -> do + po <- parseBasicPolicy syn >>= orThrowUser "malformed policy" + mkOpaque po + + _ -> throwIO (BadFormException @c nil) + + entry $ bindMatch "hbs2:mailbox:policy:basic:read:file" $ \case [StringLike fn] -> lift do what <- liftIO (readFile fn) @@ -112,10 +119,33 @@ mailboxEntries = do >>= parseBasicPolicy >>= orThrowUser "invalid policy" - let s = getAsSyntax @C what - - liftIO $ print $ vcat (fmap pretty s) + mkOpaque what _ -> throwIO (BadFormException @c nil) + entry $ bindMatch "hbs2:mailbox:policy:basic:accept:peer" $ \case + [SignPubKeyLike who, OpaqueVal box] -> lift do + p <- fromOpaqueThrow @(BasicPolicy HBS2Basic) "expected BasicPolicy" box + r <- policyAcceptPeer @HBS2Basic p who + pure $ mkBool @c r + + _ -> throwIO (BadFormException @c nil) + + + entry $ bindMatch "hbs2:mailbox:policy:basic:accept:sender" $ \case + [SignPubKeyLike who, OpaqueVal box] -> lift do + p <- fromOpaqueThrow @(BasicPolicy HBS2Basic) "expected BasicPolicy" box + r <- policyAcceptSender @HBS2Basic p who + pure $ mkBool @c r + + _ -> throwIO (BadFormException @c nil) + + + entry $ bindMatch "hbs2:mailbox:policy:basic:dump" $ nil_ $ \case + [OpaqueVal box] -> lift do + p <- fromOpaqueThrow @(BasicPolicy HBS2Basic) "expected BasicPolicy" box + liftIO $ print $ vcat (fmap pretty (getAsSyntax @c p)) + + _ -> throwIO (BadFormException @c nil) + diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy.hs index 22b0385f..859ce31f 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy.hs @@ -15,6 +15,12 @@ class ForMailbox s => IsAcceptPolicy s a where -> PubKey 'Sign s -- ^ peer -> m Bool + + policyAcceptSender :: forall m . MonadIO m + => a + -> PubKey 'Sign s -- ^ sender + -> m Bool + policyAcceptMessage :: forall m . MonadIO m => a -> Sender s @@ -22,10 +28,10 @@ class ForMailbox s => IsAcceptPolicy s a where -> m Bool - data AnyPolicy s = forall a . (ForMailbox s, IsAcceptPolicy s a) => AnyPolicy { thePolicy :: a } instance ForMailbox s => IsAcceptPolicy s (AnyPolicy s) where - policyAcceptPeer (AnyPolicy p) = policyAcceptPeer @s p + policyAcceptPeer (AnyPolicy p) = policyAcceptPeer @s p + policyAcceptSender (AnyPolicy p) = policyAcceptSender @s p policyAcceptMessage (AnyPolicy p) = policyAcceptMessage @s p diff --git a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy/Basic.hs b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy/Basic.hs index 7ba30e54..23063799 100644 --- a/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy/Basic.hs +++ b/hbs2-peer/lib/HBS2/Peer/Proto/Mailbox/Policy/Basic.hs @@ -34,7 +34,9 @@ data BasicPolicy s = , bpPeers :: HashMap (PubKey 'Sign s) BasicPolicyAction , bpSenders :: HashMap (Sender s) BasicPolicyAction } - deriving stock (Generic) + deriving stock (Generic,Typeable) + +deriving stock instance ForMailbox s => Eq (BasicPolicy s) instance ForMailbox s => Pretty (BasicPolicy s) where pretty w = pretty (getAsSyntax @C w) @@ -42,7 +44,10 @@ instance ForMailbox s => Pretty (BasicPolicy s) where instance ForMailbox s => IsAcceptPolicy s (BasicPolicy s) where policyAcceptPeer BasicPolicy{..} p = do - pure $ Allow == fromMaybe bpDefaultSenderAction (HM.lookup p bpPeers) + pure $ Allow == fromMaybe bpDefaultPeerAction (HM.lookup p bpPeers) + + policyAcceptSender BasicPolicy{..} p = do + pure $ Allow == fromMaybe bpDefaultSenderAction (HM.lookup p bpSenders) policyAcceptMessage BasicPolicy{..} s m = do pure $ Allow == fromMaybe bpDefaultSenderAction (HM.lookup s bpSenders) diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs index cd368a88..2e019fd9 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Script/Internal.hs @@ -799,6 +799,11 @@ internalEntries = do _ -> do throwIO (BadFormException @C nil) + entry $ bindMatch "quot" $ \case + [ syn ] -> pure syn + _ -> do + throwIO (BadFormException @C nil) + entry $ bindMatch "head" $ \case [ ListVal es ] -> pure (head es) _ -> throwIO (TypeCheckError @C nil) diff --git a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs index abf8ad30..dd9cb2b8 100644 --- a/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs +++ b/miscellaneous/suckless-conf/lib/Data/Config/Suckless/Syntax.hs @@ -9,6 +9,7 @@ module Data.Config.Suckless.Syntax ( Syntax(..) , Id(..) , Literal(..) + , Opaque(..) , HasContext , C(..) , Context(..) @@ -16,6 +17,8 @@ module Data.Config.Suckless.Syntax , IsLiteral(..) , mkOpaque , fromOpaque + , fromOpaqueThrow + , SyntaxTypeError(..) , pattern SymbolVal , pattern ListVal , pattern LitIntVal @@ -25,6 +28,7 @@ module Data.Config.Suckless.Syntax , pattern StringLike , pattern StringLikeList , pattern Nil + , pattern OpaqueVal ) where @@ -99,7 +103,8 @@ pattern StringLikeList e <- (stringLikeList -> e) pattern Nil :: forall {c} . Syntax c pattern Nil <- ListVal [] - +pattern OpaqueVal :: forall {c} . Opaque -> Syntax c +pattern OpaqueVal box <- OpaqueValue box data family Context c :: Type @@ -121,8 +126,7 @@ newtype Id = deriving newtype (IsString,Pretty) deriving stock (Data,Generic,Show,Eq,Ord) -type ForOpaque a = (Typeable a, Hashable a, Eq a, Data a) - +type ForOpaque a = (Typeable a, Eq a) data Opaque = forall a. ForOpaque a => Opaque @@ -141,9 +145,20 @@ mkOpaque x = do n <- liftIO $ atomicModifyIORef opaqueIdIORef (\n -> (succ n,n)) pure $ OpaqueValue $ Opaque (Proxy :: Proxy a) n (someTypeRep (Proxy :: Proxy a)) (toDyn x) +data SyntaxTypeError = + UnexpectedType String + deriving stock (Show,Typeable) + +instance Exception SyntaxTypeError + fromOpaque :: forall a. Typeable a => Opaque -> Maybe a fromOpaque (Opaque{..}) = fromDynamic opaqueDyn +fromOpaqueThrow :: forall a m . (MonadIO m, Typeable a) => String -> Opaque -> m a +fromOpaqueThrow s (Opaque{..}) = do + let o = fromDynamic @a opaqueDyn + liftIO $ maybe (throwIO (UnexpectedType s)) pure o + instance Eq Opaque where (Opaque p1 _ t1 d1) == (Opaque _ _ t2 d2) = t1 == t2 && unpack p1 d1 == unpack p1 d2 @@ -220,7 +235,7 @@ instance Pretty (Syntax c) where pretty (Symbol _ s) = pretty s pretty (List _ (x:xs)) = parens $ align $ sep ( fmap pretty (x:xs) ) pretty (List _ []) = parens mempty - pretty (OpaqueValue v) = parens ("#opaque:" <> pretty (opaqueId v)) + pretty (OpaqueValue v) = "#opaque:" <> viaShow (opaqueRep v) <> ":" <> pretty (opaqueId v) instance Pretty Literal where pretty = \case