;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Simon South <simon@simonsouth.net>
;;;
;;; 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 file-sharing)
  #:use-module (gcrypt base16)
  #:use-module (gcrypt hash)
  #:use-module (gcrypt random)
  #:use-module (gnu services)
  #:use-module (gnu services admin)
  #:use-module (gnu services configuration)
  #:use-module (gnu services shepherd)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages bittorrent)
  #:use-module (gnu packages gnupg)
  #:use-module (gnu packages guile)
  #:use-module (gnu system shadow)
  #:use-module (guix diagnostics)
  #:use-module (guix gexp)
  #:use-module (guix i18n)
  #:use-module (guix modules)
  #:use-module (guix packages)
  #:use-module (guix records)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:export (transmission-daemon-configuration
            transmission-daemon-service-type
            transmission-password-hash
            transmission-random-salt))

;;;
;;; Transmission Daemon.
;;;

(define %transmission-daemon-user "transmission")
(define %transmission-daemon-group "transmission")

(define %transmission-daemon-configuration-directory
  "/var/lib/transmission-daemon")
(define %transmission-daemon-log-file
  "/var/log/transmission.log")

(define %transmission-salt-length 8)

(define (transmission-password-hash password salt)
  "Returns a string containing the result of hashing @var{password} together
with @var{salt}, in the format recognized by Transmission clients for their
@code{rpc-password} configuration setting.

@var{salt} must be an eight-character string.  The
@code{transmission-random-salt} procedure can be used to generate a suitable
salt value at random."
  (if (not (and (string? salt)
                (eq? (string-length salt) %transmission-salt-length)))
      (raise (formatted-message
              (G_ "salt value must be a string of ~d characters")
              %transmission-salt-length))
      (string-append "{"
                     (bytevector->base16-string
                      (sha1 (string->utf8 (string-append password salt))))
                     salt)))

(define (transmission-random-salt)
  "Returns a string containing a random, eight-character salt value of the
type generated and used by Transmission clients, suitable for passing to the
@code{transmission-password-hash} procedure."
  ;; This implementation matches a portion of Transmission's tr_ssha1
  ;; function.  See libtransmission/crypto-utils.c in the Transmission source
  ;; distribution.
  (let ((salter (string-append "0123456789"
                               "abcdefghijklmnopqrstuvwxyz"
                               "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
                               "./")))
    (list->string
     (map (lambda (u8)
            (string-ref salter (modulo u8 (string-length salter))))
          (bytevector->u8-list
           (gen-random-bv %transmission-salt-length %gcry-strong-random))))))

