Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2002-2006, 2008 Henry Cejtin, Matthew Fluet, Suresh |
2 | * Jagannathan, and Stephen Weeks. | |
3 | * | |
4 | * MLton is released under a BSD-style license. | |
5 | * See the file MLton-LICENSE for details. | |
6 | *) | |
7 | ||
8 | structure NetHostDB: NET_HOST_DB_EXTRA = | |
9 | struct | |
10 | structure Prim = PrimitiveFFI.NetHostDB | |
11 | ||
12 | (* network byte order (big-endian) *) | |
13 | type pre_in_addr = Word8.word array | |
14 | type in_addr = Word8.word vector | |
15 | ||
16 | val preInAddrToWord8Array = fn a => a | |
17 | val inAddrToWord8Vector = fn v => v | |
18 | ||
19 | val inAddrLen = C_Size.toInt Prim.inAddrSize | |
20 | fun newInAddr () = | |
21 | let | |
22 | val ia: pre_in_addr = Array.array (inAddrLen, 0wx0: Word8.word) | |
23 | fun finish () = Array.vector ia | |
24 | in | |
25 | (ia, finish) | |
26 | end | |
27 | fun any () = | |
28 | let | |
29 | val (wa, finish) = newInAddr () | |
30 | fun loop (i, acc) = | |
31 | if i >= inAddrLen | |
32 | then () | |
33 | else let | |
34 | val w = Word8.castFromSysWord (C_Int.castToSysWord acc) | |
35 | val () = | |
36 | Array.update | |
37 | (wa, (inAddrLen - 1) - i, w) | |
38 | in | |
39 | loop (i + 1, C_Int.>> (acc, 0w4)) | |
40 | end | |
41 | in | |
42 | loop (0, Prim.INADDR_ANY) | |
43 | ; finish () | |
44 | end | |
45 | ||
46 | structure AddrFamily = Net.AddrFamily | |
47 | type addr_family = AddrFamily.t | |
48 | ||
49 | datatype entry = T of {name: string, | |
50 | aliases: string list, | |
51 | addrType: addr_family, | |
52 | addrs: in_addr list} | |
53 | ||
54 | local | |
55 | fun make s (T r) = s r | |
56 | in | |
57 | val name = make #name | |
58 | val aliases = make #aliases | |
59 | val addrType = make #addrType | |
60 | val addrs = make #addrs | |
61 | end | |
62 | fun addr entry = hd (addrs entry) | |
63 | ||
64 | local | |
65 | fun get (i: C_Int.t): entry option = | |
66 | if i <> C_Int.zero | |
67 | then let | |
68 | val name = CUtil.C_String.toString (Prim.getEntryName ()) | |
69 | val numAliases = Prim.getEntryAliasesNum () | |
70 | fun fill (n, aliases) = | |
71 | if C_Int.< (n, numAliases) | |
72 | then let | |
73 | val alias = | |
74 | CUtil.C_String.toString (Prim.getEntryAliasesN n) | |
75 | in | |
76 | fill (C_Int.+ (n, 1), alias::aliases) | |
77 | end | |
78 | else List.rev aliases | |
79 | val aliases = fill (0, []) | |
80 | val addrType = Prim.getEntryAddrType () | |
81 | val length = Prim.getEntryLength () | |
82 | val numAddrs = Prim.getEntryAddrsNum () | |
83 | fun fill (n, addrs) = | |
84 | if C_Int.< (n, numAddrs) | |
85 | then let | |
86 | val addr = Word8Array.array (C_Int.toInt length, 0wx0) | |
87 | val _ = Prim.getEntryAddrsN (n, Word8Array.toPoly addr) | |
88 | val addr = Word8Vector.toPoly (Word8Array.vector addr) | |
89 | in | |
90 | fill (C_Int.+ (n, 1), addr::addrs) | |
91 | end | |
92 | else List.rev addrs | |
93 | val addrs = fill (0, []) | |
94 | in | |
95 | SOME (T {name = name, | |
96 | aliases = aliases, | |
97 | addrType = AddrFamily.fromRep addrType, | |
98 | addrs = addrs}) | |
99 | end | |
100 | else NONE | |
101 | in | |
102 | fun getByAddr in_addr = | |
103 | get (Prim.getByAddress (in_addr, C_Socklen.fromInt (Vector.length in_addr))) | |
104 | fun getByName name = | |
105 | get (Prim.getByName (NullString.nullTerm name)) | |
106 | end | |
107 | ||
108 | fun getHostName () = | |
109 | let | |
110 | val n = 128 | |
111 | val buf = CharArray.array (n, #"\000") | |
112 | val () = | |
113 | Posix.Error.SysCall.simple | |
114 | (fn () => Prim.getHostName (CharArray.toPoly buf, C_Size.fromInt n)) | |
115 | in | |
116 | case CharArray.findi (fn (_, c) => c = #"\000") buf of | |
117 | NONE => CharArray.vector buf | |
118 | | SOME (i, _) => | |
119 | CharArraySlice.vector (CharArraySlice.slice (buf, 0, SOME i)) | |
120 | end | |
121 | ||
122 | fun scan reader state = | |
123 | let | |
124 | fun scanW state = | |
125 | case reader state of | |
126 | SOME (#"0", state') => | |
127 | (case reader state' of | |
128 | NONE => SOME (0w0, state') | |
129 | | SOME (c, state'') => | |
130 | if Char.isDigit c | |
131 | then StringCvt.wdigits StringCvt.OCT reader state' | |
132 | else if c = #"x" orelse c = #"X" | |
133 | then StringCvt.wdigits StringCvt.HEX reader state'' | |
134 | else SOME (0w0, state')) | |
135 | | _ => StringCvt.wdigits StringCvt.DEC reader state | |
136 | fun loop (n, state, acc) = | |
137 | if n <= 0 | |
138 | then List.rev acc | |
139 | else let | |
140 | fun finish (w, state) = | |
141 | case reader state of | |
142 | SOME (#".", state') => | |
143 | loop (n - 1, state', (w, state)::acc) | |
144 | | _ => List.rev ((w, state)::acc) | |
145 | in | |
146 | case scanW state of | |
147 | SOME (w, state') => finish (w, state') | |
148 | | NONE => List.rev acc | |
149 | end | |
150 | val l = loop (4, state, []) | |
151 | fun get1 w = | |
152 | (Word8.fromLarge (Word.toLarge (Word.andb (w, 0wxFF))), | |
153 | Word.>>(w, 0w8)) | |
154 | fun get2 w = | |
155 | let | |
156 | val (a,w) = get1 w | |
157 | val (b,w) = get1 w | |
158 | in (a,b,w) | |
159 | end | |
160 | fun get3 w = | |
161 | let | |
162 | val (a,b,w) = get2 w | |
163 | val (c,w) = get1 w | |
164 | in (a,b,c,w) | |
165 | end | |
166 | fun get4 w = | |
167 | let | |
168 | val (a,b,c,w) = get3 w | |
169 | val (d,w) = get1 w | |
170 | in (a,b,c,d,w) | |
171 | end | |
172 | fun try l = | |
173 | case l of | |
174 | [] => NONE | |
175 | | [(w, statew)] => | |
176 | let | |
177 | val (d,c,b,a,w) = get4 w | |
178 | in | |
179 | if w = 0wx0 | |
180 | then SOME (Vector.fromList [a,b,c,d], statew) | |
181 | else NONE | |
182 | end | |
183 | | [(x, statex), (w, statew)] => | |
184 | let | |
185 | val (d,c,b,w) = get3 w | |
186 | val (a,x) = get1 x | |
187 | in | |
188 | if w = 0wx0 andalso x = 0wx0 | |
189 | then SOME (Vector.fromList [a,b,c,d], statew) | |
190 | else try [(x, statex)] | |
191 | end | |
192 | | [(y, statey), (x, statex), (w, statew)] => | |
193 | let | |
194 | val (d,c,w) = get2 w | |
195 | val (b,x) = get1 x | |
196 | val (a,y) = get1 y | |
197 | in | |
198 | if w = 0wx0 andalso x = 0wx0 andalso y = 0wx0 | |
199 | then SOME (Vector.fromList [a,b,c,d], statew) | |
200 | else try [(y, statey), (x, statex)] | |
201 | end | |
202 | | [(z, statez), (y, statey), (x, statex), (w, statew)] => | |
203 | let | |
204 | val (d,w) = get1 w | |
205 | val (c,x) = get1 x | |
206 | val (b,y) = get1 y | |
207 | val (a,z) = get1 z | |
208 | in | |
209 | if w = 0wx0 andalso x = 0wx0 andalso y = 0wx0 andalso z = 0wx0 | |
210 | then SOME (Vector.fromList [a,b,c,d], statew) | |
211 | else try [(z, statez), (y, statey), (x, statex)] | |
212 | end | |
213 | | _ => NONE | |
214 | in | |
215 | try l | |
216 | end | |
217 | ||
218 | fun fromString s = StringCvt.scanString scan s | |
219 | fun toString in_addr = | |
220 | String.concatWith "." | |
221 | (Vector.foldr (fn (w,ss) => (Word8.fmt StringCvt.DEC w)::ss) [] in_addr) | |
222 | end |