guile-examples/shell/guile-shell/shell.scm

(library (shell)
  (export
   ;; shell logic
   shell
   call
   run-command
   with-ports
   command-pipeline
   echo-command)
  (import (except (rnrs base) error)
          (only (guile)
                lambda* λ
                ;; control flow
                when
                unless

                ;; ports
                current-input-port
                current-output-port
                current-error-port

                with-input-from-port
                with-output-to-port
                with-error-to-port
                with-input-from-string

                close-port
                pipe

                ;; other
                setvbuf
                eof-object?
                ;; string formatting
                simple-format
                ;; basic shell procedures guile provides
                getcwd
                chdir
                ;; other
                error
                ;; strings
                string-split
                )
          (ice-9 exceptions)
          ;; pipes
          (ice-9 popen)
          (ice-9 textual-ports)
          (ice-9 binary-ports)
          (ice-9 receive)
          (ice-9 match)
          ;; fibers
          (fibers)
          (fibers channels)
          ;; ftw stands for file-tree-walk
          ;; for file-system-tree
          (ice-9 ftw)
          ;; for match-lambda
          (ice-9 match)
          ;; lists
          (srfi srfi-1)
          ;; let-values
          (srfi srfi-11)
          ;; strings
          (srfi srfi-13)
          (prefix (file) file:)
          (alias)
          (list-helpers)
          (string-helpers)
          (commands))


  (define identity (λ (any) any))


  (define read-from-write-to
    (lambda* (in-port out-port #:key (bytes-count 1024))
      "Read from an IN-PORT and write to OUT-PORT, BYTES-COUNT
bytes at a time."
      (let loop ([bv (get-bytevector-n in-port bytes-count)])
        (unless (eof-object? bv)
          (put-bytevector out-port bv)
          (loop (get-bytevector-n in-port bytes-count))))))


  (define run-command
    (lambda* (cmd
              #:key
              (cmd-out-port (current-output-port))
              (err-out-port (current-error-port)))
      "Allow the user to give output port and error port to the
function."
      (with-output-to-port cmd-out-port
        (λ ()
          (with-error-to-port err-out-port
            (λ ()
              (let* (;; Run the actual command. If an error
                     ;; happens, it should write to the
                     ;; err-write port. Output of the command
                     ;; should be written to an output port,
                     ;; which corresponds to the input-port,
                     ;; which is returned by open-input-pipe.
                     [in-port (open-input-pipe cmd)]
                     ;; Read in block mode.
                     [_ignored (setvbuf in-port 'block)])
                ;; Write to caller given command output port.
                (read-from-write-to in-port cmd-out-port)
                ;; Get the exit code of the command.
                (close-pipe in-port))))))))


  ;; TODO: shell must use the current input port and current output
  ;; port and current error port for the shell command that is to be
  ;; run. In case of a shell command the return value is the output as
  ;; a string.
  (define shell
    (lambda* (command)
      "Run a shell COMMAND. Return 3 values: (1) exit code, (2)
command output, (3) error output."
      ;; Construct pairs of input and outout ports using
      ;; `pipe'. Whatever is written to the output port can
      ;; be read from the input port.
      (match-let ([(cmd-in . cmd-out) (pipe)]
                  [(err-in . err-out) (pipe)])
        (let ([exit-code
               (run-command command
                            ;; Write command output to the
                            ;; out port, so that it can be
                            ;; read from in port.
                            #:cmd-out-port cmd-out
                            ;; Write error output to the
                            ;; error out port, so that it
                            ;; can be read from the error in
                            ;; port.
                            #:err-out-port err-out)])
          ;; Do not forget to close the out port and error
          ;; out port.
          (close-port cmd-out)
          (close-port err-out)
          ;; Read the (error) output of the command and
          ;; return it.
          (let ([output-message (get-string-all cmd-in)]
                [error-message (get-string-all err-in)])
            (values exit-code
                    output-message
                    error-message))))))


  (define call
    (lambda* (command
              #:key
              (display-exit-code #f)
              (exit-code-formatter
               (λ (exit-code) (string-append (number->string exit-code) "\n")))
              (cmd-out-formatter identity)
              (err-out-formatter identity))
      "Like shell, but displays the results of running the shell
COMMAND, instead of returning them. How output is displayed
can be optionally specified via keyword arguments
EXIT-CODE-FORMATTER, CMD-OUT-FORMATTER,
ERR-OUT-FORMATTER. The keyword argument DISPLAY-EXIT-CODE is
a flag that enables or disables display of the exit code."
      (let-values ([(exit-code cmd-output err-output) (shell command)])
        (when display-exit-code
          (simple-format #t "~a" (exit-code-formatter exit-code)))
        (simple-format #t "~a" (cmd-out-formatter cmd-output))
        (simple-format #t "~a" (err-out-formatter err-output)))))


  (define with-ports
    (lambda* (proc
              #:key
              (in (current-input-port))
              (out (current-output-port))
              (err (current-error-port)))
      "Transform any procedure PROC into a shell procedure or shell command,
by setting its IN, OUT and ERROR ports. Any procedure can use the
current input, output and error ports internally, which are mapped to
other ports using this WITH-PORTS function."
      (with-input-from-port in
        (λ ()
          (with-output-to-port out
            (λ ()
              (with-error-to-port err
                (λ ()
                  (proc)))))))))


      ;; (define server
      ;;   (λ (in out)
      ;;     ;; infinite blocking loop
      ;;     (let lp ()
      ;;       (match (pk 'server-received #|block on get-message|# (get-message in))
      ;;         ('ping! (put-message out 'pong!))
      ;;         ('sup   (put-message out 'not-much-u))
      ;;         (msg    (put-message out (cons 'wat msg))))
      ;;       (lp))))

      ;; (define client
      ;;   (λ (in out)
      ;;     (for-each (λ (msg)
      ;;                 (put-message out msg)
      ;;                 (pk 'client-received (get-message in)))
      ;;               (list '(1 2 3)
      ;;                     #(1 2 3)
      ;;                     ;; We can pass non-string data between fibers!
      ;;                     (make-point 1 2)))))

  (define command-pipeline
    (λ (. commands)
      (cond
       [(null? commands) '()]
       [else
        ;; Create a scheduler and run it in the main thread. Inside
        ;; this expression one can use `spawn-fiber' to spawn more
        ;; fibers.
        (run-fibers
         ;; `run-fibers' takes a procedure, which is run inside a
         ;; fiber, using the newly created scheduler.
         (λ ()
           (let iter ([commands° commands]
                      [previous-output-channel (current-input-port)])
             (cond
              [(null? commands°)
               ;; Read from last command's output channel to get
               ;; the final result.
               (get-message previous-output-channel)]
              [else
               ;; Each command gets a new output channel, so that it
               ;; can write its output there.
               (let ([command-output-channel (make-channel)])
                 (let ([command-fiber
                        ;; Spawn the command as a fiber. Subsequent
                        ;; commands need to read from its out channel
                        ;; to receive input.
                        (spawn-fiber
                         (λ ()
                           ((car commands°) previous-output-channel command-output-channel)))])
                   ;; Output of this command is input of the next
                   ;; command. Spawn fibers for the next commands.
                   (iter (cdr commands°) command-output-channel)))])))
         #:drain? #t)])))


  (define echo-command
    (λ (in out)
      (cond
       [(channel? in)
        (let ([msg (get-message in)])
          (simple-format #t "received: ~a\n" msg)
          (put-message out msg))]
       [else
        (let ([msg "no message received"])
          (put-message out msg))])))


  ;; (run-fibers
  ;;  (λ ()
  ;;    (call-with-channel-input-string
  ;;     "Hello!"
  ;;     (λ (pipeline-input-channel)
  ;;       ;; TODO: But how to get the pipeline-input-channel to be
  ;;       ;; visible in the echo-command, so that echo-command makes use
  ;;       ;; of it?
  ;;       (command-pipeline echo-command
  ;;                         echo-command
  ;;                         echo-command
  ;;                         echo-command
  ;;                         echo-command)))))


  ;; EXAMPLE CALLS:

  #;(with-output-to-file "test-output.log"
  (λ ()
  (call "ls -al" #:display-exit-code #t)))

  #;(with-output-to-file "test-output.log"
  (λ ()
  (with-input-from-file "test-input.log"
  (λ ()
  (call "cut -d ' ' -f 1-2" #:display-exit-code #t)))))


  ;; IDEA: Write a function which works like this: (direct function #:in #:out)


  ;; TODO: IDEA: Building a pipeline of commands means, that pipes are
  ;; constructed, which an earlier command can use to write output and
  ;; a later command can use to read input.
  )