1 /**************************************************************************/
2 /* */
3 /* OCaml */
4 /* */
5 /* David Allsopp, MetaStack Solutions Ltd. */
6 /* */
7 /* Copyright 2015 MetaStack Solutions Ltd. */
8 /* */
9 /* All rights reserved. This file is distributed under the terms of */
10 /* the GNU Lesser General Public License version 2.1, with the */
11 /* special exception on linking described in the file LICENSE. */
12 /* */
13 /**************************************************************************/
14
15 /*
16 * Windows Vista functions enabled
17 */
18 #undef _WIN32_WINNT
19 #define _WIN32_WINNT 0x0600
20
21 #include <caml/mlvalues.h>
22 #include <caml/memory.h>
23 #include <caml/alloc.h>
24 #include <caml/fail.h>
25 #include <caml/signals.h>
26 #include "unixsupport.h"
27
28 typedef BOOLEAN (WINAPI *LPFN_CREATESYMBOLICLINK) (LPTSTR, LPTSTR, DWORD);
29
30 static LPFN_CREATESYMBOLICLINK pCreateSymbolicLink = NULL;
31 static int no_symlink = 0;
32
unix_symlink(value to_dir,value osource,value odest)33 CAMLprim value unix_symlink(value to_dir, value osource, value odest)
34 {
35 CAMLparam3(to_dir, osource, odest);
36 DWORD flags = (Bool_val(to_dir) ? SYMBOLIC_LINK_FLAG_DIRECTORY : 0);
37 BOOLEAN result;
38 LPTSTR source;
39 LPTSTR dest;
40 caml_unix_check_path(osource, "symlink");
41 caml_unix_check_path(odest, "symlink");
42
43 again:
44 if (no_symlink) {
45 caml_invalid_argument("symlink not available");
46 }
47
48 if (!pCreateSymbolicLink) {
49 pCreateSymbolicLink = (LPFN_CREATESYMBOLICLINK)GetProcAddress(GetModuleHandle("kernel32"), "CreateSymbolicLinkA");
50 no_symlink = !pCreateSymbolicLink;
51 goto again;
52 }
53
54 /* Copy source and dest outside the OCaml heap */
55 source = caml_strdup(String_val(osource));
56 dest = caml_strdup(String_val(odest));
57
58 caml_enter_blocking_section();
59 result = pCreateSymbolicLink(dest, source, flags);
60 caml_leave_blocking_section();
61
62 caml_stat_free(source);
63 caml_stat_free(dest);
64
65 if (!result) {
66 win32_maperr(GetLastError());
67 uerror("symlink", odest);
68 }
69
70 CAMLreturn(Val_unit);
71 }
72
73 #define luid_eq(l, r) (l.LowPart == r.LowPart && l.HighPart == r.HighPart)
74
unix_has_symlink(value unit)75 CAMLprim value unix_has_symlink(value unit)
76 {
77 CAMLparam1(unit);
78 HANDLE hProcess = GetCurrentProcess();
79 BOOL result = FALSE;
80
81 if (OpenProcessToken(hProcess, TOKEN_READ, &hProcess)) {
82 LUID seCreateSymbolicLinkPrivilege;
83
84 if (LookupPrivilegeValue(NULL,
85 SE_CREATE_SYMBOLIC_LINK_NAME,
86 &seCreateSymbolicLinkPrivilege)) {
87 DWORD length;
88
89 if (!GetTokenInformation(hProcess, TokenPrivileges, NULL, 0, &length)) {
90 if (GetLastError() == ERROR_INSUFFICIENT_BUFFER) {
91 TOKEN_PRIVILEGES* privileges = (TOKEN_PRIVILEGES*)caml_stat_alloc(length);
92 if (GetTokenInformation(hProcess,
93 TokenPrivileges,
94 privileges,
95 length,
96 &length)) {
97 DWORD count = privileges->PrivilegeCount;
98
99 if (count) {
100 LUID_AND_ATTRIBUTES* privs = privileges->Privileges;
101 while (count-- && !(result = luid_eq(privs->Luid, seCreateSymbolicLinkPrivilege)))
102 privs++;
103 }
104 }
105
106 caml_stat_free(privileges);
107 }
108 }
109 }
110
111 CloseHandle(hProcess);
112 }
113
114 CAMLreturn(Val_bool(result));
115 }
116