#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 db/base db/sqlite3
         racket/bool racket/fasl racket/file racket/match racket/runtime-path racket/path
         racket/set racket/string
         north/base north/adapter/base north/adapter/sqlite
         "comms.rkt" "not-crypto.rkt")

;; configuration

(define PRODUCTION? #f)

(define SERVER-DATA-DIR (if PRODUCTION? "/var/lib/crossfire/" "lib/"))
(define SERVER-DB-PATH (build-path SERVER-DATA-DIR "crossfire.sqlite"))
(define AGENT-ARCH-PREFIX "arch_")
(define AGENT-BINARY "crossfire-agent")

;; comms node for server (without secret key)
(define current-server-public-node (make-parameter #f))

;; north migrations
(define-runtime-path migrations-dir "migrations/")

;; database

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

(define (open-server-db [mode 'read/write])
  (let ([db (sqlite3-connect #:database SERVER-DB-PATH #:mode mode)])
    (query-exec db "pragma foreign_keys=1;")
    db))

;; this allows the server to be capable of migrating itself
(define (migrate-server-db [db (current-db)])
  ;; these are the steps taken by the north cli tool (it's a bit verbose but at least it's all
  ;; programmatically accessible...)
  ;; i also use a runtime path to be a bit more robust
  (define base (path->migration migrations-dir))
  (define adapter (sqlite-adapter db))
  (adapter-init adapter)
  (define current-revision (adapter-current-revision adapter))
  (define target-revision (migration-revision (migration-most-recent base)))
  (define plan (migration-plan base current-revision target-revision))
  (for ([migration (in-list plan)])
    (displayln (format "applying migration: ~a" (migration-revision migration)))
    (adapter-apply! adapter (migration-revision migration) (migration-up migration)))
  (void))

(define-syntax-rule (define-stmt name what)
  (define name (virtual-statement what)))

(define-stmt q-new-node "insert into node (name, arch, type, secret) values (?, ?, ?, ?)")
(define-stmt q-add-node-res "insert or ignore into node_resource (nodeid, resource) values (?, ?)")
(define-stmt q-del-node-res "delete from node_resource where nodeid=? and resource=?")
(define-stmt q-get-nodes "select id, name, arch from node where type=?")
(define-stmt q-get-all-resources
  "select nodeid, resource from node_resource inner join node on node.id = node_resource.nodeid
       where node.type = ?")
(define-stmt q-get-node-resources "select resource from node_resource where nodeid=?")
(define-stmt q-edit-node "update node set name=? where id=?")
(define-stmt q-get-node-type "select type from node where id=?")
(define-stmt q-get-node-info "select name, arch, type, secret from node where id=?")

;; rpc calls

(define-rpc-type server)

(struct node-info [id name arch type resources online?] #:transparent)

(define (get-nodes type)
  (define type-str (symbol->string type))
  (define resources (rows->dict #:key "nodeid" #:value "resource" #:value-mode '(list)
                                (query (current-db) q-get-all-resources type-str)))
  (for/list ([(id name arch) (in-query (current-db) q-get-nodes type-str)])
    (define online? (and (current-comms) (comms-channel-available? (current-comms) id)))
    (node-info id name arch type (hash-ref resources id) online?)))

(define (make-node name arch type resources)
  (call-with-transaction (current-db) (lambda ()
    (define secret (crypto-sign-make-key))
    (define public (crypto-sign-public-key secret))
    (define info
      (simple-result-info (query (current-db) q-new-node name arch (symbol->string type) secret)))
    (define id (cdr (assoc 'insert-id info)))
    (for ([res (in-list resources)])
      (query-exec (current-db) q-add-node-res id res))
    (values id public))))

(define (configure-agent-binary agent-node agent-arch server-node)
  ;; TODO : assumes unix
  (define binary
    (file->bytes
      (build-path SERVER-DATA-DIR (string-append AGENT-ARCH-PREFIX agent-arch) AGENT-BINARY)))

  (define (configure.linux-gnu)
    (define trailing-data (s-exp->fasl (list agent-node server-node)))
    ;; write 32 bit unsigned big endian trailer size (including size)
    (define trailing-size
      (integer->integer-bytes (+ 4 (bytes-length trailing-data)) 4 #f #t))
    (bytes-append binary trailing-data trailing-size))

  (match (string-split agent-arch "-")
    [(list _ ... "linux" "gnu") (configure.linux-gnu)]
    [_ (error "XXX: don't know how to configure arch" agent-arch)]))

(define (enforce-subject type)
  (unless (symbol=? type (node-type (current-from-node)))
    (error "unauthorized")))

(define (enforce-object id type)
  (match (query-maybe-value (current-db) q-get-node-type id)
    [#f (error "node doesn't exist" id)]
    [(== (symbol->string type)) (void)]
    [x (error "wrong node type" x)]))

;; client rpcs

(define-rpc server (get-agents)
  (enforce-subject 'client)
  (get-nodes 'agent))

(define-rpc server (new-agent name arch resources)
  (enforce-subject 'client)
  (define-values [id public] (make-node name arch 'agent resources))
  (define comms-node (node id name 'agent public #f #f #f))
  (comms-set-node-info (current-comms) comms-node)
  id)

(define-rpc server (edit-agent id name resources)
  (enforce-subject 'client)
  (call-with-transaction (current-db) (lambda ()
    (enforce-object id 'agent)
    (define existing-resource (list->set (query-list (current-db) q-get-node-resources id)))
    (define new-resource (list->set resources))
    (query-exec (current-db) q-edit-node name id)
    (for ([res (in-set (set-subtract new-resource existing-resource))])
      (query-exec (current-db) q-add-node-res id res))
    (for ([res (in-set (set-subtract existing-resource new-resource))])
      (query-exec (current-db) q-del-node-res id res)))))

(define-rpc server (get-agent-deployment id)
  (enforce-subject 'client)
  (match (query-maybe-row (current-db) q-get-node-info id)
    [(vector name arch "agent" secret)
     (configure-agent-binary (node id name 'agent (crypto-sign-public-key secret) secret #f #f)
                             arch (current-server-public-node))]
    [_ (error "invalid id or wrong node type")]))

;; agent rpcs

(define-rpc server (agent-report something)
  (enforce-subject 'agent)
  (error "TODO"))


;; command line usage
(module+ main
  (require racket/cmdline)
  (current-db (open-server-db 'create))
  (migrate-server-db)
  (define data (configure-agent-binary (node 10 "meow0" 'agent #f #f #f #f)
                                       "aarch64-unknown-linux-gnu"
                                       (node 0 "server" 'server #f #f "meow.systems" 1337)))
  (with-output-to-file "/tmp/crossfire-agent.configured"
    (lambda () (write-bytes data)))
  ; (make-node "agent0" "x86_64" 'agent '("gpu" "hifive"))
  ; (parameterize ([current-from-node (node 100 "meow" 'client #f #f #f #f)])
    ; ((rpc-impl server edit-agent) 1 "meow0" '("cpu" "hifive")))
  ; (get-nodes 'agent)
  ; (get-nodes 'meow)
   )