lqp

#lang scheme

(require (lib "url.ss" "net")
         (lib "string.ss" "srfi" "13")
         (planet ashinn/html-parser/html-parser))

(define (string->file s f) (let ([s (open-input-string s)]) (call-with-output-file f (lambda (f) (copy-port s f)))))
(define (file->string f) (let ([s (open-output-string)]) (call-with-input-file f (lambda (f) (copy-port f s))) (get-output-string s)))
(define (check-directory file) (make-directory* (call-with-values (lambda () (split-path file)) (lambda (a b c) a))))
(define (download url file) ;(sleep 3) ; HACK
  (display "Saving ") (display url) (display " to ") (display file) (newline)
  (when (string-index file #\/) (check-directory file))
  (when (file-exists? file) (delete-file file))
  (call-with-output-file file (lambda (file) (copy-port (get-pure-port (string->url url)) file))))
(define (download-if-not-yet url file)
  (if (file-exists? file) (begin (display "Skipping ") (display file) (newline)) (download url file)))
(define (archive-user server user)
  (define head-url (string-append server "users/" user "/"))
  (define next-link-regexp (string-append "<a href=\"(" head-url "\\?skip=[0-9]+)\">Previous ([0-9]+) Entries"))
  (define posting-link-regexp (string-append "<a href=\"(" head-url "([0-9]+\\.html))\\?mode=reply\">"))
  (define (form-file-name url)
    (let* ([skip (string-contains-ci url "/?skip=")]
           [number (if skip (substring url (+ skip 7)) "0")])
      (string-append user "/head-" number ".html")))
  (define (form-file-name-posting url)
    (let* ([skip (string-contains-ci url "/?skip=")]
           [number (if skip (substring url (+ skip 7)) "0")])
      (string-append user "/head-" number ".html")))
  (define (download-or-load url)
    (let ([file (form-file-name url)])
      (download-if-not-yet url file) (file->string file)))
  (define (find-next-link s)
    (let ([rxp (regexp-match next-link-regexp s)])
      (if rxp (cadr rxp) '())))
  (define (look-for-postings s)
    (let ([rxp (regexp-match* posting-link-regexp s)]) rxp))
  (define (explode-posting-url url)
    (let ([rxp (regexp-match posting-link-regexp url)]) (cons (cadr rxp) (caddr rxp))))
  (define (posting-url url) (car (explode-posting-url url)))
  (define (posting-file url) (string-append user "/" (cdr (explode-posting-url url))))
  (define (process-posting s) (display "..."))
  (define (download-loop url)
    (let* ([s (download-or-load url)]
           [next (find-next-link s)])
      (for-each
       (lambda (url) (process-posting (download-if-not-yet (posting-url url) (posting-file url))))
       (look-for-postings s))
      (unless (null? next) (download-loop next))))
  (download-loop head-url))

(archive-user "http://lj.rossia.org/" "lqp")