guix-config/sway-service.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
;;; Copyright © 2020, 2021 Joshua Branson <jbranso@dismail.de>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; GNU Guix 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 General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (sway-service)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (guix packages)
  #:use-module (guix build-system trivial)
  #:use-module (gnu packages admin)
  ;; #:autoload   (gnu packages ci) (cuirass)
  ;; #:autoload   (gnu packages version-control) (git)
  #:use-module (gnu packages wm)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services dbus)
  #:use-module (gnu services admin)
  #:use-module (gnu system shadow)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:export (
            sway-configuration
            sway-configuration?
            sway-configuration-sway
            sway-configuration-user
            sway-configuration-group
            sway-configuration-sway-variables
            sway-configuration-bindsyms
            sway-configuration-raw-content
            sway-configuration-file

            sway-variables-configuration
            sway-variables-configuration?
            sway-variables-configuration-background-image
            sway-variables-configuration-mod-key
            sway-variables-configuration-letter-left
            sway-variables-configuration-letter-down
            sway-variables-configuration-letter-up
            sway-variables-configuration-letter-right
            sway-variables-configuration-default-terminal
            sway-variables-configuration-application-launcher
            sway-variables-configuration-keyboard-layout
            sway-variables-configuration-xkb-options
            sway-variables-configuration-tap-to-click?
            sway-variables-configuration-natural-scroll?
            sway-variables-configuration-middle-emulation?

            %sway-basic-bindsyms
            %sway-moving-around-bindsyms
            %sway-layout-bindsyms
            %sway-scratchpad-bindsyms

            ;; this is (flatten (list all the above %*-bindsyms)
            %sway-bindsyms

            sway-bindsym
            sway-bindsym?
            sway-bindsym-whole-window
            sway-bindsym-border
            sway-bindsym-exclude-titlebar
            sway-bindsym-release
            sway-bindsym-locked
            sway-bindsym-to-code
            sway-bindsym-input-device
            sway-bindsym-no-warm
            sway-bindsym-no-repeat
            sway-bindsym-group
            sway-bindsym-key-combo
            sway-bindsym-command
            sway-bindsym-command-arguments

            sway-status-bar-configuration
            sway-status-bar-configuration?
            sway-status-bar-position-configuration
            sway-status-bar-status-command-configuration
            sway-status-bar-pango-markup-enabled?
            sway-status-bar-status-line-color-configuration
            sway-status-bar-background-color-configuration
            sway-status-bar-inactive-workspace-colors-configuration

            sway-service-type
            ))

;;;; Commentary:
;;; This file provides a shepherd service to run the sway window
;;; manager.
;;;; Code:

