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

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

nemo: updates to continuous integration script

File size: 13.5 KB
Line 
1
2;;
3;; Continuous integration scripts for model development.
4;;
5
6(use matchable data-structures posix files tcp srfi-1 srfi-13 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 send-static-file)
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 http-user-agent "nemo-model")
22
23(define verbose (make-parameter v:info))
24
25(define prefix (make-parameter (get-environment-variable "HOME")))
26
27(define models (make-parameter '()))
28
29(define config-path
30 (let ((path (get-environment-variable "MODEL_CI_CONFIG")))
31   (or path "model-ci.config")))
32
33(load config-path)
34
35
36(define (version-path)
37  (make-pathname (prefix) "/build/model-ci.versions"))
38 
39(define (build-location-prefix)
40  (make-pathname (prefix) "/build/model-ci"))
41
42(define (build-location model-name version) 
43  (make-pathname (build-location-prefix) 
44                 (sprintf "~A.~A" model-name version)))
45
46(define (build-log-path model-name version) 
47  (make-pathname (build-location model-name version) 
48                 (string-append (sprintf "~A-log." model-name) 
49                                (->string version)) ))
50
51(define (build-lock-path model-name version) 
52  (make-pathname (build-location model-name version) 
53                 (string-append (sprintf "~A-build-lock." model-name)
54                                (->string version)) ))
55
56(define (tests-lock-path model-name version) 
57  (make-pathname (build-location model-name version) 
58                 (string-append (sprintf "~A-tests-lock." model-name)
59                                (->string version)) ))
60
61(define (tests-log-path model-name version) 
62  (make-pathname (build-location model-name version) 
63                 (string-append (sprintf "~A-tests-log." model-name)
64                                (->string version)) ))
65
66(define (plots-lock-path model-name version) 
67  (make-pathname (build-location model-name version) 
68                 (string-append (sprintf "~A-plots-lock." model-name)
69                                (->string version)) ))
70
71(define (plots-log-path model-name version) 
72  (make-pathname (build-location model-name version) 
73                 (string-append (sprintf "~A-plots-log." model-name)
74                                (->string version)) ))
75
76(debug-file (make-pathname (build-location-prefix) "/debug.log"))
77;;(error-log (make-pathname build-location-prefix "/debug.log"))
78
79
80
81
82(define (sed-quote str)
83  (let ((lst (string->list str)))
84    (let recur ((lst lst) (ax '()))
85      (if (null? lst) (list->string (reverse ax))
86          (let ((c (car lst)))
87            (if (char=? c #\/) (recur (cdr lst) (cons c (cons #\\ ax)))
88                (recur (cdr lst) (cons c ax))))
89          ))))
90
91
92(define (quotewrap str)
93  (cond ((quotewrapped? str) str)
94        ((string-any char-whitespace? str)
95         (string-append "\"" str "\""))
96        (else str)))
97
98
99(define (d fstr . args)
100  (if (= (verbose)  v:debug)
101      (let ([port (current-output-port)])
102        (apply fprintf port fstr args)
103        (flush-output port) ) ))
104
105
106(define (info fstr . args)
107  (if (>= (verbose) v:info)
108      (let ([port (current-output-port)])
109        (apply fprintf port fstr args)
110        (flush-output port) ) ))
111
112
113(define (run:execute explist)
114  (define (smooth lst)
115    (let ((slst (map ->string lst)))
116      (string-intersperse (cons (car slst) (cdr slst)) " ")))
117  (for-each (lambda (cmd)
118              (info "  ~A~%~" cmd)
119              (system (->string cmd)))
120            (map smooth explist)))
121
122
123(define (run:execute* explist)
124  (define (smooth lst)
125    (let ((slst (map ->string lst)))
126      (string-intersperse (cons (car slst) (cdr slst)) " ")))
127  (for-each (lambda (cmd)
128              (info "  ~A~%~" cmd)
129              (system* "~a" cmd))
130            (map smooth explist)))
131
132
133
134(define-syntax run
135  (syntax-rules ()
136    ((_ exp ...)
137     (run:execute* (list `exp ...)))))
138
139
140(define-syntax run-
141  (syntax-rules ()
142    ((_ exp ...)
143     (run:execute (list `exp ...)))))
144
145
146(define (ipipe:execute lam cmd)
147  (define (smooth lst)
148    (let ((slst (map ->string lst)))
149      (string-intersperse (cons (car slst) (cdr slst)) " ")))
150  ((lambda (cmd) 
151     (info "  ~A~%~" cmd)
152     (call-with-input-pipe (sprintf "~a" cmd) lam))
153   (smooth cmd)))
154
155
156(define-syntax ipipe
157  (syntax-rules ()
158    ((_ lam exp)
159     (ipipe:execute lam `exp ))))
160
161
162;; From spiffy
163(define (call-with-input-file* file proc)
164  (call-with-input-file
165      file (lambda (p)
166             (handle-exceptions exn
167                (begin (close-input-port p) (raise exn))
168                (proc p)))))
169
170(define (call-with-output-file* file proc)
171  (call-with-output-file
172      file (lambda (p)
173             (handle-exceptions exn
174                (begin (close-output-port p) (raise exn))
175                (proc p)))))
176
177
178(define (revisions-command model-name config)
179  (or (alist-ref 'revision-command config)
180      (alist-ref 'revisions-command config)
181      (let ((config-dir (alist-ref 'config-path config)))
182        (if (not config-dir)
183            (error 'revisions-command "unable to find model revisions command"))
184        (make-pathname config-dir "revisions"))))
185
186
187(define (fetch-command model-name config)
188  (or (alist-ref 'fetch-command config)
189      (alist-ref 'fetch-command config)
190      (let ((config-dir (alist-ref 'config-path config)))
191        (if (not config-dir)
192            (error 'fetch-command "unable to find model fetch command"))
193        (make-pathname config-dir "fetch"))))
194
195
196(define (build-command model-name config)
197  (or (alist-ref 'build-command config)
198      (alist-ref 'build-command config)
199      (let ((config-dir (alist-ref 'config-path config)))
200        (if (not config-dir)
201            (error 'build-command "unable to find model build command"))
202        (make-pathname config-dir "build"))))
203
204
205(define (test-commands model-name config)
206  (or (alist-ref 'test-commands config)
207      (alist-ref 'test-command config)
208      (let ((config-dir (alist-ref 'config-path config)))
209        (if (not config-dir)
210            (error 'test-command "unable to find model test commands"))
211        (let ((tests-run-path (make-pathname config-dir "tests/run")))
212          (if (file-exists? tests-run-path)
213               (list tests-run-path)
214               (let ((flst (find-files (make-pathname config-dir "tests") 
215                                       limit: 1
216                                       test: file-execute-access?)))
217                 (sort flst string<?)
218                 ))
219              ))
220        ))
221
222
223(define (plot-commands model-name config)
224  (or (alist-ref 'plot-commands config)
225      (alist-ref 'plot-command config)
226      (let ((config-dir (alist-ref 'config-path config)))
227        (if (not config-dir)
228            (error 'plot-command "unable to find model plot commands"))
229        (list (make-pathname config-dir "plots")))))
230
231
232(define (build model-name build-dir local-version version lock-file log-file fetch-cmd build-cmd )
233  (if (not (file-exists? lock-file))
234      (call-with-output-file* log-file
235        (lambda (out)
236          (run (mkdir -p ,build-dir))
237          (run (touch ,lock-file))
238          (if (or (not local-version) (not (string=? version local-version)))
239              (begin
240                (run- (,fetch-cmd ,model-name ,version ,build-dir >> ,log-file 2>&1  )
241                      (,build-cmd ,model-name ,build-dir >> ,log-file 2>&1 ))
242                (let ((versions (call-with-input-file* (version-path) read)))
243                  (let ((versions1 (if (pair? versions) 
244                                       (alist-update model-name version versions)
245                                       (list (cons model-name version)))))
246                    (call-with-output-file* (version-path)
247                                            (lambda (out) (write versions1 out ))))
248                  )))
249          (run (rm ,lock-file))
250          ))
251      ))
252
253
254(define (run-tests model-name build-dir version lock-file log-file cmds)
255  (if (not (file-exists? lock-file))
256      (call-with-output-file* log-file
257        (lambda (out)                           
258          (run (touch ,lock-file))
259          (for-each (lambda (cmd) (run- (,cmd ,model-name ,build-dir >> ,log-file  2>&1  ))) cmds)
260          (run (rm ,lock-file))
261          ))
262      ))
263
264
265(define (make-plots model-name build-dir version lock-file log-file cmds)
266  (if (not (file-exists? lock-file))
267      (call-with-output-file* log-file
268        (lambda (out)
269          (run (touch ,lock-file))
270          (for-each (lambda (cmd) (run- (,cmd ,model-name ,build-dir >> ,log-file  2>&1  ))) cmds)
271          (run (rm ,lock-file))
272          ))
273      ))
274
275
276(define (update-model model-name config)
277
278  (if (not (file-exists? (version-path)))
279      (let* ((path (version-path))
280             (dir (pathname-directory path)))
281        (run- (mkdir -p ,dir) (touch ,path))))
282
283  (let ((versions (call-with-input-file* (version-path) read)))
284
285    (let ((local-version (and versions (pair? versions) (alist-ref model-name versions)))
286          (remote-version (string-trim-both  (car (ipipe (lambda (x) (read-lines x)) (,(revisions-command model-name config) ,model-name))))))
287
288      (let ((loc (build-location model-name remote-version)))
289        (if (not (file-exists? loc))
290            (let ((build-lock-file (build-lock-path model-name remote-version))
291                  (build-log-file (build-log-path model-name remote-version))
292                  (test-lock-file (tests-lock-path model-name remote-version))
293                  (test-log-file  (tests-log-path model-name remote-version))
294                  (plot-lock-file (plots-lock-path model-name remote-version))
295                  (plot-log-file  (plots-log-path model-name remote-version))
296                  )
297              (process-fork
298               (lambda ()
299                 (run (mkdir -p ,loc))
300                 (run (touch ,build-log-file  ,test-log-file ,plot-log-file))
301                 (build model-name loc local-version remote-version 
302                        build-lock-file build-log-file
303                        (fetch-command model-name config)
304                        (build-command model-name config))
305                 (run-tests model-name loc remote-version 
306                            test-lock-file test-log-file
307                            (test-commands model-name config))
308                 (make-plots model-name loc remote-version 
309                             plot-lock-file plot-log-file
310                             (plot-commands model-name config))
311                 (exit 0)
312                 ))
313              ))
314        (list remote-version loc))
315      )))
316
317(define-page "/models"
318  (lambda ()
319    `((h1 "NEMO model status")
320      ,(map
321        (lambda (kv)
322          (let* ((model-name (car kv))
323                 (model-config (cdr kv))
324                 (model-label (alist-ref 'label model-config))
325                 )
326           
327            `(p ,(link (sprintf "/model-status?name=~A" model-name)
328                       (or model-label (sprintf "Model ~A" model-name))))
329           
330            ))
331        (models)))
332    ))
333   
334
335(define-page "/model-status"
336  (lambda ()
337    (let* ((model-name (string->symbol ($ 'name)))
338           (model-config (alist-ref model-name (models)))
339           (model-label (alist-ref 'label model-config))
340           )
341     
342      (if (not model-config)
343          `(p ,(sprintf "Invalid model name ~A" model-name))
344          (let ((version.path (update-model model-name model-config)))
345            (cond ((file-exists? (build-lock-path model-name (car version.path)))
346                   `(p "Build in progress, try again later."))
347                  ((file-exists? (tests-lock-path model-name (car version.path)))
348                   `(p "Tests in progress, try again later."))
349                  ((file-exists? (plots-lock-path model-name (car version.path)))
350                   `(p "Plots in progress, try again later."))
351                  (else
352                   `((h1 ,(or model-label (sprintf "Model ~A" model-name )))
353                     (p)
354                     (p ,(sprintf "The current version of ~A is ~A.~%" model-name (car version.path)))
355                     ,(model-png-plots model-name (car version.path) (cadr version.path))
356                     (p ,(link (sprintf "/model-build-log?name=~A" model-name)
357                               (sprintf "Model build log version ~A~%" 
358                                        (car version.path))))
359                     (p ,(link (sprintf "/model-test-log?name=~A" model-name)
360                               (sprintf "Model test log version ~A~%" 
361                                        (car version.path))))
362                     (p ,(link (sprintf "/model-plot-log?name=~A" model-name)
363                               (sprintf "Model plot log version ~A~%" 
364                                        (car version.path))))
365                     ))
366                  ))
367          ))
368    ))
369       
370
371   
372(define (model-png-plots model-name model-version model-loc)
373  (let ((jpgpat  "(.*\\.[jJ][pP][eE]?[gG]$)")
374        (pngpat  "(.*\\.[pP][nN][gG]$)"))
375    (let ((pat   (string-append jpgpat "|" pngpat)))
376      (let ((flst (find-files model-loc test: (regexp pat))))
377        (map (lambda (f) 
378               (let ((fn (pathname-strip-directory f)))
379                 `(p (img (@ (src ,(sprintf "/model-plot?modelname=~A&plotname=~A" model-name fn))) ))
380                 )) flst)))
381    ))
382
383(define-page "/model-plot"     
384  (lambda () 
385    (let* (
386           (model-name (string->symbol ($ 'modelname)))
387           (model-config (alist-ref model-name (models)))
388           (plot-name  ($ 'plotname))
389           )
390      (if (not model-config)
391          `(html (body (p ,(sprintf "Invalid model name ~A" model-name))))
392          (let ((version.path (update-model model-name model-config)))
393            (lambda ()
394              (let ((plot-file-path (cadr version.path)))
395                (parameterize ((root-path plot-file-path))
396                              (send-static-file plot-name))
397                ))
398            ))
399      ))
400  no-template: #f)
401   
402(define-page "/model-build-log"
403  (lambda () 
404    (let* ((model-name (string->symbol ($ 'name)))
405           (model-config (alist-ref model-name (models)))
406           )
407      (if (not model-config)
408          `(p ,(sprintf "Invalid model name ~A" model-name))
409          (let ((version.path (update-model  model-name model-config)))
410            `((p "Build log:")
411              (pre . ,(intersperse (read-lines (build-log-path model-name (car version.path))) "\n")))
412            ))
413      )))
414
415   
416(define-page "/model-test-log"
417  (lambda () 
418    (let* ((model-name (string->symbol ($ 'name)))
419           (model-config (alist-ref model-name (models)))
420           )
421      (if (not model-config)
422          `(p ,(sprintf "Invalid model name ~A" model-name))
423          (let ((version.path (update-model  model-name model-config)))
424            `((p "Test log:")
425              (pre . ,(intersperse (read-lines (tests-log-path model-name (car version.path))) "\n")))
426            ))
427      )))
428
429   
430(define-page "/model-plot-log"
431  (lambda () 
432    (let* ((model-name (string->symbol ($ 'name)))
433           (model-config (alist-ref model-name (models)))
434           )
435      (if (not model-config)
436          `(p ,(sprintf "Invalid model name ~A" model-name))
437          (let ((version.path (update-model  model-name model-config)))
438            `((p "Plot log:")
439              (pre . ,(intersperse (read-lines (plots-log-path model-name (car version.path))) "\n")))
440            ))
441      )))
442
443
444(define-page "/reload"
445  (lambda ()
446    (reload-apps (awful-apps))
447    (load config-path)
448    "Reloaded"))
Note: See TracBrowser for help on using the repository browser.