From d6c48ae6a8b58f5974133170863a31c70f0123d1 Mon Sep 17 00:00:00 2001
From: Eduardo Julian
Date: Wed, 14 Jul 2021 13:59:02 -0400
Subject: Normalized the hierarchy of the standard library modules.

---
 .../library/lux/control/security/capability.lux    | 71 +++++++++++++++++
 .../source/library/lux/control/security/policy.lux | 93 ++++++++++++++++++++++
 2 files changed, 164 insertions(+)
 create mode 100644 stdlib/source/library/lux/control/security/capability.lux
 create mode 100644 stdlib/source/library/lux/control/security/policy.lux

(limited to 'stdlib/source/library/lux/control/security')

diff --git a/stdlib/source/library/lux/control/security/capability.lux b/stdlib/source/library/lux/control/security/capability.lux
new file mode 100644
index 000000000..13ae40d15
--- /dev/null
+++ b/stdlib/source/library/lux/control/security/capability.lux
@@ -0,0 +1,71 @@
+(.module:
+  [library
+   [lux #*
+    [abstract
+     [monad (#+ do)]]
+    [control
+     ["<>" parser
+      ["<c>" code]]
+     ["." io (#+ IO)]
+     [concurrency
+      ["." promise (#+ Promise)]]]
+    [data
+     [text
+      ["%" format (#+ format)]]
+     [collection
+      ["." list ("#\." functor)]]]
+    [type
+     abstract]
+    ["." meta]
+    ["." macro
+     ["." code]
+     [syntax (#+ syntax:)
+      ["|.|" export]
+      ["|.|" declaration]
+      ["|.|" annotations]]]]])
+
+(abstract: #export (Capability brand input output)
+  (-> input output)
+
+  {#.doc (doc "Represents the capability to perform an operation."
+              "This operation is assumed to have security implications.")}
+
+  (def: forge
+    (All [brand input output]
+      (-> (-> input output)
+          (Capability brand input output)))
+    (|>> :abstraction))
+
+  (def: #export (use capability input)
+    (All [brand input output]
+      (-> (Capability brand input output)
+          input
+          output))
+    ((:representation capability) input))
+
+  (syntax: #export (capability: {export |export|.parser}
+                     {declaration |declaration|.parser}
+                     {annotations (<>.maybe |annotations|.parser)}
+                     {[forge input output] (<c>.form ($_ <>.and <c>.local_identifier <c>.any <c>.any))})
+    (do {! meta.monad}
+      [this_module meta.current_module_name
+       #let [[name vars] declaration]
+       g!brand (\ ! map (|>> %.code code.text)
+                  (macro.gensym (format (%.name [this_module name]))))
+       #let [capability (` (..Capability (.primitive (~ g!brand)) (~ input) (~ output)))]]
+      (wrap (list (` (type: (~+ (|export|.format export))
+                       (~ (|declaration|.format declaration))
+                       (~ capability)))
+                  (` (def: (~ (code.local_identifier forge))
+                       (All [(~+ (list\map code.local_identifier vars))]
+                         (-> (-> (~ input) (~ output))
+                             (~ capability)))
+                       (~! ..forge)))
+                  ))))
+
+  (def: #export (async capability)
+    (All [brand input output]
+      (-> (Capability brand input (IO output))
+          (Capability brand input (Promise output))))
+    (..forge (|>> ((:representation capability)) promise.future)))
+  )
diff --git a/stdlib/source/library/lux/control/security/policy.lux b/stdlib/source/library/lux/control/security/policy.lux
new file mode 100644
index 000000000..3c1eb579e
--- /dev/null
+++ b/stdlib/source/library/lux/control/security/policy.lux
@@ -0,0 +1,93 @@
+(.module:
+  [library
+   [lux #*
+    [abstract
+     [functor (#+ Functor)]
+     [apply (#+ Apply)]
+     [monad (#+ Monad)]]
+    [type
+     abstract]]])
+
+(abstract: #export (Policy brand value label)
+  value
+
+  (type: #export (Can_Upgrade brand label value)
+    {#.doc (doc "Represents the capacity to 'upgrade' a value.")}
+    (-> value (Policy brand value label)))
+
+  (type: #export (Can_Downgrade brand label value)
+    {#.doc (doc "Represents the capacity to 'downgrade' a value.")}
+    (-> (Policy brand value label) value))
+
+  (type: #export (Privilege brand label)
+    {#.doc (doc "Represents the privilege to both 'upgrade' and 'downgrade' a value.")}
+    {#can_upgrade (Can_Upgrade brand label)
+     #can_downgrade (Can_Downgrade brand label)})
+
+  (def: privilege
+    Privilege
+    {#can_upgrade (|>> :abstraction)
+     #can_downgrade (|>> :representation)})
+
+  (type: #export (Delegation brand from to)
+    {#.doc (doc "Represents the act of delegating policy capacities.")}
+    (All [value]
+      (-> (Policy brand value from)
+          (Policy brand value to))))
+
+  (def: #export (delegation downgrade upgrade)
+    {#.doc (doc "Delegating policy capacities.")}
+    (All [brand from to]
+      (-> (Can_Downgrade brand from) (Can_Upgrade brand to)
+          (Delegation brand from to)))
+    (|>> downgrade upgrade))
+
+  (type: #export (Context brand scope label)
+    {#.doc (doc "A computational context with an associated policy privilege.")}
+    (-> (Privilege brand label)
+        (scope label)))
+
+  (def: #export (with_policy context)
+    (All [brand scope]
+      (Ex [label]
+        (-> (Context brand scope label)
+            (scope label))))
+    (context ..privilege))
+
+  (def: (decorate constructor)
+    (-> Type Type)
+    (type (All [brand label] (constructor (All [value] (Policy brand value label))))))
+
+  (implementation: #export functor
+    (:~ (decorate Functor))
+    
+    (def: (map f fa)
+      (|> fa :representation f :abstraction)))
+
+  (implementation: #export apply
+    (:~ (decorate Apply))
+    
+    (def: &functor ..functor)
+    (def: (apply ff fa)
+      (:abstraction ((:representation ff) (:representation fa)))))
+
+  (implementation: #export monad
+    (:~ (decorate Monad))
+    
+    (def: &functor ..functor)
+    (def: wrap (|>> :abstraction))
+    (def: join (|>> :representation)))
+  )
+
+(template [<brand> <value> <upgrade> <downgrade>]
+  [(abstract: #export <brand>
+     Any
+     
+     (type: #export <value> (Policy <brand>))
+     (type: #export <upgrade> (Can_Upgrade <brand>))
+     (type: #export <downgrade> (Can_Downgrade <brand>))
+     )]
+
+  [Privacy Private Can_Conceal Can_Reveal]
+  [Safety Safe Can_Trust Can_Distrust]
+  )
-- 
cgit v1.2.3