root/crawl-webtiles.scm

(define-module (hidamari-blue crawl-webtiles)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (guix packages)
  #:use-module (guix utils)
  #:use-module (guix download)
  #:use-module (guix build-system gnu)
  #:use-module (guix build-system cmake)
  #:use-module ((guix licenses) #:renamer (symbol-prefix-proc 'license:))
  #:use-module (gnu packages)
  #:use-module (gnu packages pkg-config)
  #:use-module (gnu packages ncurses)
  #:use-module (gnu packages base)
  #:use-module (gnu packages bison)
  #:use-module (gnu packages flex)
  #:use-module (gnu packages databases)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages fontutils)
  #:use-module (gnu packages fonts)
  #:use-module (gnu packages image)
  #:use-module (gnu packages games)
  #:use-module (gnu packages perl)
  #:use-module (gnu packages python))

;;; * state
;;;   - it works, but lacks configuration options through a service
;;;   - it's fetching prebuild js files like jquery
;;;   - it does not mkdir -p /var/games/crawl-webtiles/rcs
;;;   - it does not inherit the crawl base package.
;;; * what should be done
;;;   - write a service
;;;   - have config.py load from etc and generated by the service
;;;   - have the service init /var/games/crawl-webtiles
;;;   - create a new low priviledge user for the service
;;; * considerations
;;;   - maybe add WEBTILES=y to the base crawl package,
;;;     and only copy the python dirs for this build.
;;;     have the crawl package picked from a service.
;;;     - downside: we would have to build without wizard mode cheats
;;;                 (USE_DGAMELAUNCH=y)
;;;
(define (python-raw value))
(define (python-str str)
  ;; generate: u"text-content"
  (string-append ("u\"" str "\"")))
(define (python-bool value)
  ;; generate: True or False
  (if value "True" "False"))
(define (python-int value)
  ;; generate: 3 for 3.333
  (number->string (inexact->exact (floor value))))
(define (field-var name value)
  (string-append name "=" value "\n"))
(define (field-str name value)
  (field-var name (python-str value)))
(define (field-bool name value)
  (field-var name (python-bool value)))
(define (field-int name value)
  (field-var name (python-int value)))
(define (python-list lst)
  ;; generate: (a,b,c)
  (string-append "(" (string-join lst ",") ")"))
(define (python-dict lst)
  ;; generate: dict(a,b,c)
  (string-append "dict" (python-list lst)))
(define (python-array lst)
  ;; generate: [a,b,c]
  (string-append "[" (string-join lst ",") "]"))
(define (python-obj lst)
  ;; generate: {a,b,c}
  (string-append "{" (string-join lst ",") "}"))
(define (obj-var name value)
  (string-append name ": " value))
(define (obj-str name value)
  (obj-var name (python-str value)))
(define (python-pair a b)
  ;; generate: (a,b)
  (string-append "(" a "," b ")"))

(define (config-make-game name crawl rcs-dir arguments)
  (define binary (string-append crawl "/bin/crawl"))
  (define dash-name (string-downcase (string-replace name " " "-")))
  (python-pair
   dash-name
   (python-dict
    (field-str "name" name)
    (field-str "crawl_binary" binary)
    (field-str "rcfile_path" rcs-dir)
    (field-str "macro_path" rcs-dir)
    (field-str "morgue_path" (string-append rcs-dir "%n"))
    (field-str "inprogress_path" (string-append rcs-dir "running"))
    (field-str "ttyrec_path" (string-append rcs-dir "ttyrecs/%n"))
    (field-str "socket_path" rcs-dir)
    (field-var "morgue_url" "None")
    (field-var "send_json_options" "True")
    (field-var "options" (python-array (map python-str arguments))))))

(define (config-make-game-variants name crawl rcs-dir arguments variants)
  (define vanilla-game (config-make-game name crawl rcs-dir arguments))
  (define variant-games
    (map (lambda (variant-args)
           (define args (append variant-args arguments))
           (config-make-game name crawl rcs-dir args))
         variants))
  (cons vanilla-game variant-games))

(define-record-type* <crawl-game-configuration> crawl-game-configuration
  make-crawl-game-configuration
  crawl-game-configuration?
  (name           crawl-game-configuration-name
                  (default fcgiwrap))
  (package        crawl-game-configuration-package ;<package>
                  (default fcgiwrap))
  (rcs-dir        crawl-game-configuration-rcs-dir ;must have / suffix
                  (default "/var/games/crawl-webtiles/rcs/"))
  (arguments      crawl-game-configuration-arguments
                  (default '()))
  (make-variants? crawl-game-configuration-make-variants?
                  (default #t)))

(define-record-type* <crawl-webtiles-configuration> crawl-webtiles-configuration
  make-crawl-webtiles-configuration
  crawl-webtiles-configuration?
  (server-package    crawl-webtiles-configuration-server-package
                     (default crawl-webtiles))
  (games             crawl-webtiles-configuration-name
                     (default fcgiwrap))
  (ports             crawl-webtiles-configuration-listen
                     (default '(("127.0.0.1" 8080)
                                ("localhost" 8082)
                                ("" 8180))))
  (ssl-ports         crawl-webtiles-configuration-ssl-listen
                     (default '()))
  ;; "certfile": "/etc/crawl/localhost.crt",
  ;; "keyfile": "/etc/crawl/localhost.key"
  (ssl-certfile      crawl-webtiles-configuration-ssl-cert
                     (default #f))
  (ssl-keyfile       crawl-webtiles-configuration-ssl-cert
                     (default #f))
  (arguments         crawl-webtiles-configuration-arguments
                     (default '()))
  ;; how many people can play or watch at the same time
  (max-connections   crawl-webtiles-configuration-max-connections
                     (default 100))
  ;; create addional games for every game using these argument lists
  (game-variants     crawl-webtiles-configuration-game-variants
                     (default '(("-sprint")
                                ("-tutorial"))))
  (rcs-dir           crawl-webtiles-configuration-rcs-dir
                     (default "/var/games/crawl-webtiles/rcs"))
  (password-db-file  crawl-webtiles-configuration-password-db-file
                     (default "/var/games/crawl-webtiles/passwd.db3"))
  (milestones-file   crawl-webtiles-configuration-milestones-file
                     (default "/var/games/crawl-webtiles/milestones"))
  ;; keep it open to append arbitrary python code to the generated config.py
  (additional-config crawl-webtiles-configuration-additional-config
                     (default "")))

(define make-config-file
  (match-lambda
    (($ <crawl-webtiles-configuration> server-package games ports ssl-ports
                                       ssl-certfile ssl-keyfile arguments
                                       max-connections game-variants rcs-dir
                                       password-db-file milestones-file
                                       additional-config)
     (define ssl-only (and (null? ports) (not null? ssl-ports)))
     (define first-port (if (null? ports) '("" 8080) (car ports)))
     (define first-ssl-port (if (null? ssl-ports) '("" 8081) (car ssl-ports)))
     (define server-out (assoc-ref (package-outputs server-package) 'out))
     (define webserver (string-append server-out "/share/webserver"))
     (mixed-text-file
      "config.py"

      "import logging
try:
    from collections import OrderedDict
except ImportError:
    from ordereddict import OrderedDict
"
      (field-bool "dgl_mode" #t)
      (field-bool "bind_nonsecure" ssl-only)
      (field-str "bind_address" (list-ref first-port 1))
      (field-int "bind_port" (list-ref first-port 2))
      (field-var "bind_pairs"
                 (python-list
                  (map (lambda (port)
                         (python-pair (python-str (list-ref port 0))
                                      (python-int (list-ref port 1))))
                       ports)))

      (field-var
       "logging_config"
       (python-obj
        ;; #    "filename": "webtiles.log",
        (obj-var "level" "logging.INFO")
        (obj-str "format" "%(asctime)s %(levelname)s: %(message)s")))

      (field-str "password_db" password-db-file)

      (field-str "static_path" (string-append webserver "/static"))
      (field-str "template_path" (string-append webserver "/webserver/templates/"))
      ;; # Path for server-side unix sockets (to be used to communicate with crawl)
      (field-var "server_socket_path" "None") ;; # Uses global temp dir
      ;; # Server name, so far only used in the ttyrec metadata
      (field-str "server_id" "")

      ;; # Disable caching of game data files
      (field-bool "game_data_no_cache" #t)
      ;; # Watch socket dirs for games not started by the server
      (field-bool "watch_socket_dirs" #f)

      (field-var
       "games"
       (string-append
        "OrderedDict("
        (python-array (map (match-lambda
                             (($ name package rcs-dir arguments)
                              (config-make-game-variants)))
                           games))
        ")"))

      (field-str "dgl_status_file" rcs-dir "/status")
      ;; # Set to None not to read milestones
      (field-str "milestone_file" milestones-file)
      (field-int "status_file_update_rate" 5)
      (field-var "recording_term_size" (python-pair (python-int 80) (python-int 24)))
      (field-int "max_connections" max-connections)

      ;; # Script to initialize a user, e.g. make sure the paths
      ;; # and the rc file exist. This is not done by the server
      ;; # at the moment.
      (field-str "init_player_program"
                 (string-append server-out "/share/webtiles-init-player.sh"))

      ;; ssl cert/key files
      (cond ((and certfile keyfile)
             (field-var "ssl_options"
                        (python-obj
                         (obj-str "certfile" "./webserver/localhost.crt")
                         (obj-str "keyfile" "./webserver/localhost.key"))))
            ((or certfile keyfile ssl-only)
             (error "cert and keyfile must both be set" certfile keyfile))
            (else (field-var "ssl_options" "None"))) ;; # No SSL


      (field-str "ssl_address" (list-ref first-ssl-port 0))
      (field-int "ssl_port" (list-ref first-ssl-port 1))
      ;; # Or listen on multiple address/port pairs (overriding the above) with:
      ;; # ssl_bind_pairs = (
      ;; #     ("127.0.0.1", 8081),
      ;; #     ("localhost", 8083),
      ;; # )
      (field-var "ssl_bind_pairs"
                 (python-list
                  (map (lambda (port)
                         (python-pair (python-str (list-ref port 0))
                                      (python-int (list-ref port 1))))
                       ssl-ports)))

      (field-int "connection_timeout" 600)
      (field-int "max_idle_time" (* 5 60 60))
      ;; # Seconds until stale HTTP connections are closed
      ;; # This needs a patch currently not in mainline tornado.
      (field-var "http_connection_timeout" "None")
      (field-int "kill_timeout" 10) ;; # Seconds until crawl is killed after HUP is sent

      ;; TODO 20 characters passwords? why so short?
      (field-var "nick_regex" "r\"^[a-zA-Z0-9]{3,20}$\"")
      (field-int "max_passwd_length" 20)

      ;; # crypt() algorithm, e.g. "1" for MD5 or "6" for SHA-512; see crypt(3). If
      ;; # false, use traditional DES (but then only the first eight characters of the
      ;; # password are significant). If set to "broken", use traditional DES with
      ;; # the password itself as the salt; this is necessary for compatibility with
      ;; # dgamelaunch, but should be avoided if possible because it leaks the first
      ;; # two characters of the password's plaintext.
      (field-str "crypt_algorithm" "broken")
      ;; # The length of the salt string to use. If crypt_algorithm is false, this
      ;; # setting is ignored and the salt is two characters.
      (field-int "crypt_salt_length" 16)
      (field-int "login_token_lifetime" 7) ;; # Days

      ;; we do this with guix/shepherd
      (field-var "uid" "None") ;; # If this is not None, the server will setuid to that (numeric) id
      (field-var "gid" "None") ;; # after binding its sockets.
      (field-var "umask" "None") ;; # e.g. 0077
      (field-var "chroot" "None")
      (field-var "pidfile" "None")
      (field-bool "daemon" #f) ;; # If true, the server will detach from the session after startup

      ;; # Set to a URL with %s where lowercased player name should go in order to
      ;; # hyperlink WebTiles spectator names to their player pages.
      ;; # For example: "http://crawl.akrasiac.org/scoring/players/%s.html"
      ;; # Set to None to disable player page hyperlinks
      ;; TODO
      (field-var "player_url" "None")

      ;; # Only for development:
      ;; # Disable caching of static files which are not part of game data.
      (field-bool "no_cache" #f)
      ;; # Automatically log in all users with the username given here.
      (field-var "autologin" "None")
      additional-config))))

(define-public crawl-webtiles-full
  (package
   (name "crawl-webtiles")
   (version "0.19.5")
   (source (origin
            (method url-fetch)
            (uri (list (string-append "http://crawl.develz.org/release/stone_soup-"
                                      version "-nodeps.tar.xz")
                       (string-append "http://crawl.develz.org/release/"
                                      (version-major+minor version) "/stone_soup-"
                                      version "-nodeps.tar.xz")))
            (sha256
             (base32
              "00yl2lb2shglxlxzpyk99zvglfx4amjybqwnzdcasvbiggb4cj18"))))
   (arguments
    '(#:tests?
      #f
      #:make-flags
      (let* ((sqlite (assoc-ref %build-inputs "sqlite"))
             (out (assoc-ref %outputs "out")))
        (list (string-append "SQLITE_INCLUDE_DIR=" sqlite "/include")
              (string-append "prefix=" out)
              "GAME=crawl-webtiles-game"
              "SAVEDIR=~/var/games/crawl-webtiles/saves"
              "WEBTILES=y"
              ;; disables cheats and enables extended lobby
              "USE_DGAMELAUNCH=y"
              "BUILD_LUA="
              "BUILD_SQLITE="
              "BUILD_ZLIB="))
      #:phases
      (modify-phases
       %standard-phases
       (delete 'configure)
       (add-after
        'unpack 'prepare-before-make
        (lambda* (#:key inputs #:allow-other-keys)
          (chdir "source")
          (system* "tar" "-xvf" (assoc-ref inputs "js-contrib"))))
       (add-before
        'install
        'install-webtiles
        (lambda* (#:key inputs outputs #:allow-other-keys)
          (let* ((out (assoc-ref outputs "out"))
                 (python (string-append (assoc-ref inputs "python") "/bin/python"))
                 (python-path (getenv "PYTHONPATH"))
                 (sh (which "sh"))
                 (webserver (string-append out "/share/webserver")))

            ;; Eval the config from the first argument rather than
            ;; loading a static config.py file.
            ;; This allows service configuration without rebuilds
            (substitute*
             "webserver/config.py"
             (("from config import \\*")
              "import sys
exec(sys.argv[1])"
              (string-append "\"" out "/bin/crawl-webtiles-game\"")))
            ;; config paths subs
            ;; (substitute*
            ;;  "webserver/config.py"
            ;;  (("\"\\./crawl\"")
            ;;   (string-append "\"" out "/bin/crawl-webtiles-game\"")))
            ;; (substitute*
            ;;  "webserver/config.py"
            ;;  (("\\./rcs")
            ;;   "/var/games/crawl-webtiles/rcs"))
            ;; (substitute*
            ;;  "webserver/config.py"
            ;;  (("\\./util/webtiles-init-player.sh")
            ;;   (string-append out "/share/webtiles-init-player.sh")))
            ;; (substitute*
            ;;  "webserver/config.py"
            ;;  (("\\./milestones")
            ;;   "/var/games/crawl-webtiles/milestones"))
            ;; (substitute*
            ;;  "webserver/config.py"
            ;;  (("\\./webserver/passwd.db3")
            ;;   "/var/games/crawl-webtiles/passwd.db3"))
            ;; (substitute*
            ;;  "webserver/config.py"
            ;;  (("\\./webserver")
            ;; webserver))
            ;; fix python2 to python3
            ;; TODO python3 seems mostly unsupported
            ;; (substitute*
            ;;  "webserver/server.py"
            ;;  (("except OSError,")
            ;;   "except OSError as"))
            ;; (substitute*
            ;;  "webserver/process_handler.py"
            ;;  (("except OSError,")
            ;;   "except OSError as"))

            ;; init user script script
            (substitute*
             "util/webtiles-init-player.sh"
             (("\\./rcs")
              "/var/games/crawl-webtiles/rcs"))
            (substitute*
             "util/webtiles-init-player.sh"
             (("\\.\\./settings/")
              (string-append out "/settings/")))

            ;; copy files
            (mkdir-p (string-append out "/bin"))
            (mkdir-p (string-append out "/share"))
            (mkdir-p (string-append out webserver))
            (install-file "util/webtiles-init-player.sh"
                          (string-append out "/share/"))
            (copy-recursively "webserver/" webserver)

            ;; custom python run script
            (call-with-output-file (string-append out "/bin/crawl-webtiles")
              (lambda (port)
                (display
                 (string-append
                  "#!/" sh "\n"
                  "PYTHONPATH=\"" python-path "\" "
                  python " " webserver "/server.py")
                 port)))
            (chmod (string-append out "/share/webtiles-init-player.sh") #o755)
            (chmod (string-append out "/bin/crawl-webtiles") #o755)

            ;; TODO package:
            ;; ba-linkify.min.js inflate.js jquery.cookie.js
            ;; jquery.js jquery.json.js jquery.tablesorter.js
            ;; jquery.waitforimages.js require.js
            ;; ------------------
            ;; fuck it I'm out
            (copy-recursively "contrib" (string-append webserver "/static/scripts/contrib"))
            #t)
          )))))
   (build-system gnu-build-system)
   (inputs `(("ncurses" ,ncurses)
             ("sqlite" ,sqlite)
             ("zlib" ,zlib)
             ("lua51" ,lua-5.1)
             ("freetype6" ,freetype)
             ("libpng" ,libpng)
             ("python" ,python-2.7)
             ("python2-ruamel.ordereddict" ,python2-ruamel.ordereddict)
             ;; just giving the fuck up and fetching prebuilt js files.
             ;; I copied webserver/static/scripts/contrib/ from the contrib tar of crawl
             ("js-contrib" ,(origin
                             (method url-fetch)
                             (uri (string-append
                                   "https://hidamari.blue/static/crawl-webtiles-js-contrib.tar.bz2"))
                             (sha256 (base32 "0aqmkxlcl5xqajz51mn9ahl9s63kgrbrzffphxmgjzrgwnl6crn2"))
                             (file-name "crawl-webtiles-js-contrib.tar.bz2")))
             ("python-tornado" ,python2-tornado)))
   (native-inputs `(("bison" ,bison)
                    ("flex" ,flex)
                    ("perl" ,perl)
                    ("which" ,which)
                    ("pkg-config" ,pkg-config)))
   (synopsis "Roguelike dungeon crawler game")
   (description "A roguelike adventure through dungeons filled with dangerous
monsters in a quest to find the mystifyingly fabulous Orb of Zot.")
   (home-page "https://crawl.develz.org")
   (license license:gpl2+)))

;;; TODO service
;; (define-record <crawl-webtiles-configuration>
;;   (crawl-webtiles-configuration crawl-webtiles)
;;   crawl-webtiles-configuration?
;;   (crawl-webtiles config-crawl-webtiles))

;; (define crawl-webtiles-service-type
;;   (service-type (name 'crawl-webtiles)
;;                 (extensions
;;                  (list (service-extension shepherd-root-service-type)))

;;                 (compose concatenate)       ;concatenate the list of rules
;;                 (extend (lambda (config rules)
;;                           (match config
;;                             (($ <crawl-webtiles-configuration> crawl-webtiles)
;;                              (crawl-webtiles-configuration
;;                               (crawl-webtiles crawl-webtiles)   ;the crawl package to use
;;                               )))))))

;;; TODO use this as base for an inherit package
;; (define-public crawl-tiles
;;   (package
;;    (inherit crawl)
;;    (name "crawl-tiles")
;;    (arguments
;;     (substitute-keyword-arguments
;;      (package-arguments crawl)
;;      ((#:make-flags flags)
;;       `(let* ((dejavu (assoc-ref %build-inputs "font-dejavu")))
;;          (append (cons* (string-append "PROPORTIONAL_FONT=" dejavu
;;                                        "/share/fonts/truetype/DejaVuSans.ttf")
;;                         (string-append "MONOSPACED_FONT=" dejavu
;;                                        "/share/fonts/truetype/DejaVuSansMono.ttf")
;;                         "TILES=y"
;;                         ,flags)
;;                  (list "TILES=y"))))))
;;    (inputs `(,@(package-inputs crawl)
;;              ("font-dejavu" ,font-dejavu)
;;              ("freetype6" ,freetype)
;;              ("glu" ,glu)
;;              ("libpng" ,libpng)
;;              ("sdl2" ,sdl2)
;;              ("sdl2-image" ,sdl2-image)
;;              ("sdl2-mixer" ,sdl2-mixer)))
;;    (native-inputs `(,@(package-native-inputs crawl)
;;                     ;; ("advancecomp" ,advancecomp)
;;                     ("pngcrush" ,pngcrush)
;;                     ("which" ,which)))
;;    (synopsis "Graphical roguelike dungeon crawler game")))