basis-library/net/net-host-db.sml

   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