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/file racket/function racket/list racket/match racket/path
         racket/string racket/unit racket/vector syntax/parse/define
         (only-in file/sha1 bytes->hex-string)
         (for-syntax racket/base 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 (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-update 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 (parse-manifest (call-with-input-file (build-path project-dir "manifest.rktd") read)))
  (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)
  (define mf (parse-manifest (call-with-input-file (build-path project-dir "manifest.rktd") read)))
  (match-define (list client-node server-node) (call-with-input-file *client-key-file* read))

  ;; create targz
  (define tmp-targz (build-path project-dir *cf-tmp-targz*))
  (parameterize ([current-directory project-dir])
    (define out (current-output-port))
    (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...")]))))

  ;; connect to server
  (define server-wrapper@ (make-rpc-wrapper-unit server^))
  (define-values/invoke-unit server-wrapper@ (import) (export server^))

  (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))

  (displayln "yeet")
  (new-project (serialize-manifest mf) (file->bytes tmp-targz))

  (tm-shutdown (current-tm))
  (comms-shutdown (current-comms))
  (void))


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


(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-update)
    (match (cmd-update (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-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-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 (update "Update generated files in a project")
      #:args ()
      (interactive-update))

    (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)))

    (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 "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))