;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2022 Petr Hodina <phodina@protonmail.com>
;;;
;;; 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 (nongnu system images quartz64a-desktop)
  #:use-module (gnu bootloader)
  #:use-module (gnu bootloader u-boot)
  #:use-module (gnu image)
  #:use-module (nongnu packages linux)
  #:use-module (nongnu packages bootloaders)
  #:use-module (gnu packages)
  #:use-module (gnu packages glib)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages certs)
  #:use-module (gnu packages gnome)
  #:use-module (gnu packages vim)
  #:use-module (gnu packages ssh)
  #:use-module (gnu packages bison)
  #:use-module (gnu packages libffi)
  #:use-module (gnu packages xorg)
  #:use-module (gnu packages flex)
  #:use-module (gnu packages pkg-config)
  #:use-module (gnu packages python)
  #:use-module (guix platforms arm)
  #:use-module (guix download)
  #:use-module (guix packages)
  #:use-module (guix gexp)
  #:use-module (guix utils)
  #:use-module (guix build utils)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix build emacs-build-system)
  #:use-module (guix build-system gnu)
  #:use-module (guix build-system meson)
  #:use-module (gnu services)
  #:use-module (gnu services desktop)
  #:use-module (gnu services sddm)
  #:use-module (gnu services ssh)
  #:use-module (gnu services xorg)
  #:use-module (gnu services base)
  #:use-module (gnu system)
  #:use-module (gnu system accounts)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system image)
  #:use-module (gnu system keyboard)
  #:use-module (gnu system nss)
  #:use-module (gnu system shadow)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-1) ;for the remove function
  #:export (quartz64-a-raw-image
            quartz64-image-type
            quartz64-desktop-raw-image))

