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


;;; Prelude

(declare
  (usual-integrations)
  (inline)
  (local)
  (number-type generic)
  (no-procedure-checks)
  (bound-to-procedure
    ##sys#check-number))

;;;

#>
#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 );
    CFNumberGetValue( consoleSet, kCFNumberSInt32Type, pcon );
    *pbit = (CFBooleanGetValue( loginCompleted ) << 1) | CFBooleanGetValue( userIsActive );
    cfsr_to_utf8str( shortUserName, outstr );
  } else {
    *outstr = NULL;
  }
}
<#


;;;

(require-library dollar)

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

;;

(define (make-exn-condition loc msg . args)
  (make-property-condition 'exn 'location loc 'message msg 'arguments args) )

(define (make-osstatus-condition code)
  (make-property-condition 'osstatus 'code code) )

(define (make-oserr-condition code)
  (make-property-condition 'oserr 'code code) )

(define (make-exn-osstatus-condition loc msg code . args)
  (make-composite-condition
   (apply make-exn-condition loc msg args)
   (make-osstatus-condition code)) )

(define (make-exn-oserr-condition loc msg code . args)
  (make-composite-condition
   (apply make-exn-condition loc msg args)
   (make-oserr-condition code)) )

;;

(define (osstatus-error loc msg code . args)
  (abort (apply make-exn-osstatus-condition loc msg code args)) )

(define (oserr-error loc msg code . args)
  (abort (apply make-exn-oserr-condition loc msg code args)) )

;;

(define-syntax $/string:out#1
  (lambda (form r c)
    (##sys#check-syntax '$/string:out#1 form '(_ symbol . #(_ 0)))
    (let (($$ (r '$))
          ($void (r 'void))
          ($unsigned-c-string* 'unsigned-c-string* #;(r 'unsigned-c-string*))
          ($location (r 'location))
          ($let-location (r 'let-location)))
      (let ((c-nam (cadr form))
            (args (cddr form))
            (stroutvar (gensym)))
        `(,$let-location ((,stroutvar ,$unsigned-c-string*))
           (,$$ void ,c-nam (location ,stroutvar) ,@args)
           ,stroutvar) ) ) ) )
          
(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)) (osstatus-error '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) (osstatus-error '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")
                          (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))))
  (##sys#check-number sel 'gestalt)
	(let-location ((resp long))
    (let ((err ($ short Gestalt (unsigned-integer32 sel) #$resp)))
      (if (fx= 0 err) resp
          (oserr-error 'gestalt "Gestalt failed" err) ) ) ) )

) ;module macosx-env