1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
|
open Std
module Unix_perm = struct
type t = int
end
module Stat = struct
type kind = [
| `Unknown
| `Fifo
| `Character_special
| `Directory
| `Block_device
| `Regular_file
| `Symbolic_link
| `Socket
]
let pp_kind ppf = function
| `Unknown -> Fmt.string ppf "unknown"
| `Fifo -> Fmt.string ppf "fifo"
| `Character_special -> Fmt.string ppf "character special file"
| `Directory -> Fmt.string ppf "directory"
| `Block_device -> Fmt.string ppf "block device"
| `Regular_file -> Fmt.string ppf "regular file"
| `Symbolic_link -> Fmt.string ppf "symbolic link"
| `Socket -> Fmt.string ppf "socket"
type t = {
dev : Int64.t;
ino : Int64.t;
kind : kind;
perm : Unix_perm.t;
nlink : Int64.t;
uid : Int64.t;
gid : Int64.t;
rdev : Int64.t;
size : Optint.Int63.t;
atime : float;
mtime : float;
ctime : float;
}
let pp ppf t =
Fmt.record [
Fmt.field "dev" (fun t -> t.dev) Fmt.int64;
Fmt.field "ino" (fun t -> t.ino) Fmt.int64;
Fmt.field "kind" (fun t -> t.kind) pp_kind;
Fmt.field "perm" (fun t -> t.perm) (fun ppf i -> Fmt.pf ppf "0o%o" i);
Fmt.field "nlink" (fun t -> t.nlink) Fmt.int64;
Fmt.field "uid" (fun t -> t.uid) Fmt.int64;
Fmt.field "gid" (fun t -> t.gid) Fmt.int64;
Fmt.field "rdev" (fun t -> t.rdev) Fmt.int64;
Fmt.field "size" (fun t -> t.size) Optint.Int63.pp;
Fmt.field "atime" (fun t -> t.atime) Fmt.float;
Fmt.field "mtime" (fun t -> t.mtime) Fmt.float;
Fmt.field "ctime" (fun t -> t.ctime) Fmt.float;
] ppf t
end
type ro_ty = [`File | Flow.source_ty | Resource.close_ty]
type 'a ro = ([> ro_ty] as 'a) r
type rw_ty = [ro_ty | Flow.sink_ty]
type 'a rw = ([> rw_ty] as 'a) r
module Pi = struct
module type READ = sig
include Flow.Pi.SOURCE
val pread : t -> file_offset:Optint.Int63.t -> Cstruct.t list -> int
val stat : t -> Stat.t
val seek : t -> Optint.Int63.t -> [`Set | `Cur | `End] -> Optint.Int63.t
val close : t -> unit
end
module type WRITE = sig
include Flow.Pi.SINK
include READ with type t := t
val pwrite : t -> file_offset:Optint.Int63.t -> Cstruct.t list -> int
val sync : t -> unit
val truncate : t -> Optint.Int63.t -> unit
end
type (_, _, _) Resource.pi +=
| Read : ('t, (module READ with type t = 't), [> ro_ty]) Resource.pi
| Write : ('t, (module WRITE with type t = 't), [> rw_ty]) Resource.pi
let ro (type t) (module X : READ with type t = t) =
Resource.handler [
H (Flow.Pi.Source, (module X));
H (Read, (module X));
H (Resource.Close, X.close);
]
let rw (type t) (module X : WRITE with type t = t) =
Resource.handler (
H (Flow.Pi.Sink, (module X)) ::
H (Write, (module X)) ::
Resource.bindings (ro (module X))
)
end
let stat (Resource.T (t, ops)) =
let module X = (val (Resource.get ops Pi.Read)) in
X.stat t
let size t = (stat t).size
let pread (Resource.T (t, ops)) ~file_offset bufs =
let module X = (val (Resource.get ops Pi.Read)) in
let got = X.pread t ~file_offset bufs in
assert (got > 0 && got <= Cstruct.lenv bufs);
got
let pread_exact (Resource.T (t, ops)) ~file_offset bufs =
let module X = (val (Resource.get ops Pi.Read)) in
let rec aux ~file_offset bufs =
if Cstruct.lenv bufs > 0 then (
let got = X.pread t ~file_offset bufs in
let file_offset = Optint.Int63.add file_offset (Optint.Int63.of_int got) in
aux ~file_offset (Cstruct.shiftv bufs got)
)
in
aux ~file_offset bufs
let pwrite_single (Resource.T (t, ops)) ~file_offset bufs =
let module X = (val (Resource.get ops Pi.Write)) in
let got = X.pwrite t ~file_offset bufs in
assert (got > 0 && got <= Cstruct.lenv bufs);
got
let pwrite_all (Resource.T (t, ops)) ~file_offset bufs =
let module X = (val (Resource.get ops Pi.Write)) in
let rec aux ~file_offset bufs =
if Cstruct.lenv bufs > 0 then (
let got = X.pwrite t ~file_offset bufs in
let file_offset = Optint.Int63.add file_offset (Optint.Int63.of_int got) in
aux ~file_offset (Cstruct.shiftv bufs got)
)
in
aux ~file_offset bufs
let seek (Resource.T (t, ops)) off cmd =
let module X = (val (Resource.get ops Pi.Read)) in
X.seek t off cmd
let sync (Resource.T (t, ops)) =
let module X = (val (Resource.get ops Pi.Write)) in
X.sync t
let truncate (Resource.T (t, ops)) len =
let module X = (val (Resource.get ops Pi.Write)) in
X.truncate t len
|