(define-record-type* <sway-status-bar-configuration>
  sway-status-bar-configuration make-sway-status-bar-configuration
  sway-status-bar-configuration?
  (position sway-status-bar-configuration-position
            (default 'top))
  (status-command sway-status-bar-configuration-status-command  ; string
                  (default "while date +'%Y-%m-%d %l:%M:%S %p'; do sleep 1; done"))
  (pango-markup-enabled? sway-status-bar-configuration-pango-markup-enabled
                         (default #f))
  (status-line-color sway-status-bar-configuration-status-line-color  ;string
                     (default "#ffffff"))
  (background-color  sway-status-bar-configuration-background-color  ;string
                     (default "#323232"))
  (inactive-workspace-colors sway-status-bar-configuration-inactive-workspace-colors ; list of 3 strings
                             (default '("#32323200 #32323200 #5c5c5c"))))

(define-record-type* <sway-variables-configuration>
  sway-variables-configuration make-sway-variables-configuration
  sway-variables?
  ;; TODO figure out how to set dimensions for desktop background image
  (background-image        sway-variables-configuration-background-image ;file
                           (default "Sway_Wallpaper_Blue_1920x1080.png"))

  (mod-key               sway-variables-configuration-mod
                         (default "Mod4"))
  ;; direction letters
  (letter-left sway-variables-configuration-left ;char
               (default "h"))
  (letter-right sway-variables-configuration-right ;char
                (default "l"))
  (letter-up sway-variables-configuration-up ;char
             (default "k"))
  (letter-down sway-variables-configuration-down  ;char
               (default "j"))
  ;; TODO set this default up to be a terminal name
  (default-terminal sway-variables-configuration-default-terminal
    (default "urxvt"))  ;; TODO make this a package object?
  ;; set this to dmenu or whatever I am using now
  (application-launcher sway-variables-configuration-application-launcher
                        (default "dmenu")) ;; TODO SET to package object
  ;; TODO get this layout from the OS keyboard layout record
  ;;list of strings keyboard layouts that you want to use
  (keyboard-layout sway-variables-configuration-keyboard-layouts
                   (default '()))
  ;;list of strings of xkb-options that you want like (list "ctrl:swapcaps")
  (xkb-options  sway-variables-configuration-xkb-options
                (default '()))
  (tap-to-click? sway-variables-configuration-tap-to-click?
                 (default #f))
  (natural-scroll? sway-variables-configuration-natural-scroll?
                   (default #t))
  (middle-emulation? sway-variables-configuration-middle-emulation?
                     (default #f)))

(define-record-type* <sway-bindsym>
  sway-bindsym make-sway-bindsym
  sway-bindsym?
  (whole-window sway-bindsym-whole-window
                (default #f))
  (border sway-bindsym-border
          (default #f))
  (exclude-titlebar sway-bindsym-exclude-titlebar
                    (default #f))
  (release sway-bindsym-release
           (default #f))
  (locked sway-bindsym-locked
          (default #f))
  (to-code sway-bindsym-to-code
           (default #f))
  (input-device sway-bindsym-input-device
                (default #nil))
  (no-warn sway-bindsym-no-warn
           (default #f))
  (no-repeat sway-bindsym-no-repeat
             (default #f))
  (group sway-bindsym-group
         (default #f))
  (key-combo sway-bindsym-key-combo
             (default ""))
  (command sway-bindsym-command ;string or <package>
           (default ""))
  (command-arguments sway-bindsym-arguments
                     (default #f)))

(define %sway-basic-bindsyms
  (list
   (sway-bindsym
    (key-combo "$mod+Return")
    (command "$term")) ;; set to launch default terminal
   (sway-bindsym
    (key-combo "$mod+Shift+q")
    (command "kill"))
   (sway-bindsym
    (key-combo "$mod+d")
    (command "$menu"))
   (sway-bindsym
    (key-combo "$mod normal")
    (command "normal"))
   (sway-bindsym
    (key-combo "$mod+Shift+c")
    (command "reload"))
   (sway-bindsym
    (key-combo "$mod+Shift+e")
    (command "reload"))))

(define %sway-moving-around-bindsyms
  (list
   (sway-bindsym
    (key-combo "$mod+$left")
    (command "focus left"))
   (sway-bindsym
    (key-combo "$mod+$down")
    (command "focus down"))
   (sway-bindsym
    (key-combo "$mod+$up")
    (command "focus up"))
   (sway-bindsym
    (key-combo "$mod+$right")
    (command "focus right"))

   (sway-bindsym
    (key-combo "$mod+Left")
    (command "focus left"))
   (sway-bindsym
    (key-combo "$mod+Down")
    (command "focus down"))
   (sway-bindsym
    (key-combo "$mod+Up")
    (command "focus up"))
   (sway-bindsym
    (key-combo "$mod+Right")
    (command "focus Right"))
   ;;  Move the focused window with the same, but add Shift
   (sway-bindsym
    (key-combo "$mod+Shift+$left")
    (command "move left"))
   (sway-bindsym
    (key-combo "$mod+Shift+$down")
    (command "move down"))
   (sway-bindsym
    (key-combo "$mod+Shift+$up")
    (command "move up"))
   (sway-bindsym
    (key-combo "$mod+Shift+$right")
    (command "move right"))

   (sway-bindsym
    (key-combo "$mod+Shift+Left")
    (command "move left"))
   (sway-bindsym
    (key-combo "$mod+Shift+Down")
    (command "move down"))
   (sway-bindsym
    (key-combo "$mod+Shift+Up")
    (command "move up"))
   (sway-bindsym
    (key-combo "$mod+Shift+Right")
    (command "move Right"))))

(define %sway-workspace-bindsyms
  (list
   (sway-bindsym
    (key-combo "$mod+1")
    (command "workspace number 1"))
   (sway-bindsym
    (key-combo "$mod+1")
    (command "workspace number 2"))
   (sway-bindsym
    (key-combo "$mod+3")
    (command "workspace number 3"))
   (sway-bindsym
    (key-combo "$mod+4")
    (command "workspace number 4"))
   (sway-bindsym
    (key-combo "$mod+5")
    (command "workspace number 5"))
   (sway-bindsym
    (key-combo "$mod+6")
    (command "workspace number 6"))
   (sway-bindsym
    (key-combo "$mod+7")
    (command "workspace number 7"))
   (sway-bindsym
    (key-combo "$mod+8")
    (command "workspace number 8"))
   (sway-bindsym
    (key-combo "$mod+9")
    (command "workspace number 9"))
   (sway-bindsym
    (key-combo "$mod+10")
    (command "workspace number 10"))

   ;;  Move focused container to workspace
   (sway-bindsym
    (key-combo "$mod+Shift+1")
    (command "move container to workspace 1"))
   (sway-bindsym
    (key-combo "$mod+Shift+2")
    (command "move container to workspace 2"))
   (sway-bindsym
    (key-combo "$mod+Shift+3")
    (command "move container to workspace 3"))
   (sway-bindsym
    (key-combo "$mod+Shift+4")
    (command "move container to workspace 4"))
   (sway-bindsym
    (key-combo "$mod+Shift+5")
    (command "move container to workspace 5"))
   (sway-bindsym
    (key-combo "$mod+Shift+6")
    (command "move container to workspace 6"))
   (sway-bindsym
    (key-combo "$mod+Shift+7")
    (command "move container to workspace 7"))
   (sway-bindsym
    (key-combo "$mod+Shift+8")
    (command "move container to workspace 8"))
   (sway-bindsym
    (key-combo "$mod+Shift+9")
    (command "move container to workspace 9"))
   (sway-bindsym
    (key-combo "$mod+Shift+10")
    (command "move container to workspace 10"))))

(define %sway-layout-bindsyms
  (list
   (sway-bindsym
    (key-combo "$mod+b")
    (command "splith"))
   ;;bindsym $mod+b splith
   (sway-bindsym
    (key-combo "$mod+v")
    (command "splitv"))

   ;; Switch the current container between different layout styles
   (sway-bindsym
    (key-combo "$mod+s")
    (command "layout stacking"))
   (sway-bindsym
    (key-combo "$mod+w")
    (command "layout tabbed"))
   (sway-bindsym
    (key-combo "$mod+e")
    (command "layout toggle split"))

   ;; Make the current focus fullscreen
   (sway-bindsym
    (key-combo "$mod+f")
    (command "fullscreen"))
   ;; Toggle the current focus between tiling and floating mode
   (sway-bindsym
    (key-combo "$mod+Shift+space")
    (command "floating toggle"))
   ;; Swap focus between the tiling area and the floating area
   (sway-bindsym
    (key-combo "$mod+space")
    (command "focus mode_toggle"))
   ;; Move focus to the parent container
   (sway-bindsym
    (key-combo "$mod+a")
    (command "focus parent"))

   ;;  Resizing containers:
   ;; TODO how am I handling resizing containers???
   ;; TODO let users edit "resize" variable so that they can modify how much each keypress
   ;; resizes containers.

   ;; this code is hardcoded into the service definition
   ;; mode "resize" {
   ;;              #  left will shrink the containers width
   ;;              #  right will grow the containers width
   ;;              #  up will shrink the containers height
   ;;              #  down will grow the containers height
   ;;                bindsym $left resize shrink width 10px
   ;;                bindsym $down resize grow height 10px
   ;;                bindsym $up resize shrink height 10px
   ;;                bindsym $right resize grow width 10px

   ;;              # Ditto, with arrow keys
   ;;                bindsym Left resize shrink width 10px
   ;;                bindsym Down resize grow height 10px
   ;;                bindsym Up resize shrink height 10px
   ;;                bindsym Right resize grow width 10px

   ;;             # Return to default mode
   ;;               bindsym Return mode "default"
   ;;               bindsym Escape mode "default"
   ;;               }
   ;; bindsym $mod+r mode "resize"
   (sway-bindsym
    (key-combo "$mod+r")
    (command "\"resize\""))))

(define %sway-scratchpad-bindsyms
  (list
   (sway-bindsym
    (key-combo "$mod+Shift+minus")
    (command "move scratchpad"))
   ;; Show the next scratchpad window or hide the focused scratchpad window.
   ;; If there are multiple scratchpad windows, this command cycles through them.

   (sway-bindsym
    (key-combo "$mod+minus")
    (command "scratchpad show"))))

(define (flatten . lst)
  "Return a list that recursively concatenates all sub-lists of LST."
  (define (flatten1 head out)
    (if (list? head)
        (fold-right flatten1 out head)
        (cons head out)))
  (fold-right flatten1 '() lst))

(define %sway-bindsyms
  (flatten (list
            %sway-basic-bindsyms
            %sway-layout-bindsyms
            %sway-workspace-bindsyms
            %sway-moving-around-bindsyms
            %sway-scratchpad-bindsyms)))

(define-record-type* <sway-configuration>
  sway-configuration make-sway-configuration
  sway-configuration?
  (sway          sway-configuration-sway ;package
                 (default sway))
  (user             sway-configuration-user ;string
                    (default "sway"))
  (group            sway-configuration-group ;string
                    (default "users"))
  (variables  sway-configuration-variables
              (default (sway-variables-configuration)))
  (bindsyms sway-configuration-bindsyms
            (default %sway-bindsyms))
  (status-bar sway-configuration-status-bar
              (default (sway-status-bar-configuration)))
  (raw-content sway-configuration-raw-content
               (default ""))
  (file sway-configuration-file ;file-like object
        (default #f)))

(define sway-variables-configuration->list
  (match-lambda
    (($ <sway-variables-configuration> background-image mod-key letter-left letter-down letter-up letter-right
                                       default-terminal application-launcher keyboard-layout xkb-options
                                       tap-to-click? natural-scroll? middle-emulation?)
     (list
      "### Variables\n"
      "# Logo key. Use Mod1 for Alt\n"
      "set $mod " mod-key "\n"
      "# Home row direction keys, like vim\n"
      "set $left " letter-left "\n"
      "set $down " letter-down "\n"
      "set $up " letter-up "\n"
      "set $right " letter-right "\n"
      "set $term " default-terminal "\n" ;;TODO potentially use a gexp to point to default-terminal package
      ;; TODO deal with application-launcher
      "### Output configuration\n"
      "# Default Wallpaper\n"
      "output * bg " background-image " fill\n" ;;TODO use a gexp to copy the background image into the store
      ;; TODO deal with swayidle and sway lock
      "### Input configuration\n"
      (cond [(or tap-to-click? natural-scroll? middle-emulation? (not (null? keyboard-layout))
                 (not (null? xkb-options)))
             (list
              "input * " "{ \n"
              (if tap-to-click?
                  "\t tap enabled\n"
                  "")
              (if natural-scroll?
                  "\t natural_scroll enabled\n"
                  "")
              (if middle-emulation?
                  "\t middle_emulation enabled\n"
                  "")
              ;; TODO xkb-layout should be gotten from the keyboard layout,
              ;; which should specify it in the environment The keymap can
              ;; also be configured using environment variables
              ;; (XKB_DEFAULT_LAYOUT, XKB_DEFAULT_VARIANT, etc.) when starting
              ;; sway, with config options taking precedence over environment
              ;; variables.
              ;; TODO xkb-layout the arch linux wiki page shows
              ;; this https://wiki.archlinux.org/index.php/Sway#Keymap input *
              ;; { xkb_layout "us,de,ru" xkb_variant "colemak,,typewriter"
              ;; xkb_options "grp:win_space_toggle" }
              (cond [(not (null? xkb-options))
                     (list
                      "xkb_options "
                      (substring (let loop ([list xkb-options])
                                   (cond [(null? list)
                                          ""]
                                         [else (string-append "," (car list)
                                                              (loop (cdr list)))])) 1))]
                    [else ""])

              "\n} \n" ;; end input
              )]
            [else ""])
      ))))

;; <sway-bindsym> -> string
;; consider renaming to sway-bindsym->string
(define (sway-bindsym->string sway-bindsym)
  (let* ([command (sway-bindsym-command sway-bindsym)]
         [key-combo
          (cond [(package? command)
                 ;;TODO gexp <package> -> string /gnu/store/stahesunteah/bin/<package>
                 ]
                [else (sway-bindsym-key-combo sway-bindsym)])])
    (string-append key-combo " " command "\n")))

;; list of <sway-bindsym> -> string
(define (sway-bindsyms->list list)
  (let loop ([list (flatten list)])
    (cond [(null? list)
           '()]
          [else
           (cons (sway-bindsym->string (car list))
                 (loop (cdr list)))])))


;; pango-markup-enabled? Todo
(define sway-status-bar-configuration->list
  (match-lambda
    (($ <sway-status-bar-configuration> position status-command pango-markup-enabled?
                                        status-line-color background-color
                                        inactive-workspace-colors)
     (list
      "#\n"
      "# Status Bar:\n"
      "#\n"
      "# Read man 5 sway-bar-configuration for more information about this section."
      "bar {\n"
      "\t position " (symbol->string position) "\n"
      "\t # When the status_command prints a new line to stdout, swaybar updates.\n"
      "\t # The default just shows the current date and time.\n"
      "\t status_command " status-command "\n"
      "\t colors {\n"
      "\t\t statusline " status-line-color "\n"
      "\t\t background " background-color "\n"
      "\t\t inactive_workspace "
      (let loop ([list inactive-workspace-colors])
        (cond [(null? list)
               ""]
              [else (string-append (car list) " "
                                   (loop (cdr list)))]))
      "\n"
      "\t }\n"
      "}\n"
      ))))

;; TODO deal with a sway config-file
(define sway-configuration->list
  (match-lambda
    (($ <sway-configuration> sway user group variables
                             bindsyms status-bar raw-content
                             file)
     (flatten
      (list
       (sway-variables-configuration->list variables)
       (sway-bindsyms->list bindsyms)
       ;; Todo
       (sway-status-bar-configuration->list status-bar)
       )))))

;; Maybe put this code in a guix test?
;; (define config (sway-configuration
;;                 (variables
;;                  (sway-variables-configuration
;;                   (letter-left "n")
;;                   (letter-right "s")
;;                   (letter-up "t")
;;                   (letter-down "h")
;;                   (mod-key "Mod1")
;;                   (default-terminal "allcritty")
;;                   (xkb-options (list "ctrl:swapcaps"
;;                                      "shift:breaks_caps"))))
;;                 (bindsyms
;;                  (list
;;                   %sway-basic-bindsyms
;;                   %sway-moving-around-bindsyms
;;                   (sway-bindsym (key-combo "$mod+Shift+Return")
;;                                 (command "$term -e fish"))))
;;                 (status-bar
;;                  (sway-status-bar-configuration
;;                   (status-command "echo 'hello world!'")
;;                   (status-line-color "blue")
;;                   (inactive-workspace-colors (list "red" "green" "yellow"))))))

;;
;; (display (let loop ([list (sway-configuration->list config)])
;;            (cond [(null? list)
;;                   ""]
;;                  [else (string-append (car list)
;;                                       (loop (cdr list)))])))


;; For now I am assuming that this is correct.
(define (default-sway-config config)
  ;; (match-record
  ;;  config
  ;;  <sway-configuration>
  ;;  (sway user group variables bindsyms status-bar raw-content file)
  ;;  ;; (apply mixed-text-file "config.in"
  ;;  ;;        (flatten
  ;;  ;;         (sway-configuration->list config)))
  ;;  ;; TODO this won't work if I want to use gexps involving paths to executables.
  ;;  )
  (plain-file "config.in"
              (apply string-append (sway-configuration->list config))))

(define (sway-activation config)
  (match-record config
      <sway-configuration>
    (sway file)
    #~(begin
        (use-modules (guix build utils))

        ;; (format #t "creating nginx log directory '~a'~%" #$log-directory)
        ;; (mkdir-p #$log-directory)
        ;; Start-up logs. Once configuration is loaded, nginx switches to
        ;; log-directory.
        ;; do something with recording sway's logs.
        ;;(mkdir-p (string-append #$run-directory "/logs"))
        ;; Check configuration file syntax.
        (system* (string-append #$sway "/bin/sway")
                 "-c" #$(or file
                            (default-sway-config config))))))

(define (sway-shepherd-service config)
  "Return a <shepherd-service> for the Sway service with CONFIG."
  (let* ([sway (sway-configuration-sway config)]
         [user (sway-configuration-user config)]
         [group (sway-configuration-group config)]
         [file (sway-configuration-file config)])
    (list (shepherd-service
           (documentation "Run Sway.")
           (provision '(sway))
           (requirement '(user-processes dbus-system elogind udev virtual-terminal syslogd))
           ;;(requirement '(guix-daemon networking))
           (start #~(make-forkexec-constructor
                     ;; TODO change this line to
                     ;; exec dbus-run-session sway
                     ;; should we un-gexp the (string-append?
                     ;; they do it here
                     ;; [[file:~/prog/gnu/guix/guix-src/gnu/services/base.scm::(system* #$(file-append guix "/bin/guix") "archive"][here]]
                     (list (string-append #$sway "/bin/sway")
                           ;; should this be a '("-c")
                           ;; [[file:~/prog/gnu/guix/guix-src/gnu/services/networking.scm::'("-g")]['("-g")]]
                           "-c"
                           #$(or file
                                 (default-sway-config config)))
                     ;; #:environment-variables
                     ;; (list "GIT_SSL_CAINFO=/etc/ssl/certs/ca-certificates.crt"
                     ;;       (string-append "GIT_EXEC_PATH=" #$git
                     ;;                      "/libexec/git-core"))
                     #:user #$user
                     ;;#:group #$group
                     ;;#:log-file #$log-file
                     ))
           (stop #~(make-kill-destructor
                    (list (string-append #$sway "/bin/swaymsg")
                          "exit")
                    #:user #$user))))))

(define sway-service-type
  (service-type (name 'sway)
                (extensions (list
                             ;; (service-extension profile-service-type ;for 'info sway'
                             ;;                    (compose list sway-configuration-sway shepherd-root-service-type))
                             (service-extension polkit-service-type sway-service-type)
                             ;; all gnome, xfce, mate, use this profile-service-type, which I'm guessing means
                             ;; to start the service after the user has logged in.
                             (service-extension profile-service-type
                                                (compose list sway-configuration-sway))
                             ;; activation service type is a procedure that returns a gexp which is a code snippet to run at
                             ;; activation time.  example at boot
                             (service-extension activation-service-type sway-activation)
                             ;;(service-extension account-service-type sway-account)
                             ;; if people define %desktop-services, then we don't need it.
                             ;; if this service goes in the services/wm.scm, include elogind
                             ;;(service-extension elogind-service-type)
                             ))
                (default-value (sway-configuration))
                (description "Run the sway window manager.")))