#lang racket/base
(require racket/system
(planet neil/mcfly)
(planet neil/sudo:1:1))
(module+ test
(require (planet neil/overeasy:2:1)))
(doc (section "Introduction")
(para (italic (bold "WARNING:")
" THIS IS ALPHA-TESTING SOFTWARE. USE WITH CAUTION.
It is easy to lose all the data on a hard disk drive accidentally. This
package uses GNU Parted with the Racket "
(hyperlink "http://www.neilvandyke.org/racket-sudo/"
(code "sudo"))
" package, so literally one line of code can obliterate
either your doctoral dissertation, or received love-letters (nobody has both).
Don't even think of suing the author."))
(para "This package provides a Racket interface to the "
(hyperlink "http://www.gnu.org/software/parted/"
"GNU Parted")
" disk-partitioning utilities. You must have GNU Parted installed,
for this package to function.")
(para "This package calls the command-line "
(tt "parted")
" program, sometimes using the poorly-documented "
(hyperlink "http://lists.alioth.debian.org/pipermail/parted-devel/2006-December/000573.html"
"machine-parseable output interface")
". It does not use the FFI, nor otherwise add native code to the
Racket host process. It is developed with GNU Parted 2.3.")
(para "This package was originally written for the RackOut firmware
updater."))
(doc (section "Interface"))
(doc (defproc (parted-unit? (x any/c))
boolean?
(para "Predicate for whether "
(racket x)
" is a valid ``unit'' argument for certain procedures, and for
representing the units in structs. Currently this must be a symbol: "
(racket 'byte)
" or "
(racket 'cylinder)
". CHS is not currently supported.")))
(provide parted-unit?)
(define (parted-unit? x)
(and (member x '(byte cylinder)) #t))
(doc (defstruct parted-disk
((unit parted-unit?)
(path path?)
(end nonnegative-real?)
(transport string?)
(sector-size nonnegative-real?)
(physical-sector-size nonnegative-real?)
(type-name string?)
(model string?)
(cylinders (or/c #f nonnegative-integer?))
(heads (or/c #f nonnegative-integer?))
(sectors (or/c #f nonnegative-integer?))
(cylinder-size (or/c #f nonnegative-integer?))
(partitions (list-of parted-partition?)))
"Struct representing a disk drive."))
(provide (struct-out parted-disk))
(define-struct parted-disk
(unit
path
end
transport
sector-size
physical-sector-size
type-name
model
cylinders
heads
sectors
cylinder-size
partitions)
#:transparent)
(doc (defstruct parted-partition
((unit parted-unit?)
(number nonnegative-integer?)
(start nonnegative-real?)
(end nonnegative-real?)
(size (or/c #f nonnegative-real?))
(filesystem string?)
(name string?)
(flags string?)
(type string?))
(para "Struct representing a partition of a disk drive.")))
(provide (struct-out parted-partition))
(define-struct parted-partition
(unit
number
start
end
size
filesystem
name
flags
type)
#:transparent)
(define (%parted:system-command/stdout-bytes
#:error-name (error-name 'system-command/stdout-bytes)
#:sudo? (sudo? #f)
#:command command
#:args (args '()))
(let ((stdout-ob (open-output-bytes))
(stderr-ob (open-output-bytes))
(stdin-ib (open-input-bytes #"")))
(let* ((exit-code (parameterize ((current-output-port stdout-ob)
(current-error-port stderr-ob)
(current-input-port stdin-ib))
(apply (if sudo?
system*/exit-code/sudo
system*/exit-code)
command
args)))
(stdout-bytes (get-output-bytes stdout-ob))
(stderr-bytes (get-output-bytes stderr-ob)))
(if (zero? exit-code)
(if (equal? #"" stderr-bytes)
stdout-bytes
(error error-name
"command ~S had stderr output (exit-code ~S, stderr ~S, stdout ~S)"
(cons command args)
exit-code
stderr-bytes
stdout-bytes))
(error error-name
"command ~S had non-zero exit code (exit-code ~S, stderr ~S, stdout ~S)"
(cons command args)
exit-code
stderr-bytes
stdout-bytes)))))
(define (%parted:system-command/ignored-output
#:error-name (error-name 'system-command/ignore-output)
#:sudo? (sudo? #f)
#:command command
#:args (args '()))
(let ((stdout-ob (open-output-bytes))
(stderr-ob (open-output-bytes))
(stdin-ib (open-input-bytes #"")))
(let* ((exit-code (parameterize ((current-output-port stdout-ob)
(current-error-port stderr-ob)
(current-input-port stdin-ib))
(apply (if sudo?
system*/exit-code/sudo
system*/exit-code)
command
args)))
(stdout-bytes (get-output-bytes stdout-ob))
(stderr-bytes (get-output-bytes stderr-ob)))
(if (zero? exit-code)
(void)
(error error-name
"command ~S had non-zero exit code (exit-code ~S, stderr ~S, stdout ~S)"
(cons command args)
exit-code
stderr-bytes
stdout-bytes)))))
(define (%parted:tokenize-parted-disk-output-bytes stdout-bytes)
(let ((stdout-bytes-length (bytes-length stdout-bytes)))
(let loop ((line-start 0))
(cond ((= line-start stdout-bytes-length) '())
((regexp-match-positions #rx#";\r?\n" stdout-bytes line-start)
=> (lambda (m)
(let ((line-end (caar m))
(next-line-start (cdar m)))
(cons (regexp-split #rx#":" stdout-bytes line-start line-end)
(loop next-line-start)))))
(else (error 'tokenize-parted-disk-output-bytes
"could not find line starting at position ~S in input ~S"
line-start
stdout-bytes))))))
(module+ test
(test (%parted:tokenize-parted-disk-output-bytes
(bytes-append
#"BYT;\n"
#"/dev/sdb:16053960192B:scsi:512:512:msdos:Blah Blah;\n"
#"1:512B:393215999B:393215488B:fat16::boot;\n"))
(list (list #"BYT")
(list #"/dev/sdb" #"16053960192B" #"scsi" #"512" #"512" #"msdos" #"Blah Blah")
(list #"1" #"512B" #"393215999B" #"393215488B" #"fat16" #"" #"boot"))))
(define (%parted:convert-bytes-to-parted-string bstr)
(bytes->string/latin-1 bstr))
(define (%parted:convert-bytes-to-parted-number bstr)
(cond ((regexp-match #rx#"^([0-9]+(?:\\.[0-9]+)?)$" bstr)
=> (lambda (m)
(string->number (bytes->string/latin-1 (cadr m)))))
(else (error 'convert-bytes-to-parted-number bstr
"could not convert ~S"
bstr))))
(define (%parted:convert-bytes-to-parted-nonneg-integer bstr)
(if (regexp-match? #rx#"^[0-9]+$" bstr)
(string->number (bytes->string/latin-1 bstr))
(error 'convert-bytes-to-nonneg-integer bstr
"could not convert ~S"
bstr)))
(define (%parted:convert-bytes-to-parted-bytes-number bstr)
(cond ((regexp-match #rx#"^([0-9]+(?:\\.[0-9]+)?)([kKMGT])?B$" bstr)
=> (lambda (m)
(apply (lambda (all num-bytes multiplier-bytes)
(* (string->number (bytes->string/latin-1 num-bytes))
(cond ((assoc multiplier-bytes
'((#f . #e1)
(#"k" . #e1e3)
(#"K" . #e1e3)
(#"M" . #e1e6)
(#"G" . #e1e9)
(#"T" . #e1e12)))
=> cdr)
(else (error 'convert-bytes-to-parted-bytes-number
"internal error: invalid multipler ~S in ~S"
multiplier-bytes
bstr)))))
m)))
(else (error 'convert-bytes-to-parted-bytes-number
"could not convert ~S"
bstr))))
(define (%parted:convert-bytes-to-parted-cyls-number bstr)
(cond ((regexp-match #rx#"^([0-9]+(?:\\.[0-9]+)?)cyl$" bstr)
=> (lambda (m)
(string->number (bytes->string/latin-1 (cadr m)))))
(else (error 'convert-bytes-to-parted-cyls-number bstr
"could not convert ~S"
bstr))))
(define (%parted:map-partition-lines disk-type-name proc partition-lines)
(if (equal? "msdos" disk-type-name)
(map (lambda (partition-line)
(apply (lambda (number-bytes
start-bytes
end-bytes
size-bytes
filesystem-bytes
name-bytes
flags-bytes)
(let ((number (%parted:convert-bytes-to-parted-nonneg-integer number-bytes)))
(proc number
start-bytes
end-bytes
size-bytes
(%parted:convert-bytes-to-parted-string filesystem-bytes)
(%parted:convert-bytes-to-parted-string name-bytes)
(%parted:convert-bytes-to-parted-string flags-bytes)
(cond ((equal? #"" filesystem-bytes) "extended")
((> number 4) "logical")
(else "primary")))))
partition-line))
partition-lines)
(error 'map-partition-lines
"we don't know how to deal with ~S disk-type-name"
disk-type-name)))
(define (%parted:parse-parted-disk-output-bytes unit stdout-bytes)
(let ((lines (%parted:tokenize-parted-disk-output-bytes stdout-bytes)))
(case unit
((byte)
(if (> 2 (length lines))
(error 'parse-parted-disk-output-bytes
"expected ~S to to have at least 2 lines"
stdout-bytes)
(apply (lambda (format-line disk-line . partition-lines)
(if (equal? '(#"BYT") format-line)
(apply (lambda (path-bytes
end-bytes
transport-bytes
sector-size-bytes
physical-sector-size-bytes
type-name-bytes
model-bytes)
(let ((disk-type-name (%parted:convert-bytes-to-parted-string type-name-bytes)))
(make-parted-disk
unit
(%parted:convert-bytes-to-parted-string path-bytes)
(%parted:convert-bytes-to-parted-bytes-number end-bytes)
(%parted:convert-bytes-to-parted-string transport-bytes)
(%parted:convert-bytes-to-parted-number sector-size-bytes)
(%parted:convert-bytes-to-parted-number physical-sector-size-bytes)
disk-type-name
(%parted:convert-bytes-to-parted-string model-bytes)
#f #f #f #f (%parted:map-partition-lines disk-type-name
(lambda (number
start-bytes
end-bytes
size-bytes
filesystem
name
flags
type)
(make-parted-partition
unit
number
(%parted:convert-bytes-to-parted-bytes-number start-bytes)
(%parted:convert-bytes-to-parted-bytes-number end-bytes)
(%parted:convert-bytes-to-parted-bytes-number size-bytes)
filesystem
name
flags
type))
partition-lines))))
disk-line)
(error 'parse-parted-disk-output-bytes
"expected ~S to start with #\"BYT;\""
stdout-bytes)))
lines)))
((cylinder)
(if (> 2 (length lines))
(error 'parse-parted-disk-output-bytes
"expected ~S to to have at least 2 lines"
stdout-bytes)
(apply (lambda (format-line disk-line cyl-line . partition-lines)
(if (equal? '(#"CYL") format-line)
(apply (lambda (cylinders-bytes
heads-bytes
sectors-bytes
cylinder-size-bytes)
(apply (lambda (path-bytes
end-bytes
transport-bytes
sector-size-bytes
physical-sector-size-bytes
type-name-bytes
model-bytes)
(let ((disk-type-name (%parted:convert-bytes-to-parted-string type-name-bytes)))
(make-parted-disk
unit
(%parted:convert-bytes-to-parted-string path-bytes)
(%parted:convert-bytes-to-parted-cyls-number end-bytes)
(%parted:convert-bytes-to-parted-string transport-bytes)
(%parted:convert-bytes-to-parted-number sector-size-bytes)
(%parted:convert-bytes-to-parted-number physical-sector-size-bytes)
disk-type-name
(%parted:convert-bytes-to-parted-string model-bytes)
(%parted:convert-bytes-to-parted-number cylinders-bytes)
(%parted:convert-bytes-to-parted-number heads-bytes)
(%parted:convert-bytes-to-parted-number sectors-bytes)
(%parted:convert-bytes-to-parted-bytes-number cylinder-size-bytes)
(%parted:map-partition-lines disk-type-name
(lambda (number
start-bytes
end-bytes
size-bytes
filesystem
name
flags
type)
(make-parted-partition
unit
number
(%parted:convert-bytes-to-parted-cyls-number start-bytes)
(%parted:convert-bytes-to-parted-cyls-number end-bytes)
(%parted:convert-bytes-to-parted-cyls-number size-bytes)
filesystem
name
flags
type))
partition-lines))))
disk-line))
cyl-line)
(error 'parse-parted-disk-output-bytes
"expected ~S to start with #\"CYL;\""
stdout-bytes)))
lines)))
(else (raise-type-error 'parse-parted-disk-output-bytes
"(or/c 'byte 'cylinder)"
unit)))))
(module+ test
(test (%parted:parse-parted-disk-output-bytes
'byte
(bytes-append
#"BYT;\n"
#"/dev/sdb:16053960192B:scsi:512:512:msdos:Blah Blah;\n"
#"1:512B:393215999B:393215488B:fat16::boot;\n"))
(parted-disk 'byte "/dev/sdb" 16053960192 "scsi" 512 512 "msdos" "Blah Blah" #f #f #f #f (list (parted-partition
'byte 1 512 393215999 393215488 "fat16" "" "boot" "primary"
))))
(test (%parted:parse-parted-disk-output-bytes
'cylinder
(bytes-append
#"CYL;\n"
#"/dev/sdb:1951cyl:scsi:512:512:msdos:Blah Blah;\n"
#"1951:255:63:8225kB;\n"
#"1:0cyl:47cyl:47cyl:fat16::boot;\n"))
(parted-disk 'cylinder "/dev/sdb" 1951 "scsi" 512 512 "msdos" "Blah Blah" 1951 255 63 8225000 (list (parted-partition
'cylinder 1 0 47 47 "fat16" "" "boot" "primary"
))))
(test 'with-extended-and-logical-partitions
(%parted:parse-parted-disk-output-bytes
'byte
(bytes-append
#"BYT;\n"
#"/dev/sdb:16053960192B:scsi:512:512:msdos:Blah Blah;\n"
#"1:512B:393215999B:393215488B:fat16::boot;\n"
#"2:393216000B:16053698559B:15660482560B:::;\n"
#"5:394264576B:679477247B:285212672B:ext2::;\n"
#"6:680525824B:785383423B:104857600B:ext3::;\n"))
(parted-disk 'byte
"/dev/sdb"
16053960192
"scsi"
512
512
"msdos"
"Blah Blah"
#f
#f
#f
#f
(list (parted-partition 'byte
1
512
393215999
393215488
"fat16"
""
"boot"
"primary")
(parted-partition 'byte
2
393216000
16053698559
15660482560
""
""
""
"extended")
(parted-partition 'byte
5
394264576
679477247
285212672
"ext2"
""
""
"logical")
(parted-partition 'byte
6
680525824
785383423
104857600
"ext3"
""
""
"logical")))))
(define (%parted:parted-unit->command-line-arg unit)
(case unit
((byte) "B")
((cylinder) "cyl")
(else (raise-type-error 'parted-unit->command-line-arg
"parted-unit?"
unit))))
(define (%parted:get-parted-print-bytes disk-path unit)
(let ((disk-path (cleanse-path disk-path)))
(%parted:system-command/stdout-bytes
#:error-name '%rackout-parted:get-parted-print-bytes
#:sudo? #t
#:command "/sbin/parted"
#:args (list "-s"
"-m"
(path->string disk-path)
"unit"
(%parted:parted-unit->command-line-arg unit)
"print"))))
(define (%parted:disk-or-path->path-string #:error-name (error-name 'disk-or-path->path-string)
disk-or-path)
(cond ((parted-disk? disk-or-path) (parted-disk-path disk-or-path))
((path? disk-or-path) (path->string disk-or-path))
((string? disk-or-path) disk-or-path)
(else (raise-type-error error-name
"(or/c parted-disk? pathstring?)"
disk-or-path))))
(doc (defproc (get-parted-disk (#:disk disk-or-path parted-disk-or-path?)
(#:unit unit parted-unit? 'byte))
parted-disk?
(para "Yields a "
(racket parted-disk)
" struct for the disk given by "
(racket disk-or-path)
". (A "
(racket parted-disk)
" struct may be given for "
(racket disk-or-path)
" to get updated information for the same disk.)")))
(provide get-parted-disk)
(define (get-parted-disk #:disk disk-or-path
#:unit (unit 'byte))
(or (parted-unit? unit)
(raise-type-error 'get-parted-disk
"parted-unit?"
unit))
(%parted:parse-parted-disk-output-bytes
unit
(%parted:get-parted-print-bytes (%parted:disk-or-path->path-string disk-or-path)
unit)))
(doc (defproc (parted-mklabel (#:disk disk-or-path parted-disk-or-path?)
(#:label-type label-type string? "msdos"))
void?
(para "Perform the GNU Parted "
(tt "mklabel")
" operation.")))
(provide parted-mklabel)
(define (parted-mklabel #:disk disk-or-path
#:label-type (label-type "msdos"))
(%parted:system-command/ignored-output
#:error-name 'parted-mklabel
#:sudo? #true
#:command "/sbin/parted"
#:args (list "-s"
(%parted:disk-or-path->path-string disk-or-path)
"mklabel"
label-type)))
(doc (defproc (parted-mkpart
(#:disk disk-or-path disk-or-path?)
(#:partition-type partition-type string? #f)
(#:filesystem-type filesystem-type string? #f)
(#:unit unit parted-unit? 'byte)
(#:start start nonnegative-integer?)
(#:end end nonnegative-integer?))
void?
(para "Perform the GNU Parted "
(tt "mkpart")
" operation.")))
(provide parted-mkpart)
(define (parted-mkpart #:disk disk-or-path
#:partition-type (partition-type #f)
#:filesystem-type (filesystem-type #f)
#:unit (unit 'byte)
#:start start
#:end end)
(%parted:system-command/ignored-output
#:error-name 'parted-mkpart
#:sudo? #true
#:command "/sbin/parted"
#:args `("-s"
,(%parted:disk-or-path->path-string disk-or-path)
"unit"
,(%parted:parted-unit->command-line-arg unit)
"mkpart"
,@(if partition-type (list partition-type) '())
,@(if filesystem-type (list filesystem-type) '())
,(number->string start)
,(number->string end))))
(doc (defproc (parted-partition/unit-byte? (x any/c))
boolean?
(para "Predicate for whether "
(racket x)
" is a "
(racket parted-partition)
" "
(italic "and")
" uses ``byte'' units (as opposed to ``cylinder''). It is equivalent to:")
(racketblock
(and (parted-partition? X)
(eq? 'byte (parted-partition-unit X))))))
(provide parted-partition/unit-byte?)
(define (parted-partition/unit-byte? x)
(and (parted-partition? x)
(eq? 'byte (parted-partition-unit x))))
(doc (defproc (parted-mkpart/partition
(#:disk disk-or-path disk-or-path?)
(#:partition partition nonnegative-integer?))
void?
(para "Perform the GNU Parted "
(tt "mkpart")
" operation, but using a "
(racket parted-partition)
" struct to specify the properties of the partition.")
(para "This is useful as part of a pattern of using "
(racket get-parted-disk)
" to save the current partition information for a disk, performing
some operation that results in the partition table being corrupted or lost, and
then restoring the partitions (restoring either all, or selectively).")))
(provide parted-mkpart/partition)
(define (parted-mkpart/partition #:disk disk-or-path
#:partition partition)
(or (parted-partition/unit-byte? partition)
(raise-type-error 'parted-mkpart/partition
"parted-partition/unit-byte?"
partition))
(parted-mkpart
#:disk (%parted:disk-or-path->path-string #:error-name 'parted-mkpart/partition
disk-or-path)
#:partition-type (parted-partition-type partition)
#:filesystem-type (parted-partition-filesystem partition)
#:unit (parted-partition-unit partition)
#:start (parted-partition-start partition)
#:end (parted-partition-end partition)))
(doc (defproc (parted-mkpartfs
(#:disk disk-or-path disk-or-path?)
(#:partition-type partition-type string?)
(#:filesystem-type filesystem-type string?)
(#:unit unit parted-unit? 'byte)
(#:start start nonnegative-integer?)
(#:end end nonnegative-integer?))
void?
(para "Perform the GNU Parted "
(tt "mklabel")
" operation.")
(para "Note that the GNU Parted 2.3 documentation discourages use of
this operation; separate filesystem-specific tools are usually better suited to
filesystem creation.")))
(provide parted-mkpartfs)
(define (parted-mkpartfs #:disk disk-or-path
#:partition-type partition-type
#:filesystem-type filesystem-type
#:unit (unit 'byte)
#:start start
#:end end)
(%parted:system-command/ignored-output
#:error-name 'parted-mkpartfs
#:sudo? #true
#:command "/sbin/parted"
#:args (list "-s"
(%parted:disk-or-path->path-string disk-or-path)
"unit"
(%parted:parted-unit->command-line-arg unit)
"mkpartfs"
partition-type
filesystem-type
(number->string start)
(number->string end))))
(doc (section "Known Issues")
(itemlist
(item "Logic of distinguishing "
(tt "msdos")
" partition types with info given is not yet 100% clear.")
(item "May need CHS unit support.")
(item "Needs more testing with different devices and operations.")))
(doc history
(#:planet 1:0 #:date "2012-11-15"
(itemlist
(item "Initial release."))))
![[logo]](/logo.png){kind=logo}