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

;; 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.

;;;

#>
#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) * 10.0)) / ((p) * 10.0))

	MachineLocation machloc;

	ReadLocation( &machloc );

	*lat = ROUNDN( ((double) FractToFloat( machloc.latitude )) * 90.0, 4);
	*lon = ROUNDN( ((double) FractToFloat( machloc.longitude )) * 90.0, 4);
	*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;
}

#define session_LoginCompleted  0x0001
#define session_UserIsActive    0x0010

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;
  }
}
<#

;;;

(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
    ;;
    osstatus-condition?
    oserr-condition?)

  (import scheme chicken foreign
    dollar
    (only type-checks check-number)
    (only macosx-errors
      exception-osstatus osstatus-condition?  exception-oserr oserr-condition?))

  (require-library dollar type-checks macosx-errors)

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

;;

(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 ((c-nam (cadr frm))
              (args (cddr frm))
              (tmp (rnm (gensym))) )
          `(,_let-location ((,tmp ,_unsigned-c-string*))
             (,_$ void ,c-nam (,_location ,tmp) ,@args)
             ,tmp) ) ) ) ) )

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

;;

(define (session-info)
  (let-location ((sid unsigned-integer32)
                 (sab unsigned-integer32))
    (let ((sta ($ int sessionInfo #$sid #$sab)))
      (if (not (fx= 0 sta))
          (exception-osstatus 'session-info "SessionGetInfo failed" sta)
          (let-location ((uid unsigned-integer32)
                         (con unsigned-integer32)
                         (bits unsigned-integer32))
            (let ((nam ($/string:out#1 sessionInfoProperties #$uid #$con #$bits)))
              (if (not nam)
                  (exception-osstatus 'session-info "CGSessionCopyCurrentDictionary failed" 0)
                  (vector
                    sid
                    (bitwise-test?/foreign-mask sab "sessionIsRoot")
                    (bitwise-test?/foreign-mask sab "sessionHasGraphicAccess")
                    (bitwise-test?/foreign-mask sab "sessionHasTTY")
                    (bitwise-test?/foreign-mask sab "sessionIsRemote")
                    ; sessionWasInitialized removed by MacOS 10.7 so concept is
                    ; not useful.
                    (void) #;(bitwise-test?/foreign-mask sab "sessionWasInitialized")
                    nam
                    uid
                    con
                    (bitwise-test?/foreign-mask bits "session_LoginCompleted")
                    (bitwise-test?/foreign-mask bits "session_UserIsActive")) ) ) ) ) ) ) )

;;

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

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

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

(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) ) )

(define (metric?) ($ bool IsMetric))

;;

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

(define (console-user #!optional (store #f))
	(let-location ((uid unsigned-integer32) (gid unsigned-integer32))
	  (let ((nam ($/string:out#1 console_user #$uid #$gid (c-pointer store))))
	    (and nam
		      (vector nam uid gid) ) ) ) )

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

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

;;

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

;;

(define (tick-count) ($ unsigned-integer32 TickCount))

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

;;

(define (gestalt sel)
  (when (symbol? sel) (set! sel (symbol->string sel)))
  (when (string? sel) (set! sel ($ unsigned-integer32 stringToOSType (nonnull-c-string sel))))
  (check-number 'gestalt sel)
	(let-location ((resp long))
    (let ((err ($ short Gestalt (unsigned-integer32 sel) #$resp)))
      (if (fx= 0 err) resp
        (exception-oserr 'gestalt "Gestalt failed" err) ) ) ) )

) ;module macosx-env