USE: unparser
USE: logging
USE: listener
+USE: url-encoding
: <browser> ( allow-edit? vocab word -- )
#! An object for storing the current browser
] when*
] catch ;
+: browser-url ( vocab word -- url )
+ #! Given a vocabulary and word as strings, return a browser
+ #! URL which, when requested, will display the source to that
+ #! word.
+ [
+ ".?word=" , url-encode ,
+ "&vocab=" , url-encode ,
+ ] make-string ;
+
: browse ( <browser> -- )
#! Display a Smalltalk like browser for exploring/modifying words.
[
] extend
] bind [
"allow-edit?" get
- "vocabs" get
- "words" get
+ "vocabs" get
+ "words" get
"eval" get dup [ "vocabs" get swap eval-string ] [ drop ] ifte
+ [
+ "vocabs" get "words" get browser-url forward-to-url
+ ] show
] bind <browser>
] forever ;
: browser-responder ( allow-edit? -- )
#! Start the Smalltalk-like browser.
- "browser" f <browser> browse ;
+ "query" get dup [
+ dup >r "vocab" swap assoc r> "word" swap assoc
+ ] [
+ drop "browser" f
+ ] ifte <browser> browse ;
"browser" [ f browser-responder ] install-cont-responder
-!"browser-edit" [ t browser-responder ] install-cont-responder
+! "browser-edit" [ t browser-responder ] install-cont-responder
USE: url-encoding
USE: unparser
USE: hashtables
-
+USE: parser
USE: prettyprint
USE: inspector
: get-random-id ( -- id )
#! Generate a random id to use for continuation URL's
- [ 16 [ random-digit unparse , ] times ] make-string ;
+ [ 32 [ random-digit unparse , ] times ] make-string str>number 36 >base ;
: continuation-table ( -- <namespace> )
#! Return the global table of continuations
#! Get the continuation item associated with the id.
continuation-table [ get ] bind ;
+: id>url ( id -- string )
+ #! Convert the continuation id to an URL suitable for
+ #! embedding in an HREF or other HTML.
+ url-encode "?id=" swap cat2 ;
+
DEFER: show
: expired-page-handler ( alist -- )
#! stream. Return the string on exit.
1024 <string-output> dup >r swap with-stream r> stream>str ;
+: forward-to-url ( url -- )
+ #! When executed inside a 'show' call, this will force a
+ #! HTTP 302 to occur to instruct the browser to forward to
+ #! the request URL.
+ [
+ "HTTP/1.1 302 Document Moved\nLocation: " , ,
+ "\nContent-Length: 0\nContent-Type: text/plan\n\n" ,
+ ] make-string call-exit-continuation ;
+
: redirect-to-here ( -- )
#! Force a redirect to the client browser so that the browser
#! goes to the current point in the code. This forces an URL
] [
[
t swap register-continuation
- [ "HTTP/1.1 302 Document Moved\nLocation: " , , "\n" ,
+ [ "HTTP/1.1 302 Document Moved\nLocation: " , id>url , "\n" ,
"Content-Length: 0\nContent-Type: text/plain\n\n" , ] make-string
call-exit-continuation
] callcc1 drop
store-callback-cc
redirect-enabled? [ redirect-to-here ] when
[
- t swap register-continuation swap
+ t swap register-continuation id>url swap
[ serving-html ] car swons with-string-stream
call-exit-continuation
] callcc1
: cont-get-responder ( id-or-f -- )
#! httpd responder that retrieves a continuation and calls it.
+ drop
+ "id" "query" get assoc
dup f-or-"" [
#! No continuation id given
drop "root-continuation" get dup [
#! id and calls it with the POST data as a hashtable on the top
#! of the stack.
[
- "response" get alist>hash swap resume-continuation
+ drop
+ "response" get alist>hash
+ "id" "query" get assoc resume-continuation
] with-exit-continuation
print drop ;
#! back to the most recent 'show' call (via the callback-cc).
#! The text of the link will be the 'text' argument on the
#! stack.
- <a href= callback-quot t swap register-continuation a> write </a> ;
+ <a href= callback-quot t swap register-continuation id>url a> write </a> ;
: with-new-session ( quot -- )
#! Each cont-responder is bound inside their own
! eg.
! <cont-test-state> [ test-cont-responder ] test-cont-function
! => HTTP/1.1 302 Document Moved
-! Location: 8506502852110820
+! Location: ?id=8506502852110820
! Content-Length: 0
! Content-Type: text/plain
!
! Content-Type: text/html
!
! <html><head><title>Page one</title></head><body>
-! <h1>Page one</h1><a href='5431597582800278'>Next</a>
+! <h1>Page one</h1><a href='?id=5431597582800278'>Next</a>
! </body></html>
!
! "5431597582800278" f test-cont-click
! => HTTP/1.1 302 Document Moved
-! Location: 7944183606904129
+! Location: ?id=7944183606904129
! Content-Length: 0
! Content-Type: text/plain
!
!
! <html><head><title>Enter your name</title></head>
! <body><h1>Enter your name</h1>
-! <form method='post'action='8503790719833723'>
-! Name: <input type='text'name='name'size='20'>
-! <input type='submit'value='Ok'>
+! <form method='post' action='?id=8503790719833723'>
+! Name: <input type='text' name='name'size='20'>
+! <input type='submit' value='Ok'>
! </form></body></html>
!
-! "8503790719833723" [ [ "name" | "Chris" ] ] alist>hash test-cont-click
+! "8503790719833723" [ [[ "name" "Chris" ]] ] alist>hash test-cont-click
! => HTTP/1.1 302 Document Moved
-! Location: 8879727708050260
+! Location: ?id=8879727708050260
! Content-Length: 0
! Content-Type: text/plain
!
!
! <html><head><title>Hello Chris</title></head>
! <body><h1>Hello Chris</h1>
-! <a href='0937854264503953'>Next</a>
+! <a href='?id=0937854264503953'>Next</a>
! </body></html>
!
! etc.
[
"js/liveUpdater.js" get-live-updater-js write
] show
- ] register-continuation ;
+ ] register-continuation id>url ;
: include-live-updater-js ( -- )
#! Write out the HTML script to include the live updater
"document.getElementById('" write
write
"').onclick=liveUpdaterUri('" write
- register-live-anchor-quot write
+ register-live-anchor-quot id>url write
"');" write
</script> ;
"liveSearch('" write
write
"', '" write
- register-live-search-quot write
+ register-live-search-quot id>url write
"');" write
</script> ;
: todo-stylesheet-url ( -- url )
#! Generate an URL for the stylesheet.
- t [ [ drop todo-stylesheet write ] show ] register-continuation ;
+ t [ [ drop todo-stylesheet write ] show ] register-continuation id>url ;
: include-todo-stylesheet ( -- )
#! Generate HTML to include the todo stylesheet
continuation based system will sequentially display each page. The
back button, browser window cloning, etc will all continue to work.
-You'll notice the URL's in the browser have a number at the end of
-them. This is the 'continuation identifier' which is like a session id
-except that it identifies not just the data you have stored but your
-location within the responder as well.
+You'll notice the URL's in the browser have an 'id' query parameter with
+a number as its value. This is the 'continuation identifier' which is
+like a session id except that it identifies not just the data you have
+stored but your location within the responder as well.
Forms and POST data
===================
<cont-test-state> [ subroutine-example1 ] test-cont-function
=>
HTTP/1.1 302 Document Moved
- Location: 8209741119458310
+ Location: ?id=8209741119458310
Content-Length: 0
Content-Type: text/plain
Content-Type: text/html
<html><head><title>Subroutine Example 1</title></head>
<body><p>Please select:
- <ol><li><a href='7687398605200513'>Flow1</a></li>
- <li><a href='7856272029924613'>Flow2</a></li>
- <li><a href='4909116160485714'>Flow3</a></li>
+ <ol><li><a href='?id=7687398605200513'>Flow1</a></li>
+ <li><a href='?id=7856272029924613'>Flow2</a></li>
+ <li><a href='?id=4909116160485714'>Flow3</a></li>
</ol>
</p>
</body>
<cont-test-state> [ post-example1 ] test-cont-function
=>
HTTP/1.1 302 Document Moved
- Location: 5829759941409535
+ Location: ?id=5829759941409535
Content-Length: 0
Content-Type: text/plain
<html><head><title>Please enter your name</title></head>
<body>
- <form action='5456539333180428' method='post'>
+ <form action='?id=5456539333180428' method='post'>
<p>Please enter your name:
<input type='text'size='20'name='username'>
<input type='submit'value='Ok'>
! Not all functions have been wrapped yet. Only those directly involving
! executing SQL calls and obtaining results.
!
-! TODO: Do I have to free stuctures like <sqlite3> and <char*>, etc
-! or do they get freed on garbage collection?
-! How do I do pointers to pointers? Use the 'indirect' trick?
-!
IN: sqlite
USE: kernel
USE: alien
: SQLITE_TRANSIENT -1 ;
: sqlite3_open ( filename sqlite3-indirect -- result )
- "int" "sqlite" "sqlite3_open" [ "char*" "sqlite3-indirect*" ] alien-invoke ;
+ "int" "sqlite" "sqlite3_open" [ "char*" "sqlite3-indirect*" ] alien-invoke ; compiled
: sqlite3_close ( db -- )
- "int" "sqlite" "sqlite3_close" [ "sqlite3*" ] alien-invoke ;
+ "int" "sqlite" "sqlite3_close" [ "sqlite3*" ] alien-invoke ; compiled
: sqlite3_prepare ( db sql sql-len sqlite3-stmt-indirect tail -- result )
- "int" "sqlite" "sqlite3_prepare" [ "sqlite3*" "char*" "int" "sqlite3-stmt-indirect*" "char*-indirect*" ] alien-invoke ;
+ "int" "sqlite" "sqlite3_prepare" [ "sqlite3*" "char*" "int" "sqlite3-stmt-indirect*" "char*-indirect*" ] alien-invoke ; compiled
: sqlite3_finalize ( stmt -- result )
- "int" "sqlite" "sqlite3_finalize" [ "sqlite3-stmt*" ] alien-invoke ;
+ "int" "sqlite" "sqlite3_finalize" [ "sqlite3-stmt*" ] alien-invoke ; compiled
: sqlite3_reset ( stmt -- result )
- "int" "sqlite" "sqlite3_reset" [ "sqlite3-stmt*" ] alien-invoke ;
+ "int" "sqlite" "sqlite3_reset" [ "sqlite3-stmt*" ] alien-invoke ; compiled
: sqlite3_step ( stmt -- result )
- "int" "sqlite" "sqlite3_step" [ "sqlite3-stmt*" ] alien-invoke ;
+ "int" "sqlite" "sqlite3_step" [ "sqlite3-stmt*" ] alien-invoke ; compiled
: sqlite3_bind_blob ( stmt index pointer len destructor -- result )
- "int" "sqlite" "sqlite3_bind_blob" [ "sqlite3-stmt*" "int" "void*" "int" "int" ] alien-invoke ;
+ "int" "sqlite" "sqlite3_bind_blob" [ "sqlite3-stmt*" "int" "void*" "int" "int" ] alien-invoke ; compiled
: sqlite3_bind_int ( stmt index int -- result )
- "int" "sqlite" "sqlite3_bind_int" [ "sqlite3-stmt*" "int" "int" ] alien-invoke ;
+ "int" "sqlite" "sqlite3_bind_int" [ "sqlite3-stmt*" "int" "int" ] alien-invoke ; compiled
: sqlite3_bind_null ( stmt index -- result )
- "int" "sqlite" "sqlite3_bind_null" [ "sqlite3-stmt*" "int" ] alien-invoke ;
+ "int" "sqlite" "sqlite3_bind_null" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled
: sqlite3_bind_text ( stmt index text len destructor -- result )
- "int" "sqlite" "sqlite3_bind_text" [ "sqlite3-stmt*" "int" "char*" "int" "int" ] alien-invoke ;
+ "int" "sqlite" "sqlite3_bind_text" [ "sqlite3-stmt*" "int" "char*" "int" "int" ] alien-invoke ; compiled
: sqlite3_column_count ( stmt -- count )
- "int" "sqlite" "sqlite3_column_count" [ "sqlite3-stmt*" ] alien-invoke ;
+ "int" "sqlite" "sqlite3_column_count" [ "sqlite3-stmt*" ] alien-invoke ; compiled
: sqlite3_column_blob ( stmt col -- void* )
- "void*" "sqlite" "sqlite3_column_blob" [ "sqlite3-stmt*" "int" ] alien-invoke ;
+ "void*" "sqlite" "sqlite3_column_blob" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled
: sqlite3_column_bytes ( stmt col -- int )
- "int" "sqlite" "sqlite3_column_bytes" [ "sqlite3-stmt*" "int" ] alien-invoke ;
+ "int" "sqlite" "sqlite3_column_bytes" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled
: sqlite3_column_decltype ( stmt col -- string )
- "char*" "sqlite" "sqlite3_column_decltype" [ "sqlite3-stmt*" "int" ] alien-invoke ;
+ "char*" "sqlite" "sqlite3_column_decltype" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled
: sqlite3_column_int ( stmt col -- int )
- "int" "sqlite" "sqlite3_column_int" [ "sqlite3-stmt*" "int" ] alien-invoke ;
+ "int" "sqlite" "sqlite3_column_int" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled
: sqlite3_column_name ( stmt col -- string )
- "char*" "sqlite" "sqlite3_column_name" [ "sqlite3-stmt*" "int" ] alien-invoke ;
+ "char*" "sqlite" "sqlite3_column_name" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled
: sqlite3_column_text ( stmt col -- string )
- "char*" "sqlite" "sqlite3_column_text" [ "sqlite3-stmt*" "int" ] alien-invoke ;
+ "char*" "sqlite" "sqlite3_column_text" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled
: sqlite3_column_type ( stmt col -- int )
- "int" "sqlite" "sqlite3_column_type" [ "sqlite3-stmt*" "int" ] alien-invoke ;
-
-\ sqlite3_open compile
-\ sqlite3_close compile
-\ sqlite3_prepare compile
-\ sqlite3_finalize compile
-\ sqlite3_reset compile
-\ sqlite3_bind_blob compile
-\ sqlite3_bind_int compile
-\ sqlite3_bind_null compile
-\ sqlite3_bind_text compile
-\ sqlite3_step compile
-\ sqlite3_column_count compile
-\ sqlite3_column_blob compile
-\ sqlite3_column_bytes compile
-\ sqlite3_column_decltype compile
-\ sqlite3_column_int compile
-\ sqlite3_column_name compile
-\ sqlite3_column_text compile
-\ sqlite3_column_type compile
+ "int" "sqlite" "sqlite3_column_type" [ "sqlite3-stmt*" "int" ] alien-invoke ; compiled
! High level sqlite routines
: sqlite-check-result ( result -- )
#! from zero, as a string.
sqlite3_column_text ;
-: (sqlite-each)
- "statement" get sqlite3_step dup SQLITE_ROW = [
- drop
- "statement" get "quot" get call (sqlite-each)
- ] [
+: step-complete? ( step-result -- bool )
+ #! Return true if the result of a sqlite3_step is
+ #! such that the iteration has completed (ie. it is
+ #! SQLITE_DONE). Throw an error if an error occurs.
+ dup SQLITE_ROW = [
+ drop f
+ ] [
dup SQLITE_DONE = [
- drop
+ drop t
] [
sqlite-check-result
- ] ifte
+ ] ifte
] ifte ;
: sqlite-each ( statement quot -- )
- #! Excecute the SQL statement, and call the quotation for
+ #! Execute the SQL statement, and call the quotation for
#! each row returned from executing the statement with the
#! statement on the top of the stack.
- #! TODO: Implement without named parameters
- <namespace> [
- "quot" set
- "statement" set
- (sqlite-each)
- ] bind ;
+ over sqlite3_step step-complete? [
+ 2drop
+ ] [
+ 2dup 2slip sqlite-each
+ ] ifte ;
+! For comparison, here is the linrec implementation of sqlite-each
+! [ drop sqlite3_step step-complete? ]
+! [ 2drop ]
+! [ 2dup 2slip ]
+! [ ] linrec ;
\ No newline at end of file
sqlite-finalize
sqlite-close ;
+: run-test2 ( -- )
+ "test.db" sqlite-open
+ dup "select * from test" sqlite-prepare
+ dup [ show-people ] ;
+
run-test
\ No newline at end of file
projects / factor.git / commitdiff