From 421dc8c7141ecb6297996f7370d96e7e99894683 Mon Sep 17 00:00:00 2001
From: bnewbold <bnewbold@robocracy.org>
Date: Fri, 24 Jun 2011 17:21:45 -0400
Subject: arc3.1.tar

---
 prompt.arc | 119 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 119 insertions(+)
 create mode 100644 prompt.arc

(limited to 'prompt.arc')

diff --git a/prompt.arc b/prompt.arc
new file mode 100644
index 0000000..af34e53
--- /dev/null
+++ b/prompt.arc
@@ -0,0 +1,119 @@
+; Prompt: Web-based programming application.  4 Aug 06.
+
+(= appdir* "arc/apps/")
+
+(defop prompt req 
+  (let user (get-user req)
+    (if (admin user)
+        (prompt-page user)
+        (pr "Sorry."))))
+
+(def prompt-page (user . msg)
+  (ensure-dir appdir*)
+  (ensure-dir (string appdir* user))
+  (whitepage
+    (prbold "Prompt")
+    (hspace 20)
+    (pr user " | ")
+    (link "logout")
+    (when msg (hspace 10) (apply pr msg))
+    (br2)
+    (tag (table border 0 cellspacing 10)
+      (each app (dir (+ appdir* user))
+        (tr (td app)
+            (td (ulink user 'edit   (edit-app user app)))
+            (td (ulink user 'run    (run-app  user app)))
+            (td (hspace 40)
+                (ulink user 'delete (rem-app  user app))))))
+    (br2)
+    (aform (fn (req)
+             (when-umatch user req
+               (aif (goodname (arg req "app"))
+                    (edit-app user it)
+                    (prompt-page user "Bad name."))))
+       (tab (row "name:" (input "app") (submit "create app"))))))
+
+(def app-path (user app) 
+  (and user app (+ appdir* user "/" app)))
+
+(def read-app (user app)
+  (aand (app-path user app) 
+        (file-exists it)
+        (readfile it)))
+
+(def write-app (user app exprs)
+  (awhen (app-path user app)
+    (w/outfile o it 
+      (each e exprs (write e o)))))
+
+(def rem-app (user app)
+  (let file (app-path user app)
+    (if (file-exists file)
+        (do (rmfile (app-path user app))
+            (prompt-page user "Program " app " deleted."))
+        (prompt-page user "No such app."))))
+
+(def edit-app (user app)
+  (whitepage
+    (pr "user: " user " app: " app)
+    (br2)
+    (aform (fn (req)
+             (let u2 (get-user req)
+               (if (is u2 user)
+                   (do (when (is (arg req "cmd") "save")
+                         (write-app user app (readall (arg req "exprs"))))
+                       (prompt-page user))
+                   (login-page 'both nil
+                               (fn (u ip) (prompt-page u))))))
+      (textarea "exprs" 10 82
+        (pprcode (read-app user app)))
+      (br2)
+      (buts 'cmd "save" "cancel"))))
+
+(def pprcode (exprs) 
+  (each e exprs
+    (ppr e) 
+    (pr "\n\n")))
+
+(def view-app (user app)
+  (whitepage
+    (pr "user: " user " app: " app)
+    (br2)
+    (tag xmp (pprcode (read-app user app)))))
+
+(def run-app (user app)
+  (let exprs (read-app user app)
+    (if exprs 
+        (on-err (fn (c) (pr "Error: " (details c)))
+          (fn () (map eval exprs)))
+        (prompt-page user "Error: No application " app " for user " user))))
+
+(wipe repl-history*)
+
+(defop repl req
+  (if (admin (get-user req))
+      (replpage req)
+      (pr "Sorry.")))
+
+(def replpage (req)
+  (whitepage
+    (repl (readall (or (arg req "expr") "")) "repl")))
+
+(def repl (exprs url)
+    (each expr exprs 
+      (on-err (fn (c) (push (list expr c t) repl-history*))
+              (fn () 
+                (= that (eval expr) thatexpr expr)
+                (push (list expr that) repl-history*))))
+    (form url
+      (textarea "expr" 8 60)
+      (sp) 
+      (submit))
+    (tag xmp
+      (each (expr val err) (firstn 20 repl-history*)
+        (pr "> ")
+        (ppr expr)
+        (prn)
+        (prn (if err "Error: " "")
+             (ellipsize (tostring (write val)) 800)))))
+
-- 
cgit v1.2.3