1#lang racket/base
2
3;; Provides additional functions for querying OS information
4
5(require (prefix-in c: racket/contract)
6         racket/promise
7         ffi/unsafe
8         ffi/cvector
9         ffi/winapi)
10
11(provide (c:contract-out [getpid (c:-> exact-integer?)]
12                         [gethostname (c:-> string?)]))
13
14(define kernel32
15  (delay (and (eq? 'windows (system-type)) (ffi-lib "kernel32"))))
16
17(define (delay-ffi-obj name lib type)
18  (delay (get-ffi-obj name lib type)))
19
20;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
21;; gethostname
22
23(define BUFFER-SIZE 1024)
24(define (extract-terminated-string proc)
25  (let ([s (make-bytes BUFFER-SIZE)])
26    (if (proc s BUFFER-SIZE)
27      (bytes->string/utf-8 (car (regexp-match #rx#"^[^\0]*" s)))
28      (error 'gethostname "could not get hostname"))))
29
30(define unix-gethostname
31  (delay-ffi-obj "gethostname" #f (_fun _bytes _int -> _int)))
32
33(define windows-getcomputername
34  (delay-ffi-obj "GetComputerNameExA" (force kernel32)
35                 (_fun #:abi winapi _int _bytes _cvector -> _int)))
36
37(define (gethostname)
38  (case (system-type)
39    [(unix macosx)
40     (let ([ghn (force unix-gethostname)])
41       (extract-terminated-string (lambda (s sz) (zero? (ghn s sz)))))]
42    [(windows)
43     (let ([gcn (force windows-getcomputername)]
44           [DNS_FULLY_QUALIFIED 3])
45       (extract-terminated-string
46        (lambda (s sz)
47          (let ([sz_ptr (cvector _int sz)])
48            (and (not (zero? (gcn DNS_FULLY_QUALIFIED s sz_ptr)))
49                 (let ([sz (cvector-ref sz_ptr 0)])
50                   (when (sz . < . (bytes-length s)) (bytes-set! s sz 0))
51                   #t))))))]
52    [else #f]))
53
54;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
55;; getpid
56
57(define unix-getpid
58  (delay-ffi-obj "getpid" #f (_fun -> _int)))
59
60(define windows-getpid
61  (delay-ffi-obj "GetCurrentProcessId" (force kernel32)
62                 (_fun #:abi winapi -> _int)))
63
64(define (getpid)
65  ((force (case (system-type)
66            [(macosx unix) unix-getpid]
67            [(windows) windows-getpid]
68            [else (error 'getpid "unknown platform ~e" (system-type))]))))
69