@ -41,6 +41,7 @@
# :use-module ( gnu packages compression )
# :use-module ( gnu packages gnupg )
# :use-module ( srfi srfi-1 )
# :use-module ( srfi srfi-11 )
# :use-module ( srfi srfi-34 )
# :use-module ( srfi srfi-35 )
# :use-module ( srfi srfi-37 )
@ -48,23 +49,39 @@
# :use-module ( ice-9 match )
# :export ( guix-pull ) )
( define %snapshot-url
;; "http://hydra.gnu.org/job/guix/master/tarball/latest/download"
"https://git.savannah.gnu.org/cgit/guix.git/snapshot/master.tar.gz"
)
( module-autoload! ( resolve-module ' ( guix scripts pull ) )
' ( git ) ' ( git-error? set-tls-certificate-locations! )
' ( guix git ) ' ( latest-repository-commit ) )
( define-syntax-rule ( with-environment-variable variable value body . . . )
( let ( ( original ( getenv variable ) ) )
( dynamic-wind
( lambda ( )
( setenv variable value ) )
( lambda ( )
body . . . )
( lambda ( )
( setenv variable original ) ) ) ) )
( define ( ensure-guile-git! )
;; Previously Guile-Git was not a prerequisite. Thus, someone running 'guix
;; pull' on an old installation may be lacking Guile-Git. To address this,
;; we autoload things that depend on Guile-Git and check in the entry point
;; whether Guile-Git is available.
;;
;; TODO: Remove this hack when Guile-Git is widespread or enforced.
( define-syntax-rule ( with-PATH value body . . . )
( with-environment-variable "PATH" value body . . . ) )
( unless ( false-if-exception ( resolve-interface ' ( git ) ) )
( leave ( G_ " Guile-Git is missing but it is now required by 'guix pull ' .
Install it by running:
guix package -i ~a
export GUILE_LOAD_PATH=$HOME/ . guix-profile/share/guile/site/~a:$GUILE_LOAD_PATH
export GUILE_LOAD_COMPILED_PATH=$HOME/ . guix-profile/lib/guile/~a/site-ccache:$GUILE_LOAD_COMPILED_PATH
\ n " )
( match ( effective-version )
( "2.0" "guile2.0-git" )
( _ "guile-git" ) )
( effective-version )
( effective-version ) ) )
;; XXX: For unclear reasons this is needed for
;; 'set-tls-certificate-locations!'.
( module-use! ( resolve-module ' ( guix scripts pull ) )
( resolve-interface ' ( git ) ) ) )
( define %repository-url
"https://git.savannah.gnu.org/git/guix.git" )
;;;
@ -73,7 +90,8 @@
( define %default-options
;; Alist of default option values.
` ( ( tarball-url . , %snapshot-url )
` ( ( repository-url . , %repository-url )
( ref . ( branch . "origin/master" ) )
( system . , ( %current-system ) )
( substitutes? . #t )
( graft? . #t )
@ -86,7 +104,11 @@ Download and deploy the latest version of Guix.\n"))
( display ( G_ "
--verbose produce verbose output " ) )
( display ( G_ "
--url=URL download the Guix tarball from URL " ) )
--url=URL download from the Git repository at URL " ) )
( display ( G_ "
--commit=COMMIT download the specified COMMIT " ) )
( display ( G_ "
--branch=BRANCH download the tip of the specified BRANCH " ) )
( display ( G_ "
--bootstrap use the bootstrap Guile to build the new Guix " ) )
( newline )
@ -105,8 +127,15 @@ Download and deploy the latest version of Guix.\n"))
( alist-cons 'verbose? #t result ) ) )
( option ' ( "url" ) #t #f
( lambda ( opt name arg result )
( alist-cons 'tarball-url arg
( alist-delete 'tarball-url result ) ) ) )
( alist-cons 'repository-url arg
( alist-delete 'repository-url result ) ) ) )
( option ' ( "commit" ) #t #f
( lambda ( opt name arg result )
( alist-cons 'ref ` ( commit . , arg ) result ) ) )
( option ' ( "branch" ) #t #f
( lambda ( opt name arg result )
( alist-cons 'ref ` ( branch . , ( string-append "origin/" arg ) )
result ) ) )
( option ' ( #\n "dry-run" ) #f #f
( lambda ( opt name arg result )
( alist-cons 'dry-run? #t ( alist-cons 'graft? #f result ) ) ) )
@ -129,81 +158,28 @@ Download and deploy the latest version of Guix.\n"))
( define indirect-root-added
( store-lift add-indirect-root ) )
( define ( temporary-directory )
"Make a temporary directory and return its name."
( let ( ( name ( tmpnam ) ) )
( mkdir name )
( chmod name # o700 )
name ) )
( define ( first-directory directory )
"Return a the name of the first file found under DIRECTORY."
( match ( scandir directory
( lambda ( name )
( and ( not ( member name ' ( "." ".." ) ) )
( file-is-directory? name ) ) ) )
( ( directory )
directory )
( x
( raise ( condition
( &message
( message "tarball did not produce a single source directory" ) ) ) ) ) ) )
( define ( interned-then-deleted directory name )
" Add DIRECTORY to the store under NAME, and delete it . Return the resulting
store file name . "
( mlet %store-monad ( ( result ( interned-file directory name
# :recursive? #t ) ) )
( delete-file-recursively directory )
( return result ) ) )
( define ( unpack tarball )
"Return the name of the directory where TARBALL has been unpacked."
( mlet* %store-monad ( ( format -> ( lift format %store-monad ) )
( tar ( package->derivation tar ) )
( gzip ( package->derivation gzip ) ) )
( mbegin %store-monad
( what-to-build ( list tar gzip ) )
( built-derivations ( list tar gzip ) )
( format #t ( G_ "unpacking '~a'...~%" ) tarball )
( let ( ( source ( temporary-directory ) ) )
( with-directory-excursion source
( with-PATH ( string-append ( derivation->output-path gzip ) "/bin" )
( unless ( zero? ( system* ( string-append ( derivation->output-path tar )
"/bin/tar" )
"xf" tarball ) )
( raise ( condition
( &message ( message "failed to unpack source code" ) ) ) ) ) )
( interned-then-deleted ( string-append source "/"
( first-directory source ) )
"guix-source" ) ) ) ) ) )
( define %self-build-file
;; The file containing code to build Guix. This serves the same purpose as
;; a makefile, and, similarly, is intended to always keep this name.
"build-aux/build-self.scm" )
( define* ( build-from-source tarball # :key verbose? )
" Return a derivation to build Guix from TARBALL , using the self-build script
( define* ( build-from-source source # :key verbose? )
" Return a derivation to build Guix from SOURCE, using the self-build script
contained therein . "
;; Running the self-build script makes it easier to update the build
;; procedure: the self-build script of the Guix-to-be-installed contains the
;; right dependencies, build procedure, etc., which the Guix-in-use may not
;; be know.
( mlet* %store-monad ( ( source ( unpack tarball ) )
( script -> ( string-append source "/"
%self-build-file ) )
( build -> ( primitive-load script ) ) )
( let* ( ( script ( string-append source "/" %self-build-file ) )
( build ( primitive-load script ) ) )
;; BUILD must be a monadic procedure of at least one argument: the source
;; tree.
( build source # :verbose? verbose? ) ) )
( define* ( build-and-install tarball config-dir
( define* ( build-and-install source config-dir
# :key verbose? )
"Build the tool from TARBALL , and install it in CONFIG-DIR."
( mlet* %store-monad ( ( source ( build-from-source tarball
"Build the tool from SOURCE, and install it in CONFIG-DIR."
( mlet* %store-monad ( ( source ( build-from-source source
# :verbose? verbose? ) )
( source-dir -> ( derivation->output-path source ) )
( to-do? ( what-to-build ( list source ) ) )
@ -227,44 +203,83 @@ contained therein."
( return #t ) ) ) )
( leave ( G_ "failed to update Guix, check the build log~%" ) ) ) ) )
( define ( honor-lets-encrypt-certificates! store )
"Tell Guile-Git to use the Let's Encrypt certificates."
( let* ( ( drv ( package-derivation store le-certs ) )
( certs ( string-append ( derivation->output-path drv )
"/etc/ssl/certs" ) ) )
( build-derivations store ( list drv ) )
;; In the past Guile-Git would not provide this procedure.
( if ( module-defined? ( resolve-interface ' ( git ) )
'set-tls-certificate-locations! )
( set-tls-certificate-locations! certs )
( begin
;; In this case we end up using whichever certificates OpenSSL
;; chooses to use: $SSL_CERT_FILE, $SSL_CERT_DIR, or /etc/ssl/certs.
( warning ( G_ " cannot enforce use of the Let 's Encrypt \
certificates~% " ) )
( warning ( G_ "please upgrade Guile-Git~%" ) ) ) ) ) )
( define ( report-git-error error )
"Report the given Guile-Git error."
;; Prior to Guile-Git commit b6b2760c2fd6dfaa5c0fedb43eeaff06166b3134,
;; errors would be represented by integers.
( match error
( ( ? integer? error ) ;old Guile-Git
( leave ( G_ "Git error ~a~%" ) error ) )
( ( ? git-error? error ) ;new Guile-Git
( leave ( G_ "Git error: ~a~%" ) ( git-error-message error ) ) ) ) )
( define-syntax-rule ( with-git-error-handling body . . . )
( catch 'git-error
( lambda ( )
body . . . )
( lambda ( key err )
( report-git-error err ) ) ) )
( define ( guix-pull . args )
( define ( use-le-certs? url )
( string-prefix? "https://git.savannah.gnu.org/" url ) )
( define ( fetch-tarball store url )
( download-to-store store url "guix-latest.tar.gz" ) )
( with-error-handling
( let* ( ( opts ( parse-command-line args %options
( list %default-options ) ) )
( url ( assoc-ref opts 'tarball-url ) ) )
( unless ( assoc-ref opts 'dry-run? ) ;XXX: not very useful
( with-store store
( set-build-options-from-command-line store opts )
( let ( ( tarball
( if ( use-le-certs? url )
( let* ( ( drv ( package-derivation store le-certs ) )
( certs ( string-append ( derivation->output-path drv )
"/etc/ssl/certs" ) ) )
( build-derivations store ( list drv ) )
( parameterize ( ( %x509-certificate-directory certs ) )
( fetch-tarball store url ) ) )
( fetch-tarball store url ) ) ) )
( unless tarball
( leave ( G_ "failed to download up-to-date source, exiting\n" ) ) )
( parameterize ( ( %guile-for-build
( package-derivation store
( if ( assoc-ref opts 'bootstrap? )
%bootstrap-guile
( canonical-package guile-2 . 0 ) ) ) ) )
( run-with-store store
( build-and-install tarball ( config-directory )
# :verbose? ( assoc-ref opts 'verbose? ) ) ) ) ) ) ) ) ) )
( with-git-error-handling
( let* ( ( opts ( parse-command-line args %options
( list %default-options ) ) )
( url ( assoc-ref opts 'repository-url ) )
( ref ( assoc-ref opts 'ref ) )
( cache ( string-append ( cache-directory ) "/pull" ) ) )
( ensure-guile-git! )
( unless ( assoc-ref opts 'dry-run? ) ;XXX: not very useful
( with-store store
( set-build-options-from-command-line store opts )
;; For reproducibility, always refer to the LE certificates when we
;; know we're talking to Savannah.
( when ( use-le-certs? url )
( honor-lets-encrypt-certificates! store ) )
( format ( current-error-port )
( G_ "Updating from Git repository at '~a'...~%" )
url )
( let-values ( ( ( checkout commit )
( latest-repository-commit store url
# :ref ref
# :cache-directory cache ) ) )
;; Local Variables:
;; eval: (put 'with-PATH 'scheme-indent-function 1)
;; eval: (put 'with-temporary-directory 'scheme-indent-function 1)
;; End:
( format ( current-error-port )
( G_ "Building from Git commit ~a...~%" )
commit )
( parameterize ( ( %guile-for-build
( package-derivation store
( if ( assoc-ref opts 'bootstrap? )
%bootstrap-guile
( canonical-package guile-2 . 0 ) ) ) ) )
( run-with-store store
( build-and-install checkout ( config-directory )
# :verbose? ( assoc-ref opts 'verbose? ) ) ) ) ) ) ) ) ) ) )
;;; pull.scm ends here