wip

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)

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
+      mkOpaque what
-
-      liftIO $ print $ vcat (fmap pretty s)
 
     _ -> 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)
+

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
 

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)

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)

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