diff options
| -rw-r--r-- | Makefile.am | 3 | ||||
| -rw-r--r-- | drmaa/v1/high.scm | 354 |
2 files changed, 356 insertions, 1 deletions
diff --git a/Makefile.am b/Makefile.am index c16d7ca..c3bd8f6 100644 --- a/Makefile.am +++ b/Makefile.am @@ -38,7 +38,8 @@ drmaa/v1/ffi.scm: drmaa/v1/ffi.ffi SOURCES = drmaa.scm \ drmaa/errors.scm \ drmaa/v1/ffi.scm \ - drmaa/v1/low.scm + drmaa/v1/low.scm \ + drmaa/v1/high.scm TESTS = diff --git a/drmaa/v1/high.scm b/drmaa/v1/high.scm new file mode 100644 index 0000000..02aeb83 --- /dev/null +++ b/drmaa/v1/high.scm @@ -0,0 +1,354 @@ +;;; Guile DRMAA --- Guile bindings for DRMAA +;;; Copyright © 2021 Ricardo Wurmus <rekado@elephly.net> +;;; +;;; This file is part of Guile DRMAA. +;;; +;;; Guile DRMAA 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. +;;; +;;; Guile DRMAA 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 Guile DRMAA. If not, see <http://www.gnu.org/licenses/>. + +(define-module (drmaa v1 high) + #:use-module (drmaa errors) + #:use-module ((drmaa v1 low) #:prefix low:) + #:use-module (oop goops) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (ice-9 match) + #:export (job-template + + with-drmaa-session + + run-job + run-bulk-jobs) + #:re-export ((low:control . control) + (low:job-ps . job-ps) + (low:synchronize . synchronize) + (low:wait . wait) + + (low:w-if-exited? . w-if-exited?) + (low:w-exit-status . w-exit-status) + (low:w-if-signaled? . w-if-signaled?) + (low:w-termsig . w-termsig) + (low:w-coredump? . w-coredump?) + (low:w-if-aborted? . w-if-aborted?) + + (low:get-contact . get-contact) + (low:drmaa-version . drmaa-version) + (low:get-drm-system . get-drm-system) + (low:get-drmaa-implementation . get-drmaa-implementation))) + +(define-class <drmaa-class> (<object>)) + +;; TODO: maybe move validation to setters instead of only running them +;; at initialization time. +(define-method (initialize (instance <drmaa-class>) initargs) + (define klass (class-of instance)) + ;; Validate slots + (for-each + (lambda (slot) + (let* ((options (slot-definition-options slot)) + (keyword (slot-definition-init-keyword slot))) + ;; Ensure required slots are filled. + (and (memq #:required? options) + (or (member keyword initargs) + (raise (condition + (&drmaa-error) + (&formatted-message + (format "~a: required field `~a' missing.~%") + (arguments (list (class-name klass) + (slot-definition-name slot)))))))) + + ;; Only perform these checks if a value is provided. + (and=> (member keyword initargs) + (lambda (tail) + ;; Run validators on slot values + (match (memq #:valid? options) + ((_ validate . rest) + (match tail + ((_ value . rest) + ;; TODO: allow for better error messages + (or (validate value) + (raise (condition + (&drmaa-error) + (&formatted-message + (format "~a: field `~a' has the wrong type.~%") + (arguments (list (class-name klass) + (slot-definition-name slot)))))))))) + (_ #t)))))) + (class-slots klass)) + + ;; Reject extraneous fields + (let* ((allowed (map slot-definition-init-keyword (class-slots klass))) + (provided (filter keyword? initargs))) + (match (lset-difference eq? provided allowed) + (() #t) + (extraneous + (raise (condition + (&drmaa-error) + (&formatted-message + (format "~a: extraneous fields: ~{~a ~}~%") + (arguments (list (class-name klass) + (map keyword->symbol extraneous))))))))) + (next-method)) + +(define-class <job-template> (<drmaa-class>) + ;; Slots + (job-name + #:accessor job-template-job-name + #:init-keyword #:job-name + #:init-form (format #false "guile-drmaa-job-~a" + (time-second (current-time time-monotonic))) + #:drmaa-name (low:DRMAA 'JOB_NAME)) + + (remote-command + #:accessor job-template-remote-command + #:init-keyword #:remote-command + #:init-value "/bin/true" + #:drmaa-name (low:DRMAA 'REMOTE_COMMAND)) + (arguments + #:accessor job-template-arguments + #:init-keyword #:arguments + #:init-value (list) + #:drmaa-name (low:DRMAA 'V_ARGV)) + + (working-directory + #:accessor job-template-working-directory + #:init-keyword #:working-directory + #:init-value "" + #:drmaa-name (low:DRMAA 'WD)) + + (hold? + #:accessor job-template-hold? + #:init-keyword #:hold? + #:init-value #true + #:drmaa-name (low:DRMAA 'JS_STATE) + #:valid? boolean? + #:transform (lambda (value) + (if value + (low:DRMAA 'SUBMISSION_STATE_HOLD) + (low:DRMAA 'SUBMISSION_STATE_ACTIVE)))) + (join-files? + #:accessor job-template-join-files? + #:init-keyword #:join-files? + #:init-value #false + #:valid? boolean? + #:transform (lambda (value) + (if value "y" "n")) + #:drmaa-name (low:DRMAA 'JOIN_FILES)) + (block-email? + #:accessor job-template-block-email? + #:init-keyword #:block-email? + #:init-value #false + #:valid? boolean? + #:transform (lambda (value) + (if value "0" "1")) + #:drmaa-name (low:DRMAA 'BLOCK_EMAIL)) + + (input-path + #:accessor job-template-input-path + #:init-keyword #:input-path + #:init-value "" + #:drmaa-name (low:DRMAA 'INPUT_PATH)) + (output-path + #:accessor job-template-output-path + #:init-keyword #:output-path + #:init-value "" + #:drmaa-name (low:DRMAA 'OUTPUT_PATH)) + (error-path + #:accessor job-template-error-path + #:init-keyword #:error-path + #:init-value "" + #:drmaa-name (low:DRMAA 'ERROR_PATH)) + (transfer-files + #:accessor job-template-transfer-files + #:init-keyword #:transfer-files + #:init-value (list) + #:valid? (lambda (value) + (and (list? value) + (for-each + (lambda (item) + (or (member item '(error input output)) + (raise (condition + (&drmaa-error) + (&message + (message "transfer-files: must be a list containing the symbols error, input, or output.")))))) + value))) + #:transform (lambda (value) + (string-join (map (lambda (item) + (match item + ('error "e") + ('input "i") + ('output "o"))) + value))) + #:drmaa-name (low:DRMAA 'TRANSFER_FILES)) + + (job-category + #:accessor job-template-job-category + #:init-keyword #:job-category + #:drmaa-name (low:DRMAA 'JOB_CATEGORY)) + (native-specification + #:accessor job-template-native-specification + #:init-keyword #:native-specification + #:init-value "" + #:drmaa-name (low:DRMAA 'NATIVE_SPECIFICATION)) + + (environment + #:accessor job-template-environment + #:init-keyword #:environment + #:init-value (list) + #:valid? (lambda (value) + (or (and (list? value) + (for-each + (match-lambda + ((key . value) #true) + (_ #false)) + value)) + (raise (condition + (&drmaa-error) + (&message + (message "environment: must be a list of pairs.")))))) + #:transform (lambda (value) + (map (match-lambda + ((key . value) + (format #false "~a=~a" key value))) + value)) + #:drmaa-name (low:DRMAA 'V_ENV)) + (emails + #:accessor job-template-emails + #:init-keyword #:emails + #:init-value (list) + #:valid? (lambda (value) + (or (and (list? value) + (every string? value)) + (raise (condition + (&drmaa-error) + (&message + (message "emails: must be a list of strings.")))))) + #:drmaa-name (low:DRMAA 'V_EMAIL)) + + (start-time + #:accessor job-template-start-time + #:init-keyword #:start-time + #:init-form (current-date) + #:valid? date? + #:transform (lambda (value) + (date->string value "~Y/~m/~d ~H:~M:~S")) + #:drmaa-name (low:DRMAA 'START_TIME)) + (deadline-time + #:accessor job-template-deadline-time + #:init-keyword #:deadline-time + #:valid? date? + #:transform (lambda (value) + (date->string value "~Y/~m/~d ~H:~M:~S")) + #:drmaa-name (low:DRMAA 'DEADLINE_TIME)) + (duration-hlimit + #:accessor job-template-duration-hlimit + #:init-keyword #:duration-hlimit + #:valid? (lambda (value) + (and (time? value) + (eq? time-duration (time-type value)))) + #:transform (lambda (value) + (format #false "~a" (time-second value))) + #:drmaa-name (low:DRMAA 'DURATION_HLIMIT)) + (duration-slimit + #:accessor job-template-duration-slimit + #:init-keyword #:duration-slimit + #:valid? (lambda (value) + (and (time? value) + (eq? time-duration (time-type value)))) + #:transform (lambda (value) + (format #false "~a" (time-second value))) + #:drmaa-name (low:DRMAA 'DURATION_SLIMIT)) + (wct-hlimit + #:accessor job-template-wct-hlimit + #:init-keyword #:wct-hlimit + #:valid? (lambda (value) + (and (time? value) + (eq? time-duration (time-type value)))) + #:transform (lambda (value) + (format #false "~a" (time-second value))) + #:drmaa-name (low:DRMAA 'WCT_HLIMIT)) + (wct-slimit + #:accessor job-template-wct-slimit + #:init-keyword #:wct-slimit + #:valid? (lambda (value) + (and (time? value) + (eq? time-duration (time-type value)))) + #:transform (lambda (value) + (format #false "~a" (time-second value))) + #:drmaa-name (low:DRMAA 'WCT_SLIMIT)) + + ;; Class options + #:name "job-template") + +(define (job-template . args) + (apply make <job-template> args)) + +(define-method (lower-job-template (instance <job-template>)) + (define klass (class-of instance)) + (define t (low:allocate-job-template!)) + ;; Validate slots + (for-each + (lambda (slot) + (let* ((options (slot-definition-options slot)) + (keyword (slot-definition-init-keyword slot)) + (drmaa (and=> (memq #:drmaa-name options) cadr)) + (transform (or (and=> (memq #:transform options) cadr) + identity)) + (slot-name (slot-definition-name slot))) + (when (slot-bound? instance slot-name) + (let* ((value (slot-ref instance slot-name)) + (transformed (transform value))) + (if (pair? transformed) + (apply low:set-vector-attribute! t drmaa transformed) + (low:set-attribute! t drmaa transformed)))))) + (class-slots klass)) + t) + +(define-syntax-rule (with-drmaa-session body ...) + (dynamic-wind + (lambda () (low:init-session!)) + (lambda () body ...) + (lambda () (low:exit-session!)))) + +(define-syntax-rule (with-job-template instance proc) + (let ((template #false)) + (dynamic-wind + (lambda () + (set! template (lower-job-template instance))) + (lambda () + (proc template)) + (lambda () + (low:delete-job-template! template))))) + +(define-method (run-job (template <job-template>)) + "Submit a single job with the attributes defined in the job +template. Upon success return the job identifier." + (with-job-template template low:run-job)) + +(define* (run-bulk-job template end + #:key + (start 1) (increment 1)) + "Submit a set of parametric jobs, which can be run concurrently. +The attributes defined in TEMPLATE are used for every job in the set. +Each job is identical except for its index. The first job has an +index equal to START; the next has an index equal to the sum of START +and INCREMENT. END is the maximum value of the index, but the value +of the last job's index may not be equal to END if the difference +between START and END is not evenly divisible by INCREMENT. + +Return a list of job identifiers." + (with-job-template template + (lambda (t) + (low:run-bulk-jobs t end #:start start #:increment increment)))) |