;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Mark H Weaver ;;; Copyright © 2015, 2016 Eric Bavier ;;; ;;; 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 . (define-module (gnu packages search) #:use-module ((guix licenses) #:select (gpl2 gpl2+ gpl3+ bsd-3 x11)) #:use-module (guix
aboutsummaryrefslogtreecommitdiff
;;; 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 (maybe-value 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 (maybe-value-set? val)
        (serialize-file-object field-name val)
        (serialize-string field-name ""))))

(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)))