guix/utils.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix utils)
  21   #:use-module (guix config)
  22   #:use-module (srfi srfi-1)
  23   #:use-module (srfi srfi-9)
  24   #:use-module (srfi srfi-26)
  25   #:use-module (srfi srfi-39)
  26   #:use-module (srfi srfi-60)
  27   #:use-module (rnrs bytevectors)
  28   #:use-module ((rnrs io ports) #:select (put-bytevector))
  29   #:use-module ((guix build utils) #:select (dump-port))
  30   #:use-module (ice-9 vlist)
  31   #:use-module (ice-9 format)
  32   #:autoload   (ice-9 popen)  (open-pipe*)
  33   #:autoload   (ice-9 rdelim) (read-line)
  34   #:use-module (ice-9 regex)
  35   #:use-module (ice-9 match)
  36   #:use-module (ice-9 format)
  37   #:use-module (system foreign)
  38   #:export (bytevector->base16-string
  39             base16-string->bytevector
  40
  41             %nixpkgs-directory
  42             nixpkgs-derivation
  43             nixpkgs-derivation*
  44
  45             compile-time-value
  46             fcntl-flock
  47             memoize
  48             default-keyword-arguments
  49             substitute-keyword-arguments
  50
  51             <location>
  52             location
  53             location?
  54             location-file
  55             location-line
  56             location-column
  57             source-properties->location
  58
  59             gnu-triplet->nix-system
  60             %current-system
  61             %current-target-system
  62             version-compare
  63             version>?
  64             guile-version>?
  65             package-name->name+version
  66             string-tokenize*
  67             string-replace-substring
  68             file-extension
  69             file-sans-extension
  70             call-with-temporary-output-file
  71             with-atomic-file-output
  72             fold2
  73             filtered-port))
  74
  75 \f
  76 ;;;
  77 ;;; Compile-time computations.
  78 ;;;
  79
  80 (define-syntax compile-time-value
  81   (syntax-rules ()
  82     "Evaluate the given expression at compile time.  The expression must
  83 evaluate to a simple datum."
  84     ((_ exp)
  85      (let-syntax ((v (lambda (s)
  86                        (let ((val exp))
  87                          (syntax-case s ()
  88                            (_ #`'#,(datum->syntax s val)))))))
  89        v))))
  90
  91 \f
  92 ;;;
  93 ;;; Base 16.
  94 ;;;
  95
  96 (define (bytevector->base16-string bv)
  97   "Return the hexadecimal representation of BV's contents."
  98   (define len
  99     (bytevector-length bv))
 100
 101   (let-syntax ((base16-chars (lambda (s)
 102                                (syntax-case s ()
 103                                  (_
 104                                   (let ((v (list->vector
 105                                             (unfold (cut > <> 255)
 106                                                     (lambda (n)
 107                                                       (format #f "~2,'0x" n))
 108                                                     1+
 109                                                     0))))
 110                                     v))))))
 111     (define chars base16-chars)
 112     (let loop ((i 0)
 113                (r '()))
 114       (if (= i len)
 115           (string-concatenate-reverse r)
 116           (loop (+ 1 i)
 117                 (cons (vector-ref chars (bytevector-u8-ref bv i)) r))))))
 118
 119 (define base16-string->bytevector
 120   (let ((chars->value (fold (lambda (i r)
 121                               (vhash-consv (string-ref (number->string i 16)
 122                                                        0)
 123                                            i r))
 124                             vlist-null
 125                             (iota 16))))
 126     (lambda (s)
 127       "Return the bytevector whose hexadecimal representation is string S."
 128       (define bv
 129         (make-bytevector (quotient (string-length s) 2) 0))
 130
 131       (string-fold (lambda (chr i)
 132                      (let ((j (quotient i 2))
 133                            (v (and=> (vhash-assv chr chars->value) cdr)))
 134                        (if v
 135                            (if (zero? (logand i 1))
 136                                (bytevector-u8-set! bv j
 137                                                    (arithmetic-shift v 4))
 138                                (let ((w (bytevector-u8-ref bv j)))
 139                                  (bytevector-u8-set! bv j (logior v w))))
 140                            (error "invalid hexadecimal character" chr)))
 141                      (+ i 1))
 142                    0
 143                    s)
 144       bv)))
 145
 146
 147 \f
 148 ;;;
 149 ;;; Filtering & pipes.
 150 ;;;
 151
 152 (define (filtered-port command input)
 153   "Return an input port where data drained from INPUT is filtered through
 154 COMMAND (a list).  In addition, return a list of PIDs that the caller must
 155 wait.  When INPUT is a file port, it must be unbuffered; otherwise, any
 156 buffered data is lost."
 157   (let loop ((input input)
 158              (pids '()))
 159     (if (file-port? input)
 160         (match (pipe)
 161           ((in . out)
 162            (match (primitive-fork)
 163              (0
 164               (close-port in)
 165               (close-port (current-input-port))
 166               (dup2 (fileno input) 0)
 167               (close-port (current-output-port))
 168               (dup2 (fileno out) 1)
 169               (apply execl (car command) command))
 170              (child
 171               (close-port out)
 172               (values in (cons child pids))))))
 173
 174         ;; INPUT is not a file port, so fork just for the sake of tunneling it
 175         ;; through a file port.
 176         (match (pipe)
 177           ((in . out)
 178            (match (primitive-fork)
 179              (0
 180               (dynamic-wind
 181                 (const #t)
 182                 (lambda ()
 183                   (close-port in)
 184                   (dump-port input out))
 185                 (lambda ()
 186                   (false-if-exception (close out))
 187                   (primitive-exit 0))))
 188              (child
 189               (close-port out)
 190               (loop in (cons child pids)))))))))
 191
 192 \f
 193 ;;;
 194 ;;; Nixpkgs.
 195 ;;;
 196
 197 (define %nixpkgs-directory
 198   (make-parameter
 199    ;; Capture the build-time value of $NIXPKGS.
 200    (or %nixpkgs
 201        (and=> (getenv "NIXPKGS")
 202               (lambda (val)
 203                 ;; Bail out when passed an empty string, otherwise
 204                 ;; `nix-instantiate' will sit there and attempt to read
 205                 ;; from its standard input.
 206                 (if (string=? val "")
 207                     #f
 208                     val))))))
 209
 210 (define* (nixpkgs-derivation attribute #:optional (system (%current-system)))
 211   "Return the derivation path of ATTRIBUTE in Nixpkgs."
 212   (let* ((p (open-pipe* OPEN_READ (or (getenv "NIX_INSTANTIATE")
 213                                       %nix-instantiate)
 214                         "-A" attribute (%nixpkgs-directory)
 215                         "--argstr" "system" system))
 216          (l (read-line p))
 217          (s (close-pipe p)))
 218     (and (zero? (status:exit-val s))
 219          (not (eof-object? l))
 220          l)))
 221
 222 (define-syntax-rule (nixpkgs-derivation* attribute)
 223   "Evaluate the given Nixpkgs derivation at compile-time."
 224   (compile-time-value (nixpkgs-derivation attribute)))
 225
 226 \f
 227 ;;;
 228 ;;; Advisory file locking.
 229 ;;;
 230
 231 (define %struct-flock
 232   ;; 'struct flock' from <fcntl.h>.
 233   (list short                                     ; l_type
 234         short                                     ; l_whence
 235         size_t                                    ; l_start
 236         size_t                                    ; l_len
 237         int))                                     ; l_pid
 238
 239 (define F_SETLKW
 240   ;; On Linux-based systems, this is usually 7, but not always
 241   ;; (exceptions include SPARC.)  On GNU/Hurd, it's 9.
 242   (compile-time-value
 243    (cond ((string-contains %host-type "sparc") 9) ; sparc-*-linux-gnu
 244          ((string-contains %host-type "linux") 7) ; *-linux-gnu
 245          (else 9))))                              ; *-gnu*
 246
 247 (define F_SETLK
 248   ;; Likewise: GNU/Hurd and SPARC use 8, while the others typically use 6.
 249   (compile-time-value
 250    (cond ((string-contains %host-type "sparc") 8) ; sparc-*-linux-gnu
 251          ((string-contains %host-type "linux") 6) ; *-linux-gnu
 252          (else 8))))                              ; *-gnu*
 253
 254 (define F_xxLCK
 255   ;; The F_RDLCK, F_WRLCK, and F_UNLCK constants.
 256   (compile-time-value
 257    (cond ((string-contains %host-type "sparc") #(1 2 3))    ; sparc-*-linux-gnu
 258          ((string-contains %host-type "hppa")  #(1 2 3))    ; hppa-*-linux-gnu
 259          ((string-contains %host-type "linux") #(0 1 2))    ; *-linux-gnu
 260          (else                                 #(1 2 3))))) ; *-gnu*
 261
 262 (define %libc-errno-pointer
 263   ;; Glibc's 'errno' pointer.
 264   (let ((errno-loc (dynamic-func "__errno_location" (dynamic-link))))
 265     (and errno-loc
 266          (let ((proc (pointer->procedure '* errno-loc '())))
 267            (proc)))))
 268
 269 (define (errno)
 270   "Return the current errno."
 271   ;; XXX: We assume that nothing changes 'errno' while we're doing all this.
 272   ;; In particular, that means that no async must be running here.
 273   (if %libc-errno-pointer
 274       (let ((bv (pointer->bytevector %libc-errno-pointer (sizeof int))))
 275         (bytevector-sint-ref bv 0 (native-endianness) (sizeof int)))
 276       0))
 277
 278 (define fcntl-flock
 279   (let* ((ptr  (dynamic-func "fcntl" (dynamic-link)))
 280          (proc (pointer->procedure int ptr `(,int ,int *))))
 281     (lambda* (fd-or-port operation #:key (wait? #t))
 282       "Perform locking OPERATION on the file beneath FD-OR-PORT.  OPERATION
 283 must be a symbol, one of 'read-lock, 'write-lock, or 'unlock.  When WAIT? is
 284 true, block until the lock is acquired; otherwise, thrown an 'flock-error'
 285 exception if it's already taken."
 286       (define (operation->int op)
 287         (case op
 288           ((read-lock)  (vector-ref F_xxLCK 0))
 289           ((write-lock) (vector-ref F_xxLCK 1))
 290           ((unlock)     (vector-ref F_xxLCK 2))
 291           (else         (error "invalid fcntl-flock operation" op))))
 292
 293       (define fd
 294         (if (port? fd-or-port)
 295             (fileno fd-or-port)
 296             fd-or-port))
 297
 298       ;; XXX: 'fcntl' is a vararg function, but here we happily use the
 299       ;; standard ABI; crossing fingers.
 300       (let ((err (proc fd
 301                        (if wait?
 302                            F_SETLKW               ; lock & wait
 303                            F_SETLK)               ; non-blocking attempt
 304                        (make-c-struct %struct-flock
 305                                       (list (operation->int operation)
 306                                             SEEK_SET
 307                                             0 0   ; whole file
 308                                             0)))))
 309         (or (zero? err)
 310
 311             ;; Presumably we got EAGAIN or so.
 312             (throw 'flock-error (errno)))))))
 313
 314 \f
 315 ;;;
 316 ;;; Miscellaneous.
 317 ;;;
 318
 319 (define (memoize proc)
 320   "Return a memoizing version of PROC."
 321   (let ((cache (make-hash-table)))
 322     (lambda args
 323       (let ((results (hash-ref cache args)))
 324         (if results
 325             (apply values results)
 326             (let ((results (call-with-values (lambda ()
 327                                                (apply proc args))
 328                              list)))
 329               (hash-set! cache args results)
 330               (apply values results)))))))
 331
 332 (define (default-keyword-arguments args defaults)
 333   "Return ARGS augmented with any keyword/value from DEFAULTS for
 334 keywords not already present in ARGS."
 335   (let loop ((defaults defaults)
 336              (args     args))
 337     (match defaults
 338       ((kw value rest ...)
 339        (loop rest
 340              (if (assoc-ref kw args)
 341                  args
 342                  (cons* kw value args))))
 343       (()
 344        args))))
 345
 346 (define-syntax substitute-keyword-arguments
 347   (syntax-rules ()
 348     "Return a new list of arguments where the value for keyword arg KW is
 349 replaced by EXP.  EXP is evaluated in a context where VAR is boud to the
 350 previous value of the keyword argument."
 351     ((_ original-args ((kw var) exp) ...)
 352      (let loop ((args    original-args)
 353                 (before '()))
 354        (match args
 355          ((kw var rest (... ...))
 356           (loop rest (cons* exp kw before)))
 357          ...
 358          ((x rest (... ...))
 359           (loop rest (cons x before)))
 360          (()
 361           (reverse before)))))))
 362
 363 (define (gnu-triplet->nix-system triplet)
 364   "Return the Nix system type corresponding to TRIPLET, a GNU triplet as
 365 returned by `config.guess'."
 366   (let ((triplet (cond ((string-match "^i[345]86-(.*)$" triplet)
 367                         =>
 368                         (lambda (m)
 369                           (string-append "i686-" (match:substring m 1))))
 370                        (else triplet))))
 371     (cond ((string-match "^([^-]+)-([^-]+-)?linux-gnu.*" triplet)
 372            =>
 373            (lambda (m)
 374              ;; Nix omits `-gnu' for GNU/Linux.
 375              (string-append (match:substring m 1) "-linux")))
 376           ((string-match "^([^-]+)-([^-]+-)?([[:alpha:]]+)([0-9]+\\.?)*$" triplet)
 377            =>
 378            (lambda (m)
 379              ;; Nix strip the version number from names such as `gnu0.3',
 380              ;; `darwin10.2.0', etc., and always strips the vendor part.
 381              (string-append (match:substring m 1) "-"
 382                             (match:substring m 3))))
 383           (else triplet))))
 384
 385 (define %current-system
 386   ;; System type as expected by Nix, usually ARCHITECTURE-KERNEL.
 387   ;; By default, this is equal to (gnu-triplet->nix-system %host-type).
 388   (make-parameter %system))
 389
 390 (define %current-target-system
 391   ;; Either #f or a GNU triplet representing the target system we are
 392   ;; cross-building to.
 393   (make-parameter #f))
 394
 395 (define version-compare
 396   (let ((strverscmp
 397          (let ((sym (or (dynamic-func "strverscmp" (dynamic-link))
 398                         (error "could not find `strverscmp' (from GNU libc)"))))
 399            (pointer->procedure int sym (list '* '*)))))
 400     (lambda (a b)
 401       "Return '> when A denotes a newer version than B,
 402 '< when A denotes a older version than B,
 403 or '= when they denote equal versions."
 404       (let ((result (strverscmp (string->pointer a) (string->pointer b))))
 405         (cond ((positive? result) '>)
 406               ((negative? result) '<)
 407               (else '=))))))
 408
 409 (define (version>? a b)
 410   "Return #t when A denotes a newer version than B."
 411   (eq? '> (version-compare a b)))
 412
 413 (define (guile-version>? str)
 414   "Return #t if the running Guile version is greater than STR."
 415   ;; Note: Using (version>? (version) "2.0.5") or similar doesn't work,
 416   ;; because the result of (version) can have a prefix, like "2.0.5-deb1".
 417   (version>? (string-append (major-version) "."
 418                             (minor-version) "."
 419                             (micro-version))
 420              str))
 421
 422 (define (package-name->name+version name)
 423   "Given NAME, a package name like \"foo-0.9.1b\", return two values:
 424 \"foo\" and \"0.9.1b\".  When the version part is unavailable, NAME and
 425 #f are returned.  The first hyphen followed by a digit is considered to
 426 introduce the version part."
 427   ;; See also `DrvName' in Nix.
 428
 429   (define number?
 430     (cut char-set-contains? char-set:digit <>))
 431
 432   (let loop ((chars   (string->list name))
 433              (prefix '()))
 434     (match chars
 435       (()
 436        (values name #f))
 437       ((#\- (? number? n) rest ...)
 438        (values (list->string (reverse prefix))
 439                (list->string (cons n rest))))
 440       ((head tail ...)
 441        (loop tail (cons head prefix))))))
 442
 443 (define (file-extension file)
 444   "Return the extension of FILE or #f if there is none."
 445   (let ((dot (string-rindex file #\.)))
 446     (and dot (substring file (+ 1 dot) (string-length file)))))
 447
 448 (define (file-sans-extension file)
 449   "Return the substring of FILE without its extension, if any."
 450   (let ((dot (string-rindex file #\.)))
 451     (if dot
 452         (substring file 0 dot)
 453         file)))
 454
 455 (define (string-tokenize* string separator)
 456   "Return the list of substrings of STRING separated by SEPARATOR.  This is
 457 like `string-tokenize', but SEPARATOR is a string."
 458   (define (index string what)
 459     (let loop ((string string)
 460                (offset 0))
 461       (cond ((string-null? string)
 462              #f)
 463             ((string-prefix? what string)
 464              offset)
 465             (else
 466              (loop (string-drop string 1) (+ 1 offset))))))
 467
 468   (define len
 469     (string-length separator))
 470
 471   (let loop ((string string)
 472              (result  '()))
 473     (cond ((index string separator)
 474            =>
 475            (lambda (offset)
 476              (loop (string-drop string (+ offset len))
 477                    (cons (substring string 0 offset)
 478                          result))))
 479           (else
 480            (reverse (cons string result))))))
 481
 482 (define* (string-replace-substring str substr replacement
 483                                    #:optional
 484                                    (start 0)
 485                                    (end (string-length str)))
 486   "Replace all occurrences of SUBSTR in the START--END range of STR by
 487 REPLACEMENT."
 488   (match (string-length substr)
 489     (0
 490      (error "string-replace-substring: empty substring"))
 491     (substr-length
 492      (let loop ((start  start)
 493                 (pieces (list (substring str 0 start))))
 494        (match (string-contains str substr start end)
 495          (#f
 496           (string-concatenate-reverse
 497            (cons (substring str start) pieces)))
 498          (index
 499           (loop (+ index substr-length)
 500                 (cons* replacement
 501                        (substring str start index)
 502                        pieces))))))))
 503
 504 (define (call-with-temporary-output-file proc)
 505   "Call PROC with a name of a temporary file and open output port to that
 506 file; close the file and delete it when leaving the dynamic extent of this
 507 call."
 508   (let* ((template (string-copy "guix-file.XXXXXX"))
 509          (out      (mkstemp! template)))
 510     (dynamic-wind
 511       (lambda ()
 512         #t)
 513       (lambda ()
 514         (proc template out))
 515       (lambda ()
 516         (false-if-exception (close out))
 517         (false-if-exception (delete-file template))))))
 518
 519 (define (with-atomic-file-output file proc)
 520   "Call PROC with an output port for the file that is going to replace FILE.
 521 Upon success, FILE is atomically replaced by what has been written to the
 522 output port, and PROC's result is returned."
 523   (let* ((template (string-append file ".XXXXXX"))
 524          (out      (mkstemp! template)))
 525     (with-throw-handler #t
 526       (lambda ()
 527         (let ((result (proc out)))
 528           (close out)
 529           (rename-file template file)
 530           result))
 531       (lambda (key . args)
 532         (false-if-exception (delete-file template))))))
 533
 534 (define fold2
 535   (case-lambda
 536     ((proc seed1 seed2 lst)
 537      "Like `fold', but with a single list and two seeds."
 538      (let loop ((result1 seed1)
 539                 (result2 seed2)
 540                 (lst     lst))
 541        (if (null? lst)
 542            (values result1 result2)
 543            (call-with-values
 544                (lambda () (proc (car lst) result1 result2))
 545              (lambda (result1 result2)
 546                (loop result1 result2 (cdr lst)))))))
 547     ((proc seed1 seed2 lst1 lst2)
 548      "Like `fold', but with a two lists and two seeds."
 549      (let loop ((result1 seed1)
 550                 (result2 seed2)
 551                 (lst1    lst1)
 552                 (lst2    lst2))
 553        (if (or (null? lst1) (null? lst2))
 554            (values result1 result2)
 555            (call-with-values
 556                (lambda () (proc (car lst1) (car lst2) result1 result2))
 557              (lambda (result1 result2)
 558                (fold2 proc result1 result2 (cdr lst1) (cdr lst2)))))))))
 559
 560 \f
 561 ;;;
 562 ;;; Source location.
 563 ;;;
 564
 565 ;; A source location.
 566 (define-record-type <location>
 567   (make-location file line column)
 568   location?
 569   (file          location-file)                   ; file name
 570   (line          location-line)                   ; 1-indexed line
 571   (column        location-column))                ; 0-indexed column
 572
 573 (define location
 574   (memoize
 575    (lambda (file line column)
 576      "Return the <location> object for the given FILE, LINE, and COLUMN."
 577      (and line column file
 578           (make-location file line column)))))
 579
 580 (define (source-properties->location loc)
 581   "Return a location object based on the info in LOC, an alist as returned
 582 by Guile's `source-properties', `frame-source', `current-source-location',
 583 etc."
 584   (let ((file (assq-ref loc 'filename))
 585         (line (assq-ref loc 'line))
 586         (col  (assq-ref loc 'column)))
 587     ;; In accordance with the GCS, start line and column numbers at 1.  Note
 588     ;; that unlike LINE and `port-column', COL is actually 1-indexed here...
 589     (location file (and line (+ line 1)) col)))