suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Mac OS X installers: use "ds-store" package instead of scripting Finder

Browse Source 
The Mac OS X "installers" are just ".dmg" files with a particular
layout and background image, which are record in a ".DS_Store" file
in the disk image. We have been generating a ".DS_Store" file through
an AppleScript program and Finder, but that script has been fragile,
and the result depends on the version of Mac OS used to generate
the image (e.g., an imagine generated on 10.7 does not look right
on 10.5).

A new `ds-store' library can write ".DS_Store" files directly,
and it uses a format that is compatible with old Mac OS X versions.
This commit is contained in:
Matthew Flatt 2013-07-15 19:15:13 -06:00
parent 691a6303eb
commit b3390a7e2a
9 changed files with 578 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
pkgs/distro-build/info.rkt
View File

@ -5,4 +5,5 @@
(define deps '("base"
"at-exp-lib"
"web-server-lib"
"scribble-lib"))
"scribble-lib"
"ds-store-lib"))

104
pkgs/distro-build/installer-dmg.rkt
View File

@ -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"

98
pkgs/ds-store-pkgs/ds-store-doc/ds-store.scrbl Normal file
View File

@ -0,0 +1,98 @@
#lang scribble/manual
@(require (for-label ds-store
ds-store/alias
racket/base
racket/contract/base))
@title{Reading Writing @filepath{.DS_Store} Files}
A @filepath{.DS_Store} file is a metadata file on Mac OS X that holds
information about folder and icons as viewed and manipulated in
Finder. One common reason to manipulate @filepath{.DS_Store} files
is to create a nice-looking disk image for a Mac OS X installer.
@filepath{.DS_Store} reading nd writing is based on a
reverse-engineered description of the file format @cite["DS_Store"].
@section[#:tag "ds-store-api"]{@filepath{.DS_Store} Files and Entries}
@defmodule[ds-store]
@defproc[(read-ds-store [path path-string?]
[#:verbose verbose? any/c #f])
(listof ds?)]{
Reads the @filepath{.DS_Store} file at @racket[path] returning a list
of store items.}
@defproc[(write-ds-store [path path-string?]
[dses (listof ds?)])
void?]{
Writes @racket[dses] to the @filepath{.DS_Store} file at
@racket[path], replacing the file's current content.}
@defstruct*[ds ([path (or/c path-element? 'same)]
[id symbol?]
[type (or/c 'long 'shor 'bool 'type 'ustr 'blob)]
[data (or/c exact-integer? boolean? symbol? string?
bytes? iloc? fwind?)])
#:transparent]{
Represents a entry in a @filepath{.DS_Store} file. A
@filepath{.DS_Store} file typically has multiple entries for a single
file or directory in the same directory as the @filepath{.DS_Store}.
The @racket[path] should be @racket['same] only for a volume root
directory; information about a directory is otherwise recorded in its
parent directory's @filepath{.DS_Store} file.
The @racket[id] symbols should each have four ASCII characters. See
the @filepath{.DS_Store} format description @cite["DS_Store"] for more
information @racket[id] and @racket[type] values.
The @racket[data] field long should be an exact integer for
@racket['long] and @racket['shor] types, a boolean for the
@racket['bool] type, a 4-character ASCII symbol for the @racket['type]
type, a string for the @racket['ustr] type, and either a byte string,
@racket[iloc], or @racket[fwind] for the @racket['blob] type.}
@defstruct*[iloc ([x exact-integer?] [y exact-integer?]) #:transparent]{
Represents an icon location for an @racket['Iloc] entry.}
@defstruct*[fwind ([t exact-integer?]
[l exact-integer?]
[b exact-integer?]
[r exact-integer?]
[mode symbol?]
[sideview? any/c])
#:transparent]{
Represent a window location for a @racket['fwi0] entry. The
@racket[mode] field should have four ASCII characters, and recognized
@racket[mode]s include @racket['icnv], @racket['clmv], and
@racket['Nlsv].}
@; ----------------------------------------
@section[#:tag "aliases"]{Finder Aliases}
A @racket['pict] entry in a @filepath{.DS_Store} file references a
file through a Finder alias.
@defmodule[ds-store/alias]
@defproc[(path->alias-bytes [path path-string?]
[#:wrt wrt-dir (or/c #f path-string?) #f])
(or/c bytes? #f)]{
Constructs a byte string to represent a Finder alias but using the
@filepath{CoreFoundation} library on Mac OS X.}
@; ----------------------------------------
@bibliography[(bib-entry #:key "DS_Store"
#:title "DS_Store Format"
#:author "Wim Lewis and Mark Mentovai"
#:url "http://search.cpan.org/~wiml/Mac-Finder-DSStore/DSStoreFormat.pod")]

10
pkgs/ds-store-pkgs/ds-store-doc/info.rkt Normal file
View File

@ -0,0 +1,10 @@
#lang info
(define collection "ds-store")
(define deps '("base"
"scribble-lib"
"racket-doc"
"ds-store-lib"))
(define scribblings '(("ds-store.scrbl")))

42
pkgs/ds-store-pkgs/ds-store-lib/alias.rkt Normal file
View File

@ -0,0 +1,42 @@
#lang racket/base
(require ffi/unsafe)
(provide path->alias-bytes)
(define CoreServices
(ffi-lib "/System/Library/Frameworks/CoreServices.framework/CoreServices"
#:fail (lambda () #f)))
(define (make-unavailable)
(lambda args (error "unavailable")))
(define FSNewAliasFromPath
(get-ffi-obj 'FSNewAliasFromPath
CoreServices
(_fun _path _path _int (h : (_ptr o _pointer)) (_ptr io _int) -> (r : _int) -> (if (zero? r) h #f))
make-unavailable))
(define GetAliasSize
(get-ffi-obj 'GetAliasSize
CoreServices
(_fun _pointer -> _long)
make-unavailable))
(define DisposeHandle
(get-ffi-obj 'DisposeHandle
CoreServices
(_fun _pointer -> _void)
make-unavailable))
(define (path->alias-bytes file
#:wrt [wrt #f])
(define h
(FSNewAliasFromPath wrt
file
0
0))
(and h
(let ([sz (GetAliasSize h)])
(define bstr (make-bytes sz))
(memcpy bstr (ptr-ref h _pointer) sz)
(begin0
bstr
(DisposeHandle h)))))

5
pkgs/ds-store-pkgs/ds-store-lib/info.rkt Normal file
View File

@ -0,0 +1,5 @@
#lang info
(define collection "ds-store")
(define deps '("base"))

368
pkgs/ds-store-pkgs/ds-store-lib/main.rkt Normal file
View File

@ -0,0 +1,368 @@
#lang racket/base
(provide read-ds-store
write-ds-store
(struct-out ds)
(struct-out iloc)
(struct-out fwind))
;; Based on
;; http://search.cpan.org/~wiml/Mac-Finder-DSStore/DSStoreFormat.pod
;; by Wim Lewis and Mark Mentovai
(struct ds (path id type data) #:transparent)
(struct iloc (x y) #:transparent)
(struct fwind (t l b r mode sideview?) #:transparent)
(define HEAD 4)
(define (swap-bytes bstr)
(let ([s (make-bytes (bytes-length bstr))])
(for ([i (in-range 0 (bytes-length bstr) 2)])
(bytes-set! s i (bytes-ref bstr (add1 i)))
(bytes-set! s (add1 i) (bytes-ref bstr i)))
s))
(define (bytes->string/utf-16 bstr)
(define bstr2 (if (system-big-endian?)
bstr
(swap-bytes bstr)))
(define c (bytes-open-converter "platform-UTF-16" "platform-UTF-8"))
(define-values (utf-8 got status) (bytes-convert c bstr2))
(bytes-close-converter c)
(bytes->string/utf-8 utf-8))
(define (string->bytes/utf-16 s)
(define c (bytes-open-converter "platform-UTF-8" "platform-UTF-16"))
(define-values (utf-16 got status) (bytes-convert c (string->bytes/utf-8 s)))
(bytes-close-converter c)
(if (system-big-endian?)
utf-16
(swap-bytes utf-16)))
(define (mac-path<? a b)
;; A guess: alphabetic case-insensitively, but ties
;; can be determined by case:
(define as (bytes->string/utf-16 a))
(define bs (bytes->string/utf-16 b))
(or (string-ci<? as bs)
(and (string-ci=? as bs)
(string<? as bs))))
(define (read-ds-store path
#:verbose? [verbose? #f])
(call-with-input-file*
path
(lambda (p)
(define (check b)
(unless (equal? b (read-bytes (bytes-length b) p))
(error "mismatch")))
(define (read-int)
(integer-bytes->integer (read-bytes 4 p) #f #t))
(define (read-short)
(integer-bytes->integer (read-bytes 2 p) #f #t))
(define (read-utf-16 len)
(define bstr (read-bytes (* 2 len) p))
(bytes->string/utf-16 bstr))
(define (read-four)
(string->symbol (bytes->string/utf-8 (read-bytes 4 p) #\?)))
(define (addr-offset o) (- o (bitwise-and o #x1F)))
(define (addr-size o) (expt 2 (bitwise-and o #x1F)))
(check #"\0\0\0\1")
(check #"Bud1")
(define bookkeeping-offset (read-int))
(define bookkeeping-size (read-int))
(when verbose?
(printf "Bookkeeping at ~a, size ~a\n"
bookkeeping-offset
bookkeeping-size))
(file-position p (+ bookkeeping-offset HEAD))
(define count (read-int))
(when verbose?
(printf "File has ~a blocks\n" count))
(void (read-int))
(define block-addresses
(for/vector ([i (in-range count)])
(read-int)))
(when verbose?
(printf "Block addresses:\n")
(for ([a (in-vector block-addresses)]
[i (in-naturals)])
(printf " ~a: ~a = ~a\n"
i
(addr-offset a)
(addr-size a))))
(void (read-bytes (* 4 (- 256 count)) p))
(define directory-count (read-int))
(define dirs (for/list ([i (in-range directory-count)])
(cons (read-bytes (read-byte p) p)
(read-int))))
(define free-lists (for/list ([i 32])
(define c (read-int))
(for/list ([i c])
(read-int))))
(when verbose?
(printf "Free list:\n")
(for/list ([i 32]
[l (in-list free-lists)])
(printf "~a: ~a\n" (expt 2 i) l)))
(define header-block (cdr (assoc #"DSDB" dirs)))
(define header-addr (vector-ref block-addresses header-block))
(when verbose?
(printf "Header block is ~a at ~a (size ~a)\n"
header-block
(addr-offset header-addr)
(addr-size header-addr)))
(file-position p (+ (addr-offset header-addr) HEAD))
(define root-block-number (read-int)) ; root node
(define more-root-data
(list
(read-int) ; levels
(read-int) ; records
(read-int))) ; nodes
(unless (equal? (read-int) #x1000)
(error "mismatch"))
(when verbose?
(printf "Root block is ~a ~s\n" root-block-number more-root-data))
(define (show-tree n accum)
(define addr (vector-ref block-addresses n))
(file-position p (+ (addr-offset addr) HEAD))
(define P (read-int))
(define count (read-int))
(when verbose?
(printf "block ~s ~s\n" P count))
(cond
[(zero? P)
(for/fold ([accum accum]) ([i (in-range count)])
(show-record accum))]
[else
(define a3
(for/fold ([accum accum]) ([i (in-range count)])
(define bn (read-int))
(define pos (file-position p))
(define a2 (show-tree bn accum))
(file-position p pos)
(show-record a2)))
(show-tree P a3)]))
(define (show-record accum)
(define len (read-int))
(define name (read-utf-16 len))
(define id (read-four))
(define type (read-four))
(define data
(case type
[(long shor) (read-int)]
[(bool) (positive? (read-byte p))]
[(blob)
(define len (read-int))
(case id
[(fwi0) (begin0
(fwind (read-short)
(read-short)
(read-short)
(read-short)
(read-four)
(begin
(read-byte p)
(not (zero? (read-byte p)))))
(read-bytes (- len 14) p))]
[(Iloc) (begin0
(iloc (read-int)
(read-int))
(read-bytes (- len 8) p))]
[else (read-bytes len p)])]
[(type) (read-four)]
[(ustr) (read-utf-16 (read-int))]))
(when verbose?
(printf "~a '~a' '~a':\n ~s\n" name id type data))
(cons (ds (if (equal? name ".")
'same
(string->path-element name))
id
type
data)
accum))
(reverse (show-tree root-block-number null)))))
(define (write-ds-store path dses)
(struct record (filename id type data))
(define (record<? a b)
(define af (record-filename a))
(define bf (record-filename b))
(if (equal? af bf)
(mac-path<? (record-id a) (record-id b))
(mac-path<? af bf)))
(define (record-size r)
(+ 4 ; filename length
(bytes-length (record-filename r))
4 ; id
4 ; type
(bytes-length (record-data r))))
(define (int->bytes i)
(integer->integer-bytes i 4 #t #t))
(define (short->bytes i)
(integer->integer-bytes i 2 #t #t))
(define records
(sort (for/list ([ds (in-list dses)])
(define data (ds-data ds))
(record (if (eq? (ds-path ds) 'same)
(string->bytes/utf-16 ".")
(string->bytes/utf-16
(path-element->string (ds-path ds))))
(string->bytes/utf-8 (symbol->string (ds-id ds)))
(string->bytes/utf-8 (symbol->string (ds-type ds)))
(case (ds-type ds)
[(long shor) (int->bytes data)]
[(bool) (if data #"\1" #"\0")]
[(blob)
(define bstr
(cond
[(bytes? data) data]
[(fwind? data) (bytes-append
(short->bytes (fwind-t data))
(short->bytes (fwind-l data))
(short->bytes (fwind-b data))
(short->bytes (fwind-r data))
(string->bytes/utf-8 (symbol->string (fwind-mode data)))
(bytes 0
(if (fwind-sideview? data) 1 0)
0
0))]
[(iloc? data) (bytes-append
(int->bytes (iloc-x data))
(int->bytes (iloc-y data))
(bytes #xff #xff #xff #xff #xff #xff 0 0))]
[else (error "unrecognized block variant: ~s" data)]))
(bytes-append
(int->bytes (bytes-length bstr))
bstr)]
[(type)
(string->bytes/utf-8 (symbol->string data))]
[(ustr)
(define bstr (string->bytes/utf-16 data))
(string-append (int->bytes (quotient (bytes-length bstr) 2))
bstr)]
[else (error "unrecognized data: ~s" (ds-type ds))])))
record<?))
(define records-block-size
(+ 4 ; P = 0
4 ; count
(apply + (for/list ([r (in-list records)])
(record-size r)))))
(define alloc-size (let ([v (max 64
(expt 2 (integer-length (add1 records-block-size))))])
(if (= v 2048)
4096 ; avoid collision with bookkeeping block
v)))
(call-with-output-file*
path
#:exists 'truncate/replace
(lambda (p)
(define (write-records sz)
(write-int 0)
(write-int (length records))
(for ([r (in-list records)])
(write-int (quotient (bytes-length (record-filename r)) 2))
(write-bytes (record-filename r) p)
(write-bytes (record-id r) p)
(write-bytes (record-type r) p)
(write-bytes (record-data r) p))
(write-bytes (make-bytes (- sz records-block-size) 0) p))
(define (write-int i)
(write-bytes (int->bytes i) p))
(define (write-addr pos sz)
(write-int (bitwise-ior pos (sub1 (integer-length sz)))))
(write-bytes #"\0\0\0\1" p)
(write-bytes #"Bud1" p)
;; Bookeeping block always at 2048, since
;; it needs 2048 bytes:
(write-int 2048) ; offset
(write-int 2048) ; size
(write-int 2048) ; offset, again
(write-bytes (make-bytes 16 0) p)
;; Next 32-byte block (at offset 32) is used for the header block:
(write-int 2) ; block number for root
(write-int 0) ; level
(write-int (length records)) ; records
(write-int 1) ; nodes
(write-int #x1000)
(write-bytes (make-bytes 12 0) p)
;; Starting with 64, need blocks up to size
;; 1024. If any of those fit the records, then
;; use it.
(let loop ([sz 64])
(if (= sz alloc-size)
(write-records sz)
(write-bytes (make-bytes sz 0) p))
(unless (= sz 1024)
(loop (* sz 2))))
;; Write bookkeeping block
(write-int 3) ; 3 blocks
(write-int 0) ; unknown
(write-addr 2048 2048) ; bookkeeping
(write-addr 32 32) ; header block
;; records block always lands at second buddy:
(write-addr alloc-size alloc-size)
(write-bytes (make-bytes (* 4 (- 256 3)) 0) p)
;; Single directory entry:
(write-int 1)
(write-byte 4 p)
(write-bytes #"DSDB" p)
(write-int 1) ; block 1 is header
;; free lists:
(for/list ([i 32])
(define sz (expt 2 i))
(cond
[(= i 31) (write-int 0)]
[(or (sz . <= . 32)
(sz . = . 2048))
(write-int 0)]
[(= sz alloc-size) (write-int 0)]
[else (write-int 1)
(write-int sz)]))
(file-truncate p (+ 4096 HEAD))
(file-position p (+ 4096 HEAD))
;; write bytes as needed to reach records data
(let loop ([sz 4096])
(when (alloc-size . > . sz)
(write-bytes (make-bytes sz 0) p)
(loop (* 2 sz))))
(when (alloc-size . > . 2048)
(write-records alloc-size))
(void))))

9
pkgs/ds-store-pkgs/ds-store/info.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang info
(define collection "ds-store")
(define deps '("ds-store-lib"
"ds-store-doc"
"base"))
(define implies '("ds-store-lib"
"ds-store-doc"))

3
pkgs/main-distribution/info.rkt
View File

@ -80,4 +80,5 @@
"unstable-redex"
"web-server"
"wxme"
"xrepl"))
"xrepl"
"ds-store"))