fostatus-configed.rkt

#lang racket

(require json)
(require xml)
(require web-server/servlet
         web-server/servlet-env)

(define servers (string->jsexpr (file->string "servers.json")))

; Probably some nicer way to do this that I don't know about yet...
(define all_servers (hash-copy (hash-ref (hash-ref (hash-ref servers 'fonline) 'config) 'server)))

; Get a server from all_servers
(define (server_get server)
  (hash-ref all_servers server)
  )
(define (server_key server key)
  (hash-ref (server_get server) key ""))
(define (server_key_exists server key)
  (hash-has-key? (server_get server) key))

(define (server_set_attr server attr val)
  (hash-set! all_servers server (hash-set (server_get server) attr val))
  )

; Make pair where server key (used for access the all_servers hash) is the first and second value a string generated by a proc(x) that receives the server as first argument, later used for sorting.
; (server_key, output_of_proc)
(define (server_key_pair proc)
  (map (lambda (x) (list x (proc x) )) (hash-keys all_servers))
  )

(define (server_attr_pair attr)
  (server_key_pair (lambda (x) (server_key x attr)) )
  )


; Get list of server keys by sorted by some property, e.g 'name
(define (server_keys_by_sorted_attr attr)
  (map (lambda (x) (first x)) (sort (server_attr_pair attr) string<? #:key (lambda (x) (last x))))
  )

(define server_keys (server_keys_by_sorted_attr 'name))


; Helpers to get all properties from server x
(define (server_name server)    (server_key server 'name))
(define (server_host server)    (server_key server 'host))
(define (server_port server)    (server_key server 'port))
(define (server_web server)     (server_key server 'website))
(define (server_link server)    (server_key server 'link))
(define (server_irc server)     (server_key server 'irc))
(define (server_discord server) (server_key server 'discord)) 
(define (server_closed server)  (server_key server 'closed))
(define (server_color server)   (server_key server 'color))

; Web or link or ""
(define (server_external server)
  (if (not (eq? (server_web server) ""))
  (server_web server)
  (server_link server)
  )
)

(define (server_fmt_attr server input expr attr)
  (string-replace input expr (~a (server_key server attr))))

(define (server_fmt server fmt)
  (let ([res fmt])
      (set! res (string-replace res "%key" (~a server)) )
      (set! res (server_fmt_attr server res "%name" 'name))
      (set! res (server_fmt_attr server res "%host" 'host))
      (set! res (server_fmt_attr server res "%port" 'port))
      (set! res (server_fmt_attr server res "%irc" 'irc))
      (set! res (server_fmt_attr server res "%link" 'link))
    res
  )
)

; host:port or ""
(define (server_addr server)
  (if (server_key_exists server 'host)
      (server_fmt server "%host:%port")
      ""
  )
 )

(define (html_href url text) `(a (( href ,url)) ,text))

; Link to server
(define (server_href x) (html_href (format "/server/~a" x) (server_name x)))
  
(define (include_css name)
  `(link ((rel "stylesheet") (href "/style.css")))
  )

(define (html_table_header elems)
  `(tr ,@(for/list ([x elems])
    `(th ,x)))
  )

(define (html_table_row cells)
`(tr ,@(for/list ([x cells])
    `(td ,x ))))

(define (html_table header rows)
  `(table (thead (,@header) ) (tbody ,@rows))
)

; Cells to show for each row.
(define (server_attrs x) 
  (list (server_href x)
        (server_addr x)
        (html_href (server_external x) (server_external x))
  )
)




(define (send_response the-html)
  (response/xexpr
   `(html (head (title "FOStatus ConfigEd")
                ,(include_css "style.css")) 
          (body (div ((id "content"))
                     (div ((id "edit-area" ))
                          ,the-html
                          )))))
  )

(define (show_index req)
    (define server_rows (map (lambda (x) `,(html_table_row `,(server_attrs x))) server_keys))
    (define server_table (html_table
                              (html_table_header '("Name" "Address", "Website"))
                              server_rows
  ))
   (send_response `(p "Click on a server to edit config." ,server_table ))
  )


(define (checkbox_checked value)
  (writeln value)
  (if (eq? value #t)
      `[checked "checked"]
      `[data-dummy ""] ; not sure how to return an empty sexpr...
      )
  )

(define (show_server req server_sym)
   (define server (string->symbol server_sym))
   (send_response `(p ([style "text-align: center; font-size: 32px"]) ,(server_fmt server "Editing \"%name\" ")
                   ( form ([name "server"] [method "post"] [style "width: 600px;margin-top: 15px; border: 3px solid #454545;padding: 25px; background: #353535; margin-left: auto; margin-right: auto;"]) ( table () ; TODO: move to style.css
                       ( tbody ( tr ( td () "Name"    (td ( input ([style "width: 325px"] [type "text"] [name "name"] [value ,(server_name server) ] )))))
                               ( tr ( td () "Host"    (td ( input ([style "width: 325px"] [type "text"] [name "host"] [value ,(server_host server) ] )))))
                               ( tr ( td () "Port"    (td ( input ([style "width: 325px"] [type "text"] [name "port"] [value ,(~a (server_port server))] )))))
                               ( tr ( td () "Website" (td ( input ([style "width: 325px"] [type "text"] [name "website"] [value ,(~a (server_web server))] )))))
                               ( tr ( td () "Link"    (td ( input ([style "width: 325px"] [type "text"] [name "link"] [value ,(~a (server_link server))] )))))
                               ( tr ( td () "Discord" (td ( input ([style "width: 325px"] [type "text"] [name "discord"] [value ,(~a (server_discord server))] )))))
                               ( tr ( td () "IRC"     (td ( input ([style "width: 325px"] [type "text"] [name "irc"] [value ,(~a (server_irc server))] )))))
                               ( tr ( td () "Closed"  (td ( input ([style "width: 15px"]  [type "checkbox"] [name "closed"] ,(checkbox_checked (server_closed server))  ) ) ))))
                       )
                       ( input ([type "submit"] [style "margin-top: 20px; margin-left: 20px; width: 100px;"] [value "Save"] ))
                       ( input ([type "hidden"] [name "server"] [value ,server_sym] ))
                       )
                          
                       
                    )
                   )
    )


; Extract binding
(define (erb req symbol)
  (extract-binding/single symbol (request-bindings req))
)

; Binding exists
(define (exb req symbol)
  (exists-binding? symbol (request-bindings req))
  )


; Save form value to hashmap
(define (save_server_var req attr is_number)
  (if (eq? is_number #t)
    (server_set_attr (string->symbol (erb req 'server)) attr (string->number (erb req attr)))
    (server_set_attr (string->symbol (erb req 'server)) attr (erb req attr))
  )
)



(define (save_server req)
  (save_server_var req 'name #f)
  (save_server_var req 'host #f)
  (save_server_var req 'port #t)
  (save_server_var req 'website #f)
  (save_server_var req 'discord #f)
  (save_server_var req 'link #f)
  (save_server_var req 'irc #f)
  (if (eq? (exb req 'closed) #f)
   (server_set_attr (string->symbol (erb req 'server)) 'closed false)
   (server_set_attr (string->symbol (erb req 'server)) 'closed true)
   )

  (define out (open-output-file "servers2.json" #:mode 'text #:exists 'replace))
  (write-json servers out)
  (close-output-port out)
  (show_server req (erb req 'server))
)


(define-values (http-dispatch url)
  (dispatch-rules
   (("") show_index)
   (("server" (string-arg)) show_server)
   )
  )

(define (start req)
 (define is_saving (exb req 'name))
 (if (eq? is_saving #t)
     (save_server req)
     (http-dispatch req)
 )

)

(serve/servlet start
               #:port 1500
               #:servlet-path "/"
               #:servlet-regexp #rx""
               #:extra-files-paths (list(build-path (current-directory) "static" ))
               )