(define (uglify-field-name field-name)
  (string-delete #\? (symbol->string field-name)))

(define (serialize-field field-name val)
  ;; "Serialize" each configuration field as a G-expression containing a
  ;; name-value pair, the collection of which will subsequently be serialized
  ;; to disk as a JSON object.
  #~(#$(uglify-field-name field-name) . #$val))

(define serialize-boolean serialize-field)
(define serialize-integer serialize-field)
(define serialize-rational serialize-field)

(define serialize-string serialize-field)
(define-maybe string)
;; Override the definition of "serialize-maybe-string", as we need to output a
;; name-value pair for the JSON builder.
(set! serialize-maybe-string
  (lambda (field-name val)
    (serialize-string field-name
                      (if (eq? val 'unset)
                          ""
                          val))))

(define (string-list? val)
  (and (list? val)
       (and-map (lambda (x)
                  (and (string? x)
                       (not (string-index x #\,))))
                val)))
(define (serialize-string-list field-name val)
  (serialize-field field-name (string-join val ",")))

(define days
  '((sunday    . #b0000001)
    (monday    . #b0000010)
    (tuesday   . #b0000100)
    (wednesday . #b0001000)
    (thursday  . #b0010000)
    (friday    . #b0100000)
    (saturday  . #b1000000)))
(define day-lists
  (list (cons 'weekdays '(monday tuesday wednesday thursday friday))
        (cons 'weekends '(saturday sunday))
        (cons 'all (map car days))))
(define (day-list? val)
  (or (and (symbol? val)
           (assq val day-lists))
      (and (list? val)
           (and-map (lambda (x)
                      (and (symbol? x)
                           (assq x days)))
                    val))))
(define (serialize-day-list field-name val)
  (serialize-integer field-name
                     (reduce logior
                             #b0000000
                             (map (lambda (day)
                                    (assq-ref days day))
                                  (if (symbol? val)
                                      (assq-ref day-lists val)
                                      val)))))

(define encryption-modes
  '((prefer-unencrypted-connections . 0)
    (prefer-encrypted-connections   . 1)
    (require-encrypted-connections  . 2)))
(define (encryption-mode? val)
  (and (symbol? val)
       (assq val encryption-modes)))
(define (serialize-encryption-mode field-name val)
  (serialize-integer field-name (assq-ref encryption-modes val)))

(define serialize-file-like serialize-field)

(define (file-object? val)
  (or (string? val)
      (file-like? val)))
(define (serialize-file-object field-name val)
  (if (file-like? val)
      (serialize-file-like field-name val)
      (serialize-string field-name val)))
(define-maybe file-object)
(set! serialize-maybe-file-object
  (lambda (field-name val)
    (if (eq? val 'unset)
        (serialize-string field-name "")
        (serialize-file-object field-name val))))

(define (file-object-list? val)
  (and (list? val)
       (and-map file-object? val)))
(define serialize-file-object-list serialize-field)

(define message-levels
  '((none  . 0)
    (error . 1)
    (info  . 2)
    (debug . 3)))
(define (message-level? val)
  (and (symbol? val)
       (assq val message-levels)))
(define (serialize-message-level field-name val)
  (serialize-integer field-name (assq-ref message-levels val)))

(define (non-negative-integer? val)
  (and (integer? val)
       (not (negative? val))))
(define serialize-non-negative-integer serialize-integer)

(define (non-negative-rational? val)
  (and (rational? val)
       (not (negative? val))))
(define serialize-non-negative-rational serialize-rational)

(define (port-number? val)
  (and (integer? val)
       (>= val 1)
       (<= val 65535)))
(define serialize-port-number serialize-integer)

(define preallocation-modes
  '((none   . 0)
    (fast   . 1)
    (sparse . 1)
    (full   . 2)))
(define (preallocation-mode? val)
  (and (symbol? val)
       (assq val preallocation-modes)))
(define (serialize-preallocation-mode field-name val)
  (serialize-integer field-name (assq-ref preallocation-modes val)))

(define tcp-types-of-service
  '((default     . "default")
    (low-cost    . "lowcost")
    (throughput  . "throughput")
    (low-delay   . "lowdelay")
    (reliability . "reliability")))
(define (tcp-type-of-service? val)
  (and (symbol? val)
       (assq val tcp-types-of-service)))
(define (serialize-tcp-type-of-service field-name val)
  (serialize-string field-name (assq-ref tcp-types-of-service val)))

(define (transmission-password-hash? val)
  (and (string? val)
       (= (string-length val) 49)
       (eqv? (string-ref val 0) #\{)
       (string-every char-set:hex-digit val 1 41)))
(define serialize-transmission-password-hash serialize-string)
(define-maybe transmission-password-hash)
(set! serialize-maybe-transmission-password-hash serialize-maybe-string)

(define (umask? val)
  (and (integer? val)
       (>= val #o000)
       (<= val #o777)))
(define serialize-umask serialize-integer) ; must use decimal representation

(define-configuration transmission-daemon-configuration
  ;; Settings internal to this service definition.
  (transmission
   (file-like transmission)
   "The Transmission package to use.")
  (stop-wait-period
   (non-negative-integer 10)
   "The period, in seconds, to wait when stopping the service for
@command{transmission-daemon} to exit before killing its process.  This allows
the daemon time to complete its housekeeping and send a final update to
trackers as it shuts down.  On slow hosts, or hosts with a slow network
connection, this value may need to be increased.")

  ;; Files and directories.
  (download-dir
   (string (string-append %transmission-daemon-configuration-directory
                          "/downloads"))
   "The directory to which torrent files are downloaded.")
  (incomplete-dir-enabled?
   (boolean #f)
   "If @code{#t}, files will be held in @code{incomplete-dir} while their
torrent is being downloaded, then moved to @code{download-dir} once the
torrent is complete.  Otherwise, files for all torrents (including those still
being downloaded) will be placed in @code{download-dir}.")
  (incomplete-dir
   maybe-string
   "The directory in which files from incompletely downloaded torrents will be
held when @code{incomplete-dir-enabled?} is @code{#t}.")
  (umask
   (umask #o022)
   "The file mode creation mask used for downloaded files.  (See the
@command{umask} man page for more information.)")
  (rename-partial-files?
   (boolean #t)
   "When @code{#t}, ``.part'' is appended to the name of partially downloaded
files.")
  (preallocation
   (preallocation-mode 'fast)
   "The mode by which space should be preallocated for downloaded files, one
of @code{none}, @code{fast} (or @code{sparse}) and @code{full}.  Specifying
@code{full} will minimize disk fragmentation at a cost to file-creation
speed.")
  (watch-dir-enabled?
   (boolean #f)
   "If @code{#t}, the directory specified by @code{watch-dir} will be watched
for new @file{.torrent} files and the torrents they describe added
automatically (and the original files removed, if
@code{trash-original-torrent-files?} is @code{#t}).")
  (watch-dir
   maybe-string
   "The directory to be watched for @file{.torrent} files indicating new
torrents to be added, when @code{watch-dir-enabled} is @code{#t}.")
  (trash-original-torrent-files?
   (boolean #f)
   "When @code{#t}, @file{.torrent} files will be deleted from the watch
directory once their torrent has been added (see
@code{watch-directory-enabled?}).")

  ;; Bandwidth limits.
  (speed-limit-down-enabled?
   (boolean #f)
   "When @code{#t}, the daemon's download speed will be limited to the rate
specified by @code{speed-limit-down}.")
  (speed-limit-down
   (non-negative-integer 100)
   "The default global-maximum download speed, in kilobytes per second.")
  (speed-limit-up-enabled?
   (boolean #f)
   "When @code{#t}, the daemon's upload speed will be limited to the rate
specified by @code{speed-limit-up}.")
  (speed-limit-up
   (non-negative-integer 100)
   "The default global-maximum upload speed, in kilobytes per second.")
  (alt-speed-enabled?
   (boolean #f)
   "When @code{#t}, the alternate speed limits @code{alt-speed-down} and
@code{alt-speed-up} are used (in place of @code{speed-limit-down} and
@code{speed-limit-up}, if they are enabled) to constrain the daemon's
bandwidth usage.  This can be scheduled to occur automatically at certain
times during the week; see @code{alt-speed-time-enabled?}.")
  (alt-speed-down
   (non-negative-integer 50)
   "The alternate global-maximum download speed, in kilobytes per second.")
  (alt-speed-up
   (non-negative-integer 50)
   "The alternate global-maximum upload speed, in kilobytes per second.")

  ;; Bandwidth-limit scheduling.
  (alt-speed-time-enabled?
   (boolean #f)
   "When @code{#t}, the alternate speed limits @code{alt-speed-down} and
@code{alt-speed-up} will be enabled automatically during the periods specified
by @code{alt-speed-time-day}, @code{alt-speed-time-begin} and
@code{alt-time-speed-end}.")
  (alt-speed-time-day
   (day-list 'all)
   "The days of the week on which the alternate-speed schedule should be used,
specified either as a list of days (@code{sunday}, @code{monday}, and so on)
or using one of the symbols @code{weekdays}, @code{weekends} or @code{all}.")
  (alt-speed-time-begin
   (non-negative-integer 540)
   "The time of day at which to enable the alternate speed limits,
expressed as a number of minutes since midnight.")
  (alt-speed-time-end
   (non-negative-integer 1020)
   "The time of day at which to disable the alternate speed limits,
expressed as a number of minutes since midnight.")

  ;; Peer networking.
  (bind-address-ipv4
   (string "0.0.0.0")
   "The IP address at which to listen for peer connections, or ``0.0.0.0'' to
listen at all available IP addresses.")
  (bind-address-ipv6
   (string "::")
   "The IPv6 address at which to listen for peer connections, or ``::'' to
listen at all available IPv6 addresses.")
  (peer-port-random-on-start?
   (boolean #f)
   "If @code{#t}, when the daemon starts it will select a port at random on
which to listen for peer connections, from the range specified (inclusively)
by @code{peer-port-random-low} and @code{peer-port-random-high}.  Otherwise,
it listens on the port specified by @code{peer-port}.")
  (peer-port-random-low
   (port-number 49152)
   "The lowest selectable port number when @code{peer-port-random-on-start?}
is @code{#t}.")
  (peer-port-random-high
   (port-number 65535)
   "The highest selectable port number when @code{peer-port-random-on-start}
is @code{#t}.")
  (peer-port
   (port-number 51413)
   "The port on which to listen for peer connections when
@code{peer-port-random-on-start?} is @code{#f}.")
  (port-forwarding-enabled?
   (boolean #t)
   "If @code{#t}, the daemon will attempt to configure port-forwarding on an
upstream gateway automatically using @acronym{UPnP} and @acronym{NAT-PMP}.")
  (encryption
   (encryption-mode 'prefer-encrypted-connections)
   "The encryption preference for peer connections, one of
@code{prefer-unencrypted-connections}, @code{prefer-encrypted-connections} or
@code{require-encrypted-connections}.")
  (peer-congestion-algorithm
   maybe-string
   "The TCP congestion-control algorithm to use for peer connections,
specified using a string recognized by the operating system in calls to
@code{setsockopt} (or leave it unset, in which case the operating-system
default is used).

Note that on GNU/Linux systems, the kernel must be configured to allow
processes to use a congestion-control algorithm not in the default set;
otherwise, it will deny these requests with ``Operation not permitted''.  To
see which algorithms are available on your system and which are currently
permitted for use, look at the contents of the files
@file{tcp_available_congestion_control} and
@file{tcp_allowed_congestion_control} in the @file{/proc/sys/net/ipv4}
directory.

As an example, to have Transmission Daemon use
@uref{http://www-ece.rice.edu/networks/TCP-LP/, the TCP Low Priority
congestion-control algorithm}, you'll need to modify your kernel configuration
to build in support for the algorithm, then update your operating-system
configuration to allow its use by adding a @code{sysctl-service-type}
service (or updating the existing one's configuration) with lines like the
following:

@lisp
(service sysctl-service-type
         (sysctl-configuration
          (settings
           (\"net.ipv4.tcp_allowed_congestion_control\" .
            \"reno cubic lp\"))))
@end lisp

The Transmission Daemon configuration can then be updated with

@lisp
(peer-congestion-algorithm \"lp\")
@end lisp

and the system reconfigured to have the changes take effect.")
  (peer-socket-tos
   (tcp-type-of-service 'default)
   "The type of service to request in outgoing @acronym{TCP} packets,
one of @code{default}, @code{low-cost}, @code{throughput}, @code{low-delay}
and @code{reliability}.")
  (peer-limit-global
   (non-negative-integer 200)
   "The global limit on the number of connected peers.")
  (peer-limit-per-torrent
   (non-negative-integer 50)
   "The per-torrent limit on the number of connected peers.")
  (upload-slots-per-torrent
   (non-negative-integer 14)
   "The maximum number of peers to which the daemon will upload data
simultaneously for each torrent.")
  (peer-id-ttl-hours
   (non-negative-integer 6)
   "The maximum lifespan, in hours, of the peer ID associated with each public
torrent before it is regenerated.")

  ;; Peer blocklists.
  (blocklist-enabled?
   (boolean #f)
   "When @code{#t}, the daemon will ignore peers mentioned in the blocklist it
has most recently downloaded from @code{blocklist-url}.")
  (blocklist-url
   maybe-string
   "The URL of a peer blocklist (in @acronym{P2P}-plaintext or eMule
@file{.dat} format) to be periodically downloaded and applied when
@code{blocklist-enabled?} is @code{#t}.")

  ;; Queueing.
  (download-queue-enabled?
   (boolean #t)
   "If @code{#t}, the daemon will be limited to downloading at most
@code{download-queue-size} non-stalled torrents simultaneously.")
  (download-queue-size
   (non-negative-integer 5)
   "The size of the daemon's download queue, which limits the number of
non-stalled torrents it will download at any one time when
@code{download-queue-enabled?} is @code{#t}.")
  (seed-queue-enabled?
   (boolean #f)
   "If @code{#t}, the daemon will be limited to seeding at most
@code{seed-queue-size} non-stalled torrents simultaneously.")
  (seed-queue-size
   (non-negative-integer 10)
   "The size of the daemon's seed queue, which limits the number of
non-stalled torrents it will seed at any one time when
@code{seed-queue-enabled?} is @code{#t}.")
  (queue-stalled-enabled?
   (boolean #t)
   "When @code{#t}, the daemon will consider torrents for which it has not
shared data in the past @code{queue-stalled-minutes} minutes to be stalled and
not count them against its @code{download-queue-size} and
@code{seed-queue-size} limits.")
  (queue-stalled-minutes
   (non-negative-integer 30)
   "The maximum period, in minutes, a torrent may be idle before it is
considered to be stalled, when @code{queue-stalled-enabled?} is @code{#t}.")

  ;; Seeding limits.
  (ratio-limit-enabled?
   (boolean #f)
   "When @code{#t}, a torrent being seeded will automatically be paused once
it reaches the ratio specified by @code{ratio-limit}.")
  (ratio-limit
   (non-negative-rational 2.0)
   "The ratio at which a torrent being seeded will be paused, when
@code{ratio-limit-enabled?} is @code{#t}.")
  (idle-seeding-limit-enabled?
   (boolean #f)
   "When @code{#t}, a torrent being seeded will automatically be paused once
it has been idle for @code{idle-seeding-limit} minutes.")
  (idle-seeding-limit
   (non-negative-integer 30)
   "The maximum period, in minutes, a torrent being seeded may be idle before
it is paused, when @code{idle-seeding-limit-enabled?} is @code{#t}.")

  ;; BitTorrent extensions.
  (dht-enabled?
   (boolean #t)
   "Enable @uref{http://bittorrent.org/beps/bep_0005.html, the distributed
hash table (@acronym{DHT}) protocol}, which supports the use of trackerless
torrents.")
  (lpd-enabled?
   (boolean #f)
   "Enable @url{https://en.wikipedia.org/wiki/Local_Peer_Discovery, local peer
discovery} (@acronym{LPD}), which allows the discovery of peers on the local
network and may reduce the amount of data sent over the public Internet.")
  (pex-enabled?
   (boolean #t)
   "Enable @url{https://en.wikipedia.org/wiki/Peer_exchange, peer
exchange} (@acronym{PEX}), which reduces the daemon's reliance on external
trackers and may improve its performance.")
  (utp-enabled?
   (boolean #t)
   "Enable @url{http://bittorrent.org/beps/bep_0029.html, the micro transport
protocol} (@acronym{uTP}), which aims to reduce the impact of BitTorrent
traffic on other users of the local network while maintaining full utilization
of the available bandwidth.")

  ;; Remote procedure call (RPC) interface.
  (rpc-enabled?
   (boolean #t)
   "If @code{#t}, enable the remote procedure call (@acronym{RPC}) interface,
which allows remote control of the daemon via its Web interface, the
@command{transmission-remote} command-line client, and similar tools.")
  (rpc-bind-address
   (string "0.0.0.0")
   "The IP address at which to listen for @acronym{RPC} connections, or
``0.0.0.0'' to listen at all available IP addresses.")
  (rpc-port
   (port-number 9091)
   "The port on which to listen for @acronym{RPC} connections.")
  (rpc-url
   (string "/transmission/")
   "The path prefix to use in the @acronym{RPC}-endpoint @acronym{URL}.")
  (rpc-authentication-required?
   (boolean #f)
   "When @code{#t}, clients must authenticate (see @code{rpc-username} and
@code{rpc-password}) when using the @acronym{RPC} interface.  Note this has
the side effect of disabling host-name whitelisting (see
@code{rpc-host-whitelist-enabled?}.")
  (rpc-username
   maybe-string
   "The username required by clients to access the @acronym{RPC} interface
when @code{rpc-authentication-required?} is @code{#t}.")
  (rpc-password
   maybe-transmission-password-hash
   "The password required by clients to access the @acronym{RPC} interface
when @code{rpc-authentication-required?} is @code{#t}.  This must be specified
using a password hash in the format recognized by Transmission clients, either
copied from an existing @file{settings.json} file or generated using the
@code{transmission-password-hash} procedure.")
  (rpc-whitelist-enabled?
   (boolean #t)
   "When @code{#t}, @acronym{RPC} requests will be accepted only when they
originate from an address specified in @code{rpc-whitelist}.")
  (rpc-whitelist
   (string-list '("127.0.0.1" "::1"))
   "The list of IP and IPv6 addresses from which @acronym{RPC} requests will
be accepted when @code{rpc-whitelist-enabled?} is @code{#t}.  Wildcards may be
specified using @samp{*}.")
  (rpc-host-whitelist-enabled?
   (boolean #t)
   "When @code{#t}, @acronym{RPC} requests will be accepted only when they are
addressed to a host named in @code{rpc-host-whitelist}.  Note that requests to
``localhost'' or ``localhost.'', or to a numeric address, are always accepted
regardless of these settings.

Note also this functionality is disabled when
@code{rpc-authentication-required?} is @code{#t}.")
  (rpc-host-whitelist
   (string-list '())
   "The list of host names recognized by the @acronym{RPC} server when
@code{rpc-host-whitelist-enabled?} is @code{#t}.")

  ;; Miscellaneous.
  (message-level
   (message-level 'info)
   "The minimum severity level of messages to be logged (to
@file{/var/log/transmission.log}) by the daemon, one of @code{none} (no
logging), @code{error}, @code{info} and @code{debug}.")
  (start-added-torrents?
   (boolean #t)
   "When @code{#t}, torrents are started as soon as they are added; otherwise,
they are added in ``paused'' state.")
  (script-torrent-done-enabled?
   (boolean #f)
   "When @code{#t}, the script specified by
@code{script-torrent-done-filename} will be invoked each time a torrent
completes.")
  (script-torrent-done-filename
   maybe-file-object
   "A file name or file-like object specifying a script to run each time a
torrent completes, when @code{script-torrent-done-enabled?} is @code{#t}.")
  (scrape-paused-torrents-enabled?
   (boolean #t)
   "When @code{#t}, the daemon will scrape trackers for a torrent even when
the torrent is paused.")
  (cache-size-mb
   (non-negative-integer 4)
   "The amount of memory, in megabytes, to allocate for the daemon's in-memory
cache.  A larger value may increase performance by reducing the frequency of
disk I/O.")
  (prefetch-enabled?
   (boolean #t)
   "When @code{#t}, the daemon will try to improve I/O performance by hinting
to the operating system which data is likely to be read next from disk to
satisfy requests from peers."))

(define (transmission-daemon-shepherd-service config)
  "Return a <shepherd-service> for Transmission Daemon with CONFIG."
  (let ((transmission
         (transmission-daemon-configuration-transmission config))
        (stop-wait-period
         (transmission-daemon-configuration-stop-wait-period config)))
    (list
     (shepherd-service
      (provision '(transmission-daemon transmission bittorrent))
      (requirement '(networking))
      (documentation "Share files using the BitTorrent protocol.")
      (start #~(make-forkexec-constructor
                '(#$(file-append transmission "/bin/transmission-daemon")
                  "--config-dir"
                  #$%transmission-daemon-configuration-directory
                  "--foreground")
                #:user #$%transmission-daemon-user
                #:group #$%transmission-daemon-group
                #:directory #$%transmission-daemon-configuration-directory
                #:log-file #$%transmission-daemon-log-file
                #:environment-variables
                '("CURL_CA_BUNDLE=/etc/ssl/certs/ca-certificates.crt")))
      (stop #~(lambda (pid)
                (kill pid SIGTERM)

                ;; Transmission Daemon normally needs some time to shut down,
                ;; as it will complete some housekeeping and send a final
                ;; update to trackers before it exits.
                ;;
                ;; Wait a reasonable period for it to stop before continuing.
                ;; If we don't do this, restarting the service can fail as the
                ;; new daemon process finds the old one still running and
                ;; attached to the port used for peer connections.
                (let wait-before-killing ((period #$stop-wait-period))
                  (if (zero? (car (waitpid pid WNOHANG)))
                      (if (positive? period)
                          (begin
                            (sleep 1)
                            (wait-before-killing (- period 1)))
                          (begin
                            (format #t
                                    #$(G_ "Wait period expired; killing \
transmission-daemon (pid ~a).~%")
                                    pid)
                            (display #$(G_ "(If you see this message \
regularly, you may need to increase the value
of 'stop-wait-period' in the service configuration.)\n"))
                            (kill pid SIGKILL)))))
                #f))
      (actions
       (list
        (shepherd-action
         (name 'reload)
         (documentation "Reload the settings file from disk.")
         (procedure #~(lambda (pid)
                        (if pid
                            (begin
                              (kill pid SIGHUP)
                              (display #$(G_ "Service transmission-daemon has \
been asked to reload its settings file.")))
                            (display #$(G_ "Service transmission-daemon is not \
running."))))))))))))

(define %transmission-daemon-accounts
  (list (user-group
         (name %transmission-daemon-group)
         (system? #t))
        (user-account
         (name %transmission-daemon-user)
         (group %transmission-daemon-group)
         (comment "Transmission Daemon service account")
         (home-directory %transmission-daemon-configuration-directory)
         (shell (file-append shadow "/sbin/nologin"))
         (system? #t))))

(define %transmission-daemon-log-rotations
  (list (log-rotation
         (files (list %transmission-daemon-log-file)))))

(define (transmission-daemon-computed-settings-file config)
  "Return a @code{computed-file} object that, when unquoted in a G-expression,
produces a Transmission settings file (@file{settings.json}) matching CONFIG."
  (let ((settings
         ;; "Serialize" the configuration settings as a list of G-expressions
         ;; containing a name-value pair, which will ultimately be sorted and
         ;; serialized to the settings file as a JSON object.
         (map
          (lambda (field)
            ((configuration-field-serializer field)
             (configuration-field-name field)
             ((configuration-field-getter field) config)))
          (filter
           (lambda (field)
             ;; Omit configuration fields that are used only internally by
             ;; this service definition.
             (not (memq (configuration-field-name field)
                        '(transmission stop-wait-period))))
           transmission-daemon-configuration-fields))))
    (computed-file
     "settings.json"
     (with-extensions (list guile-gcrypt guile-json-4)
       (with-imported-modules (source-module-closure '((json builder)))
         #~(begin
             (use-modules (json builder))

             (with-output-to-file #$output
               (lambda ()
                 (scm->json (sort-list '(#$@settings)
                                       (lambda (x y)
                                         (string<=? (car x) (car y))))
                            #:pretty #t)))))))))

(define (transmission-daemon-activation config)
  "Return the Transmission Daemon activation GEXP for CONFIG."
  (let ((config-dir %transmission-daemon-configuration-directory)
        (incomplete-dir-enabled
         (transmission-daemon-configuration-incomplete-dir-enabled? config))
        (incomplete-dir
         (transmission-daemon-configuration-incomplete-dir config))
        (watch-dir-enabled
         (transmission-daemon-configuration-watch-dir-enabled? config))
        (watch-dir
         (transmission-daemon-configuration-watch-dir config)))
    (with-imported-modules (source-module-closure '((guix build utils)))
      #~(begin
          (use-modules (guix build utils))

          (let ((owner (getpwnam #$%transmission-daemon-user)))
            (define (mkdir-p/perms directory perms)
              (mkdir-p directory)
              (chown directory (passwd:uid owner) (passwd:gid owner))
              (chmod directory perms))

            ;; Create the directories Transmission Daemon is configured to use
            ;; and assign them suitable permissions.
            (for-each (lambda (directory-specification)
                        (apply mkdir-p/perms directory-specification))
                      '(#$@(append
                            `((,config-dir #o750))
                            (if incomplete-dir-enabled
                                `((,incomplete-dir #o750))
                                '())
                            (if watch-dir-enabled
                                `((,watch-dir #o770))
                                '())))))

          ;; Generate and activate the daemon's settings file, settings.json.
          (activate-special-files
           '((#$(string-append config-dir "/settings.json")
              #$(transmission-daemon-computed-settings-file config))))))))

(define transmission-daemon-service-type
  (service-type
   (name 'transmission)
   (extensions
    (list (service-extension shepherd-root-service-type
                             transmission-daemon-shepherd-service)
          (service-extension account-service-type
                             (const %transmission-daemon-accounts))
          (service-extension rottlog-service-type
                             (const %transmission-daemon-log-rotations))
          (service-extension activation-service-type
                             transmission-daemon-activation)))
   (default-value (transmission-daemon-configuration))
   (description "Share files using the BitTorrent protocol.")))

(define (generate-transmission-daemon-documentation)
  (generate-documentation
   `((transmission-daemon-configuration
      ,transmission-daemon-configuration-fields))
   'transmission-daemon-configuration))