(* $Id: netgzip.ml 1845 2013-05-27 14:09:37Z gerd $ *) open Printf class input_gzip_rec gzip_ch : Netchannels.rec_in_channel = object(self) val mutable closed = false method input s p l = let n = Gzip.input gzip_ch s p l in if n = 0 then raise End_of_file; n method close_in() = if not closed then ( Gzip.close_in gzip_ch; closed <- true ) end class input_gzip gzip_ch = Netchannels.lift_rec_in_channel (new input_gzip_rec gzip_ch) class output_gzip_rec gzip_ch : Netchannels.rec_out_channel = object(self) method output s p l = Gzip.output gzip_ch s p l; l method close_out() = (* FIXME: No way to suppress errors... *) Gzip.close_out gzip_ch method flush() = Gzip.flush gzip_ch end class output_gzip gzip_ch = Netchannels.lift_rec_out_channel (new output_gzip_rec gzip_ch) type in_phase = | In_hdr | In_body | In_crc | In_done type in_state = { mutable in_phase : in_phase; mutable in_stream : Zlib.stream option; mutable in_size: int32; mutable in_crc: int32; } exception Buffer_underrun let dispose_in st = match st.in_stream with | Some stream -> Zlib.inflate_end stream; st.in_stream <- None; | None -> () let dispose_in_ignore st = try dispose_in st with _ -> () let gzip_error msg = raise(Gzip.Error msg) let inflating_conv st incoming at_eof outgoing = let k = ref 0 in (* how many bytes to consume *) let input_byte() = if !k < Netbuffer.length incoming then ( let b = Char.code(Netbuffer.get incoming !k) in incr k; b ) else raise Buffer_underrun in let input_int32() = let b1 = input_byte() in let b2 = input_byte() in let b3 = input_byte() in let b4 = input_byte() in Int32.logor (Int32.of_int b1) (Int32.logor (Int32.shift_left (Int32.of_int b2) 8) (Int32.logor (Int32.shift_left (Int32.of_int b3) 16) (Int32.shift_left (Int32.of_int b4) 24))) in if Netbuffer.length incoming > 0 then ( match st.in_phase with | In_hdr -> ( try let id1 = input_byte() in let id2 = input_byte() in if id1 <> 0x1F || id2 <> 0x8B then gzip_error "bad magic number, not a gzip file"; let cm = input_byte() in if cm <> 8 then gzip_error "unknown compression method"; let flags = input_byte() in if flags land 0xE0 <> 0 then gzip_error "bad flags, not a gzip file"; for i = 1 to 6 do ignore(input_byte()) done; if flags land 0x04 <> 0 then ( let len1 = input_byte() in let len2 = input_byte() in for i = 1 to len1 + len2 lsl 8 do ignore(input_byte()) done ); if flags land 0x08 <> 0 then ( while input_byte() <> 0 do () done ); if flags land 0x10 <> 0 then ( while input_byte() <> 0 do () done ); if flags land 0x02 <> 0 then ( ignore(input_byte()); ignore(input_byte () ) ); Netbuffer.delete incoming 0 !k; k := 0; st.in_phase <- In_body with | Buffer_underrun -> if at_eof then ( dispose_in_ignore st; gzip_error "premature end of file, not a gzip file" ) ) | In_body -> ( match st.in_stream with | Some stream -> let loop = ref true in while !loop do let in_buf = Netbuffer.unsafe_buffer incoming in let in_pos = !k in let in_len = Netbuffer.length incoming - in_pos in if at_eof && in_len = 0 then (* Hope this is right *) gzip_error "premature end of file"; let used_out = Netbuffer.add_inplace outgoing (fun out_buf out_pos out_len -> let (finished, used_in, used_out) = try Zlib.inflate stream in_buf in_pos in_len out_buf out_pos out_len Zlib.Z_SYNC_FLUSH with Zlib.Error(_, _) -> dispose_in_ignore st; gzip_error "error during decompression" in st.in_size <- Int32.add st.in_size (Int32.of_int used_out); st.in_crc <- Zlib.update_crc st.in_crc out_buf out_pos used_out; k := !k + used_in; if finished then ( dispose_in st; st.in_phase <- In_crc; loop := false; ); used_out ) in if used_out > 0 then loop := false; done; Netbuffer.delete incoming 0 !k; | None -> gzip_error "zlib stream is already disposed" ) | In_crc -> ( try let crc = input_int32() in let size = input_int32() in if st.in_crc <> crc then gzip_error "CRC mismatch, data corrupted"; if st.in_size <> size then gzip_error "size mismatch, data corrupted"; Netbuffer.delete incoming 0 !k; st.in_phase <- In_done with | Buffer_underrun -> if at_eof then gzip_error "premature end of file, not a gzip file" ) | In_done -> gzip_error "excess data" ) class inflating_pipe () = let stream = Zlib.inflate_init false in let st = { in_phase = In_hdr; in_stream = Some stream; in_size = 0l; in_crc = 0l; } in let () = Gc.finalise dispose_in_ignore st in Netchannels.pipe ~conv:(inflating_conv st) () class input_inflate ch = Netchannels.input_filter ch (new inflating_pipe ()) class output_inflate ch = Netchannels.output_filter (new inflating_pipe ()) ch type out_state = { mutable out_hdr_written : bool; mutable out_stream : Zlib.stream option; mutable out_size: int32; mutable out_crc: int32; } let dispose_out st = match st.out_stream with | Some stream -> Zlib.deflate_end stream; st.out_stream <- None; | None -> () let dispose_out_ignore st = try dispose_out st with _ -> () let write_int32 nb n = let r = ref n in for i = 1 to 4 do Netbuffer.add_char nb (Char.chr ((Int32.to_int !r) land 0xff)); r := Int32.shift_right_logical !r 8 done let deflating_conv st incoming at_eof outgoing = match st.out_stream with | Some stream -> ( try if not st.out_hdr_written then ( let hdr = "\x1f\x8b\x08\x00\x00\x00\x00\x00\x00\xff" in Netbuffer.add_string outgoing hdr; st.out_hdr_written <- true; ); let loop = ref true in if not at_eof && Netbuffer.length incoming = 0 then loop := false; while !loop do let in_buf = Netbuffer.unsafe_buffer incoming in let in_len = Netbuffer.length incoming in let (_:int) = Netbuffer.add_inplace outgoing (fun out_buf out_pos out_len -> let (finished, used_in, used_out) = try Zlib.deflate stream in_buf 0 in_len out_buf out_pos out_len (if at_eof then Zlib.Z_FINISH else Zlib.Z_NO_FLUSH) with | Zlib.Error(_, "buffer error") -> (false, 0, 0) |Zlib.Error(_, msg) -> raise (Gzip.Error("error during compression")) in st.out_size <- Int32.add st.out_size (Int32.of_int used_in); st.out_crc <- Zlib.update_crc st.out_crc in_buf 0 used_in; Netbuffer.delete incoming 0 used_in; if at_eof && finished then loop := false; used_out ) in if not at_eof then loop := false done; if at_eof then ( write_int32 outgoing st.out_crc; write_int32 outgoing st.out_size; dispose_out st ) with | error -> dispose_out_ignore st; raise error ) | None -> if Netbuffer.length incoming > 0 then failwith "zlib stream is already disposed" class deflating_pipe ?(level=6) () = let stream = Zlib.deflate_init level false in let st = { out_hdr_written = false; out_stream = Some stream; out_size = 0l; out_crc = 0l; } in let () = Gc.finalise dispose_out_ignore st in Netchannels.pipe ~conv:(deflating_conv st) () class input_deflate ?level ch = Netchannels.input_filter ch (new deflating_pipe ?level ()) class output_deflate ?level ch = Netchannels.output_filter (new deflating_pipe ?level ()) ch let () = Netcompression.register ~iana_name:"gzip" ~decoder:(fun () -> new inflating_pipe()) ~encoder:(fun () -> new deflating_pipe ?level:None ()) () let init() = ()