Changeset 28058 in project
- Timestamp:
- 01/08/13 09:51:34 (7 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
release/4/nemo/trunk/scripts/model-ci.scm
r28039 r28058 4 4 ;; 5 5 6 (use matchable data-structures posix files tcp srfi-1 regex setup-api uri-generic awful sendfile)6 (use matchable data-structures posix files tcp srfi-1 srfi-13 regex setup-api uri-generic awful sendfile) 7 7 (require-library spiffy intarweb) 8 8 (import (only spiffy current-request current-response write-logged-response 9 with-headers mime-type-map root-path file-extension->mime-type )9 with-headers mime-type-map root-path file-extension->mime-type send-static-file) 10 10 (only intarweb response-port request-method request-headers 11 11 header-values header-value etag-matches? response-has-message-body-for-request? … … 19 19 (define v:debug 2) 20 20 21 (define http-user-agent "nemo-model") 22 21 23 (define verbose (make-parameter v:info)) 22 24 23 (define http-user-agent "nemo-model")24 25 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 26 35 27 36 (define (version-path) … … 29 38 30 39 (define (build-location-prefix) 31 (make-pathname prefix"/build/model-ci"))40 (make-pathname (prefix) "/build/model-ci")) 32 41 33 42 (define (build-location model-name version) … … 37 46 (define (build-log-path model-name version) 38 47 (make-pathname (build-location model-name version) 39 (string-append "~A-log." model-name version)) ) 48 (string-append (sprintf "~A-log." model-name) 49 (->string version)) )) 40 50 41 51 (define (build-lock-path model-name version) 42 52 (make-pathname (build-location model-name version) 43 (string-append "build-lock." version)) ) 53 (string-append (sprintf "~A-build-lock." model-name) 54 (->string version)) )) 44 55 45 56 (define (tests-lock-path model-name version) 46 57 (make-pathname (build-location model-name version) 47 (string-append "tests-lock." version)) ) 58 (string-append (sprintf "~A-tests-lock." model-name) 59 (->string version)) )) 48 60 49 61 (define (tests-log-path model-name version) 50 62 (make-pathname (build-location model-name version) 51 (string-append "tests-log." version)) ) 63 (string-append (sprintf "~A-tests-log." model-name) 64 (->string version)) )) 52 65 53 66 (define (plots-lock-path model-name version) 54 67 (make-pathname (build-location model-name version) 55 (string-append "plots-lock." version)) ) 68 (string-append (sprintf "~A-plots-lock." model-name) 69 (->string version)) )) 56 70 57 71 (define (plots-log-path model-name version) 58 72 (make-pathname (build-location model-name version) 59 (string-append "plots-log." version)) ) 60 61 (debug-file (make-pathname build-location-prefix "/debug.log")) 73 (string-append (sprintf "~A-plots-log." model-name) 74 (->string version)) )) 75 76 (debug-file (make-pathname (build-location-prefix) "/debug.log")) 62 77 ;;(error-log (make-pathname build-location-prefix "/debug.log")) 63 78 64 79 65 (define config-path66 (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 80 75 81 … … 144 150 ((lambda (cmd) 145 151 (info " ~A~%~" cmd) 146 ( with-input-from-pipe (sprintf "~a" cmd) lam))152 (call-with-input-pipe (sprintf "~a" cmd) lam)) 147 153 (smooth cmd))) 148 154 … … 162 168 (proc p))))) 163 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 164 177 165 178 (define (revisions-command model-name config) 166 179 (or (alist-ref 'revision-command config) 167 180 (alist-ref 'revisions-command config) 168 (let ((config-dir (alist-ref 'config- dirconfig)))181 (let ((config-dir (alist-ref 'config-path config))) 169 182 (if (not config-dir) 170 183 (error 'revisions-command "unable to find model revisions command")) … … 175 188 (or (alist-ref 'fetch-command config) 176 189 (alist-ref 'fetch-command config) 177 (let ((config-dir (alist-ref 'config- dirconfig)))190 (let ((config-dir (alist-ref 'config-path config))) 178 191 (if (not config-dir) 179 192 (error 'fetch-command "unable to find model fetch command")) … … 184 197 (or (alist-ref 'build-command config) 185 198 (alist-ref 'build-command config) 186 (let ((config-dir (alist-ref 'config- dirconfig)))199 (let ((config-dir (alist-ref 'config-path config))) 187 200 (if (not config-dir) 188 201 (error 'build-command "unable to find model build command")) … … 193 206 (or (alist-ref 'test-commands config) 194 207 (alist-ref 'test-command config) 195 (let ((config-dir (alist-ref 'config- dirconfig)))208 (let ((config-dir (alist-ref 'config-path config))) 196 209 (if (not config-dir) 197 210 (error 'test-command "unable to find model test commands")) 198 211 (let ((tests-run-path (make-pathname config-dir "tests/run"))) 199 (if (file-exists? 212 (if (file-exists? tests-run-path) 200 213 (list tests-run-path) 201 214 (let ((flst (find-files (make-pathname config-dir "tests") … … 206 219 )) 207 220 )) 208 )209 221 210 222 … … 212 224 (or (alist-ref 'plot-commands config) 213 225 (alist-ref 'plot-command config) 214 (let ((config-dir (alist-ref 'config- dirconfig)))226 (let ((config-dir (alist-ref 'config-path config))) 215 227 (if (not config-dir) 216 228 (error 'plot-command "unable to find model plot commands")) 217 ( make-pathname config-dir "plots"))))229 (list (make-pathname config-dir "plots"))))) 218 230 219 231 220 232 (define (build model-name build-dir local-version version lock-file log-file fetch-cmd build-cmd ) 221 233 (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 ))) 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 )) 235 252 236 253 237 254 (define (run-tests model-name build-dir version lock-file log-file cmds) 238 255 (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 ))) 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 )) 245 263 246 264 247 265 (define (make-plots model-name build-dir version lock-file log-file cmds) 248 266 (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 ))) 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 )) 255 274 256 275 257 276 (define (update-model model-name config) 277 258 278 (if (not (file-exists? (version-path))) 259 279 (let* ((path (version-path)) 260 280 (dir (pathname-directory path))) 261 281 (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) 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)))))) 268 287 269 288 (let ((loc (build-location model-name remote-version))) … … 276 295 (plot-log-file (plots-log-path model-name remote-version)) 277 296 ) 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 )) 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 )) 290 313 )) 291 314 (list remote-version loc)) 292 315 ))) 293 316 294 295 317 (define-page "/models" 296 318 (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 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 306 335 (define-page "/model-status" 307 336 (lambda () 308 (let* ((model-name ($ 'name)) 309 (model-config (alist-ref model-name (models)))) 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 310 342 (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))) 343 `(p ,(sprintf "Invalid model name ~A" model-name)) 344 (let ((version.path (update-model model-name model-config))) 314 345 (cond ((file-exists? (build-lock-path model-name (car version.path))) 315 346 `(p "Build in progress, try again later.")) … … 319 350 `(p "Plots in progress, try again later.")) 320 351 (else 321 `((h1 ,( sprintf "Model ~A" model-name))352 `((h1 ,(or model-label (sprintf "Model ~A" model-name ))) 322 353 (p) 323 354 (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) 355 ,(model-png-plots model-name (car version.path) (cadr version.path)) 356 (p ,(link (sprintf "/model-build-log?name=~A" model-name) 325 357 (sprintf "Model build log version ~A~%" 326 358 (car version.path)))) 327 (p ,(link ,(sprintf "/model-test-log?name=~A" model-name)359 (p ,(link (sprintf "/model-test-log?name=~A" model-name) 328 360 (sprintf "Model test log version ~A~%" 329 361 (car version.path)))) 330 (p ,(link ,(sprintf "/model-plot-log?name=~A" model-name)362 (p ,(link (sprintf "/model-plot-log?name=~A" model-name) 331 363 (sprintf "Model plot log version ~A~%" 332 364 (car version.path)))) 333 365 )) 334 ))366 )) 335 367 )) 336 368 )) 337 369 338 370 339 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 340 402 (define-page "/model-build-log" 341 403 (lambda () 342 (let* ((model-name ($ 'name)) 343 (model-config (alist-ref model-name (models)))) 404 (let* ((model-name (string->symbol ($ 'name))) 405 (model-config (alist-ref model-name (models))) 406 ) 344 407 (if (not model-config) 345 `(p "Invalid model name" ,model-name)408 `(p ,(sprintf "Invalid model name ~A" model-name)) 346 409 (let ((version.path (update-model model-name model-config))) 347 `(pre . ,(intersperse (read-lines (build-log-path model-name (car version.path))) "\n")) 410 `((p "Build log:") 411 (pre . ,(intersperse (read-lines (build-log-path model-name (car version.path))) "\n"))) 348 412 )) 349 413 ))) 350 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 351 443 352 444 (define-page "/reload" … … 355 447 (load config-path) 356 448 "Reloaded")) 357
Note: See TracChangeset
for help on using the changeset viewer.