;;;; macosx-env.scm
;;;; Kon Lovett, Mar '09
;;;; Kon Lovett, Feb '18

;; Issues
;;
;; - Assumes UTF8 encoding for SCDynamicStoreCopyComputerName
;;
;; - No SCDynamicStoreCopyProxies support
;;
;; - No CFStringGetCStringPtr use since memory allocation is not performed.
;; This is sub-par but makes the Scheme invocation more complex.
;;
;; - Deprecated:
;; (10.8 CSCopyMachineName CSCopyUserName ReadLocation Gestalt Delay TickCount)
;; (10.7 IsMetric)

;;;

(module macosx-env

(;export
  session-info
  machine-name
  short-user-name
  long-user-name
  machine-location
  metric?
  computer-name
  console-user
  local-host-name
  location-name
  main-bundle-path
  tick-count
  delay-for-ticks
  gestalt)

(import scheme chicken foreign)
(use
  dollar
  (only type-checks check-number)
  macosx-errors)

(declare
  (bound-to-procedure ##sys#check-syntax))

;;;

#>
#include <math.h>
#include <unistd.h>

#include <CoreFoundation/CoreFoundation.h>
#include <CoreServices/CoreServices.h>
#include <SystemConfiguration/SCDynamicStoreCopySpecific.h>
#include <ApplicationServices/ApplicationServices.h>
#include <Security/AuthSession.h>

#define VECLEN( v ) (sizeof( v ) / sizeof( (v)[0] ))

static void
cfsr_to_utf8str( CFStringRef cfsr, unsigned char **outstr )
{
#	define LONG_CHARS_PER_UTF8 6 /* worst case assumption */

	CFIndex buflen = LONG_CHARS_PER_UTF8 * CFStringGetLength( cfsr ) + 1;

	*outstr = (unsigned char *) C_malloc( buflen );

	if (! CFStringGetCString( cfsr, (char *) *outstr, buflen, kCFStringEncodingUTF8 )) {
		C_free( *outstr );
		*outstr = NULL;
	}

#	undef LONG_CHARS_PER_UTF8
}

static void
machine_name( unsigned char **outstr )
{
	cfsr_to_utf8str( CSCopyMachineName(), outstr );
}

static void
short_user_name( unsigned char **outstr )
{
	cfsr_to_utf8str( CSCopyUserName( true ), outstr );
}

static void
long_user_name( unsigned char **outstr )
{
	cfsr_to_utf8str( CSCopyUserName( false ), outstr );
}

static void
machine_location( double *lat, double *lon, int *dls, long *gmt )
{
#	define ROUNDN( v, p ) (round( (v) * (p) ) / (p))

	MachineLocation machloc;

	ReadLocation( &machloc );

	*lat = ROUNDN( ((double) FractToFloat( machloc.latitude )) * 90.0, 4 * 10.0);
	*lon = ROUNDN( ((double) FractToFloat( machloc.longitude )) * 90.0, 4 * 10.0);
	*dls = 0 < machloc.u.dls.Delta ? 3600 : (0 > machloc.u.dls.Delta ? -3600 : 0);
	*gmt = ((machloc.u.gmtDelta & 0x00FFFFFF) << 8) >> 8;

#	undef ROUNDN
}

static void
computer_name( unsigned char **outstr, SCDynamicStoreRef store )
{
  /* Assumes UTF8 encoding! */
	CFStringRef cfsr = SCDynamicStoreCopyComputerName( store, NULL );
	cfsr_to_utf8str( cfsr, outstr );
	CFRelease( cfsr );
}

static void
console_user( unsigned char **outstr, uint32_t *puid, uint32_t *pgid, SCDynamicStoreRef store )
{
	uid_t uid;
	gid_t gid;

	CFStringRef cfsr = SCDynamicStoreCopyConsoleUser( store, &uid, &gid );
	cfsr_to_utf8str( cfsr, outstr );
	CFRelease( cfsr );

	*puid = uid;
	*pgid = gid;
}

static void
local_host_name( unsigned char **outstr, SCDynamicStoreRef store )
{
	CFStringRef cfsr = SCDynamicStoreCopyLocalHostName( store );
	cfsr_to_utf8str( cfsr, outstr );
	CFRelease( cfsr );
}

static void
location_name( unsigned char **outstr, SCDynamicStoreRef store )
{
	CFStringRef cfsr = SCDynamicStoreCopyLocation( store );
	cfsr_to_utf8str( cfsr, outstr );
	CFRelease( cfsr );
}

static void
main_bundle_path( unsigned char **outstr )
{
  CFBundleRef bundle = CFBundleGetMainBundle();
  *outstr = NULL;
  if (NULL != bundle) {
    CFURLRef url = CFBundleCopyExecutableURL( bundle );
    if (NULL != url) {
      long buflen = pathconf( "/", _PC_PATH_MAX ); /* any pathname will do */
      *outstr = (unsigned char *) C_malloc( buflen );
      if (NULL != outstr) {
        if (!CFURLGetFileSystemRepresentation( url, true, *outstr, buflen )) {
          C_free( outstr );
          *outstr = NULL;
        }
      }
    }
  }
}

static uint32_t
stringToOSType( char *str )
{
  union {uint32_t v; uint8_t c[4];} ost;

  int i;

  /* Copy existing */
  for (i = 0; i < VECLEN( ost.c ) && *str; ++i, ++str)
    ost.c[i] = (uint8_t) *str;

  /* Pad remaining */
  for (; i < VECLEN( ost.c ); ++i)
    ost.c[i] = (uint8_t) ' ';

  return ost.v;
}

static int
sessionInfo( uint32_t *psid, uint32_t *psab )
{
  SecuritySessionId mySession;
  SessionAttributeBits sessionInfo;
  OSStatus error = SessionGetInfo( callerSecuritySession, &mySession, &sessionInfo );
  if (errSessionSuccess == error) {
    *psid = mySession;
    *psab = sessionInfo;
    return 0;
  }
  return error;
}

/* sessionInfo bitmasks */
#define session_LoginCompleted  0x0001
#define session_UserIsActive    0x0010
/* via include: "sessionIsRoot" "sessionHasGraphicAccess" "sessionHasTTY" "sessionIsRemote" */

static void
sessionInfoProperties( unsigned char **outstr, uint32_t *puid, uint32_t *pcon, uint32_t *pbit )
{
  CFDictionaryRef sessionInfoDict = CGSessionCopyCurrentDictionary();
  if (NULL != sessionInfoDict) {
    CFStringRef shortUserName = CFDictionaryGetValue( sessionInfoDict, kCGSessionUserNameKey );
    CFNumberRef userUID = CFDictionaryGetValue( sessionInfoDict, kCGSessionUserIDKey );
    CFNumberRef consoleSet = CFDictionaryGetValue( sessionInfoDict, kCGSessionConsoleSetKey );
    CFBooleanRef userIsActive = CFDictionaryGetValue( sessionInfoDict, kCGSessionOnConsoleKey );
    CFBooleanRef loginCompleted = CFDictionaryGetValue( sessionInfoDict, kCGSessionLoginDoneKey );

    CFNumberGetValue( userUID, kCFNumberSInt32Type, puid );
    if (consoleSet)
      CFNumberGetValue( consoleSet, kCFNumberSInt32Type, pcon );
    else
      *pcon = 0;
    *pbit = (CFBooleanGetValue( loginCompleted ) << 1) | CFBooleanGetValue( userIsActive );
    cfsr_to_utf8str( shortUserName, outstr );
  } else {
    *outstr = NULL;
  }
}
<#

;;;

(define-syntax $/string:out#1
  (er-macro-transformer
    (lambda (frm rnm cmp)
      (##sys#check-syntax '$/string:out#1 frm '(_ symbol . #(_ 0)))
      (let (
        (_$ (rnm '$))
        (_void (rnm 'void))
        (_unsigned-c-string* (rnm 'unsigned-c-string*))
        (_location (rnm 'location))
        (_let-location (rnm 'let-location)) )
        (let (
          (cnam (cadr frm))
          (args (cddr frm))
          (tmp (rnm (gensym))) )
          `(,_let-location ((,tmp ,_unsigned-c-string*))
             (,_$ void ,cnam (,_location ,tmp) ,@args)
             ,tmp) ) ) ) ) )

(define-syntax bitwise-test?/foreign-mask
  (syntax-rules ()
    ((_ ?bits ?cnam)
      (not
        (zero?
          (bitwise-and
            ?bits
            (foreign-value ?cnam unsigned-integer32)))) ) ) )

;;

(: session-info ( -> (vector number boolean boolean boolean boolean void string number number boolean boolean)))
;
(define (session-info)
  (let-location (
    (sessionId unsigned-integer32)
    (sessionAttributes unsigned-integer32) )
    (let (
      (status
        ($ int sessionInfo #$sessionId #$sessionAttributes)) )
      (if (not (zero? status))
        (exception-osstatus 'session-info "SessionGetInfo failed" status)
        (let-location (
          (userId unsigned-integer32)
          (consoleSet unsigned-integer32)
          (sessionProperties unsigned-integer32) )
          (let (
            (shortUserName
              ($/string:out#1
                sessionInfoProperties
                #$userId #$consoleSet #$sessionProperties)) )
            (if (not shortUserName)
              (exception-osstatus 'session-info "CGSessionCopyCurrentDictionary failed" 0)
              (vector
                sessionId
                (bitwise-test?/foreign-mask sessionAttributes "sessionIsRoot")
                (bitwise-test?/foreign-mask sessionAttributes "sessionHasGraphicAccess")
                (bitwise-test?/foreign-mask sessionAttributes "sessionHasTTY")
                (bitwise-test?/foreign-mask sessionAttributes "sessionIsRemote")
                ;sessionWasInitialized removed by macOS 10.7 so concept is
                ;not useful.
                (void) ;(bitwise-test?/foreign-mask sessionAttributes "sessionWasInitialized")
                shortUserName
                userId
                consoleSet
                (bitwise-test?/foreign-mask sessionProperties "session_LoginCompleted")
                (bitwise-test?/foreign-mask sessionProperties "session_UserIsActive")) ) ) ) ) ) ) )

;;

(: machine-name ( -> string))
;
(define (machine-name)
  ($/string:out#1 machine_name))

(: short-user-name ( -> string))
;
(define (short-user-name)
  ($/string:out#1 short_user_name))

(: long-user-name ( -> string))
;
(define (long-user-name)
  ($/string:out#1 long_user_name))

(: machine-location ( -> (vector number number number number)))
;
(define (machine-location)
	(let-location (
	  (lat double)
	  (lon double)
	  (dls int)
	  (gmt long) )
		($ void machine_location #$lat #$lon #$dls #$gmt)
		(vector lat lon dls gmt) ) )

(: metric? ( -> boolean))
;
(define (metric?)
  ($ bool IsMetric))

;;

(define-type c-pointer *)

(: computer-name (#!optional (or boolean c-pointer) -> string))
;
(define (computer-name #!optional (store #f))
  ($/string:out#1 computer_name (c-pointer store)) )

(: console-user (#!optional (or boolean c-pointer) -> (vector string number number)))
;
(define (console-user #!optional (store #f))
	(let-location (
	  (userId unsigned-integer32)
	  (groupId unsigned-integer32) )
	  (let (
	    (userShortName ($/string:out#1 console_user #$userId #$groupId (c-pointer store))) )
	    (and
	      userShortName
        (vector userShortName userId groupId) ) ) ) )

(: local-host-name (#!optional (or boolean c-pointer) -> string))
;
(define (local-host-name #!optional (store #f))
  ($/string:out#1 local_host_name (c-pointer store)) )

(: location-name (#!optional (or boolean c-pointer) -> string))
;
(define (location-name #!optional (store #f))
  ($/string:out#1 location_name (c-pointer store)) )

;;

(: main-bundle-path ( -> string))
;
(define (main-bundle-path)
  ($/string:out#1 main_bundle_path))

;;

(: tick-count ( -> number))
;
(define (tick-count)
  ($ unsigned-integer32 TickCount))

(: delay-for-ticks (number -> number))
;
(define (delay-for-ticks ticks)
	(let-location (
	  (fticks unsigned-long) )
    ($ void Delay (unsigned-long ticks) #$fticks)
    fticks ) )

;;

(: gestalt ((or number string symbol) -> number))
;
(define (gestalt sel)
  (let (
    (sel (gestalt-selector sel)) )
    (check-number 'gestalt sel)
    (let-location (
      (resp long) )
      (let (
        (err ($ short Gestalt (unsigned-integer32 sel) #$resp)) )
        (if (zero? err)
          resp
          (exception-oserr 'gestalt "Gestalt failed" err) ) ) ) ) )

(: gestalt-selector ((or number string symbol) -> number))
;
(define (gestalt-selector sel)
  (cond
    ((symbol? sel)
      (gestalt-selector (symbol->string sel)) )
    ((string? sel)
      ($ unsigned-integer32 stringToOSType (nonnull-c-string sel)))
    (else ;(number? sel)
      sel ) ) )

) ;module macosx-env