1 ;;;============================================================================
3 ;;; File: "program.scm"
5 ;;; Copyright (c) 2011-2012 by Marc Feeley, All Rights Reserved.
7 ;; This program implements the "Gambit REPL" application for iOS
8 ;; devices. It is a simple development environment for Scheme. The
9 ;; user can interact with a REPL, and edit small scripts.
11 ;;;============================================================================
15 (##include "~~lib/gambit#.scm")
16 (##include "~~lib/_gambit#.scm")
18 (##namespace ("gr#" help)) ;; don't import help
20 (##include "wiki#.scm")
21 (##include "html#.scm")
22 (##include "url#.scm")
23 (##include "json#.scm")
24 (##include "repl-server#.scm")
25 (##include "intf#.scm")
26 (##include "script#.scm")
27 (##include "repo#.scm")
28 (##include "help#.scm")
53 ;;;----------------------------------------------------------------------------
55 ;; Add cond-expand features to identify Gambit-REPL.
57 (set! ##cond-expand-features
59 (cons 'Gambit-REPL-iOS
60 (cons 'Gambit-REPL-v4.0
61 ##cond-expand-features))))
63 ;;;----------------------------------------------------------------------------
65 ;; Common HTML header.
67 (define common-html-header #<<common-html-header-end
72 <meta name="viewport" content="width=device-width, initial-scale=1.0, minimum-scale=0.25, maximum-scale=1.6">
76 function gestureStart() {
77 var metas = document.getElementsByTagName('meta');
78 for (var i=0; i<metas.length; i++) {
79 if (metas[i].name === "viewport") {
80 metas[i].content = "width=device-width, initial-scale=1.0, minimum-scale=0.25, maximum-scale=1.6";
85 document.addEventListener("gesturestart", gestureStart, false);
89 <style TYPE="text/css">
92 background-image: -webkit-gradient(linear, left top, left bottom, from(#fffb8b), to(#fffef0));
95 background-color: #a0a0a0;
98 background-image: -webkit-gradient(linear, left top, left bottom, from(#a0a0a0), to(#f0f0f0));
101 background-image: -webkit-gradient(linear, left top, left bottom, from(#a0a0a0), to(#f0f0f0));
104 background-image: -webkit-gradient(linear, left top, left bottom, from(#fffb8b), to(#fffef0));
114 display: inline-block;
116 font: bold 14px Arial;
120 border: 1px solid black;
121 -webkit-border-radius: 5px;
124 background-image: -webkit-gradient(linear, left top, left bottom, from(#fffef0), to(#fffb8b));
128 display: inline-block;
130 font: bold 14px Arial;
135 border: 1px solid black;
136 -webkit-border-radius: 5px;
139 background-image: -webkit-gradient(linear, left top, left bottom, from(#7f7fff), to(#2020b0));
142 display: inline-block;
144 font: bold 14px Arial;
148 border: 1px solid black;
149 -webkit-border-radius: 5px;
152 background-image: -webkit-gradient(linear, left top, left bottom, from(#7f7fff), to(#2020b0));
155 display: inline-block;
157 font: bold 24px Arial;
162 border: 1px solid black;
163 -webkit-border-radius: 5px;
166 background-image: -webkit-gradient(linear, left top, left bottom, from(#94a6be), to(#506070));
169 display: inline-block;
171 font: bold 14px Arial;
175 border: 1px solid black;
176 -webkit-border-radius: 5px;
177 background-image: -webkit-gradient(linear, left top, left bottom, from(#688aba), to(#385a8a));
182 display: inline-block;
184 font: bold 14px Arial;
188 border: 1px solid black;
189 -webkit-border-radius: 5px;
192 background-image: -webkit-gradient(linear, left top, left bottom, from(#ffffff), to(#b0b0b0));
197 font: bold 12px Courier;
201 font: bold 18px Arial;
210 font: bold 18px Arial;
214 font: bold 18px Arial;
223 display: inline-block;
233 -webkit-animation: fade 1s linear infinite;
234 -webkit-border-radius: 50px;
235 -webkit-box-shadow: 0 0 3px rgba(0,0,0,0.2);
237 div.spinner div.bar1 {-webkit-transform:rotate(0deg) translate(0, -142%); -webkit-animation-delay: 0s;}
238 div.spinner div.bar2 {-webkit-transform:rotate(30deg) translate(0, -142%); -webkit-animation-delay: -0.9167s;}
239 div.spinner div.bar3 {-webkit-transform:rotate(60deg) translate(0, -142%); -webkit-animation-delay: -0.833s;}
240 div.spinner div.bar4 {-webkit-transform:rotate(90deg) translate(0, -142%); -webkit-animation-delay: -0.75s;}
241 div.spinner div.bar5 {-webkit-transform:rotate(120deg) translate(0, -142%); -webkit-animation-delay: -0.667s;}
242 div.spinner div.bar6 {-webkit-transform:rotate(150deg) translate(0, -142%); -webkit-animation-delay: -0.5833s;}
243 div.spinner div.bar7 {-webkit-transform:rotate(180deg) translate(0, -142%); -webkit-animation-delay: -0.5s;}
244 div.spinner div.bar8 {-webkit-transform:rotate(210deg) translate(0, -142%); -webkit-animation-delay: -0.41667s;}
245 div.spinner div.bar9 {-webkit-transform:rotate(240deg) translate(0, -142%); -webkit-animation-delay: -0.333s;}
246 div.spinner div.bar10 {-webkit-transform:rotate(270deg) translate(0, -142%); -webkit-animation-delay: -0.25s;}
247 div.spinner div.bar11 {-webkit-transform:rotate(300deg) translate(0, -142%); -webkit-animation-delay: -0.1667s;}
248 div.spinner div.bar12 {-webkit-transform:rotate(330deg) translate(0, -142%); -webkit-animation-delay: -0.0833s;}
249 @-webkit-keyframes fade {
258 word-break: break-all;
264 common-html-header-end
267 ;;;----------------------------------------------------------------------------
271 (define splash-page-content-part1 #<<splash-page-content-part1-end
273 <body class="splash">
277 splash-page-content-part1-end
280 (define splash-page-content-part2 #<<splash-page-content-part2-end
281 </strong>, a Scheme development environment based on the <a href="event:wiki">Gambit Scheme programming system</a>.
285 <li/> learn the Scheme language,
286 <li/> debug Scheme code on the go,
287 <li/> number crunch exactly!
291 In the REPL view, enter your command after the <strong><code>></code></strong> prompt, then tap <strong>return</strong> to display the result. Here is a sample interaction:<br/>
295 > (+ 1 (/ (* 2 2) (sqrt 9)))<br/>
297 > (expt 2 100)<br/>
298 1267650600228229401496703205376<br/>
299 > (reverse (string->list "hello"))<br/>
300 (#\o #\l #\l #\e #\h)<br/>
301 > \for (int i=1;i<=3;i++) pp(i*i);<br/>
312 splash-page-content-part2-end
315 (define (set-splash-view)
318 (list common-html-header
319 splash-page-content-part1
321 splash-page-content-part2)
328 (lambda (old-event-handler)
329 generic-event-handler))
333 ;;;----------------------------------------------------------------------------
337 (define current-help-document #f)
339 (define (help #!optional (subject (macro-absent-obj)))
340 (if (eq? subject (macro-absent-obj))
341 (show-help-document (or current-help-document main-help-document) #f)
344 (define (show-help-document docu anchor)
345 (let ((load-docu? (not (equal? docu current-help-document))))
347 (define (goto-anchor)
351 (string-append "window.location='#" anchor "'"))))
354 (lambda (old-event-handler)
356 (cond ((and load-docu? (equal? event "event:loaded"))
357 (if (not (equal? docu main-help-document))
361 ((equal? event "event:r5rs")
362 (show-help-document r5rs-help-document #f))
364 ((equal? event "event:gambit-c")
365 (show-help-document gambit-c-help-document #f))
367 ((equal? event "cancel")
369 (show-help-document main-help-document #f))
371 ((wiki-event-handler event))
373 ((handle-create-account-event event))
376 (handle-navigation-event
379 (hide-cancelButton))))))))
383 (set! current-help-document docu)
384 (set-webView-content-from-file 2 docu (path-directory docu) #t))
390 (if (not (equal? docu main-help-document))
391 (show-cancelButton))))
394 ;;;----------------------------------------------------------------------------
401 (lambda (old-event-handler)
402 generic-event-handler))
405 (define (repl-eval str)
408 (add-output-to-textView 0 str)
412 (define (repl-server password)
413 (repl-server-start password))
415 (set! ##primordial-exception-handler-hook
416 (lambda (exc other-handler)
417 (repl) ;; switch to REPL view on errors
418 (##repl-exception-handler-hook exc other-handler)))
421 ;;;----------------------------------------------------------------------------
425 (define edit-page-content-part1 #<<edit-page-content-part1-end
427 <script language="JavaScript">
429 edit-page-content-part1-end
432 (define edit-page-content-part2 #<<edit-page-content-part2-end
434 function send_event(e)
435 { window.location = "event:" + e; }
437 function send_event_with_scripts(e,index)
438 { window.location = event_with_scripts(e,index); }
440 function event_with_scripts(e,index)
442 var strings = ["event:"+e,index];
443 for (var i = 0; i<nb_scripts; i++)
445 strings.push(encodeURIComponent(document.getElementById("script"+i).value));
448 return strings.join(":");
452 { send_event_with_scripts("new",0); }
454 function click_run(index)
455 { send_event_with_scripts("run",index); }
457 function click_save(index)
458 { var script = document.getElementById("script"+index).value;
459 var lines = script.split(/\n/);
460 var line1 = lines[0];
461 var name = line1.replace(/^;;; /,"");
462 var event = (/^[^\n]*\s*$/.exec(script)) ? "remove" : "save";
463 if (name.length < line1.length && /^[A-Za-z][-\.A-Za-z0-9]*\.scm$/.exec(name))
465 if (confirm((event==="remove")?('Are you sure you want to remove\n\n'+name+'\n\nfrom the Documents folder?'):('Are you sure you want to save\n\n'+name+'\n\nto the Documents folder?')))
466 send_event_with_scripts(event,index);
469 edit-page-content-part2-end
472 (define edit-page-content-part3 #<<edit-page-content-part3-end
473 else if (name.length < line1.length && /^[A-Z][-\. A-Za-z0-9]*:[-\. A-Za-z0-9:]*\.scm$/.exec(name))
475 if (confirm((event==="remove")?('Are you sure you want to remove\n\n'+name+'\n\nfrom the Gambit wiki?'):('Are you sure you want to save\n\n'+name+'\n\nto the Gambit wiki? It will replace the current script by that name if it exists. Note that previous versions of the script will still be available in the Gambit wiki page history.')))
476 send_event_with_scripts(event,index);
479 edit-page-content-part3-end
482 (define edit-page-content-part4 #<<edit-page-content-part4-end
485 alert("The script cannot be saved because it is improperly named. The first line must be the name of the script preceded by three semicolons and a space, for example:\n\n;;; test.scm\n\nMoreover, the name must start with a letter, and end in '.scm', and contain only letters, digits, '.', and '-'.");
489 function click_delete(index)
490 { if (confirm('Are you sure you want to delete this script from the Edit view?'))
491 send_event_with_scripts("delete",index);
494 function lose_focus()
495 { return event_with_scripts("exit",0); }
499 <body class="editor">
501 <span class="editorhead">
502 <div class="button3" onClick="click_new();">+</div>
505 edit-page-content-part4-end
508 (define edit-page-content-part5 #<<edit-page-content-part5-end
513 edit-page-content-part5-end
516 (define edit-page-script-rows-iPad 20)
517 (define edit-page-script-rows-default 10)
519 (define edit-page-script-rows
521 ((iPad) edit-page-script-rows-iPad)
522 (else edit-page-script-rows-default)))
524 (define (html-for-local-scripts scripts)
526 (define (html script name index)
528 "<textarea class=\"script\" id=\"script" index "\" rows="
529 edit-page-script-rows
534 "<div class=\"button2\" onClick=\"click_run(" index ");\">Run</div>\n"
535 " "
536 "<div class=\"button2\" onClick=\"click_save(" index ");\">Save</div>\n"
537 " "
538 "<div class=\"button2\" onClick=\"click_delete(" index ");\">Delete</div>\n"
541 (let loop ((scripts scripts) (i 0) (accum '()))
543 (let* ((x (car scripts))
548 (cons (html (add-script-name-if-needed name script) name i)
552 (define (add-script-name-if-needed name script)
553 (if (not (wiki-script-name-type name))
555 (let ((name-in-script (extract-script-name script)))
556 (if (equal? name name-in-script)
564 (define (set-edit-view)
567 (let ((scripts (get-script-db)))
568 (list common-html-header
569 edit-page-content-part1
570 "var nb_scripts = " (length scripts) ";\n"
571 edit-page-content-part2
573 edit-page-content-part3
575 edit-page-content-part4
576 (html-for-local-scripts scripts)
577 edit-page-content-part5))
584 (lambda (old-event-handler)
589 (handle-navigation-event
592 (let ((new-event (eval-js-in-webView 3 "lose_focus()")))
593 (and (string? new-event)
600 (define (get-index-and-update-script-db rest)
601 (let ((x (get-event-parameters rest)))
603 (let ((index (string->number (car x))))
604 (let loop ((lst (cdr x)) (rev-scripts '()))
606 (let ((script (car lst)))
608 (cons (cons (extract-script-name script) script)
610 (let ((new-script-db (reverse rev-scripts)))
612 (set-pref "run-main-script" "yes")
614 (set! script-db new-script-db)
619 (define (handle-edit-event event otherwise)
620 (cond ((has-prefix? event "event:new:") =>
622 (get-index-and-update-script-db rest)
626 ((has-prefix? event "event:run:") =>
629 (get-index-and-update-script-db rest))))
631 ((has-prefix? event "event:save:") =>
634 (get-index-and-update-script-db rest))))
636 ((has-prefix? event "event:remove:") =>
639 (get-index-and-update-script-db rest))))
641 ((has-prefix? event "event:delete:") =>
644 (get-index-and-update-script-db rest))
647 ((has-prefix? event "event:exit:") =>
649 (get-index-and-update-script-db rest)))
654 (define (handle-navigation-event event lose-focus-handler)
655 (let ((nav (has-prefix? event "NAV")))
657 (let ((n (string->number nav)))
672 (define (wiki-event-handler event)
673 (or (and (equal? event "event:wiki")
677 (and (equal? event "event:wiki-Gambit-REPL")
679 (visit-wiki-Gambit-REPL)
690 (define (visit-wiki-Gambit-REPL)
696 "/index.php/Gambit_REPL")))
698 (define latest-pasteboard #f)
700 (define (handle-app-become-active-event event)
701 (and (equal? event "app-become-active")
702 (let* ((script (get-pasteboard))
704 (not (equal? script latest-pasteboard))
705 (extract-script-name script))))
706 (set! latest-pasteboard script)
709 (lambda (old-event-handler)
710 (popup-alert (string-append CFBundleName ".app")
712 "Create the script\n\n"
714 "\n\nin the Edit view from the content of the pasteboard?")
719 (define (done accept?)
721 (lambda (new-event-handler)
725 (add-script name script)
729 (cond ((equal? event "popup-alert-cancel")
731 ((equal? event "popup-alert-accept")
735 (define (handle-create-account-event event)
736 (and (equal? event "event:create-account")
743 "/index.php/Special:RequestAccount"))
746 (define (generic-event-handler event)
747 (or (wiki-event-handler event)
748 (handle-app-become-active-event event)
749 (handle-create-account-event event)
750 (handle-navigation-event event (lambda () #f))))
752 (define run-script-event #f)
753 (set! run-script-event
755 (let ((name-script (get-script-at-index index)))
757 (let ((name (car name-script))
758 (script (cdr name-script)))
759 (run-script name script))))))
761 (define save-script-event #f)
762 (set! save-script-event
764 (let ((name-script (get-script-at-index index)))
766 (let ((name (car name-script))
767 (script (cdr name-script)))
768 (store-script name script edit))))))
770 (define remove-script-event #f)
771 (set! remove-script-event
773 (let ((name-script (get-script-at-index index)))
775 (let ((name (car name-script))
776 (script (cdr name-script)))
777 (remove-script name edit))))))
779 (define (reset-scripts)
780 (script#reset-scripts)
783 (define (remove-script name #!optional (back repl))
784 (case (wiki-script-name-type name)
788 (wiki-script-name-verify name)
789 (wiki-script-remove name)
792 (list "<h3>Removing script</h3>" (html-escape name) "<br/>")
793 "The script has been removed from the Gambit wiki"
794 "Could not remove script!"
798 (with-exception-catcher
800 (display-exception e (repl-output-port))
803 (delete-file (##path-expand name "~"))))
806 (define (store-script name script #!optional (back repl))
807 (case (wiki-script-name-type name)
811 (wiki-script-name-verify name)
812 (wiki-script-store name script)
815 (list "<h3>Storing script</h3>" (html-escape name) "<br/>")
816 "The script has been stored on the Gambit wiki"
817 "Could not store script!"
821 (with-exception-catcher
823 (display-exception e (repl-output-port))
826 (call-with-output-file
827 (##path-expand name "~")
829 (display script port)))))
832 (define (fetch-script name #!optional (back repl))
833 (case (wiki-script-name-type name)
837 (wiki-script-name-verify name)
838 (let ((script (wiki-script-fetch name)))
839 (add-script name script)
843 (list "<h3>Fetching script</h3>" (html-escape name) "<br/>")
844 "The script has been fetched from the Gambit wiki"
845 "Could not fetch script!"
849 (with-exception-catcher
851 (display-exception e (repl-output-port))
855 (call-with-input-file
856 (##path-expand name "~")
858 (read-line port #f)))))
859 (add-script name script)
864 (define (delete-script-event index)
865 (let loop ((scripts (get-script-db)) (i 0) (accum '()))
868 (set! script-db (append (reverse accum)
870 (loop (cdr scripts) (+ i 1) (cons (car scripts) accum)))))
873 (define script-name-prefix ";;; ") ;; must be consistent with the definition of the click_save JavaScript function
875 (define (extract-script-name script)
876 (let* ((line1 (first-line script))
877 (name (has-prefix? line1 script-name-prefix)))
878 (and (wiki-script-name-type name)
881 (define (first-line str)
883 (if (< i (string-length str))
884 (if (char=? (string-ref str i) #\newline)
890 ;;;----------------------------------------------------------------------------
892 ;; Repository browser.
894 (define repo-page-content-part1 #<<repo-page-content-part1-end
898 repo-page-content-part1-end
901 (define repo-page-content-part2 #<<repo-page-content-part2-end
903 <div class="repohead">
904 <div class="button1" onClick="window.location='event:back';">◀</div>
907 repo-page-content-part2-end
910 (define repo-page-content-part3 #<<repo-page-content-part3-end
912 <div class="repohead">
916 repo-page-content-part3-end
919 (define repo-page-content-part4 #<<repo-page-content-part4-end
925 repo-page-content-part4-end
928 (define repo-page-content-part5 #<<repo-page-content-part5-end
935 repo-page-content-part5-end
938 (define (html-for-script-tree tree)
940 (define (html branch)
941 (let ((name (car branch))
942 (subtree (cdr branch)))
945 (list "<td class=\"repoget\"></td>\n"
946 "<td><div class=\"button1\" onClick=\"window.location='event:view:"
948 "';\">▶</div></td>\n")
949 (list "<td class=\"repoget\"><div class=\"button0\" onClick=\"window.location='event:get:"
951 "';\">Get</div></td>\n"
952 "<td><div class=\"button1\" onClick=\"window.location='event:view:"
954 "';\">View</div></td>\n"))
955 "<td class=\"repoentry\">"
960 (let loop ((tree tree) (accum '()))
962 (let ((branch (car tree)))
963 (loop (cdr tree) (cons (html branch) accum)))
966 (define repo-enabled? #f)
968 (define (repo-enable!)
969 (if (not repo-enabled?)
971 (set! repo-enabled? #t)
972 (segm-ctrl-set-title 1 "Repo"))))
979 (if (not repo-enabled?)
981 (visit-wiki-Gambit-REPL)
985 (let ((scripts (wiki-script-list)))
986 (repo-browse #f (script-list->tree scripts))))
987 repo-page-content-part3
988 (list "<h3>Accessing Gambit wiki</h3><br/>")
990 "Could not get list of scripts!"
993 (define (script-list->tree scripts)
995 (define (cvt scripts prefix)
996 (if (not (pair? scripts))
998 (let ((script1 (car scripts)))
1000 (if (< i (string-length script1))
1001 (if (not (char=? (string-ref script1 i) #\:))
1003 (let ((p (substring script1 0 (+ i 1))))
1004 (let loop2 ((lst scripts) (rev-subtrees '()))
1007 (let ((new-prefix (string-append prefix p)))
1008 (cons (cons new-prefix
1009 (cvt (reverse rev-subtrees) new-prefix))
1013 (let ((s (car lst)))
1014 (if (and (<= i (string-length s))
1015 (string=? (substring s 0 (+ i 1)) p))
1017 (cons (substring s (+ i 1) (string-length s))
1021 (cons (cons (string-append prefix script1) '())
1022 (cvt (cdr scripts) prefix)))))))
1026 (define (repo-browse back tree)
1029 (lambda (old-event-handler)
1031 (cond ((has-prefix? event "event:view:") =>
1033 (let* ((params (get-event-parameters rest))
1035 (branch (assoc name tree)))
1037 (let ((subtree (cdr branch)))
1039 (repo-browse (lambda () (repo-browse back tree))
1041 (view-script name)))))))
1043 ((has-prefix? event "event:get:") =>
1045 (let* ((params (get-event-parameters rest))
1046 (name (car params)))
1047 (get-repo-script-event name edit))))
1049 ((equal? event "event:back")
1053 (generic-event-handler event))))))
1056 (list common-html-header
1057 repo-page-content-part1
1059 repo-page-content-part2
1060 repo-page-content-part3)
1061 repo-page-content-part4
1062 (html-for-script-tree tree)
1063 repo-page-content-part5)
1068 (define (view-script name)
1076 (string-append wiki-script-prefix name)))))
1078 (define get-repo-script-event #f)
1079 (set! get-repo-script-event fetch-script)
1082 ;;;----------------------------------------------------------------------------
1084 ;; Repository transaction page.
1086 (define repo-transaction-page-content-part1 #<<repo-transaction-page-content-part1-end
1090 repo-transaction-page-content-part1-end
1093 (define repo-transaction-page-content-part2 #<<repo-transaction-page-content-part2-end
1099 <center><div class="statusbox">
1101 repo-transaction-page-content-part2-end
1104 (define repo-transaction-page-content-part3 #<<repo-transaction-page-content-part3-end
1110 repo-transaction-page-content-part3-end
1113 (define (make-repo-transaction-page header msg status)
1114 (list common-html-header
1115 repo-page-content-part1
1117 repo-transaction-page-content-part1
1119 repo-transaction-page-content-part2
1121 repo-transaction-page-content-part3))
1123 (define (repo-transaction thunk header msg success-msg failure-msg back)
1127 (let ((content (make-repo-transaction-page header msg spinner-html)))
1129 (set-view-content 1 content #f #t)
1132 (guard-repo-transaction
1142 (make-repo-transaction-page
1145 (list "<div class=\"statussuccess\">"
1151 (thread-sleep! 2) ;; display success message for 2 seconds
1163 (define (guard-repo-transaction thunk header msg failure-msg back)
1164 (with-exception-catcher
1169 (make-repo-transaction-page
1172 (list "<div class=\"statuserror\">"
1175 (exception->error-msg e)
1180 (thread-sleep! 4) ;; display error message for 4 seconds
1185 (define spinner-html
1186 "<div class=\"spinner\"><div class=\"bar1\"></div><div class=\"bar2\"></div><div class=\"bar3\"></div><div class=\"bar4\"></div><div class=\"bar5\"></div><div class=\"bar6\"></div><div class=\"bar7\"></div><div class=\"bar8\"></div><div class=\"bar9\"></div><div class=\"bar10\"></div><div class=\"bar11\"></div><div class=\"bar12\"></div></div>")
1188 (define (exception->error-msg e)
1189 (cond ((equal? e "NotExists")
1190 "Username does not exist")
1191 ((or (equal? e "NoName")
1192 (equal? e "Illegal"))
1194 ((or (equal? e "EmptyPass")
1195 (equal? e "WrongPass")
1196 (equal? e "WrongPluginPass"))
1198 ((or (equal? e "Blocked")
1199 (equal? e "CreateBlocked"))
1200 "This user is blocked")
1201 ((equal? e "Throttled")
1202 "Too many logins... try again later")
1203 ((equal? e "failed to connect")
1204 "Could not connect to Gambit wiki")
1205 ((equal? e "script not found")
1207 ((equal? e "malformed script")
1208 "Script is not properly formatted")
1209 ((equal? e "you must first login to the Gambit wiki")
1210 "Not logged in to the Gambit wiki")
1211 ((or (equal? e "script name must be a string")
1212 (equal? e "script name must end with \".scm\"")
1213 (equal? e "script name must start with an upper case letter")
1214 (equal? e "script name must contain at least one colon")
1215 (equal? e "illegal character in script name"))
1216 "Invalid script name")
1217 ((equal? e "unknown")
1220 (with-output-to-string "" (lambda () (display-exception e))))))
1223 ;;;----------------------------------------------------------------------------
1225 ;; Repository login.
1227 (define login-page-content-part1 #<<login-page-content-part1-end
1229 <body class="login">
1232 <h1>Log in to Gambit wiki</h1>
1234 <form onSubmit="window.location='event:login:'+encodeURIComponent(document.getElementById('username').value)+':'+encodeURIComponent(document.getElementById('password').value)+':'+encodeURIComponent(document.getElementById('rememberpass').value)+':'; return false;">
1238 <td class="label">Username:</td>
1239 <td class="login"><input class="login" id="username" type="text" value="
1240 login-page-content-part1-end
1243 (define login-page-content-part2 #<<login-page-content-part2-end
1246 <td class="label">Password:</td>
1247 <td class="login"><input class="login" id="password" type="password" value="
1248 login-page-content-part2-end
1251 (define login-page-content-part3 #<<login-page-content-part3-end
1255 <td><input type="checkbox" id="rememberpass"
1256 login-page-content-part3-end
1259 (define login-page-content-part4 #<<login-page-content-part4-end
1260 />Remember my password</td>
1266 <input type="submit" class="bigbutton" value="Log in" />
1267
1268 <input type="button" class="bigbutton" value="Cancel" onClick="window.location='event:cancel';" />
1274 <center><div class="statusbox">
1276 login-page-content-part4-end
1279 (define login-page-content-part5 #<<login-page-content-part5-end
1283 If you don't have an account, you should<br/>
1284 <div class="widebutton" onClick="window.location='event:create-account';">Create an account</div><br/>
1291 login-page-content-part5-end
1294 (define (make-login-page username password remember-pass? msg)
1295 (list common-html-header
1296 login-page-content-part1
1297 (html-escape username)
1298 login-page-content-part2
1299 (html-escape password)
1300 login-page-content-part3
1301 (if remember-pass? "checked " "")
1302 login-page-content-part4
1304 login-page-content-part5))
1306 (define (make-initial-login-page)
1307 (let ((info (get-login-info)))
1314 (define (auto-login success fail)
1315 (if (wiki-logged-in?)
1317 (login success fail)))
1319 (define (login #!optional (success repl) (fail repl))
1320 (login-with-page (make-initial-login-page) success fail))
1322 (define (login-with-page page success fail)
1325 (lambda (old-event-handler)
1327 (cond ((has-prefix? event "event:login:") =>
1329 (let* ((params (get-event-parameters rest))
1330 (username (car params))
1331 (password (cadr params))
1332 (remember-pass? (equal? (caddr params) "on")))
1333 (attempt-login success
1339 ((equal? event "event:cancel")
1343 (generic-event-handler event))))))
1344 (set-view-content 1 page #f #t)
1347 (define (attempt-login success fail username password remember-pass?)
1349 (set-login-info username password remember-pass?)
1363 ((with-exception-catcher
1367 (list "<div class=\"statuserror\">"
1368 (exception->error-msg e)
1383 (wiki-login username password #t)
1391 "<div class=\"statussuccess\">You are now logged in!</div>")
1395 (thread-sleep! 2) ;; display success message for 2 seconds
1400 ;;;----------------------------------------------------------------------------
1404 (##namespace ("" open-URL))
1406 (define (open-URL str)
1408 (intf#open-URL str)))
1411 ;;;----------------------------------------------------------------------------
1417 (if (char=? #\F (string-ref str 0))
1418 (let ((script (get-script-by-name str)))
1420 (run-script str script)
1421 (let ((n (string->number (substring str 1 (string-length str)))))
1423 (##thread-interrupt! (macro-primordial-thread)))
1425 (add-input-to-textView 0 (number->string (modulo n 10))))))))
1426 (add-input-to-textView 0 str))))
1429 ;;;----------------------------------------------------------------------------
1431 ;; Start the main REPL in the primordial thread, and create a second
1432 ;; thread which executes the rest of the program (returning back from
1433 ;; the C call to ___setup) and later takes care of the interaction
1434 ;; with the ViewController.
1436 (continuation-capture
1442 (continuation-return cont #f))))
1444 ;; the primordial thread is running this...
1446 (set-navigation-bar '("REPL" "Wiki" "Help" "Edit"))
1448 (set-splash-view) ;; init the splash view
1449 (set-edit-view) ;; init the edit view
1451 (if (equal? CFBundleDisplayName "Gambit REPL dev")
1454 (if (get-pref "run-main-script")
1457 (set-pref "run-main-script" #f)
1458 (let* ((main-script-name "main")
1459 (main-script (get-script-by-name main-script-name)))
1462 (load-script main-script-name main-script)
1463 (set-pref "run-main-script" "yes"))
1466 (splash)) ;; show splash screen if main script did not work last time
1473 ;;;============================================================================