(define (python-extension-suffix python triplet)
  "Determine the suffix for C extensions for PYTHON when compiled
for TRIPLET."
  ;; python uses strings like 'x86_64-linux-gnu' instead of
  ;; 'x86_64-unknown-linux-gnu'.
  (define normalised-system
    (string-replace-substring triplet "-unknown-" "-"))
  (define major.minor (version-major+minor (package-version python)))
  (define majorminor (string-delete #\. major.minor))
  (string-append
    ;; If guix' python package used "--with-pydebug", a #\d would
    ;; need to be added, likewise "--with-pymalloc" and "--with-wide-unicode"
    ;; would require a #\m and #\u, see cpython's configure.ac.
    ".cpython-" majorminor "-" normalised-system
    (if (target-mingw? triplet)
        ".dll"
        ".so")))

(define (correct-library-name-phase python name)
  "Return a G-exp evaluating to a phase renaming the python extension NAME
from what Meson thinks its name should be to what python expects its name
to be.  NAME must not include the platform-specific suffix.  This can only
be used when cross-compiling."
  #~(lambda _
      (define name #$name)
      (define native-suffix
        #$(python-extension-suffix python
                                   (nix-system->gnu-triplet (%current-system))))
      (define target-suffix
        #$(python-extension-suffix python (%current-target-system)))
      (define native-name
        (string-append name native-suffix))
      (define target-name
        (string-append name target-suffix))
      (rename-file native-name target-name)))

(define gobject-introspection
  (package
    (name "gobject-introspection")
    (version "1.66.1")
    (source (origin
             (method url-fetch)
             (uri (string-append "mirror://gnome/sources/"
                   "gobject-introspection/" (version-major+minor version)
                   "/gobject-introspection-" version ".tar.xz"))
             (sha256
              (base32 "078n0q7b6z682mf4irclrksm73cyixq295mqnqifl9plwmgaai6x"))
             (patches (search-patches
                       "gobject-introspection-cc.patch"
                       "gobject-introspection-girepository.patch"
                       "gobject-introspection-absolute-shlib-path.patch"))))
    (build-system meson-build-system)
    (arguments
     `(,@(if (%current-target-system)
             `(#:configure-flags
               '("-Dgi_cross_use_prebuilt_gi=true"
                 ;; Building introspection data requires running binaries
                 ;; for ‘host’ on ‘build’, so don't do that.
                 ;;
                 ;; TODO: it would be nice to have introspection data anyways
                 ;; as discussed here: https://issues.guix.gnu.org/50201#60.
                 "-Dbuild_introspection_data=false"))
             '())
       #:phases
       ,#~
       (modify-phases %standard-phases
         #$@(if (%current-target-system)
                ;; 'typelibs' is undefined.
                `((add-after 'unpack 'set-typelibs
                    (lambda _
                      (substitute* "meson.build"
		;			    (("python3") "python")
                        (("\\bsources: typelibs\\b")
                         "sources: []")))))
                '())
         (add-after 'unpack 'do-not-use-/usr/bin/env
           (lambda _
             (substitute* "tools/g-ir-tool-template.in"
               (("#!@PYTHON_CMD@")
                (string-append "#!" #$(this-package-input "python")
				"/bin/python3")))))
         #$@(if (%current-target-system)
               ;; Meson gives python extensions an incorrect name, see
               ;; <https://github.com/mesonbuild/meson/issues/7049>.
                #~((add-after 'install 'rename-library
                     #$(correct-library-name-phase
                         (this-package-input "python")
                         #~(string-append #$output
                                          "/lib/gobject-introspection/giscanner"
                                          "/_giscanner"))))
                #~()))))
	(native-inputs
     (list `(,glib "bin")
       pkg-config
       bison
       flex))
    (inputs
     (list ;,@(if (%current-target-system)
             python
             bison
             flex
       zlib))
    (propagated-inputs
     (list glib
           ;; In practice, GIR users will need libffi when using
           ;; gobject-introspection.
           libffi))
    (native-search-paths
     (list
      (search-path-specification
       (variable "GI_TYPELIB_PATH")
       (files '("lib/girepository-1.0")))))
    (search-paths native-search-paths)
    (synopsis "GObject introspection tools and libraries")
    (description "GObject introspection is a middleware layer between
C libraries (using GObject) and language bindings.  The C library can be scanned
at compile time and generate metadata files, in addition to the actual native
C library.  Then language bindings can read this metadata and automatically
provide bindings to call into the C library.")
    (home-page "https://wiki.gnome.org/Projects/GObjectIntrospection")
    (license
     (list
      ;; For library.
      license:lgpl2.0+
      ;; For tools.
      license:gpl2+))))
;; Fails to cross-compile - rewrite using gexp
(define-public slock
  (package
    (name "slock")
    (version "1.4")
    (source (origin
              (method url-fetch)
              (uri (string-append "https://dl.suckless.org/tools/slock-"
                                  version ".tar.gz"))
              (sha256
               (base32
                "0sif752303dg33f14k6pgwq2jp1hjyhqv6x4sy3sj281qvdljf5m"))))
    (build-system gnu-build-system)
    (arguments
     (list #:tests? #f                      ; no tests
       #:make-flags
       #~(list (string-append "CC=" #$(cc-for-target))
             (string-append "PREFIX=" #$output))
       #:phases #~(modify-phases %standard-phases (delete 'configure))))
    (inputs
     (list libx11 libxext libxinerama libxrandr))
    (home-page "https://tools.suckless.org/slock/")
    (synopsis "Simple X session lock")
    (description
     "Simple X session lock with trivial feedback on password entry.")
    (license license:x11)))

(define quartz64a-desktop-os
  (operating-system
    (host-name "quartz64a")
    (timezone "Europe/Prague")
    (locale "en_US.utf8")

    (bootloader (bootloader-configuration
                 (bootloader u-boot-quartz64a-rk3566-bootloader)
                 (targets '("/dev/vda"))))
    (initrd-modules '())
    (kernel linux-quartz64)
    (file-systems (append (list
	                      (file-system
                          (device (file-system-label "EFI"))
                          (mount-point "/boot/efi")
                          (type "vfat"))
                          (file-system
                          (device (file-system-label "root"))
                          (mount-point "/")
                          (type "ext4")))
                        %base-file-systems))

    (swap-devices (list (swap-space
                         (target "/run/swapfile"))))

    (users (cons* (user-account
                   (name "pine")
                   (group "users")
                   (supplementary-groups '("wheel" "netdev" "audio" "video"))
				   (password (crypt "quartz64" "$6$abc"))
                   (home-directory "/home/pine"))
                  %base-user-accounts))

  ;; Add GNOME desktop
  (services 
                (append (list (service mate-desktop-service-type)
                              (service xfce-desktop-service-type)
                              (service openssh-service-type)
                              (service agetty-service-type
                               (agetty-configuration
                                (extra-options '("-L")) ; no carrier detect
                                (baud-rate "1500000")
                                (term "vt100")
                                (tty "ttyS2"))))
                        %desktop-services))

    (packages (cons* nss-certs
                     openssh
                     gvfs
                     %base-packages))

    (name-service-switch %mdns-host-lookup-nss)))

(define quartz64-image-type
  (image-type
   (name 'quartz-raw)
   (constructor (lambda (os)
                  (image
				   (inherit
                     (raw-with-offset-disk-image (* 32 (expt 2 20)))) ; 32MiB
                   (operating-system os)
                   (platform aarch64-linux))))))

(define quartz64-desktop-raw-image
  (image
   (inherit
    (os+platform->image quartz64a-desktop-os aarch64-linux
                        #:type quartz64-image-type))
   (name 'quartz-desktop-raw-image)))

;; Return the default image.
quartz64-desktop-raw-image