;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2015, 2017 David Thompson ;;; Copyright © 2014 Mark H Weaver ;;; Copyright © 2015, 2017 Sou Bunnbu ;;; Copyright © 2015 Alex Kost ;;; Copyright © 2016, 2017 Efraim Flashner ;;; Copyright © 2017, 2018, 2019 Rutger Helling ;;; Copyright © 2018, 2019 Tobias Geerinckx-Rice ;;; Copyright © 2018 Ricardo Wurmus ;;; Copyright © 2019 Kei Kebreau ;;; ;;; 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 WAR
aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Sou Bunnbu <iyzsong@gmail.com>
;;; Copyright © 2016, 2017, 2018, 2020, 2022, 2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017 Huang Ying <huang.ying.caritas@gmail.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 (gnu services dict)
  #:use-module (guix deprecation)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (guix modules)
  #:use-module (guix least-authority)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system shadow)
  #:use-module ((gnu packages admin) #:select (shadow))
  #:use-module (gnu packages dico)
  #:use-module (gnu packages dictionaries)
  #:autoload   (gnu build linux-container) (%namespaces)
  #:autoload   (gnu system file-systems) (file-system-mapping)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:export (dicod-service  ; deprecated
            dicod-service-type
            dicod-configuration
            dicod-handler
            dicod-database
            %dicod-database:gcide))


;;;
;;; GNU Dico.
;;;

