writeups/2024/misc/bind-mount-diagram.rkt

#lang racket/base

(require (for-syntax racket/base)
         racket/class
         racket/draw
         racket/match
         pict
         syntax/parse/define)

(define (s-text t [inset-amt 10])
  (define p (text t))
  (define-values [w h] (values (pict-width p) (pict-height p)))
  (define bg (filled-rectangle w h #:draw-border? #f #:color "white"))
  (inset (cc-superimpose bg p) inset-amt))

(define (s-frame color hatched? p)
  (define-values [w h] (values (pict-width p) (pict-height p)))
  (define bg (filled-rectangle w h #:draw-border? #f #:color "white"))
  (define fr
    (dc (λ (dc dx dy)
          (define old-brush (send dc get-brush))
          (define old-pen (send dc get-pen))
          (define color-bg (make-object color%
                             (send color red)
                             (send color green)
                             (send color blue)
                             0.5))
          (send dc set-brush
                (new brush% [style (if hatched? 'fdiagonal-hatch 'transparent)]
                     [color color-bg]))
          (send dc set-pen
                (new pen% [width 1] [color color]))
          (define path (new dc-path%))
          (send path move-to 0 0)
          (send path line-to (- w 0.5) 0)
          (send path line-to (- w 0.5) (- h 0.5))
          (send path line-to 0 (- h 0.5))
          (send path close)
          (send dc draw-path path dx dy)
          (send dc set-brush old-brush)
          (send dc set-pen old-pen))
        w h))
  (cc-superimpose bg fr p))

(define (add-bottom-label p label-text [l-offset 0])
  (define-values [w h] (values (- (pict-width p) l-offset) (pict-height p)))
  (define bracket (hb-append (vline 0 5) (hline w 0) (vline 0 5)))
  (define label (text label-text))
  (vr-append p
             (vc-append (inset bracket 0 10 0 0)
                        (cc-superimpose (blank w (pict-height label)) label))))


(define (backgroundify-diagram p-raw)
  (define p (inset p-raw 20))
  (cc-superimpose (filled-rectangle (pict-width p) (pict-height p)
                                    #:draw-border? #f #:color "white")
                  p))

(define (save-to-svg p name)
  (define svg (new svg-dc%
                   [width (pict-width p)]
                   [height (pict-height p)]
                   [output (format "~a.svg" name)]
                   [exists 'replace]))
  (send svg start-doc "rendering SVG")
  (send svg start-page)
  (draw-pict p svg 0 0)
  (send svg end-page)
  (send svg end-doc))

(define-simple-macro (define-diagram name:id value:expr)
  #:with name-string (datum->syntax #'name (symbol->string (syntax->datum #'name)))
  (save-to-svg (backgroundify-diagram value) name-string))


(define c-gray (make-object color% 150 150 150))
(define c-red (make-object color% 200 80 80))
(define c-blue (make-object color% 150 150 200))
(define c-green (make-object color% 30 200 30))

(define server-dir
  (s-frame c-gray #f (s-text "server/")))

(define intermediate
  (s-frame c-green #t (s-text "Intermediate/")))

(define saved
  (s-frame c-green #t (s-text "Saved")))

(define config
  (s-frame c-green #t (s-text ".config/")))

(define store-dir
  (s-frame c-gray #f (s-text "/nix/store/...-satisfactory-dedicated-server...")))

(define tmp-dir
  (s-frame c-green #t (s-text "tmp/")))

(define settings-dir
  (s-frame c-green #t (s-text "settings/")))

(define saves-dir
  (s-frame c-green #t (s-text "saves/")))

(define main-diagram
  (ht-append
    (add-bottom-label
      (s-frame c-red #t
        (inset
          (vl-append
            server-dir
            (inset (s-frame c-gray #f (s-text "Engine/")) 10 0 0 0)
            (inset (s-frame c-gray #f (s-text "<unreal engine files>")) 20 0 0 0)
            (inset (s-frame c-gray #f (s-text "FactoryGame/")) 10 0 0 0)
            (inset (s-frame c-gray #f (s-text "<game server data>")) 20 0 0 0)
            (inset intermediate 20 0 0 0)
            (inset saved 20 0 0 0)
            (inset (s-frame c-gray #f (s-text "<more server data>")) 20 0 0 0)
            config)
          20))
      "virtual filesystem (readonly tmpfs)")
    (blank 80)
    (add-bottom-label
      (s-frame c-gray #f
        (inset
          (vl-append
            store-dir
            (blank 10 40)
            (s-frame c-gray #f (s-text "<...>"))
            (blank 10 40)
            (s-frame c-green #t (s-text "<writable state dir>"))
            (inset tmp-dir 10 0 0 0)
            (inset settings-dir 10 0 0 0)
            (inset saves-dir 10 0 0 0))
          20))
      "real filesystem")))

(define-diagram bind-mounts
  (pin-arrow-line
    10
    (pin-arrow-line
      10
      (pin-arrow-line
        10
        (pin-arrow-line
          10
          main-diagram
          saves-dir lc-find
          config rc-find
          #:line-width 1
          #:style 'solid
          #:color "black"
          #:label (s-text "bind" 0))
        settings-dir lc-find
        saved rc-find
        #:line-width 1
        #:style 'solid
        #:color "black"
        #:label (s-text "bind" 0))
      tmp-dir lc-find
      intermediate rc-find
      #:line-width 1
      #:style 'solid
      #:color "black"
      #:label (s-text "bind" 0))
    store-dir lc-find
    server-dir rc-find
    #:line-width 1
    #:style 'solid
    #:color "black"
    #:label (s-text "bind (ro)" 0)))