Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

502 lines (430 sloc) 15.839 kb
;;;============================================================================
;;; File: "wiki.scm"
;;; Copyright (c) 2011-2012 by Marc Feeley, All Rights Reserved.
;;;============================================================================
(##namespace ("wiki#"))
(##include "~~lib/gambit#.scm")
(##include "wiki#.scm")
(##include "url#.scm")
(##include "json#.scm")
(##include "genport#.scm")
(declare
(standard-bindings)
(extended-bindings)
(block)
(fixnum)
(not safe)
)
;;;============================================================================
;; Mediawiki methods.
(define (mediawiki-request timeout server-address req)
(let ((conn
(with-exception-catcher
(lambda (e)
(raise mediawiki-failed-to-connect-error))
(lambda ()
(open-tcp-client
(list server-address: server-address
eol-encoding: 'cr-lf))))))
(define (raise-close-conn e)
(close-port conn)
(raise e))
(define (failed-to-connect)
(raise-close-conn mediawiki-failed-to-connect-error))
(with-exception-catcher
raise-close-conn
(lambda ()
(output-port-timeout-set! conn timeout failed-to-connect)
(input-port-timeout-set! conn timeout failed-to-connect)
(print port: conn req)
(force-output conn)
(let ((status (read-line conn)))
(if (not (equal? status "HTTP/1.1 200 OK"))
(failed-to-connect)
(let loop ()
(let ((line (read-line conn)))
(if (not (string? line))
(failed-to-connect)
(if (not (equal? line "")) ;; empty line
(loop)
(let ((response (json-read conn)))
(close-port conn)
response)))))))))))
(define mediawiki-failed-to-connect-error "failed to connect")
(define (mediawiki-post timeout server-address docu params cookie)
(let ((content
(with-output-to-string
""
(lambda () (print params)))))
(mediawiki-request
timeout
server-address
(list
"POST " docu " HTTP/1.0\n"
"Host: " server-address "\n"
"Content-Type: " "application/x-www-form-urlencoded" "\n"
"Content-Length: " (string-length content) "\n"
(if cookie
(string-append
"Cookie: " cookie "\n")
"")
"\n"
content))))
(define (mediawiki-action timeout server-address docu session action attribs)
(mediawiki-post
timeout
server-address
docu
(list "action=" action
(map (lambda (a)
(list "&"
(url-encode (symbol->string (car a)))
"="
(url-encode (cdr a))))
(append attribs
'((format . "json")))))
(and session
(let* ((login
(table-ref session "login"))
(sessionid
(table-ref login "sessionid"))
(cookieprefix
(table-ref login "cookieprefix"))
(cookie
(string-append cookieprefix "_session=" sessionid)))
cookie))))
(define (mediawiki-login timeout server-address docu username password)
(let* ((user-pass
(list (cons 'lgname username)
(cons 'lgpassword password)))
(phase1
(mediawiki-action timeout
server-address
docu
#f
"login"
user-pass))
(login1
(table-ref phase1 "login" #f)))
(if (not login1)
(raise "unknown")
(let ((result1
(table-ref login1 "result")))
(cond ((equal? result1 "Success")
phase1)
((equal? result1 "NeedToken")
(let* ((token
(table-ref login1 "token"))
(phase2
(mediawiki-action timeout
server-address
docu
phase1
"login"
(cons (cons 'lgtoken token)
user-pass)))
(login2
(table-ref phase2 "login" #f)))
(if (not login2)
(raise "unknown")
(let ((result2
(table-ref login2 "result")))
(cond ((equal? result2 "Success")
phase2)
(else
(raise result2)))))))
(else
(raise result1)))))))
(define (mediawiki-query-allpages timeout server-address docu session ns)
(let loop ((from "") (rev-allpages '()))
(let* ((x
(mediawiki-action
timeout
server-address
docu
session
"query"
(list (cons 'list "allpages")
(cons 'apnamespace ns)
(cons 'apfrom from)
(cons 'aplimit "500"))))
(query
(table-ref x "query" #f)))
(if (not query)
(raise "unknown")
(let* ((allpages
(vector->list (table-ref query "allpages")))
(new-rev-allpages
(cons allpages rev-allpages))
(query-continue
(table-ref x "query-continue" #f)))
(if query-continue
(loop (table-ref (table-ref query-continue "allpages") "apfrom")
new-rev-allpages)
(map (lambda (x)
(table-ref x "title"))
(apply append (reverse new-rev-allpages)))))))))
(define (mediawiki-page-store timeout server-address docu session title text)
(let* ((x
(mediawiki-action
timeout
server-address
docu
session
"query"
(list (cons 'prop "info")
(cons 'intoken "edit")
(cons 'titles title))))
(query
(table-ref x "query" #f)))
(if (not query)
(raise "unknown")
(let* ((pages
(table-ref query "pages"))
(page1
(cdar (table->list pages)))
(edittoken
(table-ref page1 "edittoken"))
(y
(mediawiki-action
timeout
server-address
docu
session
"edit"
(list (cons 'title title)
(cons 'summary title)
(cons 'token edittoken)
(cons 'text text))))
(edit
(table-ref y "edit" #f)))
(if (not edit)
(raise "unknown")
(let ((result
(table-ref edit "result")))
(if (not (equal? result "Success"))
(raise result))))))))
(define (mediawiki-page-fetch timeout server-address docu session title)
(let* ((x
(mediawiki-action
timeout
server-address
docu
session
"query"
(list (cons 'prop "revisions")
(cons 'titles title)
(cons 'rvprop "content"))))
(query
(table-ref x "query" #f)))
(if (not query)
(raise "unknown")
(let* ((pages
(table-ref query "pages"))
(page1
(cdar (table->list pages)))
(revisions
(table-ref page1 "revisions" #f)))
(if (not revisions)
(raise "script not found")
(let* ((revision1
(vector-ref revisions 0))
(content
(cdar (table->list revision1))))
content))))))
(define (mediawiki-page-remove timeout server-address docu session title)
(let* ((x
(mediawiki-action
timeout
server-address
docu
session
"query"
(list (cons 'prop "info")
(cons 'intoken "delete")
(cons 'titles title))))
(query
(table-ref x "query" #f)))
(if (not query)
(raise "script not found")
(let* ((pages
(table-ref query "pages"))
(page1
(cdar (table->list pages)))
(deletetoken
(table-ref page1 "deletetoken"))
(y
(mediawiki-action
timeout
server-address
docu
session
"delete"
(list (cons 'title title)
(cons 'summary title)
(cons 'token deletetoken))))
(delete
(table-ref y "delete" #f)))
(if (not delete)
(raise "script not found"))))))
;;;----------------------------------------------------------------------------
;; Gambit wiki methods.
(define wiki-session #f)
(define wiki-timeout #f)
(define wiki-server-address #f)
(define wiki-root #f)
(define wiki-api #f)
(define wiki-script-ns #f)
(define wiki-script-prefix #f)
(define wiki-script-tags #f)
(set! wiki-timeout 15)
(set! wiki-server-address "dynamo.iro.umontreal.ca:80")
(set! wiki-root "/~gambit/wiki")
(set! wiki-api "/api.php")
(set! wiki-script-ns "102")
(set! wiki-script-prefix "Script:")
(set! wiki-script-tags '("<schemecode>" . "</schemecode>"))
(define (wiki-login username password #!optional (force? #f))
(if (or (not (wiki-logged-in?))
force?)
(let ((session
(mediawiki-login
wiki-timeout
wiki-server-address
(string-append wiki-root wiki-api)
username
password)))
(set! wiki-session session)))
wiki-session)
(define (wiki-logout)
(set! wiki-session #f))
(define (wiki-script-list)
(wiki-logged-in-verify)
(let ((x
(mediawiki-query-allpages
wiki-timeout
wiki-server-address
(string-append wiki-root wiki-api)
wiki-session
wiki-script-ns)))
(let loop ((lst x) (rev-scripts '()))
(if (pair? lst)
(let ((str (car lst)))
(let ((len (string-length str))
(prefix-len (string-length wiki-script-prefix)))
(loop (cdr lst)
(if (or (< len prefix-len)
(not (string=? (substring str 0 prefix-len)
wiki-script-prefix)))
rev-scripts
(cons (substring str prefix-len len)
rev-scripts)))))
(reverse rev-scripts)))))
(define (wiki-script-store script-name source-text)
(wiki-script-name-verify script-name)
(wiki-logged-in-verify)
(let ((text
(string-append
(car wiki-script-tags)
source-text
(cdr wiki-script-tags))))
(mediawiki-page-store
wiki-timeout
wiki-server-address
(string-append wiki-root wiki-api)
wiki-session
(string-append wiki-script-prefix script-name)
text)))
(define (wiki-script-fetch script-name)
(wiki-script-name-verify script-name)
(wiki-logged-in-verify)
(let ((text
(mediawiki-page-fetch
wiki-timeout
wiki-server-address
(string-append wiki-root wiki-api)
wiki-session
(string-append wiki-script-prefix script-name))))
(let* ((tag1 (car wiki-script-tags))
(tag2 (cdr wiki-script-tags))
(tag1-len (string-length tag1))
(tag2-len (string-length tag2))
(len (string-length text)))
(if (or (< len (+ tag1-len tag2-len))
(not (string=? tag1 (substring text 0 tag1-len)))
(not (string=? tag2 (substring text (- len tag2-len) len))))
(raise "malformed script")
(let ((source-text (substring text tag1-len (- len tag2-len))))
source-text)))))
(define (wiki-script-remove script-name)
(wiki-script-name-verify script-name)
(wiki-logged-in-verify)
(mediawiki-page-remove
wiki-timeout
wiki-server-address
(string-append wiki-root wiki-api)
wiki-session
(string-append wiki-script-prefix script-name)))
(define (wiki-logged-in?)
(not (not wiki-session)))
(define (wiki-logged-in-verify)
(if (not (wiki-logged-in?))
(raise "you must first login to the Gambit wiki")))
(define (wiki-script-name-verify script-name)
(if (not (eq? (wiki-script-name-type script-name) 'wiki))
(raise "illegal wiki script name")))
(define (wiki-script-name-type script-name)
(if (not (string? script-name))
#f
(let ((len (string-length script-name)))
(if (= len 0)
#f
(let ((has-scm-ext? #f)
(has-colon? #f)
(has-space? #f))
(let loop ((i (- (if (or (< len 4)
(not (string=? ".scm"
(substring script-name (- len 4) len))))
len
(begin
(set! has-scm-ext? #t)
(- len 4)))
1)))
(if (< i 0)
(cond ((and has-scm-ext?
has-colon?
(let ((c (string-ref script-name 0)))
(and (char>=? c #\A) (char<=? c #\Z))))
'wiki)
((and has-scm-ext?
(not has-colon?)
(not has-space?))
'file)
((not has-space?)
'script)
(else
#f))
(let ((c (string-ref script-name i)))
(cond ((char=? c #\:)
(set! has-colon? #t)
(loop (- i 1)))
((char=? c #\space)
(set! has-space? #t)
(loop (- i 1)))
((or (and (char>=? c #\a) (char<=? c #\z))
(and (char>=? c #\A) (char<=? c #\Z))
(and (char>=? c #\0) (char<=? c #\9))
(memv c '(#\- #\.)))
(loop (- i 1)))
(else
#f))))))))))
;;;----------------------------------------------------------------------------
(define (http-get docu #!optional (server-address wiki-server-address))
(let ((port (open-tcp-client server-address)))
(print port: port "GET " docu "\r\n\r\n")
(force-output port)
(let* ((genport-in (genport-native-input-port->genport port))
(u8vect (genport-read-u8vector genport-in)))
(close-port port)
u8vect)))
;;;============================================================================
Jump to Line
Something went wrong with that request. Please try again.