├── .gitignore ├── src ├── windows │ ├── bindings │ │ ├── win_functions.ml │ │ ├── gen_functions.ml │ │ ├── dune │ │ ├── win_functions_functor.ml │ │ └── win_types.ml │ └── directories.ml ├── dune ├── directories_common.ml ├── directories.mli ├── macos │ └── directories.ml └── linux │ └── directories.ml ├── example ├── dune ├── quick_start.ml └── print_dir.ml ├── dune-project ├── shell.nix ├── CHANGES.md ├── LICENSE.md ├── .ocamlformat ├── .github └── workflows │ └── build.yml ├── directories.opam └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | _build/ 2 | *.merlin 3 | -------------------------------------------------------------------------------- /src/windows/bindings/win_functions.ml: -------------------------------------------------------------------------------- 1 | include Win_functions_functor.Apply (Win_functions_stubs) 2 | -------------------------------------------------------------------------------- /example/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name print_dir) 3 | (modules print_dir) 4 | (libraries directories)) 5 | 6 | (executable 7 | (name quick_start) 8 | (modules quick_start) 9 | (libraries directories)) 10 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.1) 2 | 3 | (name directories) 4 | 5 | (license ISC) 6 | 7 | (authors "OCamlPro ") 8 | 9 | (maintainers "OCamlPro ") 10 | 11 | (source 12 | (github ocamlpro/directories)) 13 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import { } }: 2 | 3 | let 4 | ocamlPackages = pkgs.ocaml-ng.ocamlPackages_5_3; 5 | in 6 | pkgs.mkShell { 7 | name = "frost"; 8 | dontDetectOcamlConflicts = false; 9 | nativeBuildInputs = with ocamlPackages; [ 10 | dune_3 11 | findlib 12 | merlin 13 | ocaml 14 | ocamlformat 15 | odoc 16 | ]; 17 | buildInputs = with ocamlPackages; [ 18 | fpath 19 | ]; 20 | } 21 | -------------------------------------------------------------------------------- /example/quick_start.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | let module App_id = struct 3 | let qualifier = "com" 4 | 5 | let organization = "YourCompany" 6 | 7 | let application = "yourapp" 8 | end in 9 | let module M = Directories.Project_dirs (App_id) in 10 | let option_value = function None -> "None" | Some v -> Fpath.to_string v in 11 | Format.printf "cache dir = `%s`@." (option_value M.cache_dir); 12 | Format.printf "config dir = `%s`@." (option_value M.config_dir); 13 | Format.printf "data dir = `%s`@." (option_value M.data_dir) 14 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (* -*- tuareg -*- *) 2 | 3 | open Jbuild_plugin.V1 4 | 5 | let os, libs = 6 | match List.assoc "os_type" ocamlc_config with 7 | | "Win32" -> "windows", "ctypes ctypes.stubs win_types win_functions" 8 | | _os -> begin match List.assoc "system" ocamlc_config with 9 | | "linux" -> "linux", "unix" 10 | | "macosx" -> "macos", "unix" 11 | | _system -> "linux", "unix" (* TODO: fix me *) 12 | end 13 | 14 | let () = 15 | Printf.ksprintf send 16 | {| 17 | (library 18 | (public_name directories) 19 | (wrapped false) 20 | (modules directories directories_common) 21 | (private_modules directories_common) 22 | (libraries fpath %s)) 23 | 24 | (copy_files# %s/*) 25 | |} 26 | libs os 27 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | ## unreleased 2 | 3 | ## 0.7 - 2025-11-03 4 | 5 | - fix environment variables for `config_dir` and `data_dir` (thanks @rossberg) 6 | 7 | ## 0.6 - 2025-01-28 8 | 9 | - use `Fpath.t` instead of `string` where possible 10 | 11 | ## 0.5 - 2022-01-09 12 | 13 | - add Base_dirs.state_dir, on linux it uses $XDG_STATE_HOME and default to $HOME/.local/.state on macOS and Windows it's equivalent to Base_dirs.cache_dir ; add Projects_dirs.state_dir 14 | 15 | ## 0.4 - 2021-11-25 16 | 17 | - rename module Common to Directories_common 18 | 19 | ## 0.3 - 2021-03-31 20 | 21 | - use ctypes.stubs instead of ctypes.foreign on windows 22 | - clean the windows implementation 23 | 24 | ## 0.2 - 2020-11-09 25 | 26 | - fix opam file 27 | 28 | ## 0.1 - 2020-11-08 29 | 30 | First release 31 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The ISC License (ISC) 2 | ===================== 3 | 4 | Copyright © 2020, OCamlPro 5 | 6 | Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. 7 | 8 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 9 | 10 | -------------------------------------------------------------------------------- /src/windows/bindings/gen_functions.ml: -------------------------------------------------------------------------------- 1 | let print_defines fmt = 2 | List.iter (fun (d, v) -> Format.fprintf fmt "#define %s (%s)@\n" d v) 3 | 4 | let print_headers fmt = List.iter (Format.fprintf fmt "#include <%s>@\n") 5 | 6 | let make_functions_stubs (c_defines : (string * string) list) 7 | (c_headers : string list) (functions_functor : (module Cstubs.BINDINGS)) = 8 | let fmt = Format.std_formatter in 9 | begin 10 | match Sys.argv.(1) with 11 | | "c" -> 12 | print_defines fmt c_defines; 13 | print_headers fmt c_headers; 14 | Cstubs.write_c ~prefix:"win_stub" fmt functions_functor 15 | | "ml" -> Cstubs.write_ml ~prefix:"win_stub" fmt functions_functor 16 | | s -> failwith ("unknown functions " ^ s) 17 | end; 18 | Format.pp_print_flush fmt () 19 | 20 | let () = 21 | make_functions_stubs 22 | [ ("NTDDI_VERSION", "NTDDI_VISTA") ] 23 | [ "windows.h"; "shlobj.h" ] 24 | (module Win_functions_functor.Apply) 25 | -------------------------------------------------------------------------------- /src/directories_common.ml: -------------------------------------------------------------------------------- 1 | module type App_id = sig 2 | val qualifier : string 3 | 4 | val organization : string 5 | 6 | val application : string 7 | end 8 | 9 | let relative_opt dir = if Fpath.is_rel dir then None else Some dir 10 | 11 | let getenv env = 12 | match Sys.getenv env with 13 | | exception Not_found -> None 14 | | "" -> None 15 | | v -> Some v 16 | 17 | let getenvdir env = 18 | match getenv env with 19 | | None -> None 20 | | Some v -> ( 21 | match Fpath.of_string v with Error _ -> None | Ok v -> relative_opt v ) 22 | 23 | let lower_and_replace_ws s replace = 24 | let s = String.trim s in 25 | let buff = Buffer.create (String.length s) in 26 | let should_replace = ref false in 27 | for i = 0 to String.length s - 1 do 28 | match s.[i] with 29 | | ' ' | '\012' | '\n' | '\r' | '\t' -> 30 | if !should_replace then ( 31 | Buffer.add_string buff replace; 32 | should_replace := false ) 33 | | c -> 34 | Buffer.add_char buff c; 35 | should_replace := true 36 | done; 37 | String.lowercase_ascii (Buffer.contents buff) 38 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version=0.27.0 2 | assignment-operator=end-line 3 | break-cases=fit 4 | break-fun-decl=wrap 5 | break-fun-sig=wrap 6 | break-infix=wrap 7 | break-infix-before-func=false 8 | break-separators=before 9 | break-sequences=true 10 | cases-exp-indent=2 11 | cases-matching-exp-indent=normal 12 | doc-comments=before 13 | doc-comments-padding=2 14 | doc-comments-tag-only=default 15 | dock-collection-brackets=false 16 | exp-grouping=preserve 17 | field-space=loose 18 | if-then-else=compact 19 | indicate-multiline-delimiters=space 20 | indicate-nested-or-patterns=unsafe-no 21 | infix-precedence=indent 22 | leading-nested-match-parens=false 23 | let-and=sparse 24 | let-binding-spacing=compact 25 | let-module=compact 26 | margin=80 27 | max-indent=2 28 | module-item-spacing=sparse 29 | ocaml-version=4.14.0 30 | ocp-indent-compat=false 31 | parens-ite=false 32 | parens-tuple=always 33 | parse-docstrings=true 34 | sequence-blank-line=preserve-one 35 | sequence-style=terminator 36 | single-case=compact 37 | space-around-arrays=true 38 | space-around-lists=true 39 | space-around-records=true 40 | space-around-variants=true 41 | type-decl=sparse 42 | wrap-comments=false 43 | wrap-fun-args=true 44 | -------------------------------------------------------------------------------- /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | on: 3 | pull_request: 4 | branches: 5 | - main 6 | push: 7 | branches: 8 | - main 9 | jobs: 10 | build: 11 | strategy: 12 | fail-fast: false 13 | matrix: 14 | os: 15 | - macos-latest 16 | - ubuntu-latest 17 | - windows-latest 18 | ocaml-compiler: 19 | - "5.3" 20 | include: 21 | - os: ubuntu-latest 22 | ocaml-compiler: "4.14" 23 | runs-on: ${{ matrix.os }} 24 | steps: 25 | - name: checkout 26 | uses: actions/checkout@v4 27 | - name: setup-ocaml 28 | uses: ocaml/setup-ocaml@v3 29 | with: 30 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 31 | - name: setup 32 | run: | 33 | opam pin add . -y --no-action 34 | opam depext -y directories 35 | opam install -y ./*.opam --deps-only --with-test 36 | opam upgrade --fixup 37 | - name: build 38 | run: opam exec -- dune build @install 39 | - name: test 40 | run: | 41 | opam exec -- dune runtest 42 | opam exec -- dune build example/print_dir.exe 43 | opam exec -- dune exec example/print_dir.exe 44 | -------------------------------------------------------------------------------- /directories.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: 3 | "An OCaml library that provides configuration, cache and data paths (and more!) following the suitable conventions on Linux, macOS and Windows" 4 | description: 5 | "directories is an OCaml library that provides configuration, cache and data paths (and more!) following the suitable conventions on Linux, macOS and Windows. It is inspired by similar libraries for other languages such as directories-jvm. The following conventions are used: XDG Base Directory Specification and xdg-user-dirs on Linux, Known Folders on Windows, Standard Directories on macOS." 6 | maintainer: ["OCamlPro "] 7 | authors: ["OCamlPro "] 8 | license: "ISC" 9 | homepage: "https://github.com/ocamlpro/directories" 10 | bug-reports: "https://github.com/ocamlpro/directories/issues" 11 | depends: [ 12 | "dune" {>= "2.1"} 13 | "ocaml" {>= "4.14.0"} 14 | "ctypes" {>= "0.17.1" & (os = "win32" | os = "cygwin")} 15 | "fpath" 16 | ] 17 | build: [ 18 | ["dune" "subst"] {pinned} 19 | [ 20 | "dune" 21 | "build" 22 | "-p" 23 | name 24 | "-j" 25 | jobs 26 | "@install" 27 | "@runtest" {with-test} 28 | "@doc" {with-doc} 29 | ] 30 | ] 31 | dev-repo: "git+https://github.com/ocamlpro/directories.git" 32 | -------------------------------------------------------------------------------- /src/directories.mli: -------------------------------------------------------------------------------- 1 | module Base_dirs () : sig 2 | val home_dir : Fpath.t option 3 | 4 | val cache_dir : Fpath.t option 5 | 6 | val config_dir : Fpath.t option 7 | 8 | val data_dir : Fpath.t option 9 | 10 | val data_local_dir : Fpath.t option 11 | 12 | val preference_dir : Fpath.t option 13 | 14 | val runtime_dir : Fpath.t option 15 | 16 | val state_dir : Fpath.t option 17 | 18 | val executable_dir : Fpath.t option 19 | end 20 | 21 | module User_dirs () : sig 22 | val home_dir : Fpath.t option 23 | 24 | val audio_dir : Fpath.t option 25 | 26 | val desktop_dir : Fpath.t option 27 | 28 | val document_dir : Fpath.t option 29 | 30 | val download_dir : Fpath.t option 31 | 32 | val font_dir : Fpath.t option 33 | 34 | val picture_dir : Fpath.t option 35 | 36 | val public_dir : Fpath.t option 37 | 38 | val template_dir : Fpath.t option 39 | 40 | val video_dir : Fpath.t option 41 | end 42 | 43 | module Project_dirs (App_id : sig 44 | val qualifier : string 45 | 46 | val organization : string 47 | 48 | val application : string 49 | end) : sig 50 | val cache_dir : Fpath.t option 51 | 52 | val config_dir : Fpath.t option 53 | 54 | val data_dir : Fpath.t option 55 | 56 | val data_local_dir : Fpath.t option 57 | 58 | val preference_dir : Fpath.t option 59 | 60 | val runtime_dir : Fpath.t option 61 | 62 | val state_dir : Fpath.t option 63 | end 64 | -------------------------------------------------------------------------------- /src/windows/bindings/dune: -------------------------------------------------------------------------------- 1 | (* -*- tuareg -*- *) 2 | 3 | open Jbuild_plugin.V1 4 | 5 | let is_windows = 6 | match List.assoc "os_type" ocamlc_config with 7 | | "Win32" -> true 8 | | _os -> false 9 | 10 | let () = 11 | if not is_windows then 12 | Printf.ksprintf send "" 13 | else 14 | Printf.ksprintf send "%s" 15 | {| 16 | 17 | (library 18 | (name win_types) 19 | (public_name directories.win_types) 20 | (modules win_types) 21 | (libraries ctypes) 22 | (wrapped false)) 23 | 24 | (library 25 | (name win_functions_functor) 26 | (public_name directories.win_functions_functor) 27 | (modules win_functions_functor) 28 | (libraries win_types ctypes ctypes.stubs) 29 | (wrapped false)) 30 | 31 | (executable 32 | (name gen_functions) 33 | (modules gen_functions) 34 | (libraries win_functions_functor ctypes ctypes.stubs)) 35 | 36 | (rule 37 | (target win_functions_c_stubs.c) 38 | (deps gen_functions.exe) 39 | (action (with-stdout-to %{target} (run %{deps} c)))) 40 | 41 | (rule 42 | (target win_functions_stubs.ml) 43 | (deps gen_functions.exe) 44 | (action (with-stdout-to %{target} (run %{deps} ml)))) 45 | 46 | (library 47 | (name win_functions) 48 | (public_name directories.win_functions) 49 | (modules win_functions_stubs win_functions) 50 | (libraries win_functions_functor win_types ctypes ctypes.stubs) 51 | (foreign_stubs (language c) (names win_functions_c_stubs)) 52 | (c_library_flags (:standard -lkernel32 -lshell32)) 53 | (wrapped false)) 54 | 55 | |} 56 | -------------------------------------------------------------------------------- /src/windows/bindings/win_functions_functor.ml: -------------------------------------------------------------------------------- 1 | module Apply (F : Cstubs.FOREIGN) = struct 2 | open Ctypes 3 | open F 4 | open Win_types 5 | 6 | module Kernel32 = struct 7 | (** see 8 | https://docs.microsoft.com/en-us/windows/win32/api/stringapiset/nf-stringapiset-widechartomultibyte 9 | *) 10 | 11 | let wide_char_to_multi_byte = 12 | foreign "WideCharToMultiByte" 13 | ( UINT.t (* UINT CodePage *) @-> DWORD.t 14 | (* DWORD dwFlags *) 15 | @-> LPWCH.t 16 | (* LPCWCH lpWideCharStr *) 17 | @-> Int.t 18 | (* int cchWideChar *) 19 | @-> LPSTR.t 20 | (* LPSTR lpMultiByteStr *) 21 | @-> Int.t 22 | (* int cbMultiByte *) 23 | @-> LPCH.t 24 | (* LPCCH lpDefaultChar *) 25 | @-> LPBOOL.t 26 | @-> 27 | (* LPBOOL lpUsedDefaultChar *) 28 | returning Int.t (* int *) ) 29 | end 30 | 31 | module Shell32 = struct 32 | (** see 33 | https://docs.microsoft.com/en-us/windows/win32/api/shlobj_core/nf-shlobj_core-shgetknownfolderpath 34 | *) 35 | 36 | let sh_get_known_folder_path = 37 | foreign "SHGetKnownFolderPath" 38 | ( ptr GUID.t 39 | (* REFKNOWNFOLDERID rfid (= GUID * ) *) 40 | @-> Known_folder_flag.t 41 | (* DWORD dwFlags (= unsigned long) *) 42 | @-> Token.t 43 | (* HANDLE hToken (= void * ) *) 44 | @-> ptr PWSTR.t 45 | @-> 46 | (* PWSTR * ppszPath (= short unsigned int ** ) *) 47 | returning Hresult.t (* HRESULT *) ) 48 | end 49 | end 50 | -------------------------------------------------------------------------------- /example/print_dir.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | (* The directories module *) 3 | let module M = Directories in 4 | (* The base dirs module *) 5 | let module B = M.Base_dirs () in 6 | (* The user dirs module *) 7 | let module U = M.User_dirs () in 8 | (* In order to instanciate the Project_dir functor, we need a module for our project *) 9 | let module OCamlPro_path = struct 10 | let qualifier = "com" 11 | 12 | let organization = "OCamlPro" 13 | 14 | let application = "print_dir" 15 | end in 16 | (* The project dirs module for our project *) 17 | let module P = M.Project_dirs (OCamlPro_path) in 18 | (* functions to print a dir path *) 19 | let print_dir = function 20 | | None, s -> Format.printf " %s None@." s 21 | | Some dir, s -> Format.printf " %s Some `%a`@." s Fpath.pp dir 22 | in 23 | let print_dirs = List.iter print_dir in 24 | 25 | (* Printing base dirs *) 26 | Format.printf "* Base dirs:@."; 27 | print_dirs 28 | [ (B.home_dir, "home_dir: ") 29 | ; (B.cache_dir, "cache_dir: ") 30 | ; (B.config_dir, "config_dir: ") 31 | ; (B.data_dir, "data_dir: ") 32 | ; (B.data_local_dir, "data_local_dir:") 33 | ; (B.preference_dir, "preference_dir:") 34 | ; (B.runtime_dir, "runtime_dir: ") 35 | ; (B.state_dir, "state_dir: ") 36 | ; (B.executable_dir, "executable_dir:") 37 | ]; 38 | 39 | (* Printing user dirs *) 40 | Format.printf "* User dirs:@."; 41 | print_dirs 42 | [ (U.home_dir, "home_dir: ") 43 | ; (U.audio_dir, "audio_dir: ") 44 | ; (U.desktop_dir, "desktop_dir: ") 45 | ; (U.document_dir, "document_dir: ") 46 | ; (U.download_dir, "download_dir: ") 47 | ; (U.font_dir, "font_dir: ") 48 | ; (U.picture_dir, "picture_dir: ") 49 | ; (U.public_dir, "public_dir: ") 50 | ; (U.template_dir, "template_dir: ") 51 | ; (U.video_dir, "video_dir: ") 52 | ]; 53 | 54 | (* Printing project dirs*) 55 | Format.printf "* Project dirs:@."; 56 | print_dirs 57 | [ (P.cache_dir, "cache_dir: ") 58 | ; (P.config_dir, "config_dir: ") 59 | ; (P.data_dir, "data_dir: ") 60 | ; (P.data_local_dir, "data_local_dir:") 61 | ; (P.preference_dir, "preference_dir:") 62 | ; (P.state_dir, "state_dir: ") 63 | ; (P.runtime_dir, "runtime_dir: ") 64 | ] 65 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # directories [![Actions Status](https://github.com/ocamlpro/directories/workflows/build/badge.svg)](https://github.com/ocamlpro/directories/actions) 2 | 3 | directories is an [OCaml] library that provides configuration, cache and data paths (and more!) following the suitable conventions on [Linux], [macOS] and [Windows]. It is inspired by similar libraries for other languages such as [directories-jvm]. 4 | 5 | The following conventions are used: 6 | 7 | - [XDG Base Directory Specification] and [xdg-user-dirs] on Linux 8 | - [Known Folders] on Windows 9 | - [Standard Directories] on macOS 10 | 11 | It only depends on [fpath]. On Windows, it also has a build-dependency on [ctypes]. 12 | 13 | ## Quickstart 14 | 15 | You should depend on `directories` then : 16 | 17 | ```ocaml 18 | let () = 19 | let module App_id = struct 20 | let qualifier = "com" 21 | let organization = "YourCompany" 22 | let application = "yourapp" 23 | end in 24 | let module M = Directories.Project_dirs (App_id) in 25 | let option_value = function None -> "None" | Some v -> v in 26 | Format.printf "cache dir = `%s`@." (option_value M.cache_dir); 27 | Format.printf "config dir = `%s`@." (option_value M.config_dir); 28 | Format.printf "data dir = `%s`@." (option_value M.data_dir) 29 | ``` 30 | 31 | For more, have a look at the [example] folder. 32 | 33 | ## About 34 | 35 | - [LICENSE] 36 | - [CHANGELOG] 37 | 38 | [CHANGELOG]: ./CHANGES.md 39 | [example]: ./example/ 40 | [LICENSE]: ./LICENSE.md 41 | 42 | [ctypes]: https://github.com/ocamllabs/ocaml-ctypes 43 | [directories-jvm]: https://github.com/dirs-dev/directories-jvm 44 | [fpath]: https://erratique.ch/software/fpath 45 | [Known Folders]: https://docs.microsoft.com/fr-fr/windows/win32/shell/known-folders 46 | [Linux]: https://en.wikipedia.org/wiki/Linux 47 | [macOS]: https://en.wikipedia.org/wiki/MacOS 48 | [OCaml]: https://en.wikipedia.org/wiki/OCaml 49 | [Standard Directories]: https://developer.apple.com/library/archive/documentation/FileManagement/Conceptual/FileSystemProgrammingGuide/FileSystemOverview/FileSystemOverview.html#//apple_ref/doc/uid/TP40010672-CH2-SW6 50 | [xdg-user-dirs]: https://www.freedesktop.org/wiki/Software/xdg-user-dirs 51 | [XDG Base Directory Specification]: https://specifications.freedesktop.org/basedir/latest 52 | [Windows]: https://en.wikipedia.org/wiki/Microsoft_Windows 53 | -------------------------------------------------------------------------------- /src/windows/directories.ml: -------------------------------------------------------------------------------- 1 | open Ctypes 2 | open Directories_common 3 | open Win_types 4 | open Win_functions 5 | 6 | let wstring_to_string wstr = 7 | let path_len = 8 | Kernel32.wide_char_to_multi_byte 65001l 0l wstr (-1l) LPSTR.null 0l 9 | LPCH.null LPBOOL.null 10 | in 11 | let path = allocate_n CHAR.t ~count:(Int32.to_int path_len) in 12 | let _ = 13 | Kernel32.wide_char_to_multi_byte 65001l 0l wstr (-1l) path path_len 14 | LPCH.null LPBOOL.null 15 | in 16 | coerce LPSTR.t string path 17 | 18 | let get_folderid id = 19 | let wpath_ptr = allocate PWSTR.t PWSTR.null in 20 | let result = 21 | Shell32.sh_get_known_folder_path 22 | (addr (GUID.to_guid id)) 23 | Known_folder_flag.Default Token.Current_user wpath_ptr 24 | in 25 | match result with 26 | | S_ok -> 27 | let s = wstring_to_string !@wpath_ptr in 28 | Fpath.of_string s |> Result.to_option 29 | | _err -> None 30 | 31 | module Base_dirs () = struct 32 | (** `FOLDERID_UserProfile` *) 33 | let home_dir : Fpath.t option = get_folderid GUID.UserProfile 34 | 35 | (** `FOLDERID_LocalApplicationData` *) 36 | let cache_dir = get_folderid GUID.LocalApplicationData 37 | 38 | (** `FOLDERID_ApplicationData` *) 39 | let config_dir = get_folderid GUID.ApplicationData 40 | 41 | (** `FOLDERID_ApplicationData` *) 42 | let data_dir = get_folderid GUID.ApplicationData 43 | 44 | (** `FOLDERID_LocalApplicationData` *) 45 | let data_local_dir = get_folderid GUID.LocalApplicationData 46 | 47 | (** `FOLDERID_ApplicationData` *) 48 | let preference_dir = get_folderid GUID.ApplicationData 49 | 50 | (** None *) 51 | let runtime_dir = None 52 | 53 | let state_dir = cache_dir 54 | 55 | (** None *) 56 | let executable_dir = None 57 | end 58 | 59 | module User_dirs () = struct 60 | module Base_dirs = Base_dirs () 61 | 62 | (** `FOLDERID_UserProfile` *) 63 | let home_dir = Base_dirs.home_dir 64 | 65 | (** `FOLDERID_Music` *) 66 | let audio_dir = get_folderid GUID.Music 67 | 68 | (** `FOLDERID_Desktop` *) 69 | let desktop_dir = get_folderid GUID.Desktop 70 | 71 | (** `FOLDERID_Documents` *) 72 | let document_dir = get_folderid GUID.Documents 73 | 74 | (** `FOLDERID_Downloads` *) 75 | let download_dir = get_folderid GUID.Downloads 76 | 77 | (** None *) 78 | let font_dir = None 79 | 80 | (** `FOLDERID_Pictures` *) 81 | let picture_dir = get_folderid GUID.Pictures 82 | 83 | (** `FOLDERID_Public` *) 84 | let public_dir = get_folderid GUID.Public 85 | 86 | (** `FOLDERID_Templates` *) 87 | let template_dir = get_folderid GUID.Templates 88 | 89 | (** `FOLDERID_Videos` *) 90 | let video_dir = get_folderid GUID.Videos 91 | end 92 | 93 | module Project_dirs (App_id : App_id) = struct 94 | let mk folderid dir = 95 | Option.map 96 | (fun folderid_path -> 97 | Fpath.(folderid_path / App_id.organization / App_id.application / dir) ) 98 | (get_folderid folderid) 99 | 100 | (** `FOLDERID_LocalApplicationData`//cache *) 101 | let cache_dir = mk GUID.LocalApplicationData "cache" 102 | 103 | (** `FOLDERID_ApplicationData`//config *) 104 | let config_dir = mk GUID.ApplicationData "config" 105 | 106 | (** `FOLDERID_ApplicationData`//data *) 107 | let data_dir = mk GUID.ApplicationData "data" 108 | 109 | (** `FOLDERID_LocalApplicationData`//data *) 110 | let data_local_dir = mk GUID.LocalApplicationData "data" 111 | 112 | (** `FOLDERID_ApplicationData`//config *) 113 | let preference_dir = mk GUID.ApplicationData "config" 114 | 115 | let state_dir = cache_dir 116 | 117 | (** None *) 118 | let runtime_dir = None 119 | end 120 | -------------------------------------------------------------------------------- /src/macos/directories.ml: -------------------------------------------------------------------------------- 1 | open Directories_common 2 | 3 | module Base_dirs () = struct 4 | (** $HOME or initial working directory value for the current user (taken from 5 | user database) *) 6 | let home_dir = 7 | match getenvdir "HOME" with 8 | | None -> ( 9 | match (Unix.getpwuid (Unix.getuid ())).Unix.pw_dir with 10 | | exception Unix.Unix_error _ -> None 11 | | exception Not_found -> None 12 | | dir -> 13 | let dir = Fpath.of_string dir |> Result.to_option in 14 | Option.bind dir relative_opt ) 15 | | Some _ as dir -> dir 16 | 17 | (** $HOME/Library/Caches *) 18 | let cache_dir = 19 | Option.map (fun dir -> Fpath.(dir / "Library" / "Caches")) home_dir 20 | 21 | (** $HOME/Library/Application Support *) 22 | let config_dir = 23 | Option.map 24 | (fun dir -> Fpath.(dir / "Library" / "Application Support")) 25 | home_dir 26 | 27 | (** $HOME/Library/Application Support *) 28 | let data_dir = 29 | Option.map 30 | (fun dir -> Fpath.(dir / "Library" / "Application Support")) 31 | home_dir 32 | 33 | (** $HOME/Library/Application Support *) 34 | let data_local_dir = data_dir 35 | 36 | (** $HOME/Library/Preferences *) 37 | let preference_dir = 38 | Option.map (fun dir -> Fpath.(dir / "Library" / "Preferences")) home_dir 39 | 40 | (** None *) 41 | let runtime_dir = None 42 | 43 | let state_dir = cache_dir 44 | 45 | (** None *) 46 | let executable_dir = None 47 | end 48 | 49 | module User_dirs () = struct 50 | module Base_dirs = Base_dirs () 51 | 52 | (** $HOME or initial working directory value for the current user (taken from 53 | user database) *) 54 | let home_dir = Base_dirs.home_dir 55 | 56 | let concat_home_dir suffix = 57 | Option.map (fun dir -> Fpath.(dir / suffix)) home_dir 58 | 59 | (** $HOME/Music *) 60 | let audio_dir = concat_home_dir "Music" 61 | 62 | (** $HOME/Desktop *) 63 | let desktop_dir = concat_home_dir "Desktop" 64 | 65 | (** $HOME/Documents *) 66 | let document_dir = concat_home_dir "Documents" 67 | 68 | (** $HOME/Downloads *) 69 | let download_dir = concat_home_dir "Downloads" 70 | 71 | (** $HOME/Library/Fonts *) 72 | let font_dir = 73 | let library_dir = concat_home_dir "Library" in 74 | Option.map (fun dir -> Fpath.(dir / "Fonts")) library_dir 75 | 76 | (** $HOME/Pictures *) 77 | let picture_dir = concat_home_dir "Pictures" 78 | 79 | (** $HOME/Public *) 80 | let public_dir = concat_home_dir "Public" 81 | 82 | (** None *) 83 | let template_dir = None 84 | 85 | (** $HOME/Movies *) 86 | let video_dir = concat_home_dir "Movies" 87 | end 88 | 89 | module Project_dirs (App_id : App_id) = struct 90 | module Base_dirs = Base_dirs () 91 | 92 | let qualifier = Directories_common.lower_and_replace_ws App_id.qualifier "-" 93 | 94 | let organization = 95 | Directories_common.lower_and_replace_ws App_id.organization "-" 96 | 97 | let application = 98 | Directories_common.lower_and_replace_ws App_id.application "-" 99 | 100 | let project_path = 101 | Format.sprintf "%s.%s.%s" qualifier organization application 102 | 103 | let concat_project_path = Option.map (fun dir -> Fpath.(dir / project_path)) 104 | 105 | (** $HOME/Libary/Caches/ *) 106 | let cache_dir = concat_project_path Base_dirs.cache_dir 107 | 108 | (** $HOME/Library/Application Support/ *) 109 | let config_dir = concat_project_path Base_dirs.config_dir 110 | 111 | (** $HOME/Library/Application Support/ *) 112 | let data_dir = concat_project_path Base_dirs.data_dir 113 | 114 | (** $HOME/Library/Application Support/ *) 115 | let data_local_dir = data_dir 116 | 117 | (** $HOME/Library/Preferences/ *) 118 | let preference_dir = concat_project_path Base_dirs.preference_dir 119 | 120 | let state_dir = cache_dir 121 | 122 | (** None *) 123 | let runtime_dir = None 124 | end 125 | -------------------------------------------------------------------------------- /src/linux/directories.ml: -------------------------------------------------------------------------------- 1 | open Directories_common 2 | 3 | module Base_dirs () = struct 4 | (** $HOME or initial working directory value for the current user (taken from 5 | user database) *) 6 | let home_dir = 7 | match getenvdir "HOME" with 8 | | None -> ( 9 | match (Unix.getpwuid (Unix.getuid ())).Unix.pw_dir with 10 | | exception Unix.Unix_error _ -> None 11 | | exception Not_found -> None 12 | | dir -> 13 | let dir = Fpath.of_string dir |> Result.to_option in 14 | Option.bind dir relative_opt ) 15 | | Some _dir as dir -> dir 16 | 17 | (** $XDG_CACHE_HOME or $HOME/.cache *) 18 | let cache_dir = 19 | match getenvdir "XDG_CACHE_HOME" with 20 | | None -> Option.map (fun dir -> Fpath.(dir / ".cache")) home_dir 21 | | Some _dir as dir -> dir 22 | 23 | (** $XDG_CONFIG_HOME or $HOME/.config *) 24 | let config_dir = 25 | match getenvdir "XDG_CONFIG_HOME" with 26 | | None -> Option.map (fun dir -> Fpath.(dir / ".config")) home_dir 27 | | Some _dir as dir -> dir 28 | 29 | (** $XDG_DATA_HOME or $HOME/.local/share *) 30 | let data_dir = 31 | match getenvdir "XDG_DATA_HOME" with 32 | | None -> Option.map (fun dir -> Fpath.(dir / ".local" / "share")) home_dir 33 | | Some _dir as dir -> dir 34 | 35 | (** $XDG_DATA_HOME or $HOME/.local/share *) 36 | let data_local_dir = data_dir 37 | 38 | (** $XDG_CONFIG_HOME or $HOME/.config *) 39 | let preference_dir = config_dir 40 | 41 | (** $XDG_STATE_HOME or $HOME/.local/state *) 42 | let state_dir = 43 | match getenvdir "XDG_STATE_HOME" with 44 | | None -> Option.map (fun dir -> Fpath.(dir / ".local" / "state")) home_dir 45 | | Some _dir as dir -> dir 46 | 47 | (** $XDG_RUNTIME_DIR *) 48 | let runtime_dir = getenvdir "XDG_RUNTIME_DIR" 49 | 50 | (** $XDG_BIN_HOME or $XDG_DATA_HOME/../bin or $HOME/.local/bin *) 51 | let executable_dir = 52 | match getenvdir "XDG_BIN_HOME" with 53 | | None -> ( 54 | match getenvdir "XDG_DATA_HOME" with 55 | | None -> Option.map (fun dir -> Fpath.(dir / ".local" / "bin")) home_dir 56 | | Some dir -> Some Fpath.(dir / ".." / "bin") ) 57 | | Some _dir as dir -> dir 58 | end 59 | 60 | module User_dirs () = struct 61 | module Base_dirs = Base_dirs () 62 | 63 | (** $HOME or initial working directory value for the current user (taken from 64 | user database) *) 65 | let home_dir = Base_dirs.home_dir 66 | 67 | let user_dirs = 68 | Option.map (fun dir -> Fpath.(dir / "user-dirs.dirs")) Base_dirs.config_dir 69 | 70 | let user_dirs = 71 | Option.bind user_dirs (fun f -> 72 | (* TODO: use Bos here instead of Sys? *) 73 | if Sys.file_exists (Fpath.to_string f) then Some f else None ) 74 | 75 | let user_dirs = 76 | Option.bind user_dirs (fun f -> 77 | (* TODO: use Bos here instead of Sys? *) 78 | if Sys.is_directory (Fpath.to_string f) then None else Some f ) 79 | 80 | let user_shell = getenv "SHELL" 81 | 82 | let get_user_dir dir = 83 | match (user_shell, user_dirs) with 84 | | Some sh, Some f -> ( 85 | try 86 | let chan = 87 | Unix.open_process_in 88 | (Format.asprintf "%s -c '. %a && echo \"$XDG_%s_DIR\"'" sh Fpath.pp 89 | f dir ) 90 | in 91 | let xdg = input_line chan in 92 | let result = Unix.close_process_in chan in 93 | match result with 94 | | WEXITED 0 -> begin 95 | match Fpath.of_string xdg with Error _ -> None | Ok xdg -> Some xdg 96 | end 97 | | _ -> None 98 | with _ -> None ) 99 | | _ -> None 100 | 101 | let get_user_dir (env, default) = 102 | match get_user_dir env with 103 | | Some v -> Some v 104 | | None -> Option.map (fun dir -> Fpath.(dir / default)) home_dir 105 | 106 | (** Defaults can be found here 107 | https://cgit.freedesktop.org/xdg/xdg-user-dirs/tree/user-dirs.defaults *) 108 | 109 | (** $XDG_MUSIC_DIR *) 110 | let audio_dir = get_user_dir ("MUSIC", "Music") 111 | 112 | (** $XDG_DESKTOP_DIR *) 113 | let desktop_dir = get_user_dir ("DESKTOP", "Desktop") 114 | 115 | (** $XDG_DOCUMENTS_DIR *) 116 | let document_dir = get_user_dir ("DOCUMENTS", "Documents") 117 | 118 | (** $XDG_DOWNLOAD_DIR *) 119 | let download_dir = get_user_dir ("DOWNLOAD", "Downloads") 120 | 121 | (** $XDG_DATA_HOME/fonts or $HOME/.local/share/fonts *) 122 | let font_dir = 123 | match getenvdir "XDG_DATA_HOME" with 124 | | None -> 125 | Option.map 126 | (fun dir -> Fpath.(dir / ".local" / "share" / "fonts")) 127 | home_dir 128 | | Some dir -> Some Fpath.(dir / "fonts") 129 | 130 | (** $XDG_PICTURES_DIR *) 131 | let picture_dir = get_user_dir ("PICTURES", "Pictures") 132 | 133 | (** $XDG_PUBLIC_DIR *) 134 | let public_dir = get_user_dir ("PUBLICSHARE", "Public") 135 | 136 | (** $XDG_TEMPLATES_DIR *) 137 | let template_dir = get_user_dir ("TEMPLATES", "Templates") 138 | 139 | (** $XDG_VIDEOS_DIR *) 140 | let video_dir = get_user_dir ("VIDEOS", "Videos") 141 | end 142 | 143 | module Project_dirs (App_id : App_id) = struct 144 | module Base_dirs = Base_dirs () 145 | 146 | let project_path = 147 | Directories_common.lower_and_replace_ws App_id.application "" 148 | 149 | let concat_project_path = Option.map (fun dir -> Fpath.(dir / project_path)) 150 | 151 | (** $XDG_CACHE_HOME/ or $HOME/.cache/ *) 152 | let cache_dir = concat_project_path Base_dirs.cache_dir 153 | 154 | (** $XDG_CONFIG_HOME/ or $HOME/.config/ *) 155 | let config_dir = concat_project_path Base_dirs.config_dir 156 | 157 | (** $XDG_DATA_HOME/ or $HOME/.local/share/ *) 158 | let data_dir = concat_project_path Base_dirs.data_dir 159 | 160 | (** $XDG_DATA_HOME/ or $HOME/.local/share/ *) 161 | let data_local_dir = data_dir 162 | 163 | (** $XDG_CONFIG_HOME/ or $HOME/.config/ *) 164 | let preference_dir = config_dir 165 | 166 | (** $XDG_STATE_HOME/ or $HOME/.local/state/ *) 167 | let state_dir = concat_project_path Base_dirs.state_dir 168 | 169 | (** $XDG_RUNTIME_DIR/ *) 170 | let runtime_dir = concat_project_path Base_dirs.runtime_dir 171 | end 172 | -------------------------------------------------------------------------------- /src/windows/bindings/win_types.ml: -------------------------------------------------------------------------------- 1 | open Ctypes 2 | 3 | module CHAR = struct 4 | type t = char typ 5 | 6 | let t = char 7 | end 8 | 9 | module LPCH = struct 10 | type t = CHAR.t ptr typ 11 | 12 | let t = ptr CHAR.t 13 | 14 | let null = from_voidp CHAR.t Ctypes.null 15 | end 16 | 17 | module PCH = LPCH 18 | 19 | module WCHAR = struct 20 | type t = int typ 21 | 22 | let t = uint16_t 23 | end 24 | 25 | module LPWCH = struct 26 | type t = WCHAR.t ptr typ 27 | 28 | let t = ptr WCHAR.t 29 | 30 | let null = from_voidp WCHAR.t Ctypes.null 31 | end 32 | 33 | module PWCH = LPWCH 34 | 35 | module BOOL = struct 36 | type t = bool 37 | 38 | let of_int32 i = not (Int32.equal Int32.zero i) 39 | 40 | let to_int32 b = if b then Int32.one else Int32.zero 41 | 42 | let t = Ctypes.view ~read:of_int32 ~write:to_int32 Ctypes.int32_t 43 | end 44 | 45 | module LPBOOL = struct 46 | type t = BOOL.t ptr typ 47 | 48 | let t = ptr BOOL.t 49 | 50 | let null = from_voidp BOOL.t Ctypes.null 51 | end 52 | 53 | module PBOOL = LPBOOL 54 | 55 | module Int = struct 56 | type t = int32 typ 57 | 58 | let t = int32_t 59 | end 60 | 61 | module UINT = struct 62 | type t = int32 typ 63 | 64 | let t = int32_t 65 | end 66 | 67 | module DWORD = struct 68 | type t = int32 typ 69 | 70 | let t = int32_t 71 | end 72 | 73 | module LPSTR = struct 74 | type t = CHAR.t ptr typ 75 | 76 | let t = ptr CHAR.t 77 | 78 | let null = from_voidp CHAR.t Ctypes.null 79 | end 80 | 81 | module PSTR = LPSTR 82 | 83 | module LPWSTR = struct 84 | type t = WCHAR.t ptr typ 85 | 86 | let t = ptr WCHAR.t 87 | 88 | let null = from_voidp WCHAR.t Ctypes.null 89 | end 90 | 91 | module PWSTR = LPWSTR 92 | 93 | (** see 94 | https://docs.microsoft.com/en-us/windows/win32/api/shlobj_core/ne-shlobj_core-known_folder_flag 95 | *) 96 | module Known_folder_flag = struct 97 | type t = 98 | | Default 99 | | Force_app_data_redirection 100 | | Return_filter_redirection_target 101 | | Force_package_redirection 102 | | No_package_redirection 103 | | Create 104 | | Dont_verify 105 | | Dont_unexpand 106 | | No_alias 107 | | Init 108 | | Default_path 109 | | Not_parent_relative 110 | | Simple_idlist 111 | | Alias_only 112 | 113 | let to_int32 = function 114 | | Default -> 0x00000000l 115 | | Force_app_data_redirection -> 0x00080000l 116 | | Return_filter_redirection_target -> 0x00040000l 117 | | Force_package_redirection -> 118 | 0x00020000l (* replaces Force_appcontainer_redirection *) 119 | | No_package_redirection -> 120 | 0x00010000l (* replaces No_appcontainer_redirection *) 121 | | Create -> 0x00008000l 122 | | Dont_verify -> 0x00004000l 123 | | Dont_unexpand -> 0x00002000l 124 | | No_alias -> 0x00001000l 125 | | Init -> 0x00000800l 126 | | Default_path -> 0x00000400l 127 | | Not_parent_relative -> 0x00000200l 128 | | Simple_idlist -> 0x0000000100l 129 | | Alias_only -> 0x80000000l 130 | 131 | let of_int32 = function 132 | | 0x00000000l -> Default 133 | | 0x00080000l -> Force_app_data_redirection 134 | | 0x00040000l -> Return_filter_redirection_target 135 | | 0x00020000l -> 136 | Force_package_redirection (* Force_appcontainer_redirection *) 137 | | 0x00010000l -> No_package_redirection (* No_appcontainer_redirection *) 138 | | 0x00008000l -> Create 139 | | 0x00004000l -> Dont_verify 140 | | 0x00002000l -> Dont_unexpand 141 | | 0x00001000l -> No_alias 142 | | 0x00000800l -> Init 143 | | 0x00000400l -> Default_path 144 | | 0x00000200l -> Not_parent_relative 145 | | 0x00000100l -> Simple_idlist 146 | | 0x80000000l -> Alias_only 147 | | n -> 148 | raise 149 | @@ Invalid_argument (Format.sprintf "Known_folder_flag.of_int: %ld" n) 150 | 151 | let t = Ctypes.view ~read:of_int32 ~write:to_int32 Ctypes.int32_t 152 | end 153 | 154 | (** see https://docs.microsoft.com/en-us/windows/win32/secauthz/access-tokens * 155 | as we don't want into troubles, we just bind what we might need... *) 156 | module Token = struct 157 | type t = 158 | | Default_user 159 | | Current_user 160 | 161 | let to_ptr t = 162 | let i = match t with Default_user -> -1 | Current_user -> 0 in 163 | Ctypes.ptr_of_raw_address (Nativeint.of_int i) 164 | 165 | let of_ptr p = 166 | match Nativeint.to_int (Ctypes.raw_address_of_ptr p) with 167 | | -1 -> Default_user 168 | | 0 -> Current_user 169 | | n -> raise @@ Invalid_argument (Format.sprintf "Token.of_int: %d" n) 170 | 171 | let t = Ctypes.view ~read:of_ptr ~write:to_ptr (Ctypes.ptr Ctypes.void) 172 | end 173 | 174 | (** see 175 | https://docs.microsoft.com/en-us/windows/win32/seccrypto/common-hresult-values 176 | *) 177 | module Hresult = struct 178 | type t = 179 | | S_ok 180 | | E_abort 181 | | E_accessdenied 182 | | E_fail 183 | | E_handle 184 | | E_invalid_arg 185 | | E_nointerface 186 | | E_notimpl 187 | | E_outofmemory 188 | | E_pointer 189 | | E_unexpected 190 | 191 | let to_int32 = function 192 | | S_ok -> 0x00000000l 193 | | E_abort -> 0x80004004l 194 | | E_accessdenied -> 0x80070005l 195 | | E_fail -> 0x80004005l 196 | | E_handle -> 0x80070006l 197 | | E_invalid_arg -> 0x80070057l 198 | | E_nointerface -> 0x80004002l 199 | | E_notimpl -> 0x80004001l 200 | | E_outofmemory -> 0x8007000El 201 | | E_pointer -> 0x80004003l 202 | | E_unexpected -> 0x8000FFFFl 203 | 204 | let of_int32 (n : Int32.t) = 205 | match n with 206 | | 0x00000000l -> S_ok 207 | | 0x80004004l -> E_abort 208 | | 0x80070005l -> E_accessdenied 209 | | 0x80004005l -> E_fail 210 | | 0x80070006l -> E_handle 211 | | 0x80070057l -> E_invalid_arg 212 | | 0x80004002l -> E_nointerface 213 | | 0x80004001l -> E_notimpl 214 | | 0x8007000El -> E_outofmemory 215 | | 0x80004003l -> E_pointer 216 | | 0x8000FFFFl -> E_unexpected 217 | | n -> 218 | raise 219 | @@ Invalid_argument (Format.sprintf "Hresult.of_int: %x" (Int32.to_int n)) 220 | 221 | let t = Ctypes.view ~read:of_int32 ~write:to_int32 Ctypes.int32_t 222 | end 223 | 224 | module GUID = struct 225 | type t = 226 | | UserProfile 227 | | LocalApplicationData 228 | | ApplicationData 229 | | Music 230 | | Desktop 231 | | Documents 232 | | Downloads 233 | | Pictures 234 | | Public 235 | | Templates 236 | | Videos 237 | 238 | let to_guid = function 239 | | UserProfile -> 240 | ( 0x5E6C858F 241 | , 0x0E22 242 | , 0x4760 243 | , 0x9A 244 | , 0xFE 245 | , 0xEA 246 | , 0x33 247 | , 0x17 248 | , 0xB6 249 | , 0x71 250 | , 0x73 ) 251 | | LocalApplicationData -> 252 | ( 0xF1B32785 253 | , 0x6FBA 254 | , 0x4FCF 255 | , 0x9D 256 | , 0x55 257 | , 0x7B 258 | , 0x8E 259 | , 0x7F 260 | , 0x15 261 | , 0x70 262 | , 0x91 ) 263 | | ApplicationData -> 264 | ( 0x3EB685DB 265 | , 0x65F9 266 | , 0x4CF6 267 | , 0xA0 268 | , 0x3A 269 | , 0xE3 270 | , 0xEF 271 | , 0x65 272 | , 0x72 273 | , 0x9F 274 | , 0x3D ) 275 | | Music -> 276 | ( 0x4BD8D571 277 | , 0x6D19 278 | , 0x48D3 279 | , 0xBE 280 | , 0x97 281 | , 0x42 282 | , 0x22 283 | , 0x20 284 | , 0x08 285 | , 0x0E 286 | , 0x43 ) 287 | | Desktop -> 288 | ( 0xB4BFCC3A 289 | , 0xDB2C 290 | , 0x424C 291 | , 0xB0 292 | , 0x29 293 | , 0x7F 294 | , 0xE9 295 | , 0x9A 296 | , 0x87 297 | , 0xC6 298 | , 0x41 ) 299 | | Documents -> 300 | ( 0xFDD39AD0 301 | , 0x238F 302 | , 0x46AF 303 | , 0xAD 304 | , 0xB4 305 | , 0x6C 306 | , 0x85 307 | , 0x48 308 | , 0x03 309 | , 0x69 310 | , 0xC7 ) 311 | | Downloads -> 312 | ( 0x374DE290 313 | , 0x123F 314 | , 0x4565 315 | , 0x91 316 | , 0x64 317 | , 0x39 318 | , 0xC4 319 | , 0x92 320 | , 0x5E 321 | , 0x46 322 | , 0x7B ) 323 | | Pictures -> 324 | ( 0x33E28130 325 | , 0x4E1E 326 | , 0x4676 327 | , 0x83 328 | , 0x5A 329 | , 0x98 330 | , 0x39 331 | , 0x5C 332 | , 0x3B 333 | , 0xC3 334 | , 0xBB ) 335 | | Public -> 336 | ( 0xDFDF76A2 337 | , 0xC82A 338 | , 0x4D63 339 | , 0x90 340 | , 0x6A 341 | , 0x56 342 | , 0x44 343 | , 0xAC 344 | , 0x45 345 | , 0x73 346 | , 0x85 ) 347 | | Templates -> 348 | ( 0xA63293E8 349 | , 0x664E 350 | , 0x48DB 351 | , 0xA0 352 | , 0x79 353 | , 0xDF 354 | , 0x75 355 | , 0x9E 356 | , 0x05 357 | , 0x09 358 | , 0xF7 ) 359 | | Videos -> 360 | ( 0x18989B1D 361 | , 0x99B5 362 | , 0x455B 363 | , 0x84 364 | , 0x1C 365 | , 0xAB 366 | , 0x7C 367 | , 0x74 368 | , 0xE4 369 | , 0xDD 370 | , 0xFC ) 371 | 372 | let t : t structure typ = structure "_GUID" 373 | 374 | let data1 = field t "Data1" ulong 375 | 376 | let data2 = field t "Data2" ushort 377 | 378 | let data3 = field t "Data3" ushort 379 | 380 | let data4 = field t "Data4" (array 8 uchar) 381 | 382 | let () = seal t 383 | 384 | let to_guid guid = 385 | let d1, d2, d3, d4_0, d4_1, d4_2, d4_3, d4_4, d4_5, d4_6, d4_7 = 386 | to_guid guid 387 | in 388 | let guid = make t in 389 | setf guid data1 (Unsigned.ULong.of_int d1); 390 | setf guid data2 (Unsigned.UShort.of_int d2); 391 | setf guid data3 (Unsigned.UShort.of_int d3); 392 | let d4 = [ d4_0; d4_1; d4_2; d4_3; d4_4; d4_5; d4_6; d4_7 ] in 393 | let d4 = List.map Unsigned.UChar.of_int d4 in 394 | setf guid data4 (CArray.of_list uchar d4); 395 | guid 396 | end 397 | --------------------------------------------------------------------------------