[MLton-commit] r5617
Vesa Karvonen
vesak at mlton.org
Wed Jun 13 09:38:24 PDT 2007
Added the bare minimal (and hopefully transitional) support for Windows
SECURITY_ATTRIBUTES.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/windows/unstable/detail/ffi/windows.h
U mltonlib/trunk/com/ssh/windows/unstable/detail/lib/windows.c
U mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml
U mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/windows/unstable/detail/ffi/windows.h
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/detail/ffi/windows.h 2007-06-12 18:53:00 UTC (rev 5616)
+++ mltonlib/trunk/com/ssh/windows/unstable/detail/ffi/windows.h 2007-06-13 16:38:23 UTC (rev 5617)
@@ -242,4 +242,6 @@
C_CODE(LPTSTR win_FormatErrorLocalAlloc(DWORD error))
+C_CODE(LPSECURITY_ATTRIBUTES win_CreateAllAccessForWorldSA(void))
+
#endif
Modified: mltonlib/trunk/com/ssh/windows/unstable/detail/lib/windows.c
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/detail/lib/windows.c 2007-06-12 18:53:00 UTC (rev 5616)
+++ mltonlib/trunk/com/ssh/windows/unstable/detail/lib/windows.c 2007-06-13 16:38:23 UTC (rev 5617)
@@ -10,6 +10,7 @@
#define WIN32_LEAN_AND_MEAN
#include <windows.h>
+#include <aclapi.h>
/************************************************************************/
@@ -109,3 +110,36 @@
NULL, error, 0, (LPTSTR)&msg, 0, NULL);
return msg;
}
+
+LPSECURITY_ATTRIBUTES win_CreateAllAccessForWorldSA(void)
+{
+ static LPSECURITY_ATTRIBUTES sa = NULL;
+ PSECURITY_DESCRIPTOR sd = NULL;
+
+ if (sa)
+ return sa;
+
+ if (!(sd = LocalAlloc(LPTR, SECURITY_DESCRIPTOR_MIN_LENGTH)))
+ goto failure;
+
+ if (!InitializeSecurityDescriptor(sd, SECURITY_DESCRIPTOR_REVISION))
+ goto failure;
+
+ if (!SetSecurityDescriptorDacl(sd, TRUE, NULL, FALSE))
+ goto failure;
+
+ if (!(sa = LocalAlloc(LPTR, sizeof (SECURITY_ATTRIBUTES))))
+ goto failure;
+
+ sa->nLength = sizeof (SECURITY_ATTRIBUTES);
+ sa->lpSecurityDescriptor = sd;
+ sa->bInheritHandle = FALSE;
+
+ return sa;
+
+failure:
+ if (sa) LocalFree(sa);
+ if (sd) LocalFree(sd);
+
+ return NULL;
+}
Modified: mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml 2007-06-12 18:53:00 UTC (rev 5616)
+++ mltonlib/trunk/com/ssh/windows/unstable/detail/windows.sml 2007-06-13 16:38:23 UTC (rev 5617)
@@ -313,6 +313,17 @@
structure SID = struct
type t = C.voidptr
end
+
+ structure SA = struct
+ type t = C.voidptr
+ val allAccessForWorld = let
+ val result = F_win_CreateAllAccessForWorldSA.f' ()
+ in
+ if not (C.Ptr.isNull' result) then result
+ else fail "Failed to initialize\
+ \ Windows.Authorization.SA.allAccessForWorld"
+ end
+ end
end
structure EventLog = struct
@@ -466,13 +477,15 @@
structure Semaphore = struct
type t = C.voidptr
- fun create {init, max, name} =
+ fun create {init, max, name, secAttr} =
one (withOpt withZs name)
(fn name' =>
raiseOnNull
(fn () => F"Semaphore.create"
- [A int init, A int max, A (opt str) name])
- F_win_CreateSemaphore.f' (null, init, max, name'))
+ [A int init, A int max, A (opt str) name,
+ A (opt ptr) secAttr])
+ F_win_CreateSemaphore.f'
+ (getOpt (secAttr, null), init, max, name'))
val close = ptrToBool "Semaphore.close" F_win_CloseHandle.f'
fun release (s, n) =
one withLong
@@ -486,12 +499,14 @@
structure Mutex = struct
type t = C.voidptr
- fun create {name, own} =
+ fun create {name, own, secAttr} =
one (withOpt withZs name)
(fn name' =>
raiseOnNull
- (fn () => F"Mutex.create"[A (opt str) name, A bool own])
- F_win_CreateMutex.f' (null, toCBool own, name'))
+ (fn () => F"Mutex.create" [A (opt str) name, A bool own,
+ A (opt ptr) secAttr])
+ F_win_CreateMutex.f'
+ (getOpt (secAttr, null), toCBool own, name'))
val close = ptrToBool "Mutex.close" F_win_CloseHandle.f'
val release = ptrToBool "Mutex.release" F_win_ReleaseMutex.f'
val toWait = id
@@ -499,12 +514,14 @@
structure Timer = struct
type t = C.voidptr
- fun create {manual, name} =
+ fun create {manual, name, secAttr} =
one (withOpt withZs name)
(fn n' =>
raiseOnNull
- (fn () => F"Timer.create"[A bool manual, A (opt str) name])
- F_win_CreateWaitableTimer.f' (null, toCBool manual, n'))
+ (fn () => F"Timer.create" [A bool manual, A (opt str) name,
+ A (opt ptr) secAttr])
+ F_win_CreateWaitableTimer.f'
+ (getOpt (secAttr, null), toCBool manual, n'))
val close = ptrToBool "Timer.close" F_win_CloseHandle.f'
fun mk name toDue {timer, due, period} = let
val due' = toDue o Int64.fromLarge
Modified: mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig
===================================================================
--- mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig 2007-06-12 18:53:00 UTC (rev 5616)
+++ mltonlib/trunk/com/ssh/windows/unstable/public/windows-ex.sig 2007-06-13 16:38:23 UTC (rev 5617)
@@ -14,6 +14,11 @@
structure SID : sig
type t
end
+
+ structure SA : sig
+ type t
+ val allAccessForWorld : t (* XXX: BAD IDEA: FULL ACCESS FOR EVERYONE *)
+ end
end
structure EventLog : sig
@@ -71,7 +76,10 @@
structure Semaphore : sig
type t
- val create : {init : Int32.t, max : Int32.t, name : String.t Option.t} -> t
+ val create : {init : Int32.t,
+ max : Int32.t,
+ name : String.t Option.t,
+ secAttr : Authorization.SA.t Option.t} -> t
val close : t Effect.t
val release : t * Int32.t -> Int32.t
val toWait : t -> Wait.t
@@ -79,7 +87,9 @@
structure Mutex : sig
type t
- val create : {name : String.t Option.t, own : Bool.t} -> t
+ val create : {name : String.t Option.t,
+ own : Bool.t,
+ secAttr : Authorization.SA.t Option.t} -> t
val close : t Effect.t
val release : t Effect.t
val toWait : t -> Wait.t
@@ -87,7 +97,9 @@
structure Timer : sig
type t
- val create : {manual : Bool.t, name : String.t Option.t} -> t
+ val create : {manual : Bool.t,
+ name : String.t Option.t,
+ secAttr : Authorization.SA.t Option.t} -> t
val close : t Effect.t
val setAbs : {timer : t,
due : Time.time,
More information about the MLton-commit
mailing list