(define-record-type* <dicod-configuration>
  dicod-configuration make-dicod-configuration
  dicod-configuration?
  (dico        dicod-configuration-dico       (default dico))
  (interfaces  dicod-configuration-interfaces     ;list of strings
               (default '("localhost")))
  (handlers    dicod-configuration-handlers       ;list of <dicod-handler>
               (default '()))
  (databases   dicod-configuration-databases      ;list of <dicod-database>
               (default (list %dicod-database:gcide)))
  (home-service? dicod-configuration-home-service? ;boolean
                 (default for-home?) (innate)))

(define-record-type* <dicod-handler>
  dicod-handler make-dicod-handler
  dicod-handler?
  (name        dicod-handler-name)
  (module      dicod-handler-module          (default #f))
  (options     dicod-handler-options         (default '())))

(define-record-type* <dicod-database>
  dicod-database make-dicod-database
  dicod-database?
  (name        dicod-database-name)
  (handler     dicod-database-handler)
  (complex?    dicod-database-complex?       (default #f))
  (options     dicod-database-options        (default '())))

(define %dicod-gcide-index
  ;; The GCIDE pre-built index.  The Dico 'gcide' module can build it lazily;
  ;; do it upfront so there's no need for a writable directory at run-time.
  (computed-file "dicod-gcide-index"
                 (with-imported-modules '((guix build utils))
                   #~(begin
                       (use-modules (guix build utils))
                       (mkdir #$output)
                       (invoke #+(file-append dico "/libexec/idxgcide")
                               #+(file-append gcide "/share/gcide")
                               #$output)))))

(define %dicod-database:gcide
  (dicod-database
   (name "gcide")
   (handler "gcide")
   (options (list #~(string-append "dbdir=" #$gcide "/share/gcide")
                  #~(string-append "idxdir=" #$%dicod-gcide-index)))))

(define %dicod-accounts
  (list (user-group
         (name "dicod")
         (system? #t))
        (user-account
         (name "dicod")
         (group "dicod")
         (system? #t)
         (home-directory "/var/empty")
         (shell (file-append shadow "/sbin/nologin")))))

(define (dicod-configuration-file config)
  (define handler->text
    (match-lambda
      (($ <dicod-handler> name #f '())
       `("
load-module " ,name ";"))
      (($ <dicod-handler> name #f options)
       (handler->text (dicod-handler
                       (name name)
                       (module name)
                       (options options))))
      (($ <dicod-handler> name module options)
       `("
load-module " ,name " {
   command \"" ,module (string-join (list ,@options) " " 'prefix) "\";
}\n"))))

  (define database->text
    (match-lambda
      (($ <dicod-database> name handler #f options)
       (append
        (handler->text (dicod-handler
                        (name handler)))
        (database->text (dicod-database
                         (name name)
                         (handler handler)
                         (complex? #t)
                         (options options)))))
      (($ <dicod-database> name handler complex? options)
       `("
database {
   name \"" ,name "\";
   handler \"" ,handler
   (string-join (list ,@options) " " 'prefix) "\";
}\n"))))

  (define configuration->text
    (match-lambda
      (($ <dicod-configuration> dico (interfaces ...) handlers databases)
       (append `("listen ("
                 ,(string-join interfaces ", ") ");\n")
               (append-map handler->text handlers)
               (append-map database->text databases)))))

  (apply mixed-text-file "dicod.conf" (configuration->text config)))

(define (dicod-shepherd-service config)
  (let* ((dicod.conf (dicod-configuration-file config))
         (interfaces (dicod-configuration-interfaces config))
         (home-service? (dicod-configuration-home-service? config))
         (mappings  `(,@(if home-service?
                            '()
                            (list (file-system-mapping
                                   (source "/dev/log")
                                   (target source))))
                      ,(file-system-mapping
                        (source dicod.conf)
                        (target source))))
         (dicod      (least-authority-wrapper
                      (file-append (dicod-configuration-dico config)
                                   "/bin/dicod")
                      #:name "dicod"
                      #:mappings mappings
                      #:namespaces (delq 'net %namespaces))))
    (list (shepherd-service
           (provision '(dicod))
           (requirement (if home-service?
                            '()
                            '(user-processes)))
           (documentation "Run the dicod daemon.")
           (start #~(make-inetd-constructor
                     (list #$dicod "--inetd" "--foreground"
                           (string-append "--config=" #$dicod.conf))
                     (map (lambda (interface)
                            (endpoint
                             (addrinfo:addr
                              (car (getaddrinfo interface "dict")))))
                          '#$interfaces)
                     #:requirements '#$requirement
                     #:user #$(and (not home-service?) "dicod")
                     #:group #$(and (not home-service?) "dicod")
                     #:service-name-stem "dicod"))
           (stop #~(make-inetd-destructor))
           (actions (list (shepherd-configuration-action dicod.conf)))))))

(define dicod-service-type
  (service-type
   (name 'dict)
   (extensions
    (list (service-extension account-service-type
                             (const %dicod-accounts))
          (service-extension shepherd-root-service-type
                             dicod-shepherd-service)))
   (default-value (dicod-configuration))
   (description
    "Run @command{dicod}, the dictionary server of
@uref{https://www.gnu.org/software/dico, GNU Dico}.  @command{dicod}
implements the standard DICT protocol supported by clients such as
@command{dico} and GNOME Dictionary.")))

(define-deprecated (dicod-service #:key (config (dicod-configuration)))
  dicod-service-type
  "Return a service that runs the @command{dicod} daemon, an implementation
of DICT server (@pxref{Dicod,,, dico, GNU Dico Manual}).

The optional @var{config} argument specifies the configuration for
@command{dicod}, which should be a @code{<dicod-configuration>} object, by
default it serves the GNU Collaborative International Dictionary of English.

You can add @command{open localhost} to your @file{~/.dico} file to make
@code{localhost} the default server for @command{dico}
client (@pxref{Initialization File,,, dico, GNU Dico Manual})."
  (service dicod-service-type config))
generated by cgit
"debug")) (synopsis "SDL networking library") (description "SDL_net is a small, cross-platform networking library for SDL.") (home-page "https://www.libsdl.org/projects/SDL_net/") (license zlib))) (define-public sdl-ttf (package (name "sdl-ttf") (version "2.0.11") (source (origin (method url-fetch) (uri (string-append "https://www.libsdl.org/projects/SDL_ttf/release/SDL_ttf-" version ".tar.gz")) (sha256 (base32 "1dydxd4f5kb1288i5n5568kdk2q7f8mqjr7i7sd33nplxjaxhk3j")))) (build-system gnu-build-system) (propagated-inputs `(("sdl" ,sdl))) (inputs `(("freetype" ,freetype) ("mesa" ,mesa))) (native-inputs `(("pkg-config" ,pkg-config))) (outputs '("out" "debug")) (synopsis "SDL TrueType font library") (description "SDL_ttf is a TrueType font rendering library for SDL.") (home-page "https://www.libsdl.org/projects/SDL_ttf/") (license zlib))) (define* (sdl-union #:optional (packages (list sdl sdl-gfx sdl-net sdl-ttf sdl-image sdl-mixer))) "Return 'sdl-union' package which is a union of PACKAGES. If PACKAGES are not specified, all SDL packages are used." (package (name "sdl-union") (version (package-version sdl)) (source #f) (build-system trivial-build-system) (arguments '(#:modules ((guix build union)) #:builder (begin (use-modules (ice-9 match) (guix build union)) (match %build-inputs (((names . directories) ...) (union-build (assoc-ref %outputs "out") directories) #t))))) (inputs (map (lambda (package) (list (package-name package) package)) packages)) (synopsis "Union of SDL libraries") (description "A union of SDL and its extension libraries. A union is required because sdl-config assumes that all of the headers and libraries are in the same directory.") (home-page (package-home-page sdl)) (license (package-license sdl)))) (define (propagated-inputs-with-sdl2 package) "Replace the \"sdl\" propagated input of PACKAGE with SDL2." (map (match-lambda (("sdl" _) `("sdl2" ,sdl2)) (other other)) (package-propagated-inputs package))) (define-public sdl2-gfx (package (inherit sdl-gfx) (name "sdl2-gfx") (version "1.0.4") (source (origin (method url-fetch) (uri (string-append "https://www.ferzkopp.net/Software/SDL2_gfx/SDL2_gfx-" version ".tar.gz")) (sha256 (base32 "0qk2ax7f7grlxb13ba0ll3zlm8780s7j8fmrhlpxzjgdvldf1q33")))) (propagated-inputs (propagated-inputs-with-sdl2 sdl-gfx)))) (define-public sdl2-image (package (inherit sdl-image) (name "sdl2-image") (version "2.0.4") (source (origin (method url-fetch) (uri (string-append "https://www.libsdl.org/projects/SDL_image/release/" "SDL2_image-" version ".tar.gz")) (sha256 (base32 "1b6f7002bm007y3zpyxb5r6ag0lml51jyvx1pwpj9sq24jfc8kp7")))) (propagated-inputs (propagated-inputs-with-sdl2 sdl-image)))) (define-public sdl2-mixer (package (inherit sdl-mixer) (name "sdl2-mixer") (version "2.0.4") (source (origin (method url-fetch) (uri (string-append "http://www.libsdl.org/projects/SDL_mixer/release/" "SDL2_mixer-" version ".tar.gz")) (modules '((guix build utils))) (snippet '(begin ;; Remove bundled libraries. (delete-file-recursively "external") #t)) (sha256 (base32 "0694vsz5bjkcdgfdra6x9fq8vpzrl8m6q96gh58df7065hw5mkxl")))) (propagated-inputs (propagated-inputs-with-sdl2 sdl-mixer)))) (define-public sdl2-ttf (package (inherit sdl-ttf) (name "sdl2-ttf") (version "2.0.15") (source (origin (method url-fetch) (uri (string-append "https://www.libsdl.org/projects/SDL_ttf/release/SDL2_ttf-" version ".tar.gz")) (modules '((guix build utils))) (snippet (begin ;; Remove bundled libraries. '(delete-file-recursively "external") #t)) (sha256 (base32 "0cyd48dipc0m399qy8s03lci8b0bpiy8xlkvrm2ia7wcv0dfpv59")))) (propagated-inputs (propagated-inputs-with-sdl2 sdl-ttf)))) (define-public guile-sdl (package (name "guile-sdl") (version "0.5.2") (source (origin (method url-fetch) (uri (string-append "mirror://gnu/guile-sdl/guile-sdl-" version ".tar.xz")) (sha256 (base32 "0cjgs012a9922hn6xqwj66w6qmfs3nycnm56hyykx5n3g5p7ag01")))) (build-system gnu-build-system) (native-inputs `(("pkg-config" ,pkg-config) ;; Required by test suite. ("xorg-server" ,xorg-server) ("libjpeg" ,libjpeg))) (inputs `(("guile" ,guile-2.2) ("sdl-union" ,(sdl-union)))) (arguments '(#:configure-flags (list (string-append "--with-sdl-prefix=" (assoc-ref %build-inputs "sdl-union"))) #:modules ((ice-9 popen) (guix build utils) (guix build gnu-build-system)) #:parallel-build? #f ; parallel build fails #:phases (modify-phases %standard-phases (add-before 'configure 'fix-env-and-patch (lambda* (#:key inputs #:allow-other-keys) (setenv "GUILE_AUTO_COMPILE" "0") ;; SDL_image needs to dlopen libjpeg in the test suite. (setenv "LD_LIBRARY_PATH" (string-append (assoc-ref inputs "libjpeg") "/lib")) ;; Change the site directory /site/X.Y like Guile expects. (substitute* "build-aux/guile-baux/re-prefixed-site-dirs" (("\"/site\"") (let ((effective (read (open-pipe* OPEN_READ "guile" "-c" "(write (effective-version))")))) (string-append "\"/site/" effective "\"")))) ;; Skip tests that rely on sound support, which is unavailable in ;; the build environment. (substitute* "test/Makefile.in" (("HAVE_MIXER = .*$") "HAVE_MIXER = 0\n")) #t)) (add-before 'check 'start-xorg-server (lambda* (#:key inputs #:allow-other-keys) ;; The test suite requires a running X server. (system (format #f "~a/bin/Xvfb :1 &" (assoc-ref inputs "xorg-server"))) (setenv "DISPLAY" ":1") #t)) (add-before 'check 'skip-cursor-test (lambda _ ;; XXX: This test sometimes enters an endless loop, and sometimes ;; crashes with: ;; guile: xcb_io.c:147: append_pending_request: Assertion `!xcb_xlib_unknown_seq_number' failed. ;; Skip it. (substitute* "test/cursor.scm" (("\\(SDL:init .*" all) (string-append "(exit 77) ;" all "\n"))) #t))))) (synopsis "Guile interface for SDL (Simple DirectMedia Layer)") (description "Guile-SDL is a set of bindings to the Simple DirectMedia Layer (SDL). With them, Guile programmers can have easy access to graphics, sound and device input (keyboards, joysticks, mice, etc.).") (home-page "https://www.gnu.org/software/guile-sdl/") (license gpl3+))) (define-public guile-sdl2 (package (name "guile-sdl2") (version "0.3.1") (source (origin (method url-fetch) (uri (string-append "https://files.dthompson.us/guile-sdl2/guile-sdl2-" version ".tar.gz")) (sha256 (base32 "0bw7x2lx90k4banc5k7yfkn3as93y25gr1xdr225ll7lmij21k64")))) (build-system gnu-build-system) (arguments '(#:make-flags '("GUILE_AUTO_COMPILE=0") #:configure-flags (list (string-append "--with-libsdl2-prefix=" (assoc-ref %build-inputs "sdl2")) (string-append "--with-libsdl2-image-prefix=" (assoc-ref %build-inputs "sdl2-image")) (string-append "--with-libsdl2-ttf-prefix=" (assoc-ref %build-inputs "sdl2-ttf")) (string-append "--with-libsdl2-mixer-prefix=" (assoc-ref %build-inputs "sdl2-mixer"))))) (native-inputs `(("guile" ,guile-2.2) ("pkg-config" ,pkg-config))) (inputs `(("sdl2" ,sdl2) ("sdl2-image" ,sdl2-image) ("sdl2-mixer" ,sdl2-mixer) ("sdl2-ttf" ,sdl2-ttf))) (synopsis "Guile bindings for SDL2") (home-page "https://dthompson.us/projects/guile-sdl2.html") (description "Guile-SDL2 provides Guile Scheme bindings for the SDL2 C shared library. The bindings are written in pure Scheme using Guile's foreign function interface.") (license lgpl3+))) (define-public ghc-sdl2 (package (name "ghc-sdl2") (version "2.4.1.0") (source (origin (method url-fetch) (uri (string-append "https://hackage.haskell.org/package/" "sdl2/sdl2-" version ".tar.gz")) (sha256 (base32 "0p4b12fmxps0sbnkqdfy0qw19s355yrkw7fgw6xz53wzq706k991")))) (build-system haskell-build-system) (arguments '(#:tests? #f)) ; tests require graphical environment (inputs `(("ghc-exceptions" ,ghc-exceptions) ("ghc-linear" ,ghc-linear) ("ghc-statevar" ,ghc-statevar) ("ghc-text" ,ghc-text) ("ghc-vector" ,ghc-vector) ("sdl2" ,sdl2))) (native-inputs `(("ghc-weigh" ,ghc-weigh) ("pkg-config" ,pkg-config))) (home-page "http://hackage.haskell.org/package/sdl2") (synopsis "High- and low-level bindings to the SDL library") (description "This package contains bindings to the SDL 2 library, in both high- and low-level forms. The @code{SDL} namespace contains high-level bindings, where enumerations are split into sum types, and we perform automatic error-checking. The @code{SDL.Raw} namespace contains an almost 1-1 translation of the C API into Haskell FFI calls. As such, this does not contain sum types nor error checking. Thus this namespace is suitable for building your own abstraction over SDL, but is not recommended for day-to-day programming.") (license bsd-3))) (define-public ghc-sdl2-mixer (package (name "ghc-sdl2-mixer") (version "1.1.0") (source (origin (method url-fetch) (uri (string-append "https://hackage.haskell.org/package/sdl2-mixer/" "sdl2-mixer-" version ".tar.gz")) (sha256 (base32 "1k8avyccq5l9z7bwxigim312yaancxl1sr3q6a96bcm7pnhiak0g")))) (build-system haskell-build-system) (inputs `(("ghc-data-default-class" ,ghc-data-default-class) ("ghc-lifted-base" ,ghc-lifted-base) ("ghc-monad-control" ,ghc-monad-control) ("ghc-sdl2" ,ghc-sdl2) ("ghc-vector" ,ghc-vector) ("sdl2-mixer" ,sdl2-mixer))) (native-inputs `(("pkg-config" ,pkg-config))) (home-page "http://hackage.haskell.org/package/sdl2-mixer") (synopsis "Bindings to SDL2 mixer") (description "This package provides Haskell bindings to @code{SDL2_mixer}.") (license bsd-3))) (define-public ghc-sdl2-image (package (name "ghc-sdl2-image") (version "2.0.0") (source (origin (method url-fetch) (uri (string-append "https://hackage.haskell.org/package/sdl2-image/" "sdl2-image-" version ".tar.gz")) (sha256 (base32 "1pr6dkg73cy9z0w54lrkj9c5bhxj56nl92lxikjy8kz6nyr455rr")))) (build-system haskell-build-system) (inputs `(("ghc-sdl2" ,ghc-sdl2) ("ghc-text" ,ghc-text) ("sdl2-image" ,sdl2-image))) (native-inputs `(("pkg-config" ,pkg-config))) (home-page "http://hackage.haskell.org/package/sdl2-image") (synopsis "Bindings to SDL2_image") (description "This package provides Haskell bindings to @code{SDL2_image}.") (license expat)))