diff --git a/pkgs/distro-build/info.rkt b/pkgs/distro-build/info.rkt index 1189b0a..5c19cc8 100644 --- a/pkgs/distro-build/info.rkt +++ b/pkgs/distro-build/info.rkt @@ -5,4 +5,5 @@ (define deps '("base" "at-exp-lib" "web-server-lib" - "scribble-lib")) + "scribble-lib" + "ds-store-lib")) diff --git a/pkgs/distro-build/installer-dmg.rkt b/pkgs/distro-build/installer-dmg.rkt index 4657b9d..0b9c880 100644 --- a/pkgs/distro-build/installer-dmg.rkt +++ b/pkgs/distro-build/installer-dmg.rkt @@ -2,9 +2,12 @@ (require racket/system racket/file racket/format - racket/runtime-path) + racket/runtime-path + ds-store + ds-store/alias) -(provide installer-dmg) +(provide installer-dmg + make-dmg) (define hdiutil "/usr/bin/hdiutil") @@ -27,7 +30,7 @@ (copy-directory/files src-dir (build-path work-dir volname) #:keep-modify-seconds? #t) (when bg - (copy-file bg (build-path work-dir "bg.png"))) + (copy-file bg (build-path work-dir ".bg.png"))) ;; The following command should work fine, but it looks like hdiutil in 10.4 ;; is miscalculating the needed size, making it too big in our case (and too ;; small with >8GB images). It seems that it works to first generate an @@ -42,7 +45,7 @@ tmp-dmg)) ;; Then do the expected dmg layout... (when bg - (dmg-layout tmp-dmg volname "bg.png")) + (dmg-layout tmp-dmg volname ".bg.png")) ;; And create the compressed image from the uncompressed image: (system*/show hdiutil "convert" "-format" "UDBZ" "-imagekey" "zlib-level=9" "-ov" @@ -50,68 +53,45 @@ (delete-file tmp-dmg)) (define (dmg-layout dmg volname bg) - (define mnt (make-temporary-file "~a-mnt" 'directory)) + (define-values (mnt del?) + (let ([preferred (build-path "/Volumes/" volname)]) + (if (not (directory-exists? preferred)) + ;; Use the preferred path so that the alias is as + ;; clean as possible: + (values preferred #f) + ;; fall back to using a temporary directory + (values (make-temporary-file "~a-mnt" 'directory) #t)))) (system*/show hdiutil "attach" "-readwrite" "-noverify" "-noautoopen" "-mountpoint" mnt dmg) - (define mnt-name (let-values ([(base name dir?) (split-path mnt)]) (path->string name))) - ;; See also https://github.com/andreyvit/yoursway-create-dmg - ;; First, give Finder a chance to see the new disk: - (define script - @~a{ - tell application "Finder" - -- look for a single disk with the mount point as its name - -- (maybe this works only on newer osx versions?) - set theDMGDisk to "" - repeat while theDMGDisk = "" - set myDisks to every disk - repeat with d in myDisks - if name of d = "@mnt-name" - if theDMGDisk = "" - set theDMGDisk to d - else - error "Too many attached DMGs found!" - end if - end if - end repeat - -- not found? maybe Finder wasn't ready - if theDMGDisk = "" then delay 1 - end repeat - if theDMGDisk = "" then error "Attached DMG not found!" - -- found a single matching disk, continue - tell theDMGDisk - open - set current view of container window to icon view - set toolbar visible of container window to false - set statusbar visible of container window to false - set bounds of container window to {320, 160, 1000, 540} - set theViewOptions to the icon view options of container window - set arrangement of theViewOptions to not arranged - set icon size of theViewOptions to 128 - set text size of theViewOptions to 16 - set background picture of theViewOptions to file "@bg" - make new alias file at container window to POSIX file "/Applications" with properties {name:"Applications"} - set position of item "@volname" of container window to {170, 180} - set position of item "@bg" of container window to {900, 180} - set position of item "Applications" of container window to {500, 180} - set name of file "@bg" to ".@bg" - close - open - update without registering applications - delay 5 - close - end tell - end tell - }) - (printf "~a\n" script) - (parameterize ([current-input-port (open-input-string script)]) - (system* "/usr/bin/osascript")) - (system*/show "/bin/sync") - (system*/show "/bin/sync") - (system*/show "/bin/sync") - (system*/show "/bin/sync") + (define alias (path->alias-bytes (build-path mnt bg) + #:wrt mnt)) + (make-file-or-directory-link "/Applications" (build-path mnt "Applications")) + (define (->path s) (string->path s)) + (write-ds-store (build-path mnt ".DS_Store") + (list + (ds 'same 'BKGD 'blob + (bytes-append #"PctB" + (integer->integer-bytes (bytes-length alias) 4 #t #t) + (make-bytes 4 0))) + (ds 'same 'ICVO 'bool #t) + (ds 'same 'fwi0 'blob + ;; Window location (size overridden below), sideview off: + (fwind 160 320 540 1000 'icnv #f)) + (ds 'same 'fwsw 'long 135) ; window sideview width? + (ds 'same 'fwsh 'long 380) ; window sideview height? + (ds 'same 'icgo 'blob #"\0\0\0\0\0\0\0\4") ; ??? + (ds 'same 'icvo 'blob + ;; folder view options: + #"icv4\0\200nonebotm\0\0\0\0\0\0\0\0\0\4\0\0") + (ds 'same 'icvt 'shor 16) ; icon label size + (ds 'same 'pict 'blob alias) + (ds (->path ".bg.png") 'Iloc 'blob (iloc 900 180)) ; file is hidden, anway + (ds (->path "Applications") 'Iloc 'blob (iloc 500 180)) + (ds (->path volname) 'Iloc 'blob (iloc 170 180)))) (system*/show hdiutil "detach" mnt) - (delete-directory mnt)) + (when del? + (delete-directory mnt))) (define (installer-dmg human-name base-name dist-suffix) (define dmg-name (format "bundle/~a-~a~a.dmg"