1 files changed, 95 insertions, 0 deletions
diff --git a/stdlib/source/lux/control/security/policy.lux b/stdlib/source/lux/control/security/policy.lux
new file mode 100644
index 000000000..f61f4c58b
--- /dev/null
+++ b/stdlib/source/lux/control/security/policy.lux
@@ -0,0 +1,95 @@
+(.module:
+  [lux #*
+   [abstract
+    [functor (#+ Functor)]
+    [apply (#+ Apply)]
+    [monad (#+ Monad)]]
+   [type
+    abstract]]
+  [//
+   ["!" capability (#+ capability:)]])
+
+(abstract: #export (Policy brand value label)
+  {}
+
+  value
+
+  (capability: #export (Can-Upgrade brand label value)
+    {#.doc (doc "Represents the capacity to 'upgrade' a value.")}
+    (can-upgrade value (Policy brand value label)))
+
+  (capability: #export (Can-Downgrade brand label value)
+    {#.doc (doc "Represents the capacity to 'downgrade' a value.")}
+    (can-downgrade (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 (..can-upgrade (|>> :abstraction))
+     #can-downgrade (..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)))
+    (|>> (!.use downgrade) (!.use 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))))))
+
+  (structure: #export functor
+    (:~ (decorate Functor))
+    
+    (def: (map f fa)
+      (|> fa :representation f :abstraction)))
+
+  (structure: #export apply
+    (:~ (decorate Apply))
+    
+    (def: &functor ..functor)
+    (def: (apply ff fa)
+      (:abstraction ((:representation ff) (:representation fa)))))
+
+  (structure: #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]
+  )