diff options
| -rwxr-xr-x | bin/ravanan | 37 | ||||
| -rw-r--r-- | ravanan/command-line-tool.scm | 1049 | ||||
| -rw-r--r-- | ravanan/job-state.scm | 15 | ||||
| -rw-r--r-- | ravanan/propnet.scm | 22 | ||||
| -rw-r--r-- | ravanan/reader.scm | 29 | ||||
| -rw-r--r-- | ravanan/store.scm | 88 | ||||
| -rw-r--r-- | ravanan/utils.scm | 4 | ||||
| -rw-r--r-- | ravanan/work/command-line-tool.scm | 176 | ||||
| -rw-r--r-- | ravanan/workflow.scm | 318 | ||||
| -rw-r--r-- | tests/store.scm | 80 |
10 files changed, 1098 insertions, 720 deletions
diff --git a/bin/ravanan b/bin/ravanan index 6ad5167..ba04718 100755 --- a/bin/ravanan +++ b/bin/ravanan @@ -36,7 +36,9 @@ exec guile --no-auto-compile -e main -s "$0" "$@" (ravanan utils) (ravanan verbosity) (ravanan workflow) - (ravanan work utils)) + (ravanan work ui) + (ravanan work utils) + (ravanan work vectors)) (define %options (list (option (list "batch-system" "batchSystem") #t #f @@ -44,7 +46,7 @@ exec guile --no-auto-compile -e main -s "$0" "$@" (if (member arg (list "single-machine" "slurm-api")) (acons 'batch-system (string->symbol arg) result) - (error "Unknown batch system" arg)))) + (user-error "Unknown batch system ~a" arg)))) (option (list "guix-channels") #t #f (lambda (opt name arg result) (acons 'guix-channels-file arg result))) @@ -87,7 +89,7 @@ exec guile --no-auto-compile -e main -s "$0" "$@" (cons 'traces (cons (string->symbol arg) (assq-ref result 'traces)))) - (error "Unknown trace subsystem" arg))))) + (user-error "Unknown trace subsystem ~a" arg))))) (option (list "help") #f #t (lambda (opt name arg result) (acons 'help #t result))) @@ -96,7 +98,13 @@ exec guile --no-auto-compile -e main -s "$0" "$@" (acons 'version #t result))))) (define (invalid-option opt name arg result) - (error "Invalid option" name)) + (user-error "Invalid option ~a" name)) + +(define (print-short-usage program) + (format (current-error-port) + "Usage: ~a [OPTIONS] CWL-WORKFLOW INPUTS +Run CWL-WORKFLOW with INPUTS.~%" + program)) (define (print-usage program) (format (current-error-port) @@ -211,13 +219,13 @@ files that have the token in the @verbatim{SLURM_JWT=token} format." (exit #t)) ;; Check for required arguments. (unless (assq-ref args 'store) - (error "--store not specified")) + (user-error "--store not specified")) (case (assq-ref args 'batch-system) ((slurm-api) (unless (assq-ref args 'scratch) - (error "--scratch not specified")) + (user-error "--scratch not specified")) (unless (assq-ref args 'slurm-jwt) - (error "--slurm-jwt not specified")))) + (user-error "--slurm-jwt not specified")))) (match (reverse (assq-ref args 'args)) ((workflow-file inputs-file) ;; We must not try to compile guix manifest files. @@ -238,13 +246,13 @@ files that have the token in the @verbatim{SLURM_JWT=token} format." (let ((file (manifest-file-error-file c))) (cond ((not file) - (error "--guix-manifest not specified")) + (user-error "--guix-manifest not specified")) ((not (file-exists? file)) - (error "Manifest file ~a does not exist" - file)) + (user-error "Manifest file ~a does not exist" + file)) (else - (error "Error loading manifest file" - file) + (user-error "Error loading manifest file ~a" + file) (raise-exception c)))))) (parameterize ((%traces (assq-ref args 'traces))) (run-workflow (file-name-stem workflow-file) @@ -282,4 +290,7 @@ files that have the token in the @verbatim{SLURM_JWT=token} format." outputs) outputs) #:pretty #t)) - (newline))))))) + (newline)) + (_ + (print-short-usage program) + (exit #f))))))) diff --git a/ravanan/command-line-tool.scm b/ravanan/command-line-tool.scm index c47bb3c..62785cc 100644 --- a/ravanan/command-line-tool.scm +++ b/ravanan/command-line-tool.scm @@ -53,9 +53,11 @@ #:use-module (ravanan work ui) #:use-module (ravanan work utils) #:use-module (ravanan work vectors) - #:export (run-command-line-tool + #:export (build-command-line-tool-script + run-command-line-tool check-requirements inherit-requirements + find-requirement %command-line-tool-supported-requirements command-line-tool-supported-requirements capture-command-line-tool-output @@ -95,15 +97,6 @@ (secondary-files formal-output-secondary-files) (binding formal-output-binding)) -(define-immutable-record-type <command-line-binding> - (command-line-binding position prefix type value item-separator) - command-line-binding? - (position command-line-binding-position) - (prefix command-line-binding-prefix) - (type command-line-binding-type) - (value command-line-binding-value) - (item-separator command-line-binding-item-separator)) - (define-immutable-record-type <output-binding> (output-binding glob load-contents? load-listing? output-eval) output-binding? @@ -292,95 +285,37 @@ G-expressions are inserted." (< (command-line-binding-position binding1) (command-line-binding-position binding2)))))) -(define (command-line-binding->args binding) - "Return a list of arguments for @var{binding}. The returned list may -contain strings or G-expressions. The G-expressions may reference an -@code{inputs-directory} variable that must be defined in the context -in which the G-expressions are inserted." - (let ((prefix (command-line-binding-prefix binding)) - (type (command-line-binding-type binding)) - (value (command-line-binding-value binding))) - (cond - ((eq? type 'boolean) - (if value - ;; TODO: Error out if boolean input has no prefix? - (maybe->list prefix) - (list))) - ((eq? type 'null) (list)) - ((array-type? type) - (match value - ;; Empty arrays should be noops. - (() (list)) - (_ - (let ((args (append-map command-line-binding->args - value))) - (append (maybe->list prefix) - (from-maybe - (maybe-let* ((item-separator (command-line-binding-item-separator binding))) - (just (list #~(string-join (list #$@args) - #$item-separator)))) - args)))))) - (else - (append (maybe->list prefix) - (list (case type - ((string) - value) - ((int float) - #~(number->string #$value)) - ((File) - #~(assoc-ref* #$value "path")) - (else - (user-error "Invalid formal input type ~a" - type))))))))) - -(define* (build-gexp-script name exp #:optional guix-daemon-socket) - "Build script named @var{name} using G-expression @var{exp}. - -When @var{guix-daemon-socket} is provided, connect to that Guix daemon." - (if guix-daemon-socket - (parameterize ((%daemon-socket-uri guix-daemon-socket)) - (build-gexp-script name exp)) - (with-store store - (run-with-store store - (mlet %store-monad ((drv (gexp->script name exp))) - (mbegin %store-monad - (built-derivations (list drv)) - (return (derivation->output-path drv)))))))) +(define* (build-gexp-script name exp) + "Build script named @var{name} using G-expression @var{exp}. Return the path to +the built script as a monadic value." + (mlet %store-monad ((drv (gexp->script name exp))) + (mbegin %store-monad + (built-derivations (list drv)) + (return (derivation->output-path drv))))) -(define* (run-command-line-tool name manifest-file channels cwl inputs - scratch store batch-system - #:key guix-daemon-socket) - "Run @code{CommandLineTool} class workflow @var{cwl} named @var{name} with -@var{inputs} using tools from Guix manifest in @var{manifest-file}. Return a -state-monadic job state object. +(define* (run-command-line-tool name script inputs resource-requirement + store batch-system) + "Run @code{CommandLineTool} class workflow @var{script} named @var{name} with +@var{inputs}. Return a state-monadic job state object. -@var{channels}, @var{scratch}, @var{store}, @var{batch-system} and -@var{guix-daemon-socket} are the same as in @code{run-workflow} from +@var{resource-requirement} is the @code{ResourceRequirement} of the workflow. +@var{store} and @var{batch-system} are the same as in @code{run-workflow} from @code{(ravanan workflow)}." - (let* ((script - (build-command-line-tool-script name manifest-file channels cwl inputs - scratch store batch-system - guix-daemon-socket)) - (requirements (inherit-requirements (or (assoc-ref cwl "requirements") - #()) - (or (assoc-ref cwl "hints") - #()))) - (cpus (from-maybe - (maybe-bind (maybe-assoc-ref (find-requirement requirements - "ResourceRequirement") - "coresMin") - (compose just - inexact->exact - ceiling - (cut coerce-type <> 'number) - (cut coerce-expression - <> - `(("inputs" . ,inputs))))) - 1)) - (store-files-directory (script->store-files-directory script store)) - (store-data-file (script->store-data-file script store)) - (stdout-file (script->store-stdout-file script store)) - (stderr-file (script->store-stderr-file script store))) + (let ((cpus (from-maybe + (maybe-bind (maybe-assoc-ref resource-requirement + "coresMin") + (compose just + inexact->exact + ceiling + (cut coerce-type <> 'number) + (cut coerce-expression + <> + `(("inputs" . ,inputs))))) + 1)) + (store-files-directory (step-store-files-directory script inputs store)) + (store-data-file (step-store-data-file script inputs store)) + (stdout-file (step-store-stdout-file script inputs store)) + (stderr-file (step-store-stderr-file script inputs store))) (if (file-exists? store-data-file) ;; Return a dummy success state object if script has already ;; been run successfully. @@ -389,7 +324,7 @@ state-monadic job state object. (format (current-error-port) "~a previously run; retrieving result from store~%" script) - (single-machine-job-state script #t))) + (single-machine-job-state script inputs #t))) ;; Run script if it has not already been run. (begin ;; Delete output files directory if an incomplete one exists @@ -401,44 +336,41 @@ state-monadic job state object. (when (file-exists? store-files-directory) (delete-file-recursively store-files-directory)) (mkdir store-files-directory) - (cond - ((eq? batch-system 'single-machine) - (state-let* ((success? (single-machine:submit-job - `(("WORKFLOW_OUTPUT_DIRECTORY" . - ,store-files-directory) - ("WORKFLOW_OUTPUT_DATA_FILE" . - ,store-data-file)) - stdout-file - stderr-file - script))) - (state-return (single-machine-job-state script success?)))) - ((slurm-api-batch-system? batch-system) - (state-let* ((job-id - (slurm:submit-job `(("WORKFLOW_OUTPUT_DIRECTORY" . - ,store-files-directory) - ("WORKFLOW_OUTPUT_DATA_FILE" . - ,store-data-file)) - stdout-file - stderr-file - cpus - name - script - #:api-endpoint (slurm-api-batch-system-endpoint batch-system) - #:jwt (slurm-api-batch-system-jwt batch-system) - #:partition (slurm-api-batch-system-partition batch-system) - #:nice (slurm-api-batch-system-nice batch-system)))) - (format (current-error-port) - "~a submitted as job ID ~a~%" - script - job-id) - (state-return (slurm-job-state script job-id)))) - (else - (assertion-violation batch-system "Invalid batch system"))))))) + (let ((environment + `(("WORKFLOW_INPUTS" . ,(scm->json-string inputs)) + ("WORKFLOW_OUTPUT_DIRECTORY" . ,store-files-directory) + ("WORKFLOW_OUTPUT_DATA_FILE" . ,store-data-file)))) + (cond + ((eq? batch-system 'single-machine) + (state-let* ((success? (single-machine:submit-job environment + stdout-file + stderr-file + script))) + (state-return (single-machine-job-state script inputs success?)))) + ((slurm-api-batch-system? batch-system) + (state-let* ((job-id + (slurm:submit-job environment + stdout-file + stderr-file + cpus + name + script + #:api-endpoint (slurm-api-batch-system-endpoint batch-system) + #:jwt (slurm-api-batch-system-jwt batch-system) + #:partition (slurm-api-batch-system-partition batch-system) + #:nice (slurm-api-batch-system-nice batch-system)))) + (format (current-error-port) + "~a submitted as job ID ~a~%" + script + job-id) + (state-return (slurm-job-state script inputs job-id)))) + (else + (assertion-violation batch-system "Invalid batch system")))))))) -(define (capture-command-line-tool-output script store) +(define (capture-command-line-tool-output script inputs store) "Capture and return output of @code{CommandLineTool} class workflow that ran -@var{script}. @var{store} is the path to the ravanan store." - (let* ((store-data-file (script->store-data-file script store)) +@var{script} with @var{inputs}. @var{store} is the path to the ravanan store." + (let* ((store-data-file (step-store-data-file script inputs store)) (output-json (call-with-input-file store-data-file json->scm))) ;; Recursively rewrite file paths in output JSON. @@ -455,7 +387,7 @@ state-monadic job state object. (string=? (assoc-ref tree "class") "File")) (let* ((store-files-directory - (script->store-files-directory script store)) + (step-store-files-directory script inputs store)) (path (expand-file-name (relative-file-name (assoc-ref tree "path") store-files-directory) @@ -478,52 +410,6 @@ state-monadic job state object. (call-with-input-file store-data-file json->scm))) -(define (copy-input-files-gexp inputs) - "Return a G-expression that copies @code{File} type inputs (along with secondary -files) from @var{inputs} into @code{inputs-directory} and return a new -association list with updated @code{location} and @code{path} fields. - -The returned G-expression will reference an @code{inputs-directory} variable." - (define (copy-input-files input) - (cond - ((vector? input) - #~,(list->vector - `#$(map copy-input-files - (vector->list input)))) - ((eq? (object-type input) - 'File) - #~,(let ((path-in-inputs-directory - (expand-file-name #$(store-item-name (assoc-ref input "path")) - inputs-directory))) - (copy-file #$(assoc-ref input "path") - path-in-inputs-directory) - (maybe-assoc-set '#$input - (cons "location" - (just path-in-inputs-directory)) - (cons "path" - (just path-in-inputs-directory)) - (cons "basename" - (just (basename path-in-inputs-directory))) - (cons "nameroot" - (just (file-name-stem path-in-inputs-directory))) - (cons "nameext" - (just (file-name-extension path-in-inputs-directory))) - (cons "secondaryFiles" - #$(from-maybe - (maybe-let* ((secondary-files - (maybe-assoc-ref (just input) "secondaryFiles"))) - (just #~(just (list->vector - `#$(vector-map->list copy-input-files - secondary-files))))) - #~%nothing))))) - (else input))) - - #~(list->dotted-list - `#$(map (match-lambda - ((id . input) - (list id (copy-input-files input)))) - inputs))) - (define (find-requirement requirements class) "Find requirement of @var{class} among @var{requirements} and return a maybe-monadic value." @@ -548,64 +434,60 @@ maybe-monadic value." (guix profiles)))) (raise-exception (manifest-file-error manifest-file)))) -(define (call-with-inferior inferior proc) - "Call @var{proc} with @var{inferior} and return the return value of @var{proc}. -Close @var{inferior} when done, even if @var{proc} exits non-locally." - (dynamic-wind (const #t) - (cut proc inferior) - (cut close-inferior inferior))) +;; Monadic version of inferior-eval-with-store; Argument order is rearranged +;; slightly to suit store-lift. +(define inferior-meval-with-store + (store-lift (lambda (store inferior proc) + (inferior-eval-with-store inferior store proc)))) -(define (manifest-file->environment manifest-file channels guix-daemon-socket) - "Build @var{manifest-file} and return an association list of environment -variables to set to use the built profile. Connect to the Guix daemon specified -by @var{guix-daemon-socket}. If @var{channels} is not @code{#f}, build manifest -in a Guix inferior with @var{channels}." - (if channels - (call-with-inferior (inferior-for-channels channels) - (cut inferior-eval - `(begin - (use-modules (ice-9 match) - (guix search-paths) - (gnu packages) - (guile) - (guix gexp) - (guix profiles)) +(define (manifest-file->search-path-sexps manifest-file inferior) + "Return a list of search path S-expressions for a profile described by +@var{manifest-file}. Load manifest in @var{inferior} unless it is @code{#f}. +Return value is monadic." + (define proc + `(lambda (store) + ;; Do not auto-compile manifest files. + (set! %load-should-auto-compile #f) + (map search-path-specification->sexp + (manifest-search-paths (load ,manifest-file))))) + + (if inferior + (begin + (inferior-eval '(use-modules (guix profiles) + (guix search-paths)) + inferior) + (mbegin %store-monad + (inferior-meval-with-store inferior proc))) + (mbegin %store-monad + (return (map search-path-specification->sexp + (manifest-search-paths (load-manifest manifest-file))))))) - (define (build-derivation drv guix-daemon-socket) - (if guix-daemon-socket - (parameterize ((%daemon-socket-uri guix-daemon-socket)) - (build-derivation drv)) - (with-store store - (run-with-store store - (mlet %store-monad ((drv drv)) - (mbegin %store-monad - (built-derivations (list drv)) - (return (derivation->output-path drv)))))))) +(define (manifest-file->profile-derivation manifest-file inferior) + "Return a derivation to build @var{manifest-file}. Build manifest in +@var{inferior} unless it is @code{#f}. Return value is monadic." + (define proc + `(lambda (store) + ;; Do not auto-compile manifest files. + (set! %load-should-auto-compile #f) + (derivation-file-name + (run-with-store store + (profile-derivation (load ,manifest-file) + #:allow-collisions? #t))))) - ;; Do not auto-compile manifest files. - (set! %load-should-auto-compile #f) - (let ((manifest (load ,(canonicalize-path manifest-file)))) - (map (match-lambda - ((specification . value) - (cons (search-path-specification-variable specification) - value))) - (evaluate-search-paths - (manifest-search-paths manifest) - (list (build-derivation - (profile-derivation manifest - #:allow-collisions? #t) - ,guix-daemon-socket)))))) - <>)) - (manifest->environment (load-manifest manifest-file) - guix-daemon-socket))) + (if inferior + (begin + (inferior-eval '(use-modules (guix profiles)) + inferior) + (mlet %store-monad ((drv-file (inferior-meval-with-store inferior proc))) + (return (read-derivation-from-file drv-file)))) + (let ((manifest (load-manifest manifest-file))) + (profile-derivation manifest + #:allow-collisions? #t)))) -(define (software-packages->environment packages channels guix-daemon-socket) - "Build a profile with @var{packages} and return an association list -of environment variables to set to use the built profile. @var{packages} is a -vector of @code{SoftwarePackage} assocation lists as defined in the CWL -standard. Connect to the Guix daemon specified by @var{guix-daemon-socket}. If -@var{channels} is not @code{#f}, look up packages in a Guix inferior with -@var{channels}." +(define (software-packages->manifest packages inferior) + "Return a manifest with @var{packages}. @var{packages} is a vector of +@code{SoftwarePackage} assocation lists as defined in the CWL standard. Look up +packages in @var{inferior} unless it is @code{#f}." (define (software-package->package-specification package) (string-append (assoc-ref* package "package") (from-maybe @@ -614,63 +496,48 @@ standard. Connect to the Guix daemon specified by @var{guix-daemon-socket}. If (cut string-append "@" <>))) ""))) - (define packages->environment - (compose (cut manifest->environment <> guix-daemon-socket) - packages->manifest)) - - (if channels - (call-with-inferior (inferior-for-channels channels) - (lambda (inferior) - (packages->environment - (vector-map->list (lambda (package) - (let ((name (assoc-ref package "package")) - (version (assoc-ref package "version"))) - (match (lookup-inferior-packages inferior - name - version) - ((inferior-package _ ...) - inferior-package)))) - packages)))) - (packages->environment + (packages->manifest + (if inferior + (vector-map->list (lambda (package) + (let ((name (assoc-ref package "package")) + (version (assoc-ref package "version"))) + (match (lookup-inferior-packages inferior + name + version) + ((inferior-package _ ...) + inferior-package)))) + packages) (vector-map->list (compose specification->package software-package->package-specification) packages)))) -(define (manifest->environment manifest guix-daemon-socket) - "Build @var{manifest} and return an association list of environment -variables to set to use the built profile. Connect to the Guix daemon specified -by @var{guix-daemon-socket}." - (define (build-derivation drv guix-daemon-socket) - (if guix-daemon-socket - (parameterize ((%daemon-socket-uri guix-daemon-socket)) - (build-derivation drv #f)) - (with-store store - (run-with-store store - (mlet %store-monad ((drv drv)) - (mbegin %store-monad - (built-derivations (list drv)) - (return (derivation->output-path drv)))))))) +(define (software-packages->search-path-sexps packages inferior) + "Return a list of search path S-expressions for a profile with @var{packages}. +@var{packages} is a vector of @code{SoftwarePackage} assocation lists as defined +in the CWL standard. Look up packages in @var{inferior} unless it is @code{#f}. +Return value is monadic." + (mbegin %store-monad + (return (map search-path-specification->sexp + (manifest-search-paths + (software-packages->manifest packages inferior)))))) - (map (match-lambda - ((specification . value) - (cons (search-path-specification-variable specification) - value))) - (evaluate-search-paths - (manifest-search-paths manifest) - (list (build-derivation - (profile-derivation manifest - #:allow-collisions? #t) - guix-daemon-socket))))) +(define (software-packages->profile-derivation packages inferior) + "Return a derivation to build a profile with @var{packages}. @var{packages} is a +vector of @code{SoftwarePackage} assocation lists as defined in the CWL +standard. Look up packages in @var{inferior} unless it is @code{#f}. Return +value is monadic." + (profile-derivation (software-packages->manifest packages inferior) + #:allow-collisions? #t)) -(define (build-command-line-tool-script name manifest-file channels cwl inputs - scratch store batch-system - guix-daemon-socket) +(define (build-command-line-tool-script name manifest-file inferior cwl + scratch store batch-system) "Build and return script to run @code{CommandLineTool} class workflow @var{cwl} -named @var{name} with @var{inputs} using tools from Guix manifest in -@var{manifest-file} and on @var{batch-system}. +named @var{name} using tools from Guix manifest in @var{manifest-file} and on +@var{batch-system}. Use @var{inferior} to build manifests, unless it is +@code{#f}. Return value is monadic. -@var{channels}, @var{scratch}, @var{store} and @var{guix-daemon-socket} are the -same as in @code{run-workflow} from @code{(ravanan workflow)}." +@var{scratch} and @var{store} are the same as in @code{run-workflow} from +@code{(ravanan workflow)}." (define (environment-variables env-var-requirement) (just (vector-map->list (lambda (environment-definition) #~(list #$(assoc-ref* environment-definition @@ -697,12 +564,12 @@ same as in @code{run-workflow} from @code{(ravanan workflow)}." (define (cores batch-system) (cond - ((slurm-api-batch-system? batch-system) - #~(string->number (getenv "SLURM_CPUS_ON_NODE"))) - ((eq? batch-system 'single-machine) - #~(total-processor-count)) - (else - (assertion-violation batch-system "Unknown batch system")))) + ((slurm-api-batch-system? batch-system) + #~(string->number (getenv "SLURM_CPUS_ON_NODE"))) + ((eq? batch-system 'single-machine) + #~(total-processor-count)) + (else + (assertion-violation batch-system "Unknown batch system")))) (define stdout-filename (cond @@ -725,12 +592,35 @@ same as in @code{run-workflow} from @code{(ravanan workflow)}." (list 'File 'Directory)) (error #f "glob output binding not specified")))) + (define (coerce-argument argument) + (assoc-set argument + (cons "valueFrom" + (coerce-expression (assoc-ref* argument "valueFrom"))))) + + (define (vector->gexp vec) + ;; FIXME: G-expressions in vectors are not properly substituted. Fix this in + ;; Guix. + #~(vector #$@(vector->list vec))) + + (define (alist->gexp alist) + ;; FIXME: G-expressions as values in dotted alists are not properly + ;; substituted. Fix this in Guix. + #~(list #$@(map (match-lambda + ((key . value) + #~(cons #$key #$value))) + alist))) + (define run-command-gexp - #~(run-command (list #$@(append-map (lambda (arg) - (if (command-line-binding? arg) - (command-line-binding->args arg) - (list arg))) - (build-command cwl inputs))) + #~(run-command (append-map (lambda (arg) + (if (command-line-binding? arg) + (command-line-binding->args arg) + (list arg))) + (build-command #$(assoc-ref cwl "baseCommand") + #$(vector->gexp + (vector-map (compose alist->gexp coerce-argument) + (assoc-ref cwl "arguments"))) + #$(assoc-ref cwl "inputs") + inputs)) #$(coerce-expression (assoc-ref cwl "stdin")) #$stdout-filename '#$(from-maybe @@ -812,7 +702,7 @@ same as in @code{run-workflow} from @code{(ravanan workflow)}." (maybe-let* ((work-reuse (find-requirement requirements "WorkReuse"))) (and (not (coerce-type (assoc-ref* work-reuse "enableReuse") 'boolean)) - (user-error "Disabling WorkReuse is not supported. ravanan's strong caching using Guix makes it unnecessary.")))) + (user-error "Disabling WorkReuse is not supported. With ravanan's strong caching using Guix, there is no need to disable WorkReuse.")))) (maybe-let* ((hints (maybe-assoc-ref (just cwl) "hints"))) (check-requirements hints batch-system @@ -823,276 +713,329 @@ same as in @code{run-workflow} from @code{(ravanan workflow)}." (maybe-let* ((work-reuse (find-requirement hints "WorkReuse"))) (and (not (coerce-type (assoc-ref* work-reuse "enableReuse") 'boolean)) - (warning "Ignoring disable of WorkReuse. ravanan's strong caching using Guix makes it unnecessary.")))) - ;; Copy input files and update corresponding input objects. - (build-gexp-script name - (let* ((requirements (inherit-requirements (or (assoc-ref cwl "requirements") - #()) - (or (assoc-ref cwl "hints") - #()))) - (initial-work-dir-requirement (find-requirement requirements - "InitialWorkDirRequirement")) - (manifest-file - (from-maybe (maybe-assoc-ref - (find-requirement requirements "SoftwareRequirement") - "manifest") - manifest-file)) - (packages - (from-maybe (maybe-assoc-ref - (find-requirement requirements "SoftwareRequirement") - "packages") - #()))) - (with-imported-modules (source-module-closure '((ravanan work command-line-tool) - (ravanan work monads) - (ravanan work ui) - (ravanan work vectors) - (ravanan glob) - (guix search-paths)) - #:select? (match-lambda - (('ravanan work . _) #t) - (('guix . _) #t) - (('json . _) #t) - (_ #f))) - (with-extensions (list guile-filesystem guile-gcrypt) - #~(begin - (use-modules (ravanan work command-line-tool) - (ravanan work monads) - (ravanan work types) - (ravanan work ui) - (ravanan work utils) - (ravanan work vectors) - (ravanan glob) - (rnrs io ports) - (srfi srfi-1) - (srfi srfi-26) - (ice-9 filesystem) - (ice-9 match) - (ice-9 threads) - (guix search-paths) - (json)) + (warning "Ignoring disable of WorkReuse. With ravanan's strong caching using Guix, there is no need to disable WorkReuse.")))) + + (let* ((requirements (inherit-requirements (or (assoc-ref cwl "requirements") + #()) + (or (assoc-ref cwl "hints") + #()))) + (initial-work-dir-requirement (find-requirement requirements + "InitialWorkDirRequirement")) + (manifest-file + (from-maybe (maybe-assoc-ref + (find-requirement requirements "SoftwareRequirement") + "manifest") + manifest-file)) + (packages + (from-maybe (maybe-assoc-ref + (find-requirement requirements "SoftwareRequirement") + "packages") + #()))) + (mlet %store-monad ((search-path-sexps + (match packages + ;; No package specifications; try the manifest file. + (#() + (manifest-file->search-path-sexps manifest-file + inferior)) + ;; Use package specifications to build an + ;; environment. + (_ + (software-packages->search-path-sexps packages + inferior)))) + (profile-derivation + (match packages + ;; No package specifications; try the manifest file. + (#() + (manifest-file->profile-derivation manifest-file + inferior)) + ;; Use package specifications to build an + ;; environment. + (_ + (software-packages->profile-derivation packages + inferior))))) + (build-gexp-script name + (with-imported-modules (source-module-closure '((ravanan work command-line-tool) + (ravanan work monads) + (ravanan work ui) + (ravanan work vectors) + (ravanan glob) + (guix search-paths)) + #:select? (match-lambda + (('ravanan work . _) #t) + (('guix . _) #t) + (('json . _) #t) + (_ #f))) + (with-extensions (list guile-filesystem guile-gcrypt) + #~(begin + (use-modules (ravanan work command-line-tool) + (ravanan work monads) + (ravanan work types) + (ravanan work ui) + (ravanan work utils) + (ravanan work vectors) + (ravanan glob) + (rnrs io ports) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 filesystem) + (ice-9 match) + (ice-9 threads) + (guix search-paths) + (json)) - (define (copy-file-value value directory) - ;; Copy file represented by value to directory and return the - ;; new File value. - (let* ((path (assoc-ref* value "path")) - (destination-path (expand-file-name (basename path) - directory))) - (copy-file path destination-path) - (assoc-set value - (cons "location" (string-append "file://" destination-path)) - (cons "path" destination-path)))) + (define (copy-input-files input inputs-directory) + ;; Copy input files and update corresponding input objects. + (cond + ((vector? input) + (vector-map (cut copy-input-files <> inputs-directory) + input)) + ((eq? (object-type input) + 'File) + (let ((path-in-inputs-directory + ;; Input files may have the same filename. So, we take + ;; the additional precaution of copying input files + ;; into their own hash-prefixed subdirectories, just + ;; like they are in the ravanan store. + (expand-file-name (file-name-join + (take-right (file-name-split + (assoc-ref input "path")) + 2)) + inputs-directory))) + (make-directories (file-dirname path-in-inputs-directory)) + (copy-file (assoc-ref input "path") + path-in-inputs-directory) + (maybe-assoc-set input + (cons "location" + (just path-in-inputs-directory)) + (cons "path" + (just path-in-inputs-directory)) + (cons "basename" + (just (basename path-in-inputs-directory))) + (cons "nameroot" + (just (file-name-stem path-in-inputs-directory))) + (cons "nameext" + (just (file-name-extension path-in-inputs-directory))) + (cons "secondaryFiles" + (maybe-let* ((secondary-files + (maybe-assoc-ref (just input) "secondaryFiles"))) + (just (vector-map (cut copy-input-files <> inputs-directory) + secondary-files))))))) + (else input))) - (define (capture-secondary-file path secondary-file - workflow-output-directory) - "Capture @var{secondary-file} for primary @var{path} and return its + (define (copy-file-value value directory) + ;; Copy file represented by value to directory and return the + ;; new File value. + (let* ((path (assoc-ref* value "path")) + (destination-path (expand-file-name (basename path) + directory))) + (copy-file path destination-path) + (assoc-set value + (cons "location" (string-append "file://" destination-path)) + (cons "path" destination-path)))) + + (define (capture-secondary-file path secondary-file + workflow-output-directory) + "Capture @var{secondary-file} for primary @var{path} and return its canonicalized value. If @var{required} is @code{#t} and no such secondary file is found, error out. @var{workflow-output-directory} is path to the output directory of the workflow." - (let* ((secondary-file-path (secondary-path path secondary-file)) - (secondary-file-value - (and (file-exists? secondary-file-path) - (copy-file-value (canonicalize-file-value - `(("class" . "File") - ("path" . ,secondary-file-path))) - workflow-output-directory)))) - (if (and (assoc-ref* secondary-file "required") - (not secondary-file-value)) - (user-error "Secondary file ~a missing for output path ~a" - pattern - path) - secondary-file-value))) - - (define (path+sha1->value path sha1 workflow-output-directory maybe-secondary-files) - (maybe-assoc-set (copy-file-value (canonicalize-file-value - `(("class" . "File") - ("path" . ,path) - ("checksum" . ,(string-append "sha1$" sha1)))) - workflow-output-directory) - (cons "secondaryFiles" - (maybe-let* ((secondary-files maybe-secondary-files)) - (just (vector-filter-map (cut capture-secondary-file - path - <> - workflow-output-directory) - secondary-files)))))) + (let* ((secondary-file-path (secondary-path path secondary-file)) + (secondary-file-value + (and (file-exists? secondary-file-path) + (copy-file-value (canonicalize-file-value + `(("class" . "File") + ("path" . ,secondary-file-path))) + workflow-output-directory)))) + (if (and (assoc-ref* secondary-file "required") + (not secondary-file-value)) + (user-error "Secondary file ~a missing for output path ~a" + pattern + path) + secondary-file-value))) - (define (path->value path workflow-output-directory maybe-secondary-files) - (path+sha1->value path - (sha1-hash path) - workflow-output-directory - maybe-secondary-files)) + (define (path+sha1->value path sha1 workflow-output-directory maybe-secondary-files) + (maybe-assoc-set (copy-file-value (canonicalize-file-value + `(("class" . "File") + ("path" . ,path) + ("checksum" . ,(string-append "sha1$" sha1)))) + workflow-output-directory) + (cons "secondaryFiles" + (maybe-let* ((secondary-files maybe-secondary-files)) + (just (vector-filter-map (cut capture-secondary-file + path + <> + workflow-output-directory) + secondary-files)))))) - (define (stdout-output->value workflow-output-directory - stdout-directory - stdout-filename - output) - (cons (assoc-ref output "id") - (let ((sha1 (sha1-hash stdout-filename))) - ;; Use path+sha1->value instead of path->value to avoid - ;; recomputing the SHA1 hash. - (path+sha1->value - (if (string=? stdout-filename - (file-name-join* stdout-directory "stdout")) - ;; If stdout filename is unspecified, rename it to a - ;; hash of its contents. - (let ((hashed-filename - (file-name-join* stdout-directory sha1))) - (rename-file stdout-filename - hashed-filename) - hashed-filename) - ;; Else, return the stdout filename as it is. - stdout-filename) - sha1 - workflow-output-directory - %nothing)))) + (define (path->value path workflow-output-directory maybe-secondary-files) + (path+sha1->value path + (sha1-hash path) + workflow-output-directory + maybe-secondary-files)) - (define (other-output->value workflow-output-directory - output-id output-type-tree - maybe-secondary-files glob-pattern) - (cons output-id - ;; TODO: Support all types. - (let* ((output-type (formal-parameter-type output-type-tree)) - (paths (glob glob-pattern)) - (matched-type (glob-match-type paths output-type))) - (unless matched-type - (user-error "Type ~a mismatch for globbed paths ~a" - output-type - paths)) - ;; Coerce output value into matched type. - (let ((output-values (map (cut path->value - <> - workflow-output-directory - maybe-secondary-files) - paths))) - (cond - ((memq matched-type (list 'File 'Directory)) - (match output-values - ((output-file) - output-file))) - ;; TODO: Recurse. - ((and (array-type? matched-type) - (memq (array-type-subtype matched-type) - (list 'File 'Directory))) - (list->vector output-values)) - ((eq? matched-type 'null) - 'null)))))) + (define (stdout-output->value workflow-output-directory + stdout-directory + stdout-filename + output) + (cons (assoc-ref output "id") + (let ((sha1 (sha1-hash stdout-filename))) + ;; Use path+sha1->value instead of path->value to avoid + ;; recomputing the SHA1 hash. + (path+sha1->value + (if (string=? stdout-filename + (file-name-join* stdout-directory "stdout")) + ;; If stdout filename is unspecified, rename it to a + ;; hash of its contents. + (let ((hashed-filename + (file-name-join* stdout-directory sha1))) + (rename-file stdout-filename + hashed-filename) + hashed-filename) + ;; Else, return the stdout filename as it is. + stdout-filename) + sha1 + workflow-output-directory + %nothing)))) - (define (stage-file file entry-name) - ;; Stage file as entry-name and return the staged File value. - (rename-file (assoc-ref* file "path") - entry-name) - (canonicalize-file-value - (maybe-assoc-set `(("class" . "File") - ("path" . ,entry-name)) - (cons "secondaryFiles" - (maybe-let* ((secondary-files - (maybe-assoc-ref (just file) "secondaryFiles"))) - (just (vector-map (lambda (file) - (stage-file file (assoc-ref* file "basename"))) - secondary-files))))))) + (define (other-output->value workflow-output-directory + output-id output-type-tree + maybe-secondary-files glob-pattern) + (cons output-id + ;; TODO: Support all types. + (let* ((output-type (formal-parameter-type output-type-tree)) + (paths (glob glob-pattern)) + (matched-type (glob-match-type paths output-type))) + (unless matched-type + (user-error "Type ~a mismatch for globbed paths ~a" + output-type + paths)) + ;; Coerce output value into matched type. + (let ((output-values (map (cut path->value + <> + workflow-output-directory + maybe-secondary-files) + paths))) + (cond + ((memq matched-type (list 'File 'Directory)) + (match output-values + ((output-file) + output-file))) + ;; TODO: Recurse. + ((and (array-type? matched-type) + (memq (array-type-subtype matched-type) + (list 'File 'Directory))) + (list->vector output-values)) + ((eq? matched-type 'null) + 'null)))))) - ;; Stage files. - ;; We currently support File and Dirent only. TODO: Support others. - (define (stage-files entries outputs-directory) - ;; Stage entries and return an association list mapping files - ;; (presumably input files) that were staged. - (filter-map (match-lambda - ((entry-name entry) - (cond - ;; Stuff string literal into a file. - ((string? entry) - (call-with-input-file entry-name - (cut put-string <> entry)) - #f) - ;; Symlink to the file. - ((eq? (object-type entry) - 'File) - (cons entry - (stage-file entry entry-name)))))) - entries)) + (define (stage-file file entry-name) + ;; Stage file as entry-name and return the staged File value. + (rename-file (assoc-ref* file "path") + entry-name) + (canonicalize-file-value + (maybe-assoc-set `(("class" . "File") + ("path" . ,entry-name)) + (cons "secondaryFiles" + (maybe-let* ((secondary-files + (maybe-assoc-ref (just file) "secondaryFiles"))) + (just (vector-map (lambda (file) + (stage-file file (assoc-ref* file "basename"))) + secondary-files))))))) - (define (set-staged-path input staging-mapping) - ;; If input is a File type input that was staged, return new - ;; staged value. Else, return as is. - (cond - ;; Recurse on vector inputs. - ((vector? input) - (list->vector - (map (cut set-staged-path <> staging-mapping) - (vector->list input)))) - ;; Try to replace File input value with staged value. - ((eq? (object-type input) - 'File) - (or (any (match-lambda - ((old-value . new-value) - (and (alist=? input old-value) - new-value))) - staging-mapping) - input)) - ;; Else, return as is. - (else input))) + ;; Stage files. + ;; We currently support File and Dirent only. TODO: Support others. + (define (stage-files entries outputs-directory) + ;; Stage entries and return an association list mapping files + ;; (presumably input files) that were staged. + (filter-map (match-lambda + ((entry-name entry) + (cond + ;; Stuff string literal into a file. + ((string? entry) + (call-with-input-file entry-name + (cut put-string <> entry)) + #f) + ;; Symlink to the file. + ((eq? (object-type entry) + 'File) + (cons entry + (stage-file entry entry-name)))))) + entries)) - ;; Set search paths for manifest. - (for-each (match-lambda - ((name . value) - (setenv name value))) - '#$(match packages - ;; No package specifications; try the manifest - ;; file. - (#() - (manifest-file->environment manifest-file - channels - guix-daemon-socket)) - ;; Use package specifications to build an - ;; environment. - (_ - (software-packages->environment packages - channels - guix-daemon-socket)))) + (define (set-staged-path input staging-mapping) + ;; If input is a File type input that was staged, return new + ;; staged value. Else, return as is. + (cond + ;; Recurse on vector inputs. + ((vector? input) + (list->vector + (map (cut set-staged-path <> staging-mapping) + (vector->list input)))) + ;; Try to replace File input value with staged value. + ((eq? (object-type input) + 'File) + (or (any (match-lambda + ((old-value . new-value) + (and (alist=? input old-value) + new-value))) + staging-mapping) + input)) + ;; Else, return as is. + (else input))) - (call-with-temporary-directory - (lambda (inputs-directory) - ;; We need to canonicalize JSON trees before inserting them - ;; into G-expressions. If we don't, we would have degenerate - ;; G-expressions that produce exactly the same result. - (let ((inputs #$(copy-input-files-gexp (canonicalize-json inputs))) - (runtime `(("cores" . ,#$(cores batch-system))))) + ;; Set search paths for manifest. + (for-each (match-lambda + ((specification . value) + (setenv (search-path-specification-variable specification) + value))) + (evaluate-search-paths + (map sexp->search-path-specification + '#$search-path-sexps) + '(#$profile-derivation))) + (call-with-temporary-directory + (lambda (inputs-directory) + (let ((inputs (map (match-lambda + ((id . input) + (cons id + (copy-input-files input inputs-directory)))) + (json-string->scm + (getenv "WORKFLOW_INPUTS")))) + (runtime `(("cores" . ,#$(cores batch-system))))) - ;; Set environment defined by workflow. - (for-each (match-lambda - ((name value) - (setenv name value))) - (list #$@(from-maybe - (maybe-bind - (find-requirement requirements - "EnvVarRequirement") - environment-variables) - (list)))) + ;; Set environment defined by workflow. + (for-each (match-lambda + ((name value) + (setenv name value))) + (list #$@(from-maybe + (maybe-bind + (find-requirement requirements + "EnvVarRequirement") + environment-variables) + (list)))) - (call-with-temporary-directory - (lambda (stdout-directory) - (call-with-temporary-directory - (lambda (outputs-directory) - (call-with-current-directory outputs-directory - (lambda () - (let* ((staging-mapping - (stage-files (list #$@(from-maybe - (maybe-bind initial-work-dir-requirement - (compose just files-to-stage)) - (list))) - outputs-directory)) - (inputs - (map (match-lambda - ((id . input) - (cons id - (set-staged-path input - staging-mapping)))) - inputs))) - ;; Actually run the command. - #$run-command-gexp - ;; Capture outputs. - #$capture-outputs-gexp)))) - #$scratch)) - #$scratch))) - #$scratch))))) - guix-daemon-socket)) + (call-with-temporary-directory + (lambda (stdout-directory) + (call-with-temporary-directory + (lambda (outputs-directory) + (call-with-current-directory outputs-directory + (lambda () + (let* ((staging-mapping + (stage-files (list #$@(from-maybe + (maybe-bind initial-work-dir-requirement + (compose just files-to-stage)) + (list))) + outputs-directory)) + (inputs + (map (match-lambda + ((id . input) + (cons id + (set-staged-path input + staging-mapping)))) + inputs))) + ;; Actually run the command. + #$run-command-gexp + ;; Capture outputs. + #$capture-outputs-gexp)))) + #$scratch)) + #$scratch))) + #$scratch)))))))) diff --git a/ravanan/job-state.scm b/ravanan/job-state.scm index a769698..2894618 100644 --- a/ravanan/job-state.scm +++ b/ravanan/job-state.scm @@ -34,18 +34,21 @@ slurm-job-state job-state-script + job-state-inputs job-state-status)) (define-immutable-record-type <single-machine-job-state> - (single-machine-job-state script success?) + (single-machine-job-state script inputs success?) single-machine-job-state? (script single-machine-job-state-script) + (inputs single-machine-job-state-inputs) (success? single-machine-job-state-success?)) (define-immutable-record-type <slurm-job-state> - (slurm-job-state script job-id) + (slurm-job-state script inputs job-id) slurm-job-state? (script slurm-job-state-script) + (inputs slurm-job-state-inputs) (job-id slurm-job-state-job-id)) (define (job-state-script state) @@ -56,6 +59,14 @@ slurm-job-state-script)) state)) +(define (job-state-inputs state) + ((cond + ((single-machine-job-state? state) + single-machine-job-state-inputs) + ((slurm-job-state? state) + slurm-job-state-inputs)) + state)) + (define* (job-state-status state batch-system) "Return current status of job with @var{state} on @var{batch-system}. The status is one of the symbols @code{completed}, @code{failed} or @code{pending} diff --git a/ravanan/propnet.scm b/ravanan/propnet.scm index 34624b5..610991d 100644 --- a/ravanan/propnet.scm +++ b/ravanan/propnet.scm @@ -26,22 +26,26 @@ #:use-module (ravanan work monads) #:use-module (ravanan work utils) #:export (propnet + propnet? propnet-propagators propnet-value=? propnet-merge-values propnet-scheduler propagator + propagator? propagator-name propagator-proc propagator-inputs propagator-optional-inputs propagator-outputs scheduler + scheduler? scheduler-schedule scheduler-poll scheduler-capture-output schedule-propnet state+status + state+status? state+status-state state+status-status poll-propnet @@ -64,6 +68,12 @@ (optional-inputs propagator-optional-inputs) (outputs propagator-outputs)) +(set-record-type-printer! <propagator> + (lambda (record port) + (display "#<<propagator> " port) + (write (propagator-name record) port) + (display ">" port))) + (define-immutable-record-type <scheduler> (scheduler schedule poll capture-output) scheduler? @@ -86,6 +96,18 @@ (propagators-in-flight propnet-state-propagators-in-flight) (propagators-inbox propnet-state-propagators-inbox)) +(set-record-type-printer! <propnet-state> + (lambda (record port) + (display "#<<propnet-state> cells: " port) + (write (run-with-state (propnet-state-cells record)) port) + (display " cells-inbox: " port) + (write (run-with-state (propnet-state-cells-inbox record)) port) + (display " propagators-in-flight: " port) + (write (run-with-state (propnet-state-propagators-in-flight record)) port) + (display " propagators-inbox: " port) + (write (run-with-state (propnet-state-propagators-inbox record)) port) + (display ">" port))) + (define (partition-map pred proc lst) "Partition @var{lst} into two lists using @var{pred} like @code{partition}. Then, map @var{proc} over both the lists and return the resulting lists." diff --git a/ravanan/reader.scm b/ravanan/reader.scm index a4e57c7..fd959de 100644 --- a/ravanan/reader.scm +++ b/ravanan/reader.scm @@ -101,18 +101,31 @@ each association list of the returned vector of association lists. If (define (normalize-env-var-requirement env-var-requirement) (assoc-set env-var-requirement - (cons "envDef" - (coerce-alist->vector - (assoc-ref env-var-requirement "envDef") - "envName" "envValue")))) + (cons "envDef" + (coerce-alist->vector + (assoc-ref env-var-requirement "envDef") + "envName" "envValue")))) + +(define (normalize-software-requirement software-requirement) + (maybe-assoc-set software-requirement + ;; Canonicalize manifest file path so that we look it up with respect to the + ;; path of the workflow file. + (cons "manifest" + (maybe-bind (maybe-assoc-ref (just software-requirement) + "manifest") + (compose just canonicalize-path))))) (define (normalize-requirements maybe-requirements) (maybe-let* ((requirements maybe-requirements)) (just (vector-map (lambda (requirement) - (if (string=? (assoc-ref requirement "class") - "EnvVarRequirement") - (normalize-env-var-requirement requirement) - requirement)) + (let ((class (assoc-ref requirement "class"))) + (cond + ((string=? class "EnvVarRequirement") + (normalize-env-var-requirement requirement)) + ((string=? class "SoftwareRequirement") + (normalize-software-requirement requirement)) + (else + requirement)))) (coerce-alist->vector requirements "class"))))) (define (normalize-secondary-files secondary-files default-required) diff --git a/ravanan/store.scm b/ravanan/store.scm index 5cb4a64..ba66076 100644 --- a/ravanan/store.scm +++ b/ravanan/store.scm @@ -18,21 +18,26 @@ (define-module (ravanan store) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) #:use-module (ice-9 filesystem) + #:use-module (gcrypt hash) + #:use-module (guix base16) + #:use-module (guix base32) + #:use-module (guix build utils) #:use-module (ravanan work command-line-tool) #:use-module (ravanan work monads) + #:use-module (ravanan work utils) #:use-module (ravanan work vectors) #:export (%store-files-directory %store-data-directory %store-logs-directory make-store - script->store-files-directory - script->store-data-file - script->store-stdout-file - script->store-stderr-file - intern-file - store-item-name)) + step-store-files-directory + step-store-data-file + step-store-stdout-file + step-store-stderr-file + intern-file)) (define %store-files-directory "files") @@ -57,29 +62,56 @@ already exists, do nothing." %store-data-directory %store-logs-directory)))) -(define (script->store-files-directory script store) - "Return the store files directory in @var{store} corresponding to @var{script} -path." +(define (sha1-hash-sexp tree) + (bytevector->base32-string + (let ((port get-hash (open-hash-port (hash-algorithm sha1)))) + ;; tree should probably be canonicalized using canonical S-expressions or + ;; similar. But, it doesn't matter much for our purposes. write already + ;; canonicalizes in a way. In the unlikely case of a problem, the worst + ;; that can happen is that we recompute all steps of the workflow. + (write tree port) + (close port) + (get-hash)))) + +(define (step-store-basename script inputs) + "Return the basename in the store for files of CWL step with @var{script} and +@var{inputs}." + (string-append (sha1-hash-sexp (cons script (canonicalize-json inputs))) + "-" + (strip-store-file-name script))) + +(define (step-store-files-directory script inputs store) + "Return the @var{store} files directory for CWL step with @var{script} and +@var{inputs}." (expand-file-name (file-name-join* %store-files-directory - (basename script)) + (step-store-basename script inputs)) store)) -(define (script->store-data-file script store) - "Return the store data file in @var{store} corresponding to @var{script} path." +(define (step-store-data-file script inputs store) + "Return the @var{store} data file for CWL step with @var{script} and +@var{inputs}." (expand-file-name (file-name-join* %store-data-directory - (string-append (basename script) ".json")) + (string-append + (step-store-basename script inputs) + ".json")) store)) -(define (script->store-stdout-file script store) - "Return the store stdout file in @var{store} corresponding to @var{script} path." +(define (step-store-stdout-file script inputs store) + "Return the @var{store} stdout file for CWL step with @var{script} and +@var{inputs}." (expand-file-name (file-name-join* %store-logs-directory - (string-append (basename script) ".stdout")) + (string-append + (step-store-basename script inputs) + ".stdout")) store)) -(define (script->store-stderr-file script store) - "Return the store stderr file in @var{store} corresponding to @var{script} path." +(define (step-store-stderr-file script inputs store) + "Return the @var{store} stderr file for CWL step with @var{script} and +@var{inputs}." (expand-file-name (file-name-join* %store-logs-directory - (string-append (basename script) ".stderr")) + (string-append + (step-store-basename script inputs) + ".stderr")) store)) (define (same-filesystem? path1 path2) @@ -96,8 +128,9 @@ interned path and location." (checksum (assoc-ref file "checksum")) (sha1 (if (and checksum (string-prefix? "sha1$" checksum)) - (string-drop checksum (string-length "sha1$")) - (sha1-hash path))) + (base16-string->bytevector + (string-drop checksum (string-length "sha1$"))) + (sha1-hash-bytes path))) (interned-path (if (string-prefix? store path) ;; If file is already a store path, return it as is. @@ -108,9 +141,10 @@ interned path and location." (let ((interned-path (expand-file-name (file-name-join* %store-files-directory - (string-append sha1 + (string-append (bytevector->base32-string sha1) "-" - (basename path))) + (basename path)) + (basename path)) store))) (if (file-exists? interned-path) (format (current-error-port) @@ -120,6 +154,7 @@ interned path and location." (format (current-error-port) "Interning ~a into store as ~a~%" path interned-path) + (mkdir (dirname interned-path)) ;; Hard link if on the same filesystem. Else, copy. ((if (same-filesystem? path (expand-file-name %store-files-directory @@ -140,11 +175,4 @@ interned path and location." (just (vector-map (cut intern-file <> store) secondary-files))))))) -;; Length of a base-16 encoded SHA1 hash -(define %store-hash-length 40) -(define (store-item-name path) - "Return the basename of store item @var{path} with the store hash stripped out." - (string-drop (basename path) - ;; the hash and the dash after the hash - (1+ %store-hash-length))) diff --git a/ravanan/utils.scm b/ravanan/utils.scm index a76a14c..e4fad9c 100644 --- a/ravanan/utils.scm +++ b/ravanan/utils.scm @@ -1,5 +1,5 @@ ;;; ravanan --- High-reproducibility CWL runner powered by Guix -;;; Copyright © 2024 Arun Isaac <arunisaac@systemreboot.net> +;;; Copyright © 2024, 2025 Arun Isaac <arunisaac@systemreboot.net> ;;; ;;; This file is part of ravanan. ;;; @@ -54,4 +54,4 @@ before loading script." ;; define-module invocation" warning during compilation. But, it is ;; probably safe to ignore this warning since we use load only within a ;; dummy module. - (load (canonicalize-path script-file)))))) + (load script-file))))) diff --git a/ravanan/work/command-line-tool.scm b/ravanan/work/command-line-tool.scm index d33c80c..3c9934f 100644 --- a/ravanan/work/command-line-tool.scm +++ b/ravanan/work/command-line-tool.scm @@ -19,6 +19,7 @@ (define-module (ravanan work command-line-tool) #:use-module (rnrs exceptions) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-26) #:use-module (ice-9 filesystem) #:use-module (ice-9 format) @@ -29,6 +30,7 @@ #:use-module (json) #:use-module (ravanan work monads) #:use-module (ravanan work types) + #:use-module (ravanan work ui) #:use-module (ravanan work utils) #:use-module (ravanan work vectors) #:export (value->string @@ -39,11 +41,22 @@ formal-parameter-type run-command sha1-hash + sha1-hash-bytes checksum location->path canonicalize-file-value secondary-path - evaluate-javascript)) + evaluate-javascript + + command-line-binding + command-line-binding? + command-line-binding-position + command-line-binding-prefix + command-line-binding-type + command-line-binding-value + command-line-binding-item-separator + command-line-binding->args + build-command)) (define (value->string x) "Convert value @var{x} to a string." @@ -202,11 +215,14 @@ status in @var{success-codes} as success. Error out otherwise." (with-output-to-port (current-error-port) (cut invoke command)))))) +(define (sha1-hash-bytes file) + "Return the SHA1 hash of @var{file} as a bytevector." + (file-hash (lookup-hash-algorithm 'sha1) + file)) + (define (sha1-hash file) "Return the SHA1 hash of @var{file} as a hexadecimal string." - (bytevector->base16-string - (file-hash (lookup-hash-algorithm 'sha1) - file))) + (bytevector->base16-string (sha1-hash-bytes file))) (define (checksum file) "Return the checksum of @var{file} as defined in the CWL specification." @@ -262,3 +278,155 @@ actually paths." (format #f "--eval=~a console.log(\"%j\", ~a)" preamble expression)) json->scm))) + +(define-immutable-record-type <command-line-binding> + (command-line-binding position prefix type value item-separator) + command-line-binding? + (position command-line-binding-position) + (prefix command-line-binding-prefix) + (type command-line-binding-type) + (value command-line-binding-value) + (item-separator command-line-binding-item-separator)) + +(define (command-line-binding->args binding) + "Return a list of arguments for @var{binding}. The returned list may +contain strings or G-expressions. The G-expressions may reference an +@code{inputs-directory} variable that must be defined in the context in which +the G-expressions are inserted." + (let ((prefix (command-line-binding-prefix binding)) + (type (command-line-binding-type binding)) + (value (command-line-binding-value binding))) + (cond + ((eq? type 'boolean) + (if value + ;; TODO: Error out if boolean input has no prefix? + (maybe->list prefix) + (list))) + ((eq? type 'null) (list)) + ((array-type? type) + (match value + ;; Empty arrays should be noops. + (() (list)) + (_ + (let ((args (append-map command-line-binding->args + value))) + (append (maybe->list prefix) + (from-maybe + (maybe-let* ((item-separator (command-line-binding-item-separator binding))) + (just (list (string-join args item-separator)))) + args)))))) + (else + (append (maybe->list prefix) + (list (case type + ((string) + value) + ((int float) + (number->string value)) + ((File) + (assoc-ref* value "path")) + (else + (user-error "Invalid formal input type ~a" + type))))))))) + +(define (build-command base-command arguments formal-inputs inputs) + "Return a list of @code{<command-line-binding>} objects for a +@code{CommandLineTool} class workflow with @var{base-command}, @var{arguments}, +@var{formal-inputs} and @var{inputs}. The @code{value} field of the returned +@code{<command-line-binding>} objects may be strings or G-expressions. The +G-expressions may reference @var{inputs} and @var{runtime} variables that must +be defined in the context in which the G-expressions are inserted." + (define (argument->command-line-binding i argument) + (command-line-binding (cond + ((assoc-ref argument "position") + => string->number) + (else i)) + (maybe-assoc-ref (just argument) "prefix") + 'string + (value->string (assoc-ref* argument "valueFrom")) + %nothing)) + + (define (collect-bindings ids+inputs+types+bindings) + (append-map id+input+type-tree+binding->command-line-binding + ids+inputs+types+bindings)) + + (define id+input+type-tree+binding->command-line-binding + (match-lambda + ;; We stretch the idea of an input id, by making it an address that + ;; identifies the exact location of a value in a tree that possibly + ;; contains array types. For example, '("foo") identifies the input "foo"; + ;; '("foo" 1) identifies the 1th element of the array input "foo"; '("foo" + ;; 37 1) identifies the 1th element of the 37th element of the array input + ;; "foo"; etc. + ((id input type-tree binding) + ;; Check type. + (let* ((type (formal-parameter-type type-tree)) + (matched-type (match-type input type))) + (unless matched-type + (error input "Type mismatch" input type)) + (let ((position + (from-maybe + (maybe-let* ((position (maybe-assoc-ref binding "position"))) + (just (string->number position))) + ;; FIXME: Why a default value of 0? + 0)) + (prefix (maybe-assoc-ref binding "prefix"))) + (cond + ;; Recurse over array types. + ;; TODO: Implement record and enum types. + ((array-type? matched-type) + (list (command-line-binding + position + prefix + matched-type + (append-map (lambda (i input) + (id+input+type-tree+binding->command-line-binding + (list (append id (list i)) + input + (assoc-ref type-tree "items") + (maybe-assoc-ref (just type-tree) + "inputBinding")))) + (iota (vector-length input)) + (vector->list input)) + (maybe-assoc-ref binding "itemSeparator")))) + (else + (list (command-line-binding position + prefix + matched-type + (apply json-ref inputs id) + %nothing))))))))) + + ;; For details of this algorithm, see §4.1 Input binding of the CWL + ;; 1.2 CommandLineTool specification: + ;; https://www.commonwl.org/v1.2/CommandLineTool.html#Input_binding + (append + ;; Insert elements from baseCommand. + (vector->list (or base-command + (vector))) + (sort + (append + ;; Collect CommandLineBinding objects from arguments; assign a sorting key. + (vector->list + (vector-map-indexed argument->command-line-binding + (or arguments + #()))) + ;; Collect CommandLineBinding objects from the inputs schema; assign a + ;; sorting key. + (collect-bindings + (filter-map (lambda (formal-input) + ;; Exclude formal inputs without an inputBinding. + (and (assoc "inputBinding" formal-input) + (let ((id (assoc-ref formal-input "id"))) + (list (list id) + (or (assoc-ref inputs id) + (assoc-ref formal-input "default") + 'null) + (or (assoc-ref formal-input "type") + (user-error "Type of input ~a not specified" + id)) + (maybe-assoc-ref (just formal-input) + "inputBinding"))))) + (vector->list formal-inputs)))) + ;; Sort elements using the assigned sorting keys. + (lambda (binding1 binding2) + (< (command-line-binding-position binding1) + (command-line-binding-position binding2)))))) diff --git a/ravanan/workflow.scm b/ravanan/workflow.scm index 2770f31..2de254b 100644 --- a/ravanan/workflow.scm +++ b/ravanan/workflow.scm @@ -27,6 +27,8 @@ #:use-module (ice-9 filesystem) #:use-module (ice-9 match) #:use-module (web uri) + #:use-module (guix inferior) + #:use-module (guix store) #:use-module (ravanan batch-system) #:use-module (ravanan command-line-tool) #:use-module (ravanan job-state) @@ -59,16 +61,28 @@ (define-condition-type &job-failure &error job-failure job-failure? - (script job-failure-script)) + (script job-failure-script) + (inputs job-failure-inputs)) (define-immutable-record-type <scheduler-proc> - (scheduler-proc name cwl scatter scatter-method) + (-scheduler-proc name script-or-propnet formal-inputs formal-outputs + resource-requirement scatter scatter-method) scheduler-proc? (name scheduler-proc-name) - (cwl scheduler-proc-cwl) + (script-or-propnet scheduler-proc-script-or-propnet) + (formal-inputs scheduler-proc-formal-inputs) + (formal-outputs scheduler-proc-formal-outputs) + (resource-requirement scheduler-proc-resource-requirement) (scatter scheduler-proc-scatter) (scatter-method scheduler-proc-scatter-method)) +(define* (scheduler-proc name script-or-propnet formal-inputs formal-outputs + #:optional + (resource-requirement %nothing) + (scatter %nothing) (scatter-method %nothing)) + (-scheduler-proc name script-or-propnet formal-inputs formal-outputs + resource-requirement scatter scatter-method)) + (define-immutable-record-type <command-line-tool-state> (command-line-tool-state job-state formal-outputs) command-line-tool-state? @@ -167,67 +181,120 @@ requirements and hints of the step." (assoc-ref* input "type")))) (assoc-ref input "id"))) -(define* (command-line-tool->propagator name cwl) - "Convert @code{CommandLineTool} workflow @var{cwl} of @var{name} to a -propagator." - (propagator name - (scheduler-proc name cwl %nothing %nothing) - (vector-map->list (lambda (input) - (cons (assoc-ref input "id") - (assoc-ref input "id"))) - (assoc-ref cwl "inputs")) - ;; Inputs that either have a default or accept null values are - ;; optional. - (vector-filter-map->list optional-input? - (assoc-ref cwl "inputs")) - (vector-map->list (lambda (output) - (cons (assoc-ref output "id") - (assoc-ref output "id"))) - (assoc-ref cwl "outputs")))) - -(define* (workflow-class->propnet name cwl scheduler batch-system) +(define* (workflow->scheduler-proc name cwl scheduler + manifest-file inferior scratch store + batch-system guix-store + #:optional + (scatter %nothing) + (scatter-method %nothing)) + "Return a @code{<scheduler-proc>} object for @var{cwl} workflow named @var{name} +scheduled using @var{scheduler}. @var{scatter} and @var{scatter-method} are the +CWL scattering properties of this step. Build @code{CommandLineTool} workflow +scripts using @var{guix-store}. + +@var{manifest-file}, @var{scratch}, @var{store} and @var{batch-system} are the +same as in @code{run-workflow}. @var{inferior} is the same as in +@code{build-command-line-tool-script} from @code{(ravanan command-line-tool)}." + (scheduler-proc name + (let ((class (assoc-ref* cwl "class"))) + (cond + ((string=? class "CommandLineTool") + (run-with-store guix-store + (build-command-line-tool-script name + manifest-file + inferior + cwl + scratch + store + batch-system))) + ((string=? class "ExpressionTool") + (error "Workflow class not implemented yet" class)) + ((string=? class "Workflow") + (workflow-class->propnet cwl + scheduler + manifest-file + inferior + scratch + store + batch-system + guix-store)) + (else + (assertion-violation class "Unexpected workflow class")))) + (assoc-ref* cwl "inputs") + (assoc-ref* cwl "outputs") + (find-requirement (inherit-requirements + (or (assoc-ref cwl "requirements") + #()) + (or (assoc-ref cwl "hints") + #())) + "ResourceRequirement") + scatter + scatter-method)) + +(define* (workflow-class->propnet cwl scheduler + manifest-file inferior scratch store + batch-system guix-store) "Return a propagator network scheduled using @var{scheduler} on -@var{batch-system} for @var{cwl}, a @code{Workflow} class workflow with -@var{name}." +@var{batch-system} for @var{cwl}, a @code{Workflow} class workflow. Build +@code{CommandLineTool} workflow scripts using @var{guix-store}. + +@var{manifest-file}, @var{scratch}, @var{store}, @var{batch-system} and +@var{guix-daemon-socket} are the same as in @code{run-workflow}. @var{inferior} +is the same as in @code{build-command-line-tool-script} from @code{(ravanan +command-line-tool)}." (define (normalize-scatter-method scatter-method) (assoc-ref* '(("dotproduct" . dot-product) ("nested_crossproduct" . nested-cross-product) ("flat_crossproduct" . flat-cross-product)) scatter-method)) + (define (step->scheduler-proc step parent-requirements parent-hints) + (let ((run (assoc-ref* step "run"))) + (workflow->scheduler-proc (assoc-ref* step "id") + (inherit-requirements-and-hints + run + parent-requirements + parent-hints + (or (assoc-ref step "requirements") + #()) + (or (assoc-ref step "hints") + #())) + scheduler + manifest-file + inferior + scratch + store + batch-system + guix-store + (maybe-assoc-ref (just step) "scatter") + (maybe-bind (maybe-assoc-ref (just step) "scatterMethod") + (compose just normalize-scatter-method))))) + (define (step->propagator step) - (let* ((step-id (assoc-ref* step "id")) - (step-propagator - (command-line-tool->propagator step-id (assoc-ref* step "run")))) - (propagator (propagator-name step-propagator) - (let ((proc (propagator-proc step-propagator))) - (scheduler-proc (scheduler-proc-name proc) - (inherit-requirements-and-hints - (scheduler-proc-cwl proc) - (or (assoc-ref cwl "requirements") - #()) - (or (assoc-ref cwl "hints") - #()) - (or (assoc-ref step "requirements") - #()) - (or (assoc-ref step "hints") - #())) - (maybe-assoc-ref (just step) "scatter") - (maybe-bind (maybe-assoc-ref (just step) "scatterMethod") - (compose just normalize-scatter-method)))) - (map (match-lambda - ((input-id . _) - (cons input-id - (json-ref step "in" input-id)))) - (propagator-inputs step-propagator)) - (propagator-optional-inputs step-propagator) - (filter-map (match-lambda - ((output . cell) - (and (vector-member output - (assoc-ref* step "out")) - (cons output - (string-append step-id "/" cell))))) - (propagator-outputs step-propagator))))) + (let ((step-id (assoc-ref* step "id")) + (run (assoc-ref* step "run"))) + (propagator step-id + (step->scheduler-proc step + (or (assoc-ref cwl "requirements") + #()) + (or (assoc-ref cwl "hints") + #())) + (vector-map->list (lambda (input) + (let ((input-id (assoc-ref input "id"))) + (cons input-id + (json-ref step "in" input-id)))) + (assoc-ref run "inputs")) + ;; Inputs that either have a default or accept null values are + ;; optional. + (vector-filter-map->list optional-input? + (assoc-ref run "inputs")) + (vector-map->list (lambda (output) + (let ((output-id (assoc-ref output "id"))) + (and (vector-member output-id + (assoc-ref* step "out")) + (cons output-id + (string-append step-id "/" output-id))))) + (assoc-ref run "outputs"))))) (maybe-let* ((requirements (maybe-assoc-ref (just cwl) "requirements"))) (check-requirements requirements @@ -246,26 +313,28 @@ propagator." merge-values scheduler)) -(define* (workflow-scheduler manifest-file channels scratch store batch-system - #:key guix-daemon-socket) +(define* (workflow-scheduler store batch-system) (define (schedule proc inputs scheduler) "Schedule @var{proc} with inputs from the @var{inputs} association list. Return a -state-monadic job state object. @var{proc} may either be a @code{<propnet>} -object or a @code{<scheduler-proc>} object." +state-monadic job state object. @var{proc} must be a @code{<scheduler-proc>} +object." (let* ((name (scheduler-proc-name proc)) - (cwl (scheduler-proc-cwl proc)) + (script-or-propnet (scheduler-proc-script-or-propnet proc)) (scatter (from-maybe (scheduler-proc-scatter proc) #f)) (scatter-method (from-maybe (scheduler-proc-scatter-method proc) - #f)) - (class (assoc-ref* cwl "class"))) + #f))) (if scatter (case scatter-method ((dot-product) (apply state-map (lambda input-elements ;; Recurse with scattered inputs spliced in. - (schedule (scheduler-proc name cwl %nothing %nothing) + (schedule (scheduler-proc name + script-or-propnet + (scheduler-proc-formal-inputs proc) + (scheduler-proc-formal-outputs proc) + (scheduler-proc-resource-requirement proc)) ;; Replace scattered inputs with single ;; elements. (apply assoc-set @@ -281,38 +350,29 @@ object or a @code{<scheduler-proc>} object." ((nested-cross-product flat-cross-product) (error scatter-method "Scatter method not implemented yet"))) - (let* ((formal-inputs (assoc-ref* cwl "inputs")) - ;; We need to resolve inputs after adding defaults since the - ;; default values may contain uninterned File objects. - (inputs (resolve-inputs (add-defaults inputs formal-inputs) - formal-inputs - store))) - (cond - ((string=? class "CommandLineTool") - (state-let* ((job-state - (run-command-line-tool name - manifest-file - channels - cwl - inputs - scratch - store - batch-system - #:guix-daemon-socket guix-daemon-socket))) - (state-return (command-line-tool-state job-state - (assoc-ref* cwl "outputs"))))) - ((string=? class "ExpressionTool") - (error "Workflow class not implemented yet" class)) - ((string=? class "Workflow") - (state-let* ((propnet-state - (schedule-propnet (workflow-class->propnet name - cwl - scheduler - batch-system) - inputs))) + (if (propnet? script-or-propnet) + (state-let* ((propnet-state (schedule-propnet script-or-propnet inputs))) (state-return (workflow-state propnet-state - (assoc-ref* cwl "outputs")))))))))) + (scheduler-proc-formal-outputs proc)))) + (let* ((formal-inputs (scheduler-proc-formal-inputs proc)) + ;; We need to resolve inputs after adding defaults since + ;; the default values may contain uninterned File objects. + (inputs (resolve-inputs (add-defaults inputs formal-inputs) + formal-inputs + store)) + (resource-requirement + (scheduler-proc-resource-requirement proc))) + (state-let* ((job-state + (run-command-line-tool name + script-or-propnet + inputs + resource-requirement + store + batch-system))) + (state-return + (command-line-tool-state job-state + (scheduler-proc-formal-outputs proc))))))))) (define (poll state) "Return updated state and current status of job @var{state} object as a @@ -341,7 +401,8 @@ state-monadic @code{<state+status>} object. The status is one of the symbols (case status ((failed) (raise-exception (job-failure - (job-state-script job-state)))) + (job-state-script job-state) + (job-state-inputs job-state)))) (else => identity))))))) ;; Poll sub-workflow state. We do not need to check the status here since ;; job failures only occur at the level of a CommandLineTool. @@ -414,16 +475,17 @@ is the class of the workflow." head-output)))))) (else ;; Log progress and return captured output. - (let ((script (job-state-script (command-line-tool-state-job-state state)))) + (let ((script (job-state-script (command-line-tool-state-job-state state))) + (inputs (job-state-inputs (command-line-tool-state-job-state state)))) (state-return (begin (format (current-error-port) "~a completed; logs at ~a and ~a~%" script - (script->store-stdout-file script store) - (script->store-stderr-file script store)) + (step-store-stdout-file script inputs store) + (step-store-stderr-file script inputs store)) (filter-outputs "CommandLineTool" - (capture-command-line-tool-output script store) + (capture-command-line-tool-output script inputs store) (command-line-tool-state-formal-outputs state)))))))) (scheduler schedule poll capture-output)) @@ -455,8 +517,8 @@ files found into the @var{store} and return a tree of the fully resolved inputs. "Return @code{#t} if @var{secondary-file} matches at least one secondary file in @var{input}." (vector-any (lambda (candidate) - (string=? (store-item-name (assoc-ref* candidate "path")) - (secondary-path (store-item-name (assoc-ref* input "path")) + (string=? (basename (assoc-ref* candidate "path")) + (secondary-path (basename (assoc-ref* input "path")) secondary-file))) (or (assoc-ref input "secondaryFiles") (user-error "Missing secondaryFiles in input ~a" @@ -524,6 +586,39 @@ error out." formal-inputs)) formal-inputs)) +(define (call-with-inferior inferior proc) + "Call @var{proc} with @var{inferior} and return the return value of @var{proc}. +Close @var{inferior} when done, even if @var{proc} exits non-locally." + (dynamic-wind (const #t) + (cut proc inferior) + (cut close-inferior inferior))) + +(define* (build-workflow name cwl scheduler + manifest-file channels scratch store + batch-system + #:optional guix-daemon-socket) + "Build @var{cwl} workflow named @var{name} into a @code{<scheduler-proc>} object +scheduled using @var{scheduler}. When @var{guix-daemon-socket} is specified, +connect to the Guix daemon at that specific socket. Else, connect to the default +socket. + +@var{manifest-file}, @var{channels}, @var{scratch}, @var{store} and +@var{batch-system} are the same as in @code{run-workflow}." + (define builder + (cut workflow->scheduler-proc name cwl scheduler + manifest-file <> scratch store + batch-system <>)) + + (if guix-daemon-socket + (parameterize ((%daemon-socket-uri guix-daemon-socket)) + (build-workflow name cwl scheduler manifest-file channels + scratch store batch-system)) + (with-store guix-store + (if channels + (call-with-inferior (inferior-for-channels channels) + (cut builder <> guix-store)) + (builder #f guix-store))))) + (define* (run-workflow name manifest-file channels cwl inputs scratch store batch-system #:key guix-daemon-socket) @@ -537,18 +632,25 @@ area need not be shared. @var{store} is the path to the shared ravanan store. @var{guix-daemon-socket} is the Guix daemon socket to connect to." (guard (c ((job-failure? c) - (let ((script (job-failure-script c))) + (let ((script (job-failure-script c)) + (inputs (job-failure-inputs c))) (user-error "~a failed; logs at ~a and ~a~%" script - (script->store-stdout-file script store) - (script->store-stderr-file script store))))) - (let ((scheduler (workflow-scheduler - manifest-file channels scratch store batch-system - #:guix-daemon-socket guix-daemon-socket))) + (step-store-stdout-file script inputs store) + (step-store-stderr-file script inputs store))))) + (let ((scheduler (workflow-scheduler store batch-system))) (run-with-state (let loop ((mstate ((scheduler-schedule scheduler) - (scheduler-proc name cwl %nothing %nothing) + (build-workflow name + cwl + scheduler + manifest-file + channels + scratch + store + batch-system + guix-daemon-socket) inputs scheduler))) ;; Poll. diff --git a/tests/store.scm b/tests/store.scm new file mode 100644 index 0000000..f209583 --- /dev/null +++ b/tests/store.scm @@ -0,0 +1,80 @@ +;;; ravanan --- High-reproducibility CWL runner powered by Guix +;;; Copyright © 2025 Arun Isaac <arunisaac@systemreboot.net> +;;; +;;; This file is part of ravanan. +;;; +;;; ravanan is free software: you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation, either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; ravanan is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with ravanan. If not, see <https://www.gnu.org/licenses/>. + +(use-modules (srfi srfi-64) + (ravanan store)) + +(test-begin "store") + +(test-equal "step-store-files-directory must be insensitive to order of inputs" + (step-store-files-directory "/gnu/store/hl96c0xd19ngvl8rf4cyw452rpgqsi1b-foo" + '(("foo" . 1) + ("foobar" . 3) + ("bar" . (("aal" . 1) + ("vel" . 2)))) + "store") + (step-store-files-directory "/gnu/store/hl96c0xd19ngvl8rf4cyw452rpgqsi1b-foo" + '(("foo" . 1) + ("bar" . (("vel" . 2) + ("aal" . 1))) + ("foobar" . 3)) + "store")) + +(test-equal "step-store-data-file must be insensitive to order of inputs" + (step-store-data-file "/gnu/store/hl96c0xd19ngvl8rf4cyw452rpgqsi1b-foo" + '(("foo" . 1) + ("foobar" . 3) + ("bar" . (("aal" . 1) + ("vel" . 2)))) + "store") + (step-store-data-file "/gnu/store/hl96c0xd19ngvl8rf4cyw452rpgqsi1b-foo" + '(("foo" . 1) + ("bar" . (("vel" . 2) + ("aal" . 1))) + ("foobar" . 3)) + "store")) + +(test-equal "step-store-stdout-file must be insensitive to order of inputs" + (step-store-stdout-file "/gnu/store/hl96c0xd19ngvl8rf4cyw452rpgqsi1b-foo" + '(("foo" . 1) + ("foobar" . 3) + ("bar" . (("aal" . 1) + ("vel" . 2)))) + "store") + (step-store-stdout-file "/gnu/store/hl96c0xd19ngvl8rf4cyw452rpgqsi1b-foo" + '(("foo" . 1) + ("bar" . (("vel" . 2) + ("aal" . 1))) + ("foobar" . 3)) + "store")) + +(test-equal "step-store-stderr-file must be insensitive to order of inputs" + (step-store-stderr-file "/gnu/store/hl96c0xd19ngvl8rf4cyw452rpgqsi1b-foo" + '(("foo" . 1) + ("foobar" . 3) + ("bar" . (("aal" . 1) + ("vel" . 2)))) + "store") + (step-store-stderr-file "/gnu/store/hl96c0xd19ngvl8rf4cyw452rpgqsi1b-foo" + '(("foo" . 1) + ("bar" . (("vel" . 2) + ("aal" . 1))) + ("foobar" . 3)) + "store")) + +(test-end "store") |