12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006 |
- (define-module (guix profiles)
- #:use-module ((guix config) #:select (%state-directory))
- #:use-module ((guix utils) #:hide (package-name->name+version))
- #:use-module ((guix build utils)
- #:select (package-name->name+version mkdir-p))
- #:use-module ((guix diagnostics) #:select (&fix-hint))
- #:use-module (guix i18n)
- #:use-module (guix records)
- #:use-module (guix packages)
- #:use-module (guix derivations)
- #:use-module (guix search-paths)
- #:use-module (guix gexp)
- #:use-module (guix modules)
- #:use-module (guix monads)
- #:use-module (guix store)
- #:use-module (ice-9 vlist)
- #:use-module (ice-9 match)
- #:use-module (ice-9 regex)
- #:use-module (ice-9 ftw)
- #:use-module (ice-9 format)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-9)
- #:use-module (srfi srfi-11)
- #:use-module (srfi srfi-19)
- #:use-module (srfi srfi-26)
- #:use-module (srfi srfi-34)
- #:use-module (srfi srfi-35)
- #:export (&profile-error
- profile-error?
- profile-error-profile
- &profile-not-found-error
- profile-not-found-error?
- &profile-collision-error
- profile-collision-error?
- profile-collision-error-entry
- profile-collision-error-conflict
- &missing-generation-error
- missing-generation-error?
- missing-generation-error-generation
- &unmatched-pattern-error
- unmatched-pattern-error?
- unmatched-pattern-error-pattern
- unmatched-pattern-error-manifest
- manifest make-manifest
- manifest?
- manifest-entries
- manifest-transitive-entries
- <manifest-entry>
- manifest-entry
- manifest-entry?
- manifest-entry-name
- manifest-entry-version
- manifest-entry-output
- manifest-entry-item
- manifest-entry-dependencies
- manifest-entry-search-paths
- manifest-entry-parent
- manifest-entry-properties
- lower-manifest-entry
- manifest-entry=?
- manifest-pattern
- manifest-pattern?
- manifest-pattern-name
- manifest-pattern-version
- manifest-pattern-output
- concatenate-manifests
- map-manifest-entries
- manifest-remove
- manifest-add
- manifest-lookup
- manifest-installed?
- manifest-matching-entries
- manifest-search-paths
- check-for-collisions
- manifest-transaction
- manifest-transaction?
- manifest-transaction-install
- manifest-transaction-remove
- manifest-transaction-install-entry
- manifest-transaction-remove-pattern
- manifest-transaction-null?
- manifest-transaction-removal-candidate?
- manifest-perform-transaction
- manifest-transaction-effects
- profile-manifest
- package->manifest-entry
- packages->manifest
- ca-certificate-bundle
- %default-profile-hooks
- profile-derivation
- profile-search-paths
- profile
- profile?
- profile-name
- profile-content
- profile-hooks
- profile-locales?
- profile-allow-collisions?
- profile-relative-symlinks?
- generation-number
- generation-profile
- generation-numbers
- profile-generations
- relative-generation-spec->number
- relative-generation
- previous-generation-number
- generation-time
- generation-file-name
- switch-to-generation
- roll-back
- delete-generation
- %user-profile-directory
- %profile-directory
- %current-profile
- ensure-profile-directory
- canonicalize-profile
- user-friendly-profile
- linux-module-database))
- (define-condition-type &profile-error &error
- profile-error?
- (profile profile-error-profile))
- (define-condition-type &profile-not-found-error &profile-error
- profile-not-found-error?)
- (define-condition-type &profile-collision-error &error
- profile-collision-error?
- (entry profile-collision-error-entry)
- (conflict profile-collision-error-conflict))
- (define-condition-type &unmatched-pattern-error &error
- unmatched-pattern-error?
- (pattern unmatched-pattern-error-pattern)
- (manifest unmatched-pattern-error-manifest))
- (define-condition-type &missing-generation-error &profile-error
- missing-generation-error?
- (generation missing-generation-error-generation))
- (define-record-type <manifest>
- (manifest entries)
- manifest?
- (entries manifest-entries))
- (define make-manifest manifest)
- (define-record-type* <manifest-entry> manifest-entry
- make-manifest-entry
- manifest-entry?
- (name manifest-entry-name)
- (version manifest-entry-version)
- (output manifest-entry-output
- (default "out"))
- (item manifest-entry-item)
- (dependencies manifest-entry-dependencies
- (default '()))
- (search-paths manifest-entry-search-paths
- (default '()))
- (parent manifest-entry-parent
- (default (delay #f)))
- (properties manifest-entry-properties
- (default '())))
- (define-record-type* <manifest-pattern> manifest-pattern
- make-manifest-pattern
- manifest-pattern?
- (name manifest-pattern-name)
- (version manifest-pattern-version
- (default #f))
- (output manifest-pattern-output
- (default "out")))
- (define (list=? = lst1 lst2)
- "Return true if LST1 and LST2 have the same length and their elements are
- pairwise equal per =."
- (match lst1
- (()
- (null? lst2))
- ((head1 . tail1)
- (match lst2
- ((head2 . tail2)
- (and (= head1 head2) (list=? = tail1 tail2)))
- (()
- #f)))))
- (define (manifest-entry=? entry1 entry2)
- "Return true if ENTRY1 is equivalent to ENTRY2, ignoring their 'properties'
- field."
- (match entry1
- (($ <manifest-entry> name1 version1 output1 item1 dependencies1 paths1)
- (match entry2
- (($ <manifest-entry> name2 version2 output2 item2 dependencies2 paths2)
- (and (string=? name1 name2)
- (string=? version1 version2)
- (string=? output1 output2)
- (equal? item1 item2)
- (equal? paths1 paths2)
- (list=? manifest-entry=? dependencies1 dependencies2)))))))
- (define (manifest-transitive-entries manifest)
- "Return the entries of MANIFEST along with their propagated inputs,
- recursively."
- (let loop ((entries (manifest-entries manifest))
- (result '())
- (visited vlist-null))
- (match entries
- (()
- (reverse result))
- ((head . tail)
- (if (vhash-assoc head visited manifest-entry=?)
- (loop tail result visited)
- (loop (append (manifest-entry-dependencies head)
- tail)
- (cons head result)
- (vhash-cons head #t visited)))))))
- (define (profile-manifest profile)
- "Return the PROFILE's manifest."
- (let ((file (string-append profile "/manifest")))
- (if (file-exists? file)
- (call-with-input-file file read-manifest)
- (manifest '()))))
- (define (manifest-entry-lookup manifest)
- "Return a lookup procedure for the entries of MANIFEST. The lookup
- procedure takes two arguments: the entry name and output."
- (define mapping
- (let loop ((entries (manifest-entries manifest))
- (mapping vlist-null))
- (fold (lambda (entry result)
- (vhash-cons (cons (manifest-entry-name entry)
- (manifest-entry-output entry))
- entry
- (loop (manifest-entry-dependencies entry)
- result)))
- mapping
- entries)))
- (lambda (name output)
- (match (vhash-assoc (cons name output) mapping)
- ((_ . entry) entry)
- (#f #f))))
- (define* (lower-manifest-entry entry system #:key target)
- "Lower ENTRY for SYSTEM and TARGET such that its 'item' field is a store
- file name."
- (define (recurse entry)
- (mapm/accumulate-builds (lambda (entry)
- (lower-manifest-entry entry system
- #:target target))
- (manifest-entry-dependencies entry)))
- (let ((item (manifest-entry-item entry)))
- (if (string? item)
- (with-monad %store-monad
- (return entry))
- (mlet %store-monad ((drv (lower-object item system
- #:target target))
- (dependencies (recurse entry))
- (output -> (manifest-entry-output entry)))
- (return (manifest-entry
- (inherit entry)
- (item (derivation->output-path drv output))
- (dependencies dependencies)))))))
- (define* (check-for-collisions manifest system #:key target)
- "Check whether the entries of MANIFEST conflict with one another; raise a
- '&profile-collision-error' when a conflict is encountered."
- (define lookup
- (manifest-entry-lookup manifest))
- (define candidates
- (filter-map (lambda (entry)
- (let ((other (lookup (manifest-entry-name entry)
- (manifest-entry-output entry))))
- (and other (list entry other))))
- (manifest-transitive-entries manifest)))
- (define lower-pair
- (match-lambda
- ((first second)
- (mlet %store-monad ((first (lower-manifest-entry first system
- #:target target))
- (second (lower-manifest-entry second system
- #:target target)))
- (return (list first second))))))
-
- (mlet %store-monad ((lst (mapm/accumulate-builds lower-pair candidates)))
- (foldm %store-monad
- (lambda (entries result)
- (match entries
- ((first second)
- (if (string=? (manifest-entry-item first)
- (manifest-entry-item second))
- (return result)
- (raise (condition
- (&profile-collision-error
- (entry first)
- (conflict second))))))))
- #t
- lst)))
- (define* (package->manifest-entry package #:optional (output "out")
- #:key (parent (delay #f))
- (properties '()))
- "Return a manifest entry for the OUTPUT of package PACKAGE."
-
- (letrec* ((deps (map (match-lambda
- ((label package)
- (package->manifest-entry package
- #:parent (delay entry)))
- ((label package output)
- (package->manifest-entry package output
- #:parent (delay entry))))
- (package-propagated-inputs package)))
- (entry (manifest-entry
- (name (package-name package))
- (version (package-version package))
- (output output)
- (item package)
- (dependencies (delete-duplicates deps))
- (search-paths
- (package-transitive-native-search-paths package))
- (parent parent)
- (properties properties))))
- entry))
- (define (packages->manifest packages)
- "Return a list of manifest entries, one for each item listed in PACKAGES.
- Elements of PACKAGES can be either package objects or package/string tuples
- denoting a specific output of a package."
- (define inferiors-loaded?
-
-
- (resolve-module '(guix inferior) #f #f #:ensure #f))
- (define (inferior->entry)
- (module-ref (resolve-interface '(guix inferior))
- 'inferior-package->manifest-entry))
- (manifest
- (delete-duplicates
- (map (match-lambda
- (((? package? package) output)
- (package->manifest-entry package output))
- ((? package? package)
- (package->manifest-entry package))
- ((thing output)
- (if inferiors-loaded?
- ((inferior->entry) thing output)
- (throw 'wrong-type-arg 'packages->manifest
- "Wrong package object: ~S" (list thing) (list thing))))
- (thing
- (if inferiors-loaded?
- ((inferior->entry) thing)
- (throw 'wrong-type-arg 'packages->manifest
- "Wrong package object: ~S" (list thing) (list thing)))))
- packages)
- manifest-entry=?)))
- (define (manifest->gexp manifest)
- "Return a representation of MANIFEST as a gexp."
- (define (entry->gexp entry)
- (match entry
- (($ <manifest-entry> name version output (? string? path)
- (deps ...) (search-paths ...) _ (properties ...))
- #~(#$name #$version #$output #$path
- (propagated-inputs #$(map entry->gexp deps))
- (search-paths #$(map search-path-specification->sexp
- search-paths))
- (properties . #$properties)))
- (($ <manifest-entry> name version output package
- (deps ...) (search-paths ...) _ (properties ...))
- #~(#$name #$version #$output
- (ungexp package (or output "out"))
- (propagated-inputs #$(map entry->gexp deps))
- (search-paths #$(map search-path-specification->sexp
- search-paths))
- (properties . #$properties)))))
- (match manifest
- (($ <manifest> (entries ...))
- #~(manifest (version 3)
- (packages #$(map entry->gexp entries))))))
- (define (find-package name version)
- "Return a package from the distro matching NAME and possibly VERSION. This
- procedure is here for backward-compatibility and will eventually vanish."
- (define find-best-packages-by-name
- (module-ref (resolve-interface '(gnu packages))
- 'find-best-packages-by-name))
-
-
-
- (match (find-best-packages-by-name name version)
- ((p _ ...) p)
- (_
- (match (find-best-packages-by-name name #f)
- ((p _ ...) p)
- (_ #f)))))
- (define (sexp->manifest sexp)
- "Parse SEXP as a manifest."
- (define (infer-search-paths name version)
-
-
-
- (let ((package (find-package name version)))
- (if package
- (package-native-search-paths package)
- '())))
- (define (infer-dependency item parent)
-
- (let-values (((name version)
- (package-name->name+version
- (store-path-package-name item))))
- (manifest-entry
- (name name)
- (version version)
- (item item)
- (parent parent))))
- (define* (sexp->manifest-entry sexp #:optional (parent (delay #f)))
- (match sexp
- ((name version output path
- ('propagated-inputs deps)
- ('search-paths search-paths)
- extra-stuff ...)
-
- (letrec* ((deps* (map (cut sexp->manifest-entry <> (delay entry))
- deps))
- (entry (manifest-entry
- (name name)
- (version version)
- (output output)
- (item path)
- (dependencies deps*)
- (search-paths (map sexp->search-path-specification
- search-paths))
- (parent parent)
- (properties (or (assoc-ref extra-stuff 'properties)
- '())))))
- entry))))
- (match sexp
- (('manifest ('version 0)
- ('packages ((name version output path) ...)))
- (manifest
- (map (lambda (name version output path)
- (manifest-entry
- (name name)
- (version version)
- (output output)
- (item path)
- (search-paths (infer-search-paths name version))))
- name version output path)))
-
-
- (('manifest ('version 1)
- ('packages ((name version output path deps) ...)))
- (manifest
- (map (lambda (name version output path deps)
-
-
-
- (let ((deps (match deps
- (((labels directories) ...)
- directories)
- ((directories ...)
- directories))))
- (letrec* ((deps* (map (cute infer-dependency <> (delay entry))
- deps))
- (entry (manifest-entry
- (name name)
- (version version)
- (output output)
- (item path)
- (dependencies deps*)
- (search-paths
- (infer-search-paths name version)))))
- entry)))
- name version output path deps)))
-
- (('manifest ('version 2 minor-version ...)
- ('packages ((name version output path
- ('propagated-inputs deps)
- ('search-paths search-paths)
- extra-stuff ...)
- ...)))
- (manifest
- (map (lambda (name version output path deps search-paths)
- (letrec* ((deps* (map (cute infer-dependency <> (delay entry))
- deps))
- (entry (manifest-entry
- (name name)
- (version version)
- (output output)
- (item path)
- (dependencies deps*)
- (search-paths
- (map sexp->search-path-specification
- search-paths)))))
- entry))
- name version output path deps search-paths)))
-
- (('manifest ('version 3 minor-version ...)
- ('packages (entries ...)))
- (manifest (map sexp->manifest-entry entries)))
- (_
- (raise (condition
- (&message (message "unsupported manifest format")))))))
- (define (read-manifest port)
- "Return the packages listed in MANIFEST."
- (sexp->manifest (read port)))
- (define (concatenate-manifests lst)
- "Concatenate the manifests listed in LST and return the resulting manifest."
- (manifest (append-map manifest-entries lst)))
- (define (map-manifest-entries proc manifest)
- "Apply PROC to all the entries of MANIFEST and return a new manifest."
- (make-manifest
- (map proc (manifest-entries manifest))))
- (define (entry-predicate pattern)
- "Return a procedure that returns #t when passed a manifest entry that
- matches NAME/OUTPUT/VERSION. OUTPUT and VERSION may be #f, in which case they
- are ignored."
- (match pattern
- (($ <manifest-pattern> name version output)
- (match-lambda
- (($ <manifest-entry> entry-name entry-version entry-output)
- (and (string=? entry-name name)
- (or (not entry-output) (not output)
- (string=? entry-output output))
- (or (not version)
- (string=? entry-version version))))))))
- (define (manifest-remove manifest patterns)
- "Remove entries for each of PATTERNS from MANIFEST. Each item in PATTERNS
- must be a manifest-pattern."
- (define (remove-entry pattern lst)
- (remove (entry-predicate pattern) lst))
- (make-manifest (fold remove-entry
- (manifest-entries manifest)
- patterns)))
- (define (manifest-add manifest entries)
- "Add a list of manifest ENTRIES to MANIFEST and return new manifest.
- Remove MANIFEST entries that have the same name and output as ENTRIES."
- (define (same-entry? entry name output)
- (match entry
- (($ <manifest-entry> entry-name _ entry-output _)
- (and (equal? name entry-name)
- (equal? output entry-output)))))
- (make-manifest
- (fold (lambda (entry result)
- (match entry
- (($ <manifest-entry> name _ out _)
- (cons entry
- (remove (cut same-entry? <> name out)
- result)))))
- (manifest-entries manifest)
- entries)))
- (define (manifest-lookup manifest pattern)
- "Return the first item of MANIFEST that matches PATTERN, or #f if there is
- no match.."
- (find (entry-predicate pattern)
- (manifest-entries manifest)))
- (define (manifest-installed? manifest pattern)
- "Return #t if MANIFEST has an entry matching PATTERN (a manifest-pattern),
- #f otherwise."
- (->bool (manifest-lookup manifest pattern)))
- (define (manifest-matching-entries manifest patterns)
- "Return all the entries of MANIFEST that match one of the PATTERNS. Raise
- an '&unmatched-pattern-error' if none of the entries of MANIFEST matches one
- of PATTERNS."
- (fold-right (lambda (pattern matches)
- (match (filter (entry-predicate pattern)
- (manifest-entries manifest))
- (()
- (raise (condition
- (&unmatched-pattern-error
- (pattern pattern)
- (manifest manifest)))))
- (lst
- (append lst matches))))
- '()
- patterns))
- (define (manifest-search-paths manifest)
- "Return the list of search path specifications that apply to MANIFEST,
- including the search path specification for $PATH."
- (delete-duplicates
- (cons $PATH
- (append-map manifest-entry-search-paths
- (manifest-entries manifest)))))
- (define-record-type* <manifest-transaction> manifest-transaction
- make-manifest-transaction
- manifest-transaction?
- (install manifest-transaction-install
- (default '()))
- (remove manifest-transaction-remove
- (default '())))
- (define (manifest-transaction-install-entry entry transaction)
- "Augment TRANSACTION's set of installed packages with ENTRY, a
- <manifest-entry>."
- (manifest-transaction
- (inherit transaction)
- (install
- (cons entry (manifest-transaction-install transaction)))))
- (define (manifest-transaction-remove-pattern pattern transaction)
- "Add PATTERN to TRANSACTION's list of packages to remove."
- (manifest-transaction
- (inherit transaction)
- (remove
- (cons pattern (manifest-transaction-remove transaction)))))
- (define (manifest-transaction-null? transaction)
- "Return true if TRANSACTION has no effect---i.e., it neither installs nor
- remove software."
- (match transaction
- (($ <manifest-transaction> () ()) #t)
- (($ <manifest-transaction> _ _) #f)))
- (define (manifest-transaction-removal-candidate? entry transaction)
- "Return true if ENTRY is a candidate for removal in TRANSACTION."
- (any (lambda (pattern)
- ((entry-predicate pattern) entry))
- (manifest-transaction-remove transaction)))
- (define (manifest-transaction-effects manifest transaction)
- "Compute the effect of applying TRANSACTION to MANIFEST. Return 4 values:
- the list of packages that would be removed, installed, upgraded, or downgraded
- when applying TRANSACTION to MANIFEST. Upgrades are represented as pairs
- where the head is the entry being upgraded and the tail is the entry that will
- replace it."
- (define (manifest-entry->pattern entry)
- (manifest-pattern
- (name (manifest-entry-name entry))
- (output (manifest-entry-output entry))))
- (define manifest-entry-pair=?
- (match-lambda*
- (((m1a . m2a) (m1b . m2b))
- (and (manifest-entry=? m1a m1b)
- (manifest-entry=? m2a m2b)))
- (_ #f)))
- (let loop ((input (manifest-transaction-install transaction))
- (install '())
- (upgrade '())
- (downgrade '()))
- (match input
- (()
- (let ((remove (manifest-transaction-remove transaction)))
- (values (delete-duplicates
- (manifest-matching-entries manifest remove)
- manifest-entry=?)
- (delete-duplicates (reverse install) manifest-entry=?)
- (delete-duplicates
- (reverse upgrade)
- manifest-entry-pair=?)
- (delete-duplicates
- (reverse downgrade)
- manifest-entry-pair=?))))
- ((entry rest ...)
-
-
-
-
- (let* ((pattern (manifest-entry->pattern entry))
- (previous (manifest-lookup manifest pattern))
- (newer? (and previous
- (version>=? (manifest-entry-version entry)
- (manifest-entry-version previous)))))
- (loop rest
- (if previous install (cons entry install))
- (if (and previous newer?)
- (alist-cons previous entry upgrade)
- upgrade)
- (if (and previous (not newer?))
- (alist-cons previous entry downgrade)
- downgrade)))))))
- (define (manifest-perform-transaction manifest transaction)
- "Perform TRANSACTION on MANIFEST and return the new manifest."
- (let ((install (manifest-transaction-install transaction))
- (remove (manifest-transaction-remove transaction)))
- (manifest-add (manifest-remove manifest remove)
- install)))
- (define (manifest-inputs manifest)
- "Return a list of <gexp-input> objects for MANIFEST."
- (define entry->input
- (match-lambda
- (($ <manifest-entry> name version output thing deps)
-
-
- (cons (gexp-input thing output)
- (append-map entry->input deps)))))
- (append-map entry->input (manifest-entries manifest)))
- (define* (manifest-lookup-package manifest name #:optional version)
- "Return as a monadic value the first package or store path referenced by
- MANIFEST that is named NAME and optionally has the given VERSION prefix, or #f
- if not found."
-
-
- (define (entry-lookup-package entry)
- (define (find-among-inputs inputs)
- (find (lambda (input)
- (and (package? input)
- (equal? name (package-name input))
- (if version
- (string-prefix? version (package-version input))
- #t)))
- inputs))
- (define (find-among-store-items items)
- (find (lambda (item)
- (let-values (((name* version*)
- (package-name->name+version
- (store-path-package-name item))))
- (and (string=? name name*)
- (if version
- (string-prefix? version version*)
- #t))))
- items))
- (with-monad %store-monad
- (match (manifest-entry-item entry)
- ((? package? package)
- (match (cons (list (package-name package) package)
- (package-transitive-inputs package))
- (((labels inputs . _) ...)
- (return (find-among-inputs inputs)))))
- ((? string? item)
- (mlet %store-monad ((refs (references* item)))
- (return (find-among-store-items refs))))
- (item
-
-
-
-
- (return #f)))))
- (anym %store-monad
- entry-lookup-package (manifest-entries manifest)))
- (define (info-dir-file manifest)
- "Return a derivation that builds the 'dir' file for all the entries of
- MANIFEST."
- (define texinfo
- (module-ref (resolve-interface '(gnu packages texinfo)) 'texinfo))
- (define gzip
- (module-ref (resolve-interface '(gnu packages compression)) 'gzip))
- (define glibc-utf8-locales
- (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales))
- (define build
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils)
- (srfi srfi-1) (srfi srfi-26)
- (ice-9 ftw))
- (define (info-file? file)
- (or (string-suffix? ".info" file)
- (string-suffix? ".info.gz" file)))
- (define (info-files top)
- (let ((infodir (string-append top "/share/info")))
- (map (cut string-append infodir "/" <>)
- (or (scandir infodir info-file?) '()))))
- (define (info-file-language file)
- (let* ((base (if (string-suffix? ".gz" file)
- (basename file ".info.gz")
- (basename file ".info")))
- (dot (string-rindex base #\.)))
- (if dot
- (string-drop base (+ 1 dot))
- "en")))
- (define (install-info info)
- (let ((language (info-file-language info)))
-
- (setenv "LC_ALL" "en_US.utf8")
- (setenv "LANGUAGE" language)
- (zero?
- (system* #+(file-append texinfo "/bin/install-info")
- "--silent" info
- (apply string-append #$output "/share/info/dir"
- (if (string=? "en" language)
- '("")
- `("." ,language)))))))
- (setenv "PATH" (string-append #+gzip "/bin"))
- (setenv "GUIX_LOCPATH"
- #+(file-append glibc-utf8-locales "/lib/locale"))
- (mkdir-p (string-append #$output "/share/info"))
- (exit (every install-info
- (append-map info-files
- '#$(manifest-inputs manifest)))))))
- (gexp->derivation "info-dir" build
- #:local-build? #t
- #:substitutable? #f
- #:properties
- `((type . profile-hook)
- (hook . info-dir))))
- (define (ghc-package-cache-file manifest)
- "Return a derivation that builds the GHC 'package.cache' file for all the
- entries of MANIFEST, or #f if MANIFEST does not have any GHC packages."
- (define ghc
- (module-ref (resolve-interface '(gnu packages haskell)) 'ghc))
- (define build
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils)
- (srfi srfi-1) (srfi srfi-26)
- (ice-9 ftw))
- (define ghc-name-version
- (let* ((base (basename #+ghc)))
- (string-drop base
- (+ 1 (string-index base #\-)))))
- (define db-subdir
- (string-append "lib/" ghc-name-version "/package.conf.d"))
- (define db-dir
- (string-append #$output "/" db-subdir))
- (define (conf-files top)
- (let ((db (string-append top "/" db-subdir)))
- (if (file-exists? db)
- (find-files db "\\.conf$")
- '())))
- (define (copy-conf-file conf)
- (let ((base (basename conf)))
- (copy-file conf (string-append db-dir "/" base))))
- (system* (string-append #+ghc "/bin/ghc-pkg") "init" db-dir)
- (for-each copy-conf-file
- (append-map conf-files
- (delete-duplicates
- '#$(manifest-inputs manifest))))
- (let ((success
- (zero?
- (system* (string-append #+ghc "/bin/ghc-pkg") "recache"
- (string-append "--package-db=" db-dir)))))
- (for-each delete-file (find-files db-dir "\\.conf$"))
- (exit success)))))
- (with-monad %store-monad
-
- (if (any (cut string-prefix? "ghc" <>)
- (map manifest-entry-name (manifest-entries manifest)))
- (gexp->derivation "ghc-package-cache" build
- #:local-build? #t
- #:substitutable? #f
- #:properties
- `((type . profile-hook)
- (hook . ghc-package-cache)))
- (return #f))))
- (define (ca-certificate-bundle manifest)
- "Return a derivation that builds a single-file bundle containing the CA
- certificates in the /etc/ssl/certs sub-directories of the packages in
- MANIFEST. Single-file bundles are required by programs such as Git and Lynx."
-
-
- (define glibc-utf8-locales
- (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales))
- (define build
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils)
- (rnrs io ports)
- (srfi srfi-1)
- (srfi srfi-26)
- (ice-9 ftw)
- (ice-9 match))
- (define (pem-file? file)
- (string-suffix? ".pem" file))
- (define (ca-files top)
- (let ((cert-dir (string-append top "/etc/ssl/certs")))
- (map (cut string-append cert-dir "/" <>)
- (or (scandir cert-dir pem-file?) '()))))
- (define (concatenate-files files result)
- "Make RESULT the concatenation of all of FILES."
- (define (dump file port)
- (display (call-with-input-file file get-string-all)
- port)
- (newline port))
- (call-with-output-file result
- (lambda (port)
- (for-each (cut dump <> port) files))))
-
-
- (setenv "LOCPATH"
- (string-append #+glibc-utf8-locales "/lib/locale/"
- #+(version-major+minor
- (package-version glibc-utf8-locales))))
- (setlocale LC_ALL "en_US.utf8")
- (match (append-map ca-files '#$(manifest-inputs manifest))
- (()
-
-
-
-
- (mkdir #$output)
- #t)
- ((ca-files ...)
- (let ((result (string-append #$output "/etc/ssl/certs")))
- (mkdir-p result)
- (concatenate-files ca-files
- (string-append result
- "/ca-certificates.crt"))
- #t))))))
- (gexp->derivation "ca-certificate-bundle" build
- #:local-build? #t
- #:substitutable? #f
- #:properties
- `((type . profile-hook)
- (hook . ca-certificate-bundle))))
- (define (glib-schemas manifest)
- "Return a derivation that unions all schemas from manifest entries and
- creates the Glib 'gschemas.compiled' file."
- (define glib
- (module-ref (resolve-interface '(gnu packages glib)) 'glib))
- (mlet %store-monad ((%glib (manifest-lookup-package manifest "glib"))
-
-
-
-
- (glib-compile-schemas
- -> #~(string-append #+glib:bin
- "/bin/glib-compile-schemas")))
- (define build
- (with-imported-modules '((guix build utils)
- (guix build union)
- (guix build profiles)
- (guix search-paths)
- (guix records))
- #~(begin
- (use-modules (guix build utils)
- (guix build union)
- (guix build profiles)
- (srfi srfi-26))
- (let* ((destdir (string-append #$output "/share/glib-2.0/schemas"))
- (schemadirs (filter file-exists?
- (map (cut string-append <> "/share/glib-2.0/schemas")
- '#$(manifest-inputs manifest)))))
-
- (mkdir-p (string-append #$output "/share/glib-2.0"))
- (union-build destdir schemadirs
- #:log-port (%make-void-port "w"))
- (let ((dir destdir))
- (when (file-is-directory? dir)
- (ensure-writable-directory dir)
- (invoke #+glib-compile-schemas
- (string-append "--targetdir=" dir)
- dir)))))))
-
- (if %glib
- (gexp->derivation "glib-schemas" build
- #:local-build? #t
- #:substitutable? #f
- #:properties
- `((type . profile-hook)
- (hook . glib-schemas)))
- (return #f))))
- (define (gtk-icon-themes manifest)
- "Return a derivation that unions all icon themes from manifest entries and
- creates the GTK+ 'icon-theme.cache' file for each theme."
- (define gtk+
- (module-ref (resolve-interface '(gnu packages gtk)) 'gtk+))
- (mlet %store-monad ((%gtk+ (manifest-lookup-package manifest "gtk+"))
-
-
-
-
- (gtk-update-icon-cache
- -> #~(string-append #+gtk+:bin
- "/bin/gtk-update-icon-cache")))
- (define build
- (with-imported-modules '((guix build utils)
- (guix build union)
- (guix build profiles)
- (guix search-paths)
- (guix records))
- #~(begin
- (use-modules (guix build utils)
- (guix build union)
- (guix build profiles)
- (srfi srfi-26)
- (ice-9 ftw))
- (let* ((destdir (string-append #$output "/share/icons"))
- (icondirs (filter file-exists?
- (map (cut string-append <> "/share/icons")
- '#$(manifest-inputs manifest)))))
-
- (mkdir-p (string-append #$output "/share"))
- (union-build destdir icondirs
- #:log-port (%make-void-port "w"))
-
- (for-each
- (lambda (theme)
- (let ((dir (string-append destdir "/" theme)))
-
-
- (when (file-is-directory? dir)
- (ensure-writable-directory dir)
- (system* #+gtk-update-icon-cache "-t" dir "--quiet"))))
- (scandir destdir (negate (cut member <> '("." "..")))))))))
-
- (if %gtk+
- (gexp->derivation "gtk-icon-themes" build
- #:local-build? #t
- #:substitutable? #f
- #:properties
- `((type . profile-hook)
- (hook . gtk-icon-themes)))
- (return #f))))
- (define (gtk-im-modules manifest)
- "Return a derivation that builds the cache files for input method modules
- for both major versions of GTK+."
- (mlet %store-monad ((gtk+ (manifest-lookup-package manifest "gtk+" "3"))
- (gtk+-2 (manifest-lookup-package manifest "gtk+" "2")))
- (define (build gtk gtk-version query)
- (let ((major (string-take gtk-version 1)))
- (with-imported-modules '((guix build utils)
- (guix build union)
- (guix build profiles)
- (guix search-paths)
- (guix records))
- #~(begin
- (use-modules (guix build utils)
- (guix build union)
- (guix build profiles)
- (ice-9 popen)
- (srfi srfi-1)
- (srfi srfi-26))
- (let* ((prefix (string-append "/lib/gtk-" #$major ".0/"
- #$gtk-version))
- (destdir (string-append #$output prefix))
- (moddirs (cons (string-append #$gtk prefix "/immodules")
- (filter file-exists?
- (map (cut string-append <> prefix "/immodules")
- '#$(manifest-inputs manifest)))))
- (modules (append-map (cut find-files <> "\\.so$")
- moddirs)))
-
- (mkdir-p (string-append #$output prefix))
- (let ((pipe (apply open-pipe* OPEN_READ #$query modules))
- (outfile (string-append #$output prefix
- "/immodules-gtk" #$major ".cache")))
- (dynamic-wind
- (const #t)
- (lambda ()
- (call-with-output-file outfile
- (lambda (out)
- (while (not (eof-object? (peek-char pipe)))
- (write-char (read-char pipe) out))))
- #t)
- (lambda ()
- (close-pipe pipe)))))))))
-
- (let* ((pkg-gtk+ (module-ref
- (resolve-interface '(gnu packages gtk)) 'gtk+))
- (pkg-gtk+2 (module-ref
- (resolve-interface '(gnu packages gtk)) 'gtk+-2))
- (gexp #~(begin
- #$(if gtk+
- (build
- gtk+ "3.0.0"
-
-
- #~(string-append
- #$pkg-gtk+:bin "/bin/gtk-query-immodules-3.0"))
- #t)
- #$(if gtk+-2
- (build
- gtk+-2 "2.10.0"
- #~(string-append
- #$pkg-gtk+2:bin "/bin/gtk-query-immodules-2.0"))
- #t))))
- (if (or gtk+ gtk+-2)
- (gexp->derivation "gtk-im-modules" gexp
- #:local-build? #t
- #:substitutable? #f
- #:properties
- `((type . profile-hook)
- (hook . gtk-im-modules)))
- (return #f)))))
- (define (linux-module-database manifest)
- "Return a derivation that unites all the kernel modules of the manifest
- and creates the dependency graph of all these kernel modules.
- This is meant to be used as a profile hook."
- (define kmod
- (module-ref (resolve-interface '(gnu packages linux)) 'kmod))
- (define guile-zlib
- (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib))
- (define build
- (with-imported-modules (source-module-closure
- '((guix build utils)
- (gnu build linux-modules)))
- (with-extensions (list guile-zlib)
- #~(begin
- (use-modules (ice-9 ftw)
- (ice-9 match)
- (srfi srfi-1)
- (gnu build linux-modules))
- (let* ((inputs '#$(manifest-inputs manifest))
- (module-directories
- (map (lambda (directory)
- (string-append directory "/lib/modules"))
- inputs))
- (directory-entries
- (lambda (directory)
- (or (scandir directory
- (lambda (basename)
- (not (string-prefix? "." basename))))
- '())))
-
- (versions (delete-duplicates
- (append-map directory-entries
- module-directories))))
- (match versions
- ((version)
- (let ((old-path (getenv "PATH")))
- (setenv "PATH" #+(file-append kmod "/bin"))
- (make-linux-module-directory inputs version #$output)
- (setenv "PATH" old-path)))
- (()
-
-
- (mkdir #$output))
- (_ (error "Specified Linux kernel and Linux kernel modules
- are not all of the same version"))))))))
- (gexp->derivation "linux-module-database" build
- #:local-build? #t
- #:substitutable? #f
- #:properties
- `((type . profile-hook)
- (hook . linux-module-database))))
- (define (xdg-desktop-database manifest)
- "Return a derivation that builds the @file{mimeinfo.cache} database from
- desktop files. It's used to query what applications can handle a given
- MIME type."
- (define desktop-file-utils
- (module-ref (resolve-interface '(gnu packages freedesktop))
- 'desktop-file-utils))
- (mlet %store-monad ((glib
- (manifest-lookup-package
- manifest "glib")))
- (define build
- (with-imported-modules '((guix build utils)
- (guix build union))
- #~(begin
- (use-modules (srfi srfi-26)
- (guix build utils)
- (guix build union))
- (let* ((destdir (string-append #$output "/share/applications"))
- (appdirs (filter file-exists?
- (map (cut string-append <>
- "/share/applications")
- '#$(manifest-inputs manifest))))
- (update-desktop-database (string-append
- #+desktop-file-utils
- "/bin/update-desktop-database")))
- (mkdir-p (string-append #$output "/share"))
- (union-build destdir appdirs
- #:log-port (%make-void-port "w"))
- (exit (zero? (system* update-desktop-database destdir)))))))
-
- (if glib
- (gexp->derivation "xdg-desktop-database" build
- #:local-build? #t
- #:substitutable? #f
- #:properties
- `((type . profile-hook)
- (hook . xdg-desktop-database)))
- (return #f))))
- (define (xdg-mime-database manifest)
- "Return a derivation that builds the @file{mime.cache} database from manifest
- entries. It's used to query the MIME type of a given file."
- (define shared-mime-info
- (module-ref (resolve-interface '(gnu packages gnome)) 'shared-mime-info))
- (mlet %store-monad ((glib (manifest-lookup-package manifest "glib")))
- (define build
- (with-imported-modules '((guix build utils)
- (guix build union))
- #~(begin
- (use-modules (guix build utils)
- (guix build union)
- (srfi srfi-26)
- (ice-9 match))
- (let* ((datadir (string-append #$output "/share"))
- (destdir (string-append datadir "/mime"))
- (pkgdirs (filter file-exists?
- (map (cut string-append <>
- "/share/mime/packages")
- (cons #+shared-mime-info
- '#$(manifest-inputs manifest))))))
- (match pkgdirs
- ((shared-mime-info)
-
-
- (mkdir-p datadir)
- (symlink #$(file-append shared-mime-info "/share/mime")
- destdir))
- (_
-
-
-
-
- (mkdir-p destdir)
- (union-build (string-append destdir "/packages") pkgdirs
- #:log-port (%make-void-port "w"))
- (setenv "XDG_DATA_HOME" datadir)
- (invoke #+(file-append shared-mime-info
- "/bin/update-mime-database")
- destdir)))))))
-
- (if glib
- (gexp->derivation "xdg-mime-database" build
- #:local-build? #t
- #:substitutable? #f
- #:properties
- `((type . profile-hook)
- (hook . xdg-mime-database)))
- (return #f))))
- (define (fonts-dir-file manifest)
- "Return a derivation that builds the @file{fonts.dir} and @file{fonts.scale}
- files for the fonts of the @var{manifest} entries."
- (define mkfontscale
- (module-ref (resolve-interface '(gnu packages xorg)) 'mkfontscale))
- (define mkfontdir
- (module-ref (resolve-interface '(gnu packages xorg)) 'mkfontdir))
- (define build
- #~(begin
- (use-modules (srfi srfi-26)
- (guix build utils)
- (guix build union))
- (let ((fonts-dirs (filter file-exists?
- (map (cut string-append <>
- "/share/fonts")
- '#$(manifest-inputs manifest)))))
- (mkdir #$output)
- (if (null? fonts-dirs)
- (exit #t)
- (let* ((share-dir (string-append #$output "/share"))
- (fonts-dir (string-append share-dir "/fonts"))
- (mkfontscale (string-append #+mkfontscale
- "/bin/mkfontscale"))
- (mkfontdir (string-append #+mkfontdir
- "/bin/mkfontdir"))
- (empty-file? (lambda (filename)
- (call-with-ascii-input-file filename
- (lambda (p)
- (eqv? #\0 (read-char p))))))
- (fonts-dir-file "fonts.dir")
- (fonts-scale-file "fonts.scale"))
- (mkdir-p share-dir)
-
-
- (union-build fonts-dir fonts-dirs
- #:log-port (%make-void-port "w")
- #:create-all-directories? #t)
- (let ((directories (find-files fonts-dir
- (lambda (file stat)
- (eq? 'directory (stat:type stat)))
- #:directories? #t)))
- (for-each (lambda (dir)
- (with-directory-excursion dir
- (when (file-exists? fonts-scale-file)
- (delete-file fonts-scale-file))
- (when (file-exists? fonts-dir-file)
- (delete-file fonts-dir-file))
- (unless (and (zero? (system* mkfontscale))
- (zero? (system* mkfontdir)))
- (exit #f))
- (when (and (file-exists? fonts-scale-file)
- (empty-file? fonts-scale-file))
- (delete-file fonts-scale-file))
- (when (and (file-exists? fonts-dir-file)
- (empty-file? fonts-dir-file))
- (delete-file fonts-dir-file))))
- directories)))))))
- (gexp->derivation "fonts-dir" build
- #:modules '((guix build utils)
- (guix build union)
- (srfi srfi-26))
- #:local-build? #t
- #:substitutable? #f
- #:properties
- `((type . profile-hook)
- (hook . fonts-dir))))
- (define (manual-database manifest)
- "Return a derivation that builds the manual page database (\"mandb\") for
- the entries in MANIFEST."
- (define gdbm-ffi
- (module-ref (resolve-interface '(gnu packages guile))
- 'guile-gdbm-ffi))
- (define guile-zlib
- (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib))
- (define modules
- (delete '(guix config)
- (source-module-closure `((guix build utils)
- (guix man-db)))))
- (define build
- (with-imported-modules modules
- (with-extensions (list gdbm-ffi
- guile-zlib)
- #~(begin
- (use-modules (guix man-db)
- (guix build utils)
- (ice-9 threads)
- (srfi srfi-1)
- (srfi srfi-19))
- (define (print-string msg)
- (display msg)
- (force-output))
- (define-syntax-rule (print fmt args ...)
-
- (print-string (format #f fmt args ...)))
- (define (compute-entry directory count total)
- (print "\r[~3d/~3d] building list of man-db entries..."
- count total)
- (let ((man (string-append directory "/share/man")))
- (if (directory-exists? man)
- (mandb-entries man)
- '())))
- (define (compute-entries)
-
-
-
-
- (let* ((inputs '#$(manifest-inputs manifest))
- (total (length inputs))
- (threads (min (parallel-job-count) 4)))
- (concatenate
- (n-par-map threads compute-entry inputs
- (iota total 1)
- (make-list total total)))))
- (define man-directory
- (string-append #$output "/share/man"))
- (mkdir-p man-directory)
- (format #t "Creating manual page database...~%")
- (force-output)
- (let* ((start (current-time))
- (entries (compute-entries))
- (_ (write-mandb-database (string-append man-directory
- "/index.db")
- entries))
- (duration (time-difference (current-time) start)))
- (newline)
- (format #t "~a entries processed in ~,1f s~%"
- (length entries)
- (+ (time-second duration)
- (* (time-nanosecond duration) (expt 10 -9))))
- (force-output))))))
- (gexp->derivation "manual-database" build
-
-
-
- #:env-vars `(("MALLOC_PERTURB_" . "1"))
- #:substitutable? #f
- #:local-build? #t
- #:properties
- `((type . profile-hook)
- (hook . manual-database))))
- (define (texlive-configuration manifest)
- "Return a derivation that builds a TeXlive configuration for the entries in
- MANIFEST."
- (define entry->texlive-input
- (match-lambda
- (($ <manifest-entry> name version output thing deps)
- (if (string-prefix? "texlive-" name)
- (cons (gexp-input thing output)
- (append-map entry->texlive-input deps))
- '()))))
- (define build
- (with-imported-modules '((guix build utils)
- (guix build union))
- #~(begin
- (use-modules (guix build utils)
- (guix build union))
-
-
-
- (union-build #$output
- '#$(append-map entry->texlive-input
- (manifest-entries manifest))
- #:create-all-directories? #t
- #:log-port (%make-void-port "w"))
- (let ((texmf.cnf (string-append
- #$output
- "/share/texmf-dist/web2c/texmf.cnf")))
- (when (file-exists? texmf.cnf)
- (substitute* texmf.cnf
- (("^TEXMFROOT = .*")
- (string-append "TEXMFROOT = " #$output "/share\n"))
- (("^TEXMF = .*")
- "TEXMF = $TEXMFROOT/share/texmf-dist\n"))))
- #t)))
- (with-monad %store-monad
- (if (any (cut string-prefix? "texlive-" <>)
- (map manifest-entry-name (manifest-entries manifest)))
- (gexp->derivation "texlive-configuration" build
- #:substitutable? #f
- #:local-build? #t
- #:properties
- `((type . profile-hook)
- (hook . texlive-configuration)))
- (return #f))))
- (define %default-profile-hooks
-
-
- (list info-dir-file
- manual-database
- fonts-dir-file
- ghc-package-cache-file
- ca-certificate-bundle
- glib-schemas
- gtk-icon-themes
- gtk-im-modules
- texlive-configuration
- xdg-desktop-database
- xdg-mime-database))
- (define* (profile-derivation manifest
- #:key
- (name "profile")
- (hooks %default-profile-hooks)
- (locales? #t)
- (allow-collisions? #f)
- (relative-symlinks? #f)
- system target)
- "Return a derivation that builds a profile (aka. 'user environment') with
- the given MANIFEST. The profile includes additional derivations returned by
- the monadic procedures listed in HOOKS--such as an Info 'dir' file, etc.
- Unless ALLOW-COLLISIONS? is true, a '&profile-collision-error' is raised if
- entries in MANIFEST collide (for instance if there are two same-name packages
- with a different version number.)
- When LOCALES? is true, the build is performed under a UTF-8 locale; this adds
- a dependency on the 'glibc-utf8-locales' package.
- When RELATIVE-SYMLINKS? is true, use relative file names for symlink targets.
- This is one of the things to do for the result to be relocatable.
- When TARGET is true, it must be a GNU triplet, and the packages in MANIFEST
- are cross-built for TARGET."
- (mlet* %store-monad ((system (if system
- (return system)
- (current-system)))
- (target (if target
- (return target)
- (current-target-system)))
- (ok? (if allow-collisions?
- (return #t)
- (check-for-collisions manifest system
- #:target target)))
- (extras (if (null? (manifest-entries manifest))
- (return '())
- (mapm/accumulate-builds (lambda (hook)
- (hook manifest))
- hooks))))
- (define inputs
- (append (filter-map (lambda (drv)
- (and (derivation? drv)
- (gexp-input drv)))
- extras)
- (manifest-inputs manifest)))
- (define glibc-utf8-locales
- (module-ref (resolve-interface '(gnu packages base))
- 'glibc-utf8-locales))
- (define set-utf8-locale
-
-
- #~(begin
- (setenv "LOCPATH"
- #$(file-append glibc-utf8-locales "/lib/locale/"
- (version-major+minor
- (package-version glibc-utf8-locales))))
- (setlocale LC_ALL "en_US.utf8")))
- (define builder
- (with-imported-modules '((guix build profiles)
- (guix build union)
- (guix build utils)
- (guix search-paths)
- (guix records))
- #~(begin
- (use-modules (guix build profiles)
- (guix search-paths)
- (srfi srfi-1))
- (let ((line (cond-expand (guile-2.2 'line)
- (else _IOLBF))))
- (setvbuf (current-output-port) line)
- (setvbuf (current-error-port) line))
- #+(if locales? set-utf8-locale #t)
- (define search-paths
-
-
- (map sexp->search-path-specification
- (delete-duplicates
- '#$(map search-path-specification->sexp
- (manifest-search-paths manifest)))))
- (build-profile #$output '#$inputs
- #:symlink #$(if relative-symlinks?
- #~symlink-relative
- #~symlink)
- #:manifest '#$(manifest->gexp manifest)
- #:search-paths search-paths))))
- (gexp->derivation name builder
- #:system system
- #:target target
-
- #:env-vars '(("GUILE_WARN_DEPRECATED" . "no"))
-
- #:local-build? #t
-
-
-
- #:substitutable? #f
- #:properties `((type . profile)
- (profile
- (count
- . ,(length
- (manifest-entries manifest))))))))
- (define-record-type* <profile> profile make-profile
- profile?
- (name profile-name (default "profile"))
- (content profile-content)
- (hooks profile-hooks
- (default %default-profile-hooks))
- (locales? profile-locales?
- (default #t))
- (allow-collisions? profile-allow-collisions?
- (default #f))
- (relative-symlinks? profile-relative-symlinks?
- (default #f)))
- (define-gexp-compiler (profile-compiler (profile <profile>) system target)
- "Compile PROFILE to a derivation."
- (match profile
- (($ <profile> name manifest hooks
- locales? allow-collisions? relative-symlinks?)
- (profile-derivation manifest
- #:name name
- #:hooks hooks
- #:locales? locales?
- #:allow-collisions? allow-collisions?
- #:relative-symlinks? relative-symlinks?
- #:system system #:target target))))
- (define* (profile-search-paths profile
- #:optional (manifest (profile-manifest profile))
- #:key (getenv (const #f)))
- "Read the manifest of PROFILE and evaluate the values of search path
- environment variables required by PROFILE; return a list of
- specification/value pairs. If MANIFEST is not #f, it is assumed to be the
- manifest of PROFILE, which avoids rereading it.
- Use GETENV to determine the current settings and report only settings not
- already effective."
- (evaluate-search-paths (manifest-search-paths manifest)
- (list profile) getenv))
- (define (profile-regexp profile)
- "Return a regular expression that matches PROFILE's name and number."
- (make-regexp (string-append "^" (regexp-quote (basename profile))
- "-([0-9]+)")))
- (define (generation-number profile)
- "Return PROFILE's number or 0. An absolute file name must be used."
- (or (and=> (false-if-exception (regexp-exec (profile-regexp profile)
- (basename (readlink profile))))
- (compose string->number (cut match:substring <> 1)))
- 0))
- (define %profile-generation-rx
-
- (make-regexp "(.*)-([0-9]+)-link$"))
- (define (generation-profile file)
- "If FILE is a profile generation GC root such as \"guix-profile-42-link\",
- return its corresponding profile---e.g., \"guix-profile\". Otherwise return
- #f."
- (match (regexp-exec %profile-generation-rx file)
- (#f #f)
- (m (let ((profile (match:substring m 1)))
- (and (file-exists? (string-append profile "/manifest"))
- profile)))))
- (define (generation-numbers profile)
- "Return the sorted list of generation numbers of PROFILE, or '(0) if no
- former profiles were found."
- (match (scandir (dirname profile)
- (cute regexp-exec (profile-regexp profile) <>))
- (#f
- '(0))
- (()
- '(0))
- ((profiles ...)
- (sort (map (compose string->number
- (cut match:substring <> 1)
- (cute regexp-exec (profile-regexp profile) <>))
- profiles)
- <))))
- (define (profile-generations profile)
- "Return a list of PROFILE's generations."
- (let ((generations (generation-numbers profile)))
- (if (equal? generations '(0))
- '()
- generations)))
- (define (relative-generation-spec->number profile spec)
- "Return PROFILE's generation specified by SPEC, which is a string. The SPEC
- may be a N, -N, or +N, where N is a number. If the spec is N, then the number
- returned is N. If it is -N, then the number returned is the profile's current
- generation number minus N. If it is +N, then the number returned is the
- profile's current generation number plus N. Return #f if there is no such
- generation."
- (let ((number (string->number spec)))
- (and number
- (case (string-ref spec 0)
- ((#\+ #\-)
- (relative-generation profile number))
- (else (if (memv number (profile-generations profile))
- number
- #f))))))
- (define* (relative-generation profile shift #:optional
- (current (generation-number profile)))
- "Return PROFILE's generation shifted from the CURRENT generation by SHIFT.
- SHIFT is a positive or negative number.
- Return #f if there is no such generation."
- (let* ((abs-shift (abs shift))
- (numbers (profile-generations profile))
- (from-current (memq current
- (if (negative? shift)
- (reverse numbers)
- numbers))))
- (and from-current
- (< abs-shift (length from-current))
- (list-ref from-current abs-shift))))
- (define* (previous-generation-number profile #:optional
- (number (generation-number profile)))
- "Return the number of the generation before generation NUMBER of
- PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the
- case when generations have been deleted (there are \"holes\")."
- (or (relative-generation profile -1 number)
- 0))
- (define (generation-file-name profile generation)
- "Return the file name for PROFILE's GENERATION."
- (format #f "~a-~a-link" profile generation))
- (define (generation-time profile number)
- "Return the creation time of a generation in the UTC format."
- (make-time time-utc 0
- (stat:ctime (stat (generation-file-name profile number)))))
- (define (link-to-empty-profile store generation)
- "Link GENERATION, a string, to the empty profile. An error is raised if
- that fails."
- (let* ((drv (run-with-store store
- (profile-derivation (manifest '())
- #:locales? #f)))
- (prof (derivation->output-path drv "out")))
- (build-derivations store (list drv))
- (switch-symlinks generation prof)))
- (define (switch-to-generation profile number)
- "Atomically switch PROFILE to the generation NUMBER. Return the number of
- the generation that was current before switching."
- (let ((current (generation-number profile))
- (generation (generation-file-name profile number)))
- (cond ((not (file-exists? profile))
- (raise (condition (&profile-not-found-error
- (profile profile)))))
- ((not (file-exists? generation))
- (raise (condition (&missing-generation-error
- (profile profile)
- (generation number)))))
- (else
- (switch-symlinks profile (basename generation))
- current))))
- (define (switch-to-previous-generation profile)
- "Atomically switch PROFILE to the previous generation. Return the former
- generation number and the current one."
- (let ((previous (previous-generation-number profile)))
- (values (switch-to-generation profile previous)
- previous)))
- (define (roll-back store profile)
- "Roll back to the previous generation of PROFILE. Return the number of the
- generation that was current before switching and the new generation number."
- (let* ((number (generation-number profile))
- (previous-number (previous-generation-number profile number))
- (previous-generation (generation-file-name profile previous-number)))
- (cond ((not (file-exists? profile))
- (raise (condition (&profile-not-found-error
- (profile profile)))))
- ((zero? number)
- (values number number))
- ((or (zero? previous-number)
- (not (file-exists? previous-generation)))
- (link-to-empty-profile store previous-generation)
- (switch-to-previous-generation profile))
- (else
- (switch-to-previous-generation profile)))))
- (define (delete-generation store profile number)
- "Delete generation with NUMBER from PROFILE. Return the file name of the
- generation that has been deleted, or #f if nothing was done (for instance
- because the NUMBER is zero.)"
- (define (delete-and-return)
- (let ((generation (generation-file-name profile number)))
- (delete-file generation)
- generation))
- (let* ((current-number (generation-number profile))
- (previous-number (previous-generation-number profile number))
- (previous-generation (generation-file-name profile previous-number)))
- (cond ((zero? number) #f)
- ((and (= number current-number)
- (not (file-exists? previous-generation)))
- (link-to-empty-profile store previous-generation)
- (switch-to-previous-generation profile)
- (delete-and-return))
- ((= number current-number)
- (roll-back store profile)
- (delete-and-return))
- (else
- (delete-and-return)))))
- (define %user-profile-directory
- (and=> (getenv "HOME")
- (cut string-append <> "/.guix-profile")))
- (define %profile-directory
- (string-append %state-directory "/profiles/"
- (or (and=> (or (getenv "USER")
- (getenv "LOGNAME")
- (false-if-exception
- (passwd:name (getpwuid (getuid)))))
- (cut string-append "per-user/" <>))
- "default")))
- (define %current-profile
-
-
- (string-append %profile-directory "/guix-profile"))
- (define (ensure-profile-directory)
- "Attempt to create /…/profiles/per-user/$USER if needed. Nowadays this is
- taken care of by the daemon."
- (let ((s (stat %profile-directory #f)))
- (unless (and s (eq? 'directory (stat:type s)))
- (catch 'system-error
- (lambda ()
- (mkdir-p %profile-directory))
- (lambda args
-
-
-
- (raise (condition
- (&message
- (message
- (format #f
- (G_ "while creating directory `~a': ~a")
- %profile-directory
- (strerror (system-error-errno args)))))
- (&fix-hint
- (hint
- (format #f (G_ "Please create the @file{~a} directory, \
- with you as the owner.")
- %profile-directory))))))))
-
- (unless (or (not s) (= (stat:uid s) (getuid)))
- (raise (condition
- (&message
- (message
- (format #f (G_ "directory `~a' is not owned by you")
- %profile-directory)))
- (&fix-hint
- (hint
- (format #f (G_ "Please change the owner of @file{~a} \
- to user ~s.")
- %profile-directory (or (getenv "USER")
- (getenv "LOGNAME")
- (getuid))))))))))
- (define (canonicalize-profile profile)
- "If PROFILE points to a profile in %PROFILE-DIRECTORY, return that.
- Otherwise return PROFILE unchanged. The goal is to treat '-p ~/.guix-profile'
- as if '-p' was omitted."
-
- (let ((profile (string-trim-right profile #\/)))
- (catch 'system-error
- (lambda ()
- (let ((target (readlink profile)))
- (if (string=? (dirname target) %profile-directory)
- target
- profile)))
- (const profile))))
- (define %known-shorthand-profiles
-
- (list (string-append (config-directory #:ensure? #f) "/current")
- %user-profile-directory))
- (define (user-friendly-profile profile)
- "Return either ~/.guix-profile or ~/.config/guix/current if that's what
- PROFILE refers to, directly or indirectly, or PROFILE."
- (or (find (lambda (shorthand)
- (and shorthand
- (let ((target (false-if-exception
- (readlink shorthand))))
- (and target (string=? target profile)))))
- %known-shorthand-profiles)
- profile))
|