Initial import from SVN

fs-persist/data-manager.ss

@@ -0,0 +1,31 @@
+#lang web-server
+; XXX: You could lock this or put it in a kill-safe thread.
+(define-struct file-manager (write current))
+
+(define (file-manager-load read write)
+  (make-file-manager write (read)))
+(define (file-manager-load/path read write path)
+  (file-manager-load (lambda () (read path))
+                     (lambda (o) (write path o))))
+
+(define (file-manager-ize/write-op wop)
+  (lambda (fm . args)
+    (define old (file-manager-current fm))
+    (define new (apply wop old args))
+    (set-file-manager-current! fm new)
+    ((file-manager-write fm) new)))
+
+(define (file-manager-ize/read-op rop)
+  (lambda (fm . args)
+    (apply rop (file-manager-current fm) args)))
+
+(define (file-manager/parameter f p)
+  (lambda args
+    (apply f (p) args)))
+
+(provide file-manager?
+         file-manager-load
+         file-manager-load/path
+         file-manager-ize/write-op
+         file-manager-ize/read-op
+         file-manager/parameter)

fs-persist/fs-persist.ss

@@ -0,0 +1,53 @@
+#lang web-server
+(require (lib "file.ss")
+         (lib "list.ss"))
+(require "fscache.ss")
+(provide read-path
+         read-path/default
+         write-path
+         bind-to-file
+         bind-within-directory)
+
+;; Utility
+(define (dirname p)
+  (apply build-path
+         (reverse (rest (reverse (explode-path (build-path p)))))))
+
+;; Caching
+(define cache (make-fscache))
+(define with-input-from-file/cache (make-with-input-from-file cache))
+(define with-output-to-file/cache (make-with-output-to-file cache))
+
+;; Generators
+(define (read-path p)
+  (with-input-from-file/cache p read))
+(define (read-path/default p fail-thunk)
+  (with-handlers ([exn:fail? (lambda (e) (fail-thunk))])
+    (with-input-from-file/cache p read)))  
+(define (write-path p v)
+  (make-directory* (dirname p))
+  (with-output-to-file/cache p (lambda () (write v)) 'truncate))
+(define (bind-to-file path-f default-t)
+  (values (lambda args
+            (read-path/default
+             (apply path-f args)
+             default-t))
+          (lambda args
+            (define new (first (reverse args)))
+            (define pargs (reverse (rest (reverse args))))
+            (write-path
+             (apply path-f pargs)
+             new))))
+(define (bind-within-directory directory-fn)
+  (define (item-dir . args)
+    (define new (first (reverse args)))
+    (define pargs (reverse (rest (reverse args))))
+    (string-append (apply directory-fn pargs) new "/"))
+  (values directory-fn
+          (lambda args
+            (map path->string 
+                 (with-handlers ([exn:fail? (lambda _ empty)])
+                   (directory-list (apply directory-fn args)))))
+          item-dir
+          (lambda args
+            (directory-exists? (apply item-dir args)))))

fs-persist/fscache.ss

@@ -0,0 +1,124 @@
+#lang web-server
+(require (lib "plt-match.ss")
+         (lib "list.ss")
+         (lib "etc.ss")
+         (lib "file.ss"))
+(provide fscache?
+         (rename-out [ext:make-fscache make-fscache])
+         make-with-input-from-file
+         make-with-output-to-file)
+
+(define-struct fscache (channel manager))
+
+(define-struct request (reply-channel))
+(define-struct (request:lookup request) (path))
+(define-struct (request:replace request) (path new-bytes))
+(define-struct (request:prune request) (proc))
+
+(define-struct return ())
+(define-struct (failure return) (exn))
+(define-struct (success return) (value))
+(define return-value
+  (match-lambda
+    [(struct success (v))
+     v]
+    [(struct failure (e))
+     (raise e)]))
+
+; ext:make-fscache : -> fscache?
+(define (ext:make-fscache)
+  (define cache-table
+    (make-hash-table 'equal))
+  (define (lookup p)
+    (define last-mod
+      (file-or-directory-modify-seconds p))
+    (define cur
+      (hash-table-get cache-table p
+                      (lambda ()
+                        (define new
+                          (list (file-or-directory-modify-seconds p)
+                                (with-input-from-file p
+                                  (lambda ()
+                                    (read-bytes (file-size p))))))
+                        (hash-table-put! cache-table p new)
+                        new)))
+    (if (> last-mod (first cur))
+        (begin (hash-table-remove! cache-table p)
+               (lookup p))
+        cur))
+  (define (replace p nb)
+    (hash-table-remove! cache-table p)
+    (with-output-to-file p (lambda () (display nb)) 'truncate)
+    #t)
+  (define request-channel (make-channel))
+  (define manager
+    (thread/suspend-to-kill
+     (lambda ()
+       (let loop ()
+         (sync
+          (handle-evt
+           request-channel
+           (match-lambda
+             [(struct request:lookup (rc p))
+              (with-handlers ([exn:fail? (lambda (e)
+                                      (channel-put rc (make-failure e)))])
+                (channel-put rc (make-success (second (lookup p)))))
+              (loop)]
+             [(struct request:replace (rc p nb))
+              (with-handlers ([exn:fail? (lambda (e)
+                                      (channel-put rc (make-failure e)))])
+                (channel-put rc (make-success (replace p nb))))
+              (loop)])))))))
+  (make-fscache request-channel manager))
+
+; fscache-lookup : fscache? path? -> bytes?
+(define (fscache-lookup an-fscache path)
+  (define reply-channel (make-channel))
+  (thread-resume (fscache-manager an-fscache))
+  (channel-put (fscache-channel an-fscache)
+               (make-request:lookup reply-channel path))
+  (return-value (channel-get reply-channel)))
+
+; fscache-replace : fscache? path? bytes? -> void
+(define (fscache-replace an-fscache path bytes)
+  (define reply-channel (make-channel))
+  (thread-resume (fscache-manager an-fscache))
+  (channel-put (fscache-channel an-fscache)
+               (make-request:replace reply-channel path bytes))
+  (return-value (channel-get reply-channel))
+  (void))
+
+; make-with-input-from-file : fscache? -> path? (-> alpha) [ignored] -> alpha
+(define ((make-with-input-from-file an-fscache) path thunk . wiff-args)
+  (define input
+    (open-input-bytes (fscache-lookup an-fscache (normalize-path path))))
+  (parameterize ([current-input-port input])
+    (thunk)))
+
+; make-with-output-to-file : fscache? -> path? (-> alpha) [ignored] -> alpha
+; XXX: Should enforce that you are not using 'append, or implement it correctly.
+(define ((make-with-output-to-file an-fscache) path thunk . wotf-args)
+  (define output-bytes (open-output-bytes))
+  ; Not in tail-position. This seems reasonable, however.
+  (begin0
+    (parameterize ([current-output-port output-bytes])
+      (thunk))
+    (fscache-replace an-fscache
+                     (normalize-path path)
+                     (get-output-bytes output-bytes))))
+
+(define (test)
+  (define an-fscache (ext:make-fscache))
+  (define with-input-from-file (make-with-input-from-file an-fscache))
+  (define with-output-to-file (make-with-output-to-file an-fscache))
+  (define path "/tmp/blahblahblah")
+  (with-output-to-file path
+    (lambda () (write #t)))
+  (build-list 100
+              (lambda (i)
+                (with-input-from-file path read)))
+  (read)
+  (build-list 100
+              (lambda (i)
+                (with-input-from-file path read)))
+  (void))

fs-persist/opcache.ss

@@ -0,0 +1,24 @@
+#lang web-server
+(require (lib "list.ss"))
+(provide (all-defined-out))
+
+; cache-op : proc? path? -> proc?
+(define (cache-op op cache-path)
+  (define the-ht (make-hash-table 'equal))
+  (define (write-cache!)
+    (with-output-to-file cache-path
+      (lambda ()
+        (write (hash-table-map the-ht list)))
+      'truncate/replace))
+  (for-each (lambda (k+v)
+              (hash-table-put! the-ht (first k+v) (second k+v)))
+            (if (file-exists? cache-path)
+                (with-input-from-file cache-path read)
+                empty))                    
+  (lambda key
+    (hash-table-get the-ht key
+                    (lambda ()
+                      (define value (apply op key))
+                      (hash-table-put! the-ht key value)
+                      (write-cache!)
+                      value))))

lib/identity.ss

@@ -0,0 +1,10 @@
+#lang web-server
+(require (lib "plt-match.ss"))
+(provide (all-defined-out))
+
+(define-struct an-identity () #:prefab)
+(define-struct (identity:reference an-identity) (refcode) #:prefab)
+(define-struct (identity:internal an-identity) (csid) #:prefab)
+(define-struct (identity:applicant an-identity) (id) #:prefab)
+
+(define current-identity (make-web-cell #f))

lib/pdftk.ss

@@ -0,0 +1,137 @@
+#lang web-server
+(require (lib "process.ss")
+         (lib "list.ss")
+         (only-in (lib "file.ss") make-directory*)
+         (planet "hash-store.ss" ("jaymccarthy" "hash-store.plt" 1)))
+(require "../lib/resume-lib.ss"
+         "../lib/util.ss"
+         "../lib/resume-data.ss"
+         "../lib/resume-data-util.ss")
+(provide update-aggregate!
+         create-multi-applicant-aggregate!)
+
+(define (merge new . olds)
+  (apply process*/ports 
+         (current-output-port) (open-input-string (string)) (current-error-port)
+         (pdftk-path)
+         (append olds
+                 (list "cat" "output" new))))
+
+(define (create-multi-applicant-aggregate! sanids letters?)
+  (define filename
+    (string-append
+     (bytes->string/utf-8
+      (SHA1
+       (string->bytes/utf-8
+        (apply string-append (if letters? "yes" "no") sanids))))
+     ".pdf"))
+  (define path (string-append (aggregate/public-directory) filename))
+  (make-directory* (aggregate/public-directory))
+  (apply merge path
+         (map (lambda (sanid)
+                (unless (and (file-exists? (applicant/aggregate-tex sanid))
+                             (file-exists? (applicant/aggregate-letters-tex sanid)))
+                  (update-aggregate! sanid #t)
+                  (update-aggregate! sanid #f))
+                (if letters?
+                    (applicant/aggregate-letters sanid)
+                    (applicant/aggregate sanid)))
+              sanids))
+  path)
+
+(define (aggregate-latex sanid letters?)
+  (string-append
+   (format #<<END
+\documentclass{article}
+\usepackage{type1cm} 
+\usepackage{graphics}
+\usepackage{pdfpages}
+\usepackage[pdftex]{hyperref}
+\pdfoptionpdfminorversion=7
+\hypersetup{
+pdfauthor = {Resume},
+pdftitle = {~a ~a},
+pdfsubject = {Faculty Applications},
+pdfkeywords = {~a}}
+\begin{document}
+\pdfbookmark[1]{~a ~a}{~a}
+\begin{center}
+{\bf \fontsize{150}{50}\selectfont X} \\
+~~ \\
+~~ \\
+~~ \\
+~~ \\
+~~ \\
+~~ \\
+{\bf \fontsize{60}{50}\selectfont ~a ~a} \\
+~~ \\
+~~ \\
+~~ \\
+~~ \\
+~~ \\
+~~ \\
+{\bf \fontsize{150}{50}\selectfont X}
+\end{center}
+\newpage
+
+END
+           (applicant-fname sanid) (applicant-lname sanid)             
+           (applicant-areas/string sanid)
+           (applicant-fname sanid) (applicant-lname sanid)
+           sanid
+           (applicant-fname sanid) (applicant-lname sanid))
+   (apply string-append
+          (map (lambda (l f)
+                 (format #<<END
+\pdfbookmark[2]{~a}{~a_ts}
+\includepdf[pages=-]{~a}
+
+END
+                         l sanid (f sanid)))
+               (list "Cover Letter"
+                     "CV"
+                     "Research Statement"
+                     "Teaching Statement")
+               (list applicant/cover-letter 
+                     applicant/cv
+                     applicant/research-stmt
+                     applicant/teaching-stmt)))
+   (if (not letters?)
+       ""
+       (string-append
+        (format #<<END
+\pdfbookmark[2]{Letter Writers}{~a_lw}
+
+END
+                sanid)
+        (apply string-append
+               (map (lambda (refcode)
+                      (if (file-exists? (applicant/reference-letter sanid refcode))
+                          (format
+                           #<<END
+\pdfbookmark[3]{~a}{~a}
+\includepdf[pages=-]{~a}
+
+END
+                           (applicant-letter-writer-name sanid refcode)
+                           refcode (applicant/reference-letter sanid refcode))
+                          ""))
+                    (applicant-letter-writers sanid)))))
+   #<<END
+\end{document}
+
+END
+   ))
+
+(define (update-aggregate! sanid letters?)
+  (define filename
+    (if letters?
+        (applicant/aggregate-letters-tex sanid)
+        (applicant/aggregate-tex sanid)))
+  (with-output-to-file filename
+    (lambda ()
+      (display (aggregate-latex sanid letters?)))
+    #:exists 'truncate/replace)
+  (parameterize ([current-directory (applicant/public-directory sanid)])
+    (system* (pdflatex-path) filename)
+    (system* (pdflatex-path) filename)))