1 files changed, 93 insertions, 0 deletions
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]
+  )