crossfire/crossfire/client.rkt

#lang racket/base
;; crossfire: distributed brute force infrastructure
;;
;; Copyright (C) 2020 haskal
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program 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 Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

(require file/tar racket/bool racket/contract racket/file racket/format racket/function racket/list
         racket/match racket/path racket/random racket/string racket/unit racket/vector
         syntax/parse/define
         (only-in file/sha1 bytes->hex-string)
         (for-syntax racket/base racket/list racket/syntax)
         "codegen.rkt" "comms.rkt" "info.rkt" "manifest.rkt" "not-crypto.rkt" "protocol.rkt")

(define *program* (format "~a-client" (#%info-lookup 'collection)))
;; XXX : slightly unix-oriented
(define *config-root*
  (build-path
    (or (getenv "XDG_CONFIG_HOME")
        (build-path (find-system-path 'home-dir) ".config"))
    *program*))
(define *client-key-file* (build-path *config-root* "config.rktd"))

(define *cf-private-cache* (build-path ".crossfire" "cache.rktd"))
(define *cf-tmp-targz* (build-path ".crossfire" "project.tgz"))

(define server-wrapper@ (make-rpc-wrapper-unit server^))

(define (call-with-server-connection func)
  (match-define (list client-node server-node) (call-with-input-file *client-key-file* read))

  (define (no-shutdown)
    (current-to-node server-node)
    (current-comms (make-comms client-node))
    (current-tm (make-transaction-manager client-node (current-comms)))
    (comms-set-node-info (current-comms) server-node)
    (comms-connect (current-comms) (node-id server-node)))

  (define (shutdown)
    (tm-shutdown (current-tm))
    (comms-shutdown (current-comms)))

  ;; here's my absolutely genius naming scheme for networking stuff it's "shutdown" and
  ;; "no shutdown" yes i'm an employee of Sysco Corporation™
  (dynamic-wind no-shutdown func shutdown))

(define-simple-macro (with-server-connection body ...+)
  #:with no-hygiene
         (datum->syntax (first (syntax-e #'(body ...)))
                        '(define-values/invoke-unit server-wrapper@ (import) (export server^)))
  (call-with-server-connection
    (lambda ()
      no-hygiene
      body ...)))

(define (read-manifest project-dir)
  (define (report-contract-error ex)
    (error "failed to parse manifest! make sure it matches the example formats"))

  (with-handlers ([exn:fail:contract? report-contract-error])
    (parse-manifest (call-with-input-file (build-path project-dir "manifest.rktd") read))))


;; command functions

(define (cmd-new project-name mode)
  (define project-root (build-path project-name))
  (when (or (file-exists? project-root) (directory-exists? project-root)
            (link-exists? project-root))
    (error "file or directory already exists named" project-name))
  (define proj-dir (build-path project-name))
  (define priv-cache (build-path proj-dir *cf-private-cache*))

  (make-directory* proj-dir)
  (make-parent-directory* priv-cache)
  (call-with-output-file priv-cache (lambda (out) (write (hash) out)))

  (define mf-gen (generate-manifest mode))
  (call-with-output-file
    (build-path proj-dir "manifest.rktd")
    (lambda (out) (write-string mf-gen out)))

  (void))


(define (cmd-generate project-dir)
  (define priv-cache (build-path project-dir *cf-private-cache*))
  (define mf (parse-manifest (call-with-input-file (build-path project-dir "manifest.rktd") read)))
  (define new-files (generate-support-code mf))
  (define old-hashes (call-with-input-file priv-cache read))

  (define messages '())

  (define new-hashes
    (for/hash ([(name contents) (in-hash new-files)])
      (define v-hash (port->blake2b-hash (open-input-string contents)))
      (define old-hash (hash-ref old-hashes name #f))
      (cond
        [(not (file-exists? name))
         (call-with-output-file (build-path project-dir name)
                                (lambda (out) (write-string contents out)))
         (set! messages (cons (format "created file ~a" name) messages))]
        [(and old-hash (not (bytes=? old-hash v-hash)))
         (define new-name (string-append name "." (substring (bytes->hex-string old-hash) 0 32)))
         (rename-file-or-directory (build-path project-dir name) (build-path project-dir new-name))
         (call-with-output-file (build-path project-dir name)
                                (lambda (out) (write-string contents out)))
         (define msg
           (format
             "because of manifest updates, ~a has been regenerated. the old version was moved to ~a"
             name new-name))
         (set! messages (cons msg messages))])
      (values name v-hash)))

  (call-with-output-file priv-cache (lambda (out) (write new-hashes out)) #:exists 'replace)
  messages)


(define (cmd-check project-dir)
  (define messages '())

  (define mf (read-manifest project-dir))
  (define mode (first (manifest-data-ref mf 'mode)))

  (when (and (symbol=? mode 'stdio)
             (not (file-exists? (build-path project-dir "crossfire-generator"))))
    (set! messages (cons "missing crossfire-generator, make sure to compile it" messages)))

  (unless (file-exists? *client-key-file*)
    (set! messages (cons (format "missing configuration to connect to server. use ~a setup"
                                 *program*)
                         messages)))

  messages)


(define (cmd-submit project-dir [progress void])
  (define mf (read-manifest project-dir))

  ;; create targz
  (define tmp-targz (build-path project-dir *cf-tmp-targz*))
  (parameterize ([current-directory project-dir])
    (tar-gzip tmp-targz "."
              #:exists-ok? #t
              #:path-filter (lambda (p)
                              (match (explode-path p)
                                [(list 'same (== (build-path ".crossfire")) rst ...) #f]
                                [(list 'same fst rst ...) #t]
                                [(list 'same) #t]
                                [_ (error "not shonks...")]))))

  (with-server-connection
    (define ft (make-file-transfer (open-input-file tmp-targz) progress))
    (new-project ft)))


(define (cmd-delete id)
  (with-server-connection
    (delete-project id)))


(define (cmd-status)
  (define (fmt-list lst)
    (if (empty? lst) "none" (~a lst)))
  (define projects
    (with-server-connection
      (get-projects)))
  (cons '("project id" "name" "progress" "matches" "active agents")
        (let ([body (for/list ([proj (in-list projects)])
                      (list (~a (project-info-id proj))
                            (project-info-name proj)
                            (format "~a%" (inexact->exact (* 100 (project-info-progress proj))))
                            (~a (project-info-matches proj))
                            (fmt-list (project-info-agent-state proj))))])
          (if (empty? body)
            '(("" " - no projects - " "" "" ""))
            body))))


(define all-printable? (listof (integer-in 32 126)))
(define all-byte? (listof (integer-in 0 255)))
(define (cmd-show id)
  ;; if it's all printable, make it a string
  ;; if it's all bytes, make it a bytes
  ;; otherwise, ....
  (define (format-match m)
    (define fmt-width
      ;; determine the number of digits needed to print in hex
      (let ([max-size (ceiling (log (apply max m) 16))])
        ;; adjust the digit count to the nearest power of 2 (4 digits, 8 digits, 16 digits, etc)
        (expt 2 (inexact->exact (ceiling (log max-size 2))))))
    (cond
      [(all-printable? m) (~s (list->string (map integer->char m)))]
      [(all-byte? m) (~s (apply bytes m))]
      [else (string-join (map (lambda (x) (~r x #:base 16 #:min-width fmt-width #:pad-string "0"))
                              m))]))

  (define matches
    (with-server-connection
      (get-project-matches id)))
  (if (empty? matches)
    (list "no matches... :(")
    (for/list ([m (in-list matches)] [i (in-naturals)])
      (format "match ~a: ~a" i (format-match m)))))


(define (cmd-agent-list)
  (define-values [agents projects]
    (with-server-connection
      (values (get-agents) (get-projects))))
  (cons '("id" "name" "arch" "resources" "status")
        (if (empty? agents)
          '(("" " - no agents - " "" "" ""))
          (for/list ([info (in-list agents)])
            (define detailed-status
              (if (node-info-online? info)
                (let ([assignments
                        (for/list ([proj (in-list projects)]
                                   #:when (member (node-info-id info)
                                                  (project-info-agent-state proj)))
                          (project-info-id proj))])
                  (if (empty? assignments)
                    "online, idle"
                    (format "working on ~a" assignments)))
                "OFFLINE"))
            (list (~a (node-info-id info))
                  (~a (node-info-name info))
                  (~a (node-info-arch info))
                  (~a (string-join (map ~a (sort (node-info-resources info) string<?)) ", "))
                  detailed-status)))))

(define (cmd-agent-create name arch resources out-port [progress-func void])
  (with-server-connection
    (define id (new-agent name arch resources))
    (define ft (get-agent-deployment id))
    (file-transfer-connect ft out-port progress-func)
    id))

(define (cmd-agent-delete id)
  (with-server-connection
    (delete-agent id)))

(define (cmd-get-deployment id out-port [progress-func void])
  (with-server-connection
    (define ft (get-agent-deployment id))
    (file-transfer-connect ft out-port progress-func)
    (void)))


(define (cmd-setup config)
  (make-parent-directory* *client-key-file*)
  (with-output-to-file *client-key-file* (lambda () (write config)) #:exists 'replace))


;; command parsing / UI

(module+ main
  (require racket/cmdline)

  (define current-subcommand (make-parameter #f))

  (define (report-status msg . args)
    (printf "~a ~a: ~a\n" *program* (current-subcommand) (apply format msg args)))

  (define (report-fatal-error msg . args)
    (apply report-status msg args)
    (exit 1))

  (define (interactive-generate)
    (match (cmd-generate (current-directory))
      ['() (report-status "generated files are up-to-date")]
      [(list msgs ...)
       (for ([msg (in-list msgs)])
         (report-status "~a" msg))]))

  (define (interactive-check)
    (match (cmd-check (current-directory))
      ['() (report-status "everything looks good to me!")]
      [(list warnings ...)
       (for ([warning (in-list warnings)])
         (report-status "error: ~a" warning))
       (report-fatal-error "check was not successful due to above messages")]))

  (define (print-table table)
    (define max-widths (for/list ([_ (in-list (first table))] [i (in-naturals)])
                         (apply max (map (lambda (x) (string-length (list-ref x i))) table))))
    (for ([row (in-list table)])
      (for ([item (in-list row)] [width (in-list max-widths)])
        (write-string (~a item #:width (+ 2 width))))
      (write-string "\n")))

  (define (print-progress a b)
    (define pct (quotient (* 100 a) b))
    ;; TODO : xterm/vt100/etc-specific
    ;; this should use a library maybe
    (printf "\r\x1b[Ktransferred ~a% [~a/~a]" pct a b)
    (flush-output))

  (define (finish-progress)
    (printf "\n"))

  (define (make-random-filename)
    (string-append (bytes->hex-string (crypto-random-bytes 8)) ".agent"))

  (define-simple-macro (subcommand (name:id description:str) body ...)
    #:with name-str (datum->syntax #'name (symbol->string (syntax-e #'name)))
    (list name-str
          (lambda (argv)
            (parameterize ([current-subcommand name-str])
              (with-handlers ([exn:fail?
                               (lambda (ex)
                                 (report-fatal-error "~a" (exn-message ex)))])
                (command-line
                  #:program (format "~a ~a" *program* name-str)
                  #:argv argv
                  #:usage-help description
                  body ...))))
          description))

  (define-simple-macro (define-commands name:id cmds ...)
    (define name (make-hash (list cmds ...))))

  (define flag-mode (make-parameter "stdio"))
  (define flag-agent (make-parameter #f))
  (define flag-agent-name (make-parameter #f))
  (define flag-agent-arch (make-parameter #f))
  (define flag-agent-res (make-parameter '()))
  (define-commands *commands*
    (subcommand (new "Create a new crossfire project")
      #:once-each [("-m" "--mode") mode "Project mode (stdio [default] or callback)"
                                   (flag-mode mode)]
      #:args (project-name)
      (match (flag-mode)
        [(or "stdio" "callback") (void)]
        [x (report-fatal-error "invalid mode ~a, need stdio or callback" x)])
      (cmd-new project-name (string->symbol (flag-mode)))
      (report-status "created new project ~a" project-name))

    (subcommand (generate "Update generated files in a project")
      #:args ()
      (interactive-generate))

    (subcommand (check "Check over a project for issues")
      #:args ()
      (interactive-check))

    (subcommand (submit "Submit a project for execution")
      #:args ()
      ;; trigger a check before we submit
      (interactive-check)
      ;; do submit
      (report-status "submitting project...!")
      (cmd-submit (current-directory) print-progress)
      (finish-progress)
      (report-status "project submitted!! time for crab"))

    (subcommand (delete "Delete an executed or completed project")
      #:args (id-str)
      (define id (or (string->number id-str)
                     (error "must provide numeric ID")))
      (cmd-delete id)
      (report-status "project ~a deleted" id))

    (subcommand (status "Summary of project status on server")
      #:args ()
      (print-table (cmd-status)))

    (subcommand (show "Show information about a project on the server")
      #:args (id-str)
      (define id (or (string->number id-str)
                     (error "must provide numeric ID")))
      (for ([line (in-list (cmd-show id))])
        (displayln line)))

    (subcommand (agent "Manage crossfire agents")
      #:once-any
      [("-l" "--list") "List agents" (flag-agent (list 'list #f))]
      [("-c" "--create") "Create a new agent" (flag-agent (list 'create #f))]
      [("-d" "--delete") aid "Delete an agent" (flag-agent (list 'delete aid))]
      [("-g" "--get-binary") aid "Redownload the binary for an agent" (flag-agent (list 'get aid))]
      #:once-each
      [("-a" "--arch") arch "For --create, the agent CPU architecture" (flag-agent-arch arch)]
      [("-n" "--name") name "For --create, the agent name" (flag-agent-name name)]
      #:multi
      [("-r" "--resource") res "For --create, resources to associate with the agent"
                           (flag-agent-res (cons res (flag-agent-res)))]
      #:args ()
      (define (do-final out-name)
        (define perms (file-or-directory-permissions out-name 'bits))
        (file-or-directory-permissions out-name (bitwise-ior perms #o111))
        (report-status "agent executable saved to ~a" out-name))

      (match (flag-agent)
        [(list 'list _)
         (print-table (cmd-agent-list))]
        [(list 'create _)
         (when (or (false? (flag-agent-name))
                   (false? (flag-agent-arch)))
           (error "you must provide -n and -a for this command"))
         (define out-name (make-random-filename))
         (call-with-output-file out-name
           (lambda (o)
             (define aid (cmd-agent-create (flag-agent-name) (flag-agent-arch) (flag-agent-res) o print-progress))
             (finish-progress)
             (report-status "created agent ~a" aid)))
         (do-final out-name)]
        [(list 'delete aid-str)
         (define aid (string->number aid-str))
         (unless aid
           (error "invalid agent id provided"))
         (cmd-agent-delete aid)
         (report-status "deleted agent ~a" aid)]
        [(list 'get aid-str)
         (define aid (string->number aid-str))
         (unless aid
           (error "invalid agent id provided"))
         (define out-name (make-random-filename))
         (call-with-output-file out-name
           (lambda (o) (cmd-get-deployment aid o print-progress)))
         (finish-progress)
         (do-final out-name)]
        [_ (error "you must provide -l, -c, -d, or -g for this command")]))

    (subcommand (setup "Set up access to a crossfire server")
      #:args (config-file)
      (unless (file-exists? config-file)
        (report-fatal-error "provided config file does not exist"))
      (define config
        (call-with-input-file config-file read))
      (cmd-setup config)
      (report-status "testing server connection")
      (cmd-status)
      (report-status "successfully imported config")))

  (define (print-usage)
    (printf "~a <command> [<arg> ...]\n" *program*)
    (displayln "  The CLI for crossfire")
    (displayln " where <command> is one of")
    (for ([k (in-list (sort (hash-keys *commands*) string<?))])
      (printf "  ~a : ~a\n" k (second (hash-ref *commands* k)))))

  (match (current-command-line-arguments)
    [(vector (? (curry hash-has-key? *commands*) cmd) argv ...)
     ((first (hash-ref *commands* cmd)) argv)]
    [(vector (or "-v" "--version"))
     (printf "~a version ~a\n" *program* (#%info-lookup 'version))]
    [(vector (or "-h" "--help") _ ...)
     (print-usage)]
    [(vector cmd _ ...)
     (printf "~a: given invalid command ~s\n" *program* cmd)]
    [(vector)
     (printf "~a: expects 1 <command> on the command line, given 0 arguments\n" *program*)])

  (void))