Merge branch 'master' into core-updates

2 files changed, 71 insertions, 11 deletions

diff --git a/guix/build/hg.scm b/guix/build/hg.scm
new file mode 100644
index 0000000000..ae4574de57
--- /dev/null
+++ b/guix/build/hg.scm
@@ -0,0 +1,51 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.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 (guix build hg)
+  #:use-module (guix build utils)
+  #:export (hg-fetch))
+
+;;; Commentary:
+;;;
+;;; This is the build-side support code of (guix hg-download).  It allows a
+;;; Mercurial repository to be cloned and checked out at a specific changeset
+;;; identifier.
+;;;
+;;; Code:
+
+(define* (hg-fetch url changeset directory
+                   #:key (hg-command "hg"))
+  "Fetch CHANGESET from URL into DIRECTORY.  CHANGESET must be a valid
+Mercurial changeset identifier.  Return #t on success, #f otherwise."
+
+  (and (zero? (system* hg-command
+                       "clone" url
+                       "--rev" changeset
+                       ;; Disable TLS certificate verification.  The hash of
+                       ;; the checkout is known in advance anyway.
+                       "--insecure"
+                       directory))
+       (with-directory-excursion directory
+         (begin
+           ;; The contents of '.hg' vary as a function of the current
+           ;; status of the Mercurial repo.  Since we want a fixed
+           ;; output, this directory needs to be taken out.
+           (delete-file-recursively ".hg")
+           #t))))
+
+;;; hg.scm ends here
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 48ff227e10..c663899160 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -64,6 +64,7 @@
 
             processes
             mkdtemp!
+            fdatasync
             pivot-root
             fcntl-flock
 
@@ -493,8 +494,7 @@ user-land process."
         <))
 
 (define mkdtemp!
-  (let* ((ptr  (dynamic-func "mkdtemp" (dynamic-link)))
-         (proc (pointer->procedure '* ptr '(*))))
+  (let ((proc (syscall->procedure '* "mkdtemp" '(*))))
     (lambda (tmpl)
       "Create a new unique directory in the file system using the template
 string TMPL and return its file name.  TMPL must end with 'XXXXXX'."
@@ -506,6 +506,20 @@ string TMPL and return its file name.  TMPL must end with 'XXXXXX'."
                  (list err)))
         (pointer->string result)))))
 
+(define fdatasync
+  (let ((proc (syscall->procedure int "fdatasync" (list int))))
+    (lambda (port)
+      "Flush buffered output of PORT, an output file port, and then call
+fdatasync(2) on the underlying file descriptor."
+      (force-output port)
+      (let* ((fd  (fileno port))
+             (ret (proc fd))
+             (err (errno)))
+        (unless (zero? ret)
+          (throw 'system-error "fdatasync" "~S: ~A"
+                 (list fd (strerror err))
+                 (list err)))))))
+
 
 (define-record-type <file-system>
   (file-system type block-size blocks blocks-free
@@ -611,8 +625,7 @@ are shared between the parent and child processes."
   ;; Some systems may be using an old (pre-2.14) version of glibc where there
   ;; is no 'setns' function available.
   (false-if-exception
-   (let* ((ptr  (dynamic-func "setns" (dynamic-link)))
-          (proc (pointer->procedure int ptr (list int int))))
+   (let ((proc (syscall->procedure int "setns" (list int int))))
      (lambda (fdes nstype)
        "Reassociate the current process with the namespace specified by FDES, a
 file descriptor obtained by opening a /proc/PID/ns/* file.  NSTYPE specifies
@@ -818,9 +831,7 @@ bytevector BV at INDEX."
 
 (define %ioctl
   ;; The most terrible interface, live from Scheme.
-  (pointer->procedure int
-                      (dynamic-func "ioctl" (dynamic-link))
-                      (list int unsigned-long '*)))
+  (syscall->procedure int "ioctl" (list int unsigned-long '*)))
 
 (define (bytevector->string-list bv stride len)
   "Return the null-terminated strings found in BV every STRIDE bytes.  Read at
@@ -1060,8 +1071,7 @@ return the list of resulting <interface> objects."
            (loop ptr (cons ifaddr result)))))))
 
 (define network-interfaces
-  (let* ((ptr  (dynamic-func "getifaddrs" (dynamic-link)))
-         (proc (pointer->procedure int ptr (list '*))))
+  (let ((proc (syscall->procedure int "getifaddrs" (list '*))))
     (lambda ()
       "Return a list of <interface> objects, each denoting a configured
 network interface.  This is implemented using the 'getifaddrs' libc function."
@@ -1078,8 +1088,7 @@ network interface.  This is implemented using the 'getifaddrs' libc function."
                    (list err)))))))
 
 (define free-ifaddrs
-  (let ((ptr (dynamic-func "freeifaddrs" (dynamic-link))))
-    (pointer->procedure void ptr '(*))))
+  (syscall->procedure void "freeifaddrs" '(*)))
 
 
 ;;;