Changeset 28058 in project


Ignore:
Timestamp:
01/08/13 09:51:34 (8 years ago)
Author:
Ivan Raikov
Message:

nemo: updates to continuous integration script

File:
1 edited

Legend:

Unmodified
Added
Removed

  • release/4/nemo/trunk/scripts/model-ci.scm

    r28039 r28058  
    44;;
    55
    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)
    77(require-library spiffy intarweb)
    88(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)
    1010        (only intarweb response-port request-method  request-headers
    1111              header-values header-value etag-matches? response-has-message-body-for-request?
    … …  
    1919(define v:debug 2)
    2020
     21(define http-user-agent "nemo-model")
     22
    2123(define verbose (make-parameter v:info))
    2224
    23 (define http-user-agent "nemo-model")
    24 
    2525(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
    2635
    2736(define (version-path)
    … …  
    2938 
    3039(define (build-location-prefix)
    31   (make-pathname prefix "/build/model-ci"))
     40  (make-pathname (prefix) "/build/model-ci"))
    3241
    3342(define (build-location model-name version)
    … …  
    3746(define (build-log-path model-name version)
    3847  (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)) ))
    4050
    4151(define (build-lock-path model-name version)
    4252  (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)) ))
    4455
    4556(define (tests-lock-path model-name version)
    4657  (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)) ))
    4860
    4961(define (tests-log-path model-name version)
    5062  (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)) ))
    5265
    5366(define (plots-lock-path model-name version)
    5467  (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)) ))
    5670
    5771(define (plots-log-path model-name version)
    5872  (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"))
    6277;;(error-log (make-pathname build-location-prefix "/debug.log"))
    6378
    6479
    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)
    7480
    7581
    … …  
    144150  ((lambda (cmd)
    145151     (info "  ~A~%~" cmd)
    146      (with-input-from-pipe (sprintf "~a" cmd) lam))
     152     (call-with-input-pipe (sprintf "~a" cmd) lam))
    147153   (smooth cmd)))
    148154
    … …  
    162168                (proc p)))))
    163169
     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
    164177
    165178(define (revisions-command model-name config)
    166179  (or (alist-ref 'revision-command config)
    167180      (alist-ref 'revisions-command config)
    168       (let ((config-dir (alist-ref 'config-dir config)))
     181      (let ((config-dir (alist-ref 'config-path config)))
    169182        (if (not config-dir)
    170183            (error 'revisions-command "unable to find model revisions command"))
    … …  
    175188  (or (alist-ref 'fetch-command config)
    176189      (alist-ref 'fetch-command config)
    177       (let ((config-dir (alist-ref 'config-dir config)))
     190      (let ((config-dir (alist-ref 'config-path config)))
    178191        (if (not config-dir)
    179192            (error 'fetch-command "unable to find model fetch command"))
    … …  
    184197  (or (alist-ref 'build-command config)
    185198      (alist-ref 'build-command config)
    186       (let ((config-dir (alist-ref 'config-dir config)))
     199      (let ((config-dir (alist-ref 'config-path config)))
    187200        (if (not config-dir)
    188201            (error 'build-command "unable to find model build command"))
    … …  
    193206  (or (alist-ref 'test-commands config)
    194207      (alist-ref 'test-command config)
    195       (let ((config-dir (alist-ref 'config-dir config)))
     208      (let ((config-dir (alist-ref 'config-path config)))
    196209        (if (not config-dir)
    197210            (error 'test-command "unable to find model test commands"))
    198211        (let ((tests-run-path (make-pathname config-dir "tests/run")))
    199           (if (file-exists?
     212          (if (file-exists? tests-run-path)
    200213               (list tests-run-path)
    201214               (let ((flst (find-files (make-pathname config-dir "tests")
    … …  
    206219              ))
    207220        ))
    208   )
    209221
    210222
    … …  
    212224  (or (alist-ref 'plot-commands config)
    213225      (alist-ref 'plot-command config)
    214       (let ((config-dir (alist-ref 'config-dir config)))
     226      (let ((config-dir (alist-ref 'config-path config)))
    215227        (if (not config-dir)
    216228            (error 'plot-command "unable to find model plot commands"))
    217         (make-pathname config-dir "plots"))))
     229        (list (make-pathname config-dir "plots")))))
    218230
    219231
    220232(define (build model-name build-dir local-version version lock-file log-file fetch-cmd build-cmd )
    221233  (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      ))
    235252
    236253
    237254(define (run-tests model-name build-dir version lock-file log-file cmds)
    238255  (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      ))
    245263
    246264
    247265(define (make-plots model-name build-dir version lock-file log-file cmds)
    248266  (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      ))
    255274
    256275
    257276(define (update-model model-name config)
     277
    258278  (if (not (file-exists? (version-path)))
    259279      (let* ((path (version-path))
    260280             (dir (pathname-directory path)))
    261281        (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))))))
    268287
    269288      (let ((loc (build-location model-name remote-version)))
    … …  
    276295                  (plot-log-file  (plots-log-path model-name remote-version))
    277296                  )
    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                 ))
    290313              ))
    291314        (list remote-version loc))
    292315      )))
    293316
    294        
    295317(define-page "/models"
    296318  (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
    306335(define-page "/model-status"
    307336  (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     
    310342      (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)))
    314345            (cond ((file-exists? (build-lock-path model-name (car version.path)))
    315346                   `(p "Build in progress, try again later."))
    … …  
    319350                   `(p "Plots in progress, try again later."))
    320351                  (else
    321                    `((h1 ,(sprintf "Model ~A" model-name ))
     352                   `((h1 ,(or model-label (sprintf "Model ~A" model-name )))
    322353                     (p)
    323354                     (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)
    325357                               (sprintf "Model build log version ~A~%"
    326358                                        (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)
    328360                               (sprintf "Model test log version ~A~%"
    329361                                        (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)
    331363                               (sprintf "Model plot log version ~A~%"
    332364                                        (car version.path))))
    333365                     ))
    334                 ))
     366                  ))
    335367          ))
    336368    ))
    337369       
    338370
    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   
    340402(define-page "/model-build-log"
    341403  (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           )
    344407      (if (not model-config)
    345           `(p "Invalid model name" ,model-name)
     408          `(p ,(sprintf "Invalid model name ~A" model-name))
    346409          (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")))
    348412            ))
    349413      )))
    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
    351443
    352444(define-page "/reload"
    … …  
    355447    (load config-path)
    356448    "Reloaded"))
    357 
Note: See TracChangeset for help on using the changeset viewer.