source: project/release/4/nemo/trunk/scripts/model-ci.scm @ 28039

Last change on this file since 28039 was 28039, checked in by Ivan Raikov, 8 years ago

nemo: added DeSouza? 2010 variant of Golgi model

File size: 10.5 KB
Line 
1
2;;
3;; Continuous integration scripts for model development.
4;;
5
6(use matchable data-structures posix files tcp srfi-1 regex setup-api uri-generic awful sendfile)
7(require-library spiffy intarweb)
8(import (only spiffy current-request current-response write-logged-response 
9              with-headers mime-type-map root-path file-extension->mime-type)
10        (only intarweb response-port request-method  request-headers
11              header-values header-value etag-matches? response-has-message-body-for-request?
12              ))
13
14(enable-sxml #t)
15
16
17(define v:quiet 0)
18(define v:info  1)
19(define v:debug 2)
20
21(define verbose (make-parameter v:info))
22
23(define http-user-agent "nemo-model")
24
25(define prefix (make-parameter (get-environment-variable "HOME")))
26
27(define (version-path)
28  (make-pathname (prefix) "/build/model-ci.versions"))
29 
30(define (build-location-prefix)
31  (make-pathname prefix "/build/model-ci"))
32
33(define (build-location model-name version) 
34  (make-pathname (build-location-prefix) 
35                 (sprintf "~A.~A" model-name version)))
36
37(define (build-log-path model-name version) 
38  (make-pathname (build-location model-name version) 
39                 (string-append "~A-log." model-name version)) )
40
41(define (build-lock-path model-name version) 
42  (make-pathname (build-location model-name version) 
43                 (string-append "build-lock." version)) )
44
45(define (tests-lock-path model-name version) 
46  (make-pathname (build-location model-name version) 
47                 (string-append "tests-lock." version)) )
48
49(define (tests-log-path model-name version) 
50  (make-pathname (build-location model-name version) 
51                 (string-append "tests-log." version)) )
52
53(define (plots-lock-path model-name version) 
54  (make-pathname (build-location model-name version) 
55                 (string-append "plots-lock." version)) )
56
57(define (plots-log-path model-name version) 
58  (make-pathname (build-location model-name version) 
59                 (string-append "plots-log." version)) )
60
61(debug-file (make-pathname build-location-prefix "/debug.log"))
62;;(error-log (make-pathname build-location-prefix "/debug.log"))
63
64
65(define config-path
66 (let ((args (command-line-arguments)))
67   (if (null? args) (error 'model-ci "missing config path argument")
68       (car args))))
69
70
71(define models (make-parameter '()))
72
73(load config-path)
74
75
76(define (sed-quote str)
77  (let ((lst (string->list str)))
78    (let recur ((lst lst) (ax '()))
79      (if (null? lst) (list->string (reverse ax))
80          (let ((c (car lst)))
81            (if (char=? c #\/) (recur (cdr lst) (cons c (cons #\\ ax)))
82                (recur (cdr lst) (cons c ax))))
83          ))))
84
85
86(define (quotewrap str)
87  (cond ((quotewrapped? str) str)
88        ((string-any char-whitespace? str)
89         (string-append "\"" str "\""))
90        (else str)))
91
92
93(define (d fstr . args)
94  (if (= (verbose)  v:debug)
95      (let ([port (current-output-port)])
96        (apply fprintf port fstr args)
97        (flush-output port) ) ))
98
99
100(define (info fstr . args)
101  (if (>= (verbose) v:info)
102      (let ([port (current-output-port)])
103        (apply fprintf port fstr args)
104        (flush-output port) ) ))
105
106
107(define (run:execute explist)
108  (define (smooth lst)
109    (let ((slst (map ->string lst)))
110      (string-intersperse (cons (car slst) (cdr slst)) " ")))
111  (for-each (lambda (cmd)
112              (info "  ~A~%~" cmd)
113              (system (->string cmd)))
114            (map smooth explist)))
115
116
117(define (run:execute* explist)
118  (define (smooth lst)
119    (let ((slst (map ->string lst)))
120      (string-intersperse (cons (car slst) (cdr slst)) " ")))
121  (for-each (lambda (cmd)
122              (info "  ~A~%~" cmd)
123              (system* "~a" cmd))
124            (map smooth explist)))
125
126
127
128(define-syntax run
129  (syntax-rules ()
130    ((_ exp ...)
131     (run:execute* (list `exp ...)))))
132
133
134(define-syntax run-
135  (syntax-rules ()
136    ((_ exp ...)
137     (run:execute (list `exp ...)))))
138
139
140(define (ipipe:execute lam cmd)
141  (define (smooth lst)
142    (let ((slst (map ->string lst)))
143      (string-intersperse (cons (car slst) (cdr slst)) " ")))
144  ((lambda (cmd) 
145     (info "  ~A~%~" cmd)
146     (with-input-from-pipe (sprintf "~a" cmd) lam))
147   (smooth cmd)))
148
149
150(define-syntax ipipe
151  (syntax-rules ()
152    ((_ lam exp)
153     (ipipe:execute lam `exp ))))
154
155
156;; From spiffy
157(define (call-with-input-file* file proc)
158  (call-with-input-file
159      file (lambda (p)
160             (handle-exceptions exn
161                (begin (close-input-port p) (raise exn))
162                (proc p)))))
163
164
165(define (revisions-command model-name config)
166  (or (alist-ref 'revision-command config)
167      (alist-ref 'revisions-command config)
168      (let ((config-dir (alist-ref 'config-dir config)))
169        (if (not config-dir)
170            (error 'revisions-command "unable to find model revisions command"))
171        (make-pathname config-dir "revisions"))))
172
173
174(define (fetch-command model-name config)
175  (or (alist-ref 'fetch-command config)
176      (alist-ref 'fetch-command config)
177      (let ((config-dir (alist-ref 'config-dir config)))
178        (if (not config-dir)
179            (error 'fetch-command "unable to find model fetch command"))
180        (make-pathname config-dir "fetch"))))
181
182
183(define (build-command model-name config)
184  (or (alist-ref 'build-command config)
185      (alist-ref 'build-command config)
186      (let ((config-dir (alist-ref 'config-dir config)))
187        (if (not config-dir)
188            (error 'build-command "unable to find model build command"))
189        (make-pathname config-dir "build"))))
190
191
192(define (test-commands model-name config)
193  (or (alist-ref 'test-commands config)
194      (alist-ref 'test-command config)
195      (let ((config-dir (alist-ref 'config-dir config)))
196        (if (not config-dir)
197            (error 'test-command "unable to find model test commands"))
198        (let ((tests-run-path (make-pathname config-dir "tests/run")))
199          (if (file-exists? 
200               (list tests-run-path)
201               (let ((flst (find-files (make-pathname config-dir "tests") 
202                                       limit: 1
203                                       test: file-execute-access?)))
204                 (sort flst string<?)
205                 ))
206              ))
207        ))
208  )
209
210
211(define (plot-commands model-name config)
212  (or (alist-ref 'plot-commands config)
213      (alist-ref 'plot-command config)
214      (let ((config-dir (alist-ref 'config-dir config)))
215        (if (not config-dir)
216            (error 'plot-command "unable to find model plot commands"))
217        (make-pathname config-dir "plots"))))
218
219
220(define (build model-name build-dir local-version version lock-file log-file fetch-cmd build-cmd )
221  (if (not (file-exists? lock-file))
222      (with-output-to-file log-file
223        (run (mkdir -p ,build-dir))
224        (run (touch ,lock-file))
225        (if (not (string=? version local-version))
226            (if (zero? (run- (,fetch-cmd ,model-name ,version ,build-dir  )
227                             (,build-cmd ,model-name ,build-dir )))
228                (let ((versions (read (version-path))))
229                  (call-with-output-file version-path
230                    (alist-update model-name version versions))
231                  ))
232            )
233        (run (rm ,lock-file))
234        )))
235
236
237(define (run-tests model-name build-dir version lock-file log-file cmds)
238  (if (not (file-exists? lock-file))
239      (with-output-to-file log-file
240        (run (touch ,lock-file))
241        (for-each (lambda (cmd) (run- (,cmd ,model-name ,build-dir >> ,log-file)))
242                  cmds)
243        (run (rm ,lock-file))
244        )))
245
246
247(define (make-plots model-name build-dir version lock-file log-file cmds)
248  (if (not (file-exists? lock-file))
249      (with-output-to-file log-file
250        (run (touch ,lock-file))
251        (for-each (lambda (cmd) (run- (,cmd ,model-name ,build-dir >> ,log-file)))
252                  cmds)
253        (run (rm ,lock-file))
254        )))
255
256
257(define (update-model model-name config)
258  (if (not (file-exists? (version-path)))
259      (let* ((path (version-path))
260             (dir (pathname-directory path)))
261        (run- (mkdir -p ,dir) (touch ,path))))
262  (let ((versions (read (version-path))))
263    (let ((local-version (car (alist-ref model-name versions)))
264          (remote-version (car (string-split (ipipe (lambda (x) x) (,(revisions-command config) ,model-name)) "\n"))))
265
266      (print "local-version = " local-version)
267      (print "remote-version = " remote-version)
268
269      (let ((loc (build-location model-name remote-version)))
270        (if (not (file-exists? loc))
271            (let ((build-lock-file (build-lock-path model-name remote-version))
272                  (build-log-file (build-log-path model-name remote-version))
273                  (test-lock-file (tests-lock-path model-name remote-version))
274                  (test-log-file  (tests-log-path model-name remote-version))
275                  (plot-lock-file (plots-lock-path model-name remote-version))
276                  (plot-log-file  (plots-log-path model-name remote-version))
277                  )
278              (process-fork (lambda () 
279                              (build model-name loc local-version remote-version 
280                                     build-lock-file build-log-file
281                                     (fetch-command config)
282                                     (build-command config))
283                              (run-tests model-name loc remote-version 
284                                         test-lock-file test-log-file
285                                         (test-commands config))
286                              (make-plots model-name loc remote-version 
287                                         plot-lock-file plot-log-file
288                                         (plot-commands config))
289                              ))
290              ))
291        (list remote-version loc))
292      )))
293
294       
295(define-page "/models"
296  (lambda ()
297    (map
298     (lambda (kv)
299       (let* ((model-name (car v))
300              (model-config-dir (cdr v)))
301         `(link ,(sprintf "/model-status?name=~A" model-name)
302                ,(sprintf "Model ~A" model-name))))
303     (models))))
304
305       
306(define-page "/model-status"
307  (lambda ()
308    (let* ((model-name ($ 'name))
309           (model-config (alist-ref model-name (models))))
310      (if (not model-config)
311          `(p "Invalid model name" ,model-name)
312          (let ((version.path (update-model model-name model-config))
313                (sys (system-information)))
314            (cond ((file-exists? (build-lock-path model-name (car version.path)))
315                   `(p "Build in progress, try again later."))
316                  ((file-exists? (tests-lock-path model-name (car version.path)))
317                   `(p "Tests in progress, try again later."))
318                  ((file-exists? (plots-lock-path model-name (car version.path)))
319                   `(p "Plots in progress, try again later."))
320                  (else
321                   `((h1 ,(sprintf "Model ~A" model-name ))
322                     (p)
323                     (p ,(sprintf "The current version of ~A is ~A.~%" model-name (car version.path)))
324                     (p ,(link ,(sprintf "/model-build-log?name=~A" model-name)
325                               (sprintf "Model build log version ~A~%" 
326                                        (car version.path))))
327                     (p ,(link ,(sprintf "/model-test-log?name=~A" model-name)
328                               (sprintf "Model test log version ~A~%" 
329                                        (car version.path))))
330                     (p ,(link ,(sprintf "/model-plot-log?name=~A" model-name)
331                               (sprintf "Model plot log version ~A~%" 
332                                        (car version.path))))
333                     ))
334                ))
335          ))
336    ))
337       
338
339
340(define-page "/model-build-log"
341  (lambda () 
342    (let* ((model-name ($ 'name))
343           (model-config (alist-ref model-name (models))))
344      (if (not model-config)
345          `(p "Invalid model name" ,model-name)
346          (let ((version.path (update-model  model-name model-config)))
347            `(pre . ,(intersperse (read-lines (build-log-path model-name (car version.path))) "\n"))
348            ))
349      )))
350   
351
352(define-page "/reload"
353  (lambda ()
354    (reload-apps (awful-apps))
355    (load config-path)
356    "Reloaded"))
357
Note: See TracBrowser for help on using the repository browser.