ocamlnet-4.0.4/0000755000175000017500000000000012541553666011762 5ustar gerdgerdocamlnet-4.0.4/LICENSE.LGPL0000644000175000017500000000012012541553660013507 0ustar gerdgerdThese license conditions apply to the mod_caml part of the netcgi library. XXX ocamlnet-4.0.4/configure0000755000175000017500000007227412541553660013677 0ustar gerdgerd#! /bin/sh # $Id: configure 2239 2015-06-14 11:15:36Z gerd $ ####################################################################### # Constants: cppo_version=0.9.4 # Helpers: # Split $PATH into words: oldifs="$IFS" IFS=" :" spacepath=`echo $PATH` IFS="$oldifs" in_path () { # Does $1 exist in $PATH? for d in $spacepath; do if test -x "$d/$1"; then return 0 fi done return 1 } get_path () { for d in $spacepath; do if test -x "$d/$1"; then echo "$d/$1" return fi done } ####################################################################### # Defaults #--- Options --- # value 0: off # value 1: on # defaults: set_defaults () { enable_gtk=0 enable_gtk2=0 enable_tcl=0 enable_zip=0 enable_apache=0 enable_gnutls=0 enable_gssapi=0 enable_pcre=0 enable_full_pcre=0 compat_pcre=0 enable_nethttpd=0 bindir=`dirname "$ocamlc"` tcl_defs="" tcl_libs="" disable_core=0 apxs="" apache="" cpp=cpp cpp_set=0 gnutls_cflags="" gnutls_libs="" gnutls_system_trust_file="" gssapi_cflags="" gssapi_libs="" destdir="" } ocamlc=`get_path ocamlc` set_defaults version="4.0.4" exec_suffix="" path_sep=":" ####################################################################### # Option parsing ehelp_gtk="Enable/disable parts that depend on lablgtk" ehelp_gtk2="Enable/disable parts that depend on lablgtk2" ehelp_tcl="Enable/disable parts that depend on tcl/tk" ehelp_gnutls="Enable/disable parts that depend on GnuTLS" ehelp_gssapi="Enable/disable parts that depend on GSSAPI/Kerberos" ehelp_zip="Enable/disable parts that depend on camlzip" ehelp_apache="Enable/disable Apache mod connector (EXPERIMENTAL)" ehelp_pcre="Enable/disable the build against pcre-ocaml" ehelp_full_pcre="Enable/disable the build against pcre-ocaml (no Str)" ehelp_nethttpd="Enable/disable nethttpd web server component (GPL!)" # Which options exist? eoptions for enable/disable eoptions="pcre full_pcre gtk gtk2 tcl gnutls gssapi zip apache nethttpd" # Packages to include anyway: requires="unix" # Directory where to install data files: net_db_dir="" net_db_dir_set=0 check_library () { # $1: the name of the library (findlib) # # $2: a typical file in $incdirs # if [ "$enable_findlib" -gt 0 ]; then ocamlfind query "$1" >/dev/null 2>/dev/null return # else # stdlib=`ocamlc -where` # for dir in $incdirs; do # case "$dir" in # +*) # dir=`echo "$dir" | sed -e "s|^\+|$stdlib/|"` ;; # esac # if [ -f "$dir/$2" ]; then # return 0 # fi # done return 1 # not found # fi } print_options () { for opt in $eoptions; do e="o=\$enable_$opt" eval "$e" uopt=`echo $opt | sed -e 's/_/-/g'` if [ $o -gt 0 ]; then echo " -enable-$uopt" else echo " -disable-$uopt" fi done echo " -bindir $bindir" echo " -datadir $net_db_dir" if [ $enable_tcl -gt 0 ]; then echo " -equeue-tcl-defs \"$tcl_defs\"" echo " -equeue-tcl-libs \"$tcl_libs\"" fi if [ -n "$apxs" ]; then echo " -apxs $apxs" fi if [ -n "$apache" ]; then echo " -apache $apache" fi if [ -n "$gnutls_cflags" ]; then echo " -gnutls-cflags $gnutls_cflags" fi if [ -n "$gnutls_libs" ]; then echo " -gnutls-libs $gnutls_libs" fi if [ -n "$gnutls_system_trust_file" ]; then echo " -gnutls-system-trust-file $gnutls_system_trust_file" fi if [ -n "$gssapi_cflags" ]; then echo " -gssapi-cflags $gssapi_cflags" fi if [ -n "$gssapi_libs" ]; then echo " -gssapi-libs $gssapi_libs" fi echo " -cpp $cpp" } usage () { set_defaults cat <<_EOF_ >&2 usage: ./configure [ options ] _EOF_ for opt in $eoptions; do e="help=\$ehelp_$opt" eval "$e" uopt=`echo $opt | sed -e 's/_/-/g'` echo "-enable-$uopt:" >&2 echo "-disable-$uopt:" >&2 echo " $help" >&2 done cat <<_EOF_ >&2 -bindir dir Install binaries into this directory -datadir dir Install the run-time data file into this directory -equeue-tcl-defs Set C compiler options to find tcl.h (for -enable-tcl) -equeue-tcl-libs Set C compiler options to link against libtcl (for -enable-tcl) -apxs /path/to/apxs Set which apxs to use for -enable-apache -apache /path/to/apache Set which apache executable to use for -enable-apache -gnutls-cflags Flags for the C compiler for GnuTLS -gnutls-libs Libraries for GnuTLS -gnutls-system-trust-file /path/to/certificates.crt File with the certificates that are trusted by default -gssapi-cflags Flags for the C compiler for GSSAPI -gssapi-libs Libraries for GSSAPI -prefer-netcgi2 This option is ignored for compatibility with older versions -cpp Use this C preprocessor program for ocamlrpcgen -compat-pcre Makes the netstring library dependent on netstring-pcre, for better compatibility with old versions of Ocamlnet Defaults are: _EOF_ print_options >&2 exit 1 } check_eopt () { for x in $eoptions; do if [ "$x" = "$1" ]; then return 0 fi done echo "Unknown option: $1" >&2 exit 1 } echo "Welcome to Ocamlnet version $version" >&2 while [ "$#" -gt 0 ]; do case "$1" in -enable-*|--enable-*) opt=`echo "$1" | sed -e 's/--\{0,1\}enable-//' -e 's/-/_/g'` check_eopt "$opt" eval "enable_$opt=2" shift ;; -disable-core|--disable-core) # Intentionally undocumented. disable_core=1 shift ;; -disable-*|--disable-*) opt=`echo "$1" | sed -e 's/--\{0,1\}disable-//' -e 's/-/_/g'` check_eopt "$opt" eval "enable_$opt=-1" shift ;; -with-*|--with*) opt=`echo "$1" | sed -e 's/--\{0,1\}with-//' -e 's/-/_/g'` check_eopt "$opt" eval "enable_$opt=2" shift ;; -without-*|--without*) opt=`echo "$1" | sed -e 's/--\{0,1\}without-//' -e 's/-/_/g'` check_eopt "$opt" eval "enable_$opt=-1" shift ;; -prefix|--prefix) bindir="$2/bin"; shift 2 ;; --prefix=*) p=`echo "$1" | set -e 's/--prefix=//'` bindir="$p/bin"; shift ;; -bindir|--bindir) bindir="$2" shift shift ;; --bindir=*) bindir=`echo "$1" | set -e 's/--bindir=//'` shift ;; -datadir|--datadir) net_db_dir="$2" net_db_dir_set=1 shift; shift ;; --datadir=*) net_db_dir=`echo "$1" | set -e 's/--datadir=//'` net_db_dir_set=1 shift ;; -equeue-tcl-defs|--equeue-tcl-defs) tcl_defs="$tcl_defs $2" shift shift ;; --equeue-tcl-defs=*) tcl_defs=`echo "$1" | set -e 's/--equeue-tcl-defs=//'`" $2" shift ;; -equeue-tcl-libs|--equeue-tcl-libs) tcl_libs="$tcl_libs $2" shift shift ;; --equeue-tcl-libs=*) tcl_libs=`echo "$1" | set -e 's/--equeue-tcl-libs=//'`" $2" shift ;; -apxs|--apxs) apxs="$2" shift shift ;; --apxs=*) apxs=`echo "$1" | set -e 's/--apxs=//'` shift ;; -apache|--apache) apache="$2" shift shift ;; --apache=*) apache=`echo "$1" | set -e 's/--apache=//'` shift ;; -gnutls-cflags|--gnutls-cflags) gnutls_cflags="$2" shift shift ;; --gnutls-cflags=*) gnutls_cflags=`echo "$1" | set -e 's/--gnutls-cflags=//'` shift ;; -gnutls-libs|--gnutls-libs) gnutls_libs="$2" shift shift ;; --gnutls-libs=*) gnutls_libs=`echo "$1" | set -e 's/--gnutls-libs=//'` shift ;; -gnutls-system-trust-file|--gnutls-system-trust-file) gnutls_system_trust_file="$2" shift 2 ;; --gnutls-system-trust-file=*) gnutls_system_trust_file=`echo "$1" | set -e 's/--gnutls-system-trust-file=//'` shift ;; -gssapi-cflags|--gssapi-cflags) gssapi_cflags="$2" shift shift ;; --gssapi-cflags=*) gssapi_cflags=`echo "$1" | set -e 's/--gssapi-cflags=//'` shift ;; -gssapi-libs|--gssapi-libs) gssapi_libs="$2" shift shift ;; --gssapi-libs=*) gssapi_libs=`echo "$1" | set -e 's/--gssapi-libs=//'` shift ;; -prefer-netcgi2|--prefer-netcgi2) # ignore! shift ;; -cpp|--cpp) cpp="$2" cpp_set=1 shift shift ;; --cpp=*) cpp=`echo "$1" | set -e 's/--cpp=//'` cpp_set=1 shift ;; -version|--version) echo "$version" exit 0 ;; -compat-pcre|--compat-pcre) compat_pcre=1 shift ;; -destdir|--destdir) destdir="$2"; shift 2;; --destdir=*) destdir=`echo "$1" | set -e 's/--destdir=//'`; shift;; *) usage esac done ###################################################################### # Check OS with_rpc_xti=0 with_cppo_tweak=0 printf "%s" "Checking operating system... " u=`uname` case "$u" in CYGWIN*) printf "Cygwin, and target is: " exec_suffix=".exe" path_sep=";" # this is only for OCAMLPATH, ";" is correct for Cygwin case `ocamlc -config | grep os_type` in *Win32*) with_cppo_tweak=1 if [ $cpp_set = 0 ]; then cpp=`realpath /bin/cpp | cygpath -m -f -` fi echo "Win32" ;; *) echo "Cygwin" ;; esac ;; MINGW*) echo "MinGW" exec_suffix=".exe" with_cppo_tweak=2 path_sep=";" mingw_lib=`get_path gcc` mingw_lib=`dirname "$mingw_lib"`/../lib OCAMLOPTFLAGS="-ccopt -L\"${mingw_lib}\"" ;; Linux) echo "Linux" ;; *FreeBSD) # also GNU/kFreeBSD echo "FreeBSD" echo echo "*** Note that you might need to load the 'sem' kernel" echo "*** module to make semaphores work: kldload sem" echo ;; NetBSD) echo "NetBSD" ;; SunOS) case `uname -r` in [1234]*) echo "SunOS" ;; *) echo "Solaris" with_rpc_xti=1 ;; esac ;; *) echo "Generic" ;; esac if [ $with_rpc_xti -gt 0 ]; then echo " This OS supports XTI networking" echo " Building rpc-xti" fi ###################################################################### # Check ocamlfind printf "%s" "Checking for findlib... " if ocamlfind query stdlib >/dev/null 2>/dev/null; then echo "found" if [ "$net_db_dir_set" -eq 0 ]; then net_db_dir=`ocamlfind printconf destdir | tr -d '\\r'`/netunidata net_db_dir_set=1 fi else echo "not found" echo "Make sure that ocamlfind is in your PATH, or download findlib" echo "from www.ocaml-programming.de" exit 1 fi if [ "$net_db_dir_set" -eq 0 ]; then net_db_dir="$libdir" net_db_dir_set=1 fi ###################################################################### # Does ocamlopt support multi-threading? printf "%s" "Checking multi-threading support... " mt_type=vm mt_switch="-vmthread" mt_comment="(unsupported)" rm -rf tmp mkdir -p tmp cat <<_EOF_ >tmp/t.ml let _ = Mutex.create();; _EOF_ if ocamlopt -thread -o tmp/t${exec_suffix} ${OCAMLOPTFLAGS} unix.cmxa threads.cmxa tmp/t.ml 2>/dev/null || ocamlc -thread -o tmp/t${exec_suffix} unix.cma threads.cma tmp/t.ml 2>/dev/null; then if tmp/t${exec_suffix} 2>/dev/null; then mt_type=posix mt_switch="-thread" mt_comment="(ok)" fi fi echo "$mt_type $mt_comment" ###################################################################### # Check word size at al printf "%s" "Checking word size... " cat <<_EOF_ >tmp/t.ml print_endline(string_of_int(Sys.word_size)) _EOF_ word_size="$(ocaml tmp/t.ml | tr -d '\r')" echo "$word_size bit" printf "%s" "Checking endianess... " cat <<_EOF_ >tmp/tend.c /* new check from MatĂ­as Giovannini */ #include "caml/mlvalues.h" value check(value d) { int i = 1; char *s = (char*) &i; return (s[0] == 0 ? Val_true : Val_false); } _EOF_ cat <<_EOF_ >tmp/t.ml external check : unit -> bool = "check";; let () = exit (if check() then 0 else 1) _EOF_ ( cd tmp ocamlc -custom -o t tend.c t.ml ) || exit if tmp/t; then echo "big" endianess="BIG_ENDIAN" else echo "little" endianess="LITTLE_ENDIAN" fi ###################################################################### printf "Checking for GPROF... " stdlib=`ocamlc -where | tr -d '\r'` if [ -f $stdlib/std_exit.p.cmx ]; then echo "found" have_gprof=1 else echo "not found" have_gprof=0 fi ###################################################################### # Check that pcre is available: if [ $enable_pcre -gt 0 -o $enable_full_pcre -gt 0 ]; then printf "%s" "Checking for PCRE... " if check_library pcre pcre.cmi; then echo "found" # This means to build netstring-pcre have_pcre=1 if [ $enable_full_pcre -gt 0 ]; then # In netstring: Netstring_str uses PCRE as backend regexp_defs="-D HAVE_PCRE" regexp_provider="netstring-pcre" # which again depends on pcre regexp_provider_make="pcre" # also solved via -I to netstring-pcre else # In netstring: Netstring_str uses Str as backend regexp_defs="-D ENABLE_STR_EXTERNALS -D HAVE_PCRE" regexp_provider="str" regexp_provider_make="str" fi else echo "not found" echo "Sorry, PCRE was requested." echo "Get the PCRE-OCaml library from:" echo "http://www.ocaml.info/home/ocaml_sources.html," echo "or disable the build against PCRE-Ocaml (not recommended)". exit 1 fi else # ENABLE_STR_EXTERNALS works for all recent OCaml versions have_pcre=0 regexp_defs="-D ENABLE_STR_EXTERNALS" regexp_provider="str" regexp_provider_make="str" fi compat_pcre_provider="" if [ $compat_pcre -gt 0 ]; then # in this case, netstring is dependent on netstring-pcre for # better compatibility with OCamlnet-3.5 and older. Even if we # did NOT -enable-pcre. compat_pcre_provider="netstring-pcre" fi ###################################################################### # Netsys ( cd src/netsys; ./configure ) ( cd src/rpc-auth-local; ./configure ) ###################################################################### # whether we can support camlboxes and multicore support_outofheap=0 if grep 'OOH_OBJECT = .' src/netsys/Makefile.conf >/dev/null 2>/dev/null; then support_outofheap=1 fi support_semaphores=0 if grep '#define HAVE_POSIX_SEM_NAMED' src/netsys/config.h \ >/dev/null 2>/dev/null; then support_semaphores=1 fi enable_camlbox=0 enable_multicore=0 printf "Checking whether netcamlbox and netmulticore are supported... " if [ $support_outofheap -gt 0 -a $support_semaphores -gt 0 ]; then echo "yes" enable_camlbox=1 enable_multicore=1 else echo "no" fi ###################################################################### # TCL with_equeue_tcl=0 if [ $enable_tcl -gt 0 ]; then printf "%s" "Checking switches for tcl.h... " tcl_defs_1="" for d in $tcl_defs; do tcl_defs_1="$tcl_defs_1 -ccopt '$d'" done rm -rf tmp mkdir -p tmp cat <tmp/t.c #include "tcl.h" main () { } EOF if ( cd tmp; ocamlc $tcl_defs_1 -c t.c >/dev/null 2>/dev/null ) then echo "ok" else echo "not ok" echo echo "Please check -equeue-tcl-defs!" exit 1 fi printf "%s" "Checking switches to link libtcl... " cat <tmp/t.c #include #include #include "tcl.h" do_something () { void (*x)(int); x = Tcl_Exit; exit(0); } EOF cat <tmp/t.ml exit 0 EOF if ( cd tmp ocamlc $tcl_defs_1 -c t.c >/dev/null 2>/dev/null && ocamlc -c t.ml >/dev/null 2>/dev/null && ocamlc -o t -custom t.o t.cmo -cclib "$tcl_libs" ) then if tmp/t; then echo "ok" else echo "not ok (check ldd output of tmp/t)" echo echo "Please check -equeue-tcl-libs!" exit 1 fi else echo "not ok" echo echo "Please check -equeue-tcl-libs!" exit 1 fi with_equeue_tcl=1 fi ###################################################################### # Check lablgtk with_equeue_gtk1=0 if [ $enable_gtk -gt 0 ]; then printf "%s" "Checking for lablgtk... " if ocamlfind query lablgtk >/dev/null 2>/dev/null; then echo "found" with_equeue_gtk1=1 else echo "not found" echo "Required library lablgtk not found!" exit 1 fi fi ###################################################################### # Check lablgtk2 with_equeue_gtk2=0 gtk2_io_add_watch_supports_lists="" if [ $enable_gtk2 -gt 0 ]; then printf "%s" "Checking for lablgtk2... " if ocamlfind query lablgtk2 >/dev/null 2>/dev/null; then echo "found" else echo "not found" echo "Required library lablgtk2 not found!" exit 1 fi printf "%s" "Checking whether lablgtk2 has GMain.Io.remove... " mkdir -p tmp cat <tmp/gtktest.ml let _ = GMain.Io.remove;; EOF if ocamlfind ocamlc -package lablgtk2 -c tmp/gtktest.ml >/dev/null 2>/dev/null; then echo "yes" else echo "no" echo "Your version of lablgtk2 is too old!" exit 1 fi printf "%s" "Checking whether lablgtk2 has GMain.Io.add_watch with list support... " mkdir -p tmp cat <<'EOF' >tmp/gtktest.ml open GMain.Io let _ = (add_watch : cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id);; exit 0 EOF # Note: this newer API is never broken in the sense checked below, i.e. # such lablgtk2 versions do not exist. if ocamlfind ocamlc -package unix,lablgtk2 -linkpkg -o tmp/gtk tmp/gtktest.ml >/dev/null 2>/dev/null && tmp/gtk; then echo "yes" gtk2_io_add_watch_supports_lists="-D GTK2_IO_ADD_WATCH_SUPPORTS_LISTS" else echo "no" printf "%s" "Checking whether lablgtk2's GMain.Io.add_watch is broken... " mkdir -p tmp cat <<'EOF' >tmp/gtktest.ml GMain.Main.init();; let ch = GMain.Io.channel_of_descr (Unix.stdout) in let w = GMain.Io.add_watch ~cond:`OUT ~callback:(fun () -> true) ch in (* add_watch is broken when it just returns Val_unit, and ok when it * returns a positive int *) if (Obj.magic w : int) > 0 then exit 0 else exit 1 EOF if ocamlfind ocamlc -package unix,lablgtk2 -linkpkg -o tmp/gtk tmp/gtktest.ml >/dev/null 2>/dev/null && tmp/gtk; then echo "no" else echo "yes" echo "You should apply the patch-ab-ml_glib.c to lablgtk2 to fix this!" exit 1 fi fi for f in Makefile uq_gtk.ml uq_gtk.mli uq_gtk_helper.ml; do rm -f src/equeue-gtk2/$f ln -s ../equeue-gtk1/$f src/equeue-gtk2 done with_equeue_gtk2=1 fi ###################################################################### # GnuTLS with_gnutls=0 if [ $enable_gnutls -gt 0 ]; then ( cd src/nettls-gnutls GNUTLS_CFLAGS="$gnutls_cflags" GNUTLS_LIBS="$gnutls_libs" GNUTLS_SYSTEM_TRUST_FILE="$gnutls_system_trust_file" ./configure ) if [ $? -eq 0 ]; then with_gnutls=1 # There is now also src/nettls-gnutls/config.mk, which needs to be # appended to Makefile.conf else echo "Required library GnuTLS not found!" exit 1 fi fi ###################################################################### # GSSAPI with_gssapi=0 if [ $enable_gssapi -gt 0 ]; then ( cd src/netgss-system GSSAPI_CFLAGS="$gssapi_cflags" GSSAPI_LIBS="$gssapi_libs" ./configure ) if [ $? -eq 0 ]; then with_gssapi=1 # There is now also src/netgss-system/config.mk, which needs to be # appended to Makefile.conf else echo "Required library for GSSAPI (probably -lkrb5) not found!" exit 1 fi fi ###################################################################### # Check camlzip with_netzip=0 if [ $enable_zip -gt 0 ]; then printf "%s" "Checking for zip/camlzip... " if ocamlfind query zip >/dev/null 2>/dev/null; then echo "found" with_netzip=1 zip_provider=zip else if ocamlfind query camlzip >/dev/null 2>/dev/null; then echo "found" with_netzip=1 zip_provider=camlzip else echo "not found" echo "Required library camlzip not found!" exit 1 fi fi fi ###################################################################### # Check Apache apache_major=0 # otherwise syntax error if [ $enable_apache -gt 0 ]; then printf "Apache mod connector... " # echo "CURRENTLY BROKEN - disabling for now" # enable_apache=0 if [ -z "$apxs" ]; then # guess apxs=`get_path apxs` fi if [ -z "$apache" ]; then # guess apache=`get_path apache` fi if [ -x "$apxs" ] && [ -x "$apache" ]; then apache_major=`$apache -v | head -n1 | sed -e "s,.*/\([1-9]\).*,\1,"` apache_libdir="`$apxs -q LIBEXECDIR`" apache_incdir="`$apxs -q INCLUDEDIR`" apache_confdir="`$apxs -q SYSCONFDIR`" apache_ldflags_shlib="`$apxs -q LDFLAGS_SHLIB`" apache_cc="`$apxs -q CC`" apache_cflags="-I \$(APACHE_INCDIR) \ `$apxs -q CFLAGS` `$apxs -q CFLAGS_SHLIB`" # This is to allow modules residing in the standard ocaml library # directory to be loaded with relative paths. #apache_ocamllibdir=`ocamlfind printconf destdir` apache_ocamllibdir=`ocamlc -where` # The apache module requires the construction of a shared library # embedding the ocaml runtime. On platforms where PIC code differs # from non-PIC, it requires a shared camlrun. Check whether it is # available. See http://caml.inria.fr/mantis/view.php?id=3866 apache_camlrun=camlrun if [ -f "$apache_ocamllibdir/libcamlrun_shared.so" ]; then apache_camlrun=camlrun_shared echo "enabled (Apache $apache_major)" else echo "enabled (Apache $apache_major)" echo -e " WARNING: libcamlrun_shared.so was not found. That \ may prevent the build\n of the apache module on platforms \ where PIC code differs from non-PIC\n such as x86_64, hppa,..." fi # at some point libstr.a was renamed to libcamlstr.a libstr="str" if [ -f "$apache_ocamllibdir/libcamlstr.a" ]; then libstr="camlstr" fi else enable_apache=0 echo "apxs or apache not found" echo " Maybe you need to use the -apache option?" exit 1 fi fi ###################################################################### # cpp echo "Preprocessor for ocamlrpcgen: $cpp" ###################################################################### # Summary echo echo "Effective options:" print_options echo pkglist="netsys netshm netstring netunidata equeue shell rpc-generator rpc rpc-auth-local netclient netcgi2 netplex netcgi2-plex" full_pkglist="$pkglist netstring-pcre rpc-auth-local rpc-xti equeue-tcl equeue-gtk1 equeue-gtk2 nethttpd netzip netcgi2-apache nettls-gnutls netgss-system" if [ $enable_camlbox -gt 0 ]; then pkglist="$pkglist netcamlbox" fi if [ $enable_multicore -gt 0 ]; then pkglist="$pkglist netmulticore" fi if [ $enable_nethttpd -gt 0 ]; then pkglist="$pkglist nethttpd" fi if [ $disable_core -gt 0 ]; then # Omit the core packages: pkglist="" with_rpc_xti=0 fi for opt in rpc_xti $woptions equeue_tcl equeue_gtk1 equeue_gtk2 netzip; do e="o=\$with_$opt" eval "$e" if [ $o -gt 0 ]; then uopt=`echo "$opt" | sed -e 's/_/-/g'` pkglist="$pkglist $uopt" fi done if [ $enable_pcre -gt 0 -o $enable_full_pcre -gt 0 ]; then pkglist="netstring-pcre $pkglist" fi if [ $enable_apache -gt 0 ]; then pkglist="$pkglist netcgi2-apache" fi if [ $enable_gnutls -gt 0 ]; then pkglist="$pkglist nettls-gnutls" fi if [ $enable_gssapi -gt 0 ]; then pkglist="$pkglist netgss-system" fi ###################################################################### # Write Makefile.conf if [ $with_cppo_tweak -ne 0 ]; then # Under Windows, calling cppo by relative path is difficult. If we # use forward slashes, we need to escape these for cmd.exe. If we # use backward slashes, the escaping is difficult for sh+make. # The workaround is to call cppo implicitly by PATH search. xdir="$(readlink -f "$(dirname "$0")")" if [ $with_cppo_tweak -eq 1 ]; then xdir="$(cygpath "${xdir}")" fi xdir="${xdir}/tools/cppo-${cppo_version}" export_path="export PATH:=${xdir}:\$(PATH)" cppo="cppo-ocamlnet.exe" else export_path="" cppo="\$(TOP_DIR)/tools/cppo-${cppo_version}/cppo" fi echo "Writing Makefile.conf" cat <<_EOF_ >Makefile.conf # Makefike.conf written by configure # The Ocamlnet version VERSION = $version # The packages to build in the right order: PKGLIST = $pkglist # All packages: FULL_PKGLIST = $full_pkglist # Whether the OS needs an .exe suffix for executables: EXEC_SUFFIX = $exec_suffix PATH_SEP = $path_sep # Required packages (findlib): REQUIRES += $requires # zip: ZIP_PROVIDER = $zip_provider # Additional options only for ocamlc: OCAMLC_OPTIONS = # Additional options only for ocamlopt: OCAMLOPT_OPTIONS = # Where the ocamlnet lookup tables are to be installed (both findlib # and non-findlib): NET_DB_DIR = $net_db_dir # Where binaries are installed: BINDIR = $bindir # Method of installation: INSTMETHOD = findlib # Multi-threading type: MT_TYPE = $mt_type # word size: WORD_SIZE = $word_size # endianess ENDIANESS = $endianess # gprof: HAVE_GPROF = $have_gprof # REGEXP support: REGEXP_DEFS = $regexp_defs HAVE_PCRE = $have_pcre REGEXP_PROVIDER = $regexp_provider REGEXP_PROVIDER_MAKE = $regexp_provider_make COMPAT_PCRE_PROVIDER = $compat_pcre_provider # Compiler switch to enable multi-threading: THREAD = $mt_switch # For -enable-tcl: EQUEUE_TCL_DEFS = $tcl_defs_1 EQUEUE_TCL_LIBS = $tcl_libs # For -enable-gtk2: GTK_EXTRA_DEFINES = $gtk2_io_add_watch_supports_lists # For -enable-apache APACHE_MAJOR = $apache_major APACHE_LIBDIR = $apache_libdir APACHE_OCAMLLIBS = -l$apache_camlrun -ltermcap -lunix -l$libstr APACHE_INCDIR = $apache_incdir APACHE_CONFDIR = $apache_confdir APACHE_LDFLAGS_SHLIB = $apache_ldflags_shlib APACHE_CC = $apache_cc APACHE_CFLAGS = $apache_cflags APACHE_OCAMLLIBDIR = $apache_ocamllibdir APXS = $apxs # ocamlrpcgen OCAMLRPCGEN_CPP = $cpp # cppo: CPPO = $cppo CPPO_VERSION = $cppo_version $export_path _EOF_ if [ $with_gnutls -gt 0 ]; then cat src/nettls-gnutls/config.mk >>Makefile.conf fi if [ $with_gssapi -gt 0 ]; then cat src/netgss-system/config.mk >>Makefile.conf fi if [ -n "$destdir" ]; then echo "DESTDIR = $destdir" >>Makefile.conf fi rm -f src/netcgi2-apache/config.h ###################################################################### # make oasis happy: setup.save will be picked up by "make postconf" # and will be appended to setup.data. That way the config update # will reach oasis. rm -f setup.save echo "pkg_version=\"$version\"" >>setup.save echo "bindir= \"$bindir\"" >>setup.save echo "datadir=\"$net_db_dir\"" >>setup.save echo "prefix=\"\"" >>setup.save echo "destdir=\"$destdir\"" >>setup.save for opt in $eoptions; do e="o=\$enable_$opt" eval "$e" if [ $o -gt 0 ]; then echo "$opt=\"true\"" >>setup.save else echo "$opt=\"false\"" >>setup.save fi done ###################################################################### # Finish echo echo "Please check Makefile.conf." echo echo "You can now compile Ocamlnet by invoking" echo " make all" echo "for the bytecode compiler, and optionally by invoking" echo " make opt" echo "for the native-code compiler (if supported on your architecture)." echo "Finally, a" echo " make install" echo "will install the package(s)." ocamlnet-4.0.4/LICENSE0000644000175000017500000000265212541553660012766 0ustar gerdgerdThese license conditions apply to the libraries: - cgi - equeue - equeue-gtk2 - equeue-tcl - netcamlbox - netcgi2 - netcgi2-plex - netclient - netgss-system - netmulticore - netplex - netshm - netstring - netstring-pcre - netsys - nettls-gnutls - netunidata - netzip - rpc - rpc-auth-local - rpc-generator - rpc-xti - shell The same holds for all files for which there are no other license terms. The cppo utility is from Martin Jambon and has its own license terms. It is only needed for building Ocamlnet. ====================================================================== Copyright (c) 2001-2006 Patrick Doane and Gerd Stolpmann This software is provided 'as-is', without any express or implied warranty. In no event will the authors be held liable for any damages arising from the use of this software. Permission is granted to anyone to use this software for any purpose, including commercial applications, and to alter it and redistribute it freely, subject to the following restrictions: 1. The origin of this software must not be misrepresented; you must not claim that you wrote the original software. If you use this software in a product, an acknowledgment in the product documentation would be appreciated but is not required. 2. Altered source versions must be plainly marked as such, and must not be misrepresented as being the original software. 3. This notice may not be removed or altered from any source distribution. ocamlnet-4.0.4/ChangeLog0000644000175000017500000010254412541553660013534 0ustar gerdgerd2015-06-21 Gerd Stolpmann * Release 4.0.4 * GnuTLS: compatibility with GnuTLS-3.4.2 * Nethttpd_plex: the post_add_hook was not called by accident (since OCamlnet-4); this is now fixed. * Nethtml: new option case_sensitive 2015-06-14 Gerd Stolpmann * GnuTLS: initializing the library on-demand. This avoids that /dev/random is kept open all the time since program start, and works around incompatibilities with Netplex. (Thomas Calderon found the problem.) * GnuTLS: setting DH parameters on certificates (this was forgotten in previous releases). (Thomas Calderon found the problem.) 2015-04-27 Gerd Stolpmann * Release 4.0.3 * GnuTLS: supporting GnuTLS versions where SRP is disabled. Supporting GnuTLS-3.4. 2015-02-26 Gerd Stolpmann * Release 4.0.2 * OpenBSD build: fix linker option (Christopher Zimmermann) 2015-02-23 Gerd Stolpmann * Equeue: There is a new method request_proxy_notification, which is only used by Uq_engines.qseq_engine (but unfortunately needs to appear in the public type of the object). This new method permits that chains of Uq_engines.qseq_engine pairs can now be arbitrarily long without consuming too much memory and without the danger of getting stack overflows. This fixes issues where notification chains got too long. In particular, we saw a stack overflow when retrieving a video stream via HTTP. The stream was sent with many chunks, resulting in a long Uq_engines.qseq_engine chain. Implementers of engines can simply define request_proxy_notification as no-ops. 2015-01-27 Gerd Stolpmann * Nethttp.set_content_range: this function generated an incorrect header (the "bytes" word was missing). (Török Edwin) 2015-01-18 Gerd Stolpmann * Release 4.0.1 * _oasis is generated from _oasis.in 2014-12-30 Gerd Stolpmann * Netplex: the Netplex socket directory has a different default if not specified in the config file. * Netshm: the POSIX specifier has now two args * IPv6: automatically enabled if there is a global IPv6 address * Unicode tables: Moved them to a separate netunidata library. This library needs to be linked in for getting access to the tables (this is no longer the default). * Renamings: Http_client, Ftp_client etc. => Nethttp_client, Netftp_client Mimestring => Netmime_string Xdr => Netxdr * Netmime: moved functions to Netmime_header and Netmime_channels * Netmech_scram: Removed the check that passwords only consist of ASCII chars. The user can now call Netsaslprep.saslprep. * Removed: rpc-auth-dh, nethttpd-for-netcgi2 2014-09-28 Gerd Stolpmann * Http_client: the authentication mechanisms are now encapsulated in a first-class module HTTP_MECHANISM. So far, there is Digest authentication in this form. The signature of HTTP_MECHANISM is similar to SASL_MECHANISM. Another visible change is that the insecure Basic authentication is no longer enabled for non-TLS-secured connections. This can be changed back by setting flags, though. Some fixes in the design improve Digest authentication for proxy connections. 2014-09-19 Gerd Stolpmann * Netpop: implementating SASL authentication for POP3. Moved Netpop into netclient. * Netsmtp: implementing SASL authentication for SMTP. Moved Netsmtp into netclient. * Adding a framework for SASL, and a number of mechanisms (PLAIN, CRAM-MD5, DIGEST-MD5, SCRAM-SHA1). 2014-08-31 Gerd Stolpmann * fcgi/scgi/ajp connectors: exporting a handle_connection function, and unifying existing such functions (Christopher Zimmermann) 2014-08-20 Gerd Stolpmann * adding support for modular cryptography (symmetric ciphers and digests) * SCRAM is now implemented with the new crypto providers * removing dependency on Cryptokit * removed library netgssapi; now part of netsys/netstring * removed library netmech-scram; now part of netstring Ocamlnet-4 adds: - new library netgss-system - new library nettls-gnutls - removed equeue-ssl and rpc-ssl - X.500 modules Netasn1, Netdn, Netx509 - Crypto definitions Netsys_crypto_types, Netsys_crypto - TLS modules Netsys_tls, Nettls_support - Support for SASL and GSSAPI - Moved many functions from Uq_engines to new modules in the equeue library (Uq_client, Uq_server, Uq_multiplex, Uq_transfer) Development of Ocamlnet-4 starts ====================================================================== 2014-10-27 Gerd Stolpmann * Release ocamlnet-3.7.7 2014-10-19 Gerd Stolpmann * Netsys_posix.mli.mkfifoat: this function is not supported on OS X 10.10, and this is now detected at config time. 2014-09-16 Gerd Stolpmann * Release ocamlnet-3.7.6 * netstring-pcre: removing dependency on camlp4 (an oversight). 2014-09-06 Gerd Stolpmann * Fixing bad format strings (Damien Doligez) 2014-08-31 Gerd Stolpmann * Release ocamlnet-3.7.5 * Windows: various fixes, including int sizes for 64-bit Windows, the invocation of cppo, and CR characters. Also, unixsupport.h is now used instead of declaring the prototypes directly. (Andreas Hauptmann) * C99: use int64_t instead of int64 in C code. The latter is gone in OCaml-4.02. (Richard Jones) 2014-08-25 Gerd Stolpmann * Build: no longer requiring camlp4 (as it is not distributed with ocaml-4.02) * Fixing some unit tests 2014-08-24 Gerd Stolpmann * Netexn: new exception representation in ocaml-4.02 * Build: renaming file for a configure test to avoid a naming conflict (Richard Jones) 2013-10-01 Gerd Stolpmann * Release OCamlnet-3.7.4 * Https_client and aggressive connection caching: In previous versions there was a problem with the reinitialization of the SSL socket when a former connection was reused. The fix requires an API change of connection_cache: The SSL socket can now be stored with the inactive connection. * Http_client: fixing a bug with connection caching: Address resolution was not taken into account for computing the key in the connection cache. 2013-09-30 Gerd Stolpmann * ssl_exts_stubs.c: releasing global lock on shutdown error (Török Edwin) 2013-09-08 Gerd Stolpmann * Uq_ssl: Fix error path when SSL connection fails during the handshake * NB. Ocamlnet-3.7.1 to 3.7.3 only contain fixes of the build system, and one minor change to make ocaml-4.01 happy 2013-08-30 Gerd Stolpmann * Release Ocamlnet-3.7.0 * Shell.to_file: implement the append flag as documented (bug reported by David Chase) * The libraries netcamlbox and netmulticore are now only built if completely supported. * Porting netcamlbox and netmulticore to ocaml-4.01: There are new implementations in OCaml for caml_modify and caml_initialize that are incompatible with our usage here. Fortunately, these symbols are now weak, and we can override them. This is done in netsys.outofheap, and for the time being we just use the old implementation from ocaml-4.00. 2013-08-30 Gerd Stolpmann * Porting netsys to ocaml-4.01: O_CLOEXEC is now supported if found 2013-08-19 Gerd Stolpmann * Netsys_sem: fix for systems that don't have Netsys_posix.sysconf_open_max (e.g. Win32). (Davild Allsopp) 2013-08-16 Gerd Stolpmann * Http_fs: read method: fixing a problem with resent messages * Http_client: better reaction after "100" responses * Http_client: implementing verbose_response_header, and verbose_response_contents again * Uq_ssl: debugging of payload data (Uq_ssl.Debug.dump_data) 2013-08-13 Gerd Stolpmann * Http_fs: fixing chunked encoding for PUT (this is already done in Http_client) * Nethttp: new function base_code * Http_client: handling the case better that an unknown status code is returned by the server. Before, [response_status] simply raised [Not_found]. Now, the base status is returned instead. 2013-07-31 Gerd Stolpmann * Extending ocamlrpcgen: It supports now six new directives, _lowercase, _uppercase, _capitalize, _prefix, _equals, and _tuple (see documentation). 2013-07-21 Gerd Stolpmann * Release Ocamlnet-3.6.6 * Netplex_container: emits now backtraces if these are enabled. * Http_fs: adding [last_response_status] method * Rpc_client: fixing a potential endless loop when session IDs are reused * Rpc_client: fixing the shutdown when a TCP connection is immediately refused, and GSS-API authentication is active. 2013-06-16 Gerd Stolpmann * Netcgi_fcgi.run: no longer ignoring the sockaddr argument (problem reported by Watanabe Masaki) 2013-06-13 Gerd Stolpmann * Remove duplicate method Netpop.stat 2013-06-06 Gerd Stolpmann * Release Ocamlnet-3.6.5 * Build fix for netstring-pcre 2013-06-03 Gerd Stolpmann * Release Ocamlnet-3.6.4 * Regular expressions: The config switch -enable-pcre no longer switches the default backend to PCRE. The default remains Str, and only Netstring_pcre is additionally built. The new switch -enable-full-pcre has now the stronger meaning of also using PCRE as default backend. New documentation page Regexp explaining this. * Netmcore_basics.txt: more documentation for Netmulticore 2013-05-27 Gerd Stolpmann * Netgzip.ml: Fixing a bug in the inflating pipe (bad calculation of the crc) * Netplex_mbox: implementation of a simple message box allowing communication between Netplex components. This module does neither need Netmulticore nor Netcamlbox, but is relatively slow. 2013-05-13 Gerd Stolpmann * netcgi2-apache: fixing build against apache-2.4. * netcgi2-apache: fixing bug that PKGNAME was incorrect * netcgi2-apache: the directory of the OCaml stdlib is now added via rpath to mod_netcgi_apache.so so that libcamlrun_shared.so is automatically found * Http_client: more liberal interpretation of the "domain" part of authentication keys * src/netsys/netsys_c_poll.c: Fix FD_CLOEXEC (Guillem Jover ) 2013-03-29 Gerd Stolpmann * Http_client authentication: The domain for authentication keys can be set to ["*"]. Also, port number can be omitted in such domains. * Http_client authentication: adding skip_challenges auth style * Uq_engines: New [qseq_engine] class. This is the same as [seq_engine], but it does not forward pure progress events. The operator [++] is now backed by [qseq_engine]. This change fixes performance bugs (e.g. Http_client had problems with HTTP responses consisting of many chunks). 2013-02-12 Gerd Stolpmann * Netmcore, Netmcore_process: also adding a function [run] in in addition to [startup] for jobs that want to return something. With [join_nowait] one can now get the result of the first process. Also updated examples/multicore/create_join.ml. 2013-02-10 Gerd Stolpmann * Netplex_main: new function [run], designed for compute jobs run under Netplex regime * Netdate: adding ISO-8601 week numbering. Fixing test suite and some bugs 2013-01-13 Gerd Stolpmann * Release OCamlnet-3.6.3 * Netmcore_heap.mli: allowing to [add] bigarrays. New function [add_string] for creating uninitialized strings on heaps. New function [add_immutable] for retaining value sharing. * Netsys_mem: New options [Copy_conditionally] and [Keep_atom] for function [init_value]. 2012-12-26 Gerd Stolpmann * Release OCamlnet-3.6.2 * netsys_c_subprocess.c: fixing a deadlock issue (when calling commands via the Shell library) 2012-11-19 Gerd Stolpmann * Netdate: Fix interpretation of the ~localzone argument of several functions. Now the timezone is assumed for the target time, not the calling time * Netdate: Adding localization * Netconversion: Adding functions for converting to lowercase/ uppercase/titlecase, and for case-insensitive comparison 2012-11-07 Gerd Stolpmann * Release OCamlnet-3.6.1 * Fix Netfs.copy: When the copy method throws EXDEV, it is fallen back to a streaming-type copy * Several fixes for OS X * Daemonizer: now using a signal for waiting until the children are up and running * Fixes for OCaml-4.00 2012-09-30 Gerd Stolpmann * Better endianness check as suggested by Matias Giovannini * Fixing handling of `Recv_send_implied sockets in socket_multiplex_controller 2012-08-27 Gerd Stolpmann * netzip: it is now autodetected whether the camlzip library is available under the findlib name "zip" or "camlzip" 2012-07-20 Gerd Stolpmann * Release Ocamlnet-3.6 * Netsys_sem: a new abstraction for emulating anonymous semaphores on systems that only provide named semaphores, like OS X. All users of semaphores inside Ocamlnet now base on Netsys_sem. 2012-07-19 Gerd Stolpmann * reimplementing Netstring_str for the case the Str engine is used. It is now thread-safe without having to use mutexes. * The default is now -disable-pcre * The module Netstring_pcre has been moved to a library of its own, namely netstring-pcre. It is only installed if -enable-pcre 2012-06-27 Gerd Stolpmann * Nethttp.Header.best_media_type: improved (patch by Christopher Zimmemann) 2012-06-22 Gerd Stolpmann * Netsys_mem.alloc_memory_pages: one can now mark the memory pages as executable 2012-05-31 Gerd Stolpmann * src/netsys/configure: disabling POSIX semaphore check for win32 2012-05-26 Gerd Stolpmann * Fixes for OpenBSD (by Christopher Zimmermann) * Netcgi connectors (SCGI, AJP, FCGI): unifying the ~sockaddr and ~port arguments. ~port now also assumes a loopback binding. (Suggested by Christopher Zimmermann). 2012-03-15 Gerd Stolpmann * Allowing posix_spawn again for MacOS. It turns out the number of file actions is limited. If we are above the limit, posix_spawn is not used. 2012-03-01 Gerd Stolpmann * Ssl_exts: adding function for returning the fingerprint of a certificate * Https_client: new verify callback for additional certificate checks 2012-02-29 Gerd Stolpmann * Release Ocamlnet-3.5.1 * Fixing various build problems: - FreeBSD-9: clock_getcpuclockid problem - FreeBSD-9: PATH_MAX problem - Mac OS: disbling posix_spawn (cannot debug this right now) - Linux: adding -lpthread to ocamlopt link flags 2012-02-22 Gerd Stolpmann * Release Ocamlnet-3.5 * Documentation: new Equeue_howto introduction into Equeue/engines 2012-02-21 Gerd Stolpmann * Netplex: new option "greedy_accpepts" for improving the speed of Netplex systems accepting new connections at a very high rate (> 1000/s). * Netplex: the constant workload manager gets the option max_jobs_per_thread. 2012-02-20 Gerd Stolpmann * Netchannels: new option ~pass_through for buffered netchannels * Netshm_data.string_manager: speeding up (using memory_of_bigarray) * Netsys_mem.memory_of_bigarray: added * Netmcore_condition: There is now a second kind of wait_entry allowing it to wait via file descriptor polling. 2012-02-16 Gerd Stolpmann * Http_client: fixing the case that a non-idempotent request needs authentication, but should always be tried again even if reconnect_mode does not allow to create a new connection. * Netplex: making many container methods/functions thread-safe 2012-02-15 Gerd Stolpmann * Uq_mt: this new module coordinates access to shared engine-based resources from multiple threads (e.g. share an RPC client by several threads) * Uq_ssl + Https_client: fixing problem when the client times out while still connecting. Before, the module closed the file descriptor too early. (Thanks to Henry Hughes for reporting.) 2012-02-14 Gerd Stolpmann * XDR/RPC: implemented direct mapping from byte representation to Ocaml value. Use new switch -direct with ocamlrpcgen to enable. 2012-02-10 Gerd Stolpmann * Xdr: additional check against invalid XDR messages. * Xdr: calling Netnumber instead of Rtypes * Netnumber: speeding int8 readers and writers up (only on 64 bit systems) 2012-02-08 Gerd Stolpmann * epoll: Adding support. This is exported as "event aggregator" in Netsys_posix (the API is prepared for other poll implementations). There is also Netsys_pollset_posix.accelerated_pollset. * Netplex: Adding container_event_system and container_run to [processor_hooks] so users can override these functions (for using Lwt in Netplex containers). 2012-02-06 Gerd Stolpmann * Netsys_posix: Adding a second implementation for spawn basing on posix_spawn 2012-02-05 Gerd Stolpmann * Netsys_posix: Adding POSIX clock functions. These allow operations with nanosecond resolution * Netlog and Netdate have been extended to support high resolution clocks. New "nanos" field in Netdate.t. * Netsys_posix: Adding event abstraction. Under Linux this is backed by eventfd and timerfd. For other OS, an emulation with pipes is available. * Netsys_posix: Adding POSIX timers. They can be connected with events (the event is signaled when the timer expires). * Netsys in general: Splitting netsys_c.c up into several files. Improved configure script. * Netplex_log: Using the new standard formatter. 2012-01-23 Gerd Stolpmann * Http_client: forgot to configure Digest authentication for the convenience module (thanks to Paolo Donadeo for finding it) 2012-01-13 Gerd Stolpmann * Fix memory leak: Adding finalizer for Netsys_posix.poll_mem values (thanks to Henry Hughes) * Fix (build): ocamlrpcgen respects existing OCAMLPATH (Dmitry Grebeniuk) 2011-12-30 Gerd Stolpmann * Security: adding limit max_arguments to Netcgi. This is more a general measure of precaution against DoS attacks where a specially crafted POST request contains many keys that collide massively in the hash table. Actually, Ocamlnet is not directly vulnerable; however, application programs can nevertheless be when they access a degenerated hash table. 2011-10-12 Gerd Stolpmann * Release 3.4.1 2011-10-11 Gerd Stolpmann * Rpc_client: new functions get_xid_of_last_call, and abandon_call 2011-09-23 Gerd Stolpmann * rpc-auth-local: Implementing this for more types of OS. * Rpc: fixing some bugs 2011-09-20 Gerd Stolpmann * Rpc_client and Rpc_server: disabling the Nagle algorithm. At the same time, Rpc_transport is improved so it almost never calls write() several times with small strings. 2011-09-10 Gerd Stolpmann * bugfixes in the Netplex shutdown procedure 2011-08-30 Gerd Stolpmann * Uq_io: adding input_lines_e * IPv6 support for Neturl and Uq_resolver. Also fixes in Uq_socks5 and netcgi2. * Netplex: print line number for syntax errors in config files. * Netplex: the method socket_directory returns an absolute path. The method startup_directory is now also available in containers. * Release 3.4 2011-08-29 Gerd Stolpmann * Http_client: one can set a different proxy server for each transport type * Netfs: new methods read_file and write_file, for file-based downloads and uploads, respectively. * Netfs: new method cancel to stop an upload prematurely * Http_fs, Ftp_fs: new method translate to get the URL for a file operation * Ftp_fs: the get_password and get_account functions take the user name as input 2011-08-23 Gerd Stolpmann * Build fixes for Ocaml-3.11. There were some regressions. 2011-08-16 Gerd Stolpmann * netcgi_apache: adding support for Findlib (new directives NetcgiRequire et al) 2011-08-05 Gerd Stolpmann * Released: ocamlnet-3.3.7 2011-08-03 Gerd Stolpmann * Netplex: new workload_hook. It is called whenever a connection is accepted or terminated. * Netplex: new config conn_limit to set the maximum number of connections a container can accept * Netplex: new config gc_when_idle to run Gc.full_major when the container is idle for some time * Reducing memory consumption (Uq_io and users such as Http_client, Netplex, Rpc) by recycling bigarray buffers more quickly * New admin messages netplex.mem.major, netplex.mem.compact, netplex.mem.pools, netplex.mem.stats * Docs netplex_admin.txt 2011-07-29 Gerd Stolpmann * Shell: calling subprograms did not work when multi-threading was enabled because of a caml_leave_blocking_section without prior caml_enter_blocking_section. This is fixed. * Uq_ssl: Changed the method of closing SSL tunnels. Before, a close-notify SSL message was sent, and also expected by the peer before the connection was closed on TCP level. Now, we half-close the TCP connection immediately after sending close-notify. This seems to fix some SSL sessions where the server ignores close-notify, and only reacts on TCP closes. This method of closing seems to be ok with the standard, which is apparently not very precise on SSL closures. * Released: Ocamlnet-3.3.6 2011-07-20 Gerd Stolpmann * Fix filter in Rpc_server: they are no longer accidentally reset for longer TCP messages * Fix Http_client: avoiding an assert when the server immediately responds without awaiting the request * Mimestring: reimplementing the MIME scanner w/o regexps. Also new string processing functions for iterating over lines. * Nethttpd: banning all regexps in message parsing that could cause stack overflows * Nethttpd: Returning better Content-Encoding for statically served files. In particular, the encoding of compressed files is taken into account * Released: Ocamlnet-3.3.5 2011-07-12 Gerd Stolpmann * Shell_sys: Fixing descriptor assignments (avoiding EBADF errors) * Netplex: support for TCP_NODELAY in servers * Released: Ocamlnet-3.3.4 2011-06-24 Gerd Stolpmann * Rpc_client: fix for GSS-API authentication how exceptions are passed back to the caller, avoiding double callbacks * Packing error for Netglob_lex. 2011-06-16 Gerd Stolpmann * Rpc_client: fix when trying several authentication methods: The original call is no longer marked as pending. This avoids a hanging event system. * Netsys_posix: adding with_tty, tty_read_password 2011-06-14 Gerd Stolpmann * Adding Netsockaddr module, and a few conversion functions for socksymbol 2011-06-13 Gerd Stolpmann * Fix: sending HTTP requests in URL-encoded form (thanks to Joel Reymont for pointing it out) * Fix: redirects after POST * Fix: timeouts in Unixqueue_pollset no longer cause failed assertions (thanks to Stéphane Legrand) * Released: Ocamlnet-3.3.3 2011-06-12 Gerd Stolpmann * Fix: Http_client removed the query path from URLs accidentally * Released: Ocamlnet-3.3.2 2011-06-10 Gerd Stolpmann * Released: Ocamlnet-3.3.1 2011-06-10 Gerd Stolpmann * FTP protocol: Finishing Ftp_client (w/ API changes). Adding Ftp_fs * HTTP protocol: adding support for TLS * HTTP protocol: can handle compression automatically * Adding tutorial for Netclient * Using Uq_resolver, finally * Adding Uq_lwt for (limited) compatibility with Lwt * Reorganizing regression test suite 2011-05-06 Gerd Stolpmann * Unixqueue: important bug fixes that were introduced since Ocamlnet-3.2, and affect e.g. Http_client. 2011-04-29 Gerd Stolpmann * Preventing errors "Netchannels: Suppressed error in close_out: Netchannels.Closed_channel" (tentative fix) 2011-04-28 Gerd Stolpmann * Reverting Netencoding.Url to the implementation used in Ocamlnet-2. The new impl introduces some incompatibilities with Neturl. * Ocamlnet can now also be built without PCRE! Just configure with -disable-pcre. 2011-04-14 Gerd Stolpmann * Test release: 3.3.0test1 * Netmulticore: adding a lot of modules for managing shared heaps. Also contains a tutorial now. 2011-03-07 Gerd Stolpmann * Netnumber: better successor of Rtypes, with both big-endian and little-endian support. Rtypes is still available as legacy module * Xdr, Xdr_mstring, Rtypes: have been moved to the "netstring" library part * Adding support for GSS-API: The generic interface is defined in Netgssapi. ONC-RPC support can be found in Rpc_auth_gssapi. The authentication framework of ONC-RPC had to be slightly extended. * Adding the SCRAM authentication method. Also includes an encapsulation as GSS-API method. * Rpc_client: one can now set the user identifier (also for Rpc_proxy) * Rpc_server: added is_dummy * Netsys_rng: secure random numbers on all platforms 2011-01-31 Gerd Stolpmann * Rpc_proxy: if initial_ping is enabled, the calls are queued up in the right order. * Netsys_posix: also allowing flags POSIX_FADV_* for better compatibility with extunix. 2011-01-30 Gerd Stolpmann * Build fixes for FreeBSD 8.1 * Build fixes for Ocaml 3.11 2011-01-17 Gerd Stolpmann * Http_fs: PUT semantics can be better controlled with the If-Match and If-None-Match headers. * Netchannels: Fixing some close_out problems when errors occur while closing 2011-01-04 Gerd Stolpmann * Optimizations (especially async code) * Netplex_sharedvar.dump: new function for debugging 2010-12-23 Gerd Stolpmann * Released: Ocamlnet-3.2 * Http_fs: fixing the case that the channel is closed before everything is downloaded * Netfs: adding `Dummy as value to all flags * Netfs: fixing symlinks in iter and copy_into. * Netglob: behaves better when the pattern encoding is distinct from the filename encoding * Shell_fs: expose input_stream_adapter, output_stream_adapter 2010-12-20 Gerd Stolpmann * Shell_fs: added stream_fs implementation via shell 2010-12-19 Gerd Stolpmann * Http_fs: added stream_fs implementation for HTTP * Netfs: new `Streaming flags for read and write * Netsys_tmp: new module for globally setting where temporary directories are created 2010-12-17 Gerd Stolpmann * Netglob: new module for globbing 2010-12-16 Gerd Stolpmann * Netsys_posix: adding query_langinfo function for basic locale support * Netconversion: new fn: user_encoding * Netfs: new abstraction representing simple filesystems (both local and remote) * Netsys_posix: adding the *at functions (like openat). Also fchdir and fdopendir are new. 2010-12-09 Gerd Stolpmann * Http_client: fixing aggressive connection caching. Also new module Http_client_conncache for extending the functionality of connection caches. 2010-12-06 Gerd Stolpmann * Netdate: Fixing possible exceptions 2010-11-27 Gerd Stolpmann * Netplex bugfixes: services could not be finished that had already no containers * Netplex_semaphore: added destroy. Some functions can now be called from controller context. * Netplex config files: added support for config_tree. No longer defaulting to /etc/netplex. Instead, the suffix ".conf" is appended to the name of the executable. * Adding Netmcore, Netmcore_camlbox 2010-11-23 Gerd Stolpmann * Released: Ocamlnet-3.1 * Rtypes: on 64 bit platforms, negative ints were incorrectly decoded 2010-11-22 Gerd Stolpmann * Uq_engines.Operators: generalized the type of ( >> ) * Netsys_mem: init_value allows now to set the custom_ops struct for custom blocks. Also, some corner cases for bigarrays have been fixed. Renamed Copy_custom to Copy_custom_int. * Netsys_mem: new function copy_value * Netcamlbox: it is now also possible to put messages with int32,int64,nativeint and bigarrays into boxes 2010-10-01 Gerd Stolpmann * Nethttpd: Fixing a bug in Nethttpd_services that prevents in some cases that HTTP connections with pipelining are correctly processed. This bug showed especially up in conjuction with Nethttpd_engine. * Nethttpd: adding encap args in Nethttpd_plex. 2010-09-09 Gerd Stolpmann * Released: Ocamlnet-3.0.3 * Nethttpd: Nethttpd_plex.nethttpd_factory got new arg processor_factory. This allows it to override this factory. (Caveat: this factory must be polymorphic.) * Netsys: netsys_oothr.cma no longer contains a reference to Thread. New archive netsys_oothr_mt.cma for this. * Netsys: resolving circular dep netsys <-> netsys_signal 2010-08-31 Gerd Stolpmann * Released Ocamlnet-3.0.0 ---------------------------------------------------------------------- These are old change logs before the Ocamlnet-3 development started. ---------------------------------------------------------------------- 2008-03-30 Gerd Stolpmann * Adding netzip library * Enhancement: Netplex controllers can send and receive messages * Enhancement: Plugins for Netplex controllers * Adding Netplex_semaphore using the new plugin feature 2008-03-29 Gerd Stolpmann * Adding subchannel logging to Netplex * Adding access logging to Nethttpd 2008-03-04 Gerd Stolpmann * Recognize GNU/kFreeBSD (Stéphane Glondu ) * Fix: Upgraded equeue-ssl for use with ocaml-ssl >= 0.4 (thanks to Debian ocaml maintainers) * [ChriS]: Removal of old cgi stuff * [ChriS]: Preparing netcgi-apache for OCaml 3.11 * Enhancements: Introducing pollsets and Unixqueue2. This work is experimental for now and not yet complete. 2007-11-18 Gerd Stolpmann * Adding syscalls to Netsys: poll, fsync, fdatasync, fadvise, fallocate, ioprio_get/set 2007-11-01 Gerd Stolpmann * Release 2.2.9 * Fix: Http_client becomes more robust when it sees illegal header fields. * Fix: Netshm decodes pairs correctly 2007-07-31 Gerd Stolpmann * Release 2.2.8 * Fix: stop all timers on Netplex shutdown * Improved Netbuffer module * [ChriS]: Improved examples for netcgi2 2007-05-06 Gerd Stolpmann * Fix: For Unix domain sockets, getsockname and getpeername may return EAFNOSUPPORT. This code is generated by the OCaml runtime when it sees an address it does not support. We handle this case as a connected socket with inaccessible address. The problem was reported to happen for MacOS. * Fix: IPv6 is now supported by most functionality. Exception is the SOCKS stuff. * Fix netcgi2: Improving compatibility of Netcgi1_compat, such that nethttpd works together with netcgi2. Porting examples/nethttpd/netplex.ml to nethttpd+netcgi2. * [ChriS]: Netcgi2-apache builds for Apache 2 2007-04-09 Gerd Stolpmann * Release 2.2.7 * Including netcgi2-apache into the release * Fix: Error handling in Nethttpd. * Fix: Build of nethttpd examples 2007-03-28 Gerd Stolpmann * Release 2.2.6 * Improving timeout handling in Rpc_client. TCP timeouts are now handled better. Added Unbound_exception. 2007-03-05 Gerd Stolpmann * Release 2.2.5 * Addition of Rpc_client.set_dgram_destination and get_sender_of_last_response to support unconnected UDP sockets. 2007-02-20 Gerd Stolpmann * Addition of EUC-KR, by Deokhwan Kim 2007-01-18 Gerd Stolpmann * Fix: The library netshm needs bigarray as requirement. 2007-01-07 Gerd Stolpmann * Releases 2.2.3 and 2.2.4: Minor clean-ups in the build system. 2006-12-31 Gerd Stolpmann * Releases 2.2.1 and 2.2.2: Single build fix for Mac OS X. ocamlnet-4.0.4/RELNOTES0000644000175000017500000000362312541553660013136 0ustar gerdgerd---------------------------------------------------------------------- Intro ---------------------------------------------------------------------- These are release notes for ocamlnet-3.0. Major changes include: - Port to Win32 - The new Rpc_proxy layer - Netplex has been extended (Netplex_sharedvar etc.) - New implementation of the Shell library for starting subprocesses - Uniform debugging with Netlog.Debug - Exception printers (Netexn) - Coordination of signal handling in Netsys_signal - New foundation for Unixqueue via pollsets - Extended Unixqueue engines (e.g. Uq_io) - More system calls in netsys - Camlboxes as an efficient way of message passing between processes - The netcgi1 library has been dropped in favor of netcgi2 Also, there are lots of smaller improvements and bug fixes. ---------------------------------------------------------------------- Known Problems ---------------------------------------------------------------------- There are known problems in this preview release: - The port to Win32 is incomplete and still alpha quality - Sometimes, DNS errors are just reported by the exception Not_found - In netcgi2-plex, the "mount_dir" and "mount_at" options are not yet implemented. - In netclient, aggressive caching of HTTP connections is still buggy. Do not use this option (by default, it is not enabled). - The FTP client is still incomplete. ---------------------------------------------------------------------- Resources ---------------------------------------------------------------------- The current development version is available in Subversion: https://godirepo.camlcity.org/svn/lib-ocamlnet2 Note that the ocamlnet file tree in Sourceforge refers to ocamlnet-1 only. There is a mailing list for Ocamlnet development: http://sourceforge.net/mail/?group_id=19774 In case of problems, you can also contact me directly: Gerd Stolpmann ocamlnet-4.0.4/Makefile.xrules0000644000175000017500000000064412541553660014741 0ustar gerdgerd# Additional rules for the examples: OCAMLRPCGEN = ocamlfind rpc-generator/ocamlrpcgen .SUFFIXES: .x .astamp .cstamp .sstamp .s2stamp .x.astamp: $(OCAMLRPCGEN) -aux $(RPCGEN_AUX_OPTIONS) $< touch $@ .x.cstamp: $(OCAMLRPCGEN) -clnt $(RPCGEN_CLIENT_OPTIONS) $< touch $@ .x.sstamp: $(OCAMLRPCGEN) -srv $(RPCGEN_SERVER_OPTIONS) $< touch $@ .x.s2stamp: $(OCAMLRPCGEN) -srv2 $(RPCGEN_SERVER_OPTIONS) $< touch $@ ocamlnet-4.0.4/LICENSE.GPL0000644000175000017500000004346512541553660013416 0ustar gerdgerdThe library Nethttpd (incl. nethttpd-for-netcgi1 and nethttpd-for-netcgi2) is distributed under the terms of the GNU General Public License (GPL). ====================================================================== GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. ocamlnet-4.0.4/Makefile.rules0000644000175000017500000001440612541553660014552 0ustar gerdgerd# Inclusion of Makefile.conf may fail when cleaning up: -include $(TOP_DIR)/Makefile.conf # Makefile.conf: written by "configure". # How to invoke compilers and tools: # (May be moved to Makefile.conf if necessary) OCAMLC = $(OCAMLFIND) ocamlc -g $(OCAMLC_OPTIONS) $(INCLUDES) -package "$(REQUIRES)" $(PP_OPTIONS) $(WARNINGS) OCAMLC_MLI= $(OCAMLFIND) ocamlc -g $(OCAMLC_OPTIONS) $(INCLUDES) -package "$(REQUIRES)" $(WARNINGS) # Note that PP_OPTIONS do not affect .mli! (usually breaks ocamldoc) OCAMLOPT = $(OCAMLFIND) ocamlopt -g $(OCAMLOPT_OPTIONS) $(INCLUDES) -package "$(REQUIRES)" $(PP_OPTIONS) $(WARNINGS) OCAMLDEP = $(OCAMLFIND) ocamldep $(OCAMLDEP_OPTIONS) $(PP_OPTIONS) OCAMLFIND = ocamlfind OCAMLYACC = ocamlyacc OCAMLLEX = ocamllex OCAMLMKLIB = $(TOP_DIR)/tools/mkstublib OCAMLDOC = $(OCAMLFIND) ocamldoc STUBCC = $(TOP_DIR)/tools/stubcc -ocamlc ocamlc # CPPO: is set by Makefile.conf # Set here which warnings we want to have: # 3: whether to report deprecated features. This is disabled because we are # massively using mutable strings (deprecated in 4.02) # 25: "all clauses guarded". I like this. WARNINGS = -w -3-25 TOOLS_DIR = $(TOP_DIR)/tools COLLECT_FILES = $(TOOLS_DIR)/collect_files # To be overridden by the command line: INC_NETSYS = -I $(TOP_DIR)/src/netsys INC_NETSTRING = -I $(TOP_DIR)/src/netstring INC_EQUEUE = -I $(TOP_DIR)/src/equeue INC_EQUEUE_SSL = -I $(TOP_DIR)/src/equeue-ssl INC_NETCGI2 = -I $(TOP_DIR)/src/netcgi2 INC_NETCGI2_APACHE = -I $(TOP_DIR)/src/netcgi2-apache INC_NETPLEX = -I $(TOP_DIR)/src/netplex INC_NETCAMLBOX = -I $(TOP_DIR)/src/netcamlbox INC_RPC = -I $(TOP_DIR)/src/rpc INC_SHELL = -I $(TOP_DIR)/src/shell INC_NETGSSAPI = -I $(TOP_DIR)/src/netgssapi # Standard definitions and rules XOBJECTS = $(OBJECTS:.cmo=.cmx) POBJECTS = $(OBJECTS:.cmo=.p.cmx) ARCHIVE ?= $(PKGNAME) .PHONY: all opt all-mt-vm opt-mt-vm all-mt-posix opt-mt-posix ARCHIVE_CMA ?= $(ARCHIVE).cma ARCHIVE_CMXA ?= $(ARCHIVE).cmxa ARCHIVE_P ?= $(ARCHIVE).p ARCHIVE_P_CMXA ?= $(ARCHIVE_P).cmxa ALL ?= $(ARCHIVE_CMA) $(ALL_EXTRA) \ all-mt-$(MT_TYPE) OPT ?= $(ARCHIVE_CMXA) $(OPT_EXTRA) \ opt-mt-$(MT_TYPE) opt-p-$(HAVE_GPROF) opt-mt-$(MT_TYPE)-p-$(HAVE_GPROF) all: $(ALL) opt: $(OPT) all-mt-vm: $(ALLMT_EXTRA) all-mt-posix: $(ALLMT_EXTRA) opt-mt-vm: opt-mt-posix: $(OPTMT_EXTRA) opt-p-0: opt-p-1: $(ARCHIVE_P_CMXA) $(OPTP_EXTRA) opt-mt-vm-p-0: opt-mt-posix-p-0: opt-mt-vm-p-1: opt-mt-posix-p-1: $(OPTMTP_EXTRA) $(ARCHIVE_CMA): $(OBJECTS) $(COBJECTS) if [ "X$(COBJECTS)" = "X" ]; then \ $(OCAMLC) -a -o $(ARCHIVE_CMA) $(OBJECTS); \ else \ $(OCAMLMKLIB) -o $(ARCHIVE) $(OBJECTS) $(COBJECTS) $(LINK_OPTIONS); \ fi $(ARCHIVE_CMXA): $(XOBJECTS) $(COBJECTS) if [ "X$(COBJECTS)" = "X" ]; then \ $(OCAMLOPT) -a -o $(ARCHIVE_CMXA) $(XOBJECTS); \ else \ $(OCAMLMKLIB) -o $(ARCHIVE) $(XOBJECTS) $(COBJECTS) $(LINK_OPTIONS); \ fi $(ARCHIVE_P_CMXA): $(XOBJECTS) $(COBJECTS) if [ "X$(COBJECTS)" = "X" ]; then \ $(OCAMLOPT) -a -o $(ARCHIVE_P_CMXA) $(POBJECTS); \ else \ $(OCAMLMKLIB) -o $(ARCHIVE_P) $(POBJECTS) $(COBJECTS) $(LINK_OPTIONS); \ fi # Files to remove everywhere by "make clean": CLEAN_LIST = *.cmi *.cmo *.cma *.cmx *.o *.a *.cmxa dll* packlist-* \ ocamldoc.dump META depend $(PACKLIST) $(GENERATE) # Generic build rules: .SUFFIXES: .cmo .cmi .cmx .ml .mli .mll .mly .c .o .ml.cmx: $(OCAMLOPT) -c $(OCAMLOPT_OPTIONS_FOR_$<) $< [ $(HAVE_GPROF) -eq 0 ] || $(OCAMLOPT) -c -p -o `basename $@ .cmx`.p.cmx $(OCAMLOPT_OPTIONS_FOR_$<) $< .ml.cmo: $(OCAMLC) -c $(OCAMLC_OPTIONS_FOR_$<) $< .mli.cmi: $(OCAMLC_MLI) -c $(OCAMLC_OPTIONS_FOR_$<) $< .mll.ml: $(OCAMLLEX) $< .mly.ml: $(OCAMLYACC) $< .c.o: $(STUBCC) -ccopt "-O -g" $(CC_OPTIONS) $(CC_OPTIONS_FOR_$<) $< # We add $(OBJECTS) to the antecedents of ocamldoc.dump to ensure that # the files are compiled. ocamldoc needs the .cmi files, and this is # the simplest way of ensuring that. ocamldoc.dump: $(DOBJECTS) $(OBJECTS) $(OCAMLDOC) -dump ocamldoc.dump -stars $(INCLUDES) -package "$(REQUIRES)" $(OCAMLDOC_OPTIONS) $(DOBJECTS) || { rm -f ocamldoc.dump; exit 1; } # Install rules: .PHONY: install install: @$(MAKE) -f Makefile.pre realinstall .PHONY: realinstall realinstall: install-$(INSTMETHOD) $(INSTOTHER) $(PACKLIST) .PHONY: uninstall uninstall: @$(MAKE) -f Makefile.pre realuninstall .PHONY: realuninstall realuninstall: $(UNINSTOTHER) uninstall-$(INSTMETHOD) .PHONY: install-findlib install-findlib: META files=`$(COLLECT_FILES) *.mli *.cmi *.cma *.cmxa *.a dll* META $(INSTALL_EXTRA)` && \ $(OCAMLFIND) install $(PKGNAME) $$files .PHONY: uninstall-findlib uninstall-findlib: $(OCAMLFIND) remove $(PKGNAME) if [ -n "$(PACKLIST)" ]; then \ if packlist=`ocamlfind query $(PKGNAME)`/$(PACKLIST); then \ if [ -f "$$packlist" ]; then \ files=`cat $$packlist` && \ rm -f $$files; \ echo "$$files" | xargs echo "Removed "; \ fi; \ fi; \ fi META: META.in sed -e 's/@VERSION@/$(VERSION)/' \ -e 's/@AUTHDHREQS@/$(AUTHDHREQS)/' \ -e 's/@PREFERRED_CGI_PKG@/$(PREFERRED_CGI_PKG)/' \ -e 's/@REGEXP_PROVIDER@/$(REGEXP_PROVIDER)/' \ -e 's/@COMPAT_PCRE_PROVIDER@/$(COMPAT_PCRE_PROVIDER)/' \ -e 's/@ZIP_PROVIDER@/$(ZIP_PROVIDER)/' \ META.in >META #---------------------------------------------------------------------- # general rules: DEP_FILES ?= $(wildcard *.ml) $(wildcard *.mli) # Set NODEP to "@true" in order to disable "depend". depend: $(DEP_FILES) $(NODEP) $(OCAMLDEP) *.ml *.mli >$@ || { rm -f $@; exit 1; } .PHONY: clean clean:: genclean rm -f $(CLEAN_LIST) .PHONY: clean-doc clean-doc:: rm -f ocamldoc.dump .PHONY: distclean distclean:: genclean rm -f $(CLEAN_LIST) META rm -f *~ depend .PHONY: generate generate: @$(MAKE) -f Makefile.pre realgenerate .PHONY: realgenerate realgenerate:: $(GENERATE) .PHONY: genclean genclean: @test ! -f Makefile.pre || $(MAKE) -f Makefile.pre realgenclean .PHONY: realgenclean realgenclean:: rm -f $(CLEAN_LIST) META ocamlnet-4.0.4/INSTALL0000644000175000017500000001721312541553660013011 0ustar gerdgerdHow to install ocamlnet ocamlnet is a quite large library, and is split up into several parts. Usually, it is not necessary to install all of ocamlnet, and there are configuration options allowing you to select what you want. There is now an oasis wrapper for the (custom) configure system. So "ocaml setup.ml -configure; ocaml setup.ml -build" should also work. The following table gives a rough overview. The libraries you must build at minimum are tagged as CORE. For the other libraries the configuration option is shown that will select them for build: Library Option What it provides ---------------------------------------------------------------------- equeue CORE Event queues equeue-gtk2 -enable-gtk2 Event queues - integration into lablgtk2 equeue-tcl -enable-tcl Event queues - integration into labltk netcamlbox CORE Multiprocessing netcgi2 CORE Web applications (revised lib) netcgi2-apache -enable-apache Web applications as Apache module netcgi2-plex CORE Web applications - support for netplex netclient CORE Clients for HTTP, FTP, Telnet, POP, SMTP netgss-system -enable-gssapi GSSAPI bindings nethttpd -with-nethttpd Web server netmulticore CORE Multiprocessing netplex CORE Generic server framework netshm CORE Shared memory for IPC netstring CORE String routines (e.g. URLs, HTML, Mail) netstring-pcre -enable[-full]-pcre PCRE layer netsys CORE System interfaces missing in Unix nettls-gnutls -enable-gnutls TLS library netunidata CORE Unicode tables netzip -enable-zip read/write gzip data using object channels rpc CORE Sophisticated SunRPC/ONCRPC implementation rpc-auth-local CORE (*) SunRPC/ONCRPC - Add-on for local auth rpc-generator CORE SunRPC/ONCRPC - Stub generator rpc-xti CORE (*) SunRPC/ONCRPC - Add-on for XTI-only transports shell CORE Sophisticated version of Sys.command ---------------------------------------------------------------------- (*) If the operation system supports it List of prerequisites: Option Prerequisite Version/Where to get/What it is ---------------------------------------------------------------------- CORE findlib >= 1.0 http://www.ocaml-programming.de/packages Library manager -enable-pcre or -enable-full-pcre pcre >= 5 (pcre-ocaml) http://www.ocaml.info/ocaml_sources Regular expressions library CHANGED IN OCAMLNET-3.6.4 !!! PLEASE READ doc/html-main/Regexp.html -enanle-gnutls gnutls 2.8 or better http://www.gnutls.org -enable-gssapi gssapi Any standard-compliant GSSAPI version should do, e.g. MIT Kerberos or Heimdal -enable-gtk2 lablgtk2 probably any (*) http://wwwfun.kurims.kyoto-u.ac.jp/soft/ olabl/lablgtk.html Bindings for gtk2 GUIs -enable-tcl labltk probably any part of the O'Caml distribution Bindings for tcl/tk GUIs -enable-zip camlzip >= 1.01 http://pauillac.inria.fr/~xleroy/software.html Bindings for zlib -with-nethttpd none none Note: nethttpd must be explicitly selected because it is distributed under different license conditions than the other libraries. See the file LICENSE for more. Note: At runtime, -with-auth-dh needs further prerequisites, namely the so-called keyserv daemon. ---------------------------------------------------------------------- (*) The distribution of this prerequite does not include findlib support. It is, however, silently assumed the prerequisite library is installed in the findlib way. Sorry if this is inconvenient for you. In order to configure ocamlnet, just run the "configure" script with the mentioned options (-enable-X and -with-X). There are a few other options, as listed below. By default, the library archives are installed into the findlib default location. You can find out this location with the command ocamlfind printconf destdir For every ocamlnet library, a subdirectory is created where the files are installed. The few binary executables are installed into the directory where the ocaml compilers are installed. The data files are installed into the same directory as the netstring archives. The "configure" run shows all effective options. Option What it changes ---------------------------------------------------------------------- -bindir Binary executables are installed in -datadir Data files are installed in . Note: This directory is compiled into the netstring library, and cannot be changed at runtime. -equeue-tcl-defs Only if you have -enable-tcl: Sets options for the C compiler so the include files for tcl are found. E.g. -equeue-tcl-defs -I/usr/include/tcl8.4 -equeue-tcl-libs Only if you have -enable-tcl: Sets options for the linker so the tcl library is found. E.g. -equeue-tcl-libs -ltcl8.4 ---------------------------------------------------------------------- The directory where the library archives are installed can be changed when you run "make install", see below. After having configured ocamlnet, you can build it: make all builds the bytecode version, and make opt builds the native version (if posssible on your platform). After the build you can install ocamlnet. It is not required to become root for this, as it is sufficient that you have write privileges in all directories where files are installed. Do this with: make install At this time, you can change the location where the library archives are installed: env OCAMLFIND_DESTDIR="" make install Here, is the replacement for what is output by "ocamlfind printconf destdir". In order to uninstall ocamlnet, run make uninstall ---------------------------------------------------------------------- Special notes for distributors The build system includes a few mechanisms making life easier to build ocamlnet in package management environments. First, it is suggested to distribute ocamlnet as several packages in binary form: - ocamlnet CORE only - ocamlnet-gnutls Add-on libraries needing gnutls - ocamlnet-gssapi Add-on libraries needing GSSAPI - ocamlnet-gtk2 Add-on libraries needing gtk2 - ocamlnet-tcl Add-on libraries needing tcl - ocamlnet-zip Add-on libraries needing camlzip - ocamlnet-pcre Add-on libraries needing pcre - ocamlnet-nethttpd nethttpd (optional, if it makes the different licensing conditions clearer) Second, you can completely separate the builds of the CORE and the add-on stuff: It is possible to build the add-on stuff later, i.e. after the ocamlnet CORE is already installed. To do so, use the special configuration option -disable-core, and run "make" with these extra variables: INC_NETSYS="-package netsys" INC_NETSTRING="-package netstring" INC_EQUEUE="-package equeue" INC_NETCGI2="-package netcgi2" INC_NETCGI2_APACHE="-package netcgi2-apache" INC_NETPLEX="-package netplex" INC_NETCAMLBOX="-package netcamlbox" INC_RPC="-package rpc" INC_SHELL="-package shell" INC_NETGSSAPI="-package netgssapi" i.e. "make all" becomes make all INC_NETSYS="..." INC_NETSTRING="..." ... The effect is that the add-on libraries are built against the already installed core. Third, at installation time, it is possible to install into a local directory hierarchy. To do so, use env DESTDIR="" \ OCAMLFIND_DESTDIR="/$(ocamlfind printconf destdir)" \ make install where is the local directory. You should ensure that the direcories "/$(ocamlfind printconf destdir)", and optionally, "/$(ocamlfind printconf destdir)"/stublibs already exist. ocamlnet-4.0.4/Makefile0000644000175000017500000000531512541553660013420 0ustar gerdgerd# make all: compiles the configured packages with ocamlc # make opt: compiles the configured packages with ocamlopt # make install: installs the configured packages # make clean: cleans everything up # Inclusion of Makefile.conf may fail when cleaning up: -include Makefile.conf NAME=ocamlnet TOP_DIR=. # PKGLIST: should be set in Makefile.conf. It contains the packages to # compile and to install. The following assignment sets it to its # default value if no Makefile.conf exists. PKGLIST ?= netstring cgi .PHONY: build build: all if ocamlopt 2>/dev/null; then $(MAKE) opt; fi .PHONY: all all: tools for pkg in $(PKGLIST); do \ ( cd src/$$pkg && $(MAKE) -f Makefile.pre generate ) || exit; \ ( cd src/$$pkg && $(MAKE) -f Makefile.pre depend ) || exit; \ ( cd src/$$pkg && $(MAKE) all ) || exit; \ done .PHONY: opt opt: tools for pkg in $(PKGLIST); do \ ( cd src/$$pkg && $(MAKE) -f Makefile.pre generate ) || exit; \ ( cd src/$$pkg && $(MAKE) -f Makefile.pre depend ) || exit; \ ( cd src/$$pkg && $(MAKE) opt ) || exit; \ done .PHONY: doc doc: for pkg in src/*/.; do \ test ! -f $$pkg/Makefile -o -f $$pkg/doc-ignore || \ { ( cd $$pkg && $(MAKE) -f Makefile.pre generate ) || exit; \ ( cd $$pkg && $(MAKE) -f Makefile.pre depend ) || exit; \ ( cd $$pkg && $(MAKE) ocamldoc.dump ) || exit; \ }; \ done cd doc; $(MAKE) doc .PHONY: tools tools: ( cd tools/cppo-$(CPPO_VERSION) && $(MAKE) all ) ( cd tools/unimap_to_ocaml && $(MAKE) all ) # The following PHONY rule is important for Cygwin: .PHONY: install install: for pkg in $(PKGLIST); do \ ( cd src/$$pkg && $(MAKE) -f Makefile.pre install ) || exit; \ done .PHONY: uninstall uninstall: for pkg in src/*/.; do \ test ! -f $$pkg/Makefile || \ ( cd $$pkg && $(MAKE) -f Makefile.pre uninstall); \ done .PHONY: clean clean: for pkg in src/*/.; do \ test ! -f $$pkg/Makefile || \ ( cd $$pkg && $(MAKE) -f Makefile.pre clean); \ done if test -f doc/Makefile; then cd doc && $(MAKE) clean; fi ( cd tools/cppo-$(CPPO_VERSION) && $(MAKE) clean ) ( cd tools/unimap_to_ocaml && $(MAKE) clean ) .PHONY: clean-doc clean-doc: for pkg in src/*/.; do \ test ! -f $$pkg/Makefile -o -f $$pkg/doc-ignore || \ ( cd $$pkg && $(MAKE) -f Makefile.pre clean-doc); \ done cd doc && $(MAKE) clean-doc .PHONY: CLEAN CLEAN: clean .PHONY: distclean distclean: rm -f Makefile.conf rm -rf tmp for pkg in src/*/.; do \ test ! -f $$pkg/Makefile || \ ( cd $$pkg && $(MAKE) -f Makefile.pre distclean); \ done # That one is for oasis .PHONY: postconf postconf: cat setup.save >>setup.data # phony because VERSION may also change .PHONY: _oasis _oasis: _oasis.in v=`./configure -version`; sed -e 's/@VERSION@/'"$$v/" _oasis.in >_oasis oasis setup ocamlnet-4.0.4/setup.ml0000644000175000017500000055377212541553660013471 0ustar gerdgerd(* setup.ml generated for the first time by OASIS v0.4.4 *) (* OASIS_START *) (* DO NOT EDIT (digest: 176138732fd41551d60346d8f54784f0) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISGettext.ml" *) let ns_ str = str let s_ str = str let f_ (str: ('a, 'b, 'c, 'd) format4) = str let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" let init = [] end module OASISContext = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISContext.ml" *) open OASISGettext type level = [ `Debug | `Info | `Warning | `Error] type t = { (* TODO: replace this by a proplist. *) quiet: bool; info: bool; debug: bool; ignore_plugins: bool; ignore_unknown_fields: bool; printf: level -> string -> unit; } let printf lvl str = let beg = match lvl with | `Error -> s_ "E: " | `Warning -> s_ "W: " | `Info -> s_ "I: " | `Debug -> s_ "D: " in prerr_endline (beg^str) let default = ref { quiet = false; info = false; debug = false; ignore_plugins = false; ignore_unknown_fields = false; printf = printf; } let quiet = {!default with quiet = true} let fspecs () = (* TODO: don't act on default. *) let ignore_plugins = ref false in ["-quiet", Arg.Unit (fun () -> default := {!default with quiet = true}), s_ " Run quietly"; "-info", Arg.Unit (fun () -> default := {!default with info = true}), s_ " Display information message"; "-debug", Arg.Unit (fun () -> default := {!default with debug = true}), s_ " Output debug message"; "-ignore-plugins", Arg.Set ignore_plugins, s_ " Ignore plugin's field."; "-C", (* TODO: remove this chdir. *) Arg.String (fun str -> Sys.chdir str), s_ "dir Change directory before running."], fun () -> {!default with ignore_plugins = !ignore_plugins} end module OASISString = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISString.ml" *) (** Various string utilities. Mostly inspired by extlib and batteries ExtString and BatString libraries. @author Sylvain Le Gall *) let nsplitf str f = if str = "" then [] else let buf = Buffer.create 13 in let lst = ref [] in let push () = lst := Buffer.contents buf :: !lst; Buffer.clear buf in let str_len = String.length str in for i = 0 to str_len - 1 do if f str.[i] then push () else Buffer.add_char buf str.[i] done; push (); List.rev !lst (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the separator. *) let nsplit str c = nsplitf str ((=) c) let find ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in while !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else what_idx := 0; incr str_idx done; if !what_idx <> String.length what then raise Not_found else !str_idx - !what_idx let sub_start str len = let str_len = String.length str in if len >= str_len then "" else String.sub str len (str_len - len) let sub_end ?(offset=0) str len = let str_len = String.length str in if len >= str_len then "" else String.sub str 0 (str_len - len) let starts_with ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in let ok = ref true in while !ok && !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx else ok := false; incr str_idx done; if !what_idx = String.length what then true else false let strip_starts_with ~what str = if starts_with ~what str then sub_start str (String.length what) else raise Not_found let ends_with ~what ?(offset=0) str = let what_idx = ref ((String.length what) - 1) in let str_idx = ref ((String.length str) - 1) in let ok = ref true in while !ok && offset <= !str_idx && 0 <= !what_idx do if str.[!str_idx] = what.[!what_idx] then decr what_idx else ok := false; decr str_idx done; if !what_idx = -1 then true else false let strip_ends_with ~what str = if ends_with ~what str then sub_end str (String.length what) else raise Not_found let replace_chars f s = let buf = Buffer.create (String.length s) in String.iter (fun c -> Buffer.add_char buf (f c)) s; Buffer.contents buf end module OASISUtils = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISUtils.ml" *) open OASISGettext module MapExt = struct module type S = sig include Map.S val add_list: 'a t -> (key * 'a) list -> 'a t val of_list: (key * 'a) list -> 'a t val to_list: 'a t -> (key * 'a) list end module Make (Ord: Map.OrderedType) = struct include Map.Make(Ord) let rec add_list t = function | (k, v) :: tl -> add_list (add k v t) tl | [] -> t let of_list lst = add_list empty lst let to_list t = fold (fun k v acc -> (k, v) :: acc) t [] end end module MapString = MapExt.Make(String) module SetExt = struct module type S = sig include Set.S val add_list: t -> elt list -> t val of_list: elt list -> t val to_list: t -> elt list end module Make (Ord: Set.OrderedType) = struct include Set.Make(Ord) let rec add_list t = function | e :: tl -> add_list (add e t) tl | [] -> t let of_list lst = add_list empty lst let to_list = elements end end module SetString = SetExt.Make(String) let compare_csl s1 s2 = String.compare (String.lowercase s1) (String.lowercase s2) module HashStringCsl = Hashtbl.Make (struct type t = string let equal s1 s2 = (String.lowercase s1) = (String.lowercase s2) let hash s = Hashtbl.hash (String.lowercase s) end) module SetStringCsl = SetExt.Make (struct type t = string let compare = compare_csl end) let varname_of_string ?(hyphen='_') s = if String.length s = 0 then begin invalid_arg "varname_of_string" end else begin let buf = OASISString.replace_chars (fun c -> if ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') || ('0' <= c && c <= '9') then c else hyphen) s; in let buf = (* Start with a _ if digit *) if '0' <= s.[0] && s.[0] <= '9' then "_"^buf else buf in String.lowercase buf end let varname_concat ?(hyphen='_') p s = let what = String.make 1 hyphen in let p = try OASISString.strip_ends_with ~what p with Not_found -> p in let s = try OASISString.strip_starts_with ~what s with Not_found -> s in p^what^s let is_varname str = str = varname_of_string str let failwithf fmt = Printf.ksprintf failwith fmt end module PropList = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/PropList.ml" *) open OASISGettext type name = string exception Not_set of name * string option exception No_printer of name exception Unknown_field of name * name let () = Printexc.register_printer (function | Not_set (nm, Some rsn) -> Some (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) | Not_set (nm, None) -> Some (Printf.sprintf (f_ "Field '%s' is not set") nm) | No_printer nm -> Some (Printf.sprintf (f_ "No default printer for value %s") nm) | Unknown_field (nm, schm) -> Some (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm) | _ -> None) module Data = struct type t = (name, unit -> unit) Hashtbl.t let create () = Hashtbl.create 13 let clear t = Hashtbl.clear t (* # 78 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/PropList.ml" *) end module Schema = struct type ('ctxt, 'extra) value = { get: Data.t -> string; set: Data.t -> ?context:'ctxt -> string -> unit; help: (unit -> string) option; extra: 'extra; } type ('ctxt, 'extra) t = { name: name; fields: (name, ('ctxt, 'extra) value) Hashtbl.t; order: name Queue.t; name_norm: string -> string; } let create ?(case_insensitive=false) nm = { name = nm; fields = Hashtbl.create 13; order = Queue.create (); name_norm = (if case_insensitive then String.lowercase else fun s -> s); } let add t nm set get extra help = let key = t.name_norm nm in if Hashtbl.mem t.fields key then failwith (Printf.sprintf (f_ "Field '%s' is already defined in schema '%s'") nm t.name); Hashtbl.add t.fields key { set = set; get = get; help = help; extra = extra; }; Queue.add nm t.order let mem t nm = Hashtbl.mem t.fields nm let find t nm = try Hashtbl.find t.fields (t.name_norm nm) with Not_found -> raise (Unknown_field (nm, t.name)) let get t data nm = (find t nm).get data let set t data nm ?context x = (find t nm).set data ?context x let fold f acc t = Queue.fold (fun acc k -> let v = find t k in f acc k v.extra v.help) acc t.order let iter f t = fold (fun () -> f) () t let name t = t.name end module Field = struct type ('ctxt, 'value, 'extra) t = { set: Data.t -> ?context:'ctxt -> 'value -> unit; get: Data.t -> 'value; sets: Data.t -> ?context:'ctxt -> string -> unit; gets: Data.t -> string; help: (unit -> string) option; extra: 'extra; } let new_id = let last_id = ref 0 in fun () -> incr last_id; !last_id let create ?schema ?name ?parse ?print ?default ?update ?help extra = (* Default value container *) let v = ref None in (* If name is not given, create unique one *) let nm = match name with | Some s -> s | None -> Printf.sprintf "_anon_%d" (new_id ()) in (* Last chance to get a value: the default *) let default () = match default with | Some d -> d | None -> raise (Not_set (nm, Some (s_ "no default value"))) in (* Get data *) let get data = (* Get value *) try (Hashtbl.find data nm) (); match !v with | Some x -> x | None -> default () with Not_found -> default () in (* Set data *) let set data ?context x = let x = match update with | Some f -> begin try f ?context (get data) x with Not_set _ -> x end | None -> x in Hashtbl.replace data nm (fun () -> v := Some x) in (* Parse string value, if possible *) let parse = match parse with | Some f -> f | None -> fun ?context s -> failwith (Printf.sprintf (f_ "Cannot parse field '%s' when setting value %S") nm s) in (* Set data, from string *) let sets data ?context s = set ?context data (parse ?context s) in (* Output value as string, if possible *) let print = match print with | Some f -> f | None -> fun _ -> raise (No_printer nm) in (* Get data, as a string *) let gets data = print (get data) in begin match schema with | Some t -> Schema.add t nm sets gets extra help | None -> () end; { set = set; get = get; sets = sets; gets = gets; help = help; extra = extra; } let fset data t ?context x = t.set data ?context x let fget data t = t.get data let fsets data t ?context s = t.sets data ?context s let fgets data t = t.gets data end module FieldRO = struct let create ?schema ?name ?parse ?print ?default ?update ?help extra = let fld = Field.create ?schema ?name ?parse ?print ?default ?update ?help extra in fun data -> Field.fget data fld end end module OASISMessage = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISMessage.ml" *) open OASISGettext open OASISContext let generic_message ~ctxt lvl fmt = let cond = if ctxt.quiet then false else match lvl with | `Debug -> ctxt.debug | `Info -> ctxt.info | _ -> true in Printf.ksprintf (fun str -> if cond then begin ctxt.printf lvl str end) fmt let debug ~ctxt fmt = generic_message ~ctxt `Debug fmt let info ~ctxt fmt = generic_message ~ctxt `Info fmt let warning ~ctxt fmt = generic_message ~ctxt `Warning fmt let error ~ctxt fmt = generic_message ~ctxt `Error fmt end module OASISVersion = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISVersion.ml" *) open OASISGettext type s = string type t = string type comparator = | VGreater of t | VGreaterEqual of t | VEqual of t | VLesser of t | VLesserEqual of t | VOr of comparator * comparator | VAnd of comparator * comparator (* Range of allowed characters *) let is_digit c = '0' <= c && c <= '9' let is_alpha c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') let is_special = function | '.' | '+' | '-' | '~' -> true | _ -> false let rec version_compare v1 v2 = if v1 <> "" || v2 <> "" then begin (* Compare ascii string, using special meaning for version * related char *) let val_ascii c = if c = '~' then -1 else if is_digit c then 0 else if c = '\000' then 0 else if is_alpha c then Char.code c else (Char.code c) + 256 in let len1 = String.length v1 in let len2 = String.length v2 in let p = ref 0 in (** Compare ascii part *) let compare_vascii () = let cmp = ref 0 in while !cmp = 0 && !p < len1 && !p < len2 && not (is_digit v1.[!p] && is_digit v2.[!p]) do cmp := (val_ascii v1.[!p]) - (val_ascii v2.[!p]); incr p done; if !cmp = 0 && !p < len1 && !p = len2 then val_ascii v1.[!p] else if !cmp = 0 && !p = len1 && !p < len2 then - (val_ascii v2.[!p]) else !cmp in (** Compare digit part *) let compare_digit () = let extract_int v p = let start_p = !p in while !p < String.length v && is_digit v.[!p] do incr p done; let substr = String.sub v !p ((String.length v) - !p) in let res = match String.sub v start_p (!p - start_p) with | "" -> 0 | s -> int_of_string s in res, substr in let i1, tl1 = extract_int v1 (ref !p) in let i2, tl2 = extract_int v2 (ref !p) in i1 - i2, tl1, tl2 in match compare_vascii () with | 0 -> begin match compare_digit () with | 0, tl1, tl2 -> if tl1 <> "" && is_digit tl1.[0] then 1 else if tl2 <> "" && is_digit tl2.[0] then -1 else version_compare tl1 tl2 | n, _, _ -> n end | n -> n end else begin 0 end let version_of_string str = str let string_of_version t = t let version_compare_string s1 s2 = version_compare (version_of_string s1) (version_of_string s2) let chop t = try let pos = String.rindex t '.' in String.sub t 0 pos with Not_found -> t let rec comparator_apply v op = match op with | VGreater cv -> (version_compare v cv) > 0 | VGreaterEqual cv -> (version_compare v cv) >= 0 | VLesser cv -> (version_compare v cv) < 0 | VLesserEqual cv -> (version_compare v cv) <= 0 | VEqual cv -> (version_compare v cv) = 0 | VOr (op1, op2) -> (comparator_apply v op1) || (comparator_apply v op2) | VAnd (op1, op2) -> (comparator_apply v op1) && (comparator_apply v op2) let rec string_of_comparator = function | VGreater v -> "> "^(string_of_version v) | VEqual v -> "= "^(string_of_version v) | VLesser v -> "< "^(string_of_version v) | VGreaterEqual v -> ">= "^(string_of_version v) | VLesserEqual v -> "<= "^(string_of_version v) | VOr (c1, c2) -> (string_of_comparator c1)^" || "^(string_of_comparator c2) | VAnd (c1, c2) -> (string_of_comparator c1)^" && "^(string_of_comparator c2) let rec varname_of_comparator = let concat p v = OASISUtils.varname_concat p (OASISUtils.varname_of_string (string_of_version v)) in function | VGreater v -> concat "gt" v | VLesser v -> concat "lt" v | VEqual v -> concat "eq" v | VGreaterEqual v -> concat "ge" v | VLesserEqual v -> concat "le" v | VOr (c1, c2) -> (varname_of_comparator c1)^"_or_"^(varname_of_comparator c2) | VAnd (c1, c2) -> (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) let rec comparator_ge v' = let cmp v = version_compare v v' >= 0 in function | VEqual v | VGreaterEqual v | VGreater v -> cmp v | VLesserEqual _ | VLesser _ -> false | VOr (c1, c2) -> comparator_ge v' c1 || comparator_ge v' c2 | VAnd (c1, c2) -> comparator_ge v' c1 && comparator_ge v' c2 end module OASISLicense = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISLicense.ml" *) (** License for _oasis fields @author Sylvain Le Gall *) type license = string type license_exception = string type license_version = | Version of OASISVersion.t | VersionOrLater of OASISVersion.t | NoVersion type license_dep_5_unit = { license: license; excption: license_exception option; version: license_version; } type license_dep_5 = | DEP5Unit of license_dep_5_unit | DEP5Or of license_dep_5 list | DEP5And of license_dep_5 list type t = | DEP5License of license_dep_5 | OtherLicense of string (* URL *) end module OASISExpr = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISExpr.ml" *) open OASISGettext type test = string type flag = string type t = | EBool of bool | ENot of t | EAnd of t * t | EOr of t * t | EFlag of flag | ETest of test * string type 'a choices = (t * 'a) list let eval var_get t = let rec eval' = function | EBool b -> b | ENot e -> not (eval' e) | EAnd (e1, e2) -> (eval' e1) && (eval' e2) | EOr (e1, e2) -> (eval' e1) || (eval' e2) | EFlag nm -> let v = var_get nm in assert(v = "true" || v = "false"); (v = "true") | ETest (nm, vl) -> let v = var_get nm in (v = vl) in eval' t let choose ?printer ?name var_get lst = let rec choose_aux = function | (cond, vl) :: tl -> if eval var_get cond then vl else choose_aux tl | [] -> let str_lst = if lst = [] then s_ "" else String.concat (s_ ", ") (List.map (fun (cond, vl) -> match printer with | Some p -> p vl | None -> s_ "") lst) in match name with | Some nm -> failwith (Printf.sprintf (f_ "No result for the choice list '%s': %s") nm str_lst) | None -> failwith (Printf.sprintf (f_ "No result for a choice list: %s") str_lst) in choose_aux (List.rev lst) end module OASISText = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISText.ml" *) type elt = | Para of string | Verbatim of string | BlankLine type t = elt list end module OASISTypes = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISTypes.ml" *) type name = string type package_name = string type url = string type unix_dirname = string type unix_filename = string type host_dirname = string type host_filename = string type prog = string type arg = string type args = string list type command_line = (prog * arg list) type findlib_name = string type findlib_full = string type compiled_object = | Byte | Native | Best type dependency = | FindlibPackage of findlib_full * OASISVersion.comparator option | InternalLibrary of name type tool = | ExternalTool of name | InternalExecutable of name type vcs = | Darcs | Git | Svn | Cvs | Hg | Bzr | Arch | Monotone | OtherVCS of url type plugin_kind = [ `Configure | `Build | `Doc | `Test | `Install | `Extra ] type plugin_data_purpose = [ `Configure | `Build | `Install | `Clean | `Distclean | `Install | `Uninstall | `Test | `Doc | `Extra | `Other of string ] type 'a plugin = 'a * name * OASISVersion.t option type all_plugin = plugin_kind plugin type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list (* # 115 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISTypes.ml" *) type 'a conditional = 'a OASISExpr.choices type custom = { pre_command: (command_line option) conditional; post_command: (command_line option) conditional; } type common_section = { cs_name: name; cs_data: PropList.Data.t; cs_plugin_data: plugin_data; } type build_section = { bs_build: bool conditional; bs_install: bool conditional; bs_path: unix_dirname; bs_compiled_object: compiled_object; bs_build_depends: dependency list; bs_build_tools: tool list; bs_c_sources: unix_filename list; bs_data_files: (unix_filename * unix_filename option) list; bs_ccopt: args conditional; bs_cclib: args conditional; bs_dlllib: args conditional; bs_dllpath: args conditional; bs_byteopt: args conditional; bs_nativeopt: args conditional; } type library = { lib_modules: string list; lib_pack: bool; lib_internal_modules: string list; lib_findlib_parent: findlib_name option; lib_findlib_name: findlib_name option; lib_findlib_containers: findlib_name list; } type object_ = { obj_modules: string list; obj_findlib_fullname: findlib_name list option; } type executable = { exec_custom: bool; exec_main_is: unix_filename; } type flag = { flag_description: string option; flag_default: bool conditional; } type source_repository = { src_repo_type: vcs; src_repo_location: url; src_repo_browser: url option; src_repo_module: string option; src_repo_branch: string option; src_repo_tag: string option; src_repo_subdir: unix_filename option; } type test = { test_type: [`Test] plugin; test_command: command_line conditional; test_custom: custom; test_working_directory: unix_filename option; test_run: bool conditional; test_tools: tool list; } type doc_format = | HTML of unix_filename | DocText | PDF | PostScript | Info of unix_filename | DVI | OtherDoc type doc = { doc_type: [`Doc] plugin; doc_custom: custom; doc_build: bool conditional; doc_install: bool conditional; doc_install_dir: unix_filename; doc_title: string; doc_authors: string list; doc_abstract: string option; doc_format: doc_format; doc_data_files: (unix_filename * unix_filename option) list; doc_build_tools: tool list; } type section = | Library of common_section * build_section * library | Object of common_section * build_section * object_ | Executable of common_section * build_section * executable | Flag of common_section * flag | SrcRepo of common_section * source_repository | Test of common_section * test | Doc of common_section * doc type section_kind = [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] type package = { oasis_version: OASISVersion.t; ocaml_version: OASISVersion.comparator option; findlib_version: OASISVersion.comparator option; alpha_features: string list; beta_features: string list; name: package_name; version: OASISVersion.t; license: OASISLicense.t; license_file: unix_filename option; copyrights: string list; maintainers: string list; authors: string list; homepage: url option; synopsis: string; description: OASISText.t option; categories: url list; conf_type: [`Configure] plugin; conf_custom: custom; build_type: [`Build] plugin; build_custom: custom; install_type: [`Install] plugin; install_custom: custom; uninstall_custom: custom; clean_custom: custom; distclean_custom: custom; files_ab: unix_filename list; sections: section list; plugins: [`Extra] plugin list; disable_oasis_section: unix_filename list; schema_data: PropList.Data.t; plugin_data: plugin_data; } end module OASISFeatures = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISFeatures.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISVersion module MapPlugin = Map.Make (struct type t = plugin_kind * name let compare = Pervasives.compare end) module Data = struct type t = { oasis_version: OASISVersion.t; plugin_versions: OASISVersion.t option MapPlugin.t; alpha_features: string list; beta_features: string list; } let create oasis_version alpha_features beta_features = { oasis_version = oasis_version; plugin_versions = MapPlugin.empty; alpha_features = alpha_features; beta_features = beta_features } let of_package pkg = create pkg.OASISTypes.oasis_version pkg.OASISTypes.alpha_features pkg.OASISTypes.beta_features let add_plugin (plugin_kind, plugin_name, plugin_version) t = {t with plugin_versions = MapPlugin.add (plugin_kind, plugin_name) plugin_version t.plugin_versions} let plugin_version plugin_kind plugin_name t = MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions let to_string t = Printf.sprintf "oasis_version: %s; alpha_features: %s; beta_features: %s; \ plugins_version: %s" (OASISVersion.string_of_version t.oasis_version) (String.concat ", " t.alpha_features) (String.concat ", " t.beta_features) (String.concat ", " (MapPlugin.fold (fun (_, plg) ver_opt acc -> (plg^ (match ver_opt with | Some v -> " "^(OASISVersion.string_of_version v) | None -> "")) :: acc) t.plugin_versions [])) end type origin = | Field of string * string | Section of string | NoOrigin type stage = Alpha | Beta let string_of_stage = function | Alpha -> "alpha" | Beta -> "beta" let field_of_stage = function | Alpha -> "AlphaFeatures" | Beta -> "BetaFeatures" type publication = InDev of stage | SinceVersion of OASISVersion.t type t = { name: string; plugin: all_plugin option; publication: publication; description: unit -> string; } (* TODO: mutex protect this. *) let all_features = Hashtbl.create 13 let since_version ver_str = SinceVersion (version_of_string ver_str) let alpha = InDev Alpha let beta = InDev Beta let to_string t = Printf.sprintf "feature: %s; plugin: %s; publication: %s" t.name (match t.plugin with | None -> "" | Some (_, nm, _) -> nm) (match t.publication with | InDev stage -> string_of_stage stage | SinceVersion ver -> ">= "^(OASISVersion.string_of_version ver)) let data_check t data origin = let no_message = "no message" in let check_feature features stage = let has_feature = List.mem t.name features in if not has_feature then match origin with | Field (fld, where) -> Some (Printf.sprintf (f_ "Field %s in %s is only available when feature %s \ is in field %s.") fld where t.name (field_of_stage stage)) | Section sct -> Some (Printf.sprintf (f_ "Section %s is only available when features %s \ is in field %s.") sct t.name (field_of_stage stage)) | NoOrigin -> Some no_message else None in let version_is_good ~min_version version fmt = let version_is_good = OASISVersion.comparator_apply version (OASISVersion.VGreaterEqual min_version) in Printf.ksprintf (fun str -> if version_is_good then None else Some str) fmt in match origin, t.plugin, t.publication with | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha | _, _, InDev Beta -> check_feature data.Data.beta_features Beta | Field(fld, where), None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version (f_ "Field %s in %s is only valid since OASIS v%s, update \ OASISFormat field from '%s' to '%s' after checking \ OASIS changelog.") fld where (string_of_version min_version) (string_of_version data.Data.oasis_version) (string_of_version min_version) | Field(fld, where), Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = try match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> failwithf (f_ "Field %s in %s is only valid for the OASIS \ plugin %s since v%s, but no plugin version is \ defined in the _oasis file, change '%s' to \ '%s (%s)' in your _oasis file.") fld where plugin_name (string_of_version min_version) plugin_name plugin_name (string_of_version min_version) with Not_found -> failwithf (f_ "Field %s in %s is only valid when the OASIS plugin %s \ is defined.") fld where plugin_name in version_is_good ~min_version plugin_version_current (f_ "Field %s in %s is only valid for the OASIS plugin %s \ since v%s, update your plugin from '%s (%s)' to \ '%s (%s)' after checking the plugin's changelog.") fld where plugin_name (string_of_version min_version) plugin_name (string_of_version plugin_version_current) plugin_name (string_of_version min_version) with Failure msg -> Some msg end | Section sct, None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version (f_ "Section %s is only valid for since OASIS v%s, update \ OASISFormat field from '%s' to '%s' after checking OASIS \ changelog.") sct (string_of_version min_version) (string_of_version data.Data.oasis_version) (string_of_version min_version) | Section sct, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = try match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> failwithf (f_ "Section %s is only valid for the OASIS \ plugin %s since v%s, but no plugin version is \ defined in the _oasis file, change '%s' to \ '%s (%s)' in your _oasis file.") sct plugin_name (string_of_version min_version) plugin_name plugin_name (string_of_version min_version) with Not_found -> failwithf (f_ "Section %s is only valid when the OASIS plugin %s \ is defined.") sct plugin_name in version_is_good ~min_version plugin_version_current (f_ "Section %s is only valid for the OASIS plugin %s \ since v%s, update your plugin from '%s (%s)' to \ '%s (%s)' after checking the plugin's changelog.") sct plugin_name (string_of_version min_version) plugin_name (string_of_version plugin_version_current) plugin_name (string_of_version min_version) with Failure msg -> Some msg end | NoOrigin, None, SinceVersion min_version -> version_is_good ~min_version data.Data.oasis_version "%s" no_message | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> begin try let plugin_version_current = match Data.plugin_version plugin_knd plugin_name data with | Some ver -> ver | None -> raise Not_found in version_is_good ~min_version plugin_version_current "%s" no_message with Not_found -> Some no_message end let data_assert t data origin = match data_check t data origin with | None -> () | Some str -> failwith str let data_test t data = match data_check t data NoOrigin with | None -> true | Some str -> false let package_test t pkg = data_test t (Data.of_package pkg) let create ?plugin name publication description = let () = if Hashtbl.mem all_features name then failwithf "Feature '%s' is already declared." name in let t = { name = name; plugin = plugin; publication = publication; description = description; } in Hashtbl.add all_features name t; t let get_stage name = try (Hashtbl.find all_features name).publication with Not_found -> failwithf (f_ "Feature %s doesn't exist.") name let list () = Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] (* * Real flags. *) let features = create "features_fields" (since_version "0.4") (fun () -> s_ "Enable to experiment not yet official features.") let flag_docs = create "flag_docs" (since_version "0.3") (fun () -> s_ "Building docs require '-docs' flag at configure.") let flag_tests = create "flag_tests" (since_version "0.3") (fun () -> s_ "Running tests require '-tests' flag at configure.") let pack = create "pack" (since_version "0.3") (fun () -> s_ "Allow to create packed library.") let section_object = create "section_object" beta (fun () -> s_ "Implement an object section.") let dynrun_for_release = create "dynrun_for_release" alpha (fun () -> s_ "Make '-setup-update dynamic' suitable for releasing project.") let compiled_setup_ml = create "compiled_setup_ml" alpha (fun () -> s_ "It compiles the setup.ml and speed-up actions done with it.") let disable_oasis_section = create "disable_oasis_section" alpha (fun () -> s_ "Allows the OASIS section comments and digest to be omitted in \ generated files.") let no_automatic_syntax = create "no_automatic_syntax" alpha (fun () -> s_ "Disable the automatic inclusion of -syntax camlp4o for packages \ that matches the internal heuristic (if a dependency ends with \ a .syntax or is a well known syntax).") end module OASISUnixPath = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISUnixPath.ml" *) type unix_filename = string type unix_dirname = string type host_filename = string type host_dirname = string let current_dir_name = "." let parent_dir_name = ".." let is_current_dir fn = fn = current_dir_name || fn = "" let concat f1 f2 = if is_current_dir f1 then f2 else let f1' = try OASISString.strip_ends_with ~what:"/" f1 with Not_found -> f1 in f1'^"/"^f2 let make = function | hd :: tl -> List.fold_left (fun f p -> concat f p) hd tl | [] -> invalid_arg "OASISUnixPath.make" let dirname f = try String.sub f 0 (String.rindex f '/') with Not_found -> current_dir_name let basename f = try let pos_start = (String.rindex f '/') + 1 in String.sub f pos_start ((String.length f) - pos_start) with Not_found -> f let chop_extension f = try let last_dot = String.rindex f '.' in let sub = String.sub f 0 last_dot in try let last_slash = String.rindex f '/' in if last_slash < last_dot then sub else f with Not_found -> sub with Not_found -> f let capitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.capitalize base) let uncapitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.uncapitalize base) end module OASISHostPath = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISHostPath.ml" *) open Filename module Unix = OASISUnixPath let make = function | [] -> invalid_arg "OASISHostPath.make" | hd :: tl -> List.fold_left Filename.concat hd tl let of_unix ufn = if Sys.os_type = "Unix" then ufn else make (List.map (fun p -> if p = Unix.current_dir_name then current_dir_name else if p = Unix.parent_dir_name then parent_dir_name else p) (OASISString.nsplit ufn '/')) end module OASISSection = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISSection.ml" *) open OASISTypes let section_kind_common = function | Library (cs, _, _) -> `Library, cs | Object (cs, _, _) -> `Object, cs | Executable (cs, _, _) -> `Executable, cs | Flag (cs, _) -> `Flag, cs | SrcRepo (cs, _) -> `SrcRepo, cs | Test (cs, _) -> `Test, cs | Doc (cs, _) -> `Doc, cs let section_common sct = snd (section_kind_common sct) let section_common_set cs = function | Library (_, bs, lib) -> Library (cs, bs, lib) | Object (_, bs, obj) -> Object (cs, bs, obj) | Executable (_, bs, exec) -> Executable (cs, bs, exec) | Flag (_, flg) -> Flag (cs, flg) | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) | Test (_, tst) -> Test (cs, tst) | Doc (_, doc) -> Doc (cs, doc) (** Key used to identify section *) let section_id sct = let k, cs = section_kind_common sct in k, cs.cs_name let string_of_section sct = let k, nm = section_id sct in (match k with | `Library -> "library" | `Object -> "object" | `Executable -> "executable" | `Flag -> "flag" | `SrcRepo -> "src repository" | `Test -> "test" | `Doc -> "doc") ^" "^nm let section_find id scts = List.find (fun sct -> id = section_id sct) scts module CSection = struct type t = section let id = section_id let compare t1 t2 = compare (id t1) (id t2) let equal t1 t2 = (id t1) = (id t2) let hash t = Hashtbl.hash (id t) end module MapSection = Map.Make(CSection) module SetSection = Set.Make(CSection) end module OASISBuildSection = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISBuildSection.ml" *) end module OASISExecutable = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISExecutable.ml" *) open OASISTypes let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = let dir = OASISUnixPath.concat bs.bs_path (OASISUnixPath.dirname exec.exec_main_is) in let is_native_exec = match bs.bs_compiled_object with | Native -> true | Best -> is_native () | Byte -> false in OASISUnixPath.concat dir (cs.cs_name^(suffix_program ())), if not is_native_exec && not exec.exec_custom && bs.bs_c_sources <> [] then Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) else None end module OASISLibrary = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISLibrary.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISSection (* Look for a module file, considering capitalization or not. *) let find_module source_file_exists bs modul = let possible_base_fn = List.map (OASISUnixPath.concat bs.bs_path) [modul; OASISUnixPath.uncapitalize_file modul; OASISUnixPath.capitalize_file modul] in (* TODO: we should be able to be able to determine the source for every * files. Hence we should introduce a Module(source: fn) for the fields * Modules and InternalModules *) List.fold_left (fun acc base_fn -> match acc with | `No_sources _ -> begin let file_found = List.fold_left (fun acc ext -> if source_file_exists (base_fn^ext) then (base_fn^ext) :: acc else acc) [] [".ml"; ".mli"; ".mll"; ".mly"] in match file_found with | [] -> acc | lst -> `Sources (base_fn, lst) end | `Sources _ -> acc) (`No_sources possible_base_fn) possible_base_fn let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = List.fold_left (fun acc modul -> match find_module source_file_exists bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; acc) [] (lib.lib_modules @ lib.lib_internal_modules) let generated_unix_files ~ctxt ~is_native ~has_native_dynlink ~ext_lib ~ext_dll ~source_file_exists (cs, bs, lib) = let find_modules lst ext = let find_module modul = match find_module source_file_exists bs modul with | `Sources (base_fn, [fn]) when ext <> "cmi" && Filename.check_suffix fn ".mli" -> None (* No implementation files for pure interface. *) | `Sources (base_fn, _) -> Some [base_fn] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; Some lst in List.fold_left (fun acc nm -> match find_module nm with | None -> acc | Some base_fns -> List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) [] lst in (* The .cmx that be compiled along *) let cmxs = let should_be_built = match bs.bs_compiled_object with | Native -> true | Best -> is_native | Byte -> false in if should_be_built then if lib.lib_pack then find_modules [cs.cs_name] "cmx" else find_modules (lib.lib_modules @ lib.lib_internal_modules) "cmx" else [] in let acc_nopath = [] in (* The headers and annot/cmt files that should be compiled along *) let headers = let sufx = if lib.lib_pack then [".cmti"; ".cmt"; ".annot"] else [".cmi"; ".cmti"; ".cmt"; ".annot"] in List.map begin List.fold_left begin fun accu s -> let dot = String.rindex s '.' in let base = String.sub s 0 dot in List.map ((^) base) sufx @ accu end [] end (find_modules lib.lib_modules "cmi") in (* Compute what libraries should be built *) let acc_nopath = (* Add the packed header file if required *) let add_pack_header acc = if lib.lib_pack then [cs.cs_name^".cmi"; cs.cs_name^".cmti"; cs.cs_name^".cmt"] :: acc else acc in let byte acc = add_pack_header ([cs.cs_name^".cma"] :: acc) in let native acc = let acc = add_pack_header (if has_native_dynlink then [cs.cs_name^".cmxs"] :: acc else acc) in [cs.cs_name^".cmxa"] :: [cs.cs_name^ext_lib] :: acc in match bs.bs_compiled_object with | Native -> byte (native acc_nopath) | Best when is_native -> byte (native acc_nopath) | Byte | Best -> byte acc_nopath in (* Add C library to be built *) let acc_nopath = if bs.bs_c_sources <> [] then begin ["lib"^cs.cs_name^"_stubs"^ext_lib] :: ["dll"^cs.cs_name^"_stubs"^ext_dll] :: acc_nopath end else acc_nopath in (* All the files generated *) List.rev_append (List.rev_map (List.rev_map (OASISUnixPath.concat bs.bs_path)) acc_nopath) (headers @ cmxs) end module OASISObject = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISObject.ml" *) open OASISTypes open OASISGettext let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = List.fold_left (fun acc modul -> match OASISLibrary.find_module source_file_exists bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in object %s") modul cs.cs_name; acc) [] obj.obj_modules let generated_unix_files ~ctxt ~is_native ~source_file_exists (cs, bs, obj) = let find_module ext modul = match OASISLibrary.find_module source_file_exists bs modul with | `Sources (base_fn, _) -> [base_fn ^ ext] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in object %s") modul cs.cs_name ; lst in let header, byte, native, c_object, f = match obj.obj_modules with | [ m ] -> (find_module ".cmi" m, find_module ".cmo" m, find_module ".cmx" m, find_module ".o" m, fun x -> x) | _ -> ([cs.cs_name ^ ".cmi"], [cs.cs_name ^ ".cmo"], [cs.cs_name ^ ".cmx"], [cs.cs_name ^ ".o"], OASISUnixPath.concat bs.bs_path) in List.map (List.map f) ( match bs.bs_compiled_object with | Native -> native :: c_object :: byte :: header :: [] | Best when is_native -> native :: c_object :: byte :: header :: [] | Byte | Best -> byte :: header :: []) end module OASISFindlib = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISFindlib.ml" *) open OASISTypes open OASISUtils open OASISGettext open OASISSection type library_name = name type findlib_part_name = name type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t exception InternalLibraryNotFound of library_name exception FindlibPackageNotFound of findlib_name type group_t = | Container of findlib_name * group_t list | Package of (findlib_name * common_section * build_section * [`Library of library | `Object of object_] * group_t list) type data = common_section * build_section * [`Library of library | `Object of object_] type tree = | Node of (data option) * (tree MapString.t) | Leaf of data let findlib_mapping pkg = (* Map from library name to either full findlib name or parts + parent. *) let fndlb_parts_of_lib_name = let fndlb_parts cs lib = let name = match lib.lib_findlib_name with | Some nm -> nm | None -> cs.cs_name in let name = String.concat "." (lib.lib_findlib_containers @ [name]) in name in List.fold_left (fun mp -> function | Library (cs, _, lib) -> begin let lib_name = cs.cs_name in let fndlb_parts = fndlb_parts cs lib in if MapString.mem lib_name mp then failwithf (f_ "The library name '%s' is used more than once.") lib_name; match lib.lib_findlib_parent with | Some lib_name_parent -> MapString.add lib_name (`Unsolved (lib_name_parent, fndlb_parts)) mp | None -> MapString.add lib_name (`Solved fndlb_parts) mp end | Object (cs, _, obj) -> begin let obj_name = cs.cs_name in if MapString.mem obj_name mp then failwithf (f_ "The object name '%s' is used more than once.") obj_name; let findlib_full_name = match obj.obj_findlib_fullname with | Some ns -> String.concat "." ns | None -> obj_name in MapString.add obj_name (`Solved findlib_full_name) mp end | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> mp) MapString.empty pkg.sections in (* Solve the above graph to be only library name to full findlib name. *) let fndlb_name_of_lib_name = let rec solve visited mp lib_name lib_name_child = if SetString.mem lib_name visited then failwithf (f_ "Library '%s' is involved in a cycle \ with regard to findlib naming.") lib_name; let visited = SetString.add lib_name visited in try match MapString.find lib_name mp with | `Solved fndlb_nm -> fndlb_nm, mp | `Unsolved (lib_nm_parent, post_fndlb_nm) -> let pre_fndlb_nm, mp = solve visited mp lib_nm_parent lib_name in let fndlb_nm = pre_fndlb_nm^"."^post_fndlb_nm in fndlb_nm, MapString.add lib_name (`Solved fndlb_nm) mp with Not_found -> failwithf (f_ "Library '%s', which is defined as the findlib parent of \ library '%s', doesn't exist.") lib_name lib_name_child in let mp = MapString.fold (fun lib_name status mp -> match status with | `Solved _ -> (* Solved initialy, no need to go further *) mp | `Unsolved _ -> let _, mp = solve SetString.empty mp lib_name "" in mp) fndlb_parts_of_lib_name fndlb_parts_of_lib_name in MapString.map (function | `Solved fndlb_nm -> fndlb_nm | `Unsolved _ -> assert false) mp in (* Convert an internal library name to a findlib name. *) let findlib_name_of_library_name lib_nm = try MapString.find lib_nm fndlb_name_of_lib_name with Not_found -> raise (InternalLibraryNotFound lib_nm) in (* Add a library to the tree. *) let add sct mp = let fndlb_fullname = let cs, _, _ = sct in let lib_name = cs.cs_name in findlib_name_of_library_name lib_name in let rec add_children nm_lst (children: tree MapString.t) = match nm_lst with | (hd :: tl) -> begin let node = try add_node tl (MapString.find hd children) with Not_found -> (* New node *) new_node tl in MapString.add hd node children end | [] -> (* Should not have a nameless library. *) assert false and add_node tl node = if tl = [] then begin match node with | Node (None, children) -> Node (Some sct, children) | Leaf (cs', _, _) | Node (Some (cs', _, _), _) -> (* TODO: allow to merge Package, i.e. * archive(byte) = "foo.cma foo_init.cmo" *) let cs, _, _ = sct in failwithf (f_ "Library '%s' and '%s' have the same findlib name '%s'") cs.cs_name cs'.cs_name fndlb_fullname end else begin match node with | Leaf data -> Node (Some data, add_children tl MapString.empty) | Node (data_opt, children) -> Node (data_opt, add_children tl children) end and new_node = function | [] -> Leaf sct | hd :: tl -> Node (None, MapString.add hd (new_node tl) MapString.empty) in add_children (OASISString.nsplit fndlb_fullname '.') mp in let rec group_of_tree mp = MapString.fold (fun nm node acc -> let cur = match node with | Node (Some (cs, bs, lib), children) -> Package (nm, cs, bs, lib, group_of_tree children) | Node (None, children) -> Container (nm, group_of_tree children) | Leaf (cs, bs, lib) -> Package (nm, cs, bs, lib, []) in cur :: acc) mp [] in let group_mp = List.fold_left (fun mp -> function | Library (cs, bs, lib) -> add (cs, bs, `Library lib) mp | Object (cs, bs, obj) -> add (cs, bs, `Object obj) mp | _ -> mp) MapString.empty pkg.sections in let groups = group_of_tree group_mp in let library_name_of_findlib_name = lazy begin (* Revert findlib_name_of_library_name. *) MapString.fold (fun k v mp -> MapString.add v k mp) fndlb_name_of_lib_name MapString.empty end in let library_name_of_findlib_name fndlb_nm = try MapString.find fndlb_nm (Lazy.force library_name_of_findlib_name) with Not_found -> raise (FindlibPackageNotFound fndlb_nm) in groups, findlib_name_of_library_name, library_name_of_findlib_name let findlib_of_group = function | Container (fndlb_nm, _) | Package (fndlb_nm, _, _, _, _) -> fndlb_nm let root_of_group grp = let rec root_lib_aux = (* We do a DFS in the group. *) function | Container (_, children) -> List.fold_left (fun res grp -> if res = None then root_lib_aux grp else res) None children | Package (_, cs, bs, lib, _) -> Some (cs, bs, lib) in match root_lib_aux grp with | Some res -> res | None -> failwithf (f_ "Unable to determine root library of findlib library '%s'") (findlib_of_group grp) end module OASISFlag = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISFlag.ml" *) end module OASISPackage = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISPackage.ml" *) end module OASISSourceRepository = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISSourceRepository.ml" *) end module OASISTest = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISTest.ml" *) end module OASISDocument = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISDocument.ml" *) end module OASISExec = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISExec.ml" *) open OASISGettext open OASISUtils open OASISMessage (* TODO: I don't like this quote, it is there because $(rm) foo expands to * 'rm -f' foo... *) let run ~ctxt ?f_exit_code ?(quote=true) cmd args = let cmd = if quote then if Sys.os_type = "Win32" then if String.contains cmd ' ' then (* Double the 1st double quote... win32... sigh *) "\""^(Filename.quote cmd) else cmd else Filename.quote cmd else cmd in let cmdline = String.concat " " (cmd :: args) in info ~ctxt (f_ "Running command '%s'") cmdline; match f_exit_code, Sys.command cmdline with | None, 0 -> () | None, i -> failwithf (f_ "Command '%s' terminated with error code %d") cmdline i | Some f, i -> f i let run_read_output ~ctxt ?f_exit_code cmd args = let fn = Filename.temp_file "oasis-" ".txt" in try begin let () = run ~ctxt ?f_exit_code cmd (args @ [">"; Filename.quote fn]) in let chn = open_in fn in let routput = ref [] in begin try while true do routput := (input_line chn) :: !routput done with End_of_file -> () end; close_in chn; Sys.remove fn; List.rev !routput end with e -> (try Sys.remove fn with _ -> ()); raise e let run_read_one_line ~ctxt ?f_exit_code cmd args = match run_read_output ~ctxt ?f_exit_code cmd args with | [fst] -> fst | lst -> failwithf (f_ "Command return unexpected output %S") (String.concat "\n" lst) end module OASISFileUtil = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/oasis/OASISFileUtil.ml" *) open OASISGettext let file_exists_case fn = let dirname = Filename.dirname fn in let basename = Filename.basename fn in if Sys.file_exists dirname then if basename = Filename.current_dir_name then true else List.mem basename (Array.to_list (Sys.readdir dirname)) else false let find_file ?(case_sensitive=true) paths exts = (* Cardinal product of two list *) let ( * ) lst1 lst2 = List.flatten (List.map (fun a -> List.map (fun b -> a, b) lst2) lst1) in let rec combined_paths lst = match lst with | p1 :: p2 :: tl -> let acc = (List.map (fun (a, b) -> Filename.concat a b) (p1 * p2)) in combined_paths (acc :: tl) | [e] -> e | [] -> [] in let alternatives = List.map (fun (p, e) -> if String.length e > 0 && e.[0] <> '.' then p ^ "." ^ e else p ^ e) ((combined_paths paths) * exts) in List.find (fun file -> (if case_sensitive then file_exists_case file else Sys.file_exists file) && not (Sys.is_directory file) ) alternatives let which ~ctxt prg = let path_sep = match Sys.os_type with | "Win32" -> ';' | _ -> ':' in let path_lst = OASISString.nsplit (Sys.getenv "PATH") path_sep in let exec_ext = match Sys.os_type with | "Win32" -> "" :: (OASISString.nsplit (Sys.getenv "PATHEXT") path_sep) | _ -> [""] in find_file ~case_sensitive:false [path_lst; [prg]] exec_ext (**/**) let rec fix_dir dn = (* Windows hack because Sys.file_exists "src\\" = false when * Sys.file_exists "src" = true *) let ln = String.length dn in if Sys.os_type = "Win32" && ln > 0 && dn.[ln - 1] = '\\' then fix_dir (String.sub dn 0 (ln - 1)) else dn let q = Filename.quote (**/**) let cp ~ctxt ?(recurse=false) src tgt = if recurse then match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "xcopy" [q src; q tgt; "/E"] | _ -> OASISExec.run ~ctxt "cp" ["-r"; q src; q tgt] else OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "copy" | _ -> "cp") [q src; q tgt] let mkdir ~ctxt tgt = OASISExec.run ~ctxt (match Sys.os_type with | "Win32" -> "md" | _ -> "mkdir") [q tgt] let rec mkdir_parent ~ctxt f tgt = let tgt = fix_dir tgt in if Sys.file_exists tgt then begin if not (Sys.is_directory tgt) then OASISUtils.failwithf (f_ "Cannot create directory '%s', a file of the same name already \ exists") tgt end else begin mkdir_parent ~ctxt f (Filename.dirname tgt); if not (Sys.file_exists tgt) then begin f tgt; mkdir ~ctxt tgt end end let rmdir ~ctxt tgt = if Sys.readdir tgt = [||] then begin match Sys.os_type with | "Win32" -> OASISExec.run ~ctxt "rd" [q tgt] | _ -> OASISExec.run ~ctxt "rm" ["-r"; q tgt] end else begin OASISMessage.error ~ctxt (f_ "Cannot remove directory '%s': not empty.") tgt end let glob ~ctxt fn = let basename = Filename.basename fn in if String.length basename >= 2 && basename.[0] = '*' && basename.[1] = '.' then begin let ext_len = (String.length basename) - 2 in let ext = String.sub basename 2 ext_len in let dirname = Filename.dirname fn in Array.fold_left (fun acc fn -> try let fn_ext = String.sub fn ((String.length fn) - ext_len) ext_len in if fn_ext = ext then (Filename.concat dirname fn) :: acc else acc with Invalid_argument _ -> acc) [] (Sys.readdir dirname) end else begin if file_exists_case fn then [fn] else [] end end # 2893 "setup.ml" module BaseEnvLight = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/base/BaseEnvLight.ml" *) module MapString = Map.Make(String) type t = string MapString.t let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" let load ?(allow_empty=false) ?(filename=default_filename) () = if Sys.file_exists filename then begin let chn = open_in_bin filename in let st = Stream.of_channel chn in let line = ref 1 in let st_line = Stream.from (fun _ -> try match Stream.next st with | '\n' -> incr line; Some '\n' | c -> Some c with Stream.Failure -> None) in let lexer = Genlex.make_lexer ["="] st_line in let rec read_file mp = match Stream.npeek 3 lexer with | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> Stream.junk lexer; Stream.junk lexer; Stream.junk lexer; read_file (MapString.add nm value mp) | [] -> mp | _ -> failwith (Printf.sprintf "Malformed data file '%s' line %d" filename !line) in let mp = read_file MapString.empty in close_in chn; mp end else if allow_empty then begin MapString.empty end else begin failwith (Printf.sprintf "Unable to load environment, the file '%s' doesn't exist." filename) end let rec var_expand str env = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try var_expand (MapString.find var env) env with Not_found -> failwith (Printf.sprintf "No variable %s defined when trying to expand %S." var str)) str; Buffer.contents buff let var_get name env = var_expand (MapString.find name env) env let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) lst end # 2998 "setup.ml" module BaseContext = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/base/BaseContext.ml" *) (* TODO: get rid of this module. *) open OASISContext let args () = fst (fspecs ()) let default = default end module BaseMessage = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/base/BaseMessage.ml" *) (** Message to user, overrid for Base @author Sylvain Le Gall *) open OASISMessage open BaseContext let debug fmt = debug ~ctxt:!default fmt let info fmt = info ~ctxt:!default fmt let warning fmt = warning ~ctxt:!default fmt let error fmt = error ~ctxt:!default fmt end module BaseEnv = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils open PropList module MapString = BaseEnvLight.MapString type origin_t = | ODefault | OGetEnv | OFileLoad | OCommandLine type cli_handle_t = | CLINone | CLIAuto | CLIWith | CLIEnable | CLIUser of (Arg.key * Arg.spec * Arg.doc) list type definition_t = { hide: bool; dump: bool; cli: cli_handle_t; arg_help: string option; group: string option; } let schema = Schema.create "environment" (* Environment data *) let env = Data.create () (* Environment data from file *) let env_from_file = ref MapString.empty (* Lexer for var *) let var_lxr = Genlex.make_lexer [] let rec var_expand str = let buff = Buffer.create ((String.length str) * 2) in Buffer.add_substitute buff (fun var -> try (* TODO: this is a quick hack to allow calling Test.Command * without defining executable name really. I.e. if there is * an exec Executable toto, then $(toto) should be replace * by its real name. It is however useful to have this function * for other variable that depend on the host and should be * written better than that. *) let st = var_lxr (Stream.of_string var) in match Stream.npeek 3 st with | [Genlex.Ident "utoh"; Genlex.Ident nm] -> OASISHostPath.of_unix (var_get nm) | [Genlex.Ident "utoh"; Genlex.String s] -> OASISHostPath.of_unix s | [Genlex.Ident "ocaml_escaped"; Genlex.Ident nm] -> String.escaped (var_get nm) | [Genlex.Ident "ocaml_escaped"; Genlex.String s] -> String.escaped s | [Genlex.Ident nm] -> var_get nm | _ -> failwithf (f_ "Unknown expression '%s' in variable expansion of %s.") var str with | Unknown_field (_, _) -> failwithf (f_ "No variable %s defined when trying to expand %S.") var str | Stream.Error e -> failwithf (f_ "Syntax error when parsing '%s' when trying to \ expand %S: %s") var str e) str; Buffer.contents buff and var_get name = let vl = try Schema.get schema env name with Unknown_field _ as e -> begin try MapString.find name !env_from_file with Not_found -> raise e end in var_expand vl let var_choose ?printer ?name lst = OASISExpr.choose ?printer ?name var_get lst let var_protect vl = let buff = Buffer.create (String.length vl) in String.iter (function | '$' -> Buffer.add_string buff "\\$" | c -> Buffer.add_char buff c) vl; Buffer.contents buff let var_define ?(hide=false) ?(dump=true) ?short_desc ?(cli=CLINone) ?arg_help ?group name (* TODO: type constraint on the fact that name must be a valid OCaml id *) dflt = let default = [ OFileLoad, (fun () -> MapString.find name !env_from_file); ODefault, dflt; OGetEnv, (fun () -> Sys.getenv name); ] in let extra = { hide = hide; dump = dump; cli = cli; arg_help = arg_help; group = group; } in (* Try to find a value that can be defined *) let var_get_low lst = let errors, res = List.fold_left (fun (errors, res) (o, v) -> if res = None then begin try errors, Some (v ()) with | Not_found -> errors, res | Failure rsn -> (rsn :: errors), res | e -> (Printexc.to_string e) :: errors, res end else errors, res) ([], None) (List.sort (fun (o1, _) (o2, _) -> Pervasives.compare o2 o1) lst) in match res, errors with | Some v, _ -> v | None, [] -> raise (Not_set (name, None)) | None, lst -> raise (Not_set (name, Some (String.concat (s_ ", ") lst))) in let help = match short_desc with | Some fs -> Some fs | None -> None in let var_get_lst = FieldRO.create ~schema ~name ~parse:(fun ?(context=ODefault) s -> [context, fun () -> s]) ~print:var_get_low ~default ~update:(fun ?context x old_x -> x @ old_x) ?help extra in fun () -> var_expand (var_get_low (var_get_lst env)) let var_redefine ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt = if Schema.mem schema name then begin (* TODO: look suspsicious, we want to memorize dflt not dflt () *) Schema.set schema env ~context:ODefault name (dflt ()); fun () -> var_get name end else begin var_define ?hide ?dump ?short_desc ?cli ?arg_help ?group name dflt end let var_ignore (e: unit -> string) = () let print_hidden = var_define ~hide:true ~dump:false ~cli:CLIAuto ~arg_help:"Print even non-printable variable. (debug)" "print_hidden" (fun () -> "false") let var_all () = List.rev (Schema.fold (fun acc nm def _ -> if not def.hide || bool_of_string (print_hidden ()) then nm :: acc else acc) [] schema) let default_filename = BaseEnvLight.default_filename let load ?allow_empty ?filename () = env_from_file := BaseEnvLight.load ?allow_empty ?filename () let unload () = env_from_file := MapString.empty; Data.clear env let dump ?(filename=default_filename) () = let chn = open_out_bin filename in let output nm value = Printf.fprintf chn "%s=%S\n" nm value in let mp_todo = (* Dump data from schema *) Schema.fold (fun mp_todo nm def _ -> if def.dump then begin try let value = Schema.get schema env nm in output nm value with Not_set _ -> () end; MapString.remove nm mp_todo) !env_from_file schema in (* Dump data defined outside of schema *) MapString.iter output mp_todo; (* End of the dump *) close_out chn let print () = let printable_vars = Schema.fold (fun acc nm def short_descr_opt -> if not def.hide || bool_of_string (print_hidden ()) then begin try let value = Schema.get schema env nm in let txt = match short_descr_opt with | Some s -> s () | None -> nm in (txt, value) :: acc with Not_set _ -> acc end else acc) [] schema in let max_length = List.fold_left max 0 (List.rev_map String.length (List.rev_map fst printable_vars)) in let dot_pad str = String.make ((max_length - (String.length str)) + 3) '.' in Printf.printf "\nConfiguration: \n"; List.iter (fun (name, value) -> Printf.printf "%s: %s %s\n" name (dot_pad name) value) (List.rev printable_vars); Printf.printf "\n%!" let args () = let arg_concat = OASISUtils.varname_concat ~hyphen:'-' in [ "--override", Arg.Tuple ( let rvr = ref "" in let rvl = ref "" in [ Arg.Set_string rvr; Arg.Set_string rvl; Arg.Unit (fun () -> Schema.set schema env ~context:OCommandLine !rvr !rvl) ] ), "var+val Override any configuration variable."; ] @ List.flatten (Schema.fold (fun acc name def short_descr_opt -> let var_set s = Schema.set schema env ~context:OCommandLine name s in let arg_name = OASISUtils.varname_of_string ~hyphen:'-' name in let hlp = match short_descr_opt with | Some txt -> txt () | None -> "" in let arg_hlp = match def.arg_help with | Some s -> s | None -> "str" in let default_value = try Printf.sprintf (f_ " [%s]") (Schema.get schema env name) with Not_set _ -> "" in let args = match def.cli with | CLINone -> [] | CLIAuto -> [ arg_concat "--" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIWith -> [ arg_concat "--with-" arg_name, Arg.String var_set, Printf.sprintf (f_ "%s %s%s") arg_hlp hlp default_value ] | CLIEnable -> let dflt = if default_value = " [true]" then s_ " [default: enabled]" else s_ " [default: disabled]" in [ arg_concat "--enable-" arg_name, Arg.Unit (fun () -> var_set "true"), Printf.sprintf (f_ " %s%s") hlp dflt; arg_concat "--disable-" arg_name, Arg.Unit (fun () -> var_set "false"), Printf.sprintf (f_ " %s%s") hlp dflt ] | CLIUser lst -> lst in args :: acc) [] schema) end module BaseArgExt = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/base/BaseArgExt.ml" *) open OASISUtils open OASISGettext let parse argv args = (* Simulate command line for Arg *) let current = ref 0 in try Arg.parse_argv ~current:current (Array.concat [[|"none"|]; argv]) (Arg.align args) (failwithf (f_ "Don't know what to do with arguments: '%s'")) (s_ "configure options:") with | Arg.Help txt -> print_endline txt; exit 0 | Arg.Bad txt -> prerr_endline txt; exit 1 end module BaseCheck = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/base/BaseCheck.ml" *) open BaseEnv open BaseMessage open OASISUtils open OASISGettext let prog_best prg prg_lst = var_redefine prg (fun () -> let alternate = List.fold_left (fun res e -> match res with | Some _ -> res | None -> try Some (OASISFileUtil.which ~ctxt:!BaseContext.default e) with Not_found -> None) None prg_lst in match alternate with | Some prg -> prg | None -> raise Not_found) let prog prg = prog_best prg [prg] let prog_opt prg = prog_best prg [prg^".opt"; prg] let ocamlfind = prog "ocamlfind" let version var_prefix cmp fversion () = (* Really compare version provided *) let var = var_prefix^"_version_"^(OASISVersion.varname_of_comparator cmp) in var_redefine ~hide:true var (fun () -> let version_str = match fversion () with | "[Distributed with OCaml]" -> begin try (var_get "ocaml_version") with Not_found -> warning (f_ "Variable ocaml_version not defined, fallback \ to default"); Sys.ocaml_version end | res -> res in let version = OASISVersion.version_of_string version_str in if OASISVersion.comparator_apply version cmp then version_str else failwithf (f_ "Cannot satisfy version constraint on %s: %s (version: %s)") var_prefix (OASISVersion.string_of_comparator cmp) version_str) () let package_version pkg = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%v"; pkg] let package ?version_comparator pkg () = let var = OASISUtils.varname_concat "pkg_" (OASISUtils.varname_of_string pkg) in let findlib_dir pkg = let dir = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%d"; pkg] in if Sys.file_exists dir && Sys.is_directory dir then dir else failwithf (f_ "When looking for findlib package %s, \ directory %s return doesn't exist") pkg dir in let vl = var_redefine var (fun () -> findlib_dir pkg) () in ( match version_comparator with | Some ver_cmp -> ignore (version var ver_cmp (fun _ -> package_version pkg) ()) | None -> () ); vl end module BaseOCamlcConfig = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/base/BaseOCamlcConfig.ml" *) open BaseEnv open OASISUtils open OASISGettext module SMap = Map.Make(String) let ocamlc = BaseCheck.prog_opt "ocamlc" let ocamlc_config_map = (* Map name to value for ocamlc -config output (name ^": "^value) *) let rec split_field mp lst = match lst with | line :: tl -> let mp = try let pos_semicolon = String.index line ':' in if pos_semicolon > 1 then ( let name = String.sub line 0 pos_semicolon in let linelen = String.length line in let value = if linelen > pos_semicolon + 2 then String.sub line (pos_semicolon + 2) (linelen - pos_semicolon - 2) else "" in SMap.add name value mp ) else ( mp ) with Not_found -> ( mp ) in split_field mp tl | [] -> mp in let cache = lazy (var_protect (Marshal.to_string (split_field SMap.empty (OASISExec.run_read_output ~ctxt:!BaseContext.default (ocamlc ()) ["-config"])) [])) in var_redefine "ocamlc_config_map" ~hide:true ~dump:false (fun () -> (* TODO: update if ocamlc change !!! *) Lazy.force cache) let var_define nm = (* Extract data from ocamlc -config *) let avlbl_config_get () = Marshal.from_string (ocamlc_config_map ()) 0 in let chop_version_suffix s = try String.sub s 0 (String.index s '+') with _ -> s in let nm_config, value_config = match nm with | "ocaml_version" -> "version", chop_version_suffix | _ -> nm, (fun x -> x) in var_redefine nm (fun () -> try let map = avlbl_config_get () in let value = SMap.find nm_config map in value_config value with Not_found -> failwithf (f_ "Cannot find field '%s' in '%s -config' output") nm (ocamlc ())) end module BaseStandardVar = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/base/BaseStandardVar.ml" *) open OASISGettext open OASISTypes open OASISExpr open BaseCheck open BaseEnv let ocamlfind = BaseCheck.ocamlfind let ocamlc = BaseOCamlcConfig.ocamlc let ocamlopt = prog_opt "ocamlopt" let ocamlbuild = prog "ocamlbuild" (**/**) let rpkg = ref None let pkg_get () = match !rpkg with | Some pkg -> pkg | None -> failwith (s_ "OASIS Package is not set") let var_cond = ref [] let var_define_cond ~since_version f dflt = let holder = ref (fun () -> dflt) in let since_version = OASISVersion.VGreaterEqual (OASISVersion.version_of_string since_version) in var_cond := (fun ver -> if OASISVersion.comparator_apply ver since_version then holder := f ()) :: !var_cond; fun () -> !holder () (**/**) let pkg_name = var_define ~short_desc:(fun () -> s_ "Package name") "pkg_name" (fun () -> (pkg_get ()).name) let pkg_version = var_define ~short_desc:(fun () -> s_ "Package version") "pkg_version" (fun () -> (OASISVersion.string_of_version (pkg_get ()).version)) let c = BaseOCamlcConfig.var_define let os_type = c "os_type" let system = c "system" let architecture = c "architecture" let ccomp_type = c "ccomp_type" let ocaml_version = c "ocaml_version" (* TODO: Check standard variable presence at runtime *) let standard_library_default = c "standard_library_default" let standard_library = c "standard_library" let standard_runtime = c "standard_runtime" let bytecomp_c_compiler = c "bytecomp_c_compiler" let native_c_compiler = c "native_c_compiler" let model = c "model" let ext_obj = c "ext_obj" let ext_asm = c "ext_asm" let ext_lib = c "ext_lib" let ext_dll = c "ext_dll" let default_executable_name = c "default_executable_name" let systhread_supported = c "systhread_supported" let flexlink = BaseCheck.prog "flexlink" let flexdll_version = var_define ~short_desc:(fun () -> "FlexDLL version (Win32)") "flexdll_version" (fun () -> let lst = OASISExec.run_read_output ~ctxt:!BaseContext.default (flexlink ()) ["-help"] in match lst with | line :: _ -> Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) | [] -> raise Not_found) (**/**) let p name hlp dflt = var_define ~short_desc:hlp ~cli:CLIAuto ~arg_help:"dir" name dflt let (/) a b = if os_type () = Sys.os_type then Filename.concat a b else if os_type () = "Unix" then OASISUnixPath.concat a b else OASISUtils.failwithf (f_ "Cannot handle os_type %s filename concat") (os_type ()) (**/**) let prefix = p "prefix" (fun () -> s_ "Install architecture-independent files dir") (fun () -> match os_type () with | "Win32" -> let program_files = Sys.getenv "PROGRAMFILES" in program_files/(pkg_name ()) | _ -> "/usr/local") let exec_prefix = p "exec_prefix" (fun () -> s_ "Install architecture-dependent files in dir") (fun () -> "$prefix") let bindir = p "bindir" (fun () -> s_ "User executables") (fun () -> "$exec_prefix"/"bin") let sbindir = p "sbindir" (fun () -> s_ "System admin executables") (fun () -> "$exec_prefix"/"sbin") let libexecdir = p "libexecdir" (fun () -> s_ "Program executables") (fun () -> "$exec_prefix"/"libexec") let sysconfdir = p "sysconfdir" (fun () -> s_ "Read-only single-machine data") (fun () -> "$prefix"/"etc") let sharedstatedir = p "sharedstatedir" (fun () -> s_ "Modifiable architecture-independent data") (fun () -> "$prefix"/"com") let localstatedir = p "localstatedir" (fun () -> s_ "Modifiable single-machine data") (fun () -> "$prefix"/"var") let libdir = p "libdir" (fun () -> s_ "Object code libraries") (fun () -> "$exec_prefix"/"lib") let datarootdir = p "datarootdir" (fun () -> s_ "Read-only arch-independent data root") (fun () -> "$prefix"/"share") let datadir = p "datadir" (fun () -> s_ "Read-only architecture-independent data") (fun () -> "$datarootdir") let infodir = p "infodir" (fun () -> s_ "Info documentation") (fun () -> "$datarootdir"/"info") let localedir = p "localedir" (fun () -> s_ "Locale-dependent data") (fun () -> "$datarootdir"/"locale") let mandir = p "mandir" (fun () -> s_ "Man documentation") (fun () -> "$datarootdir"/"man") let docdir = p "docdir" (fun () -> s_ "Documentation root") (fun () -> "$datarootdir"/"doc"/"$pkg_name") let htmldir = p "htmldir" (fun () -> s_ "HTML documentation") (fun () -> "$docdir") let dvidir = p "dvidir" (fun () -> s_ "DVI documentation") (fun () -> "$docdir") let pdfdir = p "pdfdir" (fun () -> s_ "PDF documentation") (fun () -> "$docdir") let psdir = p "psdir" (fun () -> s_ "PS documentation") (fun () -> "$docdir") let destdir = p "destdir" (fun () -> s_ "Prepend a path when installing package") (fun () -> raise (PropList.Not_set ("destdir", Some (s_ "undefined by construct")))) let findlib_version = var_define "findlib_version" (fun () -> BaseCheck.package_version "findlib") let is_native = var_define "is_native" (fun () -> try let _s: string = ocamlopt () in "true" with PropList.Not_set _ -> let _s: string = ocamlc () in "false") let ext_program = var_define "suffix_program" (fun () -> match os_type () with | "Win32" | "Cygwin" -> ".exe" | _ -> "") let rm = var_define ~short_desc:(fun () -> s_ "Remove a file.") "rm" (fun () -> match os_type () with | "Win32" -> "del" | _ -> "rm -f") let rmdir = var_define ~short_desc:(fun () -> s_ "Remove a directory.") "rmdir" (fun () -> match os_type () with | "Win32" -> "rd" | _ -> "rm -rf") let debug = var_define ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") ~cli:CLIEnable "debug" (fun () -> "true") let profile = var_define ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") ~cli:CLIEnable "profile" (fun () -> "false") let tests = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Compile tests executable and library and run them") ~cli:CLIEnable "tests" (fun () -> "false")) "true" let docs = var_define_cond ~since_version:"0.3" (fun () -> var_define ~short_desc:(fun () -> s_ "Create documentations") ~cli:CLIEnable "docs" (fun () -> "true")) "true" let native_dynlink = var_define ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") ~cli:CLINone "native_dynlink" (fun () -> let res = let ocaml_lt_312 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (ocaml_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "3.12.0")) in let flexdll_lt_030 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (flexdll_version ())) (OASISVersion.VLesser (OASISVersion.version_of_string "0.30")) in let has_native_dynlink = let ocamlfind = ocamlfind () in try let fn = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ocamlfind ["query"; "-predicates"; "native"; "dynlink"; "-format"; "%d/%a"] in Sys.file_exists fn with _ -> false in if not has_native_dynlink then false else if ocaml_lt_312 () then false else if (os_type () = "Win32" || os_type () = "Cygwin") && flexdll_lt_030 () then begin BaseMessage.warning (f_ ".cmxs generation disabled because FlexDLL needs to be \ at least 0.30. Please upgrade FlexDLL from %s to 0.30.") (flexdll_version ()); false end else true in string_of_bool res) let init pkg = rpkg := Some pkg; List.iter (fun f -> f pkg.oasis_version) !var_cond end module BaseFileAB = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/base/BaseFileAB.ml" *) open BaseEnv open OASISGettext open BaseMessage let to_filename fn = let fn = OASISHostPath.of_unix fn in if not (Filename.check_suffix fn ".ab") then warning (f_ "File '%s' doesn't have '.ab' extension") fn; Filename.chop_extension fn let replace fn_lst = let buff = Buffer.create 13 in List.iter (fun fn -> let fn = OASISHostPath.of_unix fn in let chn_in = open_in fn in let chn_out = open_out (to_filename fn) in ( try while true do Buffer.add_string buff (var_expand (input_line chn_in)); Buffer.add_char buff '\n' done with End_of_file -> () ); Buffer.output_buffer chn_out buff; Buffer.clear buff; close_in chn_in; close_out chn_out) fn_lst end module BaseLog = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/base/BaseLog.ml" *) open OASISUtils let default_filename = Filename.concat (Filename.dirname BaseEnv.default_filename) "setup.log" module SetTupleString = Set.Make (struct type t = string * string let compare (s11, s12) (s21, s22) = match String.compare s11 s21 with | 0 -> String.compare s12 s22 | n -> n end) let load () = if Sys.file_exists default_filename then begin let chn = open_in default_filename in let scbuf = Scanf.Scanning.from_file default_filename in let rec read_aux (st, lst) = if not (Scanf.Scanning.end_of_input scbuf) then begin let acc = try Scanf.bscanf scbuf "%S %S\n" (fun e d -> let t = e, d in if SetTupleString.mem t st then st, lst else SetTupleString.add t st, t :: lst) with Scanf.Scan_failure _ -> failwith (Scanf.bscanf scbuf "%l" (fun line -> Printf.sprintf "Malformed log file '%s' at line %d" default_filename line)) in read_aux acc end else begin close_in chn; List.rev lst end in read_aux (SetTupleString.empty, []) end else begin [] end let register event data = let chn_out = open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename in Printf.fprintf chn_out "%S %S\n" event data; close_out chn_out let unregister event data = if Sys.file_exists default_filename then begin let lst = load () in let chn_out = open_out default_filename in let write_something = ref false in List.iter (fun (e, d) -> if e <> event || d <> data then begin write_something := true; Printf.fprintf chn_out "%S %S\n" e d end) lst; close_out chn_out; if not !write_something then Sys.remove default_filename end let filter events = let st_events = List.fold_left (fun st e -> SetString.add e st) SetString.empty events in List.filter (fun (e, _) -> SetString.mem e st_events) (load ()) let exists event data = List.exists (fun v -> (event, data) = v) (load ()) end module BaseBuilt = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/base/BaseBuilt.ml" *) open OASISTypes open OASISGettext open BaseStandardVar open BaseMessage type t = | BExec (* Executable *) | BExecLib (* Library coming with executable *) | BLib (* Library *) | BObj (* Library *) | BDoc (* Document *) let to_log_event_file t nm = "built_"^ (match t with | BExec -> "exec" | BExecLib -> "exec_lib" | BLib -> "lib" | BObj -> "obj" | BDoc -> "doc")^ "_"^nm let to_log_event_done t nm = "is_"^(to_log_event_file t nm) let register t nm lst = BaseLog.register (to_log_event_done t nm) "true"; List.iter (fun alt -> let registered = List.fold_left (fun registered fn -> if OASISFileUtil.file_exists_case fn then begin BaseLog.register (to_log_event_file t nm) (if Filename.is_relative fn then Filename.concat (Sys.getcwd ()) fn else fn); true end else registered) false alt in if not registered then warning (f_ "Cannot find an existing alternative files among: %s") (String.concat (s_ ", ") alt)) lst let unregister t nm = List.iter (fun (e, d) -> BaseLog.unregister e d) (BaseLog.filter [to_log_event_file t nm; to_log_event_done t nm]) let fold t nm f acc = List.fold_left (fun acc (_, fn) -> if OASISFileUtil.file_exists_case fn then begin f acc fn end else begin warning (f_ "File '%s' has been marked as built \ for %s but doesn't exist") fn (Printf.sprintf (match t with | BExec | BExecLib -> (f_ "executable %s") | BLib -> (f_ "library %s") | BObj -> (f_ "object %s") | BDoc -> (f_ "documentation %s")) nm); acc end) acc (BaseLog.filter [to_log_event_file t nm]) let is_built t nm = List.fold_left (fun is_built (_, d) -> (try bool_of_string d with _ -> false)) false (BaseLog.filter [to_log_event_done t nm]) let of_executable ffn (cs, bs, exec) = let unix_exec_is, unix_dll_opt = OASISExecutable.unix_exec_is (cs, bs, exec) (fun () -> bool_of_string (is_native ())) ext_dll ext_program in let evs = (BExec, cs.cs_name, [[ffn unix_exec_is]]) :: (match unix_dll_opt with | Some fn -> [BExecLib, cs.cs_name, [[ffn fn]]] | None -> []) in evs, unix_exec_is, unix_dll_opt let of_library ffn (cs, bs, lib) = let unix_lst = OASISLibrary.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) ~has_native_dynlink:(bool_of_string (native_dynlink ())) ~ext_lib:(ext_lib ()) ~ext_dll:(ext_dll ()) (cs, bs, lib) in let evs = [BLib, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst let of_object ffn (cs, bs, obj) = let unix_lst = OASISObject.generated_unix_files ~ctxt:!BaseContext.default ~source_file_exists:(fun fn -> OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) ~is_native:(bool_of_string (is_native ())) (cs, bs, obj) in let evs = [BObj, cs.cs_name, List.map (List.map ffn) unix_lst] in evs, unix_lst end module BaseCustom = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/base/BaseCustom.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let run cmd args extra_args = OASISExec.run ~ctxt:!BaseContext.default ~quote:false (var_expand cmd) (List.map var_expand (args @ (Array.to_list extra_args))) let hook ?(failsafe=false) cstm f e = let optional_command lst = let printer = function | Some (cmd, args) -> String.concat " " (cmd :: args) | None -> s_ "No command" in match var_choose ~name:(s_ "Pre/Post Command") ~printer lst with | Some (cmd, args) -> begin try run cmd args [||] with e when failsafe -> warning (f_ "Command '%s' fail with error: %s") (String.concat " " (cmd :: args)) (match e with | Failure msg -> msg | e -> Printexc.to_string e) end | None -> () in let res = optional_command cstm.pre_command; f e in optional_command cstm.post_command; res end module BaseDynVar = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/base/BaseDynVar.ml" *) open OASISTypes open OASISGettext open BaseEnv open BaseBuilt let init pkg = (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) (* TODO: provide compile option for library libary_byte_args_VARNAME... *) List.iter (function | Executable (cs, bs, exec) -> if var_choose bs.bs_build then var_ignore (var_redefine (* We don't save this variable *) ~dump:false ~short_desc:(fun () -> Printf.sprintf (f_ "Filename of executable '%s'") cs.cs_name) (OASISUtils.varname_of_string cs.cs_name) (fun () -> let fn_opt = fold BExec cs.cs_name (fun _ fn -> Some fn) None in match fn_opt with | Some fn -> fn | None -> raise (PropList.Not_set (cs.cs_name, Some (Printf.sprintf (f_ "Executable '%s' not yet built.") cs.cs_name))))) | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> ()) pkg.sections end module BaseTest = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/base/BaseTest.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISExpr open OASISGettext let test lst pkg extra_args = let one_test (failure, n) (test_plugin, cs, test) = if var_choose ~name:(Printf.sprintf (f_ "test %s run") cs.cs_name) ~printer:string_of_bool test.test_run then begin let () = info (f_ "Running test '%s'") cs.cs_name in let back_cwd = match test.test_working_directory with | Some dir -> let cwd = Sys.getcwd () in let chdir d = info (f_ "Changing directory to '%s'") d; Sys.chdir d in chdir dir; fun () -> chdir cwd | None -> fun () -> () in try let failure_percent = BaseCustom.hook test.test_custom (test_plugin pkg (cs, test)) extra_args in back_cwd (); (failure_percent +. failure, n + 1) with e -> begin back_cwd (); raise e end end else begin info (f_ "Skipping test '%s'") cs.cs_name; (failure, n) end in let failed, n = List.fold_left one_test (0.0, 0) lst in let failure_percent = if n = 0 then 0.0 else failed /. (float_of_int n) in let msg = Printf.sprintf (f_ "Tests had a %.2f%% failure rate") (100. *. failure_percent) in if failure_percent > 0.0 then failwith msg else info "%s" msg; (* Possible explanation why the tests where not run. *) if OASISFeatures.package_test OASISFeatures.flag_tests pkg && not (bool_of_string (BaseStandardVar.tests ())) && lst <> [] then BaseMessage.warning "Tests are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-tests'" end module BaseDoc = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/base/BaseDoc.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISGettext let doc lst pkg extra_args = let one_doc (doc_plugin, cs, doc) = if var_choose ~name:(Printf.sprintf (f_ "documentation %s build") cs.cs_name) ~printer:string_of_bool doc.doc_build then begin info (f_ "Building documentation '%s'") cs.cs_name; BaseCustom.hook doc.doc_custom (doc_plugin pkg (cs, doc)) extra_args end in List.iter one_doc lst; if OASISFeatures.package_test OASISFeatures.flag_docs pkg && not (bool_of_string (BaseStandardVar.docs ())) && lst <> [] then BaseMessage.warning "Docs are turned off, consider enabling with \ 'ocaml setup.ml -configure --enable-docs'" end module BaseSetup = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage open OASISTypes open OASISSection open OASISGettext open OASISUtils type std_args_fun = package -> string array -> unit type ('a, 'b) section_args_fun = name * (package -> (common_section * 'a) -> string array -> 'b) type t = { configure: std_args_fun; build: std_args_fun; doc: ((doc, unit) section_args_fun) list; test: ((test, float) section_args_fun) list; install: std_args_fun; uninstall: std_args_fun; clean: std_args_fun list; clean_doc: (doc, unit) section_args_fun list; clean_test: (test, unit) section_args_fun list; distclean: std_args_fun list; distclean_doc: (doc, unit) section_args_fun list; distclean_test: (test, unit) section_args_fun list; package: package; oasis_fn: string option; oasis_version: string; oasis_digest: Digest.t option; oasis_exec: string option; oasis_setup_args: string list; setup_update: bool; } (* Associate a plugin function with data from package *) let join_plugin_sections filter_map lst = List.rev (List.fold_left (fun acc sct -> match filter_map sct with | Some e -> e :: acc | None -> acc) [] lst) (* Search for plugin data associated with a section name *) let lookup_plugin_section plugin action nm lst = try List.assoc nm lst with Not_found -> failwithf (f_ "Cannot find plugin %s matching section %s for %s action") plugin nm action let configure t args = (* Run configure *) BaseCustom.hook t.package.conf_custom (fun () -> (* Reload if preconf has changed it *) begin try unload (); load (); with _ -> () end; (* Run plugin's configure *) t.configure t.package args; (* Dump to allow postconf to change it *) dump ()) (); (* Reload environment *) unload (); load (); (* Save environment *) print (); (* Replace data in file *) BaseFileAB.replace t.package.files_ab let build t args = BaseCustom.hook t.package.build_custom (t.build t.package) args let doc t args = BaseDoc.doc (join_plugin_sections (function | Doc (cs, e) -> Some (lookup_plugin_section "documentation" (s_ "build") cs.cs_name t.doc, cs, e) | _ -> None) t.package.sections) t.package args let test t args = BaseTest.test (join_plugin_sections (function | Test (cs, e) -> Some (lookup_plugin_section "test" (s_ "run") cs.cs_name t.test, cs, e) | _ -> None) t.package.sections) t.package args let all t args = let rno_doc = ref false in let rno_test = ref false in let arg_rest = ref [] in Arg.parse_argv ~current:(ref 0) (Array.of_list ((Sys.executable_name^" all") :: (Array.to_list args))) [ "-no-doc", Arg.Set rno_doc, s_ "Don't run doc target"; "-no-test", Arg.Set rno_test, s_ "Don't run test target"; "--", Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), s_ "All arguments for configure."; ] (failwithf (f_ "Don't know what to do with '%s'")) ""; info "Running configure step"; configure t (Array.of_list (List.rev !arg_rest)); info "Running build step"; build t [||]; (* Load setup.log dynamic variables *) BaseDynVar.init t.package; if not !rno_doc then begin info "Running doc step"; doc t [||]; end else begin info "Skipping doc step" end; if not !rno_test then begin info "Running test step"; test t [||] end else begin info "Skipping test step" end let install t args = BaseCustom.hook t.package.install_custom (t.install t.package) args let uninstall t args = BaseCustom.hook t.package.uninstall_custom (t.uninstall t.package) args let reinstall t args = uninstall t args; install t args let clean, distclean = let failsafe f a = try f a with e -> warning (f_ "Action fail with error: %s") (match e with | Failure msg -> msg | e -> Printexc.to_string e) in let generic_clean t cstm mains docs tests args = BaseCustom.hook ~failsafe:true cstm (fun () -> (* Clean section *) List.iter (function | Test (cs, test) -> let f = try List.assoc cs.cs_name tests with Not_found -> fun _ _ _ -> () in failsafe (f t.package (cs, test)) args | Doc (cs, doc) -> let f = try List.assoc cs.cs_name docs with Not_found -> fun _ _ _ -> () in failsafe (f t.package (cs, doc)) args | Library _ | Object _ | Executable _ | Flag _ | SrcRepo _ -> ()) t.package.sections; (* Clean whole package *) List.iter (fun f -> failsafe (f t.package) args) mains) () in let clean t args = generic_clean t t.package.clean_custom t.clean t.clean_doc t.clean_test args in let distclean t args = (* Call clean *) clean t args; (* Call distclean code *) generic_clean t t.package.distclean_custom t.distclean t.distclean_doc t.distclean_test args; (* Remove generated file *) List.iter (fun fn -> if Sys.file_exists fn then begin info (f_ "Remove '%s'") fn; Sys.remove fn end) (BaseEnv.default_filename :: BaseLog.default_filename :: (List.rev_map BaseFileAB.to_filename t.package.files_ab)) in clean, distclean let version t _ = print_endline t.oasis_version let update_setup_ml, no_update_setup_ml_cli = let b = ref true in b, ("-no-update-setup-ml", Arg.Clear b, s_ " Don't try to update setup.ml, even if _oasis has changed.") let default_oasis_fn = "_oasis" let update_setup_ml t = let oasis_fn = match t.oasis_fn with | Some fn -> fn | None -> default_oasis_fn in let oasis_exec = match t.oasis_exec with | Some fn -> fn | None -> "oasis" in let ocaml = Sys.executable_name in let setup_ml, args = match Array.to_list Sys.argv with | setup_ml :: args -> setup_ml, args | [] -> failwith (s_ "Expecting non-empty command line arguments.") in let ocaml, setup_ml = if Sys.executable_name = Sys.argv.(0) then (* We are not running in standard mode, probably the script * is precompiled. *) "ocaml", "setup.ml" else ocaml, setup_ml in let no_update_setup_ml_cli, _, _ = no_update_setup_ml_cli in let do_update () = let oasis_exec_version = OASISExec.run_read_one_line ~ctxt:!BaseContext.default ~f_exit_code: (function | 0 -> () | 1 -> failwithf (f_ "Executable '%s' is probably an old version \ of oasis (< 0.3.0), please update to version \ v%s.") oasis_exec t.oasis_version | 127 -> failwithf (f_ "Cannot find executable '%s', please install \ oasis v%s.") oasis_exec t.oasis_version | n -> failwithf (f_ "Command '%s version' exited with code %d.") oasis_exec n) oasis_exec ["version"] in if OASISVersion.comparator_apply (OASISVersion.version_of_string oasis_exec_version) (OASISVersion.VGreaterEqual (OASISVersion.version_of_string t.oasis_version)) then begin (* We have a version >= for the executable oasis, proceed with * update. *) (* TODO: delegate this check to 'oasis setup'. *) if Sys.os_type = "Win32" then failwithf (f_ "It is not possible to update the running script \ setup.ml on Windows. Please update setup.ml by \ running '%s'.") (String.concat " " (oasis_exec :: "setup" :: t.oasis_setup_args)) else begin OASISExec.run ~ctxt:!BaseContext.default ~f_exit_code: (function | 0 -> () | n -> failwithf (f_ "Unable to update setup.ml using '%s', \ please fix the problem and retry.") oasis_exec) oasis_exec ("setup" :: t.oasis_setup_args); OASISExec.run ~ctxt:!BaseContext.default ocaml (setup_ml :: args) end end else failwithf (f_ "The version of '%s' (v%s) doesn't match the version of \ oasis used to generate the %s file. Please install at \ least oasis v%s.") oasis_exec oasis_exec_version setup_ml t.oasis_version in if !update_setup_ml then begin try match t.oasis_digest with | Some dgst -> if Sys.file_exists oasis_fn && dgst <> Digest.file default_oasis_fn then begin do_update (); true end else false | None -> false with e -> error (f_ "Error when updating setup.ml. If you want to avoid this error, \ you can bypass the update of %s by running '%s %s %s %s'") setup_ml ocaml setup_ml no_update_setup_ml_cli (String.concat " " args); raise e end else false let setup t = let catch_exn = ref true in try let act_ref = ref (fun _ -> failwithf (f_ "No action defined, run '%s %s -help'") Sys.executable_name Sys.argv.(0)) in let extra_args_ref = ref [] in let allow_empty_env_ref = ref false in let arg_handle ?(allow_empty_env=false) act = Arg.Tuple [ Arg.Rest (fun str -> extra_args_ref := str :: !extra_args_ref); Arg.Unit (fun () -> allow_empty_env_ref := allow_empty_env; act_ref := act); ] in Arg.parse (Arg.align ([ "-configure", arg_handle ~allow_empty_env:true configure, s_ "[options*] Configure the whole build process."; "-build", arg_handle build, s_ "[options*] Build executables and libraries."; "-doc", arg_handle doc, s_ "[options*] Build documents."; "-test", arg_handle test, s_ "[options*] Run tests."; "-all", arg_handle ~allow_empty_env:true all, s_ "[options*] Run configure, build, doc and test targets."; "-install", arg_handle install, s_ "[options*] Install libraries, data, executables \ and documents."; "-uninstall", arg_handle uninstall, s_ "[options*] Uninstall libraries, data, executables \ and documents."; "-reinstall", arg_handle reinstall, s_ "[options*] Uninstall and install libraries, data, \ executables and documents."; "-clean", arg_handle ~allow_empty_env:true clean, s_ "[options*] Clean files generated by a build."; "-distclean", arg_handle ~allow_empty_env:true distclean, s_ "[options*] Clean files generated by a build and configure."; "-version", arg_handle ~allow_empty_env:true version, s_ " Display version of OASIS used to generate this setup.ml."; "-no-catch-exn", Arg.Clear catch_exn, s_ " Don't catch exception, useful for debugging."; ] @ (if t.setup_update then [no_update_setup_ml_cli] else []) @ (BaseContext.args ()))) (failwithf (f_ "Don't know what to do with '%s'")) (s_ "Setup and run build process current package\n"); (* Build initial environment *) load ~allow_empty:!allow_empty_env_ref (); (** Initialize flags *) List.iter (function | Flag (cs, {flag_description = hlp; flag_default = choices}) -> begin let apply ?short_desc () = var_ignore (var_define ~cli:CLIEnable ?short_desc (OASISUtils.varname_of_string cs.cs_name) (fun () -> string_of_bool (var_choose ~name:(Printf.sprintf (f_ "default value of flag %s") cs.cs_name) ~printer:string_of_bool choices))) in match hlp with | Some hlp -> apply ~short_desc:(fun () -> hlp) () | None -> apply () end | _ -> ()) t.package.sections; BaseStandardVar.init t.package; BaseDynVar.init t.package; if t.setup_update && update_setup_ml t then () else !act_ref t (Array.of_list (List.rev !extra_args_ref)) with e when !catch_exn -> error "%s" (Printexc.to_string e); exit 1 end # 5409 "setup.ml" module CustomPlugin = struct (* # 22 "/data/netsoft/debian7_amd64/godi-4.01/build/apps/apps-oasis/work/oasis-0.4.5/src/plugins/custom/CustomPlugin.ml" *) (** Generate custom configure/build/doc/test/install system @author *) open BaseEnv open OASISGettext open OASISTypes type t = { cmd_main: command_line conditional; cmd_clean: (command_line option) conditional; cmd_distclean: (command_line option) conditional; } let run = BaseCustom.run let main t _ extra_args = let cmd, args = var_choose ~name:(s_ "main command") t.cmd_main in run cmd args extra_args let clean t pkg extra_args = match var_choose t.cmd_clean with | Some (cmd, args) -> run cmd args extra_args | _ -> () let distclean t pkg extra_args = match var_choose t.cmd_distclean with | Some (cmd, args) -> run cmd args extra_args | _ -> () module Build = struct let main t pkg extra_args = main t pkg extra_args; List.iter (fun sct -> let evs = match sct with | Library (cs, bs, lib) when var_choose bs.bs_build -> begin let evs, _ = BaseBuilt.of_library OASISHostPath.of_unix (cs, bs, lib) in evs end | Executable (cs, bs, exec) when var_choose bs.bs_build -> begin let evs, _, _ = BaseBuilt.of_executable OASISHostPath.of_unix (cs, bs, exec) in evs end | _ -> [] in List.iter (fun (bt, bnm, lst) -> BaseBuilt.register bt bnm lst) evs) pkg.sections let clean t pkg extra_args = clean t pkg extra_args; (* TODO: this seems to be pretty generic (at least wrt to ocamlbuild * considering moving this to BaseSetup? *) List.iter (function | Library (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BLib cs.cs_name | Executable (cs, _, _) -> BaseBuilt.unregister BaseBuilt.BExec cs.cs_name; BaseBuilt.unregister BaseBuilt.BExecLib cs.cs_name | _ -> ()) pkg.sections let distclean t pkg extra_args = distclean t pkg extra_args end module Test = struct let main t pkg (cs, test) extra_args = try main t pkg extra_args; 0.0 with Failure s -> BaseMessage.warning (f_ "Test '%s' fails: %s") cs.cs_name s; 1.0 let clean t pkg (cs, test) extra_args = clean t pkg extra_args let distclean t pkg (cs, test) extra_args = distclean t pkg extra_args end module Doc = struct let main t pkg (cs, _) extra_args = main t pkg extra_args; BaseBuilt.register BaseBuilt.BDoc cs.cs_name [] let clean t pkg (cs, _) extra_args = clean t pkg extra_args; BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name let distclean t pkg (cs, _) extra_args = distclean t pkg extra_args end end # 5557 "setup.ml" open OASISTypes;; let setup_t = { BaseSetup.configure = CustomPlugin.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("./configure", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; build = CustomPlugin.Build.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("make", ["build"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; test = []; doc = []; install = CustomPlugin.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("make", ["install"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; uninstall = CustomPlugin.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("make", ["uninstall"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; clean = [ CustomPlugin.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("./configure", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; CustomPlugin.Build.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("make", ["build"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; CustomPlugin.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("make", ["install"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; CustomPlugin.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("make", ["uninstall"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] } ]; clean_test = []; clean_doc = []; distclean = [ CustomPlugin.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("./configure", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; CustomPlugin.Build.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("make", ["build"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; CustomPlugin.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("make", ["install"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] }; CustomPlugin.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("make", ["uninstall"]))]; cmd_clean = [(OASISExpr.EBool true, None)]; cmd_distclean = [(OASISExpr.EBool true, None)] } ]; distclean_test = []; distclean_doc = []; package = { oasis_version = "0.4"; ocaml_version = Some (OASISVersion.VGreaterEqual "4.00.0"); findlib_version = None; alpha_features = []; beta_features = []; name = "ocamlnet"; version = "4.0.4"; license = OASISLicense.OtherLicense "http://download.camlcity.org/download/licenses/ocamlnet"; license_file = None; copyrights = []; maintainers = []; authors = ["Gerd Stolpmann et al."]; homepage = Some "http://projects.camlcity.org/projects/ocamlnet"; synopsis = "Internet protocols and helper data structures"; description = None; categories = []; conf_type = (`Configure, "custom", Some "0.4"); conf_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, Some (("make", ["-s"; "postconf"]))) ] }; build_type = (`Build, "custom", Some "0.4"); build_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; install_type = (`Install, "custom", Some "0.4"); install_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; uninstall_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; clean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; distclean_custom = { pre_command = [(OASISExpr.EBool true, None)]; post_command = [(OASISExpr.EBool true, None)] }; files_ab = []; sections = [ Flag ({ cs_name = "gtk2"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "gtk2: Support for gtk2 event loops"; flag_default = [(OASISExpr.EBool true, false)] }); Flag ({ cs_name = "tcl"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "tcl: Support for Tcl/Tk event loops"; flag_default = [(OASISExpr.EBool true, false)] }); Flag ({ cs_name = "zlib"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "zlib: Support for compression"; flag_default = [(OASISExpr.EBool true, false)] }); Flag ({ cs_name = "apache"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "apache: Build the Apache module"; flag_default = [(OASISExpr.EBool true, false)] }); Flag ({ cs_name = "gnutls"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "gnutls: Enable (Gnu) TLS"; flag_default = [(OASISExpr.EBool true, false)] }); Flag ({ cs_name = "gssapi"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "gssapi: Enable GSSAPI"; flag_default = [(OASISExpr.EBool true, false)] }); Flag ({ cs_name = "pcre"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "pcre: Build netstring-pcre library"; flag_default = [(OASISExpr.EBool true, false)] }); Flag ({ cs_name = "full_pcre"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "full_pcre: Use pcre for all regular expressions"; flag_default = [(OASISExpr.EBool true, false)] }); Flag ({ cs_name = "nethttpd"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { flag_description = Some "nethttpd: Build the webserver nethttpd"; flag_default = [(OASISExpr.EBool true, false)] }); Library ({ cs_name = "equeue"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/equeue"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "equeue-gtk2"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "gtk2", true) ]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/equeue-gtk2"; bs_compiled_object = Best; bs_build_depends = [FindlibPackage ("lablgtk2", None)]; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "equeue-tcl"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "tcl", true) ]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/equeue-tcl"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "netcamlbox"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netcamlbox"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "netcgi2"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netcgi2"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "netcgi2-plex"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netcgi2-plex"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "netcgi2-apache"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "apache", true) ]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netcgi2-apache"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "netclient"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netclient"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "netgss-system"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "gssapi", true) ]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netgss-system"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "nethttpd"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "nethttpd", true) ]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/nethttpd"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "netmulticore"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netmulticore"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "netplex"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netplex"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "netshm"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netshm"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "netstring"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netstring"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "netstring-pcre"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.EFlag "pcre", OASISExpr.EFlag "full_pcre"), true) ]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netstring-pcre"; bs_compiled_object = Best; bs_build_depends = [FindlibPackage ("pcre", None)]; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "netsys"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netsys"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "nettls-gnutls"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "gnutls", true) ]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netsys-gnutls"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "netunidata"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netunidata"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "netzip"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EFlag "zlib", true) ]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netzip"; bs_compiled_object = Best; bs_build_depends = [FindlibPackage ("zip", None)]; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "rpc"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/rpc"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "rpc-auth-local"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/rpc-auth-local"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "rpc-generator"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/rpc-generator"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "rpc-xti"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [ (OASISExpr.EBool true, false); (OASISExpr.EOr (OASISExpr.ETest ("system", "sunos"), OASISExpr.ETest ("system", "solaris")), true) ]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/rpc-xti"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Library ({ cs_name = "shell"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/shell"; bs_compiled_object = Best; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, { lib_modules = []; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = None; lib_findlib_containers = [] }); Executable ({ cs_name = "ocamlrpcgen"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/rpc-generator"; bs_compiled_object = Byte; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, {exec_custom = false; exec_main_is = "main.ml"}); Executable ({ cs_name = "netplex-admin"; cs_data = PropList.Data.create (); cs_plugin_data = [] }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; bs_path = "src/netplex"; bs_compiled_object = Byte; bs_build_depends = []; bs_build_tools = [ExternalTool "make"]; bs_c_sources = []; bs_data_files = []; bs_ccopt = [(OASISExpr.EBool true, [])]; bs_cclib = [(OASISExpr.EBool true, [])]; bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; bs_nativeopt = [(OASISExpr.EBool true, [])] }, {exec_custom = false; exec_main_is = "netplex_admin.ml"}) ]; plugins = []; disable_oasis_section = []; schema_data = PropList.Data.create (); plugin_data = [] }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; oasis_digest = Some "0)xR\016Ec\217\133\2065\228a8\211G"; oasis_exec = None; oasis_setup_args = []; setup_update = false };; let setup () = BaseSetup.setup setup_t;; # 6642 "setup.ml" (* OASIS_STOP *) let () = setup ();; ocamlnet-4.0.4/_oasis0000644000175000017500000000570612541553660013164 0ustar gerdgerdOASISFormat: 0.4 Name: ocamlnet Version: 4.0.4 Synopsis: Internet protocols and helper data structures Authors: Gerd Stolpmann et al. ConfType: custom (0.4) BuildType: custom (0.4) InstallType: custom (0.4) BuildTools: make License: http://download.camlcity.org/download/licenses/ocamlnet OCamlVersion: >= 4.00.0 Homepage: http://projects.camlcity.org/projects/ocamlnet XCustomConf: ./configure PostConfCommand: make -s postconf XCustomBuild: make build XCustomInstall: make install XCustomUninstall: make uninstall Flag "gtk2" Description: gtk2: Support for gtk2 event loops Default: false Flag "tcl" Description: tcl: Support for Tcl/Tk event loops Default: false Flag "zlib" Description: zlib: Support for compression Default: false Flag "apache" Description: apache: Build the Apache module Default: false Flag "gnutls" Description: gnutls: Enable (Gnu) TLS Default: false Flag "gssapi" Description: gssapi: Enable GSSAPI Default: false Flag "pcre" Description: pcre: Build netstring-pcre library Default: false Flag "full_pcre" Description: full_pcre: Use pcre for all regular expressions Default: false Flag "nethttpd" Description: nethttpd: Build the webserver nethttpd Default: false Library "equeue" Path: src/equeue Library "equeue-gtk2" Path: src/equeue-gtk2 BuildDepends: lablgtk2 Build: false if flag(gtk2) Build: true Library "equeue-tcl" Path: src/equeue-tcl Build: false if flag(tcl) Build: true Library "netcamlbox" Path: src/netcamlbox Library "netcgi2" Path: src/netcgi2 Library "netcgi2-plex" Path: src/netcgi2-plex Library "netcgi2-apache" Path: src/netcgi2-apache Build: false if flag(apache) Build: true Library "netclient" Path: src/netclient Library "netgss-system" Path: src/netgss-system Build: false if flag(gssapi) Build: true Library "nethttpd" Path: src/nethttpd Build: false if flag(nethttpd) Build: true Library "netmulticore" Path: src/netmulticore Library "netplex" Path: src/netplex Library "netshm" Path: src/netshm Library "netstring" Path: src/netstring Library "netstring-pcre" Path: src/netstring-pcre BuildDepends: pcre Build: false if flag(pcre) || flag(full_pcre) Build: true Library "netsys" Path: src/netsys Library "nettls-gnutls" Path: src/netsys-gnutls Build: false if flag(gnutls) Build: true Library "netunidata" Path: src/netunidata Library "netzip" Path: src/netzip BuildDepends: zip Build: false if flag(zlib) Build: true Library "rpc" Path: src/rpc Library "rpc-auth-local" Path: src/rpc-auth-local Library "rpc-generator" Path: src/rpc-generator Library "rpc-xti" Path: src/rpc-xti Build: false if system(sunos) || system(solaris) Build: true Library "shell" Path: src/shell Executable "ocamlrpcgen" Path: src/rpc-generator MainIs: main.ml Executable "netplex-admin" Path: src/netplex MainIs: netplex_admin.ml ocamlnet-4.0.4/src/0000755000175000017500000000000012541553665012550 5ustar gerdgerdocamlnet-4.0.4/src/netstring/0000755000175000017500000000000012541553661014561 5ustar gerdgerdocamlnet-4.0.4/src/netstring/netglob.ml0000644000175000017500000006151412541553660016553 0ustar gerdgerd(* $Id: netglob.ml 1998 2014-08-24 20:41:09Z gerd $ *) open Netglob_lex open Printf type glob_expr = glob_expr_atom list and glob_expr_atom = [ `Literal of string | `Star | `Qmark | `Bracket of (bool * glob_set) | `Brace of glob_expr list | `Tilde of string ] and glob_set = < set : (int * int) list > type valid_glob_expr = { pat : glob_expr; encoding : Netconversion.encoding; } exception Bad_glob_expr of string exception Unsupported_expr of string class type user_info = object method path_encoding : Netconversion.encoding option method home_directory : string -> string end class type glob_fsys = object method path_encoding : Netconversion.encoding option method read_dir : string -> string list method file_is_dir : string -> bool method file_exists : string -> bool end type glob_mode = [ `Existing_paths | `All_paths | `All_words ] type pattern = [ `String of string | `Expr of valid_glob_expr ] let literal_glob_expr enc s = { pat = [ `Literal s ]; encoding = enc } let reparse_bracket_expr enc l = (* In order to support multi-byte encodings, reparse the expression now. For simplifying this, we require that ranges (like c-d) are purely ASCII. So only the chars outside ranges need to be reparsed *) let rec collect buf toks = match toks with | Bracket_char c :: toks' -> Buffer.add_char buf c; collect buf toks' | Bracket_range(c1,c2) as tok :: toks' -> let new_toks = reparse buf in new_toks @ [tok] @ collect (Buffer.create 80) toks' | Bracket_code _ :: _ -> assert false | Bracket_end :: _ | [] -> reparse buf and reparse buf = let s = Buffer.contents buf in let codes = ref [] in ( try Netconversion.ustring_iter enc (fun i -> codes := i :: !codes) s with _ -> raise Lexing_Error ); List.rev_map (fun i -> Bracket_code i) !codes in collect (Buffer.create 80) l let parse_glob_expr ?(encoding = `Enc_iso88591) ?(enable_star = true) ?(enable_qmark = true) ?(enable_brackets = true) ?(enable_braces = true) ?(enable_tilde = true) ?(enable_escape = true) s = if not (Netconversion.is_ascii_compatible encoding) then failwith "Netglob.parse_glob_expr: the encoding is not ASCII-compatible"; let feat = { enable_star = enable_star; enable_qmark = enable_qmark; enable_brackets = enable_brackets; enable_braces = enable_braces; enable_tilde = enable_tilde; enable_escape = enable_escape; escaped = false; } in let rec collect_until lexbuf = let tok = glob_expr feat lexbuf in if tok = Glob_end then [] else tok :: (collect_until lexbuf) in let rec process_brace_list current list = match list with | Brace_literal s :: list' -> let gl = collect_until (Lexing.from_string s) in process_brace_list (current @ gl) list' | Brace_braces l :: list' -> process_brace_list (current @ [Glob_braces l]) list' | Brace_comma :: list' -> let ge = process_glob_list [] current in ge :: process_brace_list [] list' | Brace_end :: _ -> assert false | [] -> let ge = process_glob_list [] current in [ ge ] and process_glob_list acc list = match list with | Glob_star :: list' -> ( match acc with | `Star :: acc' -> (* Ignore the second star! *) process_glob_list acc list' | _ -> process_glob_list (`Star :: acc) list' ) | Glob_qmark :: list' -> process_glob_list (`Qmark :: acc) list' | Glob_brackets (neg,btoks) :: list' -> let set = List.map (function | Bracket_char c -> assert false | Bracket_range (c1,c2) -> (* c1, c2 are ASCII *) (Char.code c1, Char.code c2) | Bracket_code i -> (i, i) | Bracket_end -> assert false ) (reparse_bracket_expr encoding btoks) in let set_obj = ( object method set = set end ) in process_glob_list (`Bracket(neg,set_obj) :: acc) list' | Glob_braces btoks :: list' -> let alts = process_brace_list [] btoks in process_glob_list (`Brace alts :: acc) list' | Glob_literal s :: list' -> if s <> "" then ( match acc with | `Literal s' :: acc' -> process_glob_list (`Literal(s' ^ s) :: acc') list' | _ -> process_glob_list (`Literal s :: acc) list' ) else process_glob_list acc list' | Glob_tilde(s,slash) :: list' -> let atoms = if slash then [ `Literal "/"; `Tilde s ] else [ `Tilde s ] in process_glob_list ( atoms @ acc ) list' | Glob_end :: _ -> assert false | [] -> List.rev acc in try let glob_list = collect_until (Lexing.from_string s) in let glob_expr = process_glob_list [] glob_list in { pat = glob_expr; encoding = encoding } with | Bracket_Unsupported -> raise (Unsupported_expr s) | Lexing_Error -> raise (Bad_glob_expr s) let validate_glob_expr enc expr = let checkenc s = try Netconversion.verify enc s with _ -> failwith "Netglob.validate_glob_expr: literal does not conform \ to selected pattern encoding" in let rec validate ge = match ge with | `Literal s :: ge' -> if s = "" then failwith "Netglob.validate_glob_expr: empty literal"; checkenc s; validate ge' | `Bracket(_,set) :: ge' -> List.iter (fun (j,k) -> if j < 0 || k < 0 || j > k then failwith "Netglob.validate_glob_expr: bad bracket set"; ) set#set | `Brace l :: ge' -> List.iter validate l; validate ge' | `Tilde s :: ge' -> checkenc s; validate ge' | _ :: ge' -> validate ge' | [] -> () in if not (Netconversion.is_ascii_compatible enc) then failwith "Netglob.validate_glob_expr: the encoding is not ASCII-compatible"; validate expr; { pat = expr; encoding = enc } let recover_glob_expr expr = expr.pat let encoding_of_glob_expr expr = expr.encoding (* A more efficient representation for sets: *) type eff_set = { ascii : bool array; non_ascii : (int, unit) Hashtbl.t } let to_eset set = let ascii = Array.make 128 false in let non_ascii = Hashtbl.create 13 in List.iter (fun (k0,k1) -> assert(k0 <= k1); for p = k0 to k1 do if p < 128 then ascii.(p) <- true else Hashtbl.replace non_ascii p () done ) set; { ascii = ascii; non_ascii = non_ascii } let rec mem_eset code eset = if code >= 0 && code < 128 then eset.ascii.(code) else Hashtbl.mem eset.non_ascii code let size_eset eset = let n = ref 0 in for k = 0 to 127 do if eset.ascii.(k) then incr n done; !n + Hashtbl.length eset.non_ascii let ascii_ranges eset = let ranges = ref [] in let inrange = ref None in for k = 0 to 127 do let p = eset.ascii.(k) in match !inrange with | None -> if p then inrange := Some k | Some q -> if not p then ( ranges := (q, k-1) :: !ranges; inrange := None; ) done; ( match !inrange with | None -> () | Some q -> ranges := (q, 127) :: !ranges ); List.rev !ranges let rec exclude_set codes set = match set with [] -> [] | (x,y) :: set' -> let x' = if List.mem x codes then x+1 else x in let y' = if List.mem y codes then y-1 else y in if x = x' && y = y' && x <= y then (x,y) :: exclude_set codes set' else if x' <= y' then exclude_set codes ( (x',y') :: set') else exclude_set codes set' let print_set buf encoding neg_char negated set = (* Always produce a portable expression: *) let eset = to_eset set in (* Check for special characters: *) let want_minus = mem_eset (Char.code '-') eset in let want_rbracket = mem_eset (Char.code ']') eset in let want_circum = mem_eset (Char.code '^') eset in let want_exclam = mem_eset (Char.code '!') eset in let size = size_eset eset in (* Check for very special sets: *) if not negated && want_circum && size = 1 then Buffer.add_string buf "^" (* "[^]" would not be portable enough *) else if not negated && want_exclam && size = 1 then Buffer.add_string buf "!" (* "[!]" would not be portable enough *) else if not negated && want_circum && want_exclam && size = 2 then failwith "print_glob_expr" (* There is no portable representation *) else ( (* First create a set expression where the special characters * '-', ']', '^', and '!' do not occur literally. *) let empty = ref true in let buf' = Buffer.create 200 in let ascii_part = ascii_ranges eset in let ascii_part' = exclude_set (List.map Char.code ['-'; ']'; '^'; '!']) ascii_part in let ascii_part'_eset = to_eset ascii_part' in List.iter (fun (x0,x1) -> if x0 = x1 then ( Buffer.add_char buf' (Char.chr x0); empty := false; ) else if x0 <= x1 then ( Buffer.add_char buf' (Char.chr x0); Buffer.add_char buf' '-'; Buffer.add_char buf' (Char.chr x1); empty := false; ) ) ascii_part'; (* The non-ascii part is easy: *) Hashtbl.iter (fun code _ -> let encoded = Netconversion.ustring_of_uarray encoding [| code |] in Buffer.add_string buf' encoded ) eset.non_ascii; (* Check which of the special characters are already covered * by ranges: *) let done_minus = mem_eset (Char.code '-') ascii_part'_eset in let done_rbracket = mem_eset (Char.code ']') ascii_part'_eset in let done_circum = mem_eset (Char.code '^') ascii_part'_eset in let done_exclam = mem_eset (Char.code '!') ascii_part'_eset in (* Begin with printing *) Buffer.add_string buf (if negated then "[" ^ String.make 1 neg_char else "["); (* ']' must always be the first character of the set: *) if want_rbracket && not done_rbracket then ( Buffer.add_string buf "]"; empty := false; ); Buffer.add_buffer buf buf'; (* '-' must be the first or the last character; '^' and '!' must * not be the first character. So we usually print these * characters in the order "^!-". One case is special: We have * not yet printed any character. Then, "-" must be printed * first (if member of the set), or we have one of the very * special cases already tested above. *) if !empty then ( if want_minus && not done_minus then Buffer.add_char buf '-'; if want_circum && not done_circum then Buffer.add_char buf '^'; if want_exclam && not done_exclam then Buffer.add_char buf '!'; ) else ( if want_circum && not done_circum then Buffer.add_char buf '^'; if want_exclam && not done_exclam then Buffer.add_char buf '!'; if want_minus && not done_minus then Buffer.add_char buf '-'; ); Buffer.add_char buf ']'; ) let esc_re = Netstring_str.regexp "[][*?{},\\~]";; let esc_subst m s = "\\" ^ Netstring_str.matched_group m 0 s let print_glob_expr ?(escape_in_literals=true) expr = let buf = Buffer.create 200 in let rec print gl = match gl with | `Literal s :: gl' -> Buffer.add_string buf (if escape_in_literals then Netstring_str.global_substitute esc_re esc_subst s else s ); print gl' | `Star :: gl' -> Buffer.add_string buf "*"; print gl' | `Qmark :: gl' -> Buffer.add_string buf "?"; print gl' | `Bracket (negated,set) :: gl' -> print_set buf expr.encoding '!' negated set#set; print gl' | `Brace ge_list :: gl' -> Buffer.add_string buf "{"; let first = ref true in List.iter (fun ge -> if not !first then Buffer.add_string buf ","; print ge; ) ge_list; Buffer.add_string buf "}"; print gl' | `Tilde s :: gl' -> Buffer.add_char buf '~'; Buffer.add_string buf s; print gl' | [] -> () in print expr.pat; Buffer.contents buf class local_user_info() = let pe = match Sys.os_type with | "Win32" -> Netconversion.user_encoding() | _ -> None in object method path_encoding = pe method home_directory name = (* Win32: only the HOME method works *) try if name = "" then ( try Sys.getenv "HOME" with Not_found -> let pw = Unix.getpwuid(Unix.getuid()) in pw.Unix.pw_dir ) else (Unix.getpwnam name).Unix.pw_dir with | _ -> raise Not_found end let local_user_info = new local_user_info let rec product f l1 l2 = match l1 with [] -> [] | x1 :: l1' -> List.map (fun x2 -> f x1 x2) l2 @ product f l1' l2 let rec expand_braces ge = match ge with | [] -> [ [] ] | `Brace gelist :: ge' -> let gelist' = List.flatten (List.map expand_braces gelist) in let ge_alts' = expand_braces ge' in product ( @ ) gelist' ge_alts' | any :: ge' -> let ge_alts' = expand_braces ge' in List.map (fun ge_alt' -> any :: ge_alt') ge_alts' let rec expand_tildes encoding user_info ge = match ge with | [] -> [] | `Tilde name :: ge' -> let atom = try let dir = user_info#home_directory name in if dir="" then raise Not_found; (* empty literals not allowed *) ( match user_info#path_encoding with | None -> `Literal dir | Some ui_enc -> if ui_enc = encoding then `Literal dir else `Literal (Netconversion.convert ~in_enc:ui_enc ~out_enc:encoding dir) ) with Not_found -> `Literal ("~" ^ name) in atom :: expand_tildes encoding user_info ge' | any :: ge' -> any :: expand_tildes encoding user_info ge' let expand_glob_expr ?(user_info=local_user_info()) ?(expand_brace=true) ?(expand_tilde=true) expr = let pat' = if expand_tilde then expand_tildes expr.encoding user_info expr.pat else expr.pat in let pat_l = if expand_brace then expand_braces pat' else [pat'] in List.map (fun p -> { expr with pat = p }) pat_l let period = Char.code '.' let slash = Char.code '/' let match_glob_expr ?(protect_period=true) ?(protect_slash=true) ?encoding expr s = let esets = Hashtbl.create 5 in let get_eset set = try Hashtbl.find esets set with Not_found -> let eset = to_eset set#set in Hashtbl.add esets set eset; eset in let u = Netconversion.uarray_of_ustring ( match encoding with | None -> expr.encoding | Some e -> e ) s in let n = Array.length u in let leading_period p = u.(p) = period && (p = 0 || (protect_slash && u.(p - 1) = slash)) in let rec match_at c ge = match ge with | `Literal lit :: ge' -> let lit_u = Netconversion.uarray_of_ustring expr.encoding lit in let lit_n = Array.length lit_u in let ok = try for k = 0 to lit_n - 1 do if c+k >= n then raise Not_found; let code = u.(c+k) in if code <> lit_u.(k) then raise Not_found; done; true with | Not_found -> false in ok && match_at (c+lit_n) ge' | `Star :: ge' -> let k = ref 0 in let cont = ref true in let found = ref false in while c + !k <= n && not !found && !cont do found := match_at (c + !k) ge'; if c + !k < n then cont := (not protect_period || not (leading_period (c + !k))) && (not protect_slash || u.(c + !k) <> slash); incr k; done; !found | `Qmark :: ge' -> let ok = c < n && (not protect_period || not (leading_period c)) && (not protect_slash || u.(c) <> slash) in ok && match_at (c+1) ge' | `Bracket(neg,set) :: ge' -> let ok = c < n && ( let code = u.(c) in (not protect_slash || code <> slash) && (not protect_period || not (leading_period c)) && ( let eset = get_eset set in let is_mem = mem_eset code eset in (neg <> is_mem) ) ) in ok && match_at (c+1) ge' | `Brace _ :: _ -> failwith "Netglob.match_glob_expr: found `Brace subpattern" | `Tilde _ :: _ -> failwith "Netglob.match_glob_expr: found `Tilde subpattern" | [] -> c = n in match_at 0 expr.pat let skip_slashes s k = let l = String.length s in let j = ref k in while !j < l && s.[!j] = '/' do incr j done; !j let rev_skip_slashes s k = let j = ref k in while !j >= 0 && s.[!j] = '/' do decr j done; !j let search_slash s = let k = String.index s '/' in let j = skip_slashes s (k+1) in (k, j) let split_glob_expr expr = let rec split_loop is_first acc ge = (* acc: accumulates the current component *) match ge with | [] -> [ List.rev acc ] | (`Literal s as atom) :: ge' -> assert(s <> ""); ( try let (k,j) = search_slash s in (* or Not_found *) let l = String.length s in let s1 = String.sub s 0 k in (* part before '/' *) let s2 = String.sub s j (l - j) in (* part after '/' *) if is_first && k = 0 then ( (* Case: rooted expression *) let ge'' = if s2 <> "" then (`Literal s2) :: ge' else ge' in let comps = split_loop false [] ge'' in (* N.B. comps is a list of lists... *) match comps with | ( (`Literal s3) :: r ) :: l -> ( `Literal("/" ^ s3) :: r) :: l | r :: l -> (`Literal "/" :: r) :: l | [] -> [ [ `Literal "/" ] ] ) else if ge' = [] && s2 = "" then ( (* Case: component matches only directory *) [ List.rev (`Literal (s1 ^ "/") :: acc) ] ) else ( let acc' = if s1 <> "" then (`Literal s1)::acc else acc in let ge'' = if s2 <> "" then (`Literal s2) :: ge' else ge' in (List.rev acc') :: split_loop false [] ge'' ) with | Not_found -> split_loop false (atom::acc) ge' ) | (`Star | `Qmark | `Bracket(_,_) as atom) :: ge' -> split_loop false (atom::acc) ge' | `Brace _ :: _ -> failwith "Netglob.split_glob_expr: brace expression found" | `Tilde _ :: _ -> failwith "Netglob.split_glob_expr: tilde expression found" in List.map (fun p -> { expr with pat = p }) (split_loop true [] expr.pat) let check_rooted_glob_expr expr = match expr.pat with | (`Literal s) :: r -> assert(s <> ""); if s.[0] = '/' then ( let j = skip_slashes s 1 in let l = String.length s in let s' = String.sub s j (l - j) in (* part after '/' *) if s' = "" then Some { expr with pat = r } else Some { expr with pat = `Literal s' :: r } ) else None | _ -> None let check_directory_glob_expr expr = match List.rev expr.pat with | (`Literal s) :: r -> assert(s <> ""); ( try let l = String.length s in if s.[l-1] <> '/' then raise Not_found; let k = rev_skip_slashes s (l-1) + 1 in let s' = String.sub s 0 k in (* the part before '/' *) if s' = "" then Some { expr with pat = List.rev r } else Some { expr with pat = List.rev (`Literal s' :: r) } with Not_found -> None ) | _ -> None class of_dual_stream_fs (abs_fs:Netfs.stream_fs) rel_fs = let is_abs name = name <> "" && name.[0] = '/' in let fix name = if is_abs name then (abs_fs, name) else (rel_fs, "/" ^ name) in object method path_encoding = abs_fs#path_encoding method read_dir name = let (fs,name) = fix name in try fs#readdir [] name with _ -> [] method file_is_dir name = let (fs,name) = fix name in try fs#test [] name `D with _ -> false method file_exists name = let (fs,name) = fix name in try fs#test [] name `E with _ -> false end class of_stream_fs fs0 = let fs = (fs0 : #Netfs.stream_fs :> Netfs.stream_fs) in of_dual_stream_fs fs fs let of_stream_fs = new of_stream_fs class local_fsys ?encoding () = let abs_fs = Netfs.local_fs ?encoding () in let rel_fs = Netfs.local_fs ?encoding ~root:"." () in of_dual_stream_fs abs_fs rel_fs let local_fsys = new local_fsys let fn_concat d f = let l = String.length d in if l = 0 || d.[l-1] = '/' then d ^ f else d ^ "/" ^ f let glob1 ?base_dir ?(protect_period=true) ?(fsys = local_fsys()) ?user_info ?(mode = `Existing_paths) expr = (* File names and paths are encoded as [fsys] demands it. The encoding of the pattern can be different! *) let rec collect_and_match base_dir generated_prefix components = match components with | [] -> if generated_prefix <> "" then [ generated_prefix ] else [] | comp :: components' -> let full_path file = match base_dir with | Some d -> fn_concat d file | None -> file in let dir_ge = check_directory_glob_expr comp in let comp' = match dir_ge with | Some ge' -> ge' | None -> comp in let check_for_match only_dirs e file = (* file is encoded in fsys#path_encoding. For matching, we need to convert it to the encoding of the pattern. *) try let pe = match fsys#path_encoding with | None -> `Enc_iso88591 (* so no conv errors possible *) | Some pe -> pe in match_glob_expr ~protect_period ~encoding:pe e file && (not only_dirs || fsys#file_is_dir (full_path file)) with | Netconversion.Cannot_represent _ -> false in let files = match comp'.pat with | [ `Literal s ] -> (* s is encoded in expr.encoding. We need it here in the fsys#encoding *) ( try let s' = match fsys#path_encoding with | None -> s | Some pe -> Netconversion.convert ~in_enc:expr.encoding ~out_enc:pe s in match mode with | `Existing_paths -> let path = full_path s' in if fsys # file_exists path then [ s' ] else [] | _ -> [ s' ] with Netconversion.Cannot_represent _ when mode = `Existing_paths -> [] ) | _ -> let only_dirs = components' <> [] || dir_ge <> None in let file_list = fsys#read_dir (full_path ".") in (*eprintf "Files in %s: %s\n%!" (full_path ".") (String.concat "," file_list);*) List.filter (check_for_match only_dirs comp') file_list in List.flatten (List.map (fun file -> let prefixed_file = fn_concat generated_prefix file ^ (if dir_ge <> None then "/" else "") in collect_and_match (Some(full_path file)) prefixed_file components' ) files ) in let collect_and_match_0 components = match components with | comp :: components' -> ( match check_rooted_glob_expr comp with | None -> collect_and_match base_dir "" components | Some comp' -> if comp'.pat = [] then (* Special case "/" *) [ "/" ] else collect_and_match (Some "/") "/" (comp' :: components') ) | [] -> [] in let e_list = expand_glob_expr ?user_info expr in List.flatten (List.map (fun e' -> let l = collect_and_match_0 (split_glob_expr e') in if mode = `All_words && l = [] && e'.pat <> [] then [print_glob_expr e'] else l ) e_list ) let glob ?encoding ?base_dir ?protect_period ?fsys ?user_info ?mode pat = match pat with | `Expr e -> glob1 ?base_dir ?protect_period ?fsys ?user_info ?mode e | `String s -> let e = parse_glob_expr ?encoding s in glob1 ?base_dir ?protect_period ?fsys ?user_info ?mode e ocamlnet-4.0.4/src/netstring/netstring_top.mli0000644000175000017500000000042212541553660020160 0ustar gerdgerd(* $Id: netstring_top.mli 1003 2006-09-24 15:17:15Z gerd $ * ---------------------------------------------------------------------- * *) (* You may load this module into the toploop in order to install * the printers for the various opaque data types of Netstring. *) ocamlnet-4.0.4/src/netstring/netauth.ml0000644000175000017500000000760612541553660016573 0ustar gerdgerd(* $Id: netauth.ml 1543 2011-02-08 02:08:35Z gerd $ *) let xor_s s u = let s_len = String.length s in let u_len = String.length u in assert(s_len = u_len); let x = String.create s_len in for k = 0 to s_len-1 do x.[k] <- Char.chr ((Char.code s.[k]) lxor (Char.code u.[k])) done; x let hmac ~h ~b ~l ~k ~message = if String.length k > b then failwith "Netauth.hmac: key too long"; let k_padded = k ^ String.make (b - String.length k) '\000' in let ipad = String.make b '\x36' in let opad = String.make b '\x5c' in h((xor_s k_padded opad) ^ (h ((xor_s k_padded ipad) ^ message))) let add_1_complement s1 s2 = (* Add two bitstrings s1 and s2 (in big-endian order) with one's complement addition *) let l1 = String.length s1 in let l2 = String.length s2 in if l1 <> l2 then invalid_arg "Netauth.add_1_complement"; let r = String.make l1 '\000' in let carry = ref 0 in for k = l1-1 downto 0 do let i1 = Char.code s1.[k] in let i2 = Char.code s2.[k] in let sum = i1 + i2 + !carry in r.[k] <- Char.chr (sum land 0xff); carry := if sum > 0xff then 1 else 0; done; if !carry > 0 then ( for k = l1-1 downto 0 do let i = Char.code r.[k] in let sum = i + !carry in r.[k] <- Char.chr (sum land 0xff); carry := if sum > 0xff then 1 else 0; done ); r let rotate_right n s = (* Rotate the (big-endian) bitstring s to the right by n bits *) let l = String.length s in let b = 8 * l in (* bit length of s *) let n' = n mod b in let n' = if n' < 0 then b+n' else n' in let u = String.create l in (* First byte-shift the string, then bit-shift the remaining 0-7 bits *) let bytes = n' lsr 3 in let bits = n' land 7 in String.blit s 0 u bytes (l-bytes); if bytes > 0 then String.blit s (l-bytes) u 0 bytes; let mask = match bits with | 0 -> 0 | 1 -> 1 | 2 -> 3 | 3 -> 7 | 4 -> 15 | 5 -> 31 | 6 -> 63 | 7 -> 127 | _ -> assert false in let carry = ref 0 in if bits > 0 && l > 0 then ( for k = 0 to l-1 do let x = Char.code u.[k] in u.[k] <- Char.chr ((x lsr bits) lor (!carry lsl (8-bits))); carry := x land mask; done; u.[0] <- Char.chr((Char.code u.[0]) lor (!carry lsl (8-bits))); ); u let n_fold n s = (** n-fold the number given by the bitstring s. The length of the number is taken as the byte-length of s. n must be divisible by 8. *) if n=0 || n mod 8 <> 0 then invalid_arg "Netauth.n_fold"; let p = n / 8 in let buf = Buffer.create (String.length s) in let rec add_rot u len = if len > 0 && len mod p = 0 then () else ( Buffer.add_string buf u; add_rot (rotate_right 13 u) (len+String.length u) ) in add_rot s 0; let blen = Buffer.length buf in let s = ref (Buffer.sub buf 0 p) in for k = 1 to (blen / p) - 1 do s := add_1_complement !s (Buffer.sub buf (k*p) p) done; !s type key_type = [ `Kc | `Ke | `Ki ] let k_truncate k s = let b = k/8 in String.sub s 0 b let derive_key_rfc3961_simplified ~encrypt ~random_to_key ~block_size ~k ~usage ~key_type = if block_size < 40 then invalid_arg "Netauth.derive_key_rfc3961: bad block_size"; if k <= 0 || k mod 8 <> 0 then invalid_arg "Netauth.derive_key_rfc3961: bad k"; if usage < 0 || usage > 255 then invalid_arg "Netauth.derive_key_rfc3961: bad usage (only 0-255 allowed)"; let usage_s = String.make 3 '\000' ^ String.make 1 (Char.chr usage) ^ (match key_type with | `Kc -> "\x99" | `Ke -> "\xaa" | `Ki -> "\x55" ) in let usage_exp = n_fold block_size usage_s in let kbuf = Buffer.create 80 in let ki = ref (encrypt usage_exp) in Buffer.add_string kbuf !ki; while 8*(Buffer.length kbuf) < k do ki := encrypt !ki; Buffer.add_string kbuf !ki done; let derived_random = k_truncate k (Buffer.contents kbuf) in random_to_key derived_random ocamlnet-4.0.4/src/netstring/netascii_armor.mli0000644000175000017500000000333512541553661020267 0ustar gerdgerd(* $Id: netascii_armor.mli 2195 2015-01-01 12:23:39Z gerd $ *) (** Messages with ASCII armor *) (** There are various forms of ASCII-armored messages: - PEM messages (privacy enhanced mail) - a historic message format - OpenPGP messages. This type of message has a header, a BASE-64-encoded body, and a checksum. - X.509 keys. These just use BASE-64. *) type armor_type = [ `Plain | `Base64 | `OpenPGP ] type armored_message = [ `Plain of Netmime.mime_body | `Base64 of Netmime.mime_body | `OpenPGP of Netmime.mime_header * Netmime.mime_body * int ] (** Messages: - [`Plain m]: The body [m] is written as-is - [`Base64 m]: The body [m] needs to be BASE-64-encoded in order to create the ASCII armor - [`OpenPGP(h,m,chksum)]: There is a header [h], a body [m] which will be BASE-64-encoded, and a checksum [chksum] *) type armored_message_ro = [ `Plain of Netmime.mime_body_ro | `Base64 of Netmime.mime_body_ro | `OpenPGP of Netmime.mime_header_ro * Netmime.mime_body_ro * int ] (** The read-only version of [armored_message] *) type armor_spec = (string * armor_type) list (** Which types of armor to decode, and how. The strings are the identifiers in the boundaries, e.g. include "PRIVACY-ENHANCED MESSAGE" if the boundaries are "-----BEGIN PRIVACY-ENHANCED MESSAGE-----" and "-----END PRIVACY-ENHANCED MESSAGE-----". For every type you can define the [armor_type]. *) val parse : armor_spec -> Netchannels.in_obj_channel -> (string * armored_message_ro) list (** Parses the channel, and returns all messages that are enabled in the specification. The channel is read line-by-line. *) ocamlnet-4.0.4/src/netstring/netxdr.ml0000644000175000017500000015715012541553661016430 0ustar gerdgerd(* * $Id: netxdr.ml 2195 2015-01-01 12:23:39Z gerd $ *) (* This is an XDR implementation. * See RFC 1014 *) open Netnumber open Printf exception Propagate of string;; (**********************************************************************) (* auxiliary stuff: *) let aux_cmp (ha,sa) (hb,sb) = if ha = hb then compare sa sb else ha - hb ;; let all_distinct_q l = (* returns whether all elements of l are distinct *) let a = Array.map (fun s -> (Hashtbl.hash s), s) (Array.of_list l) in Array.sort aux_cmp a; let distinct = ref true in let k = ref 0 in while !distinct && !k < Array.length a - 1 do let (ha,sa) = a.( !k ) in let (hb,sb) = a.( !k + 1 ) in distinct := (ha != hb) && (sa <> sb); incr k done; !distinct ;; let all_distinct = function [] | [_] -> true | [a;b] -> a <> b | l -> all_distinct_q l ;; let sub_set_q l1 l2 = (* returns whether all elements of l1 occur in l2 *) let a1 = Array.map (fun s -> (Hashtbl.hash s), s) (Array.of_list l1) in let a2 = Array.map (fun s -> (Hashtbl.hash s), s) (Array.of_list l2) in Array.sort aux_cmp a1; Array.sort aux_cmp a2; let occurs = ref true in let k1 = ref 0 in let k2 = ref 0 in while !occurs && !k1 < Array.length a1 && !k2 < Array.length a2 do let (h1,s1) = a1.( !k1 ) in let found = ref false in while not !found && !k2 < Array.length a2 do let (h2,s2) = a2.( !k2 ) in found := (h1 == h2) && (s1 = s2); if not !found then incr k2 done; occurs := !found; incr k1 done; !occurs ;; let sub_set l1 l2 = match (l1,l2) with ([],_) -> true | ([x],_) -> List.mem x l2 | _ -> sub_set_q l1 l2 ;; (* (* currently unused! *) let equal_sets_q l1 l2 = (* returns whether all elements of l1 occur in l2, and vice versa *) let a1 = Array.map (fun s -> (Hashtbl.hash s), s) (Array.of_list l1) in let a2 = Array.map (fun s -> (Hashtbl.hash s), s) (Array.of_list l2) in Array.sort aux_cmp a1; Array.sort aux_cmp a2; let equal = ref true in let k1 = ref 0 in let k2 = ref 0 in let k2_match = ref false in (* can only be false when !k2 = 0 *) while !equal && !k1 < Array.length a1 && !k2 < Array.length a2 do let (h1,s1) = a1.( !k1 ) in let (h2,s2) = a2.( !k2 ) in if (h1 == h2) && (s1 = s2) then ( incr k1; k2_match := true; (* a match for the k2 element has been found *) ) else ( if !k2_match then ( incr k2; while !k2 < Array.length a2 && (h2,s2) = a2.( !k2 ) do incr k2 done; if !k2 < Array.length a2 then ( let (h2',s2') = a2.( !k2 ) in if (h1 == h2') && (s1 = s2') then ( incr k1; ) else equal := false ) else equal := false ) else equal := false ) done; if !equal && !k1 = Array.length a1 && !k2 < Array.length a2 && !k1 > 0 then ( (* !k1 > 0 ==> a1 is not empty && !k2_match, * !k2 < length a2 ==> a2 is not empty *) let (h2,s2) = a2.( !k2 ) in incr k2; while !k2 < Array.length a2 && (h2,s2) = a2.( !k2 ) do incr k2 done; ); !equal && !k1 = Array.length a1 && !k2 = Array.length a2 ;; let equal_sets l1 l2 = match (l1,l2) with ([],[]) -> true | ([x],[y]) -> x = y | _ -> equal_sets_q l1 l2 ;; *) (**********************************************************************) (* definition of XDR types and type systems *) (**********************************************************************) (* restriction: it is not allowed to have an X_param as enumerator type * in union_over_enum. There must always be a real X_enum or, in a * type system, a resolvable X_type at this position. *) type xdr_type_term = X_int | X_uint | X_hyper | X_uhyper | X_enum of (string * int4) list | X_float | X_double | X_opaque_fixed of uint4 | X_opaque of uint4 | X_string of uint4 | X_mstring of string * uint4 | X_array_fixed of xdr_type_term * uint4 | X_array of xdr_type_term * uint4 | X_struct of (string * xdr_type_term) list | X_union_over_int of (int4 * xdr_type_term) list * xdr_type_term option | X_union_over_uint of (uint4 * xdr_type_term) list * xdr_type_term option | X_union_over_enum of xdr_type_term * (string * xdr_type_term) list * xdr_type_term option | X_void | X_type of string | X_param of string | X_rec of (string * xdr_type_term) (* define a recursive type *) | X_refer of string (* refer to a recursive type *) | X_direct of xdr_type_term * (string -> int ref -> int -> exn) * (exn -> string -> int ref -> unit) * (exn -> int) ;; module StringSet = Set.Make(String) ;; type xdr_type0 = { mutable term : xdr_term; mutable params : StringSet.t; (* "params" is normally only non-empty in the top node *) mutable min_size : int (* min_size: the minimum number of bytes every element of the array will take in XDR form. This does not include any inner parameters. *) } and xdr_term = T_int | T_uint | T_hyper | T_uhyper | T_enum of (string * int32) array (* array must be sorted by ascending int32 *) | T_float | T_double | T_opaque_fixed of uint4 | T_opaque of uint4 | T_string of uint4 | T_mstring of string * uint4 | T_array_fixed of xdr_type0 * uint4 | T_array of xdr_type0 * (* max size: *) uint4 | T_struct of (string * xdr_type0) array | T_union_over_int of (int4, xdr_type0) Hashtbl.t * xdr_type0 option | T_union_over_uint of (uint4, xdr_type0) Hashtbl.t * xdr_type0 option | T_union_over_enum of xdr_type0 * xdr_type0 option array * xdr_type0 option (* The array corresponds to the T_enum array. None means that the * constant is not mapped. *) | T_void | T_param of string | T_rec of (string * xdr_type0) | T_refer of (string * xdr_type0) | T_direct of xdr_type0 * (string -> int ref -> int -> exn) * (exn -> string -> int ref -> unit) * (exn -> int) ;; type xdr_type = xdr_type0 * xdr_type0 (* left: includes T_rec and T_refer, right: does not include T_rec, T_refer *) type xdr_type_term_system = (string * xdr_type_term) list ;; type xdr_type_system = (string * xdr_type) list (* export xdr_type_system in an opaque manner *) let t_name = function | T_int -> "T_int" | T_uint -> "T_uint" | T_hyper -> "T_hyper" | T_uhyper -> "T_uhyper" | T_enum _ -> "T_enum" | T_float -> "T_float" | T_double -> "T_double" | T_opaque_fixed _ -> "T_opaque_fixed" | T_opaque _ -> "T_opaque" | T_string _ -> "T_string" | T_mstring(_,_) -> "T_mstring" | T_array_fixed (_,_) -> "T_array_fixed" | T_array (_,_) -> "T_array" | T_struct _ -> "T_struct" | T_union_over_int(_,_) -> "T_union_over_int" | T_union_over_uint(_,_) -> "T_union_over_uint" | T_union_over_enum(_,_,_) -> "T_union_over_enum" | T_void -> "T_void" | T_param _ -> "T_param" | T_rec _ -> "T_rec" | T_refer _ -> "T_refer" | T_direct _ -> "T_direct" let x_bool = X_enum ["FALSE", int4_of_int 0; "TRUE", int4_of_int 1] ;; let x_optional t = X_union_over_enum (x_bool, ["TRUE", t; "FALSE", X_void], None) ;; let x_opaque_max = X_opaque (mk_uint4 ('\255', '\255', '\255', '\255'));; let x_string_max = X_string (mk_uint4 ('\255', '\255', '\255', '\255'));; let x_mstring_max name = X_mstring (name, mk_uint4 ('\255', '\255', '\255', '\255'));; let x_array_max t = X_array (t, (mk_uint4 ('\255', '\255', '\255', '\255')));; (**********************************************************************) (* definition of XDR values *) (**********************************************************************) type xdr_value_version = [ `V1 | `V2 | `V3 | `V4 | `Ocamlrpcgen ] type xdr_value = XV_int of int4 | XV_uint of uint4 | XV_hyper of int8 | XV_uhyper of uint8 | XV_enum of string | XV_float of fp4 | XV_double of fp8 | XV_opaque of string | XV_string of string | XV_array of xdr_value array | XV_struct of (string * xdr_value) list | XV_union_over_int of (int4 * xdr_value) | XV_union_over_uint of (uint4 * xdr_value) | XV_union_over_enum of (string * xdr_value) | XV_void | XV_enum_fast of int | XV_struct_fast of xdr_value array | XV_union_over_enum_fast of (int * xdr_value) | XV_array_of_string_fast of string array | XV_mstring of Netxdr_mstring.mstring | XV_direct of exn * int ;; let xv_true = XV_enum_fast 1 (* "TRUE" *);; let xv_false = XV_enum_fast 0 (* "FALSE" *);; let xv_none = XV_union_over_enum_fast (0,XV_void);; let xv_some v = XV_union_over_enum_fast (1,v);; exception Dest_failure let dest_xv_int v = match v with XV_int x -> x | _ -> raise Dest_failure;; let dest_xv_uint v = match v with XV_uint x -> x | _ -> raise Dest_failure;; let dest_xv_hyper v = match v with XV_hyper x -> x | _ -> raise Dest_failure;; let dest_xv_uhyper v = match v with XV_uhyper x -> x | _ -> raise Dest_failure;; let dest_xv_enum v = match v with XV_enum x -> x | _ -> raise Dest_failure;; let dest_xv_enum_fast v = match v with XV_enum_fast x -> x | _ -> raise Dest_failure;; let dest_xv_float v = match v with XV_float x -> x | _ -> raise Dest_failure;; let dest_xv_double v = match v with XV_double x -> x | _ -> raise Dest_failure;; let dest_xv_opaque v = match v with XV_opaque x -> x | _ -> raise Dest_failure;; let dest_xv_string v = match v with XV_string x -> x | _ -> raise Dest_failure;; let dest_xv_mstring v = match v with XV_mstring x -> x | _ -> raise Dest_failure;; let dest_xv_array v = match v with XV_array x -> x | _ -> raise Dest_failure;; let dest_xv_array_of_string_fast v = match v with XV_array_of_string_fast x -> x | _ -> raise Dest_failure;; let dest_xv_struct v = match v with XV_struct x -> x | _ -> raise Dest_failure;; let dest_xv_struct_fast v = match v with XV_struct_fast x -> x | _ -> raise Dest_failure;; let dest_xv_void v = match v with XV_void -> () | _ -> raise Dest_failure;; let dest_xv_union_over_int v = match v with XV_union_over_int x -> x | _ -> raise Dest_failure;; let dest_xv_union_over_uint v = match v with XV_union_over_uint x -> x | _ -> raise Dest_failure;; let dest_xv_union_over_enum v = match v with XV_union_over_enum x -> x | _ -> raise Dest_failure;; let dest_xv_union_over_enum_fast v = match v with XV_union_over_enum_fast x -> x | _ -> raise Dest_failure;; let fail_map_xv_enum_fast k = failwith ("Netxdr.map_xv_enum_fast [" ^ string_of_int k ^ "]") ;; let map_xv_enum_fast0 t v = match t.term with T_enum l -> let m = Array.length l in ( match v with XV_enum_fast k -> if k >= 0 && k < m then snd(Array.unsafe_get l k) else fail_map_xv_enum_fast 1 | XV_enum name -> let k = ref 0 in while !k < m && (fst l.( !k ) <> name) do incr k done; if !k >= m then fail_map_xv_enum_fast 2; snd(l.( !k )) | _ -> fail_map_xv_enum_fast 3 ) | _ -> fail_map_xv_enum_fast 4 let map_xv_enum_fast (_,t) v = map_xv_enum_fast0 t v let fail_map_xv_struct_fast k = failwith ("Netxdr.map_xv_struct_fast [" ^ string_of_int k ^ "]") ;; let map_xv_struct_fast0 t v = match t.term with T_struct decl -> let m = Array.length decl in ( match v with XV_struct_fast x -> let k = Array.length x in if k = m then x else fail_map_xv_struct_fast 1 | XV_struct l -> ( try Array.map (fun (name,y) -> List.assoc name l) decl with Not_found -> fail_map_xv_struct_fast 2 ) | _ -> fail_map_xv_struct_fast 3 ) | _ -> fail_map_xv_struct_fast 4 let map_xv_struct_fast (_,t) v = map_xv_struct_fast0 t v let fail_map_xv_union_over_enum_fast k = failwith ("Netxdr.map_xv_union_over_enum_fast [" ^ string_of_int k ^ "]") ;; let map_xv_union_over_enum_fast0 t v = match t.term with T_union_over_enum( { term = T_enum e }, u, u_dfl ) -> let m = Array.length e in assert( m = Array.length u ); ( match v with XV_union_over_enum_fast(k, x) -> if k >= 0 && k < m then (k, (snd e.(k)), x) else fail_map_xv_union_over_enum_fast 1 | XV_union_over_enum(name, x) -> let k = ref 0 in while !k < m && fst(e.( !k )) <> name do incr k done; if !k >= m then fail_map_xv_union_over_enum_fast 2; (!k, (snd e.(!k)), x) | _ -> fail_map_xv_union_over_enum_fast 3; ) | _ -> fail_map_xv_union_over_enum_fast 4 let map_xv_union_over_enum_fast (_,t) v = map_xv_union_over_enum_fast0 t v exception Xdr_format of string;; exception Xdr_format_message_too_long of xdr_value;; (* raised in unpack_xdr_value if the byte stream does not match * the expected type. The string is an explanation and might be * useful while debugging. In the special case Xdr_format_message_too_long * there are more bytes than expected, but a prefix matches the type. * The prefix is returned as xdr_value. *) let () = Netexn.register_printer (Xdr_format "") (function | Xdr_format s -> sprintf "Netxdr.Xdr_format(%S)" s | _ -> assert false ) exception Xdr_failure of string let safe_add x y = (* exported *) (* pre: x >= 0 && y >= 0 *) let s = x + y in if s < 0 then (* can only happen on 32 bit platforms *) raise(Xdr_failure "int overflow while computing size"); s let safe_mul x y = (* exported *) (* pre: x >= 0 && y >= 0 *) if x=0 || y=0 then 0 else let n = max_int / y in if x > n then raise(Xdr_failure "int overflow while computing size"); x * y (**********************************************************************) (* check if XDR types are well-formed *) (**********************************************************************) (* TODO: check on recursions without finite fix point. *) let rec validate_xdr_type_i1 (r:xdr_type_term -> xdr_type0) (b:(string * xdr_type0) list) (t:xdr_type_term) : xdr_type0 = (* r: function that resolves X_type references * t: the xdr_type_term to validate * b: list of recursive bindings * * raise Not_found on any error *) let mktype tm = { term = tm; params = StringSet.empty; min_size = (-1) } in (* min_size is calculated in a second pass *) match t with X_int -> mktype T_int | X_uint -> mktype T_uint | X_hyper -> mktype T_hyper | X_uhyper -> mktype T_uhyper | X_float -> mktype T_float | X_double -> mktype T_double | X_void -> mktype T_void | X_enum e -> let e_names, e_values = List.split e in if all_distinct e_names && all_distinct e_values then let ea = Array.map (fun (n,i) -> (n, Netnumber.int32_of_int4 i)) (Array.of_list e) in Array.sort (fun (_,i) (_,i') -> compare i i') ea; mktype (T_enum ea) else raise (Propagate "Bad enumeration type: double values") | X_opaque_fixed n -> mktype (T_opaque_fixed n) | X_opaque n -> mktype (T_opaque n) | X_string n -> mktype (T_string n) | X_mstring (name,n) -> mktype (T_mstring (name,n)) | X_array_fixed (s,n) -> let nL = int64_of_uint4 n in if nL > 0x3fff_ffff_ffffL then raise (Propagate "Bad fixed array: bound too high"); mktype (T_array_fixed(validate_xdr_type_i1 r b s, n)) | X_array (s,n) -> mktype (T_array (validate_xdr_type_i1 r b s, n)) | X_struct s -> let s_names, s_types = List.split s in if all_distinct s_names then mktype (T_struct (Array.of_list (List.map (fun (n,x) -> n,validate_xdr_type_i1 r b x) s))) else raise (Propagate "Bad struct type: components with same names found") | X_union_over_int (u, default) -> let u_values, u_types = List.split u in if all_distinct u_values then begin let default' = match default with Some d -> Some (validate_xdr_type_i1 r b d) | None -> None in let htbl = Hashtbl.create(List.length u) in List.iter (fun (n,x) -> let x' = validate_xdr_type_i1 r b x in Hashtbl.add htbl n x') u; mktype(T_union_over_int(htbl, default')) end else raise (Propagate "Bad union_over_int type: variants found with same tags") | X_union_over_uint (u,default) -> let u_values, u_types = List.split u in if all_distinct u_values then begin let default' = match default with Some d -> Some (validate_xdr_type_i1 r b d) | None -> None in let htbl = Hashtbl.create(List.length u) in List.iter (fun (n,x) -> let x' = validate_xdr_type_i1 r b x in Hashtbl.add htbl n x') u; mktype(T_union_over_uint(htbl, default')) end else raise (Propagate "Bad union_over_uint type: variants found with same tags") | X_union_over_enum (e,u,default) -> let e' = validate_xdr_type_i1 r b e in let u_values, u_types = List.split u in let el = match e'.term with T_enum x -> x | _ -> raise (Propagate "Bad union_over_enum type: discriminator is not enumerator") in let el_names, el_values = List.split (Array.to_list el) in if all_distinct u_values && sub_set u_values el_names then begin let default' = match default with Some d -> Some (validate_xdr_type_i1 r b d) | None -> None in mktype (T_union_over_enum (e', Array.map (fun (name, _) -> try Some(validate_xdr_type_i1 r b (List.assoc name u)) with Not_found -> default' ) el, default')) end else raise (Propagate "Bad union_over_enum type: variants found with identical tags") | X_type _ -> r t | X_param p -> mktype (T_param p) | X_rec (name, s) -> let node = mktype T_void in let t' = validate_xdr_type_i1 r ((name,node)::b) s in node.term <- T_rec (name, t'); node | X_refer name -> mktype (T_refer (name, List.assoc name b)) | X_direct(s, read, write, size) -> mktype (T_direct (validate_xdr_type_i1 r b s, read, write, size)) ;; let rec find_params (t:xdr_type0) : StringSet.t = (* collect all parameters *) match t.term with T_param p -> StringSet.singleton p | T_array_fixed (t',n) -> find_params t' | T_array (t',n) -> find_params t' | T_struct s -> Array.fold_left (fun set (s,t') -> StringSet.union (find_params t') set) StringSet.empty s | T_union_over_int (htbl,def_opt) -> Hashtbl.fold (fun n t' set -> StringSet.union (find_params t') set) htbl (match def_opt with None -> StringSet.empty | Some def -> find_params def) | T_union_over_uint (htbl,def_opt) -> Hashtbl.fold (fun n t' set -> StringSet.union (find_params t') set) htbl (match def_opt with None -> StringSet.empty | Some def -> find_params def) | T_union_over_enum (e,u,def_opt) -> Array.fold_left (fun set t' -> match t' with Some t'' -> StringSet.union (find_params t'') set | None -> set) (match def_opt with None -> StringSet.empty | Some def -> find_params def) u | T_rec (_,t') -> find_params t' | T_direct(t',_,_,_) -> find_params t' | _ -> StringSet.empty ;; (* Elimination of rec/refer *) let map_opt f o = match o with | None -> None | Some x -> Some(f x) let map_hashtbl f t = let acc = Hashtbl.create (Hashtbl.length t) in Hashtbl.iter (fun k v -> let v' = f k v in Hashtbl.add acc k v'; (* !!! reverses order of bindings !!! *) ) t; acc let rec elim_rec t = (* get rid of T_rec and T_refer *) match t.term with | T_int | T_uint | T_hyper | T_uhyper | T_enum _ | T_float | T_double | T_opaque_fixed _ | T_opaque _ | T_string _ | T_mstring _ | T_void | T_param _ -> t | T_array_fixed(t',n) -> { t with term = T_array_fixed(elim_rec t', n) } | T_array(t',n) -> { t with term = T_array(elim_rec t', n) } | T_struct s -> let s' = Array.map (fun (n,t') -> (n, elim_rec t')) s in { t with term = T_struct s' } | T_union_over_int(ht, dt) -> let ht' = map_hashtbl (fun c t' -> elim_rec t') ht in let dt' = map_opt elim_rec dt in { t with term = T_union_over_int(ht', dt') } | T_union_over_uint(ht, dt) -> let ht' = map_hashtbl (fun c t' -> elim_rec t') ht in let dt' = map_opt elim_rec dt in { t with term = T_union_over_uint(ht', dt') } | T_union_over_enum(et,ct,dt) -> let et' = elim_rec et in let ct' = Array.map (map_opt elim_rec) ct in let dt' = map_opt elim_rec dt in { t with term = T_union_over_enum(et',ct',dt') } | T_rec(n,t') -> elim_rec t' | T_refer(n,t') -> t' | T_direct(t',read,write,size) -> { t with term = T_direct(elim_rec t', read, write, size) } let rec calc_min_size t = let ( ++ ) x y = (* pre: x >= 0 && y >= 0 *) let s = x + y in if s < 0 then (* can only happen on 32 bit platforms *) raise(Propagate("Minimum size of type exceeds limit")); s in let calc_for_union u_snd default = ( match default with | None -> () | Some d -> calc_min_size d ); List.iter (fun t' -> calc_min_size t') u_snd; let l = (match default with | None -> [] | Some d -> [d] ) @ u_snd in assert(l <> []); 4 ++ (List.fold_left (fun acc x -> min acc x.min_size ) ((List.hd l).min_size) (List.tl l) ) in let hashtbl_vals h = Hashtbl.fold (fun _ v acc -> v :: acc) h [] in let optarray_elems a = Array.fold_left (fun acc x_opt -> match x_opt with | None -> acc | Some x -> x :: acc ) [] a in if t.min_size < 0 then ( t.min_size <- 0; (* for stopping recursions *) ( match t.term with T_int -> t.min_size <- 4 | T_uint -> t.min_size <- 4 | T_hyper -> t.min_size <- 8 | T_uhyper -> t.min_size <- 8 | T_float -> t.min_size <- 4 | T_double -> t.min_size <- 8 | T_void -> t.min_size <- 0 | T_enum e -> t.min_size <- 4 | T_opaque_fixed n -> let nL = int64_of_uint4 n in let min_size = if nL=0L then 0 else Int64.to_int(Int64.succ (Int64.div (Int64.pred nL) 4L)) in t.min_size <- min_size | T_opaque n -> t.min_size <- 4 | T_string n -> t.min_size <- 4 | T_mstring (name,n) -> t.min_size <- 4 | T_array_fixed (s,n) -> calc_min_size s; if s.min_size = 0 then raise(Propagate "Array elements must not have length 0"); let nL = int64_of_uint4 n in let n_max = max_int / s.min_size in if nL > Int64.of_int n_max then raise(Propagate "Minimum size of type exceeds limit"); let iL = Int64.of_int s.min_size in t.min_size <- Int64.to_int (Int64.mul nL iL) | T_array (s,n) -> calc_min_size s; if s.min_size = 0 then raise(Propagate "Array elements must not have length 0"); t.min_size <- 4 | T_struct s -> Array.iter (fun (_,t') -> calc_min_size t') s; t.min_size <- (Array.fold_left (fun acc (_,x) -> acc ++ x.min_size ) 0 s ) | T_union_over_int (u, default) -> t.min_size <- calc_for_union (hashtbl_vals u) default | T_union_over_uint (u, default) -> t.min_size <- calc_for_union (hashtbl_vals u) default | T_union_over_enum (e,u,default) -> t.min_size <- calc_for_union (optarray_elems u) default | T_param p -> (* not optimal, but we do not know it better at this point *) t.min_size <- 0 | T_direct(t',_,_,_) -> calc_min_size t'; t.min_size <- t'.min_size | T_rec (_,t') -> calc_min_size t'; t.min_size <- t'.min_size | T_refer (r,t') -> calc_min_size t'; t.min_size <- t'.min_size; (* eprintf "%s: " r*) ); (* eprintf "min_size(%s) = %d\n" (t_name t.term) t.min_size*) ) let rec validate_xdr_type (t:xdr_type_term) : xdr_type = let r n = raise (Propagate "Cannot resolve X_type element") in try let t0' = validate_xdr_type_i1 r [] t in let pl = find_params t0' in t0'.params <- pl; let t1' = elim_rec t0' in calc_min_size t0'; calc_min_size t1'; (t0', t1') with Not_found -> failwith "Netxdr.validate_xdr_type: unspecified error" | Propagate s -> failwith ("Netxdr.validate_xdr_type: " ^ s) ;; let params (t:xdr_type) = StringSet.fold (fun p acc -> p :: acc) (fst t).params [] let rec expand_X_type (s:xdr_type_system) (t:xdr_type_term) : xdr_type0 = match t with X_type n -> begin let rec r s1 s2 = match s2 with [] -> raise (Propagate ("Cannot resolve X_type " ^ n)) | (n',t') :: s2' -> if n = n' then fst t' else r (s1 @ [n',t']) s2' in r [] s end | _ -> raise (Propagate "Found X_type where it must not occur") ;; let validate_xdr_type_system (s:xdr_type_term_system) : xdr_type_system = let names = List.map fst s in if all_distinct names then begin let rec r (s1:xdr_type_system) (s2:xdr_type_term_system) = match s2 with [] -> [] | (n,t) :: s2' -> let t2 = begin try let t0' = validate_xdr_type_i1 (expand_X_type s1) [] t in let pl = find_params t0' in t0'.params <- pl; let t1' = elim_rec t0' in calc_min_size t0'; calc_min_size t1'; (t0',t1') with Not_found -> failwith "Netxdr.validate_xdr_type_system: unspecified error" | Propagate s -> failwith ("Netxdr.validate_xdr_type_system: " ^ s) end in (n,t2)::(r (s1 @ [n,t2]) s2') in r [] s end else failwith "Netxdr.validate_xdr_type_system: type system has members with same names" ;; (**********************************************************************) (* the reverse way *) (**********************************************************************) let rec xdr_type_term0 (t:xdr_type0) : xdr_type_term = let conv_list l = List.map (fun (x, t') -> x, xdr_type_term0 t') l in let conv_htbl htbl = Hashtbl.fold (fun x t' l -> (x, xdr_type_term0 t') :: l) htbl [] in let conv_option p = match p with None -> None | Some t' -> Some (xdr_type_term0 t') in match t.term with T_int -> X_int | T_uint -> X_uint | T_hyper -> X_hyper | T_uhyper -> X_uhyper | T_enum l -> X_enum (Array.to_list (Array.map (fun (n,i) -> (n,Netnumber.int4_of_int32 i)) l)) | T_float -> X_float | T_double -> X_double | T_void -> X_void | T_param p -> X_param p | T_opaque_fixed n -> X_opaque_fixed n | T_opaque n -> X_opaque n | T_string n -> X_string n | T_mstring(name,n)-> X_mstring(name,n) | T_array_fixed (t', n) -> X_array_fixed (xdr_type_term0 t',n) | T_array (t', n) -> X_array (xdr_type_term0 t',n) | T_struct s -> X_struct (conv_list (Array.to_list s)) | T_rec (n, t') -> X_rec (n, xdr_type_term0 t') | T_refer (n, t') -> X_refer n | T_union_over_int (u,d) -> X_union_over_int (conv_htbl u, conv_option d) | T_union_over_uint (u,d) -> X_union_over_uint (conv_htbl u, conv_option d) | T_union_over_enum ( { term = T_enum e } as e_term ,u,d) -> let u' = List.flatten (Array.to_list (Array.mapi (fun k t'_opt -> match t'_opt with Some t' -> let name = fst(e.(k)) in [ name, xdr_type_term0 t' ] | None -> [] ) u ) ) in X_union_over_enum (xdr_type_term0 e_term, u', conv_option d) | T_direct (t', read, write, size) -> X_direct (xdr_type_term0 t',read, write, size) | _ -> assert false ;; let xdr_type_term (t:xdr_type) : xdr_type_term = xdr_type_term0 (fst t) let xdr_type_term_system (s:xdr_type_system) : xdr_type_term_system = List.map (fun (n,t) -> n,xdr_type_term t) s ;; (**********************************************************************) (* expand X_type members relative to given systems *) (**********************************************************************) (* The implementation of "expanded_xdr_type_term" repeats many phrases * that have been defined for "validate_xdr_type" in a very similar * way. * TODO: Currently many checks have been left out *) let rec expanded_xdr_type_term (s:xdr_type_term_system) (t:xdr_type_term) : xdr_type_term = match t with X_array_fixed (t',n) -> X_array_fixed ((expanded_xdr_type_term s t'), n) | X_array (t',n) -> X_array ((expanded_xdr_type_term s t'), n) | X_struct st -> let s_names, s_types = List.split st in X_struct (List.combine s_names (List.map (expanded_xdr_type_term s) s_types)) | X_union_over_int (u,default) -> let u_values, u_types = List.split u in let default' = match default with Some d -> Some (expanded_xdr_type_term s d) | None -> None in X_union_over_int (List.combine u_values (List.map (expanded_xdr_type_term s) u_types), default') | X_union_over_uint (u,default) -> let u_values, u_types = List.split u in let default' = match default with Some d -> Some (expanded_xdr_type_term s d) | None -> None in X_union_over_uint (List.combine u_values (List.map (expanded_xdr_type_term s) u_types), default') | X_union_over_enum (e,u,default) -> let u_values, u_types = List.split u in let default' = match default with Some d -> Some (expanded_xdr_type_term s d) | None -> None in X_union_over_enum ( (expanded_xdr_type_term s e), (List.combine u_values (List.map (expanded_xdr_type_term s) u_types)), default') | X_type n -> let rec r s1 s2 = match s2 with [] -> failwith ("Netxdr.expanded_xdr_type_term: cannot resolve X_type " ^ n) | (n',t') :: s2' -> if n = n' then expanded_xdr_type_term s1 t' else r (s1 @ [n',t']) s2' in r [] s | X_rec (n, t') -> X_rec (n, expanded_xdr_type_term s t') | X_direct (t',read, write, size) -> X_direct ((expanded_xdr_type_term s t'), read, write, size) | _ -> t ;; let expanded_xdr_type (s:xdr_type_system) (t:xdr_type_term) : xdr_type = try let t0 = validate_xdr_type_i1 (expand_X_type s) [] t in let t1 = elim_rec t0 in calc_min_size t0; calc_min_size t1; (t0,t1) with Not_found -> failwith "Netxdr.expanded_xdr_type: unspecified error" | Propagate s -> failwith ("Netxdr.expanded_xdr_type: " ^ s) ;; (**********************************************************************) (* test on compatibility *) (**********************************************************************) let are_compatible (s1:xdr_type) (s2:xdr_type) : bool = (* implementation: * enum, struct and union members can be swapped *) failwith "Netxdr.are_compatible: not implemented" ;; (**********************************************************************) (* common implementation of value_matches_type & pack_xdr_value *) (**********************************************************************) (* pack: interestingly, two loops over the value where one loop only determines the size of the final buffer are _faster_ than a single loop over the value doing everything. Whoever understands that. *) type encoder = Netxdr_mstring.mstring list -> Netxdr_mstring.mstring list type decoder = string -> int -> int -> (string * int) let overflow() = raise(Xdr_failure "overflow in ++") let ( ++ ) x y = (* pre: x >= 0 && y >= 0 *) let s = x + y in if s < 0 then overflow(); s let get_string_decoration_size x_len n = (* header field plus padding *) let x_len_u = uint4_of_int x_len in let x_len_mod_4 = x_len land 3 in if Netnumber.le_uint4 x_len_u n then begin (if x_len_mod_4 = 0 then 4 else 8 - x_len_mod_4 ) end else raise (Xdr_failure "string is longer than allowed") let sizefn_string n x = let x_len = String.length x in get_string_decoration_size x_len n + x_len let sizefn_mstring n x = let x_len = x#length in get_string_decoration_size x_len n + x_len let pack_size (v:xdr_value) (t:xdr_type0) (get_param:string->xdr_type) (get_encoder:string->encoder option) : int = (* returned size does not include mstrings! *) let rec get_size v t = match t.term with | T_int -> 4 | T_uint -> 4 | T_hyper -> 8 | T_uhyper -> 8 | T_enum e -> 4 | T_float -> 4 | T_double -> 8 | T_opaque_fixed n -> let x = dest_xv_opaque v in let i = int_of_uint4 n in if String.length x <> i then raise (Xdr_failure "opaque string has unexpected length"); let i4 = i land 3 in if i4=0 then i else i+(4-i4) | T_opaque n -> let x = dest_xv_opaque v in sizefn_string n x | T_string n -> let x = dest_xv_string v in sizefn_string n x | T_mstring(_,n) -> (* for an mstring we only count the length field plus padding *) let x = dest_xv_mstring v in let l = x#length in get_string_decoration_size l n | T_array_fixed (t',n) -> get_array_size v t' n (fun m n -> m=n) | T_array (t',n) -> 4 + get_array_size v t' n Netnumber.le_uint4 | T_struct s -> let v_array = map_xv_struct_fast0 t v in let sum = ref 0 in Array.iteri (fun k v_component -> sum := !sum ++ get_size v_component (snd s.(k))) v_array; !sum | T_union_over_int (u,default) -> let i,x = dest_xv_union_over_int v in let t' = try Hashtbl.find u i with Not_found -> match default with Some d -> d | None -> raise (Xdr_failure "T_union_over_int") in 4 ++ get_size x t' | T_union_over_uint (u,default) -> let i,x = dest_xv_union_over_uint v in let t' = try Hashtbl.find u i with Not_found -> match default with Some d -> d | None -> raise (Xdr_failure "T_union_over_uint") in 4 ++ get_size x t' | T_union_over_enum (et,u,default) -> let k,i,x = map_xv_union_over_enum_fast0 t v in let t' = match u.(k) with Some u_t -> u_t | None -> ( match default with Some d -> d | None -> raise (Xdr_failure "T_union_over_enum") ) in 4 ++ get_size x t' | T_void -> 0 | T_param n -> let t' = get_param n in let enc_opt = get_encoder n in if enc_opt = None then get_size v (snd t') else 0 | T_rec (n, t') -> get_size v t' | T_refer (n, t') -> get_size v t' | T_direct(t', _, _, _) -> ( match v with | XV_direct(_,size) -> size | _ -> get_size v t' ) and get_array_size v t' n cmp = (* w/o array header *) (* TODO: optimize arrays of types with fixed repr length *) match v with | XV_array x -> (* generic *) let m = uint4_of_int (Array.length x) in if cmp m n then ( let s = ref 0 in Array.iter (fun v' -> s := !s ++ get_size v' t') x; !s ) else raise (Xdr_failure "array length mismatch") | XV_array_of_string_fast x -> ( match t'.term with | T_string sn -> let m = uint4_of_int (Array.length x) in if cmp m n then ( let sum = ref 0 in Array.iter (fun s -> sum := !sum ++ sizefn_string sn s) x; !sum ) else raise (Xdr_failure "array length mismatch") | T_direct(t1, _, _, _) -> get_array_size v t1 n cmp | _ -> raise Dest_failure ) | _ -> raise Dest_failure in get_size v t let print_string_padding l buf pos = let n = 4-(l land 3) in if n < 4 then begin let p = !pos in if n >= 1 then String.unsafe_set buf p '\000'; if n >= 2 then String.unsafe_set buf (p + 1) '\000'; if n >= 3 then String.unsafe_set buf (p + 2) '\000'; pos := p + n end let rec pack_mstring (v:xdr_value) (t:xdr_type0) (get_param:string->xdr_type) (get_encoder:string->encoder option) : Netxdr_mstring.mstring list = (* The recursion over pack_mstring is only used for encoded parameters *) let size = pack_size v t get_param get_encoder in (* all sanity checks are done here! Also, [size] does not include the size for mstrings (only the length field, and padding), and it does not include encoded parameters *) let buf = String.create size in let buf_start = ref 0 in let buf_pos = ref 0 in let result = ref [] in (* The resulting mstrings in reverse order *) let save_buf() = if !buf_pos > !buf_start then ( let x = Netxdr_mstring.string_based_mstrings # create_from_string buf !buf_start (!buf_pos - !buf_start) false in result := x :: !result; buf_start := !buf_pos ) in let print_string s l = String.unsafe_blit s 0 buf !buf_pos l; buf_pos := !buf_pos + l; print_string_padding l buf buf_pos in let rec pack v t = match t.term with T_int -> let x = dest_xv_int v in Netnumber.BE.write_int4_unsafe buf !buf_pos x; buf_pos := !buf_pos + 4 | T_uint -> let x = dest_xv_uint v in Netnumber.BE.write_uint4_unsafe buf !buf_pos x; buf_pos := !buf_pos + 4 | T_hyper -> let x = dest_xv_hyper v in Netnumber.BE.write_int8_unsafe buf !buf_pos x; buf_pos := !buf_pos + 8 | T_uhyper -> let x = dest_xv_uhyper v in Netnumber.BE.write_uint8_unsafe buf !buf_pos x; buf_pos := !buf_pos + 8 | T_enum e -> let i = map_xv_enum_fast0 t v in Netnumber.BE.write_int4_unsafe buf !buf_pos (int4_of_int32 i); buf_pos := !buf_pos + 4 | T_float -> let x = dest_xv_float v in let s = Netnumber.BE.fp4_as_string x in String.unsafe_blit s 0 buf !buf_pos 4; buf_pos := !buf_pos + 4 | T_double -> let x = dest_xv_double v in let s = Netnumber.BE.fp8_as_string x in String.unsafe_blit s 0 buf !buf_pos 8; buf_pos := !buf_pos + 8 | T_opaque_fixed n -> let x = dest_xv_opaque v in print_string x (String.length x) | T_opaque n -> let x = dest_xv_opaque v in let x_len = String.length x in Netnumber.BE.write_uint4_unsafe buf !buf_pos (uint4_of_int x_len); buf_pos := !buf_pos + 4; print_string x x_len | T_string n -> let x = dest_xv_string v in let x_len = String.length x in Netnumber.BE.write_uint4_unsafe buf !buf_pos (uint4_of_int x_len); buf_pos := !buf_pos + 4; print_string x x_len | T_mstring(_,n) -> let x = dest_xv_mstring v in let x_len = x#length in Netnumber.BE.write_uint4_unsafe buf !buf_pos (uint4_of_int x_len); buf_pos := !buf_pos + 4; save_buf(); result := x :: !result; print_string_padding x_len buf buf_pos | T_array_fixed (t',n) -> pack_array v t' n false | T_array (t',n) -> pack_array v t' n true | T_struct s -> let v_array = map_xv_struct_fast0 t v in Array.iteri (fun k v_component -> pack v_component (snd s.(k))) v_array | T_union_over_int (u,default) -> let i,x = dest_xv_union_over_int v in let t' = try Hashtbl.find u i with Not_found -> match default with Some d -> d | None -> raise (Xdr_failure "T_union_over_int") in Netnumber.BE.write_int4_unsafe buf !buf_pos i; buf_pos := !buf_pos + 4; pack x t' | T_union_over_uint (u,default) -> let i,x = dest_xv_union_over_uint v in let t' = try Hashtbl.find u i with Not_found -> match default with Some d -> d | None -> raise (Xdr_failure "T_union_over_uint") in Netnumber.BE.write_uint4_unsafe buf !buf_pos i; buf_pos := !buf_pos + 4; pack x t' | T_union_over_enum (et,u,default) -> let k,i,x = map_xv_union_over_enum_fast0 t v in let t' = match u.(k) with Some u_t -> u_t | None -> ( match default with Some d -> d | None -> raise (Xdr_failure "T_union_over_enum") ) in Netnumber.BE.write_int4_unsafe buf !buf_pos (int4_of_int32 i); buf_pos := !buf_pos + 4; pack x t' | T_void -> () | T_param n -> let t' = get_param n in let enc_opt = get_encoder n in ( match enc_opt with | None -> pack v (snd t') | Some enc -> save_buf(); let l = pack_mstring v (snd t') (fun _ -> assert false) (fun _ -> assert false) in let e = enc l in result := List.rev e @ !result ) | T_rec (n, t') -> pack v t' | T_refer (n, t') -> pack v t' | T_direct(t', _, write, _) -> ( match v with | XV_direct(x,xv_size) -> let old = !buf_pos in write x buf buf_pos; (* Printf.eprintf "old=%d new=%d size=%d\n" old !buf_pos size; *) assert(!buf_pos = old + xv_size); | _ -> pack v t' ) and pack_array v t' n have_array_header = match v with | XV_array x -> (* generic *) if have_array_header then pack_array_header (Array.length x); Array.iter (fun v' -> pack v' t') x | XV_array_of_string_fast x -> ( match t'.term with | T_string n -> if have_array_header then pack_array_header (Array.length x); Array.iter (fun s -> let s_len = String.length s in Netnumber.BE.write_uint4_unsafe buf !buf_pos (uint4_of_int s_len); buf_pos := !buf_pos + 4; print_string s s_len ) x | T_direct(t1,_,_,_) -> pack_array v t1 n have_array_header | _ -> raise Dest_failure ) | _ -> raise Dest_failure and pack_array_header x_len = Netnumber.BE.write_uint4_unsafe buf !buf_pos (uint4_of_int x_len); buf_pos := !buf_pos + 4; in pack v t; save_buf(); List.rev !result ;; let write_string_fixed n x buf pos = (* exported *) let x_len = String.length x in if x_len <> n then raise (Xdr_failure "fixed string has bad length"); String.unsafe_blit x 0 buf !pos x_len; pos := !pos + x_len; print_string_padding x_len buf pos let write_string x buf pos = (* exported *) let x_len = String.length x in Netnumber.BE.write_uint4_unsafe buf !pos (uint4_of_int x_len); pos := !pos + 4; String.unsafe_blit x 0 buf !pos x_len; pos := !pos + x_len; print_string_padding x_len buf pos let value_matches_type (v:xdr_value) ((_,t):xdr_type) (p:(string * xdr_type) list) : bool = if StringSet.for_all (fun n -> List.mem_assoc n p) t.params && List.for_all (fun (n,t') -> StringSet.is_empty (fst t').params) p then try ignore(pack_size v t (fun n -> List.assoc n p) (fun _ -> None)); true with _ -> (* we assume here that no other errors can occur *) false else false ;; (**********************************************************************) (* pack and unpack values *) (**********************************************************************) let pack_xdr_value ?(encode = []) (v:xdr_value) ((_,t):xdr_type) (p:(string * xdr_type) list) (print:string->unit) : unit = (* DEBUG *) (* List.iter (fun pn -> prerr_endline ("param " ^ pn)) t.params; *) if StringSet.for_all (fun n -> List.mem_assoc n p) t.params && List.for_all (fun (n,t') -> StringSet.is_empty (fst t').params) p then try let mstrings = pack_mstring v t (fun n -> List.assoc n p) (fun n -> try Some(List.assoc n encode) with Not_found -> None) in List.iter (fun ms -> let (s,p) = ms#as_string in print (String.sub s p ms#length) ) mstrings with | Dest_failure -> raise(Xdr_failure "Netxdr.pack_xdr_value [2]: XDR type mismatch") | Netnumber.Cannot_represent _ -> raise(Xdr_failure "Netxdr.pack_xdr_value [3]: integer not representable") | Netnumber.Out_of_range -> raise(Xdr_failure "Netxdr.pack_xdr_value [4]: index out of range") | Failure s -> raise(Xdr_failure ("Netxdr.pack_xdr_value [5]: " ^ s)) else raise(Xdr_failure "Netxdr.pack_xdr_value [1]") ;; let pack_xdr_value_as_string ?(rm = false) ?(encode = []) (v:xdr_value) ((_,t):xdr_type) (p:(string * xdr_type) list) : string = if StringSet.for_all (fun n -> List.mem_assoc n p) t.params && List.for_all (fun (n,t') -> StringSet.is_empty (fst t').params) p then try let mstrings0 = pack_mstring v t (fun n -> List.assoc n p) (fun n -> try Some(List.assoc n encode) with Not_found -> None) in let rm_prefix = if rm then let s = "\000\000\000\000" in [ Netxdr_mstring.string_based_mstrings # create_from_string s 0 4 false ] else [] in let mstrings = rm_prefix @ mstrings0 in Netxdr_mstring.concat_mstrings mstrings with | Dest_failure -> (*let bt = Printexc.get_backtrace() in eprintf "Backtrace: %s\n" bt; *) raise(Xdr_failure "Netxdr.pack_xdr_value_as_string [2]: XDR type mismatch") | Netnumber.Cannot_represent _ -> raise(Xdr_failure "Netxdr.pack_xdr_value_as_string [3]: integer not representable") | Netnumber.Out_of_range -> raise(Xdr_failure "Netxdr.pack_xdr_value_as_string [4]: index out of range") | Failure s -> raise(Xdr_failure ("Netxdr.pack_xdr_value_as_string [5]: " ^ s)) else raise(Xdr_failure "Netxdr.pack_xdr_value_as_string [1]") ;; let pack_xdr_value_as_mstrings ?(encode = []) (v:xdr_value) ((_,t):xdr_type) (p:(string * xdr_type) list) = if StringSet.for_all (fun n -> List.mem_assoc n p) t.params && List.for_all (fun (n,t') -> StringSet.is_empty (fst t').params) p then try pack_mstring v t (fun n -> List.assoc n p) (fun n -> try Some(List.assoc n encode) with Not_found -> None) with | Dest_failure -> raise(Xdr_failure "Netxdr.pack_xdr_value_as_mstring [2]: XDR type mismatch") | Netnumber.Cannot_represent _ -> raise (Xdr_failure "Netxdr.pack_xdr_value_as_mstring [3]: integer not representable") | Netnumber.Out_of_range -> raise(Xdr_failure "Netxdr.pack_xdr_value_as_mstring [4]: index out of range") | Failure s -> raise(Xdr_failure ("Netxdr.pack_xdr_value_as_mstring [5]: " ^ s)) else raise(Xdr_failure "Netxdr.pack_xdr_value_as_mstring [1]") ;; (* "let rec" prevents that these functions are inlined. This is wanted here, because these are error cases, and for a function call less code is generated than for raising an exception *) let rec raise_xdr_format_too_short () = raise (Xdr_format "message too short") let rec raise_xdr_format_value_not_included () = raise (Xdr_format "value not included in enumeration") let rec raise_xdr_format_maximum_length () = raise (Xdr_format "maximum length of field exceeded") let rec raise_xdr_format_undefined_descriminator() = raise (Xdr_format "undefined discriminator") let rec find_enum (e : (string * int32) array) (i : int32) = (* no inlining! *) let rec loop lb ub = (* The element is between lb and ub *) if lb > ub then raise_xdr_format_value_not_included (); let m = (ub + lb) lsr 1 in let x_m = snd(e.(m)) in if i = x_m then (* Found! *) m else if i < x_m then loop lb (m-1) else (* i > x_m *) loop (m+1) ub in loop 0 (Array.length e - 1) ;; (* DEBUG*) (* let hex_dump_s s pos len = let b = Buffer.create 100 in for k = 0 to len - 1 do let c = s.[pos+k] in bprintf b "%02x " (Char.code c) done; Buffer.contents b *) let read_string_fixed n str k k_end = (* exported *) let k0 = !k in let m = if n land 3 = 0 then n else n+4-(n land 3) in if k0 > k_end - m then raise_xdr_format_too_short (); let s = String.create n in String.unsafe_blit str k0 s 0 n; k := k0 + m; s let read_string n str k k_end = (* exported *) let k0 = !k in k := k0 + 4; if !k > k_end then raise_xdr_format_too_short(); let m = Netnumber.BE.read_uint4_unsafe str k0 in (* Test: n < m as unsigned int32: *) if Netnumber.lt_uint4 n m then raise_xdr_format_maximum_length (); read_string_fixed (int_of_uint4 m) str k k_end let empty_mf = Hashtbl.create 1 let rec unpack_term ?(pos = 0) ?len ?(fast = false) ?(prefix = false) ?(mstring_factories = empty_mf) ?(xv_version = if fast then `Ocamlrpcgen else `V1) (str:string) (t:xdr_type0) (get_param:string->xdr_type) (get_decoder:string->decoder option) : xdr_value * int = (* The recursion over unpack_term is only used for decoding encrypted parameters *) let xv_version = if xv_version = `Ocamlrpcgen then `V4 else xv_version in let v2 = (xv_version <> `V1) in (* meaning: at least v2 *) let v3 = v2 && (xv_version <> `V2) in let v4 = v3 && (xv_version <> `V3) in let len = match len with None -> String.length str - pos | Some l -> l in if pos < 0 || len < 0 || len > String.length str - pos then invalid_arg "Netxdr.unpack_xdr_value"; let k_end = pos+len in let k = ref pos in let rec read_fp4 k0 = if k0 + 4 > k_end then raise_xdr_format_too_short(); k := !k + 4; Netnumber.BE.read_fp4 str k0 in let rec read_fp8 k0 = if k0 + 8 > k_end then raise_xdr_format_too_short(); k := !k + 8; Netnumber.BE.read_fp8 str k0 in let rec read_enum e k0 = k := k0 + 4; if !k > k_end then raise_xdr_format_too_short(); let i = Netnumber.int32_of_int4(Netnumber.BE.read_int4_unsafe str k0) in let j = find_enum e i in (* returns array position, or Xdr_format *) if v2 then XV_enum_fast j else XV_enum(fst(e.(j))) in let rec read_string_or_opaque n k0 = k := k0 + 4; if !k > k_end then raise_xdr_format_too_short(); let m = Netnumber.BE.read_uint4_unsafe str k0 in (* Test: n < m as unsigned int32: *) if Netnumber.lt_uint4 n m then raise_xdr_format_maximum_length (); read_string_fixed (int_of_uint4 m) str k k_end in let rec read_mstring name n k0 = let factory = try Hashtbl.find mstring_factories name with Not_found -> ( try Hashtbl.find mstring_factories "*" with Not_found -> failwith "read_mstring: no such factory" ) in k := k0 + 4; if !k > k_end then raise_xdr_format_too_short(); let m = Netnumber.BE.read_uint4_unsafe str k0 in (* Test: n < m as unsigned int32: *) if Netnumber.lt_uint4 n m then raise_xdr_format_maximum_length (); let m = int_of_uint4 m in let p = if m land 3 = 0 then m else m+4-(m land 3) in if !k > k_end - p then raise_xdr_format_too_short (); let ms = factory # create_from_string str !k m false in k := !k + p; ms in let rec unpack_array t' p = (* Estimate the maximum p *) (* eprintf "unpack_array: t' = %s\n" (t_name t'.term);*) assert(t'.min_size > 0); let p_max = (k_end - !k) / t'.min_size in if p > p_max then raise_xdr_format_too_short(); match t'.term with | T_string n -> let n' = Netnumber.logical_int32_of_uint4 n in let a = Array.make p "" in let k' = Netsys_xdr.s_read_string_array_unsafe str !k (k_end - !k) n' a in if k' = (-1) then raise_xdr_format_too_short(); if k' = (-2) then raise_xdr_format_maximum_length (); k := k'; if v3 then XV_array_of_string_fast a else XV_array(Array.map (fun s -> XV_string s) a) | _ -> let a = Array.make p XV_void in for i = 0 to p-1 do Array.unsafe_set a i (unpack t') done; XV_array a and unpack t = let k0 = !k in (* fprintf stderr "unpack k=%d t=%s\n%!" k0 (t_name t.term); *) match t.term with T_int -> k := k0 + 4; if !k > k_end then raise_xdr_format_too_short(); XV_int (Netnumber.BE.read_int4_unsafe str k0) | T_uint -> k := k0 + 4; if !k > k_end then raise_xdr_format_too_short(); XV_uint (Netnumber.BE.read_uint4_unsafe str k0) | T_hyper -> k := k0 + 8; if !k > k_end then raise_xdr_format_too_short(); XV_hyper (Netnumber.BE.read_int8_unsafe str k0) | T_uhyper -> k := !k + 8; if k0 > k_end then raise_xdr_format_too_short(); XV_uhyper (Netnumber.BE.read_uint8_unsafe str k0) | T_enum e -> read_enum e k0 | T_float -> XV_float (read_fp4 k0) | T_double -> XV_double (read_fp8 k0) | T_opaque_fixed n -> XV_opaque (read_string_fixed (int_of_uint4 n) str k k_end) | T_opaque n -> XV_opaque (read_string_or_opaque n k0) | T_string n -> XV_string (read_string_or_opaque n k0) | T_mstring(name,n) -> XV_mstring (read_mstring name n k0) | T_array_fixed (t',n) -> let p = int_of_uint4 n in unpack_array t' p | T_array (t',n) -> k := k0 + 4; let m = Netnumber.BE.read_uint4 str k0 in if Netnumber.lt_uint4 n m then raise_xdr_format_maximum_length (); unpack_array t' (int_of_uint4 m) | T_struct s -> if v2 then XV_struct_fast ( Array.map (fun (name,t') -> unpack t') s ) else XV_struct (List.map (fun (name,t') -> (name,unpack t')) (Array.to_list s) ) | T_union_over_int (u,default) -> unpack_union_over_int u default k0 | T_union_over_uint (u,default) -> unpack_union_over_uint u default k0 | T_union_over_enum ( { term = T_enum e },u,default) -> unpack_union_over_enum e u default k0 | T_void -> XV_void | T_param p -> let t' = get_param p in let dec_opt = get_decoder p in ( match dec_opt with | None -> unpack (snd t') | Some decoder -> let (dec_s, n) = decoder str k0 (k_end - k0) in k := !k + n; assert( !k <= k_end ); let (v, p) = unpack_term ~mstring_factories ~xv_version dec_s (snd t') (fun _ -> assert false) (fun _ -> None) in v ) | T_rec (_, t') | T_refer (_, t') -> unpack t' | T_direct(t', read, _, _) -> if v4 then let k0 = !k in let xv = read str k k_end in XV_direct(xv, !k-k0) else unpack t' | _ -> assert false and unpack_union_over_int u default k0 = k := k0 + 4; let n = Netnumber.BE.read_int4 str k0 in let t' = try Hashtbl.find u n with Not_found -> match default with None -> raise_xdr_format_undefined_descriminator() | Some d -> d in XV_union_over_int (n, unpack t') and unpack_union_over_uint u default k0 = k := k0 + 4; let n = Netnumber.BE.read_uint4 str k0 in let t' = try Hashtbl.find u n with Not_found -> match default with None -> raise_xdr_format_undefined_descriminator() | Some d -> d in XV_union_over_uint (n, unpack t') and unpack_union_over_enum e u default k0 = k := k0 + 4; let i = Netnumber.int32_of_int4 (Netnumber.BE.read_int4 str k0) in let j = find_enum e i (* returns array position, or Xdr_format *) in let t' = match u.(j) with Some u_t -> u_t | None -> ( match default with Some d -> d | None -> raise_xdr_format_undefined_descriminator() ) in if v2 then XV_union_over_enum_fast(j, unpack t') else let name = fst(e.(j)) in XV_union_over_enum(name, unpack t') in try let v = unpack t in if prefix || !k = k_end then (v, !k - pos) else ( (* fprintf stderr "Too LONG: k=%d k_end=%d\n%!" !k k_end; fprintf stderr "Dump: %s\n%!" (hex_dump_s str pos (k_end-pos)); *) raise (Xdr_format_message_too_long v) ) with Cannot_represent _ -> raise (Xdr_format "implementation restriction") | Out_of_range -> raise (Xdr_format "message too short") ;; let unpack_xdr_value ?pos ?len ?fast ?prefix ?mstring_factories ?xv_version ?(decode=[]) (str:string) ((_,t):xdr_type) (p:(string * xdr_type) list) : xdr_value = if StringSet.for_all (fun n -> List.mem_assoc n p) t.params && List.for_all (fun (n,t') -> StringSet.is_empty (fst t').params) p then fst(unpack_term ?pos ?len ?fast ?prefix ?mstring_factories ?xv_version str t (fun n -> List.assoc n p) (fun n -> try Some(List.assoc n decode) with Not_found -> None) ) else failwith "Netxdr.unpack_xdr_value" ;; let unpack_xdr_value_l ?pos ?len ?fast ?prefix ?mstring_factories ?xv_version ?(decode=[]) (str:string) ((_,t):xdr_type) (p:(string * xdr_type) list) : xdr_value * int = if StringSet.for_all (fun n -> List.mem_assoc n p) t.params && List.for_all (fun (n,t') -> StringSet.is_empty (fst t').params) p then unpack_term ?pos ?len ?fast ?prefix ?mstring_factories ?xv_version str t (fun n -> List.assoc n p) (fun n -> try Some(List.assoc n decode) with Not_found -> None) else failwith "Netxdr.unpack_xdr_value" ;; ocamlnet-4.0.4/src/netstring/netdn.ml0000644000175000017500000002111412541553661016222 0ustar gerdgerd(* $Id: netdn.ml 2195 2015-01-01 12:23:39Z gerd $ *) open Printf type oid = Netoid.t type dn = (oid * Netasn1.Value.value) list list module type AT_LOOKUP = sig val attribute_types : (oid * string * string list) list val lookup_attribute_type_by_oid : oid -> string * string list val lookup_attribute_type_by_name : string -> oid * string * string list end module type DN_string = sig val parse : string -> dn val print : dn -> string end let () = Netmappings_asn1.init() (* ensure that asn1 tables are linked in *) let directory_string_from_ASN1 value = let fail_enc() = failwith "Netx509.directory_string_from_ASN1: bad input encoding" in match value with | Netasn1.Value.UTF8String s -> ( try Netconversion.verify `Enc_utf8 s with Netconversion.Malformed_code_at _ -> fail_enc() ); s | Netasn1.Value.PrintableString s -> ( try Netconversion.convert ~in_enc:`Enc_asn1_printable ~out_enc:`Enc_utf8 s with Netconversion.Malformed_code -> fail_enc() ) | Netasn1.Value.IA5String s -> ( try Netconversion.convert ~in_enc:`Enc_usascii ~out_enc:`Enc_utf8 s with Netconversion.Malformed_code -> fail_enc() ) | Netasn1.Value.TeletexString s -> ( try Netconversion.convert ~in_enc:`Enc_asn1_T61 ~out_enc:`Enc_utf8 s with Netconversion.Malformed_code -> fail_enc() ) | Netasn1.Value.BMPString s -> ( try Netconversion.convert ~in_enc:`Enc_utf16_be ~out_enc:`Enc_utf8 s with Netconversion.Malformed_code -> fail_enc() ) | Netasn1.Value.UniversalString s -> ( try Netconversion.convert ~in_enc:`Enc_utf32_be ~out_enc:`Enc_utf8 s with Netconversion.Malformed_code -> fail_enc() ) | _ -> failwith "Netx509.directory_string_from_ASN1: \ unsupported ASN.1 value type" module DN_string_generic(L : AT_LOOKUP) = struct type token = | Space | Quote | Hash | Plus | Comma | Semi | Less | Equal | Greater | Text of (string * bool) (* bool: whether there were escaped chars when decoding the text *) let illegal_esc() = failwith "Netdn.DN_string.parse: illegal escape sequence" let syntax_error() = failwith "Netdn.DN_string.parse: syntax error" let hex_val s = int_of_string ("0x" ^ s) let tokenize s = let l = String.length s in let b = Buffer.create 80 in let b_esc = ref false in let rec next k = if k < l then ( match s.[k] with | ' ' -> special Space (k+1) | '"' -> special Quote (k+1) | '#' -> special Hash (k+1) | '+' -> special Plus (k+1) | ',' -> special Comma (k+1) | ';' -> special Semi (k+1) | '<' -> special Less (k+1) | '=' -> special Equal (k+1) | '>' -> special Greater (k+1) | '\\' -> if k+1 < l then match s.[k+1] with | ( ' ' | '"' | '#' | '+' | ',' | ';' | '<' | '=' | '>' | '\\' ) as c -> Buffer.add_char b c; b_esc := true; next (k+2) | ( '0' .. '9' | 'A' .. 'F' | 'a' .. 'f' ) as c1 -> if k+2 < l then match s.[k+2] with | ( '0' .. '9' | 'A' .. 'F' | 'a' .. 'f' ) as c2 -> let h = String.create 2 in h.[0] <- c1; h.[1] <- c2; let v = hex_val h in Buffer.add_char b (Char.chr v); b_esc := true; next (k+3) | _ -> illegal_esc() else illegal_esc() | _ -> illegal_esc() else illegal_esc() | c -> Buffer.add_char b c; next (k+1) ) else if Buffer.length b > 0 then [ Text (Buffer.contents b, !b_esc) ] else [] and special token k = if Buffer.length b > 0 then ( let u = Buffer.contents b in let e = !b_esc in Buffer.clear b; b_esc := false; Text(u,e) :: token :: next k ) else token :: next k in next 0 let rec skip_spaces toks = (* until the next Equal token *) match toks with | Space :: toks' -> skip_spaces toks' | Equal :: toks' -> toks | other :: toks' -> other :: skip_spaces toks' | [] -> [] let descr_re = Netstring_str.regexp "^[A-Za-z][A-Za-z0-9-]*$" let parse s = let rec parse_rdn cur toks = let toks = skip_spaces toks in match toks with | Text(name,esc) :: Equal :: toks1 -> if esc then illegal_esc(); if Netstring_str.string_match descr_re name 0 <> None then ( (* it's a descr *) let name_uc = String.uppercase name in let (oid, _, _) = try L.lookup_attribute_type_by_name name_uc with Not_found -> failwith ("Netdn.DN_string.parse: unknown attribute '" ^ name ^ "'") in parse_value cur oid toks1 ) else ( try let oid = Netoid.of_string name in parse_value cur oid toks1 with | _ -> syntax_error() ) | _ -> syntax_error() and parse_value cur oid toks = match toks with | Hash :: _ -> failwith "Netdn.DN_string.parse: hex-encoded values are not \ supported by this parser" | Space :: toks1 -> (* CHECK *) parse_value cur oid toks1 | _ -> parse_value_rest cur oid [] toks and parse_value_rest cur oid value toks = match toks with | Plus :: toks1 -> let ava = (oid, utf8 (String.concat "" (List.rev value))) in parse_rdn (ava :: cur) toks1 | Comma :: toks1 -> let ava = (oid, utf8 (String.concat "" (List.rev value))) in let rdn = List.rev (ava :: cur) in rdn :: parse_rdn [] toks1 | Text(s,_) :: toks1 -> parse_value_rest cur oid (s :: value) toks1 | Hash :: toks1 -> parse_value_rest cur oid ("#" :: value) toks1 | Equal :: toks1 -> parse_value_rest cur oid ("=" :: value) toks1 | Space :: toks1 -> parse_value_rest cur oid (" " :: value) toks1 | (Quote | Semi | Less | Greater) :: toks1 -> syntax_error() | [] -> let ava = (oid, utf8 (String.concat "" (List.rev value))) in let rdn = List.rev (ava :: cur) in [ rdn ] and utf8 s = try Netconversion.verify `Enc_utf8 s; Netasn1.Value.UTF8String s with | Netconversion.Malformed_code_at _ -> failwith "Netdn.DN_string.parse: not in UTF-8" in parse_rdn [] (tokenize s) let string_of_ava (oid, value) = let oid_str = try let (_, l) = L.lookup_attribute_type_by_oid oid in if l = [] then raise Not_found; List.hd l with Not_found -> Netoid.to_string oid in let u = directory_string_from_ASN1 value in let b = Buffer.create 80 in Buffer.add_string b oid_str; Buffer.add_char b '='; let l = String.length u in for k = 0 to l - 1 do match String.unsafe_get u k with | ' ' -> if k=0 || k=l-1 then Buffer.add_string b "\\20" else Buffer.add_char b ' ' | '#' -> if k=0 then Buffer.add_string b "\\23" else Buffer.add_char b '#' | ('"' | '+' | ',' | ';' | '<' | '>' | '\\') as c -> Buffer.add_string b (sprintf "\\%02x" (Char.code c)) | c -> Buffer.add_char b c done; Buffer.contents b let print dn = String.concat "," (List.map (fun rdn -> String.concat "+" (List.map string_of_ava rdn) ) dn ) end ocamlnet-4.0.4/src/netstring/netdb.mli0000644000175000017500000000266212541553661016366 0ustar gerdgerd(* $Id: netdb.mli 2195 2015-01-01 12:23:39Z gerd $ * ---------------------------------------------------------------------- * *) (* This is an internal interface of ocamlnet! Do not use outside! *) (* This module manages persistent values (often lookup tables). These * values can be stored in external files, or they can be initialized * from string values. *) val read_db : string -> string (* Reads the value with the given name, and returns it. * * First it is checked whether there was a set_db call, and if so, * this value is unmarshalled and returned. Otherwise, it is checked * whether there is a loader, and if so, it is called. * * In both cases the checksum is checked. *) val exists_db : string -> bool (* Checks whether the named value is available, i.e. read_db would * be able to find it *) val set_db_checksum : string -> string -> unit (* [set_db_checksum key cksum]: sets the MD5 digest of this key *) val set_db : string -> string -> unit (* Sets the persistent value with the given name (1st arg) to the * passed value (2nd arg). The value must be marshalled as string. *) val set_db_loader : string -> (string -> string) -> unit (* [set_db_loader key loader]: sets a loader for this key, which is called when set_db has not been set for this key. The arg of the loader is the key. *) val enable_db_loaders : bool -> unit (* Whether dynamic loading is enabled *) ocamlnet-4.0.4/src/netstring/netmime_channels.ml0000644000175000017500000002055612541553661020434 0ustar gerdgerd(* $Id: netmime_channels.ml 2195 2015-01-01 12:23:39Z gerd $ *) open Netmime open Netchannels let read_mime_header ?(unfold=false) ?(strip=true) ?(ro=false) stream = let h = Netmime_string.read_header ~downcase:false ~unfold ~strip stream in let hobj = new basic_mime_header h in if ro then wrap_mime_header_ro hobj else hobj ;; type multipart_style = [ `None | `Flat | `Deep ] ;; let decode_mime_body hdr = let encoding = try Netmime_header.get_content_transfer_encoding hdr with Not_found -> "7bit" in match encoding with ("7bit"|"8bit"|"binary") -> (fun s -> s) | "base64" -> (fun s -> new output_filter (new Netencoding.Base64.decoding_pipe ~url_variant:false ~accept_spaces:true ()) s) | "quoted-printable" -> (fun s -> new output_filter (new Netencoding.QuotedPrintable.decoding_pipe()) s) | _ -> failwith "Netmime.decode_mime_body: Unknown Content-transfer-encoding" ;; let encode_mime_body ?(crlf = true) hdr = let encoding = try Netmime_header.get_content_transfer_encoding hdr with Not_found -> "7bit" in match encoding with ("7bit"|"8bit"|"binary") -> (fun s -> s) | "base64" -> (fun s -> new output_filter (new Netencoding.Base64.encoding_pipe ~linelength:76 ~crlf ()) s) | "quoted-printable" -> (fun s -> new output_filter (new Netencoding.QuotedPrintable.encoding_pipe ~crlf ()) s) | _ -> failwith "Netmime.encode_mime_body: Unknown Content-transfer-encoding" ;; let storage ?fin : store -> (mime_body * out_obj_channel) = function `Memory -> let body = new memory_mime_body "" in let body_ch = body#open_value_wr() in body, body_ch | `File filename -> let body = new file_mime_body ?fin filename in let body_ch = body#open_value_wr() in body, body_ch ;; let rec read_mime_message1 ?unfold ?strip ?(multipart_style = (`Deep : multipart_style)) ?(storage_style = fun _ -> storage `Memory) stream : complex_mime_message = (* First read the header: *) let h_obj = read_mime_header ?unfold ?strip ~ro:false stream in let mime_type, mime_type_params = try Netmime_header.get_content_type h_obj with Not_found -> "", [] in let multipart = "multipart/" in let is_multipart_type = (String.length mime_type >= String.length multipart) && (String.sub mime_type 0 (String.length multipart) = multipart) in (* Now parse the body, (with multiparts or without) *) let body = if is_multipart_type && multipart_style <> `None then begin (* --- Divide the message into parts: --- *) let boundary = try List.assoc "boundary" mime_type_params with Not_found -> failwith "Netmime.read_mime_message: missing boundary parameter" in let multipart_style = (* of the sub parser *) if multipart_style = `Flat then `None else multipart_style in `Parts (Netmime_string.read_multipart_body (read_mime_message1 ~multipart_style ~storage_style) (Netmime_string.param_value boundary) stream ) end else begin (* --- Read the body and optionally decode it: --- *) (* Where to store the body: *) let decoder = decode_mime_body h_obj in let body, body_ch = storage_style h_obj in if with_out_obj_channel (decoder body_ch) (fun body_ch' -> body_ch' # output_channel (stream :> in_obj_channel); body_ch' <> body_ch ) then body_ch # close_out(); `Body body end in (h_obj, body) ;; let read_mime_message ?unfold ?strip ?(ro=false) ?multipart_style ?storage_style stream = let msg = read_mime_message1 ?unfold ?strip ?multipart_style ?storage_style stream in if ro then wrap_complex_mime_message_ro (msg :> complex_mime_message_ro) else msg let rec augment_message (hdr,cbody) = (* Computes the content-transfer-encoding field for multipart messages. * The resulting message uses `Parts_ag(cte,parts) instead of `Parts(parts) * where cte is the content-transfer-encoding field. *) match cbody with `Body _ as b -> (hdr,b) | `Parts p -> let p' = List.map augment_message p in let mp_cte_id = List.fold_left (fun x (hdr,body) -> let cte = match body with `Body _ -> (try Netmime_header.get_content_transfer_encoding hdr with Not_found -> "7bit") | `Parts_ag(cte,_) -> cte in let cte_id = match cte with "7bit" | "quoted-printable" | "base64" -> 0 | "8bit" -> 1 | _ -> 2 in max x cte_id ) 0 p' in let mp_cte = match mp_cte_id with 0 -> "7bit" | 1 -> "8bit" | 2 -> "binary" | _ -> assert false in (hdr, `Parts_ag(mp_cte,p')) ;; let rec write_mime_message_int ?(wr_header = true) ?(wr_body = true) ?(nr = 0) ?ret_boundary ?(crlf = true) outch (hdr,cbody) = let eol = if crlf then "\r\n" else "\n" in let mk_boundary parts = (* For performance reasons, gather random data only from the first * `Body *) let rec gather_data parts = match parts with (_,`Body body) :: parts' -> let s = String.make 240 ' ' in (* So it is in the minor heap *) with_in_obj_channel (body # open_value_rd()) (fun ch -> try ignore(ch # input s 0 240) with End_of_file -> () (* When body is empty *) ); [s] | (_,`Parts_ag(_, parts'')) :: parts' -> (try gather_data parts'' with Not_found -> gather_data parts') | [] -> raise Not_found in let data = try gather_data parts with Not_found -> [] in Netmime_string.create_boundary ~random:data ~nr () in match cbody with `Body body -> (* Write the header as it is, and append the body *) if wr_header then Netmime_string.write_header ~eol ~soft_eol:eol outch hdr#fields; if wr_body then begin let outch' = encode_mime_body ~crlf hdr outch in with_in_obj_channel (body # open_value_rd()) (fun bodych -> outch' # output_channel bodych); if outch' <> outch then outch' # close_out(); end | `Parts_ag(cte,parts) -> if parts = [] then failwith "Netmime.write_mime_message: Cannot write multipart message with empty list of parts"; (* If the header does not include a proper content-type field, repair * this now. *) let hdr' = new basic_mime_header hdr#fields in (* hdr' will contain the repaired header as side effect *) let boundary = try let ctype,params = try Netmime_header.get_content_type hdr (* or Not_found *) with Not_found as ex -> raise ex (* falls through to next [try] *) | ex -> failwith ("Netmime.write_mime_message: Cannot parse content-type field: " ^ Netexn.to_string ex) in if String.length ctype < 10 || String.sub ctype 0 10 <> "multipart/" then failwith "Netmime.write_mime_message: The content type of a multipart message must be 'multipart/*'"; try let b = List.assoc "boundary" params in (* or Not_found *) Netmime_string.param_value b with Not_found -> (* Add the missing boundary parameter: *) let b = mk_boundary parts in let ctype_field = hdr # field "content-type" ^ ";" ^ eol ^ " boundary=\"" ^ b ^ "\"" in hdr' # update_field "content-type" ctype_field; b with Not_found -> (* Add the missing content-type header: *) let b = mk_boundary parts in let ctype_field = "multipart/mixed;" ^ eol ^ " boundary=\"" ^ b ^ "\"" in hdr' # update_field "content-type" ctype_field; b in (* Now fix the content-transfer-encoding field *) hdr' # update_field "content-transfer-encoding" cte; (* Write now the header fields *) if wr_header then Netmime_string.write_header ~eol ~soft_eol:eol outch hdr'#fields; (* Write the parts: *) if wr_body then begin let boundary_string = "--" ^ boundary ^ eol in List.iter (fun part -> outch # output_string boundary_string; write_mime_message_int ~wr_header:true ~wr_body:true ~nr:(nr + 1) ~crlf outch part; outch # output_string eol; ) parts; outch # output_string ("--" ^ boundary ^ "--" ^ eol); end; ( match ret_boundary with None -> () | Some r -> r := boundary ) ;; let write_mime_message ?wr_header ?wr_body ?nr ?ret_boundary ?crlf ch msg = write_mime_message_int ?wr_header ?wr_body ?nr ?ret_boundary ?crlf ch (augment_message msg) ;; ocamlnet-4.0.4/src/netstring/netchannels_crypto.mli0000644000175000017500000000606412541553661021174 0ustar gerdgerd(* $Id: netchannels_crypto.mli 2195 2015-01-01 12:23:39Z gerd $ *) (** Crypto extensions for {!Netchannels} *) (** {1:tls TLS} *) (** A TLS channel is a layer on top of a bidirectional channel that adds the TLS protocol. *) class type tls_channel = object inherit Netchannels.raw_io_channel method tls_endpoint : Netsys_crypto_types.tls_endpoint end class tls_layer : ?start_pos_in:int -> ?start_pos_out:int -> ?resume:string -> role:[ `Client | `Server ] -> rd:Netchannels.raw_in_channel -> wr:Netchannels.raw_out_channel -> peer_name:string option -> Netsys_crypto_types.tls_config -> tls_channel (** Adds TLS security to an already established connection, here made available as separate channels for input and output. The TLS handshake is done on the first I/O activity (call [flush] to enforce it). [resume]: see {!Netsys_tls.create_file_endpoint}. *) class tls_endpoint : ?start_pos_in:int -> ?start_pos_out:int -> ?resume:string -> role:[ `Client | `Server ] -> peer_name:string option -> Unix.file_descr -> Netsys_crypto_types.tls_config -> tls_channel (** This class is slightly more efficient than [tls_layer], and to preferred if you have direct access to the file descriptors. *) (** {1:symmetric Symmetric Cryptography} *) (** Encrypt or decrypt data while writing to a channel *) class type crypto_out_filter = object inherit Netchannels.out_obj_channel method supports_aead : bool (** Whether the cipher supports authentication, and will provide a MAC *) method mac : unit -> string (** Get the MAC of the processed data *) end (** Encrypt or decrypt data while reading from a channel *) class type crypto_in_filter = object inherit Netchannels.in_obj_channel method supports_aead : bool (** Whether the cipher supports authentication, and will provide a MAC *) method mac : unit -> string (** Get the MAC of the processed data *) end val encrypt_out : Netsys_ciphers.cipher_ctx -> Netchannels.out_obj_channel -> crypto_out_filter (** [let ch2 = encrypt_out ctx ch1]: Writing to [ch2] encrypts the data and writes the ciphertext to [ch1]. Closing [ch2] will flush data and close [ch1]. *) val encrypt_in : Netsys_ciphers.cipher_ctx -> Netchannels.in_obj_channel -> crypto_in_filter (** [let ch2 = encrypt_in ctx ch1]: Reading from [ch2] encrypts the data from [ch1]. Closing [ch2] will close [ch1]. *) val decrypt_out : Netsys_ciphers.cipher_ctx -> Netchannels.out_obj_channel -> crypto_out_filter (** [let ch2 = decrypt_out ctx ch1]: Writing to [ch2] decrypts the data and writes the plaintext to [ch1]. Closing [ch2] will flush data and close [ch1]. *) val decrypt_in : Netsys_ciphers.cipher_ctx -> Netchannels.in_obj_channel -> crypto_in_filter (** [let ch2 = decrypt_in ctx ch1]: Reading from [ch2] decrypts the data from [ch1]. Closing [ch2] will close [ch1]. *) ocamlnet-4.0.4/src/netstring/netconst.mli0000644000175000017500000000021012541553661017112 0ustar gerdgerd(* $Id: netconst.mli 1015 2006-10-02 13:54:31Z gerd $ *) val ocamlnet_version : string (* Returns the version string of Ocamlnet *) ocamlnet-4.0.4/src/netstring/netsendmail.mli0000644000175000017500000003476612541553661017607 0ustar gerdgerd(* $Id: netsendmail.mli 2195 2015-01-01 12:23:39Z gerd $ * ---------------------------------------------------------------------- * *) (** Functions to compose and send electronic mails * * {b Contents} * * - {!Netsendmail.composing} * - {!Netsendmail.sending} * * The tutorial has been moved to {!Netsendmail_tut}. *) (** {1:composing Composing Messages} * * The core function is {!Netsendmail.compose} generating a MIME mail. * The mail can be sent with {!Netsendmail.sendmail}, written to an * object channel with {!Netmime.write_mime_message}, or postprocessed * by a user function. * * The call to [compose] can be as easy as * * {[ compose ~from_addr:("me", "me\@domain.net") * ~to_addrs:["you", "you\@domain.com"] * ~subject:"I have a message for you" * "Hello, this is my message!\n" * ]} * * This call generates the message as {!Netmime.complex_mime_message}, * and can be directly sent with {!Netsendmail.sendmail}. * * The [compose] function is the simplified interface; alternatively one * can also generate the mail by calling {!Netsendmail.wrap_mail}, * {!Netsendmail.wrap_parts}, and {!Netsendmail.wrap_attachment}, getting * more fine-grained control of certain options. *) val compose : ?in_charset:Netconversion.encoding -> ?out_charset:Netconversion.encoding -> ?from_addr:(string * string) -> ?cc_addrs:(string * string) list -> ?bcc_addrs:(string * string) list -> ?content_type:(string * (string * Netmime_string.s_param) list) -> ?container_type:(string * (string * Netmime_string.s_param) list) -> ?attachments:Netmime.complex_mime_message list -> to_addrs:(string * string) list -> subject:string -> (* text:*) string -> Netmime.complex_mime_message (** Composes a mail message with a main text, and optionally * a number of attachments. * * The addresses [from_addr], [to_addrs], [cc_addrs], and [bcc_addrs] are * passed as pairs [(human_readable,formal)] where * [human_readable] is an arbitrary printable string identifying the * sender/receiver, and where [formal] is the RFC-822 mailbox specification. * An example is [("Stolpmann, Gerd", "gerd\@gerd-stolpmann.de")]. * * The [subject] can be any text. * * The anonymous [string] argument is the main text of the mail. * * The resulting message is always a correct MIME message. * * @param in_charset All passed texts (except the formal addresses) must * be encoded in [in_charset]. Default: [`Enc_iso88591]. * As another exception, setting [content_type] explicitly prevents * the main text from being converted, and [in_charset] does not * have a meaning for the main text. * @param out_charset The encoded words in the generated header fields, * if necessary, and the main text are encoded in [out_charset]. * Default: [`Enc_iso88591]. * It is required that [out_charset] is ASCII-compatible. * As a special rule, setting [content_type] explicitly prevents * the main text from being converted to [out_charset]. * @param content_type The content type of the main text. The list is * the list of parameters attached * to the type, e.g. [("text/plain", ["charset", mk_param "ISO-8859-1"])] * (see {!Netmime_string.mk_param}). When this argument is set, * the main text is no longer converted to [out_charset]. * By default, when this argument is missing, the main text is * converted from [in_charset] to [out_charset], and the * content type becomes ["text/plain; charset="]. * @param container_type The content type of the container wrapping the * main text and the attachment into one entity * (only used if [attachments] are present). This * defaults to [("multipart/mixed", [])]. This must be either a * "multipart" or "message" type. * @param attachments An optional list of attachments. Should be generated * with [wrap_attachment]. *) (** {b Character Set Conversion} * * The impact of [in_charset] and [out_charset] on the generated mail * is not very obvious. The charset arguments may have an effect on * the mail header and the mail body. * * The mail header can only be composed of ASCII characters (7 bit). * To circumvent this restriction the MIME standard specifies a special * format, the so-called encoded words. These may only be used in some * places, and [compose] knows where: In the subject, and the non-formal * part of mail addresses. The [out_charset] is the character set * used in the generated mail. The [in_charset] is the character set * the strings are encoded you pass to [compose]. It is a good idea * to have [in_charset = out_charset], or at least choose [out_charset] * as a superset of [in_charset], because this ensures that the character * set conversion succeeds. * * If the mail header does not make use of the additional non-ASCII * characters, the encoded words will be avoided. * * The mail body is only subject of character set conversion if * the [content_type] is {b not} passed to [compose]. In this case, * the function sets it to [text/plain], and converts the message * from [in_charset] to [out_charset]. * * {b Adding Attachments} * * To generate the attachments, call {!Netsendmail.wrap_attachment}, e.g. * * {[ compose ... * ~attachments:[ wrap_attachment * ~content_type:("application/octet-stream", []) * (new Netmime.file_mime_body "file.tar.gz") ] * ]} * * There * are a number of kinds of attaching files, identified by [container_type]. * The default is [multipart/mixed], meaning that the parts of the mail are * mixed messages and files. One can give a hint whether to display * the parts directly in the mailer program (so-called inline attachments), * or whether to suggest that the file is saved to disk ("real" * attachments). This hint is contained in the [Content-disposition] * header, see [wrap_attachment] how to set it. * * For a discusion of the other [container_type]s see the * {!Netsendmail.tutorial} at the end of this document. *) val wrap_attachment : ?in_charset:Netconversion.encoding -> ?out_charset:Netconversion.encoding -> ?content_id:string -> ?content_description:string -> ?content_location:string -> ?content_disposition:(string * (string * Netmime_string.s_param) list) -> content_type:(string * (string * Netmime_string.s_param) list) -> Netmime.mime_body -> Netmime.complex_mime_message (** Generates a header for the [mime_body]. The returned value * is intended to be used as input for the [attachments] argument * of the [compose] function: * * {[ * compose ... * ~attachments:[ wrap_attachment * ~content_type:("audio/wav", []) * (new file_mime_body "music.wav") ] * ]} * * The header contains at least the [Content-type] and the * [Content-transfer-encoding] fields. The latter is currently * always ["base64"], but it is possible that the function is * changed in the future to also generate ["quoted-printable"] * when applicable. * * @param in_charset The encoding of the [content_description] argument. * Default: [`Enc_iso88591]. * @param out_charset The encoding of the generated [Content-Description] * header. Default: [`Enc_iso88591]. * @param content_type Specifies the content type with main * type and list of parameters. Example: * [ ("text/plain", ["charset", Netmime_string.mk_param "ISO-8859-1" ]) ] * (see {!Netmime_string.mk_param}) * @param content_disposition Optionally sets the [Content-disposition] * header. Frequent values are * - [ ("inline", []) ]: Indicates that the attachment is displayed * together with the main text * - [ ("attachment", ["filename", Netmime_string.mk_param fn]) ]: Indicates * that the attachment should be stored onto the disk. The * parameter [fn] is the suggested file name. Note that [fn] * should only consist of ASCII characters unless the [charset] * argument of [mk_param] is set to a different character encoding. * @param content_id Optionally sets the [Content-ID] header field. * The passed string is the ID value without the embracing angle * brackets. The [Content-ID] can be used to refer to the attachment * from other parts of the mail, e.g. in [multipart/related] mails * HTML documents can include hyperlinks to attachments using the * URL syntax [cid:ID] where [ID] is the ID value. * @param content_description The [Content-Description] header * @param content_location The [Content-Location] header. This must be * a valid URL, only composed of 7 bit characters, and with escaped * unsafe characters *) val wrap_mail : ?in_charset:Netconversion.encoding -> ?out_charset:Netconversion.encoding -> ?from_addr:(string * string) -> ?cc_addrs:(string * string) list -> ?bcc_addrs:(string * string) list -> to_addrs:(string * string) list -> subject:string -> Netmime.complex_mime_message -> Netmime.complex_mime_message (** Sets the mail-related header fields in the input message, and * returns a message ready for delivery. Transfer- and delivery-related * header fields are removed from the message first, and the new fields * are set to the values passed to this function. * * The arguments are like in {!Netsendmail.compose}. * * The input message should have at least a [Content-type] header, * but this is not enforced. * * Use this function as an alternative to {!Netsendmail.compose}, * if the message is already available as [complex_mime_message], * e.g. to re-send a parsed mail message to a new destination. *) (** {b Note: Resending Messages} * * Note that mails generated by [wrap_mail] always appear as new mails, * not as forwarded or replied mails. In order to do the latter a different * way of processing the message is needed. *) val wrap_parts : ?in_charset:Netconversion.encoding -> ?out_charset:Netconversion.encoding -> ?content_type:(string * (string * Netmime_string.s_param) list) -> ?content_id:string -> ?content_description:string -> ?content_location:string -> ?content_disposition:(string * (string * Netmime_string.s_param) list) -> Netmime.complex_mime_message list -> Netmime.complex_mime_message (** Generates an intermediate container for multipart attachments. * Use this if you want to bundle a set of attachments as a single * attachment. * * @param in_charset The encoding of the [content_description] argument. * Default: [`Enc_iso88591]. * @param out_charset The encoding of the generated [Content-Description] * header. Default: [`Enc_iso88591]. * @param content_type The [Content-Type] header. Default: multipart/mixed * @param content_id The [Content-ID] header, without the angle brackets * @param content_description The [Content-Description] header * @param content_location The [Content-Location] header. This must be * a valid URL, only composed of 7 bit characters, and with escaped * unsafe characters * @param content_disposition The [Content-Disposition] header *) (** {b Low-level} *) val create_address_list_tokens : ?in_charset:Netconversion.encoding -> ?out_charset:Netconversion.encoding -> (string * string) list -> Netmime_string.s_token list (** Returns the list of [s_token]s representing email addresses as * structured value. The addresses are passed as list of pairs * [(human_readable, formal)] as in the [compose] function above. * The returned structured field value can be formatted and filled * into a mail header. For example, to set the "To" header to * ["Stolpmann, Gerd" ] use * {[ * let sval = create_address_list_tokens ["Stolpmann, Gerd", * "gerd\@gerd-stolpmann.de"] in * header # update_field "to" (format_field_value "to" sval) * ]} * This ensures that the field is correctly quoted, that appropriate * encodings are applied and that long values are folded into several * lines. * * @param in_charset The character encoding used for [human_readable]. * Defaults to [`Enc_iso88591]. * @param out_charset The character encoding used in the generated * encoded word. This encoding must be ASCII-compatible. Defaults to * [`Enc_iso88591]. *) val create_text_tokens : ?in_charset:Netconversion.encoding -> ?out_charset:Netconversion.encoding -> string -> Netmime_string.s_token list (** Returns the list of [s_token]s representing an informal text * as structured value. The text is passed as simple string. * The returned structured field value can be formatted and filled * into a mail header. For example, to set the "Subject" header to * ["I have to say something"], use * {[ * let sval = create_text_tokens "I have to say something" in * header # update_field "subject" (format_field_value "subject" sval) * ]} * This ensures that the field is correctly quoted, that appropriate * encodings are applied and that long values are folded into several * lines. * * @param in_charset The character encoding used for the input string. * Defaults to [`Enc_iso88591]. * @param out_charset The character encoding used in the generated * encoded words. This encoding must be ASCII-compatible. Defaults to * [`Enc_iso88591]. *) val format_field_value : string -> Netmime_string.s_token list -> string (** To put [sval], an [s_token list], into the header field [name], * call * * [ header # update_field name (format_field_value name sval) ] * * The field value is folded into several lines, if necessary. *) (** {1:sending Sending Messages} *) val sendmail : ?mailer:string -> ?crlf:bool -> Netmime.complex_mime_message -> unit (** Sends the passed message. The mailer program must be sendmail-compatible * (this can be assumed on all Unix systems, even if a non-sendmail * mailer is installed). * * The mailer program is the command passed as [mailer], which is by * default a reasonable compile-time setting. * * With [crlf] one can determine the EOL convention for the message piped to * the mailer program: If [crlf], CR/LF is used, if [not crlf], only LF is * used. The default is [false] for Unix systems. * * See also {!Netsmtp.sendmail} for a way to send emails via SMTP. *) ocamlnet-4.0.4/src/netstring/nethtml.ml0000644000175000017500000005477312541553661016606 0ustar gerdgerd(* $Id: nethtml.ml 2244 2015-06-21 13:07:46Z gerd $ * ---------------------------------------------------------------------- * *) open Nethtml_scanner;; type document = Element of (string * (string*string) list * document list) | Data of string ;; exception End_of_scan;; exception Found;; type element_class = (* What is the class of an element? *) [ `Inline | `Block | `Essential_block | `None | `Everywhere ] ;; type model_constraint = (* The constraint the subelements must fulfill *) [ `Inline | `Block | `Flow (* = `Inline or `Block *) | `Empty | `Any | `Special | `Elements of string list (* Enumeration of allowed elements *) | `Or of (model_constraint * model_constraint) | `Except of (model_constraint * model_constraint) | `Sub_exclusions of (string list * model_constraint) ] ;; type simplified_dtd = (string * (element_class * model_constraint)) list let ( |. ) a b = `Or(a,b);; let ( -. ) a b = `Except(a,b);; let block_elements = (* Only used for exclusions *) [ "p"; "dl"; "div"; "center"; "noscript"; "noframes"; "blockquote"; "form"; "isindex"; "hr"; "table"; "fieldset"; "address"; "h1"; "h2"; "h3"; "h4"; "h5"; "h6"; "pre"; "ul"; "ol"; "dir"; "menu" ];; let html40_dtd = [ (* --------- INLINE ELEMENTS ------------ *) (* %fontstyle; *) "tt", (`Inline, `Inline); "i", (`Inline, `Inline); "b", (`Inline, `Inline); "big", (`Inline, `Inline); "small", (`Inline, `Inline); (* transitional: *) "u", (`Inline, `Inline); "s", (`Inline, `Inline); "strike", (`Inline, `Inline); (* %phrase; *) "em", (`Inline, `Inline); "strong", (`Inline, `Inline); "dfn", (`Inline, `Inline); "code", (`Inline, `Inline); "samp", (`Inline, `Inline); "kbd", (`Inline, `Inline); "var", (`Inline, `Inline); "cite", (`Inline, `Inline); "abbr", (`Inline, `Inline); "acronym", (`Inline, `Inline); (* %special; *) "sup", (`Inline, `Inline); "sub", (`Inline, `Inline); "span", (`Inline, `Inline); "bdo", (`Inline, `Inline); "br", (`Inline, `Empty); "a", (`Inline, `Sub_exclusions(["a"],`Inline)); "img", (`Inline, `Empty); "object", (`Inline, (`Flow |. `Elements ["param"])); "script", (`Inline, `Special); "map", (`Inline, (`Flow |. `Elements ["area"])); "q", (`Inline, `Inline); (* transitional: *) "applet", (`Inline, (`Flow |. `Elements ["param"])); "font", (`Inline, `Inline); "basefont", (`Inline, `Empty); "iframe", (`Inline, `Flow); (* %formctrl; *) "input", (`Inline, `Empty); "select", (`Inline, `Elements ["optgroup"; "option"]); "textarea", (`Inline, `Elements []); (* #PCDATA *) "label", (`Inline, `Sub_exclusions( ["label"], `Inline)); "button", (`Inline, `Sub_exclusions( ["a"; "input"; "select"; "textarea"; "label"; "button"; "form"; "fieldset"; "isindex"; "iframe"], `Flow)); (* ------------ BLOCK ELEMENTS ----------*) "p", (`Block, `Inline); (* %heading; *) "h1", (`Block, `Inline); "h2", (`Block, `Inline); "h3", (`Block, `Inline); "h4", (`Block, `Inline); "h5", (`Block, `Inline); "h6", (`Block, `Inline); (* %list; *) "ul", (`Block, `Elements ["li"]); "ol", (`Block, `Elements ["li"]); (* transitional: *) "dir", (`Block, `Sub_exclusions( block_elements, `Elements ["li"])); "menu", (`Block, `Sub_exclusions( block_elements, `Elements ["li"])); (* %preformatted; *) "pre", (`Block, `Sub_exclusions( [ "img"; "object"; "applet"; "big"; "small"; "sub"; "sup"; "font"; "basefont"], `Inline )); (* other: *) "dl", (`Block, `Elements ["dt"; "dd"]); "div", (`Block, `Flow); "noscript", (`Block, `Flow); "blockquote", (`Block, (`Flow |. `Elements ["script"])); (* strict DTD has `Block here *) "form", (`Block, `Sub_exclusions( ["form"], `Flow |. `Elements ["script"])); (* strict DTD has `Block here *) "hr", (`Block, `Empty); "table", (`Block, `Elements ["caption"; "col"; "colgroup"; "thead"; "tfoot"; "tbody"; "tr"]); "fieldset", (`Block, (`Flow |. `Elements ["legend"])); "address", (`Block, `Inline); (* transitional: *) "center", (`Block, `Flow); "noframes", (`Block, `Flow); "isindex", (`Block, `Empty); (* ------------ OTHER ELEMENTS ----------*) "body", (`None, (`Flow |. `Elements ["script"])); (* strict DTD has `Block here *) "area", (`None, `Empty); "link", (`None, `Empty); "param", (`None, `Empty); "ins", (`Everywhere, `Flow); "del", (`Everywhere, `Flow); "dt", (`None, `Inline); "dd", (`None, `Flow); "li", (`None, `Flow); "optgroup", (`None, `Elements ["option"]); "option", (`None, `Elements []); (* #PCDATA *) "legend", (`None, `Inline); "caption", (`None, `Inline); "thead", (`None, `Elements ["tr"]); "tbody", (`None, `Elements ["tr"]); "tfoot", (`None, `Elements ["tr"]); "colgroup", (`None, `Elements ["col"]); "col", (`None, `Empty); "tr", (`None, `Elements ["th"; "td"]); "th", (`None, `Flow); "td", (`None, `Flow); "head", (`None, `Elements ["title"; "base"; "script"; "style"; "meta"; "link"; "object"]); "title", (`None, `Elements []); (* #PCDATA *) "base", (`None, `Empty); "meta", (`None, `Empty); "style", (`None, `Special); "html", (`None, (`Flow |. `Elements ["head"; "title"; "base"; "script"; "style"; "meta"; "link"; "object"; "body"; "frameset"])); (* transitional: *) "frameset", (`None, `Elements ["frameset"; "frame"; "noframes"]); "frame", (`None, `Empty); ] ;; let relax_dtd dtd = (* Changes (`Inline, `Inline) constraints into (`Inline, `Flow). *) let rec relax_model m = match m with `Inline -> `Flow | `Sub_exclusions(l,m') -> `Sub_exclusions(l,relax_model m') | other -> other in List.map (fun (name, (elclass, elconstr)) -> match elclass with `Inline -> (name, (elclass, relax_model elconstr)) | other -> (name, (elclass, elconstr)) ) dtd ;; let essential_blocks dtd elements = (* Changes the passed block elements into essential block elements *) List.map (fun (name, (elclass, elconstr)) -> match elclass with `Block when List.mem name elements -> (name, ( `Essential_block, elconstr)) | other -> (name, (elclass, elconstr)) ) dtd ;; let relaxed_html40_dtd = essential_blocks (relax_dtd html40_dtd) [ "body"; "table"; "ol"; "ul"; "dl" ] ;; let rec parse_comment buf = let t = scan_comment buf in match t with Mcomment -> let s = Lexing.lexeme buf in s ^ parse_comment buf | Eof -> raise End_of_scan | _ -> (* must be Rcomment *) "" ;; let rec parse_doctype buf = let t = scan_doctype buf in match t with Mdoctype -> let s = Lexing.lexeme buf in s ^ parse_doctype buf | Eof -> raise End_of_scan | _ -> (* must be Rdoctype *) "" ;; let rec parse_pi buf = let t = scan_pi buf in match t with Mpi -> let s = Lexing.lexeme buf in s ^ parse_pi buf | Eof -> raise End_of_scan | _ -> (* must be Rpi *) "" ;; let hashtbl_from_alist l = let ht = Hashtbl.create (List.length l) in List.iter (fun (k, v) -> Hashtbl.add ht k v) l; ht ;; module S = struct type t = string let compare = (Pervasives.compare : string -> string -> int) end module Strset = Set.Make(S);; let parse_document ?(dtd = html40_dtd) ?(return_declarations = false) ?(return_pis = false) ?(return_comments = false) ?(case_sensitive = false) buf = let current_name = ref "" in let current_atts = ref [] in let current_subs = ref [] in let current_excl = ref Strset.empty in (* current exclusions *) let stack = Stack.create() in let dtd_hash = hashtbl_from_alist dtd in let maybe_lowercase = if case_sensitive then (fun s -> s) else String.lowercase in let model_of element_name = if element_name = "" then (`Everywhere, `Any) else let extract = function (eclass, `Sub_exclusions(_,m)) -> eclass, m | m -> m in try extract(Hashtbl.find dtd_hash element_name) with Not_found -> (`Everywhere, `Any) in let exclusions_of element_name = if element_name = "" then [] else let extract = function (eclass, `Sub_exclusions(l,_)) -> l | _ -> [] in try extract(Hashtbl.find dtd_hash element_name) with Not_found -> [] in let is_possible_subelement parent_element parent_exclusions sub_element = let (sub_class, _) = model_of sub_element in let rec eval m = match m with `Inline -> sub_class = `Inline | `Block -> sub_class = `Block || sub_class = `Essential_block | `Flow -> sub_class = `Inline || sub_class = `Block || sub_class = `Essential_block | `Elements l -> List.mem sub_element l | `Any -> true | `Or(m1,m2) -> eval m1 || eval m2 | `Except(m1,m2) -> eval m1 && not (eval m2) | `Empty -> false | `Special -> false | `Sub_exclusions(_,_) -> assert false in (sub_class = `Everywhere) || ( (not (Strset.mem sub_element parent_exclusions)) && let (_, parent_model) = model_of parent_element in eval parent_model ) in let unwind_stack sub_name = (* If the current element is not a possible parent element for sub_name, * search the parent element in the stack. * Either the new current element is the parent, or there was no * possible parent. In the latter case, the current element is the * same element as before. *) let backup = Stack.create() in let backup_name = !current_name in let backup_atts = !current_atts in let backup_subs = !current_subs in let backup_excl = !current_excl in try while not (is_possible_subelement !current_name !current_excl sub_name) do (* Maybe we are not allowed to end the current element: *) let (current_class, _) = model_of !current_name in if current_class = `Essential_block then raise Stack.Empty; (* End the current element and remove it from the stack: *) let grant_parent = Stack.pop stack in Stack.push grant_parent backup; (* Save it; may we need it *) let (gp_name, gp_atts, gp_subs, gp_excl) = grant_parent in (* If gp_name is an essential element, we are not allowed to close * it implicitly, even if that violates the DTD. *) let current = Element (!current_name, !current_atts, List.rev !current_subs) in current_name := gp_name; current_atts := gp_atts; current_excl := gp_excl; current_subs := current :: gp_subs done; with Stack.Empty -> (* It did not work! Push everything back to the stack, and * resume the old state. *) while Stack.length backup > 0 do Stack.push (Stack.pop backup) stack done; current_name := backup_name; current_atts := backup_atts; current_subs := backup_subs; current_excl := backup_excl in let parse_atts() = let rec next_no_space p_string = (* p_string: whether string literals in quotation marks are allowed *) let tok = if p_string then scan_element_after_Is buf else scan_element buf in match tok with Space _ -> next_no_space p_string | t -> t in let rec parse_atts_lookahead next = match next with | Relement -> ( [], false ) | Relement_empty -> ( [], true ) | Name n -> ( match next_no_space false with Is -> ( match next_no_space true with Name v -> let toks, is_empty = parse_atts_lookahead (next_no_space false) in ( (maybe_lowercase n, v) :: toks, is_empty ) | Literal v -> let toks, is_empty = parse_atts_lookahead (next_no_space false) in ( (maybe_lowercase n,v) :: toks, is_empty ) | Eof -> raise End_of_scan | Relement -> (* Illegal *) ( [], false ) | Relement_empty -> (* Illegal *) ( [], true ) | _ -> (* Illegal *) parse_atts_lookahead (next_no_space false) ) | Eof -> raise End_of_scan | Relement -> (* <==> *) ( [ maybe_lowercase n, maybe_lowercase n ], false) | Relement_empty -> (* <==> *) ( [ maybe_lowercase n, maybe_lowercase n ], true) | next' -> (* assume <==> *) let toks, is_empty = parse_atts_lookahead next' in ( ( maybe_lowercase n, maybe_lowercase n ) :: toks, is_empty) ) | Eof -> raise End_of_scan | _ -> (* Illegal *) parse_atts_lookahead (next_no_space false) in parse_atts_lookahead (next_no_space false) in let rec parse_special name = (* Parse until *) match scan_special buf with | Lelementend n -> if maybe_lowercase n = name then "" else " raise End_of_scan | Cdata s -> s ^ parse_special name | _ -> (* Illegal *) parse_special name in let rec skip_element() = (* Skip until ">" (or "/>") *) match scan_element buf with | Relement | Relement_empty -> () | Eof -> raise End_of_scan | _ -> skip_element() in let rec parse_next() = let t = scan_document buf in match t with | Lcomment -> let comment = parse_comment buf in if return_comments then current_subs := (Element("--",["contents",comment],[])) :: !current_subs; parse_next() | Ldoctype -> let decl = parse_doctype buf in if return_declarations then current_subs := (Element("!",["contents",decl],[])) :: !current_subs; parse_next() | Lpi -> let pi = parse_pi buf in if return_pis then current_subs := (Element("?",["contents",pi],[])) :: !current_subs; parse_next() | Lelement name -> let name = maybe_lowercase name in let (_, model) = model_of name in ( match model with `Empty -> let atts, _ = parse_atts() in unwind_stack name; current_subs := (Element(name, atts, [])) :: !current_subs; parse_next() | `Special -> let atts, is_empty = parse_atts() in unwind_stack name; let data = if is_empty then "" else ( let d = parse_special name in (* Read until ">" *) skip_element(); d ) in current_subs := (Element(name, atts, [Data data])) :: !current_subs; parse_next() | _ -> let atts, is_empty = parse_atts() in (* Unwind the stack until we find an element which can be * the parent of the new element: *) unwind_stack name; if is_empty then ( (* Simple case *) current_subs := (Element(name, atts, [])) :: !current_subs; ) else ( (* Push the current element on the stack, and this element * becomes the new current element: *) let new_excl = exclusions_of name in Stack.push (!current_name, !current_atts, !current_subs, !current_excl) stack; current_name := name; current_atts := atts; current_subs := []; List.iter (fun xel -> current_excl := Strset.add xel !current_excl) new_excl; ); parse_next() ) | Cdata data -> current_subs := (Data data) :: !current_subs; parse_next() | Lelementend name -> let name = maybe_lowercase name in (* Read until ">" *) skip_element(); (* Search the element to close on the stack: *) let found = (name = !current_name) || try Stack.iter (fun (old_name, _, _, _) -> if name = old_name then raise Found; match model_of old_name with `Essential_block, _ -> raise Not_found; (* Don't close essential blocks implicitly *) | _ -> ()) stack; false with Found -> true | Not_found -> false in (* If not found, the end tag is wrong. Simply ignore it. *) if not found then parse_next() else begin (* If found: Remove the elements from the stack, and append * them to the previous element as sub elements *) while !current_name <> name do let old_name, old_atts, old_subs, old_excl = Stack.pop stack in current_subs := (Element (!current_name, !current_atts, List.rev !current_subs)) :: old_subs; current_name := old_name; current_atts := old_atts; current_excl := old_excl done; (* Remove one more element: the element containing the element * currently being closed. *) let old_name, old_atts, old_subs, old_excl = Stack.pop stack in current_subs := (Element (!current_name, !current_atts, List.rev !current_subs)) :: old_subs; current_name := old_name; current_atts := old_atts; current_excl := old_excl; (* Go on *) parse_next() end | Eof -> raise End_of_scan | _ -> parse_next() in try parse_next(); (* never returns. Will get a warning X *) assert false with End_of_scan -> (* Close all remaining elements: *) while Stack.length stack > 0 do let old_name, old_atts, old_subs, old_excl = Stack.pop stack in current_subs := Element (!current_name, !current_atts, List.rev !current_subs) :: old_subs; current_name := old_name; current_atts := old_atts; current_excl := old_excl done; List.rev !current_subs ;; let parse ?dtd ?return_declarations ?return_pis ?return_comments ?case_sensitive ch = let buf = Netchannels.lexbuf_of_in_obj_channel ch in parse_document ?dtd ?return_declarations ?return_comments ?return_pis ?case_sensitive buf ;; type xmap_value = | Xmap_attribute of string * string * string (* elname, attname, attval *) | Xmap_data of string option * string (* elname, pcdata *) let rec xmap f surelem doc = (* surdoc: surrounding element *) match doc with | Element(name,atts,subdocs) -> (match name with | "!" | "?" | "--" -> Element(name,atts,xmap_list f None subdocs) | _ -> let atts' = List.map (fun (aname,aval) -> aname, f (Xmap_attribute(name, aname, aval)) ) atts in let subdocs' = xmap_list f (Some name) subdocs in Element(name,atts',subdocs') ) | Data s -> Data(f (Xmap_data(surelem,s))) and xmap_list f surelem l = List.map (xmap f surelem) l;; let map_list f l = xmap_list (function | Xmap_attribute(_, _, v) -> f v | Xmap_data(_, v) -> f v ) None l let encode ?(enc = `Enc_iso88591) ?(prefer_name = true) ?(dtd = html40_dtd) dl = let enc_string = Netencoding.Html.encode ~in_enc:enc ~out_enc:`Enc_usascii ~prefer_name () in let dtd_hash = hashtbl_from_alist dtd in let enc_node = function | Xmap_attribute(_, _, v) -> enc_string v | Xmap_data(None, v) -> enc_string v | Xmap_data(Some el, v) -> let is_special = try snd(Hashtbl.find dtd_hash el) = `Special with Not_found -> false in if is_special then v else enc_string v in xmap_list enc_node None dl ;; let decode ?(enc = `Enc_iso88591) ?subst ?entity_base ?lookup ?(dtd = html40_dtd) dl = let dec_string = Netencoding.Html.decode ~in_enc:enc ~out_enc:enc ?subst ?entity_base ?lookup () in let dtd_hash = hashtbl_from_alist dtd in let dec_node = function | Xmap_attribute(_, _, v) -> dec_string v | Xmap_data(None, v) -> dec_string v | Xmap_data(Some el, v) -> let is_special = try snd(Hashtbl.find dtd_hash el) = `Special with Not_found -> false in if is_special then v else dec_string v in xmap_list dec_node None dl ;; let quote_quot_re = Netstring_str.regexp "\"";; let write_ ~dtd ~xhtml write_os doc = let quote_quot s = Netstring_str.global_substitute quote_quot_re (fun _ _ -> """) s in let rec trav doc = match doc with Element(name,atts,subdocs) -> ( match name with "!" -> write_os ""; | "?" -> write_os ""; | "--" -> write_os ""; | _ -> let is_empty = try let _, constr = List.assoc name dtd in constr = `Empty with Not_found -> false in write_os "<"; write_os name; List.iter (fun (aname,aval) -> write_os " "; write_os aname; write_os "=\""; write_os (quote_quot aval); write_os "\""; ) atts; if is_empty then (* Ignore subdocs (even if <> []) because they should not be there. *) write_os (if xhtml then "/>" else ">") else begin write_os ">"; List.iter trav subdocs; write_os ""; end ) | Data s -> write_os s in try List.iter trav doc with Not_found -> failwith "write" ;; let write ?(dtd = html40_dtd) ?(xhtml = true) ch doc = write_ ~dtd ~xhtml (ch # output_string) doc ocamlnet-4.0.4/src/netstring/netmech_digest_sasl.mli0000644000175000017500000000362412541553661021275 0ustar gerdgerd(* $Id: netmech_digest_sasl.mli 2195 2015-01-01 12:23:39Z gerd $ *) module DIGEST_MD5 : Netsys_sasl_types.SASL_MECHANISM (** The DIGEST-MD5 SASL mechanism (RFC 2831). This mechanism is only provided to connect to old services; it shouldn't be used otherwise. Key facts: - The password is not sent in the clear - Not only authenticates the client to the server, but the client can also find out whether the server knew the password, i.e. the server is also authenticated. - DIGEST-MD5 is vulnerable to man-in-the-middle attacks. - The MD5 hash is broken (too weak) Only "auth" mode is supported (no integrity or privacy protection). This implementation rejects servers that offer multiple realms. This implementation supports both [server_session_id] (which is the nonce) and the [client_session_id] (the cnonce). Parameters: - [create_server_session] understands: "realm" (optional), "nonce" (optional) - [server_prop] will return: "realm" (the realm selected by the client), "nonce", "digest-uri" (once known), "cnonce" (once known), "nc" (once known). - [create_client_session] understands: "realm" (optional), "cnonce" (optional), "digest-uri" (optional). If the digest-uri is not set, it defaults to "generic/generic". - [client_prop] will return: "cnonce", "realm" (once known; this is always the server realm), "nonce" (once known), "nc" (after sending the response). - The parameters [mutual] and [secure] are understood but ignored (there is mutual authentication anyway, and DIGEST is considered as secure method) As for all SASL mechanisms in OCamlnet, SASLprep is not automatically called. Users of DIGEST-MD5 should pass user names and passwords through {!Netsaslprep.saslprep}. *) ocamlnet-4.0.4/src/netstring/netnumber.mli0000644000175000017500000001644612541553661017276 0ustar gerdgerd(* $Id: netnumber.mli 2195 2015-01-01 12:23:39Z gerd $ *) (** Binary encodings of numbers *) (** This is the successor of the [Rtypes] module *) (** {2 Numeric types} *) (* 4- and 8-bytes representation of signed integers *) type int4 (** 32 bit signed integer *) type int8 (** 64 bit signed integer *) (* 4- and 8-bytes representation of non-negative integers *) type uint4 (** 32 bit unsigned integer *) type uint8 (** 64 bit unsigned integer *) (* Floating-point numbers of single and double precision according to IEEE *) type fp4 (** single precision float (IEEE "float") *) type fp8 (** double precision float (IEEE "double") *) exception Cannot_represent of string (** raised if a conversion can't be done *) exception Out_of_range (** raised if string position out of range *) (** {2 Basic encoding/decoding functions} *) val mk_int4 : char * char * char * char -> int4 val mk_int8 : char * char * char * char * char * char * char * char -> int8 val mk_uint4 : char * char * char * char -> uint4 val mk_uint8 : char * char * char * char * char * char * char * char -> uint8 (** [mk_] create integer values from character tuples. In these tuples * the MSB is the first component and the LSB the last. *) (* destroy integers and get tuples *) val dest_int4 : int4 -> char * char * char * char val dest_int8 : int8 -> char * char * char * char * char * char * char * char val dest_uint4 : uint4 -> char * char * char * char val dest_uint8 : uint8 -> char * char * char * char * char * char * char * char (** [dest_] destroy integer values and returns the corresponding char * tuples. *) val mk_fp4 : char * char * char * char -> fp4 val mk_fp8 : char * char * char * char * char * char * char * char -> fp8 val dest_fp4 : fp4 -> char * char * char * char val dest_fp8 : fp8 -> char * char * char * char * char * char * char * char (** {2 Conversions} *) (** Conversions from int to (u)int and vice versa. * On 32-bit computers, the type [int] can hold 31-bit signed integers * (including the sign, i.e. one bit cannot be used). * On 64-bit computers, the type [int] can hold 63-bit signed integers * (including the sign, i.e. one bit cannot be used). * The [int_of_xxx] functions raise [Cannot_represent] if the number to * convert is too big (or too small) to be represented as [int]. Note * that this depends on the word size of your architecture. *) val int_of_int4 : int4 -> int val int_of_uint4 : uint4 -> int val int_of_int8 : int8 -> int val int_of_uint8 : uint8 -> int val int4_of_int : int -> int4 val uint4_of_int : int -> uint4 val int8_of_int : int -> int8 val uint8_of_int : int -> uint8 val int32_of_int4 : int4 -> int32 val int32_of_uint4 : uint4 -> int32 val int32_of_int8 : int8 -> int32 val int32_of_uint8 : uint8 -> int32 val int4_of_int32 : int32 -> int4 val uint4_of_int32 : int32 -> uint4 val int8_of_int32 : int32 -> int8 val uint8_of_int32 : int32 -> uint8 val int64_of_int4 : int4 -> int64 val int64_of_uint4 : uint4 -> int64 val int64_of_int8 : int8 -> int64 val int64_of_uint8 : uint8 -> int64 val int4_of_int64 : int64 -> int4 val uint4_of_int64 : int64 -> uint4 val int8_of_int64 : int64 -> int8 val uint8_of_int64 : int64 -> uint8 (** Casts from [uint4]/[uint8] to [int32]/[int64]. Here, the sign is ignored and * simply considered as a bit. *) val logical_uint4_of_int32 : int32 -> uint4 val logical_int32_of_uint4 : uint4 -> int32 val logical_uint8_of_int64 : int64 -> uint8 val logical_int64_of_uint8 : uint8 -> int64 val fp8_of_fp4 : fp4 -> fp8 val fp4_of_fp8 : fp8 -> fp4 (** Note [fp4_of_fp8]: This conversion is not exact. It is quite * normal that precision is lost. Numbers too small or too large * for fp4 are converted to the "infinity" value. *) val float_of_fp4 : fp4 -> float val float_of_fp8 : fp8 -> float val fp4_of_float : float -> fp4 val fp8_of_float : float -> fp8 (** Note fp4_of_float: The same problems as in fp4_of_fp8 may arise *) (** {2 Comparisons} *) (** The comparisons "=" and "<>" work for all numbers. For signed integers, the operators "<", "<=", ">", and ">=" work, too. The unsigned integer type use representation that are not compatible with these operators, and the following functions need to be called. For [fp4] and [fp8] there are no comparison functions - convert to [float] first and compare then. *) val lt_uint4 : uint4 -> uint4 -> bool (** [lt_uint4] is true iff the first value is less than the second value as unsigned int *) val le_uint4 : uint4 -> uint4 -> bool val gt_uint4 : uint4 -> uint4 -> bool val ge_uint4 : uint4 -> uint4 -> bool (** Other comparisons *) val lt_uint8 : uint8 -> uint8 -> bool (** [lt_uint8] is true iff the first value is less than the second value as unsigned int *) val le_uint8 : uint8 -> uint8 -> bool val gt_uint8 : uint8 -> uint8 -> bool val ge_uint8 : uint8 -> uint8 -> bool (** Other comparisons *) (** {2 Minimum/maximum values} *) val min_int4 : int4 val min_uint4 : uint4 val min_int8 : int8 val min_uint8 : uint8 val max_int4 : int4 val max_uint4 : uint4 val max_int8 : int8 val max_uint8 : uint8 module type ENCDEC = sig (** Encode/decode numbers as strings. These functions exist in two flavors: - {!Netnumber.BE} implements network byte order (big endian) - {!Netnumber.LE} implements little endian *) val read_int4 : string -> int -> int4 val read_int8 : string -> int -> int8 val read_uint4 : string -> int -> uint4 val read_uint8 : string -> int -> uint8 (** [read_] create integer values from the characters found at a certain position in the string. Raises [Out_of_range] if the position is bad *) val read_int4_unsafe : string -> int -> int4 val read_int8_unsafe : string -> int -> int8 val read_uint4_unsafe : string -> int -> uint4 val read_uint8_unsafe : string -> int -> uint8 (** Same, but no index check *) val write_int4 : string -> int -> int4 -> unit val write_int8 : string -> int -> int8 -> unit val write_uint4 : string -> int -> uint4 -> unit val write_uint8 : string -> int -> uint8 -> unit (** [write_] copies the characters corresponding to the integer values into the string at the given positions. Raises [Out_of_range] if the position is bad. *) val write_int4_unsafe : string -> int -> int4 -> unit val write_int8_unsafe : string -> int -> int8 -> unit val write_uint4_unsafe : string -> int -> uint4 -> unit val write_uint8_unsafe : string -> int -> uint8 -> unit (** [write_][_unsafe]: Same, but no index check. *) val int4_as_string : int4 -> string val int8_as_string : int8 -> string val uint4_as_string : uint4 -> string val uint8_as_string : uint8 -> string (** [_as_string]: Returns the corresponding string for an integer value *) val write_fp4 : string -> int -> fp4 -> unit val write_fp8 : string -> int -> fp8 -> unit val fp4_as_string : fp4 -> string val fp8_as_string : fp8 -> string val read_fp4 : string -> int -> fp4 val read_fp8 : string -> int -> fp8 end module BE : ENCDEC (** Encoders/decoders for big endian - network byte order *) module LE : ENCDEC (** Encoders/decoders for little endian *) module HO : ENCDEC (** Encoders/decoders for host byte order - which is either little endian or big endian, depending on the CPU (or CPU mode) *) ocamlnet-4.0.4/src/netstring/netmech_crammd5_sasl.ml0000644000175000017500000001554612541553661021203 0ustar gerdgerd(* $Id: netmech_crammd5_sasl.ml 2195 2015-01-01 12:23:39Z gerd $ *) (* TODO: add saslprep to at least the server, so far we have it *) (* Unit tests: tests/netstring/bench/test_netmech.ml *) let next_challenge = ref None (* testing *) let override_challenge s = next_challenge := Some s module CRAM_MD5 : Netsys_sasl_types.SASL_MECHANISM = struct let mechanism_name = "CRAM-MD5" let client_first = `No let server_sends_final_data = false let supports_authz = false let available() = true type credentials = (string * string * (string * string) list) list let init_credentials l = (l:credentials) type server_session = { mutable sstate : Netsys_sasl_types.server_state; schallenge : string; mutable suser : string option; lookup : string -> string -> credentials option; } let server_state ss = ss.sstate let no_mutual = "The CRAM-MD5 mechanism does not support mutual authentication" let create_server_session ~lookup ~params () = let params = Netsys_sasl_util.preprocess_params "Netmech_crammd5_sasl.create_server_session:" [ "mutual"; "secure" ] params in let req_mutual = try List.assoc "mutual" params = "true" with Not_found -> false in (* Ignore "secure" *) let r = String.create 16 in Netsys_rng.fill_random r; let c1 = Netencoding.to_hex ~lc:true r in let c = match !next_challenge with | None -> c1 | Some c -> c in next_challenge := None; { sstate = if req_mutual then `Auth_error no_mutual else `Emit; schallenge = "<" ^ c ^ ">"; suser = None; lookup } let server_configure_channel_binding ss cb_list = failwith "Netmach_crammd5_sasl.server_configure_channel_binding: \ not supported" let compute_response user password challenge = let k = if String.length password < 64 then password (* padding is done by hmac anyway *) else Digest.string password in let r = Netauth.hmac ~h:Digest.string (* MD5, actually *) ~b:64 ~l:16 ~k ~message:challenge in let r_hex = Netencoding.to_hex ~lc:true r in user ^ " " ^ r_hex let verify_utf8 s = try Netconversion.verify `Enc_utf8 s with _ -> failwith "UTF-8 mismatch" let server_process_response ss msg = try if ss.sstate <> `Wait then failwith "protocol error"; let n = String.length msg in let k1 = String.rindex msg ' ' in let user = String.sub msg 0 k1 in let resp = String.sub msg (k1+1) (n-k1-1) in let expected_password = match ss.lookup user "" with | None -> failwith "unknown user" | Some creds -> Netsys_sasl_util.extract_password creds in let expected_msg = compute_response user expected_password ss.schallenge in if msg <> expected_msg then failwith "bad password"; verify_utf8 user; verify_utf8 expected_password; ss.sstate <- `OK; ss.suser <- Some user; with | Failure msg -> ss.sstate <- `Auth_error msg let server_process_response_restart ss msg set_stale = failwith "Netmech_crammd5_sasl.server_process_response_restart: \ not available" let server_emit_challenge ss = if ss.sstate <> `Emit then failwith "Netmech_crammd5_sasl.server_emit_challenge: bad state"; let data = ss.schallenge in ss.sstate <- `Wait; data let server_channel_binding ss = `None let server_stash_session ss = "server,t=CRAM-MD5;" ^ Marshal.to_string (ss.sstate, ss.schallenge, ss.suser) [] let ss_re = Netstring_str.regexp "server,t=CRAM-MD5;" let server_resume_session ~lookup s = match Netstring_str.string_match ss_re s 0 with | None -> failwith "Netmech_crammd5_sasl.server_resume_session" | Some m -> let p = Netstring_str.match_end m in let data = String.sub s p (String.length s - p) in let (state,chal,user) = Marshal.from_string data 0 in { sstate = state; suser = user; schallenge = chal; lookup } let server_session_id ss = None let server_prop ss key = raise Not_found let server_gssapi_props ss = raise Not_found let server_user_name ss = match ss.suser with | None -> raise Not_found | Some name -> name let server_authz_name ss = "" type client_session = { mutable cstate : Netsys_sasl_types.client_state; mutable cresp : string; cuser : string; cauthz : string; cpasswd : string; } let create_client_session ~user ~authz ~creds ~params () = let params = Netsys_sasl_util.preprocess_params "Netmech_crammd5_sasl.create_client_session:" [ "mutual"; "secure" ] params in let req_mutual = try List.assoc "mutual" params = "true" with Not_found -> false in (* Ignore "secure" *) let pw = try Netsys_sasl_util.extract_password creds with Not_found -> failwith "Netmech_crammd5_sasl.create_client_session: no password \ found in credentials" in { cstate = if req_mutual then `Auth_error no_mutual else `Wait; cresp = ""; cuser = user; cauthz = authz; cpasswd = pw; } let client_configure_channel_binding cs cb = if cb <> `None then failwith "Netmech_crammd5_sasl.client_configure_channel_binding: \ not supported" let client_state cs = cs.cstate let client_channel_binding cs = `None let client_restart cs = if cs.cstate <> `OK then failwith "Netmech_crammd5_sasl.client_restart: unfinished auth"; cs.cstate <- `Wait let client_process_challenge cs msg = if cs.cstate <> `Wait then cs.cstate <- `Auth_error "protocol error" else ( cs.cresp <- compute_response cs.cuser cs.cpasswd msg; cs.cstate <- `Emit; ) let client_emit_response cs = if cs.cstate <> `Emit then failwith "Netmech_crammd5_sasl.client_emit_response: bad state"; cs.cstate <- `OK; cs.cresp let client_stash_session cs = "client,t=CRAM-MD5;" ^ Marshal.to_string cs [] let cs_re = Netstring_str.regexp "client,t=CRAM-MD5;" let client_resume_session s = match Netstring_str.string_match cs_re s 0 with | None -> failwith "Netmech_crammd5_sasl.client_resume_session" | Some m -> let p = Netstring_str.match_end m in let data = String.sub s p (String.length s - p) in let cs = Marshal.from_string data 0 in (cs : client_session) let client_session_id cs = None let client_prop cs key = raise Not_found let client_gssapi_props cs = raise Not_found let client_user_name cs = cs.cuser let client_authz_name cs = "" end ocamlnet-4.0.4/src/netstring/netfs.ml0000644000175000017500000004674512541553661016252 0ustar gerdgerd(* $Id: netfs.ml 1809 2012-11-05 23:09:14Z gerd $ *) type read_flag = [ `Skip of int64 | `Binary | `Streaming | `Dummy ] type read_file_flag = [ `Binary | `Dummy ] type write_flag = [ `Create | `Exclusive | `Truncate | `Binary | `Streaming | `Dummy ] type write_file_flag = [ `Create | `Exclusive | `Truncate | `Binary | `Link | `Dummy ] type write_common = [ `Create | `Exclusive | `Truncate | `Binary | `Dummy ] (* The intersection of write_flag and write_file_flag *) type size_flag = [ `Dummy ] type test_flag = [ `Link | `Dummy ] type remove_flag = [ `Recursive | `Dummy ] type rename_flag = [ `Dummy ] type symlink_flag = [ `Dummy ] type readdir_flag = [ `Dummy ] type readlink_flag = [ `Dummy ] type mkdir_flag = [ `Path | `Nonexcl | `Dummy ] type rmdir_flag = [ `Dummy ] type copy_flag = [ `Dummy ] type test_type = [ `N | `E | `D | `F | `H | `R | `W | `X | `S ] class type local_file = object method filename : string method close : unit -> unit end class type stream_fs = object method path_encoding : Netconversion.encoding option method path_exclusions : (int * int) list method nominal_dot_dot : bool method read : read_flag list -> string -> Netchannels.in_obj_channel method read_file : read_file_flag list -> string -> local_file method write : write_flag list -> string -> Netchannels.out_obj_channel method write_file : write_file_flag list -> string -> local_file -> unit method size : size_flag list -> string -> int64 method test : test_flag list -> string -> test_type -> bool method test_list : test_flag list -> string -> test_type list -> bool list method remove : remove_flag list -> string -> unit method rename : rename_flag list -> string -> string -> unit method symlink : symlink_flag list -> string -> string -> unit method readdir : readdir_flag list -> string -> string list method readlink : readlink_flag list -> string -> string method mkdir : mkdir_flag list -> string -> unit method rmdir : rmdir_flag list -> string -> unit method copy : copy_flag list -> string -> string -> unit method cancel : unit -> unit end class empty_fs detail : stream_fs = let enosys path = raise (Unix.Unix_error(Unix.ENOSYS, path, detail)) in object method path_encoding = enosys "" method path_exclusions = enosys "" method nominal_dot_dot = enosys "" method read _ p = enosys p method read_file _ p = enosys p method write _ p = enosys p method write_file _ p _ = enosys p method size _ p = enosys p method test _ p _ = enosys p method test_list _ p _ = enosys p method remove _ p = enosys p method rename _ p _ = enosys p method symlink _ p _ = enosys p method readdir _ p = enosys p method readlink _ p = enosys p method mkdir _ p = enosys p method rmdir _ p = enosys p method copy _ p _ = enosys p method cancel () = enosys "" end let slash_re = Netstring_str.regexp "/+" let drive_re = Netstring_str.regexp "^[a-zA-Z]:$" exception Not_absolute exception Unavailable let list_isect_empty l1 l2 = (* whether intersection is empty *) List.for_all (fun x1 -> not (List.mem x1 l2)) l1 let readdir d = try let l = ref [] in ( try while true do l := (Unix.readdir d) :: !l done; assert false with End_of_file -> () ); Unix.closedir d; List.rev !l with | error -> Unix.closedir d; raise error let copy_prim ~streaming orig_fs orig_name dest_fs dest_name = let sflags = if streaming then [`Streaming] else [] in Netchannels.with_in_obj_channel (orig_fs#read (sflags @ [`Binary]) orig_name) (fun r_ch -> Netchannels.with_out_obj_channel (dest_fs#write (sflags @ [`Binary; `Truncate; `Create]) dest_name) (fun w_ch -> w_ch # output_channel r_ch ) ) let local_fs ?encoding ?root ?(enable_relative_paths=false) () : stream_fs = let enc = match encoding with | None -> ( match Sys.os_type with | "Win32" -> Netconversion.user_encoding() | _ -> None ) | Some e -> Some e in ( match enc with | None -> () | Some e -> if not (Netconversion.is_ascii_compatible e) then failwith "Netfs.local_fs: the encoding is not ASCII-compatible"; ); let excl = match Sys.os_type with | "Win32" | "Cygwin" -> (* http://msdn.microsoft.com/en-us/library/aa365247%28v=VS.85%29.aspx *) [ 0, 31; (* control chars *) 42, 42; (* <, >, :, quotation mark, /, backslash, |, ?, * *) 47, 47; 58, 58; 60, 60; 62, 63; 92, 92; 124, 124 ] | _ -> [ 0, 0; 47, 47 ] in let excl_array_size = List.fold_left (fun mx (from,upto) -> max mx upto) 0 excl + 1 in let excl_array = ( let a = Array.make excl_array_size false in List.iter (fun (from,upto) -> for k = from to upto do a.(k) <- true done ) excl; a) in let check_component path c = let iter f s = match enc with | None -> String.iter (fun c -> f (Char.code c)) s | Some e -> Netconversion.ustring_iter e f s in try iter (fun code -> if code < excl_array_size && excl_array.(code) then raise (Unix.Unix_error(Unix.EINVAL, "Netfs: invalid char in path", path)) ) c with Netconversion.Malformed_code -> raise (Unix.Unix_error(Unix.EINVAL, "Netfs: path does not comply to charset encoding", path)) in let win32_root = root = None && Sys.os_type = "Win32" in let is_drive_letter s = Netstring_str.string_match drive_re s 0 <> None in let is_unc s = String.length s >= 3 && s.[0] = '/' && s.[1] = '/' && s.[2] <> '/' in let check_and_norm_path p = let l = Netstring_str.split_delim slash_re p in List.iter (check_component p) l; try ( match l with | [] -> raise (Unix.Unix_error(Unix.EINVAL, "Netfs: empty path", p)) | "" :: first :: rest -> if win32_root then ( if ((not (is_drive_letter first) || rest=[]) && not (is_unc p)) then raise Not_absolute ) | first :: rest -> if win32_root then ( if not(is_drive_letter first) || rest=[] then raise Not_absolute ) else raise Not_absolute ); let np = String.concat "/" l in if win32_root then ( if is_unc p then "/" ^ np else if np.[0] = '/' then String.sub np 1 (String.length np - 1) (* remove leading / *) else np ) else np with | Not_absolute -> if enable_relative_paths then String.concat "/" l else raise (Unix.Unix_error(Unix.EINVAL, "Netfs: path not absolute", p)) in let real_root = match root with | None -> "" | Some r -> if (Unix.stat r).Unix.st_kind <> Unix.S_DIR then failwith "Netfs.local_fs: root is not a directory"; r in ( object(self) method path_encoding = enc method path_exclusions = excl method nominal_dot_dot = false method read flags filename = let fn = real_root ^ check_and_norm_path filename in let binary = List.mem `Binary flags in let skip_d = try List.find (fun flag -> match flag with | `Skip _ -> true | _ -> false ) flags with Not_found -> `Skip 0L in let skip = match skip_d with | `Skip n -> n | _ -> assert false in (* Use Unix.openfile to open so we get Unix_errors on error *) let fd = Unix.openfile fn [Unix.O_RDONLY] 0 in let st = Unix.fstat fd in if st.Unix.st_kind = Unix.S_DIR then raise(Unix.Unix_error(Unix.EISDIR,"Netfs.read","")); if skip > 0L then ignore(Unix.LargeFile.lseek fd skip Unix.SEEK_SET); let ch = Unix.in_channel_of_descr fd in set_binary_mode_in ch binary; new Netchannels.input_channel ch method read_file flags filename = let fn = real_root ^ check_and_norm_path filename in let st = Unix.stat fn in if st.Unix.st_kind = Unix.S_DIR then raise(Unix.Unix_error(Unix.EISDIR,"Netfs.read_file","")); ( object method filename = fn method close() = () end ) method write flags filename = let fn = real_root ^ check_and_norm_path filename in let binary = List.mem `Binary flags in let create = List.mem `Create flags in let truncate = List.mem `Truncate flags in let exclusive = List.mem `Exclusive flags in let mode = List.flatten [ [Unix.O_WRONLY]; if create then [ Unix.O_CREAT ] else []; if truncate then [ Unix.O_TRUNC ] else []; if exclusive then [ Unix.O_EXCL ] else []; ] in (* Use Unix.openfile to open so we get Unix_errors on error *) let fd = Unix.openfile fn mode 0o666 in let ch = Unix.out_channel_of_descr fd in set_binary_mode_out ch binary; new Netchannels.output_channel ch method write_file flags filename local = (* This is just a copy operation *) let fn = real_root ^ check_and_norm_path filename in let binary = List.mem `Binary flags in let link = List.mem `Link flags in let local_filename = local#filename in let wflags = List.map (function | #write_common as x -> (x :> write_flag) | _ -> `Dummy ) flags in try let do_copy = try not link || ( Unix.link local_filename fn; false ) with | Unix.Unix_error( ( Unix.EACCES | Unix.ELOOP | Unix.ENAMETOOLONG | Unix.ENOENT | Unix.ENOTDIR | Unix.EPERM | Unix.EROFS ), _, _) as e -> (* These errors cannot be fixed by doing copies instead *) raise e | Unix.Unix_error(_,_,_) -> true in if do_copy then ( let fd_local = Unix.openfile local_filename [Unix.O_RDONLY] 0 in let ch_local = Unix.in_channel_of_descr fd_local in set_binary_mode_in ch_local binary; Netchannels.with_in_obj_channel (new Netchannels.input_channel ch_local) (fun obj_local -> Netchannels.with_out_obj_channel (self # write wflags filename) (fun out -> out # output_channel obj_local ) ); ); local#close() with | error -> local#close(); raise error method size flags filename = let fn = real_root ^ check_and_norm_path filename in let fd = Unix.openfile fn [Unix.O_RDONLY] 0 in try let n = Unix.LargeFile.lseek fd 0L Unix.SEEK_END in Unix.close fd; n with | error -> Unix.close fd; raise error (* esp. non-seekable *) method private test_list_NH flags fn = try let st = Unix.LargeFile.lstat fn in if st.Unix.LargeFile.st_kind = Unix.S_LNK then [ `N; `H ] else [ `N ] with | Unix.Unix_error(Unix.ENOENT,_,_) -> [] method private test_list_EDFS flags fn = try let st = if List.mem `Link flags then Unix.LargeFile.lstat fn else Unix.LargeFile.stat fn in let non_empty = st.Unix.LargeFile.st_size <> 0L in let kind_l = match st.Unix.LargeFile.st_kind with | Unix.S_REG -> [ `F ] | Unix.S_DIR -> [ `D ] | _ -> [] in [ `E ] @ kind_l @ (if non_empty then [`S] else []) with | Unix.Unix_error(Unix.ENOENT,_,_) -> [] method private test_list_RWX flags fn = let r_ok = try Unix.access fn [Unix.R_OK]; true with _ -> false in let w_ok = try Unix.access fn [Unix.W_OK]; true with _ -> false in let x_ok = try Unix.access fn [Unix.X_OK]; true with _ -> false in List.flatten [ if r_ok then [`R] else []; if w_ok then [`W] else []; if x_ok then [`X] else [] ] method test flags filename ttype = let fn = real_root ^ check_and_norm_path filename in let l = match ttype with | `N | `H -> self#test_list_NH flags fn | `E | `D | `F | `S -> self#test_list_EDFS flags fn | `R | `W | `X -> self#test_list_RWX flags fn in List.mem ttype l method test_list flags filename tests = let fn = real_root ^ check_and_norm_path filename in let nh = if not(list_isect_empty tests [`N;`H]) then self#test_list_NH flags fn else [] in let edfs = if not(list_isect_empty tests [`E;`D;`F;`S]) then self#test_list_EDFS flags fn else [] in let rwx = if not(list_isect_empty tests [`R;`W;`X]) then self#test_list_RWX flags fn else [] in List.map (fun t -> match t with | `N | `H -> List.mem t nh | `E | `D | `F | `S -> List.mem t edfs | `R | `W | `X -> List.mem t rwx ) tests method remove flags filename = let fn = real_root ^ check_and_norm_path filename in if List.mem `Recursive flags then ( try self#rm_r_safe fn with Unavailable -> self#rm_r_trad fn ) else Unix.unlink fn (* A rename race: while the recursive removal progresses, a second process renames the directory. The removal function suddenly does not find the directory anymore. Even worse, the second process could move a different directory into the place of the old directory being deleted. In this case, the wrong data would be deleted. We can avoid this in the style of rm_r_safe, or by chdir-ing into the directory hierarchy. The latter is incompatible with multi-threading, so we don't do it here. *) method private rm_r_trad fn = (* "traditional" implemenation w/o protection against rename races *) let is_dir fn = try (Unix.stat fn).Unix.st_kind = Unix.S_DIR with _ -> false in let rec recurse fn = if is_dir fn then ( let files = readdir (Unix.opendir fn) in List.iter (fun file -> if file <> "." && file <> ".." then ( recurse (fn ^ "/" ^ file) ) ) files; Unix.rmdir fn; ) else Unix.unlink fn in recurse fn method private rm_r_safe fn = (* safer implemention using openat and fdopendir *) let rec rm_dir_entries fd = let files = readdir (Netsys_posix.fdopendir (Unix.dup fd)) in List.iter (fun file -> if file <> "." && file <> ".." then rm_dir_or_file fd file ) files and rm_dir_or_file fd file = let file_fd = Netsys_posix.openat fd file [Unix.O_RDONLY] 0 in let file_is_dir = try (Unix.fstat file_fd).Unix.st_kind = Unix.S_DIR with _ -> false in if file_is_dir then ( ( try rm_dir_entries file_fd with error -> Unix.close file_fd; raise error ); Unix.close file_fd; Netsys_posix.unlinkat fd file [Netsys_posix.AT_REMOVEDIR] ) else ( Unix.close file_fd; Netsys_posix.unlinkat fd file [] ) in let test_availability() = if not (Netsys_posix.have_at()) then raise Unavailable; try let dir = Netsys_posix.fdopendir(Unix.openfile "." [Unix.O_RDONLY] 0) in Unix.closedir dir with _ -> raise Unavailable in test_availability(); rm_dir_or_file Netsys_posix.at_fdcwd fn method rename flags oldname newname = let oldfn = real_root ^ check_and_norm_path oldname in let newfn = real_root ^ check_and_norm_path newname in Unix.rename oldfn newfn method symlink flags oldpath newpath = let oldfn = real_root ^ check_and_norm_path oldpath in let newfn = real_root ^ check_and_norm_path newpath in Unix.symlink oldfn newfn method readdir flags filename = let fn = real_root ^ check_and_norm_path filename in readdir (Unix.opendir fn) method readlink flags filename = let fn = real_root ^ check_and_norm_path filename in Unix.readlink fn method mkdir flags filename = if List.mem `Path flags then self#mkdir_p filename else ( let fn = real_root ^ check_and_norm_path filename in try Unix.mkdir fn 0o777 with | Unix.Unix_error(Unix.EEXIST,_,_) when List.mem `Nonexcl flags -> () ) method private mkdir_p filename = let rec traverse curdir todo = match todo with | [] -> () | d :: todo' -> let curdir' = curdir @ [d] in let p = String.concat "/" curdir' in let fn = real_root ^ p in ( try Unix.mkdir fn 0o777 with Unix.Unix_error(Unix.EEXIST,_,_) -> () ); traverse curdir' todo' in let fn1 = check_and_norm_path filename in let l = Netstring_str.split_delim slash_re fn1 in traverse [List.hd l] (List.tl l) method rmdir flags filename = let fn = real_root ^ check_and_norm_path filename in Unix.rmdir fn method copy flags srcfilename destfilename = copy_prim ~streaming:false self srcfilename self destfilename method cancel () = () (* This is totally legal here - the user has to invoke close_out anyway as part of the cancellation protocol. *) end ) let convert_path ?subst oldfs newfs oldpath = match oldfs#path_encoding, newfs#path_encoding with | Some oldenc, Some newenc -> Netconversion.convert ?subst ~in_enc:oldenc ~out_enc:newenc oldpath | _ -> oldpath let copy ?(replace=false) ?(streaming=false) orig_fs0 orig_name dest_fs0 dest_name = let orig_fs = (orig_fs0 :> stream_fs) in let dest_fs = (dest_fs0 :> stream_fs) in if replace then dest_fs # remove [] dest_name; try if orig_fs = dest_fs then orig_fs # copy [] orig_name dest_name else raise(Unix.Unix_error(Unix.ENOSYS,"","")) with | Unix.Unix_error(Unix.ENOSYS,_,_) | Unix.Unix_error(Unix.EXDEV,_,_) -> copy_prim ~streaming orig_fs orig_name dest_fs dest_name type file_kind = [ `Regular | `Directory | `Symlink | `Other | `None ] let iter ~pre ?(post=fun _ -> ()) fs0 start = let fs = (fs0 :> stream_fs) in let rec iter_members dir rdir = let files = fs # readdir [] dir in List.iter (fun file -> if file <> "." && file <> ".." then ( let absfile = dir ^ "/" ^ file in let relfile = if rdir="" then file else rdir ^ "/" ^ file in let l0 = fs#test_list [] absfile [`D; `F; `E] in let l1 = fs#test_list [`Link] absfile [`D; `F; `H] in let (is_dir0, is_reg0, is_existing) = match l0 with | [is_dir; is_reg; is_ex] -> (is_dir, is_reg, is_ex) | _ -> assert false in let (is_dir1, is_reg1, is_link) = match l1 with | [is_dir; is_reg; is_link] -> (is_dir, is_reg, is_link) | _ -> assert false in if is_dir1 then ( pre relfile `Directory `Directory; iter_members absfile relfile; post relfile ) else ( let t0 = if is_reg0 then `Regular else if is_dir0 then `Directory else if is_existing then `Other else `None in let t1 = if is_reg1 then `Regular else if is_dir1 then `Directory else if is_link then `Symlink else `Other in pre relfile t0 t1 ) ) ) files in iter_members start "" let copy_into ?(replace=false) ?subst ?streaming orig_fs0 orig_name dest_fs0 dest_name = let orig_fs = (orig_fs0 :> stream_fs) in let dest_fs = (dest_fs0 :> stream_fs) in let orig_base = Filename.basename orig_name in let dest_start = dest_name ^ "/" ^ convert_path ?subst orig_fs dest_fs orig_base in if not(dest_fs # test [] dest_name `D) then raise(Unix.Unix_error (Unix.ENOENT, "Netfs.copy_into: destination directory does not exist", dest_name)); if orig_fs # test [] orig_name `D then ( if replace then dest_fs # remove [ `Recursive ] dest_start; dest_fs # mkdir [ `Nonexcl ] dest_start; iter ~pre:(fun rpath typ link_typ -> let dest_rpath = convert_path ?subst orig_fs dest_fs rpath in match link_typ with | `Regular -> copy ?streaming orig_fs (orig_name ^ "/" ^ rpath) dest_fs (dest_start ^ "/" ^ dest_rpath) | `Directory -> dest_fs # mkdir [ `Nonexcl ] (dest_start ^ "/" ^ dest_rpath) | `Symlink -> dest_fs # symlink [] (orig_fs # readlink [] (orig_name ^ "/" ^ rpath)) (dest_start ^ "/" ^ dest_rpath) | `Other -> () ) orig_fs orig_name ) else copy ~replace ?streaming orig_fs orig_name dest_fs dest_start ocamlnet-4.0.4/src/netstring/netaccel.ml0000644000175000017500000000161712541553661016676 0ustar gerdgerd(* $Id: netaccel.ml 798 2004-07-08 22:11:07Z stolpmann $ *) external int_blit : int array -> int -> int array -> int -> int -> unit = "netstring_int_blit_ml" ;; external int_series : int array -> int -> int array -> int -> int -> int -> unit = "netstring_int_series_byte" "netstring_int_series_ml";; external read_iso88591 : int -> Netconversion.encoding -> int array -> int array -> string -> int -> int -> (int*int*Netconversion.encoding) = "netstring_read_iso88591_byte" "netstring_read_iso88591_ml" ;; external read_utf8 : bool -> int array -> int array -> string -> int -> int -> (int*int*Netconversion.encoding) = "netstring_read_utf8_byte" "netstring_read_utf8_ml" ;; let init() = Netaux.ArrayAux.int_blit_ref := int_blit; Netaux.ArrayAux.int_series_ref := int_series; Netconversion.read_iso88591_ref := read_iso88591; Netconversion.read_utf8_ref := read_utf8;; ocamlnet-4.0.4/src/netstring/netconst.mlp0000644000175000017500000000014012541553661017123 0ustar gerdgerd(* $Id: netconst.mlp 1015 2006-10-02 13:54:31Z gerd $ *) let ocamlnet_version = "@VERSION@" ;; ocamlnet-4.0.4/src/netstring/netmech_scram.mli0000644000175000017500000003627212541553661020106 0ustar gerdgerd(* $Id: netmech_scram.mli 2195 2015-01-01 12:23:39Z gerd $ *) (** SCRAM mechanism for authentication (RFC 5802) *) (** This implements SCRAM for SASL and GSSAPI. {b This module needs the SHA-1 hash function. In order to use it, initialize crypto support, e.g. by including the [nettls-gnutls] packages and calling {!Nettls_gnutls.init}.} As for all SASL mechanisms in OCamlnet, SASLprep is not automatically called. Users of SCRAM should pass user names and passwords through {!Netsaslprep.saslprep}. *) type ptype = [ `GSSAPI | `SASL | `HTTP ] (** Profile types: - [`GSSAPI]: as defined in RFC 5802, the gs2-header is omitted - [`SASL]: as defined in RFC 5802 - [`HTTP]: at the moment this follows draft-ietf-httpauth-scram-auth-03, and uses a different [gs2-header] *) type profile = { ptype : ptype; hash_function : Netsys_digests.iana_hash_fn; (** Which hash function *) return_unknown_user : bool; (** Whether servers exhibit the fact that the user is unknown *) iteration_count_limit : int; (** Largest supported iteration number *) } (** Profile *) type cb = Netsys_sasl_types.cb (** Using the same channel binding type as for SASL *) type server_error = [ `Invalid_encoding | `Extensions_not_supported | `Invalid_proof | `Channel_bindings_dont_match | `Server_does_support_channel_binding | `Channel_binding_not_supported | `Unsupported_channel_binding_type | `Unknown_user | `Invalid_username_encoding | `No_resources | `Other_error | `Extension of string ] (** Error codes of this protocol *) type client_session (** Session context for clients *) type server_session (** Session context for servers *) exception Invalid_encoding of string * string (** Raised by clients when something cannot be decoded. First string is an error message, the second string the raw message that cannot be decoded *) exception Invalid_username_encoding of string * string (** Raised by clients when the username does not match the requirements. Arguments as for [Invalid_encoding]. *) exception Extensions_not_supported of string * string (** Raised by clients when the server enables an unsupported extension. Arguments as for [Invalid_encoding]. *) exception Protocol_error of string (** Raised by clients when the server violates the protocol. The argument is a message. *) exception Invalid_server_signature (** Raised by clients when the signature sent by the server is invalid (i.e. the server does not know the client password) *) exception Server_error of server_error (** Raised by clients when the server sent an error code *) val profile : ?return_unknown_user:bool -> ?iteration_count_limit:int -> ptype -> Netsys_digests.iana_hash_fn -> profile (** Creates a profile *) val string_of_server_error : server_error -> string val server_error_of_string : string -> server_error (** Conversion *) val mechanism_name : profile -> string (** The official name of the mechanism *) (** {2 Clients} *) (** The idea is to create a client session [s] first. The functions [client_emit_flag] and [client_recv_flag] indicate now whether the client needs to emit a new message, or whether it needs to receive a message, respectively. Emission is done by [client_emit_message], reception by [client_recv_message]. If everything goes well, the protocol state advances, and finally [client_finish_flag] is true. This indicates that the client is authenticated and that the server knows the client's password. If an error occurs, an exception is raised (see above for possibilities), and [client_error_flag] signals [true]. *) val create_client_session : ?nonce: string -> profile -> string -> string -> client_session (** [create_client_session p username password]: Creates a new client session for profile [p] so that the client authenticates as user [username], and proves its identity with the given [password]. *) val create_client_session2 : ?nonce:string -> profile -> string -> string -> string -> client_session (** [create_client_session p username authzname password]: Like [create_client_session], but also sets the authorization name (only processed for the SASL profile). *) val client_configure_channel_binding : client_session -> cb -> unit (** Sets whether to request channel binding. *) val client_emit_flag : client_session -> bool (** Whether [client_emit_message] can now be called *) val client_recv_flag : client_session -> bool (** Whether [client_recv_message] can now be called *) val client_finish_flag : client_session -> bool (** Whether the client is authenticated and the server verified *) val client_error_flag : client_session -> bool (** Whether an error occurred, and the protocol cannot advance anymore *) val client_channel_binding : client_session -> cb (** Returns the channel binding *) val client_emit_message : client_session -> string (** Emits the next message to be sent to the server *) val client_emit_message_kv : client_session -> string option * (string * string) list (** Emits the next message to be sent to the server. The message is not encoded as a single string, but as [(gs2_opt, kv)] where [gs2_opt] is the optional GS2 header (the production [gs2-header] from the RFC), and [kv] contains the parameters as key/value pairs. *) val client_recv_message : client_session -> string -> unit (** Receives the next message from the server *) val client_protocol_key : client_session -> string option (** The 128-bit protocol key for encrypting messages. This is available as soon as the second client message is emitted. *) val client_user_name : client_session -> string (** The user name *) val client_authz_name : client_session -> string (** The authorization name *) val client_password : client_session -> string (** The password *) val client_export : client_session -> string val client_import : string -> client_session (** Exports a client session as string, and imports the string again. The export format is just a marshalled Ocaml value. *) val client_prop : client_session -> string -> string (** Returns a property of the client (or Not_found): - "snonce" - "cnonce" - "salt" - "i" (iteration_count) - "protocol_key" *) (** {2 Servers} *) (** The idea is to create a server session [s] first. The functions [server_emit_flag] and [server_recv_flag] indicate now whether the server needs to emit a new message, or whether it needs to receive a message, respectively. Emission is done by [server_emit_message], reception by [server_recv_message]. If everything goes well, the protocol state advances, and finally [server_finish_flag] is true. This indicates that the client could be authenticated. If an error occurs, {b no} exception is raised, and the protocol advances nevertheless, and finally the server sends an error token to the client. After this, [server_error_flag] returns true. *) type credentials = [ `Salted_password of string * string * int | `Stored_creds of string * string * string * int ] (** Two forms of providing credentials: - [`Salted_password(spw,salt,iteration_count)]: get the salted password with [spw = salt_password h password salt iteration_count] - [`Stored(stkey, srvkey, salt, iteration_count)]: get the pair (stkey, srvkey) with [stored_key h password salt iteration_count] *) val create_server_session : ?nonce:string -> profile -> (string -> credentials) -> server_session (** [create_server_session p auth]: Creates a new server session with profile [p] and authenticator function [auth]. The function is [auth] is called when the credentials of the client have been received to check whether the client can be authenticated. It is called as {[ let credentials = auth username ]} where [username] is the user name. The function can now raise [Not_found] if the user is unknown, or it can return the credentials. Note that the cleartext password needs not to be known. The credentials contain a salt and an iteration count: [salt] is a random string, and [iteration_count] a security parameter that should be at least 4096. Whereas [salt] should be different for each user, the [iteration_count] can be chosen as a constant (e.g. 4096). Now [salted_password] can be computed from the cleartext password and these two extra parameters. See [salt_password] below. *) val create_server_session2 : ?nonce:string -> profile -> (string -> string -> credentials) -> server_session (** Same as [create_server_session], but the authentication callback gets two arguments: {[ let credentials = auth username authzname ]} where [authzname] is the passed authorization name (or "" if na). *) val create_salt : unit -> string (** Creates a random string suited as salt *) val salt_password : Netsys_digests.iana_hash_fn -> string -> string -> int -> string (** [let salted_password = salt_password h password salt iteration_count] Use this now as credentials [`Salted_password(salted_password,salt,iteration_count)]. As we do not implement [SASLprep] only passwords consisting of US-ASCII characters are accepted ([Invalid_encoding] otherwise). *) val stored_key : Netsys_digests.iana_hash_fn -> string -> string -> int -> string * string (** [let stkey,srvkey = stored_key h password salt iteration_count] Use this now as credentials [`Stored_creds(stkey,srvkey,salt,iteration_count)]. *) val server_emit_flag : server_session -> bool (** Whether [server_emit_message] can now be called *) val server_recv_flag : server_session -> bool (** Whether [server_recv_message] can now be called *) val server_finish_flag : server_session -> bool (** Whether the client is authenticated *) val server_error_flag : server_session -> bool (** Whether an error occurred, and the protocol cannot advance anymore *) val server_emit_message : server_session -> string (** Emits the next message to be sent to the client *) val server_emit_message_kv : server_session -> (string * string) list (** Emits the next message to be sent to the client. The message is returned as a list of key/value pairs. *) val server_recv_message : server_session -> string -> unit (** Receives the next message from the client *) val server_protocol_key : server_session -> string option (** The 128-bit protocol key for encrypting messages. This is available as soon as the second client message has been received. *) val server_channel_binding : server_session -> cb (** Returns the channel binding requirement. It is up to the application to enforce the binding. This information is available as soon as the second client message has been received *) val server_user_name : server_session -> string option (** The user name as transmitted from the client. This is returned here even before the authentication is completed! *) val server_authz_name : server_session -> string option (** The authorization name as transmitted from the client. This is returned here even before the authentication is completed! *) val server_export : server_session -> string val server_import : string -> server_session val server_import_any : string -> (string -> credentials) -> server_session val server_import_any2 : string -> (string -> string -> credentials) -> server_session (** Exports a server session as string, and imports the string again. [server_import] can only import established sessions. [server_import_any] can also import unfinished sessions, but one needs to pass the authentication function as for [server_create_session]. [server_import_any2] uses the modified auth function as in [server_create_session2]. *) val server_prop : server_session -> string -> string (** Returns a property of the client (or Not_found): - "snonce" - "cnonce" - "salt" - "i" (iteration_count) - "protocol_key" *) (** {2 Confidentiality} *) type specific_keys = { kc : string; ke : string; ki : string } (** The specific keys to use *) (** This module implements AES in Ciphertext Stealing mode (see RFC 3962) *) module AES_CTS : sig val c : int val m : int val encrypt : string -> string -> string val encrypt_mstrings : string -> Netxdr_mstring.mstring list -> Netxdr_mstring.mstring list val decrypt : string -> string -> string val decrypt_mstrings : string -> Netxdr_mstring.mstring list -> Netxdr_mstring.mstring list val tests : (string * string * string) list val run_tests : unit -> bool val run_mtests : unit -> bool end (** This is the cryptosystem as defined in RFC 3961, so far needed here. This uses [AES_CTS] as cipher, and SHA1-96 for signing. *) module Cryptosystem : sig exception Integrity_error val derive_keys : string -> int -> specific_keys (** [derive_keys protocol_key usage]: Returns the specific keys for this [protocol_key] and this [usage] numbers. See RFC 4121 for applicable usage numbers *) val encrypt_and_sign : specific_keys -> string -> string (** Encrypts the plaintext message and adds a signature to the ciphertext. Returns [ciphertext_with_signature]. *) val encrypt_and_sign_mstrings : specific_keys -> Netxdr_mstring.mstring list -> Netxdr_mstring.mstring list (** Same, but with data representation as [mstring list] *) val decrypt_and_verify : specific_keys -> string -> string (** Decrypts the ciphertext and verifies the attached signature. Returns the restored plaintext. For very short plaintexts (< 16 bytes) there will be some padding at the end ("residue"), as returned as [ec] above. We ignore this problem generally, because GSS-API adds a 16-byte header to the plaintext anyway, so these short messages do not occur. If the signature is not valid, the exception [Integrity_error] is raised. *) val decrypt_and_verify_mstrings : specific_keys -> Netxdr_mstring.mstring list -> Netxdr_mstring.mstring list (** Same, but with data representation as [mstring list] *) val get_ec : specific_keys -> int -> int (** [let ec = get_ec e_keys n]: Returns the required value for the "extra count" field of RFC 4121 if the plaintext message has size [n]. Here, [n] is the size of the payload message plus the token header of 16 bytes, i.e. the function is always called with [n >= 16]. Here, the returned [ec] value is always 0. *) val get_mic : specific_keys -> string -> string (** Returns a message integrity code *) val get_mic_mstrings : specific_keys -> Netxdr_mstring.mstring list -> string (** Same, but with data representation as [mstring list] *) end module Debug : sig val enable : bool ref (** Enable debugging of this module *) end ocamlnet-4.0.4/src/netstring/netdn.mli0000644000175000017500000000371112541553661016376 0ustar gerdgerd(* $Id: netdn.mli 2195 2015-01-01 12:23:39Z gerd $ *) (** X.500 distinguished names *) type oid = Netoid.t type dn = (oid * Netasn1.Value.value) list list (** This is the raw version of the DN: a sequence of relative DNs, and a relative DN is a set of (type,value) pairs. The types are things like cn, country, organization, ... *) module type AT_LOOKUP = sig val attribute_types : (oid * string * string list) list (** The above types in the format [(oid, full_name, short_names)] *) val lookup_attribute_type_by_oid : oid -> string * string list (** Looks the OID up, and returns [(full_name, short_names)]. May raise [Not_found]. *) val lookup_attribute_type_by_name : string -> oid * string * string list (** Looks the name up, which can either be a full name or a short name. Returns the whole triple [(oid, full_name, short_names)], or raises [Not_found]. *) end module type DN_string = sig (** For a given attribute lookup module [L] this module provides parser and printer for distinguished names in string format (RFC 4514). This implementation is restricted to attributes using the ASN.1 types [PrintableString], [TeletexString], [IA5String], [UniversalString], [BMPString], and [UTF8String]. It is not possible to parse hexencoded strings ('#' notation). (NB. We'd need a generic BER printer for supporting this.) *) val parse : string -> dn (** Parses the string (or fails). The string must use UTF-8 encoding. *) val print : dn -> string (** Prints the DN (cannot fail), using UTF-8 encoding *) end module DN_string_generic (L : AT_LOOKUP) : DN_string (** For a given attribute lookup module [L] this module provides parser and printer for distinguished names in string format (RFC 4514). *) (**/**) val directory_string_from_ASN1 : Netasn1.Value.value -> string (* See Netx509, where this function is exported officially *) ocamlnet-4.0.4/src/netstring/netmime_channels.mli0000644000175000017500000002624012541553661020601 0ustar gerdgerd(* $Id: netmime_channels.mli 2195 2015-01-01 12:23:39Z gerd $ *) (** MIME: parsing and printing for channels *) open Netmime open Netchannels (** {1:parsing Parsing MIME messages} *) val read_mime_header : ?unfold:bool -> (* default: false *) ?strip:bool -> (* default: true *) ?ro:bool -> (* default: false *) Netstream.in_obj_stream -> mime_header (** Decodes the MIME header that begins at the current position of the * netstream, and returns the header as class [basic_mime_header]. * After returning, the stream is advanced to the byte following the * empty line terminating the header. * * Example: To read the header at the beginning of the file "f", use: * {[ * let ch = new Netchannels.input_channel (open_in "f") in * let stream = new Netstream.input_stream ch in * let h = read_mime_header stream in * ... * stream#close_in(); (* no need to close ch *) * ]} * * Note that although the [stream] position after parsing is exactly * known, the position of [ch] cannot be predicted. * * @param unfold whether linefeeds are replaced by spaces in the values of the * header fields (Note: defaults to [false] here in contrast to * [Netmime_string.scan_header]!) * @param strip whether whitespace at the beginning and at the end of the * header fields is stripped * @param ro whether the returned header is read-only (default: false) *) (** Hint: To write the header [h] into the channel [ch], use * {[ Netmime_string.write_header ch h#fields ]} * * Link: {!Netmime_string.write_header} *) type multipart_style = [ `None | `Flat | `Deep ] (** How to parse multipart messages: * - [`None]: Do not handle multipart messages specially. Multipart bodies * are not further decoded, and returned as [`Body b] where [b] is * the transfer-encoded text representation. * - [`Flat]: If the top-level message is a multipart message, the parts * are separated and returned as list. If the parts are again multipart * messages, these inner multipart messages are not furher decoded * and returned as [`Body b]. * - [`Deep]: Multipart messages are recursively decoded and returned as * tree structure. * * This value determines how far the [complex_mime_message] structure * is created for a parsed MIME message. [`None] means that no parts * are decoded, and messages have always only a simple [`Body b], * even if [b] is in reality a multi-part body. With [`Flat], the * top-level multi-part bodies are decoded (if found), and messages * can have a structured [`Parts [_, `Body b1; _, `Body b1; ...]] * body. Finally, [`Deep] allows that inner multi-part bodies are * recursively decoded, and messages can have an arbitrarily complex * form. *) val decode_mime_body : #mime_header_ro -> out_obj_channel -> out_obj_channel (** [let ch' = decode_mime_body hdr ch]: * According to the value of the Content-transfer-encoding header field * in [hdr] the encoded MIME body written to [ch'] is decoded and transferred * to [ch]. * * Handles 7bit, 8bit, binary, quoted-printable, base64. * * Example: The file "f" contains base64-encoded data, and is to be decoded * and to be stored in "g": * * {[ * let ch_f = new Netchannels.input_channel (open_in "f") in * let ch_g = new Netchannels.output_channel (open_out "g") in * let hdr = new basic_mime_header ["content-transfer-encoding", "base64" ] in * let ch = decode_mime_body hdr ch_g in * ch # output_channel ch_f; * ch # close_out(); * ch_g # close_out(); * ch_f # close_in(); * ]} * * Note: This function is internally used by [read_mime_message] to * decode bodies. There is usually no need to call it directly. *) val storage : ?fin:bool -> store -> (mime_body * out_obj_channel) (** Creates a new storage facility for a mime body according to [store]. * This function can be used to build the [storage_style] argument * of the class [read_mime_message] (below). For example, this is * useful to store large attachments in external files, as in: * * {[ * let storage_style hdr = * let filename = hdr ... (* extract from hdr *) in * storage (`File filename) * ]} * * @param fin whether to finalize bodies stored in files. * Default: false *) val read_mime_message : ?unfold:bool -> (* Default: false *) ?strip:bool -> (* default: true *) ?ro:bool -> (* Default: false *) ?multipart_style:multipart_style -> (* Default: `Deep *) ?storage_style:(mime_header -> (mime_body * out_obj_channel)) -> Netstream.in_obj_stream -> complex_mime_message (** Decodes the MIME message that begins at the current position of the * passed netstream. It is expected that the message continues until * EOF of the netstream. * * Multipart messages are decoded as specified by [multipart_style] (see * above). * * Message bodies with content-transfer-encodings of 7bit, 8bit, binary, * base64, and quoted-printable can be processed. The bodies are stored * without content-transfer-encoding (i.e. in decoded form), but the * content-transfer-encoding header field is not removed from the header. * * The [storage_style] function determines where every message body is * stored. The corresponding header of the body is passed to the function * as argument; the result of the function is a pair of a new [mime_body] * and an [out_obj_channel] writing into this body. You can create such a * pair by calling [storage] (above). * * By default, the [storage_style] is [storage ?ro `Memory] for every header. * Here, the designator [`Memory] means that the body will be stored in an * O'Caml string. The designator [`File fn] would mean that the body will be stored in the * file [fn]. The file would be created if it did not yet exist, and * it would be overwritten if it did already exist. * * Note that the [storage_style] function is called for every non-multipart * body part. * * Large message bodies (> maximum string length) are supported if the * bodies are stored in files. The memory consumption is optimized for * this case, and usually only a small constant amount of memory is needed. * * Example: * * Parse the MIME message stored in the file f: * * {[ * let m = read_mime_message * (new input_stream (new input_channel (open_in f))) * ]} * * @param unfold whether linefeeds are replaced by spaces in the values of the * header fields (Note: defaults to [false] here in contrast to * {!Netmime_string.scan_header}!) * @param strip whether whitespace at the beginning and at the end of the * header fields is stripped * @param ro Whether the created MIME message is read-only * *) (* TODO: what about messages with type "message/*"? It may be possible that * they can be recursively decoded, but it is also legal for some media * types that they are "partial". * Currently the type "message/*" is NOT decoded. *) (** {1:printing Printing MIME Messages} *) val encode_mime_body : ?crlf:bool -> #mime_header_ro -> out_obj_channel -> out_obj_channel (** [let ch' = encode_mime_body hdr ch]: * According to the value of the Content-transfer-encoding header field * in [hdr] the unencoded MIME body written to ch' is encoded and transferred * to ch. * * Handles 7bit, 8bit, binary, quoted-printable, base64. * * For an example, see [decode_mime_body] which works in a similar way * but performs decoding instead of encoding. * * @param crlf if set (this is by default the case) CR/LF will be used for * end-of-line (eol) termination, if not set LF will be used. For 7bit, 8bit and * binary encoding the existing eol delimiters are not rewritten, so this option * has only an effect for quoted-printable and base64. *) val write_mime_message : ?wr_header:bool -> (* default: true *) ?wr_body:bool -> (* default: true *) ?nr:int -> (* default: 0 *) ?ret_boundary:string ref -> (* default: do not return it *) ?crlf:bool -> (* default: true *) Netchannels.out_obj_channel -> complex_mime_message -> unit (** Writes the MIME message to the output channel. The content-transfer- * encoding of the leaves is respected, and their bodies are encoded * accordingly. The content-transfer-encoding of multipart messages is * always "fixed", i.e. set to "7bit", "8bit", or "binary" depending * on the contents. * * The function fails if multipart messages do not have a multipart * content type field (i.e. the content type does not begin with "multipart"). * If only the boundary parameter is missing, a good boundary parameter is * added to the content type. "Good" means here that it is impossible * that the boundary string occurs in the message body if the * content-transfer-encoding is quoted-printable or base64, and that * such an occurrence is very unlikely if the body is not encoded. * If the whole content type field is missing, a "multipart/mixed" type * with a boundary parameter is added to the printed header. * * Note that already existing boundaries are used, no matter whether * they are of good quality or not. * * No other header fields are added, deleted or modified. The mentioned * modifications are _not_ written back to the passed MIME message but * only added to the generated message text. * * It is possible in some cases that the boundary does not work (both * the existing boundary, and the added boundary). This causes that a wrong * and unparseable MIME message is written. In order to ensure a correct * MIME message, it is recommended to parse the written text, and to compare * the structure of the message trees. It is, however, very unlikely that * a problem arises. * * Note that if the passed message is a simple message like (_,`Body _), * and if no content-transfer-encoding is set, the written message might * not end with a linefeed character. * * @param wr_header If true, the outermost header is written. Inner headers * of the message parts are written unless ~wr_body=false. * @param wr_body If true, the body of the whole message is written; if false, * no body is written at all. * @param nr This argument sets the counter that is included in generated * boundaries to a certain minimum value. * @param ret_boundary if passed, the boundary of the outermost multipart * message is written to this reference. (Internally used.) * @param crlf if set (this is by default the case) CR/LF will be used for * end-of-line (eol) termination, if not set LF will be used. The eol * separator is used for the header, the multipart framing, and for * bodies encoded as quoted-printable or base64. Other eol separators are * left untouched. *) ocamlnet-4.0.4/src/netstring/netoid.ml0000644000175000017500000000431212541553661016375 0ustar gerdgerd(* $Id: netoid.ml 2195 2015-01-01 12:23:39Z gerd $ *) type t = int array let equal oid1 oid2 = (oid1 = oid2) let compare oid1 oid2 = let l1 = Array.length oid1 in let l2 = Array.length oid2 in let rec cmp k = if k >= l1 || k >= l2 then if k >= l1 then ( if k >= l2 then 0 else (-1) ) else (* k >= l2 *) 1 else let p = oid1.(k) - oid2.(k) in if p = 0 then cmp (k+1) else p in cmp 0 let dec_re = Netstring_str.regexp "^[0-9]+$" let int_of_decimal s = match Netstring_str.string_match dec_re s 0 with | Some _ -> int_of_string s | None -> raise Not_found let split_re = Netstring_str.regexp "[.]" let of_string s = try Array.of_list (List.map int_of_decimal (Netstring_str.split split_re s)) with _ -> failwith "Netoid.of_string" let to_string oid = String.concat "." (List.map string_of_int (Array.to_list oid)) (* Curly notation follows RFC 2078, but additional information about DER can also be found in ITU-T X.690: http://www.itu.int/ITU-T/studygroups/com17/languages/X.690-0207.pdf *) let of_string_curly s = let oid_str_re = Netstring_str.regexp "[ \t\r\n]+\\|{\\|}" in let rec cont1 l = match l with | Netstring_str.Delim "{" :: l' -> cont2 l' | Netstring_str.Delim "}" :: _ -> raise Not_found | Netstring_str.Delim _ :: l' -> cont1 l' (* whitespace *) | _ -> raise Not_found and cont2 l = (* after "{" *) match l with | Netstring_str.Delim "{" :: _ -> raise Not_found | Netstring_str.Delim "}" :: l' -> cont3 l' | Netstring_str.Delim _ :: l' -> cont2 l' | Netstring_str.Text s :: l' -> int_of_string s :: cont2 l' | _ -> raise Not_found and cont3 l = (* after "}" *) match l with | Netstring_str.Delim ("{" | "}") :: _ -> raise Not_found | Netstring_str.Delim _ :: l' -> cont3 l' | [] -> [] | _ -> raise Not_found in let l = Netstring_str.full_split oid_str_re s in try Array.of_list(cont1 l) with | _ -> failwith "Netoid.of_string_curly" let to_string_curly oid = "{" ^ String.concat " " (List.map string_of_int (Array.to_list oid)) ^ "}" ocamlnet-4.0.4/src/netstring/META.in0000644000175000017500000000061412541553661015640 0ustar gerdgerdversion = "@VERSION@" requires = "@REGEXP_PROVIDER@ unix netsys @COMPAT_PCRE_PROVIDER@" description = "Ocamlnet - String processing library" archive(byte) = "netstring.cma" archive(byte,toploop) = "netstring.cma netstring_top.cmo" archive(native) = "netstring.cmxa" archive(native,gprof) = "netstring.p.cmxa" archive(byte,-nonetaccel) += "netaccel.cma netaccel_link.cmo" ocamlnet-4.0.4/src/netstring/nethttp.ml0000644000175000017500000017270212541553661016612 0ustar gerdgerd(* $Id: nethttp.ml 2219 2015-01-27 14:51:36Z gerd $ * ---------------------------------------------------------------------- * Nethttp: Basic definitions for the HTTP protocol *) type protocol_version = int * int type protocol_attribute = [ `Secure_https ] type protocol = [ `Http of (protocol_version * protocol_attribute list) | `Other ] let string_of_protocol = function | `Http((m,n),_) -> "HTTP/" ^ string_of_int m ^ "." ^ string_of_int n | `Other -> failwith "string_of_protocol" let http_re = Netstring_str.regexp "HTTP/\\([0-9]+\\)\\.\\([0-9]+\\)$" let protocol_of_string s = match Netstring_str.string_match http_re s 0 with | Some m -> ( try `Http ((int_of_string (Netstring_str.matched_group m 1 s), int_of_string (Netstring_str.matched_group m 2 s)), []) with Failure _ -> `Other (* Probably denial-of-service attack! *) ) | None -> `Other type http_status = (* 1xx: (informational) *) [ `Continue | `Switching_protocols (* 2xx: (successful) *) | `Ok | `Created | `Accepted | `Non_authoritative | `No_content | `Reset_content | `Partial_content (* 3xx: (redirection) *) | `Multiple_choices | `Moved_permanently | `Found | `See_other | `Not_modified | `Use_proxy | `Temporary_redirect (* 4xx: (client error) *) | `Bad_request | `Unauthorized | `Payment_required | `Forbidden | `Not_found | `Method_not_allowed | `Not_acceptable | `Proxy_auth_required | `Request_timeout | `Conflict | `Gone | `Length_required | `Precondition_failed | `Request_entity_too_large | `Request_uri_too_long | `Unsupported_media_type | `Requested_range_not_satisfiable | `Expectation_failed (* 5xx: (server error) *) | `Internal_server_error | `Not_implemented | `Bad_gateway | `Service_unavailable | `Gateway_timeout | `Http_version_not_supported ] let int_of_http_status = function (* 1xx: (informational) *) | `Continue -> 100 | `Switching_protocols -> 101 (* 2xx: (successful) *) | `Ok -> 200 | `Created -> 201 | `Accepted -> 202 | `Non_authoritative -> 203 | `No_content -> 204 | `Reset_content -> 205 | `Partial_content -> 206 (* 3xx: (redirection) *) | `Multiple_choices -> 300 | `Moved_permanently -> 301 | `Found -> 302 | `See_other -> 303 | `Not_modified -> 304 | `Use_proxy -> 305 | `Temporary_redirect -> 307 (* 4xx: (client error) *) | `Bad_request -> 400 | `Unauthorized -> 401 | `Payment_required -> 402 | `Forbidden -> 403 | `Not_found -> 404 | `Method_not_allowed -> 405 | `Not_acceptable -> 406 | `Proxy_auth_required -> 407 | `Request_timeout -> 408 | `Conflict -> 409 | `Gone -> 410 | `Length_required -> 411 | `Precondition_failed -> 412 | `Request_entity_too_large -> 413 | `Request_uri_too_long -> 414 | `Unsupported_media_type -> 415 | `Requested_range_not_satisfiable -> 416 | `Expectation_failed -> 417 (* 5xx: (server error) *) | `Internal_server_error -> 500 | `Not_implemented -> 501 | `Bad_gateway -> 502 | `Service_unavailable -> 503 | `Gateway_timeout -> 504 | `Http_version_not_supported -> 505 let string_of_http_status = function (* 1xx: (informational) *) | `Continue -> "Continue" | `Switching_protocols -> "Switching Protocols" (* 2xx: (successful) *) | `Ok -> "OK" | `Created -> "Created" | `Accepted -> "Accepted" | `Non_authoritative -> "Non-authoritative Information" | `No_content -> "No Content" | `Reset_content -> "Reset Content" | `Partial_content -> "Partial Content" (* 3xx: (redirection) *) | `Multiple_choices -> "Multiple Choices" | `Moved_permanently -> "Moved Permanently" | `Found -> "Found" | `See_other -> "See Other" | `Not_modified -> "Not Modified" | `Use_proxy -> "Use Proxy" | `Temporary_redirect -> "Temporary Redirect" (* 4xx: (client error) *) | `Bad_request -> "Bad Request" | `Unauthorized -> "Unauthorized" | `Payment_required -> "Payment Required" | `Forbidden -> "Forbidden" | `Not_found -> "Not Found" | `Method_not_allowed -> "Method Not Allowed" | `Not_acceptable -> "Not Acceptable" | `Proxy_auth_required -> "Proxy Authorization Required" | `Request_timeout -> "Request Timeout" | `Conflict -> "Conflict" | `Gone -> "Gone" | `Length_required -> "Length Required" | `Precondition_failed -> "Precondition Failed" | `Request_entity_too_large -> "Request Entity Too Large" | `Request_uri_too_long -> "Request URI Too Long" | `Unsupported_media_type -> "Unsupported Media Type" | `Requested_range_not_satisfiable -> "Request Range Not Satisfiable" | `Expectation_failed -> "Expectation Failed" (* 5xx: (server error) *) | `Internal_server_error -> "Internal Server Error" | `Not_implemented -> "Not Implemented" | `Bad_gateway -> "Bad Gateway" | `Service_unavailable -> "Service Unavailable" | `Gateway_timeout -> "Gateway Timeout" | `Http_version_not_supported -> "HTTP Version Not Supported" let http_status_of_int = function (* 1xx: (informational) *) | 100 -> `Continue | 101 -> `Switching_protocols (* 2xx: (successful) *) | 200 -> `Ok | 201 -> `Created | 202 -> `Accepted | 203 -> `Non_authoritative | 204 -> `No_content | 205 -> `Reset_content | 206 -> `Partial_content (* 3xx: (redirection) *) | 300 -> `Multiple_choices | 301 -> `Moved_permanently | 302 -> `Found | 303 -> `See_other | 304 -> `Not_modified | 305 -> `Use_proxy | 307 -> `Temporary_redirect (* 4xx: (client error) *) | 400 -> `Bad_request | 401 -> `Unauthorized | 402 -> `Payment_required | 403 -> `Forbidden | 404 -> `Not_found | 405 -> `Method_not_allowed | 406 -> `Not_acceptable | 407 -> `Proxy_auth_required | 408 -> `Request_timeout | 409 -> `Conflict | 410 -> `Gone | 411 -> `Length_required | 412 -> `Precondition_failed | 413 -> `Request_entity_too_large | 414 -> `Request_uri_too_long | 415 -> `Unsupported_media_type | 416 -> `Requested_range_not_satisfiable | 417 -> `Expectation_failed (* 5xx: (server error) *) | 500 -> `Internal_server_error | 501 -> `Not_implemented | 502 -> `Bad_gateway | 503 -> `Service_unavailable | 504 -> `Gateway_timeout | 505 -> `Http_version_not_supported | _ -> raise Not_found let base_code code = if code >= 100 && code < 200 then 100 else if code >= 200 && code < 300 then 200 else if code >= 300 && code < 400 then 300 else if code >= 400 && code < 500 then 400 else 500 type http_method = string * string (** Method name, URI *) type cache_control_token = [ `No_store | `Max_age of int | `Max_stale of int option | `Min_fresh of int | `No_transform | `Only_if_cached | `Public | `Private of string list | `No_cache of string list | `Must_revalidate | `Proxy_revalidate | `S_maxage of int | `Extension of string * string option ] type etag = [ `Weak of string | `Strong of string ] let weak_validator_match e1 e2 = match (e1,e2) with | (`Strong s1, `Strong s2) -> s1 = s2 | (`Strong s1, `Weak w2) -> s1 = w2 | (`Weak w1, `Strong s2) -> w1 = s2 | (`Weak w1, `Weak w2) -> w1 = w2 let strong_validator_match e1 e2 = match (e1,e2) with | (`Strong s1, `Strong s2) -> s1 = s2 | _ -> false exception Bad_header_field of string class type http_header = Netmime.mime_header class type http_header_ro = Netmime.mime_header_ro class type http_trailer = Netmime.mime_header class type http_trailer_ro = Netmime.mime_header_ro type netscape_cookie = { cookie_name : string; cookie_value : string; cookie_expires : float option; cookie_domain : string option; cookie_path : string option; cookie_secure : bool; } type cookie = netscape_cookie let status_re = Netstring_str.regexp "^\\([0-9]+\\)\\([ \t]+\\(.*\\)\\)?$" let status_of_cgi_header hdr = let (code, phrase) = try let status = hdr # field "Status" in ( match Netstring_str.string_match status_re status 0 with | Some m -> (int_of_string (Netstring_str.matched_group m 1 status), (try Netstring_str.matched_group m 3 status with Not_found -> "") ) | None -> failwith "Bad Status response header field" (* Don't know what to do *) ) with Not_found -> (* Maybe there is a [Location] header: *) ( try let _location = hdr # field "Location" in (302, "Found") with Not_found -> (* Default: 200 OK *) (200, "OK") ) in (* Repair [phrase] if empty: *) let phrase = if phrase = "" then ( try string_of_http_status (http_status_of_int code) with Not_found -> "Unknown" ) else phrase in (code, phrase) ;; let query_re = Netstring_str.regexp "^\\([^?]*\\)\\?\\(.*\\)$" let decode_query req_uri = match Netstring_str.string_match query_re req_uri 0 with | Some m -> (Netstring_str.matched_group m 1 req_uri, Netstring_str.matched_group m 2 req_uri) | None -> (req_uri, "") let host4_re = Netstring_str.regexp "\\([^]: \t[]+\\)\\(:\\([0-9]+\\)\\)?$" (* CHECK *) let host6_re = Netstring_str.regexp "\\[\\([^ \t]+\\)\\]\\(:\\([0-9]+\\)\\)?$" let split_host_port s = match Netstring_str.string_match host4_re s 0 with | Some m -> let host_name = Netstring_str.matched_group m 1 s in let host_port = try Some(int_of_string(Netstring_str.matched_group m 3 s)) with | Not_found -> None in (host_name, host_port) | None -> ( match Netstring_str.string_match host6_re s 0 with | Some m -> let host_name = Netstring_str.matched_group m 1 s in let host_port = try Some(int_of_string(Netstring_str.matched_group m 3 s)) with | Not_found -> None in (host_name, host_port) | None -> failwith "Invalid hostname" ) let uripath_encode s = let l = Neturl.split_path s in let l' = List.map (Netencoding.Url.encode ~plus:false) l in Neturl.join_path l' let uripath_decode s = let l = Neturl.split_path s in let l' = List.map (fun u -> let u' = Netencoding.Url.decode ~plus:false u in if String.contains u' '/' then failwith "Nethttp.uripath_decode"; u') l in Neturl.join_path l' let rev_split is_cut s = (* exported *) let rec seek_cut acc i0 i1 = if i1 >= String.length s then (String.sub s i0 (i1 - i0)) :: acc else if is_cut(String.unsafe_get s i1) then skip ((String.sub s i0 (i1 - i0)) :: acc) (i1 + 1) (i1 + 1) else seek_cut acc i0 (i1 + 1) and skip acc i0 i1 = if i1 >= String.length s then acc else if is_cut(String.unsafe_get s i1) then skip acc i0 (i1 + 1) else seek_cut acc i1 i1 in skip [] 0 0 module Cookie = struct (* This module has been written by Christophe Troestler. For full copyright message see netcgi.ml *) (* Cookies are chosen to be mutable because they are stored on the client -- there is no rollback possible -- and mutability kind of reflects that... *) type t = { mutable name : string; mutable value : string; mutable max_age : int option; mutable domain : string option; mutable path : string option; mutable secure : bool; mutable comment : string; mutable comment_url : string; mutable ports : int list option; } let make ?max_age ?domain ?path ?(secure=false) ?(comment="") ?(comment_url="") ?ports name value = { name = name; value = value; max_age = max_age; domain = domain; path = path; secure = secure; comment = comment; comment_url = comment_url; ports = ports; } (* Old version of cookies *) let of_netscape_cookie c = { name = c.cookie_name; value = c.cookie_value; max_age = (match c.cookie_expires with | None -> None | Some t -> Some(truncate(t -. Unix.time()))); domain = c.cookie_domain; path = c.cookie_path; secure = c.cookie_secure; comment = ""; comment_url = ""; ports = None } let to_netscape_cookie cookie = { cookie_name = cookie.name; cookie_value = cookie.value; cookie_expires = (match cookie.max_age with | None -> None | Some t -> Some(float t +. Unix.time())); cookie_domain = cookie.domain; cookie_path = cookie.path; cookie_secure = cookie.secure; } let name cookie = cookie.name let value cookie = cookie.value let max_age cookie = cookie.max_age let domain cookie = cookie.domain let path cookie = cookie.path let secure cookie = cookie.secure let comment cookie = cookie.comment let comment_url cookie = cookie.comment_url let ports cookie = cookie.ports let set_value cookie v = cookie.value <- v let set_max_age cookie t = cookie.max_age <- t let set_domain cookie dom = cookie.domain <- dom let set_path cookie s = cookie.path <- s let set_secure cookie b = cookie.secure <- b let set_comment cookie s = cookie.comment <- s let set_comment_url cookie s = cookie.comment_url <- s let set_ports cookie p = cookie.ports <- p (* Set -------------------------------------------------- *) (* Escape '"', '\\',... and surround the string with quotes. *) let escape s0 = let len = String.length s0 in let encoded_length = ref len in for i = 0 to len - 1 do match String.unsafe_get s0 i with | '\"' | '\\' | '\n' | '\r' -> incr encoded_length | '\000' .. '\031' -> decr encoded_length (* ignore *) | _ -> () done; let s = String.create (!encoded_length + 2) in String.unsafe_set s 0 '\"'; let j = ref 1 in for i = 0 to len - 1 do (match String.unsafe_get s0 i with | '\"' | '\\' as c -> String.unsafe_set s !j '\\'; incr j; String.unsafe_set s !j c; incr j | '\n' -> String.unsafe_set s !j '\\'; incr j; String.unsafe_set s !j 'n'; incr j | '\r' -> String.unsafe_set s !j '\\'; incr j; String.unsafe_set s !j 'r'; incr j | '\000' .. '\031' -> () (* Ignore these control chars, useless for comments *) | c -> String.unsafe_set s !j c; incr j ); done; String.unsafe_set s !j '\"'; s (* [gen_cookie c] returns a buffer containing an attribute suitable for "Set-Cookie" (RFC 2109) and "Set-Cookie2" (RFC 2965). which is backward compatible with Netscape spec. It is the minimal denominator. *) let gen_cookie c = let buf = Buffer.create 128 in (* Encode, do not quote, key-val for compatibility with old browsers. *) Buffer.add_string buf (Netencoding.Url.encode ~plus:false c.name); Buffer.add_string buf "="; Buffer.add_string buf (Netencoding.Url.encode ~plus:false c.value); Buffer.add_string buf ";Version=1"; (* FIXME: Although values of Domain and Path can be quoted since RFC2109, it seems that browsers do not understand them -- they take the quotes as part of the value. One way to get correct headers is to strip [d] and [p] of unsafe chars -- if they have any. *) (match c.domain with | None -> () | Some d -> Buffer.add_string buf ";Domain="; Buffer.add_string buf d); (match c.path with | None -> () | Some p -> Buffer.add_string buf ";Path="; Buffer.add_string buf p); if c.secure then Buffer.add_string buf ";secure"; (match c.max_age with | None -> () | Some s -> Buffer.add_string buf ";Max-Age="; Buffer.add_string buf (if s > 0 then string_of_int s else "0"); (* For compatibility with old browsers: *) Buffer.add_string buf ";Expires="; Buffer.add_string buf (if s > 0 then Netdate.mk_mail_date (Unix.time() +. float s) else "Thu, 1 Jan 1970 00:00:00 GMT"); ); if c.comment <> "" then ( Buffer.add_string buf ";Comment="; Buffer.add_string buf (escape c.comment); ); buf let set_set_cookie_ct (http_header:#Netmime.mime_header) cookies = let add_cookie (c1, c2) c = let buf = gen_cookie c in (* In any case, we set a "Set-Cookie" header *) let c1 = (Buffer.contents buf) :: c1 in let c2 = if c.comment_url = "" && c.ports = None then c2 else ( (* When this is relevant, also set a "Set-Cookie2" header *) if c.comment_url <> "" then ( Buffer.add_string buf ";CommentURL="; Buffer.add_string buf (escape c.comment_url)); (match c.ports with | None -> () | Some p -> Buffer.add_string buf ";Port=\""; Buffer.add_string buf (String.concat "," (List.map string_of_int p)); Buffer.add_string buf "\"" ); (Buffer.contents buf) :: c2 ) in (c1, c2) in let cookie, cookie2 = List.fold_left add_cookie ([], []) cookies in http_header#update_multiple_field "Set-Cookie" cookie; (* "Set-Cookie2" must come after in order, when they are understood, to override the "Set-Cookie". *) http_header#update_multiple_field "Set-Cookie2" cookie2 (* Get -------------------------------------------------- *) (* According to RFC 2068: quoted-string = ( <"> *(qdtext) <"> ) qdtext = quoted-pair = "\\" CHAR As there a no details, we decode the usual escapes and treat other "\x" as simply "x". *) let unescape_range s low up = if low >= up then "" else let len = up - low in let s = String.sub s low len in let rec decode i j = if i < len then ( match String.unsafe_get s i with | '\\' -> let i = i + 1 in if i < len then ( (match String.unsafe_get s i with | '\"' | '\\' as c -> String.unsafe_set s j c | 'n' -> String.unsafe_set s j '\n' | 'r' -> String.unsafe_set s j '\r' | 't' -> String.unsafe_set s j '\t' | c -> String.unsafe_set s j c ); decode (i + 1) (j + 1) ) else j | c -> String.unsafe_set s j c; decode (i + 1) (j + 1) ) else j in let j = decode 0 0 in if j < len then String.sub s 0 j else s let ports_of_string s = let l = rev_split (fun c -> c = ',' || c = ' ') s in List.fold_left (fun pl p -> try int_of_string p :: pl with _ -> pl) [] l (* Given a new key-val data, update the list of cookies accordingly (new cookie or update attributes of the current one). *) let add_key_val key value cl = if key <> "" && String.unsafe_get key 0 = '$' then (* Keys starting with '$' are for control; ignore the ones we do not know about. *) (match cl with | [] -> [] | c :: _ -> (if key = "$Path" then c.path <- Some value else if key = "$Domain" then c.domain <- Some value else if key = "$Port" then c.ports <- Some (ports_of_string value)); cl ) else make key value :: cl let decode_range s start _end = Netencoding.Url.decode ~pos:start ~len:(_end - start) s (* The difference between version 0 and version 1 cookies is that the latter start with $Version (present 1st or omitted). Our decoding function can handle both versions transparently, so $Version is ignored. In the absence of "=", the string is treated as the VALUE. *) (* [get_key cs i0 i len] scan the cookie string [cs] and get the key-val pairs. keys and values are stripped of heading and trailing spaces, except for quoted values. *) let rec get_key cs i0 i len cl = if i >= len then let value = decode_range cs i0 len in if value = "" then cl else make "" value :: cl else match String.unsafe_get cs i with | ',' | ';' -> (* No "=", interpret as a value as Mozilla does. We choose this over MSIE which is reported to return just "n" instead of "n=" when the value is empty. *) let cl = make "" (decode_range cs i0 i) :: cl in skip_space_before_key cs (i + 1) len cl | '=' -> let i1 = i + 1 in skip_value_space cs i1 len (decode_range cs i0 i) cl | c -> get_key cs i0 (i + 1) len cl and skip_space_before_key cs i len cl = if i >= len then cl else match String.unsafe_get cs i with | ' ' | '\t' | '\n' | '\r' -> skip_space_before_key cs (i + 1) len cl | _ -> get_key cs i i len cl and skip_value_space cs i len key cl = if i >= len then add_key_val key "" cl (* no value *) else match String.unsafe_get cs i with | ' ' | '\t' | '\n' | '\r' -> (* skip linear white space *) skip_value_space cs (i + 1) len key cl | '\"' -> get_quoted_value cs (i + 1) (i + 1) len key cl | _ -> get_value cs i i len key cl and get_value cs i0 i len key cl = if i >= len then add_key_val key (decode_range cs i0 len) cl else match String.unsafe_get cs i with | ',' | ';' -> let cl = add_key_val key (decode_range cs i0 i) cl in (* Usually there is a space after ';' to skip *) skip_space_before_key cs (i + 1) len cl | _ -> get_value cs i0 (i + 1) len key cl and get_quoted_value cs i0 i len key cl = if i >= len then (* quoted string not closed; try anyway *) add_key_val key (unescape_range cs i0 len) cl else match String.unsafe_get cs i with | '\\' -> get_quoted_value cs i0 (i + 2) len key cl | '\"' -> let cl = add_key_val key (unescape_range cs i0 i) cl in skip_to_next cs (i + 1) len cl | _ -> get_quoted_value cs i0 (i + 1) len key cl and skip_to_next cs i len cl = if i >= len then cl else match String.unsafe_get cs i with | ',' | ';' -> skip_space_before_key cs (i + 1) len cl | _ -> skip_to_next cs (i + 1) len cl let get_cookie_ct (http_header:#http_header_ro) = let cookies = http_header#multiple_field "Cookie" in let cl = List.fold_left (fun cl cs -> get_key cs 0 0 (String.length cs) cl) [] cookies in (* The order of cookies is important for the Netscape ones since "more specific path mapping should be sent before cookies with less specific path mappings" -- for those, there will be only a single "Cookie" line. *) List.rev cl end module Header = struct open Netmime open Netmime_string type param_value = [ `V of string | `Q of string ] type auth_challenge = string * (string * param_value) list type auth_credentials = string * (string * param_value) list (* As scanner we use the scanner for mail header fields from Netmime_string. It * is very configurable. *) let std_special_chars = [ ','; ';'; '=' ] (* CHECK: Maybe we should add more characters, e.g. '@'. They are not * used in HTTP, and including them here would cause that field values * containing them are rejected. Maybe we want that. *) let scan_value ?(specials = std_special_chars) s = let scanner = create_mime_scanner ~specials ~scan_options:[] s in Stream.from (fun _ -> Some (snd (scan_token scanner))) (* ---- Parser combinators for stream parsers: ---- *) let rec parse_comma_separated_list subparser stream = (* The [subparser] is required to return its value when it finds a * comma (i.e. [Special ','], or when it finds [End]. These tokens * must not be swallowed. *) let expr_opt = subparser stream in match expr_opt with | Some expr -> expr :: parse_comma_separated_rest subparser stream | None -> [] and parse_comma_separated_rest subparser stream = match Stream.peek stream with | Some(Special ',') -> Stream.junk stream; ignore(parse_commas stream); parse_comma_separated_list subparser stream | _ -> [] and parse_commas stream = match Stream.peek stream with | Some(Special ',') -> Stream.junk stream; parse_commas stream | _ -> () let parse_end stream = match Stream.peek stream with | Some End -> Stream.junk stream; () | _ -> raise Stream.Failure let merge_lists mh fieldparser fieldname = let fields = mh # multiple_field fieldname in if fields = [] then raise Not_found; List.flatten (List.map fieldparser fields) let parse_field mh fn_name f_parse fieldname = try let field = mh # field fieldname in f_parse (scan_value field) with | Stream.Failure | Stream.Error _ -> raise (Bad_header_field fn_name) let parse_comma_separated_field ?specials mh fn_name f_parse fieldname = let fieldparser field = try let stream = scan_value ?specials field in let r = parse_comma_separated_list f_parse stream in parse_end stream; r with | Stream.Failure | Stream.Error _ -> raise (Bad_header_field fn_name) in merge_lists mh fieldparser fieldname (* ----- Common parsers/printer: ---- *) let parse_token_list mh fn_name fieldname = let parse_token stream = match Stream.peek stream with | Some (Atom tok) -> Stream.junk stream; Some tok | _ -> None in parse_comma_separated_field mh fn_name parse_token fieldname let parse_token_or_qstring stream = match Stream.peek stream with | Some(Atom tok) -> Stream.junk stream; tok | Some(QString v) -> Stream.junk stream; v | _ -> raise Stream.Failure let rec parse_params stream = match Stream.npeek 3 stream with | [ Special ';'; Atom name; Special '=' ] -> for k=1 to 3 do Stream.junk stream done; let v = parse_token_or_qstring stream in (name,v) :: parse_params stream | _ -> [] let parse_extended_token_list mh fn_name fieldname = (* token [ '=' (token|qstring) ( ';' token '=' (token|qstring) ) * ] *) let rec parse_extended_token stream = match Stream.peek stream with | Some(Atom tok) -> Stream.junk stream; let extension = parse_equation stream in ( match extension with | Some (eq_val, params) -> Some (tok, Some eq_val, params) | None -> Some (tok, None, []) ) | _ -> None and parse_equation stream = match Stream.peek stream with | Some(Special '=') -> Stream.junk stream; let v = parse_token_or_qstring stream in let params = parse_params stream in Some (v, params) | _ -> None in parse_comma_separated_field mh fn_name parse_extended_token fieldname let qstring_indicator_re = Netstring_str.regexp "[]\\\"()<>@,;:/[?={} \x00-\x1f\x7f]" (* Netstring_pcre.regexp "[\\\\\"()<>@,;:/[\\]?={} \\x00-\\x1f\\x7f]" *) let qstring_re = Netstring_str.regexp "[\\\"]" (* Netstring_pcre.regexp "[\\\\\\\"]" *) let qstring_of_value s = (* Returns a qstring *) "\"" ^ Netstring_str.global_replace qstring_re "\\\\\\0" s ^ "\"" (* Escape qstring_re with a backslash *) let string_of_value s = (* Returns a token or a qstring, depending on the value of [s] *) try ignore(Netstring_str.search_forward qstring_indicator_re s 0); qstring_of_value s with Not_found -> s let string_of_params l = if l = [] then "" else ";" ^ String.concat ";" (List.map (fun (n,s) -> n ^ "=" ^ string_of_value s) l) let string_of_extended_token fn_name = function | (tok, None, []) -> tok | (tok, None, _) -> invalid_arg fn_name | (tok, Some eq_val, params) -> tok ^ "=" ^ eq_val ^ string_of_params params let parse_parameterized_token_list mh fn_name fieldname = (* token ( ';' token '=' (token|qstring) ) * *) let rec parse_parameterized_token stream = match Stream.peek stream with | Some (Atom tok) -> Stream.junk stream; let params = parse_params stream in Some(tok, params) | _ -> None in parse_comma_separated_field mh fn_name parse_parameterized_token fieldname let string_of_parameterized_token (tok, params) = tok ^ string_of_params params let q_split ( l : (string * (string * string) list) list ) : (string * (string * string) list * (string * string) list) list = (* Find the "q" param, and split [params] at that position *) let rec split params = match params with | [] -> ([], []) | ("q", q) :: rest -> ([], params) | other :: rest -> let before, after = split rest in (other :: before), after in List.map (fun (tok, params) -> let before, after = split params in (tok, before, after)) l let q_merge fn_name (tok, params, q_params) = if List.mem_assoc "q" params then invalid_arg fn_name; ( match q_params with | ( "q", _ ) :: _ | [] -> (tok, (params @ q_params)) | _ -> invalid_arg fn_name ) let date_of_string fn_name s = try Netdate.parse_epoch s with Invalid_argument _ -> raise(Bad_header_field fn_name) let string_of_date f = Netdate.format ~fmt:"%a, %d %b %Y %H:%M:%S GMT" (Netdate.create ~zone:0 f) let sort_by_q ?(default=1.0) toks_with_params = (* Sorts [toks_with_params] such that the highest [q] values come first. * Tokens with a [q] value of 0 are removed. Tokens without [q] value * are assumed to have the [default] value. This is also done with * unparseable [q] values. *) List.map snd (List.stable_sort (fun (q1, tok_param1) (q2, tok_param2) -> Pervasives.compare q2 q1) (List.filter (fun (q, tok_param) -> q > 0.0) (List.map (fun (tok, params) -> try let q_str = List.assoc "q" params in (float_of_string q_str, (tok, params)) with | Not_found -> (default, (tok, params)) | Failure _ -> (default, (tok, params)) ) toks_with_params))) let sort_by_q' ?default tok_with_params_and_qparams = List.map (fun ((tok, tok_params), q_params) -> (tok, tok_params, q_params)) (sort_by_q ?default (List.map (fun (tok, tok_params, q_params) -> ((tok, tok_params), q_params)) tok_with_params_and_qparams)) (* ---- The field accessors: ---- *) let get_accept mh = q_split (parse_parameterized_token_list mh "Nethttp.get_accept" "Accept") let set_accept mh av = let s = String.concat "," (List.map (fun triple -> string_of_parameterized_token (q_merge "Nethttp.set_accept" triple)) av) in mh # update_field "Accept" s let best_media_type mh supp = let match_mime a b = let (main_type, sub_type) = Netmime_string.split_mime_type b in sub_type = "*" (*Ignore non-wildcard types*) && (main_type = "*" || main_type = (fst (Netmime_string.split_mime_type a))) in let filter p l = List.fold_right (fun ((tok, _, _) as e) l -> if p tok then e :: l else l) l [] in let accept = try get_accept mh with Not_found -> [ "*/*",[],[] ] in match sort_by_q' (List.flatten (List.map (fun t -> filter ((=) t) accept @ filter (match_mime t) accept ) supp)) with (tok, params, qparams) :: _ -> (tok, params) | [] -> ("", []) let get_accept_charset mh = parse_parameterized_token_list mh "Nethttp.get_accept_charset" "Accept-Charset" let set_accept_charset mh l = mh # update_field "Accept-Charset" (String.concat "," (List.map string_of_parameterized_token l)) let best_tok_of_list toks supp = let tok = List.find (fun tok -> tok = "*" || List.mem tok supp) toks in if tok = "*" then List.find (fun tok -> not (List.mem tok toks)) supp else tok let best_charset mh supp = try let toks_with_params = get_accept_charset mh in (* or Not_found *) (* Special handling of ISO-8859-1: *) let toks_with_params' = if not(List.mem_assoc "*" toks_with_params) && not(List.exists (fun (tok,_) -> String.lowercase tok = "iso-8859-1") toks_with_params) then toks_with_params @ [ "ISO-8859-1", ["q", "1.0"] ] else toks_with_params in let toks' = List.map fst (sort_by_q toks_with_params') in best_tok_of_list toks' supp with Not_found -> "*" let get_accept_encoding mh = parse_parameterized_token_list mh "Nethttp.get_accept_encoding" "Accept-Encoding" let set_accept_encoding mh l = mh # update_field "Accept-Encoding" (String.concat "," (List.map string_of_parameterized_token l)) let best_encoding mh supp = try let toks_with_params = sort_by_q (get_accept_encoding mh) in best_tok_of_list (List.map fst toks_with_params) supp with Not_found -> "identity" let get_accept_language mh = parse_parameterized_token_list mh "Nethttp.get_accept_language" "Accept-Language" let set_accept_language mh l = mh # update_field "Accept-Language" (String.concat "," (List.map string_of_parameterized_token l)) let get_accept_ranges mh = parse_token_list mh "Nethttp.get_accept_ranges" "Accept-Ranges" let set_accept_ranges mh toks = mh # update_field "Accept-Ranges" (String.concat "," toks) let get_age mh = try float_of_string (mh # field "Age") with Failure _ -> raise(Bad_header_field "Nethttp.get_age") let set_age mh v = mh # update_field "Age" (Printf.sprintf "%.0f" v) let get_allow mh = parse_token_list mh "Nethttp.get_allow" "Allow" let set_allow mh toks = mh # update_field "Allow" (String.concat "," toks) let comma_split_re = Netstring_str.regexp "\\([ \t]*,\\)+[ \t]*" let comma_split = Netstring_str.split comma_split_re let parse_opt_eq_token stream = match Stream.peek stream with | Some(Special '=') -> Stream.junk stream; ( match Stream.peek stream with | Some (Atom v) -> Stream.junk stream; Some v | Some (QString v) -> Stream.junk stream; Some v | _ -> raise Stream.Failure ) | _ -> None let parse_cc_directive_1 stream = match Stream.npeek 3 stream with | (Atom "no-cache") :: _ -> Stream.junk stream; ( match parse_opt_eq_token stream with | None -> `No_cache [] | Some names -> `No_cache(comma_split names) ) | (Atom "no-store") :: _ -> Stream.junk stream; `No_store | [ Atom "max-age"; Special '='; Atom seconds ] -> for k = 1 to 3 do Stream.junk stream done; `Max_age(int_of_string seconds) | (Atom "max-stale") :: _ -> Stream.junk stream; ( match parse_opt_eq_token stream with | None -> `Max_stale None | Some seconds -> `Max_stale(Some(int_of_string seconds)) ) | [ Atom "min-fresh"; Special '='; Atom seconds ] -> for k = 1 to 3 do Stream.junk stream done; `Min_fresh(int_of_string seconds) | ( Atom "no-transform") :: _ -> Stream.junk stream; `No_transform | ( Atom "only-if-cached") :: _ -> Stream.junk stream; `Only_if_cached | ( Atom "public") :: _ -> Stream.junk stream; `Public | ( Atom "private") :: _ -> ( match parse_opt_eq_token stream with | None -> `Private [] | Some names -> `Private(comma_split names) ) | ( Atom "must-revalidate") :: _ -> Stream.junk stream; `Must_revalidate | ( Atom "proxy-revalidate") :: _ -> Stream.junk stream; `Proxy_revalidate | [ Atom "s-maxage"; Special '='; Atom seconds ] -> for k = 1 to 3 do Stream.junk stream done; `S_maxage(int_of_string seconds) | ( Atom extension ) :: _ -> Stream.junk stream; let val_opt = parse_opt_eq_token stream in `Extension(extension, val_opt) | _ -> raise Stream.Failure let parse_cc_directive stream = try Some (parse_cc_directive_1 stream) with Stream.Failure -> None let get_cache_control mh = parse_comma_separated_field mh "Nethttp.get_cache_control" parse_cc_directive "Cache-Control" let set_cache_control mh l = let s = String.concat "," (List.map (function | `No_store -> "no-store" | `Max_age n -> "max-age=" ^ string_of_int n | `Max_stale None -> "max-stale" | `Max_stale(Some n) -> "max-stale=" ^ string_of_int n | `Min_fresh n -> "min-fresh=" ^ string_of_int n | `No_transform -> "no-transform" | `Only_if_cached -> "only-if-cached" | `Public -> "public" | `Private names -> "private=\"" ^ String.concat "," names ^ "\"" | `No_cache [] -> "no-cache" | `No_cache names -> "no-cache=\"" ^ String.concat "," names ^ "\"" | `Must_revalidate -> "must-revalidate" | `Proxy_revalidate -> "proxy-revalidate" | `S_maxage n -> "s-maxage=" ^ string_of_int n | `Extension(tok,None) -> tok | `Extension(tok, Some param) -> tok ^ "=" ^ string_of_value param ) l) in mh # update_field "Cache-Control" s let get_connection mh = parse_token_list mh "Nethttp.get_connection" "Connection" let set_connection mh toks = mh # update_field "Connection" (String.concat "," toks) let get_content_encoding mh = parse_token_list mh "Nethttp.get_content_encoding" "Content-Encoding" let set_content_encoding mh toks = mh # update_field "Content-Encoding" (String.concat "," toks) let get_content_language mh = parse_token_list mh "Nethttp.get_content_language" "Content-Language" let set_content_language mh toks = mh # update_field "Content-Language" (String.concat "," toks) let get_content_length mh = try Int64.of_string (mh # field "Content-Length") with Failure _ -> raise (Bad_header_field "Nethttp.get_content_length") let set_content_length mh n = mh # update_field "Content-Length" (Int64.to_string n) let get_content_location mh = mh # field "Content-Location" let set_content_location mh s = mh # update_field "Content-Location" s let get_content_md5 mh = mh # field "Content-MD5" let set_content_md5 mh s = mh # update_field "Content-MD5" s let parse_byte_range_resp_spec stream = match Stream.npeek 3 stream with | (Special '*') :: _ -> Stream.junk stream; None | [ Atom first; Special '-'; Atom last ] -> for k = 1 to 3 do Stream.junk stream done; Some(Int64.of_string first, Int64.of_string last) | _ -> raise Stream.Failure let parse_byte_range_resp_length stream = match Stream.peek stream with | Some (Special '*') -> Stream.junk stream; None | Some (Atom length) -> Stream.junk stream; Some(Int64.of_string length) | _ -> raise Stream.Failure let parse_content_range_spec stream = if Stream.next stream <> Atom "bytes" then raise Stream.Failure; let br = parse_byte_range_resp_spec stream in if Stream.next stream <> Special '/' then raise Stream.Failure; let l = parse_byte_range_resp_length stream in if Stream.next stream <> End then raise Stream.Failure; `Bytes(br,l) let get_content_range mh = let s = mh # field "Content-Range" in let stream = scan_value ~specials:[ ','; ';'; '='; '*'; '-'; '/' ] s in try parse_content_range_spec stream with | Stream.Failure | Stream.Error _ | Failure _ -> raise (Bad_header_field "Nethttp.get_content_range") let set_content_range mh (`Bytes(range_opt,length_opt)) = let s = ( match range_opt with | Some (first,last) -> Int64.to_string first ^ "-" ^ Int64.to_string last | None -> "*" ) ^ "/" ^ ( match length_opt with | Some length -> Int64.to_string length | None -> "*" ) in mh # update_field "Content-Range" ("bytes " ^ s) let get_content_type mh = try List.hd (parse_parameterized_token_list mh "Nethttp.get_content_type" "Content-Type") with Failure _ -> raise(Bad_header_field "Nethttp.get_content_type") let set_content_type mh (tok,params) = mh # update_field "Content-Type" (string_of_parameterized_token (tok,params)) let get_date mh = date_of_string "Nethttp.get_date" (mh # field "Date") let set_date mh d = mh # update_field "Date" (string_of_date d) let parse_etag_token stream = match Stream.npeek 3 stream with | [ Atom "W"; Special '/'; QString e ] -> for k = 1 to 3 do Stream.junk stream done; `Weak e | (QString e) :: _ -> Stream.junk stream; `Strong e | _ -> raise Stream.Failure let parse_etag stream = let etag = parse_etag_token stream in parse_end stream; etag let get_etag mh = let s = mh # field "ETag" in let stream = scan_value ~specials:[ ','; ';'; '='; '/' ] s in try parse_etag stream with | Stream.Failure | Stream.Error _ | Failure _ -> raise (Bad_header_field "Nethttp.get_etag") let string_of_etag = function | `Weak s -> "W/" ^ qstring_of_value s | `Strong s -> qstring_of_value s let set_etag mh etag = mh # update_field "ETag" (string_of_etag etag) let get_expect mh = parse_extended_token_list mh "Nethttp.get_expect" "Expect" let set_expect mh expectation = mh # update_field "Expect" (String.concat "," (List.map (string_of_extended_token "Nethttp.set_expect") expectation)) let get_expires mh = date_of_string "Nethttp.get_expires" (mh # field "Expires") let set_expires mh d = mh # update_field "Expires" (string_of_date d) let get_from mh = mh # field "From" let set_from mh v = mh # update_field "From" v let get_host mh = let s = mh # field "Host" in try split_host_port s with | Failure _ -> raise(Bad_header_field "Nethttp.get_host") let set_host mh (host,port_opt) = let s = host ^ ( match port_opt with Some p -> ":" ^ string_of_int p | None -> "") in mh # update_field "Host" s let parse_etag_or_star_tok stream = match Stream.peek stream with | Some (Special '*') -> Stream.junk stream; Some None | _ -> try Some(Some(parse_etag_token stream)) with | Stream.Failure -> None let get_etag_list mh fn_name fieldname = let specials = [ ','; ';'; '='; '/'; '*' ] in let l = parse_comma_separated_field ~specials mh fn_name parse_etag_or_star_tok fieldname in if List.mem None l then None else Some(List.map (function Some e -> e | None -> assert false) l) let set_etag_list mh fieldname l_opt = let v = match l_opt with | None -> "*" | Some l -> String.concat "," (List.map string_of_etag l) in mh # update_field fieldname v let get_if_match mh = get_etag_list mh "Nethttp.get_if_match" "If-Match" let set_if_match mh = set_etag_list mh "If-Match" let get_if_modified_since mh = date_of_string "Nethttp.get_if_modified_since" (mh # field "If-Modified-Since") let set_if_modified_since mh d = mh # update_field "If-Modified-Since" (string_of_date d) let get_if_none_match mh = get_etag_list mh "Nethttp.get_if_none_match" "If-None-Match" let set_if_none_match mh = set_etag_list mh "If-None-Match" let get_if_range mh = let s = mh # field "If-Range" in let stream = scan_value ~specials:[ ','; ';'; '='; '/' ] s in try `Etag (parse_etag stream) with | Stream.Failure | Stream.Error _ | Failure _ -> `Date (date_of_string "Nethttp.get_if_range" s) let set_if_range mh v = let s = match v with | `Etag e -> string_of_etag e | `Date d -> string_of_date d in mh # update_field "If-Range" s let get_if_unmodified_since mh = date_of_string "Nethttp.get_if_unmodified_since" (mh # field "If-Unmodified-Since") let set_if_unmodified_since mh d = mh # update_field "If-Unmodified-Since" (string_of_date d) let get_last_modified mh = date_of_string "Nethttp.get_last_modified" (mh # field "Last-Modified") let set_last_modified mh d = mh # update_field "Last-Modified" (string_of_date d) let get_location mh = mh # field "Location" let set_location mh s = mh # update_field "Location" s let get_max_forwards mh = try int_of_string (mh # field "Max-Forwards") with Failure _ -> raise(Bad_header_field "Nethttp.get_max_forwards") let set_max_forwards mh n = mh # update_field "Max-Forwards" (string_of_int n) let parse_pragma_directive stream = match Stream.peek stream with | Some (Atom tok) -> Stream.junk stream; let param_opt = parse_opt_eq_token stream in Some (tok, param_opt) | _ -> None let get_pragma mh = parse_comma_separated_field mh "Nethttp.get_pragma" parse_pragma_directive "Pragma" let set_pragma mh l = let s = String.concat "," (List.map (function | (tok, None) -> tok | (tok, Some param) -> tok ^ "=" ^ string_of_value param) l) in mh # update_field "Pragma" s let parse_opt_last_pos stream = match Stream.peek stream with | Some(Atom last) -> Stream.junk stream; Some(Int64.of_string last) | _ -> None let rec parse_byte_range_spec stream = match Stream.npeek 2 stream with | [ Atom first; Special '-' ] -> Stream.junk stream; Stream.junk stream; let last = parse_opt_last_pos stream in let r = parse_byte_range_spec_rest stream in (Some (Int64.of_string first), last) :: r | [ Special '-'; Atom suffix_length ] -> Stream.junk stream; Stream.junk stream; let r = parse_byte_range_spec_rest stream in (None, Some(Int64.of_string suffix_length)) :: r | _ -> [] and parse_byte_range_spec_rest stream = match Stream.peek stream with | Some (Special ',') -> Stream.junk stream; parse_commas stream; parse_byte_range_spec stream | _ -> [] let parse_ranges_specifier stream = if Stream.next stream <> Atom "bytes" then raise Stream.Failure; if Stream.next stream <> Special '=' then raise Stream.Failure; let r = parse_byte_range_spec stream in if Stream.next stream <> End then raise Stream.Failure; `Bytes r let get_range mh = let s = mh # field "Range" in let stream = scan_value ~specials:[ ','; ';'; '='; '*'; '-'; '/' ] s in try parse_ranges_specifier stream with | Stream.Failure | Stream.Error _ | Failure _ -> raise (Bad_header_field "Nethttp.get_range") let set_range mh (`Bytes l) = let s = "bytes=" ^ String.concat "," (List.map (function | (Some first, Some last) -> Int64.to_string first ^ "-" ^ Int64.to_string last | (Some first, None) -> Int64.to_string first ^ "-" | (None, Some last) -> "-" ^ Int64.to_string last | (None, None) -> invalid_arg "Nethttp.set_range") l) in mh # update_field "Range" s let get_referer mh = mh # field "Referer" let get_referrer = get_referer let set_referer mh s = mh # update_field "Referer" s let set_referrer = set_referer let get_retry_after mh = let s = mh # field "Retry-After" in try `Seconds(int_of_string s) with Failure _ -> `Date(date_of_string "Nethttp.get_retry_after" s) let set_retry_after mh v = let s = match v with | `Seconds n -> string_of_int n | `Date d -> string_of_date d in mh # update_field "Retry-After" s let get_server mh = mh # field "Server" let set_server mh name = mh # update_field "Server" name let get_te mh = q_split (parse_parameterized_token_list mh "Nethttp.get_te" "TE") let set_te mh te = let s = String.concat "," (List.map (fun triple -> string_of_parameterized_token (q_merge "Nethttp.set_te" triple)) te) in mh # update_field "TE" s let get_trailer mh = parse_token_list mh "Nethttp.get_trailer" "Trailer" let set_trailer mh fields = mh # update_field "Trailer" (String.concat "," fields) let get_transfer_encoding mh = parse_parameterized_token_list mh "Nethttp.get_transfer_encoding" "Transfer-Encoding" let set_transfer_encoding mh te = let s = String.concat "," (List.map string_of_parameterized_token te) in mh # update_field "Transfer-Encoding" s let get_upgrade mh = parse_token_list mh "Nethttp.get_upgrade" "Upgrade" let set_upgrade mh fields = mh # update_field "Upgrade" (String.concat "," fields) let get_user_agent mh = mh # field "User-Agent" let set_user_agent mh s = mh # update_field "User-Agent" s let get_vary mh = let l = parse_token_list mh "Nethttp.get_vary" "Vary" in if List.mem "*" l then `Star else `Fields l let set_vary mh v = let s = match v with | `Star -> "*" | `Fields l -> String.concat "," l in mh # update_field "Vary" s (* --- Authentication --- *) let parse_challenges mh fn_name fieldname = let rec parse_auth_params stream = match Stream.npeek 2 stream with | [ Atom ap_name; Special '=' ] -> Stream.junk stream; Stream.junk stream; let ap_val = parse_token_or_qstring stream in let rest = parse_auth_param_rest stream in (ap_name, ap_val) :: rest | _ -> raise Stream.Failure and parse_auth_param_rest stream = match Stream.npeek 3 stream with | [ (Special ','); (Atom ap_name); (Special '=') ] -> Stream.junk stream; Stream.junk stream; Stream.junk stream; let ap_val = parse_token_or_qstring stream in let rest = parse_auth_param_rest stream in (ap_name, ap_val) :: rest | _ -> [] and parse_auth_params_negotiate stream = match Stream.npeek 1 stream with | [ (Atom d1) ] -> Stream.junk stream; let d2 = match Stream.npeek 1 stream with | [ Special '=' ] -> Stream.junk stream; ( match Stream.npeek 1 stream with | [ Special '=' ] -> Stream.junk stream; "==" | _ -> "=" ) | _ -> "" in [ "credentials", d1 ^ d2 ] | _ -> [ "credentials", "" ] and parse_challenge stream = match Stream.peek stream with | Some (Atom auth_scheme) -> Stream.junk stream; let auth_params = match String.lowercase auth_scheme with | "negotiate" -> parse_auth_params_negotiate stream | _ -> parse_auth_params stream in Some(auth_scheme, auth_params) | _ -> None in parse_comma_separated_field mh fn_name parse_challenge fieldname let encode_param p_val = match p_val with | `Q s -> s | `V s -> string_of_value s let mk_challenges fields = String.concat "," (List.map (fun (auth_name, auth_params) -> let pstring = match String.lowercase auth_name with | "negotiate" -> ( match auth_params with | [ "credentials", data ] -> encode_param data | _ -> "" ) | _ -> (String.concat "," (List.map (fun (p_name, p_val) -> p_name ^ "=" ^ encode_param p_val ) auth_params ) ) in auth_name ^ (if pstring <> "" then " " ^ pstring else "") ) fields) let mark_decoded (n,v) = (n, `V v) let mark_params_decoded (mech,params) = (mech, List.map mark_decoded params) let mark_many_decoded l = List.map mark_params_decoded l let get_www_authenticate mh = mark_many_decoded (parse_challenges mh "Nethttp.get_www_authenticate" "WWW-Authenticate") let parse_quoted_parameters s = let u = "dummy " ^ s in let mh = new Netmime.basic_mime_header ["WWW-Authenticate", u ] in try match get_www_authenticate mh with | [] -> [] | [_, params] -> ( List.map (fun (n,v) -> match v with | `Q _ -> assert false | `V s -> (n,s) ) params ) | _ -> assert false with | Bad_header_field _ -> failwith "parse_quoted_parameters" let set_www_authenticate mh fields = mh # update_field "WWW-Authenticate" (mk_challenges fields) let get_proxy_authenticate mh = mark_many_decoded (parse_challenges mh "Nethttp.get_proxy_authenticate" "Proxy-Authenticate") let set_proxy_authenticate mh fields = mh # update_field "Proxy-Authenticate" (mk_challenges fields) let ws_re = Netstring_str.regexp "[ \t\r\n]+";; let parse_credentials mh fn_name fieldname = let rec parse_creds stream = match Stream.peek stream with | Some (Atom auth_name) -> Stream.junk stream; let params = parse_auth_params stream in (auth_name, params) | _ -> raise Stream.Failure and parse_auth_params stream = match Stream.npeek 2 stream with | [ Atom ap_name; Special '=' ] -> Stream.junk stream; Stream.junk stream; let ap_val = parse_token_or_qstring stream in let rest = parse_auth_param_rest stream in (ap_name, ap_val) :: rest | _ -> raise Stream.Failure and parse_auth_param_rest stream = match Stream.npeek 3 stream with | [ Special ','; Atom ap_name; Special '=' ] -> Stream.junk stream; Stream.junk stream; Stream.junk stream; let ap_val = parse_token_or_qstring stream in let rest = parse_auth_param_rest stream in (ap_name, ap_val) :: rest | _ -> [] in (* Basic authentication is a special case! *) let v = mh # field fieldname in (* or Not_found *) match Netstring_str.split ws_re v with | [ name; creds ] when String.lowercase name = "basic" -> (name, ["credentials", creds]) | [ name; creds ] when String.lowercase name = "negotiate" -> (name, ["credentials", creds]) | _ -> parse_field mh fn_name parse_creds fieldname let mk_credentials (auth_name, auth_params) = match String.lowercase auth_name with | "basic" | "negotiate" -> let creds = try List.assoc "credentials" auth_params with Not_found -> failwith "Nethttp.mk_credentials: credentials not found" in auth_name ^ " " ^ encode_param creds | _ -> auth_name ^ " " ^ (String.concat "," (List.map (fun (p_name, p_val) -> p_name ^ "=" ^ encode_param p_val) auth_params)) let get_authorization mh = mark_params_decoded (parse_credentials mh "Nethttp.get_authorization" "authorization") let set_authorization mh v = mh # update_field "Authorization" (mk_credentials v) let get_proxy_authorization mh = mark_params_decoded (parse_credentials mh "Nethttp.get_proxy_authorization" "proxy-authorization") let set_proxy_authorization mh v = mh # update_field "Proxy-Authorization" (mk_credentials v) (* --- Cookies --- *) exception No_equation of string let split_name_is_value s = (* Recognizes a string "name=value" and returns the pair (name,value). * If the string has the wrong format, the function will raise * No_equation, and the argument of the exception is the unparseable * string. *) try let p = String.index s '=' in (String.sub s 0 p, String.sub s (p+1) (String.length s - p - 1)) with Not_found -> raise(No_equation s) let spaces_at_beginning_re = Netstring_str.regexp "^[ \t\r\n]+" let spaces_at_end_re = Netstring_str.regexp "[ \t\r\n]+$" let strip_spaces s = (* Remove leading and trailing spaces: *) Netstring_str.global_replace spaces_at_end_re "" (Netstring_str.global_replace spaces_at_beginning_re "" s) let split_cookies_re = Netstring_str.regexp "[ \t\r\n]*;[ \t\r\n]*" ;; let get_cookie mh = let cstrings = mh # multiple_field "Cookie" in (* Remove leading and trailing spaces: *) let cstrings' = List.map strip_spaces cstrings in let partss = List.map (fun cstring -> Netstring_str.split split_cookies_re cstring ) cstrings' in let parts = List.flatten partss in List.map (fun part -> let n,v = try split_name_is_value part with No_equation _ -> (part, "") (* Because it is reported that MSIE returns just "n" instead * of "n=" when the value v is empty *) in let n_dec = Netencoding.Url.decode n in let v_dec = Netencoding.Url.decode v in (n_dec, v_dec) ) parts let get_cookie_ct = Cookie.get_cookie_ct let set_cookie mh l = let s = String.concat ";" (List.map (fun (n,v) -> Netencoding.Url.encode n ^ "=" ^ Netencoding.Url.encode v) l) in mh # update_field "Cookie" s let nv_re = Netstring_str.regexp "^\\([^=;]+\\)\\(=\\(.*\\)\\)?$" let get_set_cookie_1 s = let nv_list = List.map (fun item -> ( match Netstring_str.string_match nv_re item 0 with | None -> raise(Bad_header_field "Nethttp.Header.get_set_cookie") | Some m -> let name = Netstring_str.matched_group m 1 item in let value = try Netstring_str.matched_group m 3 item with Not_found -> "" in (name, value) ) ) (Netstring_str.split split_cookies_re s) in match nv_list with | (n,v) :: params -> let params = List.map (fun (n,v) -> (String.lowercase n, v)) params in { cookie_name = Netencoding.Url.decode ~plus:false n; cookie_value = Netencoding.Url.decode ~plus:false v; cookie_expires = (try let exp_str = List.assoc "expires" params in Some(Netdate.since_epoch (Netdate.parse exp_str)) with | Not_found -> None); cookie_domain = ( try Some(List.assoc "domain" params) with | Not_found -> None ); cookie_path = ( try Some(List.assoc "path" params) with | Not_found -> None ); cookie_secure = ( try List.mem_assoc "secure" params with | Not_found -> false ) } | _ -> raise(Bad_header_field "Nethttp.Header.get_set_cookie") let get_set_cookie mh = let fields = mh # multiple_field "Set-Cookie" in List.map get_set_cookie_1 fields let set_set_cookie mh l = let cookie_fields = List.map (fun c -> let enc_name = Netencoding.Url.encode ~plus:false c.cookie_name in let enc_value = Netencoding.Url.encode ~plus:false c.cookie_value in enc_name ^ "=" ^ enc_value ^ ( match c.cookie_expires with None -> "" | Some t -> ";EXPIRES=" ^ Netdate.mk_usenet_date t ) ^ (match c.cookie_domain with None -> "" | Some d -> ";DOMAIN=" ^ d ) ^ (match c.cookie_path with None -> "" | Some p -> ";PATH=" ^ p ) ^ if c.cookie_secure then ";SECURE" else "" ) l in mh # update_multiple_field "Set-cookie" cookie_fields let set_set_cookie_ct = Cookie.set_set_cookie_ct end type transport_layer_id = int let new_trans_id () = Oo.id (object end) let http_trans_id = new_trans_id() let https_trans_id = new_trans_id() let spnego_trans_id = new_trans_id() let proxy_only_trans_id = new_trans_id() type match_result = [ `Accept of string * string option | `Reroute of string * int | `Accept_reroute of string * string option * int | `Reject ] module type HTTP_MECHANISM = sig val mechanism_name : string val available : unit -> bool val restart_supported : bool type credentials val init_credentials : (string * string * (string * string) list) list -> credentials val client_match : params:(string * string * bool) list -> Header.auth_challenge -> match_result type client_session val client_state : client_session -> Netsys_sasl_types.client_state val create_client_session : user:string -> creds:credentials -> params:(string * string * bool) list -> unit -> client_session val client_configure_channel_binding : client_session -> Netsys_sasl_types.cb -> unit val client_restart : params:(string * string * bool) list -> client_session -> unit val client_process_challenge : client_session -> string -> string -> #http_header_ro -> Header.auth_challenge -> unit val client_emit_response : client_session -> string -> string -> #http_header_ro -> Header.auth_credentials * (string * string) list val client_channel_binding : client_session -> Netsys_sasl_types.cb val client_user_name : client_session -> string val client_stash_session : client_session -> string val client_resume_session : string -> client_session val client_session_id : client_session -> string option val client_domain : client_session -> string list val client_prop : client_session -> string -> string val client_gssapi_props : client_session -> Netsys_gssapi.client_props end let qstring_of_value = Header.qstring_of_value ocamlnet-4.0.4/src/netstring/netmappings.ml0000644000175000017500000000234012541553661017437 0ustar gerdgerd(* $Id: netmappings.ml 2195 2015-01-01 12:23:39Z gerd $ * ---------------------------------------------------------------------- * *) type from_uni_list = U_nil | U_single of (int*int) | U_double of (int*int * int*int) | U_array of int array ;; let to_unicode = Hashtbl.create 50;; let from_unicode = Hashtbl.create 50;; let omtp = !Netsys_oothr.provider let mutex = omtp # create_mutex() let lock () = mutex#lock();; let unlock () = mutex#unlock();; let get_to_unicode enc_name : int array = lock(); try let table = try Hashtbl.find to_unicode enc_name with Not_found -> let t_str = Netdb.read_db ("cmapf." ^ enc_name) in let t = Marshal.from_string t_str 0 in Hashtbl.add to_unicode enc_name t; t in unlock(); table with error -> unlock(); raise error ;; let get_from_unicode enc_name : from_uni_list array = lock(); try let table = try Hashtbl.find from_unicode enc_name with Not_found -> let t_str = Netdb.read_db ("cmapr." ^ enc_name) in let t = Marshal.from_string t_str 0 in Hashtbl.add from_unicode enc_name t; t in unlock(); table with error -> unlock(); raise error ;; ocamlnet-4.0.4/src/netstring/netdb.ml0000644000175000017500000000242112541553661016206 0ustar gerdgerd(* $Id: netdb.ml 2196 2015-01-01 12:27:27Z gerd $ * ---------------------------------------------------------------------- * *) let values = Hashtbl.create 13 let loaders = Hashtbl.create 13 let cksums = Hashtbl.create 13 let enabled = ref true let read_db name = let v = try Hashtbl.find values name with | Not_found -> if not !enabled then failwith ("Ocamlnet: The lookup table `" ^ name ^ "' is not compiled into the program, and access to " ^ "the external file database is disabled"); let loader = try Hashtbl.find loaders name with | Not_found -> failwith ("Ocamlnet: No such lookup table: " ^ name) in loader name in try let cksum = Hashtbl.find cksums name in if Digest.string v <> cksum then failwith ("Netdb: checksum error for table: " ^ name); v with | Not_found -> v let exists_db name = Hashtbl.mem values name || (!enabled && Hashtbl.mem loaders name) let set_db name value = Hashtbl.replace values name value let set_db_checksum name cksum = Hashtbl.replace cksums name cksum let set_db_loader name loader = Hashtbl.replace loaders name loader let enable_db_loaders b = enabled := b ocamlnet-4.0.4/src/netstring/netmech_crammd5_sasl.mli0000644000175000017500000000315312541553661021343 0ustar gerdgerd(* $Id: netmech_crammd5_sasl.mli 2195 2015-01-01 12:23:39Z gerd $ *) module CRAM_MD5 : Netsys_sasl_types.SASL_MECHANISM (** The CRAM-MD5 SASL mechanism (RFC 2195), which is obsolete and only provided for completeness. Key facts: - The password is checked with a challenge-response mechanism, and does not appear in the clear. - The mechanism is vulnerable to man-in-the-middle attacks. - The client does not authenticate the server in any way. - The hash function MD5 counts as broken. - There is no support for channel binding within the mechanism. - There is no support for authorization names. - The mechanism provides at best medium security, and should only be used over channels that are otherwise secured. This implementation checks whether the server receives user names and passwords in UTF-8 encoding. Note that the mechanism predates the widespread use of Unicode, so this may cause interoperability issues with old implementations. Parameters: - Both [create_client_session] and [create_server_session] accept the boolean parameter "mutual". If true, however, authentication fails immediately, as mutual authentication cannot be supported. - The boolean parameter "secure" is ignored (i.e. we regard this mechanism as secure) As for all SASL mechanisms in OCamlnet, SASLprep is not automatically called. Users of CRAM-MD5 should pass user names and passwords through {!Netsaslprep.saslprep}. *) (**/**) val override_challenge : string -> unit (* debug *) ocamlnet-4.0.4/src/netstring/netglob.mli0000644000175000017500000005137412541553661016730 0ustar gerdgerd(* $Id: netglob.mli 1615 2011-06-09 23:33:05Z gerd $ *) (** Globbing *) (** Globbing resolves shell wildcards like "*" and "?". For example, {[ let files = Netglob.glob (`String "*.cm[iox]") ]} would return all files matching this pattern (e.g. module.cmi, module.cmo). The main user function is {!Netglob.glob}. Globbing accesses the local filesystem by default, but one can also run the globbing algorithm on any other filesystem, provided the access primitives of {!Netglob.glob_fsys} are available. *) (** {2 Types and exceptions} *) type glob_expr = glob_expr_atom list and glob_expr_atom = [ `Literal of string | `Star | `Qmark | `Bracket of (bool * glob_set) | `Brace of glob_expr list | `Tilde of string ] (** Atoms: - [`Literal s]: Matches the string literally. The string must not be empty. The backslash is not an escape character, but matches the backslash character. - [`Star]: The "*" operator - [`Qmark]: The "?" operator - [`Bracket(negated,set)]: The [[...]] operator. The [set] argument describes the characters that are matched. The [negated] argument is true when the expression is negated (i.e. [[^...]]). - [`Brace l]: The [{e1,e2,...}] operator - [`Tilde t]: The [~username] operator. If [t=""] the current user is meant. The [`Tilde] atom may only occur at the beginning of the list. The [`Tilde] atom always matches a directory, and must be followed by a literal slash (if anything follows). Compatibility: Conforms to POSIX with extensions (braces). Shells often implement brace expressions in a slightly different way (braces are parsed and expanded in a separate step before the other pattern constructors are handled). The cases where this leads to different results are quite exotic (e.g. ["{~g,~h}1"] would mean ["~g1 ~h1"], but this implementation rejects the pattern). *) and glob_set = < set : (int * int) list > (** A set of code points is given as a list of ranges [(from,to)], with [from <= to]. It is allowed that ranges overlap. *) type valid_glob_expr (** A validated [glob_expr] *) (** Access to the user database *) class type user_info = object method path_encoding : Netconversion.encoding option (** Paths of filesystems may be encoded *) method home_directory : string -> string (** Returns the home directory of the passed user, or the home directory of the current user for the empty string. Raises [Not_found] if the lookup fails. *) end (** Filesystem primitives. This is intentionally not the same as {!Netfs.stream_fs} because only a few access functions are needed here, and because the functions here should also be capable of accessing relative paths (not starting with /). It is possible to turn a {!Netfs.stream_fs} into {!Netglob.glob_fs} by calling {!Netglob.of_stream_fs}. *) class type glob_fsys = object method path_encoding : Netconversion.encoding option (** Paths of filesystems may be encoded *) method read_dir : string -> string list (** Returns the file names contained in the directory, without path. The names "." and ".." should be returned. It is acceptable to return the empty list for an unreadable directory. *) method file_is_dir : string -> bool (** Whether the file name is valid and a directory, or a symlink to a directory. *) method file_exists : string -> bool (** Whether the file name is valid and refers to an existing file, or to a symlink pointing to an existing file. *) end type glob_mode = [ `Existing_paths | `All_paths | `All_words ] (** Modes: - [`Existing_paths]: Only paths are returned that really exist - [`All_paths]: Generated paths not including [*], [?] and bracket expressions are returned even if they do not exist. For example, globbing for ["fictive{1,2,3}"] would return [["ficitve1";"fictive2";"fictive3"]] independent of whether these files exist. - [`All_words]: Patterns that cannot be resolved are returned as-is (like the shell does) *) type pattern = [ `String of string | `Expr of valid_glob_expr ] (** Input for {!Netglob.glob} *) exception Bad_glob_expr of string (** An syntax error in the glob expression; the argument is the bad expression *) exception Unsupported_expr of string (** The notations [:class:], [.symbol.], [=eqclass=] inside [...] are * not supported by this implementation. If they are found, this exception * will be raised, and the argument is the whole glob expression *) (** {2 Parsing and printing} *) val parse_glob_expr : ?encoding:Netconversion.encoding -> ?enable_star:bool -> (* Recognize "*" *) ?enable_qmark:bool -> (* Recognize "?" *) ?enable_brackets:bool -> (* Recognize "[set]" *) ?enable_braces:bool -> (* Recognize "{alt,...}" *) ?enable_tilde:bool -> (* recognize ~ *) ?enable_escape:bool -> (* Recognize backslash as escape char *) string -> valid_glob_expr (** Parses the glob expression. By default, all syntax features are enabled. * May raise [Bad_glob_expr] or [Unsupported_expr]. * * The glob expressions are POSIX-compliant with the extension of * brace expressions, and tildes, and the omission of internationalized * bracket expressions: * - [*]: Matches a sequence of zero or more arbitrary characters * - [?]: Matches one arbitrary character * - [[abc]]: Matches one of the mentioned characters * - [[a-z]]: Matches one of the characters of the range. This is here * only permitted when the range falls into the ASCII set. (Otherwise * the interpretation would be dependent on the encoding.) Note that * the ASCII restriction does not comply to POSIX. * - [[!expr]] or [[^expr]]: Negates the bracket expression * - [{expr,expr,...}]: Generates a string for each of the alternatives. * A brace expression is even recognized if there is no comma, or even * no contents (i.e. ["{expr}"] and ["{}"]). The elements of brace expressions * may be again glob expressions; nested brace expressions are allowed. * - [~username]: Generates the home directory of this user * - [~]: Generates the home directory of the current user * - If enabled, the backslash character is the escape character. Within * bracket expressions, the backslash character never escapes. * - Not supported: Collating symbols [[.a.]], equivalence classes * [[=a=]], and character classes [[:name:]]. If they are found, the * exception [Unsupported_expr] will be raised. * * Glob expressions have a character [encoding]. This defaults to * [`Enc_iso88591]. Encodings must be ASCII-compatible. *) val validate_glob_expr : Netconversion.encoding -> glob_expr -> valid_glob_expr (** Checks whether the passed expression is syntactically valid. If so, a validated expression is returned. Otherwise, this function fails. *) val recover_glob_expr : valid_glob_expr -> glob_expr (** Returns the explicit representation *) val encoding_of_glob_expr : valid_glob_expr -> Netconversion.encoding (** Returns the encoding *) val literal_glob_expr : Netconversion.encoding -> string -> valid_glob_expr (** Returns an expression that matches literally the passed string *) val print_glob_expr : ?escape_in_literals:bool -> valid_glob_expr -> string (** Prints the glob expression as string. Meta characters are * escaped by a backslash when possible. Meta characters are: * ["*"], ["?"], ["["], ["]"], ["{"], ["}"], [","], ["~"] and ["\\"] * * - [escape_in_literals]: Whether meta characters in [`Literal] * subexpressions are escaped. This is true by default. *) (** {2 Operations on [valid_glob_expr]} *) val expand_glob_expr : ?user_info:user_info -> ?expand_brace:bool -> ?expand_tilde:bool -> valid_glob_expr -> valid_glob_expr list (** Resolve generative sub expressions by expanding them. The returned * list of glob expr no longer contains the expanded constructions. * * - [expand_brace]: Expands [`Brace] subexpressions. * - [expand_tilde]: Expands [`Tilde] subexpressions. * - [user_info]: The subset of file system operations needed for tilde * expansion. Defaults to {!Netglob.local_user_info} (see below). * * Both [expand_*] options are enabled by default. *) val match_glob_expr : ?protect_period:bool -> (* Protect leading dots; default: true *) ?protect_slash:bool -> (* Protect slashes; default: true *) ?encoding:Netconversion.encoding -> valid_glob_expr -> string -> bool (** Matches the glob_expr against a string. * * The input must neither contain brace expressions nor tildes (i.e. call * [expand_glob_expr] first). The function fails if it encounters such an * expression. * * - [protect_period]: If true, a leading period cannot be not matched by * [*], [?], [[...]], but only by a literal [.]. A leading period is * a [.] at the beginning of the string to be matched against, or * if also [protect_slash] a [.] after a [/] * - [protect_slash]: If true, a slash cannot be matched by [*], [?], [[...]], * but only by a literal [/] * * Both options are enabled by default. * * - [encoding]: The encoding of the string argument. Defaults to the * encoding of the glob pattern. *) val split_glob_expr : valid_glob_expr -> valid_glob_expr list (** Splits the glob expression into filename components separated by * literal [/] characters. For example, for the glob expression * ["a*b/c/d?"], the list [["a*b"; "c"; "d?"]] is returned. * * If the first component begins with a slash, the slash is not removed * from the first returned list element, e.g. for ["/ab/c*"], the list * [[ "/ab"; "c*" ]] is computed. Use [check_rooted_glob_expr] to test this * case. * * Several adjacent slashes are handled like a single slash. E.g. * for ["a//b"], the list [["a"; "b"]] is returned. * * If the last component ends with a slash, it is not removed from the * returned list element, e.g. for ["a/b/"], the list [[ "a"; "b/" ]] is * returned. Use [check_directory_glob_expr] to test this case. * * The glob expression passed to this function must not contain brace * or tilde expressions. *) val check_rooted_glob_expr : valid_glob_expr -> valid_glob_expr option (** If the glob expression matches the root directory (i.e. the expression * begins with a literal [/]), the function returns [Some expr'], where * [expr'] matches the path relative to the root directory (i.e. the * expression without the [/] at the beginning). * * Otherwise, [None] is returned. * * Example: For ["/a/b*"], the expression ["a/b*"] is returned. * * Special case: for ["/"], the expression [""] (only matching the empty * string) is returned. * * The glob expression passed to this function must not contain brace * or tilde expressions. *) val check_directory_glob_expr : valid_glob_expr -> valid_glob_expr option (** If the last component of the glob expression matches only directories * because it ends with a literal [/] character, the value [Some expr'] is * returned where [expr'] matches the same path without the trailing [/]. * * Otherwise, [None] is returned. * * Example: For ["a/b*/"], the expression ["a/b*"] is returned. * * Special case: for ["/"], the expression [""] (only matching the empty * string) is returned. * * The glob expression passed to this function must not contain brace * or tilde expressions. *) (** {2 Globbing} *) val glob : ?encoding:Netconversion.encoding -> (* default: `Enc_iso88591 *) ?base_dir:string -> (* default: current directory *) ?protect_period:bool -> (* default: true *) ?fsys:glob_fsys -> (* default: access real file system *) ?user_info:user_info -> ?mode:glob_mode -> (* default: `Existing_paths *) pattern -> string list (** Forms a set of filenames as described below, and matches this set * against the pattern. The pattern can be given as a [`String s] * in which case [s] is parsed (with all features enabled, and * it is assumed it has the passed [encoding]). Alternatively, * an already parsed [`Expr e] can be given. (Note that [encoding] * is ignored in this case.) * * {b Slashes must be explicitly matched:} * "/" must literally occur in order to be a candidate for matching. * It is not matched by [*] or [?] or a bracket expression. * * {b Periods:} The leading period is protected if [protect_period]. * It must then also literally occur to be matched. * * {b Anchoring:} If the [glob_expr] begins with a literal "/", the set * of filenames is * anchored at the root directory; otherwise the set is anchored at * the current directory or, if [base_dir] is passed, at this directory. * (If [fsys] is passed, it is required to also set [base_dir].) * * Initially, the set contains all files of the anchor * directory (for the root directory, a "/" is prepended). * * After that, the set is extended by adding the paths of * subdirectories relative to the anchor directory. Note that the * constructed set is always infinite, because "." and ".." are not * handled specially, and are also regarded as "subdirectories". However, * after applying the matching criterion, the returned list is always * finite. * * Note that the anchor directory itself is not part of the generated * set. For example, for the expression "/*" the root directory "/" is * not returned. As an exception of this rule, for the glob expression * "/" the file "/" is returned. * * {b Braces:} Brace expressions are handled by expanding them first, even * before filename generation starts. * * {b Mode:} By default, only existing paths are returned * ([mode=`Existing_paths]). * If no files match, the empty list is returned (and not the pattern * as the shell does). By passing a different [mode], this can be changed: * - [`All_paths]: It is allowed that non-existing paths * are returned when the paths do not contain *, ?, or \[ * metacharacters after the brace expansion. Path expressions * with these metacharacters are still checked for existence. * - [`All_words]: When an expression does not refer to existing * paths, it is returned as such, leaving the metacharacters *, ?, \[ * unexpanded (i.e., what the Bourne shell does). Note that * either all metacharacters are resolved, or none, but not * a subset of them. * * {b Encodings:} Often, only the pattern has an encoding, but not * the filesystem (as in Unix). In this case, no conversion is attempted, * and the byte representation of the pattern is matched with the * byte representation of the filenames. Good luck. * * If the filesystem has an encoding, however, conversions may * be required, and this can cause problems. Usually, network filesystems * provide an encoding, and the Win32 local filesystem. (For Unix, * one can pass a custom [fsys] with encoding knowledge.) Conversion * problems can be avoided if (1) the encoding of the pattern is a superset * of the filename encoding. Also, (2) one should not use literals * in the pattern that cannot be represented in the filename encoding. * If (2) cannot be satisfied, ensure you have at least * [mode=`Existing_paths], i.e. the default mode (this removes results * from the returned list when a conversion problem occurs). * * The return value of [glob] is encoded in the encoding of the filesystem * if the filesystem provides an encoding. (If you want to check this * encoding, pass [fsys], e.g. as [local_fsys()], and call the * [path_encoding] method of [fsys].) *) (** {2 Remarks} *) (** {b Examples demonstrating the effect of encodings:} (Linux) {[ let fsys = local_fsys ~encoding:`Enc_utf8() let l = glob ~fsys (`String "\214*") ]} The byte 214 is O-umlaut in ISO-8859-1 (the default encoding for patterns). By passing an [fsys] argument we change the encoding for filenames to UTF-8. For example, if "\195\150ffentlich" was a file in the current directory, it would be found and returned in [l]. Conversions: For example, assume we have a file "\226\130\172uro" (EUR-uro in UTF-8). The glob {[ let fsys = local_fsys ~encoding:`Enc_utf8() let l = glob ~fsys (`String "*") ]} finds it although the euro sign cannot be represented in ISO-8859-1, the default pattern encoding. We run into a problem, however, if we want to generate the euro sign even if the file is not present, and the filesystem uses an encoding that does not include this sign: {[ let fsys = local_fsys ~encoding:`Enc_iso88591() let l = glob ~fsys ~encoding:`Enc_utf8 ~mode:`All_paths (`String "\226\130\172uro") ]} This raises an exception [Netconversion.Cannot_represent 8364]. *) (** {b Notes for Win32:} - Globbing only supports forward slashes, not backslashes as path separators - Globbing does neither recognize drive letters nor UNC paths as special cases. This may lead to subtle bugs. Glob expressions like "c:/file.*" may or may not work depending on the context. - The usually case-insensitive file system is not taken into account. (To be fixed.) *) (** {2 Default access objects} *) class local_user_info : unit -> user_info val local_user_info : unit -> user_info (** Get the home directory of a user from the local user database. *) class local_fsys : ?encoding:Netconversion.encoding -> unit -> glob_fsys val local_fsys : ?encoding:Netconversion.encoding -> unit -> glob_fsys (** Accesses the local filesystem *) class of_stream_fs : #Netfs.stream_fs -> glob_fsys val of_stream_fs : #Netfs.stream_fs -> glob_fsys (** Use an arbitrary network filesystem for globbing *) (** {2 Compatibility} This implementation is not fully compatible with the POSIX specs. The differences: - Missing support for character classes, equivalence classes and collating symbols. - Ranges in brackets are restricted to ASCII. - Unparseable patterns are indicated by exceptions. POSIX, however, requires that such patterns are taken literally. E.g. a pattern "\[" would match a left bracket in POSIX, but this module throws a syntax error. - If the slash character is protected, it is still allowed inside brackets. POSIX, however, requires that the pattern is scanned for slashes before brackets. For instance, the pattern "\[a/b*\]" is scanned as [ [`Literal "[a/b]"; `Star] ] following the POSIX rules while this implementation sees a bracket expression with "a", "b", "/" and "*" characters. - The "^" character negates the set if used at the beginning of bracket expressions. POSIX leaves this unspecified. - Brace expresions are an extension (although commonly implemented in shells). - The default globbing mode is [`Existing_paths] which is not defined by POSIX. Use [`All_paths] for getting POSIX behavior. Compared with popular shells, there are some subtle differences in how the various syntax elements (wildcards, braces, tildes) are parsed and processed. Shells do it in this order: - Parse and expand brace expressions - Parse and expand tildes - Split the paths at slashes into path components - Parse and expand wildcards For example, after expanding braces it is possible to see totally new tilde or wildcard expressions, e.g. ["~user{1,2}/file"] would be legal. This implementation here does not support this - we first parse the expression, and then interpret it. However, users interested in a higher degree of compatibility can call the {!Netglob} parsing, processing and printing functions in the required order, and emulate the shell behavior. For example, {[ let alt_glob pat = let g1 = parse_glob_expr ~enable_star:false ~enable_qmark:false ~enable_brackets:false ~enable_tilde:false (* only braces remain enabled *) pat in let g2_list = expand_glob_expr g1 in let pat2_list = List.map (print_glob_expr ~escape_in_literals:false) g2_list in let g3_list = List.map (fun pat2 -> parse_glob_expr ~enable_braces:false pat2) pat2_list in List.flatten (List.map (fun g3 -> glob (`Expr g3)) g3_list) ]} would parse and expand brace expressions in a separate step before running [glob] on the remaining syntactic elements. *) ocamlnet-4.0.4/src/netstring/netoid.mli0000644000175000017500000000136512541553661016553 0ustar gerdgerd(* $Id: netoid.mli 2195 2015-01-01 12:23:39Z gerd $ *) (** X.500 Object Identifiers *) type t = int array val equal : t -> t -> bool (** Whether two OIDs are equal *) val compare : t -> t -> int (** Lexicographic ordering of OIDs *) val of_string : string -> t (** Parses an OID in dot notation, e.g. [of_string "2.3.4" = [| 2; 3; 4 |]] *) val to_string : t -> string (** Returns the OID in dot notation, e.g. [to_string [| 2; 3; 4 |] = "2.3.4"] *) val of_string_curly : string -> t (** Parses an OID in curly brace notation, e.g. [of_string "{2 3 4}" = [| 2; 3; 4 |]] *) val to_string_curly : t -> string (** Returns the OID in curly brace notation, e.g. [to_string [| 2; 3; 4 |] = "{2 3 4}"] *) ocamlnet-4.0.4/src/netstring/netstream.ml0000644000175000017500000002544212541553661017124 0ustar gerdgerd(* $Id: netstream.ml 1412 2010-02-15 16:20:27Z gerd $ * ---------------------------------------------------------------------- * *) open Netchannels;; class type in_obj_stream = object inherit Netchannels.in_obj_channel method block_size : int method window : Netbuffer.t method want : int -> unit method want_another_block : unit -> unit method window_length : int method window_at_eof : bool method skip : int -> unit end class virtual input_methods init_s_netbuf = object(self) val mutable s_pos = 0 val mutable s_at_eof = false val s_netbuf = init_s_netbuf val mutable s_closed = false method virtual want : int -> unit method virtual want_another_block : unit -> unit method virtual window_length : int method virtual input : string -> int -> int -> int (* The following input methods base all on [input] *) method really_input buf pos len = if s_closed then raise Netchannels.Closed_channel; let rec read p = let l = self # input buf (pos+p) (len-p) in let p' = p + l in if p' = len then () else ( if l=0 then raise Sys_blocked_io; read p' ) in self # want len; (* may raise Buffer_underrun *) read 0 method input_char () = let s = String.create 1 in self # really_input s 0 1; s.[0] method input_byte () = let s = String.create 1 in self # really_input s 0 1; int_of_char s.[0] method input_line () = (* CHECK: Are the different end of line conventions important here? *) let rec find_eol() = try Netbuffer.index_from s_netbuf 0 '\n' (* or Not_found *) with Not_found -> if not s_at_eof then begin self # want_another_block(); (* may raise Buffer_underrun *) find_eol() end else self#window_length in if s_closed then raise Netchannels.Closed_channel; let n = find_eol() in if n >= self#window_length then begin if n = 0 then raise End_of_file; let s = String.create n in self#really_input s 0 n; s end else begin let s = String.create n in self#really_input s 0 n; ignore(self#input_char()); (* '\n' *) s end method pos_in = if s_closed then raise Netchannels.Closed_channel; s_pos end class input_stream ?len ?(block_size = 4096) in_ch : in_obj_stream = object (self) val s_channel = (in_ch : in_obj_channel) val s_maxlength = len val s_blocksize = block_size val mutable s_underrun = false inherit input_methods (Netbuffer.create block_size) (* Note: This implementation must even work if [in_ch] is a pipe, * and raises Buffer_underrun from time to time. This may happen * at inconvenient situations. In this case the flag s_underrun stores * whether an underrun happened, and should be reported later. *) initializer try self # want_minimum() (* may raise Buffer_underrun *) with Buffer_underrun -> s_underrun <- true method private debug msg = prerr_endline (msg ^ ": s_pos=" ^ string_of_int s_pos ^ " s_at_eof=" ^ string_of_bool s_at_eof ^ " buflen=" ^ string_of_int (Netbuffer.length s_netbuf) ^ " s_closed=" ^ string_of_bool s_closed); method block_size = s_blocksize (* The block size is a static property, so never raise Closed_channel *) method window = if s_closed then raise Netchannels.Closed_channel; s_netbuf method window_length = if s_closed then raise Netchannels.Closed_channel; Netbuffer.length s_netbuf method window_at_eof = if s_closed then raise Netchannels.Closed_channel; s_at_eof method want_another_block() = if s_closed then raise Netchannels.Closed_channel; if not s_at_eof then begin (* How much are we allowed to read? *) let m = match s_maxlength with None -> s_blocksize | Some l -> min (l - s_pos - Netbuffer.length s_netbuf) s_blocksize in assert(m >= 0); (* Try to read m bytes: *) let rec read_block k = if k < m then let n = Netbuffer.add_inplace ~len:(m-k) s_netbuf (s_channel # input) (* may raise End_of_file, Buffer_underrun *) in ( if n > 0 then read_block (k+n) else raise Sys_blocked_io ) else () in try if m=0 then (* Artificial EOF because len is reached *) s_at_eof <- true else read_block 0 with End_of_file -> s_at_eof <- true end; (* self # debug "after stream#want_another_block"; *) (* Unix.sleep 1; *) method want n = if s_closed then raise Netchannels.Closed_channel; while not s_at_eof && Netbuffer.length s_netbuf < n do self # want_another_block() done method private want_minimum() = self # want s_blocksize method skip len = if s_closed then raise Netchannels.Closed_channel; let rec read len = if len > 0 then begin let k = min (Netbuffer.length s_netbuf) len in Netbuffer.delete s_netbuf 0 k; s_pos <- s_pos + k; self # want_minimum(); (* may raise Buffer_underrun *) if k > 0 then read (len - k) end in read len method input buf pos len = if s_closed then raise Netchannels.Closed_channel; if s_underrun then ( self # want_minimum(); (* may raise Buffer_underrun *) s_underrun <- false; ); (* Assertion: Either window length >= minimum, or eof *) let len' = min len (Netbuffer.length s_netbuf) in Netbuffer.blit s_netbuf 0 buf pos len'; Netbuffer.delete s_netbuf 0 len'; s_pos <- s_pos + len'; ( try self # want_minimum(); (* may raise Buffer_underrun *) with Buffer_underrun -> s_underrun <- true ); if len'=0 && len>0 then raise End_of_file; len' method close_in () = if not s_closed then ( s_channel # close_in(); s_closed <- true; ) end (* let find_prefix s1 pos len s2 = (* Checks where a non-empty prefix of [s2] occurs at the end of the substring * of [s1] beginning at [pos] with length [len]. The function returns * the position [p] of the prefix in [s1]. * The function raises Not_found if it does not find a prefix. * POSTCONDITION: * - s1[p..p+n-1] = s2[0..n-1] for some biggest n, n <= String.length s2 * "The string s1 contains the prefix of s2 at position p, and the * prefix has the maximum length n." * - n < String.length s2 ==> p+n = String.length s1 * "If the prefix is a proper prefix, it occurs at the end of s1" *) assert(String.length s2 > 0); let l1 = min (String.length s1) (pos+len) in let l2 = String.length s2 in let s2c0 = s2.[0] in let rec check_rec p k = k >= l2 || p+k >= l1 || (s1.[p+k] = s2.[k] && check_rec p (k+1)) in let rec search_rec p = if p >= l1 then raise Not_found; let p' = String.index_from s1 p s2c0 in (* or Not_found *) if p' >= l1 then raise Not_found; if check_rec p' 0 then p' else search_rec (p'+1) in search_rec pos ;; *) class sub_stream ?len ?delimiter in_stream : in_obj_stream = object(self) val s = (in_stream : in_obj_stream) val mutable s_winlen = 0 val mutable s_del = None (* initialized below *) val s_len = len val mutable s_underrun = false inherit input_methods (in_stream # window) initializer (match delimiter with Some "" -> invalid_arg "new Netstream.sub_stream"; | Some d -> s_del <- Some(d, Netaux.KMP.make_pattern d) | None -> s_del <- None ); (match s_len with Some l -> if l<0 then invalid_arg "new Netstream.sub_stream"; | None -> () ); try self # want_minimum() with Buffer_underrun -> s_underrun <- true method block_size = s # block_size method window = if s_closed then raise Netchannels.Closed_channel; s_netbuf method window_length = if s_closed then raise Netchannels.Closed_channel; s_winlen method window_at_eof = if s_closed then raise Netchannels.Closed_channel; s_at_eof method private compute_winlen() = (* sets [s_winlen], [s_at_eof], and returns whether the current window * is "ambigous" (it is not clear if the stream does end or does not * end) *) let ambigous = ref false in let w = s#window in let wlen = s#window_length in let weof = s#window_at_eof in begin match s_del with None -> s_winlen <- wlen; s_at_eof <- weof; | Some(d,pat) -> let p = Netaux.KMP.find_pattern pat ~len:wlen (Netbuffer.unsafe_buffer w) in if p >= wlen then begin (* Delimiter d does not occur in the buffer *) s_winlen <- wlen; s_at_eof <- weof; end else if (p + String.length d) > wlen then begin (* Case: prefix is a proper prefix *) ambigous := not weof; s_winlen <- wlen; s_at_eof <- weof; end else begin (* Case: [d] occurs in the window *) s_winlen <- p; s_at_eof <- true; end end; begin match s_len with None -> () | Some l -> if l - s_pos < s_winlen then begin ambigous := false; s_winlen <- l - s_pos; s_at_eof <- true; end end; !ambigous method want_another_block() = if s_closed then raise Netchannels.Closed_channel; s # want_another_block(); (* may raise Buffer_underrun *) while self # compute_winlen() do s # want_another_block(); (* may raise Buffer_underrun *) done method want n = if s_closed then raise Netchannels.Closed_channel; while not s_at_eof && s_winlen < n do self # want_another_block() (* may raise Buffer_underrun *) done method private want_minimum() = if self # compute_winlen() then self # want_another_block(); (* may raise Buffer_underrun *) self # want s#block_size method skip len = if s_closed then raise Netchannels.Closed_channel; let rec read len = if len > 0 then begin let k = min s_winlen len in s # skip k; (* may raise Buffer_underrun *) s_pos <- s_pos + k; self # want_minimum(); (* may raise Buffer_underrun *) if k > 0 then read (len - k) end in read len method input buf pos len = if s_closed then raise Netchannels.Closed_channel; if s_underrun then ( self # want_minimum(); (* may raise Buffer_underrun *) s_underrun <- false; ); (* Assertion: Either window length >= minimum, or eof *) let len' = min len s_winlen in Netbuffer.blit s_netbuf 0 buf pos len'; s # skip len'; (* never raises Buffer_underrun *) s_pos <- s_pos + len'; ( try self # want_minimum(); with Buffer_underrun -> s_underrun <- true ); if len'=0 && len>0 then raise End_of_file; len' method close_in () = if not s_closed then ( s # close_in(); s_closed <- true; ) end let print_in_obj_stream fmt s = Format.fprintf fmt "" s#pos_in s#window_length s#window_at_eof ;; ocamlnet-4.0.4/src/netstring/Makefile.pre0000644000175000017500000000323012541553661017004 0ustar gerdgerdTOP_DIR=../.. PRE = 1 PKGNAME = netstring GENERATE = netconst.ml netglob_lex.ml \ netunichar.ml netmappings_asn1.ml META CLEAN_LIST += $(GENERATE) NETNUMBER_DEFS = -D WORDSIZE_$(WORD_SIZE) -D HOST_IS_$(ENDIANESS) \ -D USE_NETSYS_XDR PP_OPTIONS = -pp "$(CPPO) $(NETNUMBER_DEFS) $(REGEXP_DEFS)" INSTALL_EXTRA = netstring_top.cmo netaccel_link.cmo netaccel.cma netconst.ml: netconst.mlp sed -e 's/@VERSION@/$(VERSION)/' netconst.mlp >netconst.ml unicode_charinfo.txt: ocaml ../../tools/unicode_extract.ml > unicode_charinfo.txt netunichar.ml: unicode_charinfo.txt ocaml ../../tools/unicode_charinfo.ml unicode_charinfo.txt \ > netunichar.ml ASN1_MAPPINGS = ../netunidata/mappings/asn1_*.unimap unimap_to_ocaml = $(TOP_DIR)/tools/unimap_to_ocaml/unimap_to_ocaml # The .pmap files are the distributed files. The .unimap files cannot be # distributed because of license conditions. netmappings_asn1.pmap: $(unimap_to_ocaml) \ -o netmappings_asn1.pmap -pmap $(ASN1_MAPPINGS) netmappings_asn1.ml: netmappings_asn1.pmap $(unimap_to_ocaml) \ -o netmappings_asn1.ml netmappings_asn1.pmap # How I created netsaslprep_data.ml: #netsaslprep_data.ml: tmp/CompositionExclusions-3.2.0.txt \ # tmp/UnicodeData-3.2.0.txt # ocaml str.cma ../../tools/saslprep-extract-from-unicode.ml \ # > netsaslprep_data.ml # #tmp/CompositionExclusions-3.2.0.txt: # mkdir -p tmp # cd tmp && \ # wget 'http://www.unicode.org/Public/3.2-Update/CompositionExclusions-3.2.0.txt' # #tmp/UnicodeData-3.2.0.txt: # mkdir -p tmp # cd tmp && \ # wget 'http://www.unicode.org/Public/3.2-Update/UnicodeData-3.2.0.txt' include $(TOP_DIR)/Makefile.rules ocamlnet-4.0.4/src/netstring/netaddress.ml0000644000175000017500000001371012541553661017251 0ustar gerdgerd(* Addresses indicate the senders and recipients of messages and * correspond to either an individual mailbox or a group of * mailboxes. *) type local_part = string type domain = string type addr_spec = local_part * domain option class mailbox ?(name : string option) (route : string list) (spec : addr_spec) = object method name = match name with Some s -> s | _ -> raise Not_found method route = route method spec = spec end class group (name : string) (mailboxes : mailbox list) = object method name = name method mailboxes = mailboxes end type t = [ `Mailbox of mailbox | `Group of group ] let mbox_addr_spec spec = `Mailbox (new mailbox [] spec) let mbox_route_addr personal (route, spec) = `Mailbox (new mailbox ?name:personal route spec) open Netmime_string let rev = List.rev exception Parse_error of int * string let parse string = let scanner = create_mime_scanner ~specials:specials_rfc822 ~scan_options:[] string in (* manage lookahead token *) let lookahead_et, lookahead = let et, t = Netmime_string.scan_token scanner in ref et, ref t in let next () = let et, t = Netmime_string.scan_token scanner in lookahead_et := et; lookahead := t in let peek () = !lookahead in (* parsing error - some kind of location/error recovery? *) let error s = let pos = Netmime_string.get_pos !lookahead_et in raise (Parse_error (pos, s)) in (* parse a list of elements *) let list elem next acc = next (elem () :: acc) in (* match a special token for a character *) let special c = match peek () with | Special c' when c = c' -> next () | _ -> error (Printf.sprintf "expecting '%c'" c) in (* main entry point *) let rec address_list acc = match peek () with | End -> rev acc | _ -> list address next_address acc and next_address acc = match peek () with | End -> rev acc | Special ',' -> next (); address_list acc | _ -> error "expecting ','" (* RFC-1123 section 5.2.15: syntax definition of "mailbox" is changed to allow route address with no phrase *) and address () = match peek () with | (Atom _ | QString _) -> address1 () | Special '<' -> mbox_route_addr None (route_addr ()) | Special ',' -> next (); address () (* RFC 2822 section 4.4: support for "null" members *) | _ -> error "expecting address" and address1 () = let w0 = word () in match peek () with | Special '@' -> mbox_addr_spec (w0, Some (at_domain ())) | Special ('<'|':') -> address2 (w0) | Special '.' -> next (); mbox_addr_spec (addr_spec [w0]) | (Atom _ | QString _) -> address2 (phrase [w0]) | _ -> error "syntax error" and address2 name = match peek () with | Special '<' -> mbox_route_addr (Some name) (route_addr ()) | Special ':' -> next (); group name | _ -> error "expecting '<' or ':'" and group name = let mboxes = mailbox_list_opt () in special ';'; `Group (new group name mboxes) and mailbox_list_opt () = match peek () with | Special ';' -> [] | _ -> list mailbox next_mailbox [] and next_mailbox acc = match peek () with | Special ',' -> next (); list mailbox next_mailbox acc | _ -> rev acc (* reuse parsing code for address () and filter out group response *) and mailbox () = match address () with | `Mailbox m -> m | _ -> error "expecting mailbox" and route_addr () = special '<'; let x = match peek () with | (Atom _ | QString _) -> let spec = addr_spec [] in ([], spec) | Special '@' -> let r = route () in let spec = addr_spec [] in (r, spec) | _ -> error "expecting local part or route address" in special '>'; x and route () = let r = at_domain_list [] in special ':'; r and addr_spec acc = let lp = local_part acc in match peek () with | Special '@' -> (lp, Some (at_domain ())) | _ -> (lp, None) and local_part acc = list word next_local_part acc and next_local_part acc = match peek () with | Special '.' -> next (); local_part acc | _ -> String.concat "." (rev acc) and at_domain_list acc = list at_domain next_at_domain_list acc and next_at_domain_list acc = match peek () with | Special ',' -> next (); at_domain_list acc | _ -> rev acc and at_domain () = special '@'; domain [] and domain acc = list subdomain next_subdomain acc and next_subdomain acc = match peek () with | Special '.' -> next (); domain acc | _ -> String.concat "." (rev acc) and subdomain () = match peek () with | Atom s -> next (); s | DomainLiteral s -> next (); s | _ -> error "expecting atom or domain" and phrase acc = list word_or_dot next_phrase acc and next_phrase acc = match peek() with | (Atom _ | QString _ | Special '.') -> phrase acc | _ -> String.concat " " (rev acc) (* RFC 2822 section 4.1: support for '.' often used for initials in names *) and word_or_dot () = match peek () with | Atom s -> next (); s | QString s -> next (); s | Special '.' -> next (); "." | _ -> error "expecting atom or quoted-string" and word () = match peek () with | Atom s -> next (); s | QString s -> next (); s | _ -> error "expecting atom or quoted-string" in address_list [] ocamlnet-4.0.4/src/netstring/netulex.mli0000644000175000017500000002415512541553661016757 0ustar gerdgerd(* $Id: netulex.mli 1003 2006-09-24 15:17:15Z gerd $ * ---------------------------------------------------------------------- * PXP: The polymorphic XML parser for Objective Caml. * Copyright by Gerd Stolpmann. See LICENSE for details. *) (** Support module for Alain Frisch's [ulex] lexer generator * * The sub module [ULB] is a Unicode-based lexing buffer that * reads encoded strings and makes them available to the lexer * as both Unicode arrays and UTF-8 strings. * * The sub module [Ulexing] is a replacement for the module * in [ulex] with the same name. It uses [ULB] to represent * the main lexing buffer. It is much faster than the original * [Ulexing] implementation when the scanned text is UTF-8 * encoded and [Ulexing.utf8_lexeme] is frequently called to * get the lexeme strings. Furthermore, it can process input * data of all encodings available to [Netconversion]. It is, * however, no drop-in replacement as it has a different * signature. * * To enable this version of [Ulexing], simply put an * [open Netulex] before using the [ulex] lexers. * * Note that the tutorial has been moved to {!Netulex_tut}. *) (** {1:modules Modules} *) module ULB : sig (** This module provides the [unicode_lexbuf] record with * access functions. In this record, the data is available * in two forms: As an array of Unicode code points * [ulb_chars], and as string of encoded chars [ulb_rawbuf]. * Both buffers are synchronised by [ulb_chars_pos]. This * array stores where every character of [ulb_chars] can be * found in [ulb_rawbuf]. *) type unicode_lexbuf = private { mutable ulb_encoding : Netconversion.encoding; (** The character encoding of [ulb_rawbuf] *) mutable ulb_encoding_start : int; (** The first character position to which [ulb_encoding] * applies (the encoding of earlier positions is * lost) *) mutable ulb_rawbuf : string; (** The encoded string to analyse *) mutable ulb_rawbuf_len : int; (** The filled part of [ulb_rawbuf] *) mutable ulb_rawbuf_end : int; (** The analysed part of [ulb_rawbuf]. We have always * [ulb_rawbuf_end <= ulb_rawbuf_len]. The analysed part * may be shorter than the filled part because there is * not enough space in [ulb_chars], or because the filled * part ends with an incomplete multi-byte character *) mutable ulb_rawbuf_const : bool; (** Whether [ulb_rawbuf] is considered as a constant. If * [true], it is never blitted. *) mutable ulb_chars : int array; (** The analysed part of [ulb_rawbuf] as array of Unicode * code points. Only the positions 0 to [ulb_chars_len-1] * of the array are filled. *) mutable ulb_chars_pos : int array; (** For every analysed character this array stores the * byte position where the character begins in [ulb_rawbuf]. * In addition, the array contains at [ulb_chars_len] the * value of [ulb_rawbuf_end]. * * This array is one element longer than [ulb_chars]. *) mutable ulb_chars_len : int; (** The filled part of [ulb_chars] *) mutable ulb_eof : bool; (** Whether EOF has been seen *) mutable ulb_refill : string -> int -> int -> int; (** The refill function *) mutable ulb_enc_change_hook : unicode_lexbuf -> unit; (** This function is called when the encoding changes *) mutable ulb_cursor : Netconversion.cursor; (** Internally used by the implementation *) } val from_function : ?raw_size:int -> ?char_size:int -> ?enc_change_hook:(unicode_lexbuf -> unit) -> refill:(string -> int -> int -> int) -> Netconversion.encoding -> unicode_lexbuf (** Creates a [unicode_lexbuf] to analyse strings of the * passed [encoding] coming from the [refill] function. * * @param raw_size The initial size for [ulb_rawbuf]. Defaults to 512 * @param char_size The initial size for [ulb_chars]. Defaults to 256 * @param enc_change_hook This function is called when the encoding * is changed, either by this module, or by the user calling * [set_encoding]. * @param refill This function is called with arguments [ulb_rawbuf], * [ulb_rawbuf_len], and [l], where * [l = String.length ulb_rawbuf - ulb_rawbuf_len] is the free * space in the buffer. The function should fill new bytes into * this substring, and return the number of added bytes. The * return value 0 signals EOF. *) val from_in_obj_channel : ?raw_size:int -> ?char_size:int -> ?enc_change_hook:(unicode_lexbuf -> unit) -> Netconversion.encoding -> Netchannels.in_obj_channel -> unicode_lexbuf (** Creates a [unicode_lexbuf] to analyse strings of the * passed [encoding] coming from the object channel. * * @param raw_size The initial size for [ulb_rawbuf]. Defaults to 512 * @param char_size The initial size for [ulb_chars]. Defaults to 256 * @param enc_change_hook This function is called when the encoding * is changed, either by this module, or by the user calling * [set_encoding]. *) val from_string : ?enc_change_hook:(unicode_lexbuf -> unit) -> Netconversion.encoding -> string -> unicode_lexbuf (** Creates a [unicode_lexbuf] analysing the passed string encoded in * the passed encoding. This function copies the input string. * * @param enc_change_hook This function is called when the encoding * is changed, either by this module, or by the user calling * [set_encoding] *) val from_string_inplace : ?enc_change_hook:(unicode_lexbuf -> unit) -> Netconversion.encoding -> string -> unicode_lexbuf (** Creates a [unicode_lexbuf] analysing the passed string encoded in * the passed encoding. This function does not copy the input string, * but uses it directly as [ulb_rawbuf]. The string is not modified by [ULB], * but the caller must ensure that other program parts do not * modify it either. * * @param enc_change_hook This function is called when the encoding * is changed, either by this module, or by the user calling * [set_encoding] *) val delete : int -> unicode_lexbuf -> unit (** Deletes the number of characters from [unicode_lexbuf]. * These characters * are removed from the beginning of the buffer, i.e. * [ulb_chars.(n)] becomes the new first character of the * buffer. All three buffers [ulb_rawbuf], [ulb_chars], and * [ulb_chars_pos] are blitted as necessary. * * When the buffer is already at EOF, the function fails. * * For efficiency, it should be tried to call [delete] as seldom as * possible. Its speed is linear to the number of characters to move. *) val refill : unicode_lexbuf -> unit (** Tries to add characters to the [unicode_lexbuf] by calling the * [ulb_refill] function. When the buffer is already at EOF, the * exception [End_of_file] is raised, and the buffer is not modified. * Otherwise, the [ulb_refill] function is called to * add new characters. If necessary, [ulb_rawbuf], [ulb_chars], and * [ulb_chars_pos] are enlarged such that it is ensured that either * at least one new character is added, or that EOF is found for * the first time * In the latter case, [ulb_eof] is set to [true] (and the next call * of [refill_unicode_lexbuf] will raise [End_of_file]). *) val set_encoding : Netconversion.encoding -> unicode_lexbuf -> unit (** Sets the [encoding] to the passed value. This only affects future * [refill] calls. The hook [enc_change_hook] is invoked when defined. *) val close : unicode_lexbuf -> unit (** Sets [ulb_eof] of the [unicode_lexbuf]. The rest of the buffer * is not modified *) val utf8_sub_string : int -> int -> unicode_lexbuf -> string (** The two [int] arguments are the position and length of a sub * string of the lexbuf that is returned as UTF8 string. Position * and length are given as character multiples, not byte multiples. *) val utf8_sub_string_length : int -> int -> unicode_lexbuf -> int (** Returns [String.length(utf8_sub_string args)]. Tries not to * allocate the UTF-8 string. *) end (* module ULB *) module Ulexing : sig (** This is a lexing buffer for [ulex]. *) type lexbuf exception Error (** Lexical error *) val from_ulb_lexbuf : ULB.unicode_lexbuf -> lexbuf (** Creates a new [lexbuf] from the [unicode_lexbuf]. After that, * the [unicode_lexbuf] must no longer be modified. *) val lexeme_start: lexbuf -> int (** The character position of the start of the lexeme *) val lexeme_end: lexbuf -> int (** The character position of the end of the lexeme *) val lexeme_length: lexbuf -> int (** The length of the lexeme in characters *) val lexeme: lexbuf -> int array (** Returns the lexeme as array of Unicode code points *) val lexeme_char: lexbuf -> int -> int (** Returns the code point of a certain character of the * lexeme *) val sub_lexeme: lexbuf -> int -> int -> int array (** Returns a substring of the lexeme as array of Unicode * code points. The first [int] is the characater position * where to start, the second [int] is the number of * characters. *) val utf8_lexeme: lexbuf -> string (** Returns the lexeme as UTF-8 encoded string *) val utf8_sub_lexeme: lexbuf -> int -> int -> string (** Returns a substring of the lexeme as UTF-8 encoded * string. The first [int] is the characater position * where to start, the second [int] is the number of * characters. *) val utf8_sub_lexeme_length: lexbuf -> int -> int -> int (** Same as * String.length(utf8_sub_lexeme args), i.e. returns * the number of bytes a certain sub lexeme will have * when encoded as UTF-8 string. *) (**/**) (* "Internal" interface. This must match ulex's ones. *) val start: lexbuf -> unit val next: lexbuf -> int val mark: lexbuf -> int -> unit val backtrack: lexbuf -> int end ocamlnet-4.0.4/src/netstring/netmappings.mli0000644000175000017500000000402512541553661017612 0ustar gerdgerd(* $Id: netmappings.mli 1219 2009-04-14 13:28:56Z ChriS $ * ---------------------------------------------------------------------- *) (** Internal access to the character conversion database * * This is an internal module. *) type from_uni_list = U_nil | U_single of (int*int) | U_double of (int*int * int*int) | U_array of int array ;; (* A representation of (int*int) list that is optimized for the case that * lists with 0 and 1 and 2 elements are the most frequent cases. *) val get_to_unicode : string -> int array val get_from_unicode : string -> from_uni_list array (* These functions get the conversion tables from local encodings to * Unicode and vice versa. * It is normally not necessary to access these tables; the * Netconversion module does it already for you. * * The argument is the internal name of the encoding. (E.g. if * encoding = `Enc_iso88591, the internal name is "iso88591", i.e. * the "`Enc_" prefix is removed. However, for "composite encodings" * like `Enc_eucjp things are more complicated.) * * Specification of the conversion tables: * * to_unicode: maps a local code to Unicode, i.e. * let m = Hashtbl.find `Enc_isoXXX to_unicode in * let unicode = m.(isocode) * - This may be (-1) to indicate that the code point is not defined. * * from_unicode: maps Unicode to a local code, i.e. * let m = Hashtbl.find `Enc_isoXXX from_unicode in * let l = m.(unicode land mask) * Now search in l the pair (unicode, isocode), and return isocode. * Where mask = Array.length from_unicode - 1 *) val lock : unit -> unit (* In multi-threaded applications: obtains a lock which is required to * Lazy.force the values found in to_unicode and from_unicode. * In single-threaded applications: a NO-OP *) val unlock : unit -> unit (* In multi-threaded applications: releases the lock which is required to * Lazy.force the values found in to_unicode and from_unicode. * In single-threaded applications: a NO-OP *) ocamlnet-4.0.4/src/netstring/netmime.ml0000644000175000017500000003253212541553661016556 0ustar gerdgerd(* $Id: netmime.ml 2195 2015-01-01 12:23:39Z gerd $ * ---------------------------------------------------------------------- * *) open Netchannels type store = [ `Memory | `File of string ] exception Immutable of string class type mime_header_ro = object method fields : (string * string) list method field : string -> string method multiple_field : string -> string list end class type mime_header = object inherit mime_header_ro method ro : bool method set_fields : (string * string) list -> unit method update_field : string -> string -> unit method update_multiple_field : string -> string list -> unit method delete_field : string -> unit end class type mime_body_ro = object method value : string method store : store method open_value_rd : unit -> in_obj_channel method finalize : unit -> unit end class type mime_body = object inherit mime_body_ro method ro : bool method set_value : string -> unit method open_value_wr : unit -> out_obj_channel end type complex_mime_message = mime_header * complex_mime_body and complex_mime_body = [ `Body of mime_body | `Parts of complex_mime_message list ] type complex_mime_message_ro = mime_header_ro * complex_mime_body_ro and complex_mime_body_ro = [ `Body of mime_body_ro | `Parts of complex_mime_message_ro list ] (* Check that coercion is possible: *) let _ = fun x -> (x : complex_mime_message :> complex_mime_message_ro) type mime_message = mime_header * [ `Body of mime_body ] type mime_message_ro = mime_header_ro * [ `Body of mime_body_ro ] module CI : sig (* case-insensitive strings *) type t val compare : t -> t -> int val make : string -> t end = struct type t = string let compare (a_ci:t) (b_ci:t) = Pervasives.compare a_ci b_ci let make s = String.lowercase s end module CIMap = Map.Make(CI) (* Maps from case-insensitive strings to any type *) module DL : sig (* doubly-linked lists *) type 'a t type 'a cell val create : unit -> 'a t val is_empty : 'a t -> bool val cell : 'a -> 'a cell val contents : 'a cell -> 'a val first : 'a t -> 'a cell (* or Not_found *) val last : 'a t -> 'a cell (* or Not_found *) val prev : 'a cell -> 'a cell (* or Not_found *) val next : 'a cell -> 'a cell (* or Not_found *) val iter : ('a cell -> unit) -> 'a t -> unit val delete : 'a cell -> unit val insert_after : neo:'a cell -> 'a cell -> unit val add_at_end : neo:'a cell -> 'a t -> unit val replace : neo:'a cell -> 'a cell -> unit val of_list : 'a list -> 'a t val to_list : 'a t -> 'a list end = struct type 'a t = { mutable first : 'a cell option; mutable last : 'a cell option; } and 'a cell = { mutable prev : 'a cell option; mutable next : 'a cell option; mutable list : 'a t option; contents : 'a; } let create() = { first = None; last = None } let is_empty l = l.first = None let cell x = { prev = None; next = None; list = None; contents = x } let contents c = c.contents let first l = match l.first with Some c -> c | None -> raise Not_found let last l = match l.last with Some c -> c | None -> raise Not_found let prev c = match c.prev with Some c' -> c' | None -> raise Not_found let next c = match c.next with Some c' -> c' | None -> raise Not_found let iter f l = match l.first with Some c -> f c; let current = ref c in while (let c0 = ! current in c0.next) <> None do (* Error in camlp4 *) current := next !current; f !current done; () | None -> () let delete c = match c.list with Some l -> ( match c.prev with Some p -> p.next <- c.next | None -> l.first <- c.next ); ( match c.next with Some n -> n.prev <- c.prev | None -> l.last <- c.prev ); c.prev <- None; c.next <- None; c.list <- None | None -> failwith "DL.delete: cannot delete free cell" let insert_after ~neo c = if neo.list <> None then failwith "DL.insert_after: new cell must be free"; match c.list with Some l -> let nx = c.next in c.next <- Some neo; neo.prev <- Some c; ( match nx with Some n -> n.prev <- Some neo; neo.next <- Some n; | None -> l.last <- Some neo; neo.next <- None ); neo.list <- Some l | None -> failwith "DL.insert_after: cannot insert after free cell" let add_at_end ~neo l = if neo.list <> None then failwith "DL.insert_after: new cell must be free"; match l.last with Some n -> n.next <- Some neo; neo.prev <- Some n; neo.next <- None; neo.list <- Some l; l.last <- Some neo | None -> l.last <- Some neo; l.first <- Some neo; neo.prev <- None; neo.next <- None; neo.list <- Some l let replace ~neo c = if neo.list <> None then failwith "DL.replace: new cell must be free"; match c.list with Some l -> ( match c.prev with Some p -> p.next <- Some neo | None -> l.first <- Some neo ); neo.prev <- c.prev; ( match c.next with Some n -> n.prev <- Some neo | None -> l.last <- Some neo ); neo.next <- c.next; neo.list <- Some l; c.prev <- None; c.next <- None; c.list <- None | None -> failwith "DL.replace: cannot replace free cell" let of_list l = let dl = create() in List.iter (fun x -> add_at_end ~neo:(cell x) dl ) l; dl let rec to_list dl = chain_to_list dl.first and chain_to_list chain = match chain with None -> [] | Some c -> c.contents :: chain_to_list c.next end class basic_mime_header h : mime_header = object (self) val mutable hdr_map = lazy (assert false) val mutable hdr_dl = lazy (assert false) initializer self # do_set_fields h method ro = false (* Heirs can redefine [ro] to make this object immutable *) method fields = DL.to_list (Lazy.force hdr_dl) method field n = let m = Lazy.force hdr_map in match CIMap.find (CI.make n) m with [] -> raise Not_found | cell :: _ -> snd (DL.contents cell) method multiple_field n = let m = Lazy.force hdr_map in try List.map (fun cell -> snd (DL.contents cell)) (CIMap.find (CI.make n) m) with Not_found -> [] method set_fields h = if self#ro then raise (Immutable "set_fields"); self # do_set_fields h method private do_set_fields h = hdr_dl <- lazy (DL.of_list h); hdr_map <- lazy begin (* This seems to be expensive (O(n log n)). Because of this we do it only * on demand; maybe nobody accesses the header at all *) let m = ref CIMap.empty in DL.iter (fun cell -> let (n,v) = DL.contents cell in let n_ci = CI.make n in let current = try CIMap.find n_ci !m with Not_found -> [] in m := CIMap.add n_ci (cell :: current) !m; ) (Lazy.force hdr_dl); CIMap.map List.rev !m end method update_field n v = if self#ro then raise (Immutable "update_field"); self # update_multiple_field n [v] method update_multiple_field n vl = if self#ro then raise (Immutable "update_multiple_field"); let n_ci = CI.make n in let m = Lazy.force hdr_map in let dl = Lazy.force hdr_dl in (* Algorithm: First try to replace existing values. * If there are more new values than old values, * at the excess values after the last old value, * or if not possible, at the end. *) let insert_point = ref None in let old_cells = ref(try CIMap.find n_ci m with Not_found -> []) in let new_vals = ref vl in let new_cells = ref [] in while !old_cells <> [] || !new_vals <> [] do match !old_cells, !new_vals with (old_cell :: old_cells'), (new_val :: new_vals') -> (* Only update if the value has changed: *) let (old_n, old_val) = DL.contents old_cell in if old_val = new_val then ( new_cells := old_cell :: !new_cells; insert_point := Some old_cell; ) else ( let new_cell = DL.cell (n, new_val) in DL.replace ~neo:new_cell old_cell; insert_point := Some new_cell; new_cells := new_cell :: !new_cells ); old_cells := old_cells'; new_vals := new_vals'; | [], (new_val :: new_vals') -> let new_cell = DL.cell (n, new_val) in ( match !insert_point with Some p -> DL.insert_after ~neo:new_cell p; | None -> DL.add_at_end ~neo:new_cell dl ); new_vals := new_vals'; insert_point := Some new_cell; new_cells := new_cell :: !new_cells | (old_cell :: old_cells'), [] -> DL.delete old_cell; old_cells := old_cells' | [], [] -> assert false done; let m' = CIMap.add n_ci (List.rev !new_cells) m in hdr_map <- lazy m' method delete_field n = if self#ro then raise (Immutable "delete_field"); let n_ci = CI.make n in let m = Lazy.force hdr_map in let old_cells = try CIMap.find n_ci m with Not_found -> [] in List.iter DL.delete old_cells; let m' = CIMap.remove n_ci m in hdr_map <- lazy m'; end ;; let basic_mime_header = new basic_mime_header class wrap_mime_header hdr : mime_header = object(self) method fields = hdr#fields method field = hdr#field method multiple_field = hdr#multiple_field method ro = hdr#ro (* Heirs can redefine [ro] to make this object immutable *) method set_fields fields = if self#ro then raise(Immutable "set_fields"); hdr#set_fields fields method update_field n v = if self#ro then raise(Immutable "update_field"); hdr#update_field n v method update_multiple_field n v = if self#ro then raise(Immutable "update_multiple_fields"); hdr#update_multiple_field n v method delete_field n = if self#ro then raise(Immutable "delete_field"); hdr#delete_field n end class wrap_mime_header_ro hdr : mime_header = object(self) method fields = hdr#fields method field = hdr#field method multiple_field = hdr#multiple_field method ro = true method set_fields _ = raise (Immutable "set_fields") method update_field _ _ = raise (Immutable "update_field") method update_multiple_field _ _ = raise (Immutable "update_multiple_field") method delete_field _ = raise (Immutable "delete_field") end let wrap_mime_header_ro = new wrap_mime_header_ro class memory_mime_body v : mime_body = object (self) val mutable value = v val mutable finalized = false method value = if finalized then self # finalized(); value method store = `Memory method open_value_rd() = if finalized then self # finalized(); new input_string value method finalize() = finalized <- true method ro = (* Heirs can redefine [ro] to make this object immutable *) false method set_value s = if self#ro then raise (Immutable "set_value"); if finalized then self # finalized(); value <- s; method open_value_wr() = if self#ro then raise (Immutable "open_value_wr"); if finalized then self # finalized(); let b = Netbuffer.create 60 in new output_netbuffer ~onclose:(fun () -> value <- Netbuffer.contents b) b; method private finalized() = failwith "Netmime.memory_mime_body: object is finalized"; end ;; let memory_mime_body = new memory_mime_body class file_mime_body ?(fin=false) f : mime_body = object (self) val mutable finalized = false val fin = fin val filename = f val cached_value = Weak.create 1 method ro = (* Heirs can redefine [ro] to make this object immutable *) false method store = `File filename method value = if finalized then self # finalized(); match Weak.get cached_value 0 with None -> with_in_obj_channel (new input_channel (open_in_bin filename)) (fun objch -> let v = string_of_in_obj_channel objch in Weak.set cached_value 0 (Some v); v ) | Some v -> v method open_value_rd() = if finalized then self # finalized(); new input_channel (open_in_bin filename) method set_value s = if self#ro then raise (Immutable "set_value"); if finalized then self # finalized(); with_out_obj_channel (new output_channel (open_out_bin filename)) (fun ch -> ch # output_string s); method open_value_wr() = if self#ro then raise (Immutable "open_value_wr"); if finalized then self # finalized(); new output_channel (open_out_bin filename) method finalize () = if fin && not finalized then begin try Sys.remove filename with _ -> () end; finalized <- true method private finalized() = failwith "Netmime.file_mime_body: object is finalized"; end ;; let file_mime_body = new file_mime_body class wrap_mime_body bdy : mime_body = object (self) method value = bdy#value method store = bdy#store method open_value_rd = bdy#open_value_rd method finalize = bdy#finalize method ro = bdy#ro method set_value = bdy#set_value method open_value_wr = bdy#open_value_wr end class wrap_mime_body_ro bdy : mime_body = object (self) method value = bdy#value method store = bdy#store method open_value_rd = bdy#open_value_rd method finalize = bdy#finalize method ro = true method set_value _ = raise (Immutable "set_value") method open_value_wr _ = raise (Immutable "open_value_wr") end let wrap_mime_body_ro = new wrap_mime_body_ro let rec wrap_complex_mime_message_ro (h,cb) = (wrap_mime_header_ro h, match cb with `Body b -> `Body(wrap_mime_body_ro b) | `Parts p -> `Parts(List.map wrap_complex_mime_message_ro p) ) ;; ocamlnet-4.0.4/src/netstring/nethttp.mli0000644000175000017500000013437512541553661016767 0ustar gerdgerd(* $Id: nethttp.mli 2195 2015-01-01 12:23:39Z gerd $ * ---------------------------------------------------------------------- * Nethttp: Basic definitions for the HTTP protocol *) (** {1 Basic definitions for the HTTP protocol} *) (** These definitions can be used by both HTTP clients and servers, and by * protocols in the middle, e.g. CGI. *) type protocol_version = int * int (* (major,minor) number *) (** A pair of a major and minor version number *) type protocol_attribute = [ `Secure_https ] type protocol = [ `Http of (protocol_version * protocol_attribute list) | `Other ] (** The base protocol. RFC 2145 defines how to interpret major and * minor numbers. In particular, we have: * - [`Http((0,9),_)] is the ancient HTTP version 0.9 * - [`Http((1,n),_)] is the HTTP protocol 1.n. It is expected that * all these versions are compatible to each other * except negotiable features. * - [`Http((m,_),_)] for m>1 is regarded as unknown protocol, * incompatible to any [`Http((1,n),_)] * - [`Other] is anything else (unrecognizes protocol) *) val string_of_protocol : protocol -> string (** Returns the string representation, e.g. "HTTP/1.0". Fails for [`Other] *) val protocol_of_string : string -> protocol (** Parses the protocol string, e.g. "HTTP/1.0". Returns [`Other] * for unrecognized strings *) type http_status = (* Status codes from RFC 2616 *) (* 1xx: (informational) *) [ `Continue | `Switching_protocols (* 2xx: (successful) *) | `Ok | `Created | `Accepted | `Non_authoritative | `No_content | `Reset_content | `Partial_content (* 3xx: (redirection) *) | `Multiple_choices | `Moved_permanently | `Found | `See_other | `Not_modified | `Use_proxy | `Temporary_redirect (* 4xx: (client error) *) | `Bad_request | `Unauthorized | `Payment_required | `Forbidden | `Not_found | `Method_not_allowed | `Not_acceptable | `Proxy_auth_required | `Request_timeout | `Conflict | `Gone | `Length_required | `Precondition_failed | `Request_entity_too_large | `Request_uri_too_long | `Unsupported_media_type | `Requested_range_not_satisfiable | `Expectation_failed (* 5xx: (server error) *) | `Internal_server_error | `Not_implemented | `Bad_gateway | `Service_unavailable | `Gateway_timeout | `Http_version_not_supported ] (** HTTP response status: * * {b Informational (1xx):} * - [`Continue] * - [`Switching_protocols] * * {b Successful (2xx):} * - [`Ok] * - [`Created] * - [`Accepted] * - [`Non_authoritative] * - [`No_content] * - [`Reset_content] * - [`Partial_content] * * {b Redirection (3xx):} * - [`Multiple_choices] * - [`Moved_permanently] * - [`Found] * - [`See_other] * - [`Not_modified] * - [`Use_proxy] * - [`Temporary_redirect] * * {b Client error (4xx):} * - [`Bad_request] * - [`Unauthorized] * - [`Payment_required] * - [`Forbidden] * - [`Not_found] * - [`Method_not_allowed] * - [`Not_acceptable] * - [`Proxy_auth_required] * - [`Request_timeout] * - [`Conflict] * - [`Gone] * - [`Length_required] * - [`Precondition_failed] * - [`Request_entity_too_large] * - [`Request_uri_too_long] * - [`Unsupported_media_type] * - [`Request_range_not_satisfiable] * - [`Expectation_failed] * * {b Server Error (5xx):} * - [`Internal_server_error] * - [`Not_implemented] * - [`Bad_gateway] * - [`Service_unavailable] * - [`Gateway_timeout] * - [`Http_version_not_supported] *) val int_of_http_status : http_status -> int (** Returns the integer code for a status value *) val http_status_of_int : int -> http_status (** Returns the status value for an integer code, or raises [Not_found] *) val string_of_http_status : http_status -> string (** Returns the informational text for a status value *) (* See also Netcgi.status_line *) val base_code : int -> int (** Allows to handle unknown status codes that are untranslatable by [http_status_of_int]: - for a code 100 to 199 the value 100 is returned - for a code 200 to 299 the value 200 is returned - for a code 300 to 399 the value 300 is returned - for a code 400 to 499 the value 400 is returned - for all other codes 500 is returned E.g. {[ let st = try Nethttp.http_status_of_int code with Not_found -> Nethttp.http_status_of_int (Nethttp.base_code code) ]} *) type http_method = string * string (** Method name, URI *) type cache_control_token = [ `No_store | `Max_age of int | `Max_stale of int option | `Min_fresh of int | `No_transform | `Only_if_cached | `Public | `Private of string list | `No_cache of string list | `Must_revalidate | `Proxy_revalidate | `S_maxage of int | `Extension of string * string option ] (** The cache control token for the [Cache-control] header *) type etag = [ `Weak of string | `Strong of string ] (** Entity tags can be weak or strong *) val weak_validator_match : etag -> etag -> bool (** Whether the tags match weakly (see RFC 2616 for definition) *) val strong_validator_match : etag -> etag -> bool (** Whether the tags match strongly (see RFC 2616 for definition) *) exception Bad_header_field of string (** Raised when a header field cannot be parsed. The string argument * is the name of the failing function *) class type http_header = Netmime.mime_header class type http_header_ro = Netmime.mime_header_ro (** The HTTP header is represented as MIME header *) class type http_trailer = Netmime.mime_header class type http_trailer_ro = Netmime.mime_header_ro (** The HTTP trailer is represented as MIME header *) val status_of_cgi_header : http_header -> (int * string) (** Returns the status code and the status text corresponding to the * [Status] header *) type netscape_cookie = { cookie_name : string; (** The name of the cookie *) cookie_value : string; (** The value of the cookie. There are no restrictions on the * value of the cookie *) cookie_expires : float option; (** Expiration: * - [None]: the cookie expires when the browser session ends. * - [Some t]: the cookie expires at the time [t] (seconds since * the epoch) *) cookie_domain : string option; (** Cookies are bound to a certain domain, i.e. the browser sends * them only when web pages of the domain are requested: * * - [None]: the domain is the hostname of the server * - [Some domain]: the domain is [domain] *) cookie_path : string option; (** Cookies are also bound to certain path prefixes, i.e. the browser * sends them only when web pages at the path or below are requested. * * - [None]: the path is script name + path_info * - [Some p]: the path is [p]. With [Some "/"] you can disable the * path restriction completely. *) cookie_secure : bool; (** Cookies are also bound to the type of the web server: * [false] means servers without SSL, [true] means servers with * activated SSL ("https"). *) } (** These are old-style cookies, as introduced by Netscape. For a better representation of cookies see the {!Nethttp.Cookie} module. This type is kept for now (and is also not considered as deprecated), as the access functions in the {!Nethttp.Header} module are more complete than those for {!Nethttp.Cookie}. *) type cookie = netscape_cookie (** Compatibility name. {b Deprecated} *) val decode_query : string -> (string * string) (** Splits the URI into a "script name" and a "query string" *) val split_host_port : string -> (string * int option) (** Splits the [Host] header in hostname and optional port number. * Fails on syntax error *) val uripath_encode : string -> string (** Encodes unsafe characters in URI paths. The slash character is not encoded. * This function should only be applied to the part before '?'. *) val uripath_decode : string -> string (** Decodes %XX sequences in URI paths. %2F is forbidden (failure). * This function should only be applied to the part before '?'. *) (**********************************************************************) (** {2 Parsing and Printing of Headers} *) module Cookie : sig (* This module has been written by Christophe Troestler. See the header of netcgi.mli for full copyright message. *) (** Functions to manipulate cookies. You should know that besides the [name] and [value] attribute, user agents will send at most the [path], [domain] and [port] and usually will not send them at all. For interoperability, cookies are set using version 0 (by Netscape) unless version 1 (RFC 2965 and the older RFC 2109) fields are set. While version 0 is well supported by browsers, RFC 2109 requires a recent browser and RFC 2965 is usually not supported. You do not have to worry however, cookies are always sent in such a way older browsers understand them -- albeit not all attributes of course -- so your application can be ready for the time RFC 2965 will be the norm. This cookie representation is preferred over the Netscape-only type {!Nethttp.netscape_cookie}. N.B. This module appears also as {!Netcgi.Cookie}. *) type t (** Mutable cookie type *) val make : ?max_age:int -> ?domain:string -> ?path:string -> ?secure:bool -> ?comment:string -> ?comment_url:string -> ?ports:int list -> string -> string -> t (** [make ?expires ?domain ?path ?secure name value] creates a new cookie with name [name] holding [value]. @param max_age see {!Netcgi.Cookie.set_max_age}. Default: when user agent exits. @param domain see {!Netcgi.Cookie.set_domain}. Default: hostname of the server. @param path see {!Netcgi.Cookie.set_path}. Default: script name + path_info. @param secure see {!Netcgi.Cookie.set_secure}. Default: [false]. @param comment see {!Netcgi.Cookie.set_comment}. Default: [""]. @param comment_url see {!Netcgi.Cookie.set_comment_url}. Default: [""]. @param ports see {!Netcgi.Cookie.set_ports}. Default: same port the cookie was sent. *) val name : t -> string (** The name of the cookie. *) val value : t -> string (** The value of the cookie. *) val domain : t -> string option (** The domain of the cookie, if set. *) val path : t -> string option (** The path of the cookie, if set. *) val ports : t -> int list option (** [port c] the ports to which the cookie may be returned or [[]] if not set. *) val max_age : t -> int option (** The expiration time of the cookie, in seconds. [None] means that the cookie will be discarded when the browser exits. This information is not returned by the browser. *) val secure : t -> bool (** Tells whether the cookie is secure. This information is not returned by the browser. *) val comment : t -> string (** Returns the comment associated to the cookie or [""] if it does not exists. This information is not returned by the browser. *) val comment_url : t -> string (** Returns the comment URL associated to the cookie or [""] if it does not exists. This information is not returned by the browser. *) val set_value : t -> string -> unit (** [set_value c v] sets the value of the cookie [c] to [v]. *) val set_max_age : t -> int option -> unit (** [set_max_age c (Some t)] sets the lifetime of the cookie [c] to [t] seconds. If [t <= 0], it means that the cookie should be discarded immediately. [set_expires c None] tells the cookie to be discarded when the user agent exits. (Despite the fact that the name is borrowed from the version 1 of the specification, it works transparently with version 0.) *) val set_domain : t -> string option -> unit (** Cookies are bound to a certain domain, i.e. the browser sends them only when web pages of the domain are requested: - [None]: the domain is the hostname of the server. - [Some domain]: the domain is [domain]. *) val set_path : t -> string option -> unit (** Cookies are also bound to certain path prefixes, i.e. the browser sends them only when web pages at the path or below are requested. - [None]: the path is script name + path_info - [Some p]: the path is [p]. With [Some "/"] you can disable the path restriction completely. *) val set_secure : t -> bool -> unit (** Cookies are also bound to the type of the web server: [set_secure false] means servers without SSL, [set_secure true] means servers with activated SSL ("https"). *) val set_comment : t -> string -> unit (** [set_comment c s] sets the comment of the cookie [c] to [s] which must be UTF-8 encoded (RFC 2279). Because cookies can store personal information, the comment should describe how the cookie will be used so the client can decide whether to allow the cookie or not. To cancel a comment, set it to [""]. Cookie version 1 (RFC 2109). *) val set_comment_url : t -> string -> unit (** [set_comment_url c url] same as {!Netcgi.Cookie.set_comment} except that the cookie comment is available on the page pointed by [url]. To cancel, set it to [""]. Cookie version 1 (RFC 2965). *) val set_ports : t -> int list option -> unit (** [set ports c (Some p)] says that the cookie [c] must only be returned if the server request comes from one of the listed ports. If [p = []], the cookie will only be sent to the request-port it was received from. [set_ports c None] says that the cookie may be sent to any port. Cookie version 1 (RFC 2965). *) val of_netscape_cookie : netscape_cookie -> t (** Convert a Netscape cookie to the new representation *) val to_netscape_cookie : t -> netscape_cookie (** Convert to Netscape cookie (with information loss) *) end module Header : sig (** This module is a parser/printer for the header fields used in HTTP/1.1. * The [get_*] functions generally raise [Not_found] when the queried header * is not present. If the syntax of the field is a comma-separated list of * multiple values, the [get_*] functions generally merge all headers of * the same type. The order is preserved in this case. The list [[]] means * that the header exists, but only with empty value. For example, * * {[ * Accept: text/html * Accept: text/plain * ]} * * would be returned as [["text/html",[],[]; "text/plain", [],[]]] * by [get_accept]. The header * * {[Accept:]} * * would be returned as [[]]. * * The [set_*] functions generally produce only a single header with comma- * separated values. Existing header are overwritten/removed. * * To remove a header, simply use the [delete_field] method of [http_header]. * * Error behaviour: The [get_*] functions raise [Bad_header_field] * when they cannot parse a header field. The [set_*] functions * raise [Invalid_argument] when an invalid value is passed to them * (only very few functions do that). The argument of both * exceptions is the function name. *) type param_value = [ `V of string | `Q of string ] (** Parameters may occur quoted ([`Q]) or as already decoded values ([`V]) *) type auth_challenge = string * (string * param_value) list (** The type of a single challenge, used during authentication. It is interpreted as [(mechanism_name, params)]. The headers [www-authenticate] and [proxy-authenticate] use this. See RFC 7235 for general information. *) type auth_credentials = string * (string * param_value) list (** The type of a single credentials response, used during authentication. It is interpreted as [(mechanism_name, params)]. The headers [authorize] and [proxy-authorize] use this. See RFC 7235 for general information. *) val parse_quoted_parameters : string -> (string * string) list (** A generic parser for comma-separated parameters in the form key=value or key="value". Fails if the string cannot be parsed. *) val get_accept : #http_header_ro -> (string * (string * string) list * (string * string) list) list (** Returns the [Accept] header as list of triples [(media_range, * media_range_params, accept_params)]. If there are * [accept_params], the first such parameter is always ["q"]. * * All present [Accept] headers are merged. The function returns * [[]] when there is at least one [Accept] header, but none of * the headers has a non-empty value. The function raises * [Not_found] if there no such headers at all (which should be * interpreted as [ ["*/*",[],[] ] ]). *) val best_media_type : #http_header_ro -> string list -> ( string * (string * string) list ) (** Returns the best media type for a header and a list of supported types. * If any type is acceptable, "*/*" will be returned. If no type is * acceptable, "" will be returned. * The supported media types should be sorted such that the best type * is mentioned first. * Of several media types with equal quality the one mentioned first in the * list of supported types is chosen. In case several types in the Accept: * header match the same type in the list of supported types, the most * specific type is chosen. *) val set_accept : #http_header -> (string * (string * string) list * (string * string) list) list -> unit (** Sets the [Accept] header *) val get_accept_charset : #http_header_ro -> (string * (string * string) list) list (** Returns the [Accept-charset] header as list of pairs [(charset,params)]. * The only mentioned parameter in RFC 2616 is ["q"]. * * All present [Accept-charset] headers are merged. The function * raises [Not_found] when there is no [Accept-charset] header * (which should be interpreted as [ ["*",[]] ]). *) val best_charset : #http_header_ro -> string list -> string (** Returns the best charset for a header and a list of supported charsets. * If any charset is acceptable, "*" will be returned. * The supported charsets should be sorted such that the best charset * is mentioned first. * * This function already implements the special handling of ISO-8859-1 * mentioned in RFC 2616. *) val set_accept_charset : #http_header -> (string * (string * string) list) list -> unit (** Sets the [Accept-charset] header *) val get_accept_encoding : #http_header_ro -> (string * (string * string) list) list (** Returns the [Accept-encoding] header as list of pairs [(coding,params)]. * The only mentioned parameter in RFC 2616 is ["q"]. The RFC describes * compatibility problems with the "q" parameter. * * All present [Accept-encoding] headers are merged. The function * raises [Not_found] when there is no [Accept-encoding] header * (which should be interpreted as [ ["identity",[]] ]). The * return value [[]] must be interpreted as [ ["identity",[]] ]. *) val best_encoding : #http_header_ro -> string list -> string (** Returns the best encoding for a header and a list of supported * encodings. If anything else fails, "identity" will be * returned. The supported encodings should be sorted such that * the best encoding is mentioned first. *) val set_accept_encoding : #http_header -> (string * (string * string) list) list -> unit (** Sets the [Accept-encoding] header *) val get_accept_language : #http_header_ro -> (string * (string * string) list) list (** Returns the [Accept-language] header as list of pairs * [(lang_range,params)]. The only mentioned parameter in RFC * 2616 is ["q"]. * * All present [Accept-language] headers are merged. The function * raises [Not_found] when there is no [Accept-language] header * (which should be interpreted as [ ["*",[]] ]). *) val set_accept_language : #http_header -> (string * (string * string) list) list -> unit (** Sets the [Accept-language] header *) val get_accept_ranges : #http_header_ro -> string list (** Returns the [Accept-ranges] header as list of tokens. * * All present [Accept-ranges] headers are merged. The function * raises [Not_found] when there is no [Accept-ranges] * header. The RFC leaves it open how this is to be interpreted * in general. *) val set_accept_ranges : #http_header -> string list -> unit (** Sets the [Accept-ranges] header *) val get_age : #http_header_ro -> float (** Returns the [Age] header as number *) val set_age : #http_header -> float -> unit (** Sets the [Age] header *) val get_allow : #http_header_ro -> string list (** Returns the [Allow] header as list of tokens. * * All present [Allow] headers are merged. The function raises [Not_found] * when there is no [Allow] header. The RFC leaves it open how this is * to be interpreted in general. *) val set_allow : #http_header -> string list -> unit (** Sets the [Allow] header *) val get_authorization : #http_header_ro -> auth_credentials (** Returns the [Authorization] header as pair [(auth_scheme,auth_params)], * or raises [Not_found] if not present. * * The "Basic" authentication scheme is represented specially as * [("basic", [ "credentials", creds ])] where [creds] are the * Base64-encoded credentials. * * At present, parameters are always decoded ([`V]). *) val set_authorization : #http_header -> auth_credentials -> unit (** Sets the [Authorization] header. * The "Basic" authentication scheme is represented as explained for * [get_authorization]. *) val get_cache_control : #http_header_ro -> cache_control_token list (** Returns the [Cache-control] header as list of tokens. * * All present [Cache-control] headers are merged. The function * raises [Not_found] when there is no [Cache-control] header. *) val set_cache_control : #http_header -> cache_control_token list -> unit (** Sets the [Cache-control] header *) val get_connection : #http_header_ro -> string list (** Returns the [Connection] header as list of tokens. * * All present [Connection] headers are merged. The function * raises [Not_found] when there is no [Connection] header. * * The Connection header must be ignored when received from a * HTTP/1.0 client. *) val set_connection : #http_header -> string list -> unit (** Sets the [Connection] header *) val get_content_encoding : #http_header_ro -> string list (** Returns the [Content-encoding] header as list of tokens. * * All present [Content-encoding] headers are merged. * @raise Not_found when there is no [Content-encoding] header. *) val set_content_encoding : #http_header -> string list -> unit (** Sets the [Content-encoding] header *) val get_content_language : #http_header_ro -> string list (** Returns the [Content-language] header as list of tokens. * * All present [Content-language] headers are merged. * @raise Not_found when there is no [Content-language] header. *) val set_content_language : #http_header -> string list -> unit (** Sets the [Content-language] header *) val get_content_length : #http_header_ro -> int64 (** Returns the [Content-length] header as number. If the number * is too big for int64, the exception [Bad_header_field * "Content-length"] will be raised. * @raise Not_found when the header is missing. *) val set_content_length : #http_header -> int64 -> unit (** Sets the [Content-length] header *) val get_content_location : #http_header_ro -> string (** Returns the [Content-location] header as string. * @raise Not_found when the header is missing. *) val set_content_location : #http_header -> string -> unit (** Sets the [Content-location] header *) val get_content_md5 : #http_header_ro -> string (** Returns the [Content-MD5] header as string. The Base64 encoding * has not been touched. * @raise Not_found when the header is missing. *) val set_content_md5 : #http_header -> string -> unit (** Sets the [Content-MD5] header *) val get_content_range : #http_header_ro -> [ `Bytes of (int64*int64) option * int64 option ] (** Returns the [Content-range] header as * [`Bytes(byte_range_resp_spec, instance_length)]. The option value * [None] corresponds to "*" in the RFC. * @raise Not_found when the header is missing. *) val set_content_range : #http_header -> [ `Bytes of (int64*int64) option * int64 option ] -> unit (** Sets the [Content-range] header *) val get_content_type : #http_header_ro -> string * (string * string) list (** Returns the [Content-type] header as pair [(media_type, params)]. * @raise Not_found when the header is missing. *) val set_content_type : #http_header -> string * (string * string) list -> unit (** Sets the [Content-type] header *) val get_date : #http_header_ro -> float (** Returns the [Date] header as number (seconds since the Epoch). * @raise Not_found when the header is missing. *) val set_date : #http_header -> float -> unit (** Sets the [Date] header *) val get_etag : #http_header_ro -> etag (** Returns the [Etag] header. * @raise Not_found when the header is missing. *) val set_etag : #http_header -> etag -> unit (** Sets the [Etag] header *) val get_expect : #http_header_ro -> (string * string option * (string * string) list) list (** Returns the [Expect] header as list of triples [(token,value,params)]. * * All present [Expect] headers are merged. * @raise Not_found when there is no [Expect] header. *) val set_expect : #http_header -> (string * string option * (string * string) list) list -> unit (** Sets the [Expect] header *) val get_expires : #http_header_ro -> float (** Returns the [Expires] header as number (seconds since the Epoch). * @raise Not_found when the header is missing. *) val set_expires : #http_header -> float -> unit (** Sets the [Expires] header *) val get_from : #http_header_ro -> string (** Returns the [From] header as string. * @raise Not_found when the header is missing. *) val set_from : #http_header -> string -> unit (** Sets the [From] header *) val get_host : #http_header_ro -> string * int option (** Returns the [Host] header as pair [(host,port)]. * @raise Not_found when the header is missing. *) val set_host : #http_header -> string * int option -> unit (** Sets the [Host] header *) val get_if_match : #http_header_ro -> etag list option (** Returns the [If-match] header. The value [None] means "*". * @raise Not_found when the header is missing. *) val set_if_match : #http_header -> etag list option -> unit (** Sets the [If-match] header *) val get_if_modified_since : #http_header_ro -> float (** Returns the [If-modified-since] header as number (seconds * since the Epoch). * @raise Not_found when the header is missing. *) val set_if_modified_since : #http_header -> float -> unit (** Sets the [If-modified-since] header *) val get_if_none_match : #http_header_ro -> etag list option (** Returns the [If-none-match] header. The value [None] means "*". * @raise Not_found when the header is missing. *) val set_if_none_match : #http_header -> etag list option -> unit (** Sets the [If-none-match] header *) val get_if_range : #http_header_ro -> [ `Etag of etag | `Date of float ] (** Returns the [If-range] header. * @raise Not_found when the header is missing. *) val set_if_range : #http_header -> [ `Etag of etag | `Date of float ] -> unit (** Sets the [If-range] header *) val get_if_unmodified_since : #http_header_ro -> float (** Returns the [If-unmodified-since] header as number (seconds * since the Epoch). * @raise Not_found when the header is missing. *) val set_if_unmodified_since : #http_header -> float -> unit (** Sets the [If-unmodified-since] header *) val get_last_modified : #http_header_ro -> float (** Returns the [Last-modified] header as number (seconds since the Epoch). * @raise Not_found when the header is missing. *) val set_last_modified : #http_header -> float -> unit (** Sets the [Last-modified] header *) val get_location : #http_header_ro -> string (** Returns the [Location] header as string. * @raise Not_found when the header is missing. *) val set_location : #http_header -> string -> unit (** Sets the [Location] header *) val get_max_forwards : #http_header_ro -> int (** Returns the [Max-forwards] header as number. * @raise Not_found when the header is missing. *) val set_max_forwards : #http_header -> int -> unit (** Sets the [Max-forwards] header *) val get_pragma : #http_header_ro -> (string * string option) list (** Returns the [Pragma] header as list of pairs [(token,value)]. * * All present [Pragma] headers are merged. * @raise Not_found when there is no [Pragma] header. *) val set_pragma : #http_header -> (string * string option) list -> unit (** Sets the [Pragma] header *) val get_proxy_authenticate : #http_header_ro -> auth_challenge list (** Returns the [Proxy-authenticate] header as list of challenges * [(auth_scheme,auth_params)]. See also [get_www_authenticate]. * * All present [Proxy-authenticate] headers are merged. * @raise Not_found when there is no [Proxy-authenticate] header. * * At present, parameters are always decoded ([`V]). *) val set_proxy_authenticate : #http_header -> auth_challenge list -> unit (** Sets the [Proxy-authenticate] header *) val get_proxy_authorization : #http_header_ro -> auth_credentials (** Returns the [Proxy-authorization] header as pair * [(auth_scheme,auth_params)]. @raise Not_found when the header is * missing. * * The "Basic" authentication scheme is represented specially as * [("basic", [ "credentials", creds ])] where [creds] are the * Base64-encoded credentials. * * At present, parameters are always decoded ([`V]). *) val set_proxy_authorization : #http_header -> auth_credentials -> unit (** Sets the [Proxy-authorization] header * The "Basic" authentication scheme is represented as explained for * [get_proxy_authorization]. *) val get_range : #http_header_ro -> [`Bytes of (int64 option * int64 option) list ] (** Returns the [Range] header as [`Bytes ranges], where the list [ranges] * has elements of the form [(Some first_pos, Some last_pos)], * [(Some first_pos, None)] (prefix range), or [(None, Some * last_pos)] (suffix range). * @raise Not_found when the header is missing. *) val set_range : #http_header -> [`Bytes of (int64 option * int64 option) list ] -> unit (** Sets the [Range] header *) val get_referer : #http_header_ro -> string (** Returns the [Referer] header as string. * @raise Not_found when the header is missing. *) val get_referrer : #http_header_ro -> string (** Same, for addicts of correct orthography *) val set_referer : #http_header -> string -> unit (** Sets the [Referer] header *) val set_referrer : #http_header -> string -> unit (** Same, for addicts of correct orthography *) val get_retry_after : #http_header_ro -> [ `Date of float | `Seconds of int ] (** Returns the [Retry-after] header. * @raise Not_found when the header is missing. *) val set_retry_after : #http_header -> [ `Date of float | `Seconds of int ] -> unit (** Sets the [Retry-after] header *) val get_server : #http_header_ro -> string (** Returns the [Server] header as uninterpreted string (including * comments). * @raise Not_found when the header is missing. *) val set_server : #http_header -> string -> unit (** Sets the [Server] header *) val get_te : #http_header_ro -> (string * (string * string) list * (string * string) list) list (** Returns the [TE] header as list of triples * [(te_token, te_params, accept_params)]. * If there are [accept_params], the first such parameter is always ["q"]. * * All present [TE] headers are merged. The function returns [[]] when * there is at least one [TE] header, but none of the headers has a * non-empty value. * @raise Not_found if there no such headers at all. *) val set_te : #http_header -> (string * (string * string) list * (string * string) list) list -> unit (** Sets the [TE] header *) val get_trailer : #http_header_ro -> string list (** Returns the [Trailer] header as list of field names. * * All present [Trailer] headers are merged. The function returns * [[]] when there is at least one [Trailer] header, but none of * the headers has a non-empty value. * @raise Not_found if there no such headers at all. *) val set_trailer : #http_header -> string list -> unit (** Sets the [Trailer] header *) val get_transfer_encoding : #http_header_ro -> (string * (string * string) list) list (** Returns the [Transfer-encoding] header as list of pairs * [(token, params)]. * * All present [Transfer-encoding] headers are merged. The * function returns [[]] when there is at least one * [Transfer-encoding] header, but none of the headers has a * non-empty value. * @raise Not_found if there no such headers at all. *) val set_transfer_encoding : #http_header -> (string * (string * string) list) list -> unit (** Sets the [Transfer-encoding] header *) val get_upgrade : #http_header_ro -> string list (** Returns the [Upgrade] header as list of products. * * All present [Upgrade] headers are merged. The function returns * [[]] when there is at least one [Upgrade] header, but none of * the headers has a non-empty value. * @raise Not_found if there no such headers at all. *) val set_upgrade : #http_header -> string list -> unit (** Sets the [Upgrade] header *) val get_user_agent : #http_header_ro -> string (** Returns the [User-agent] header as uninterpreted string * (including comments). * @raise Not_found if the header is missing. *) val set_user_agent : #http_header -> string -> unit (** Sets the [User-agent] header *) val get_vary : #http_header_ro -> [ `Star | `Fields of string list ] (** Returns the [Vary] header. * @raise Not_found if the header is missing. *) val set_vary : #http_header -> [ `Star | `Fields of string list ] -> unit (** Sets the [Vary] header *) (* val get_via : #http_header_ro -> (string option * string * string * string option) list (** Returns the [Via] header as list of tuples * [(proto_name, proto_version, received_by, comment)]. * * All present [Via] headers are merged. * @raise Not_found if the header is missing. *) *) (* val set_via : #http_header -> (string option * string * string * string option) list -> unit (** Sets the [Via] header *) *) (* val get_warning : #http_header_ro -> (int * string * string * float option) list (** Returns the [Warning] header as list of tuples * [(code, agent, text, date)]. * * All present [Warning] headers are merged. * @raise Not_found if the header is missing. *) *) (* val set_warning : #http_header -> (int * string * string * float option) list -> unit (** Sets the [Warning] header *) *) val get_www_authenticate : #http_header_ro -> auth_challenge list (** Returns the [WWW-Authenticate] header as list of challenges * [(auth_scheme,auth_params)]. * * All present [WWW-Authenticate] headers are merged. * * The scheme "negotiate" uses a deviating header format. * This data is returned as e.g. [("negotiate", ["credentials", data])]. * * At present, parameters are always decoded ([`V]). * @raise Not_found if the header is missing. *) val set_www_authenticate : #http_header -> auth_challenge list -> unit (** Sets the [WWW-Authenticate] header *) val get_cookie : #http_header_ro -> (string * string) list (** Get the (Netscape) cookies as (name,value) pairs (or Not_found). *) val get_cookie_ct : #http_header_ro -> Cookie.t list (** Get the cookies in the {!Nethttp.Cookie.t} representation (the suffix "_ct" reminds of [Cookie.t]). This function also supports version 1 cookies. Returns the empty list if there are no cookies. *) val set_cookie : #http_header -> (string * string) list -> unit (** Set the [Cookie] header. Note: This does not set cookies in the client, * use [set_set_cookie] instead! *) val get_set_cookie : #http_header_ro -> netscape_cookie list (** Get the [Set-Cookie] header *) val set_set_cookie : #http_header -> netscape_cookie list -> unit (** Set the [Set-Cookie] header *) val set_set_cookie_ct : #http_header -> Cookie.t list -> unit (** Set the [Set-Cookie] and [Set-Cookie2] headers: [set_set_cookie_ct header cookies] sets the [cookies] in [header] using version 0 or version 1 depending on whether version 1 fields are used. For better browser compatibility, if "Set-cookie2" (RFC 2965) is issued, then a "Set-cookie" precedes (declaring the same cookie with a limited number of options). *) end (** {2 HTTP transport registry} *) type transport_layer_id = int (** see {!Nethttp_client.transport_layer_id} *) val new_trans_id : unit -> transport_layer_id (** Allocates and returns a new ID *) val http_trans_id : transport_layer_id (** Identifies the pure HTTP transport (without SSL), with or without web proxies *) val https_trans_id : transport_layer_id (** Identifies anonymous HTTPS transport (i.e. no client certificates), with or without web proxies. *) val spnego_trans_id : transport_layer_id (** Identifies an anonymous HTTPS transport that is additionally authenticated via SPNEGO (as described in RFC 4559) *) val proxy_only_trans_id : transport_layer_id (** Identifies web proxy connections. Use this to e.g. send an FTP URL to a web proxy via HTTP *) (** {2 Types for authentication} *) (** See also {!Netsys_sasl_types.SASL_MECHANISM}. This is very similar, only that - the messages are encapsulated as HTTP headers, and - the "realm" parameter is commonly supported by mechanisms In SASL terms, HTTP authentication is normally "server first". There is only one exception: re-authentication, which is "client first". *) type match_result = [ `Accept of string * string option | `Reroute of string * transport_layer_id | `Accept_reroute of string * string option * transport_layer_id | `Reject ] (** See {!Nethttp.HTTP_MECHANISM.client_match} *) module type HTTP_MECHANISM = sig val mechanism_name : string val available : unit -> bool (** Whether the mechanism is available, in particular whether the required crypto support is linked in *) val restart_supported : bool (** Whether the mechanism supports quick restarts (re-authentication) *) type credentials val init_credentials : (string * string * (string * string) list) list -> credentials (** Supply the mechanism with credentials. These are given as list [(type,value,params)]. The mechanism may pick any element of this list which are considered as equivalent. Types are defined per mechanism. All mechanisms understand the "password" type, which is just the cleartext password, e.g. {[ [ "password", "ThE sEcReT", [] ] ]} The password can have parameters: - "realm": the password is only applicable to this realm. The realm parameter should only occur once. - "domain-uri": the password is only applicable to this URI space. The URI must include the protocol scheme, the host name, and "/" as path. The port number is optional. Example: "http://localhost/". The domain-uri parameter can occur several times. *) val client_match : params:(string * string * bool) list -> Header.auth_challenge -> match_result (** Checks whether this mechanism can accept the initial authentication challenge (i.e. the first challenge sent from the server to the client. The [params] are as for [create_client_session]. On success, returns [`Accept(realm,id_opt)]. On failure, returns [`Reject]. This function usually does not raise exceptions. If the mechanism does not support the notion of realms, a dummy realm should be returned. The [id_opt] is the session ID (if supported). Session IDs can be used to bind reauthentications to the original session. The challenge is from a [www-authenticate] or a [proxy-authenticate] header. There is also the result [`Reroute(realm, trans_id)], meaning that the request would be acceptable if it came over the transport identified by [trans_id]. [`Accept_reroute] is the combination of accepting and rerouting, i.e. the auth protocol can start, but the second request should go over the other transport. Both [`Reroute] and [`Accept_reroute] are only allowed for initial challenges. *) type client_session val client_state : client_session -> Netsys_sasl_types.client_state val create_client_session : user:string -> creds:credentials -> params:(string * string * bool) list -> unit -> client_session (** The new client session authenticate as [user]. The credentials are [creds]. [user] must be encoded in UTF-8. The parameters are given as list [(name,value,critical)]. Critical parameters must be interpreted by the mechanism, and unknown critical parameters must be rejected by a [Failure] exception. Non-critical parameters are ignored if they are unknown to the mechanism. Available parameters: - "realm" - "id" (if [client_match] returns a session ID) - "trans_id": the {!Nethttp_client.transport_layer_id} of the current HTTP request - "conn_id": an identifier for the TCP connection - "https": is set to "true" if the current connection is TLS-secured - "target-host": the hostname from the HTTP request - "target-uri": the URL from the HTTP request *) val client_configure_channel_binding : client_session -> Netsys_sasl_types.cb -> unit (** Configure GS2-style channel binding *) val client_restart : params:(string * string * bool) list -> client_session -> unit (** Restart the session for another authentication round. The session must be in state [`OK]. After the restart the session will be in state [`Emit]. The params are the same as for [create_client_session], but updated where needed. *) val client_process_challenge : client_session -> string -> string -> #http_header_ro -> Header.auth_challenge -> unit (** [client_process_challenge cs method uri header challenge]: Process the challenge from the server. The state must be [`Wait]. As an exception, this function can also be called for the initial challenge from the server, even if the state is [`Emit]. [method] is the request method. [uri] is the request URI *) val client_emit_response : client_session -> string -> string -> #http_header_ro -> Header.auth_credentials * (string * string) list (** [let (creds,new_headers) = client_emit_response cs method uri header]: Emit a new response as a pair [(creds,new_headers)]. The state must be [`Emit]. The [creds] either go into the [authorization] or [proxy-authorization] header. The [new_headers] are additional headers to modify. *) val client_channel_binding : client_session -> Netsys_sasl_types.cb (** Whether the client suggests or demands channel binding *) val client_user_name : client_session -> string (** The user name *) val client_stash_session : client_session -> string (** Serializes the session as string *) val client_resume_session : string -> client_session (** Unserializes the session *) val client_session_id : client_session -> string option (** Optionally return a string that can be used to identify the client session. Not all mechanisms support this. *) val client_domain : client_session -> string list (** After successful authentication, this function may return the URIs defining the authentication space. *) val client_prop : client_session -> string -> string (** Get a mechanism-specific property of the session. Commonly supported keys: - "realm" - "domain-uri" *) val client_gssapi_props : client_session -> Netsys_gssapi.client_props (** Returns the GSSAPI props if available, or raise [Not_found] *) end (**/**) val rev_split : (char -> bool) -> string -> string list (* See netcgi_common.mli *) val qstring_of_value : string -> string (* quoted string *) ocamlnet-4.0.4/src/netstring/netnumber.ml0000644000175000017500000006721412541553661017124 0ustar gerdgerd(* $Id: netnumber.ml 1993 2014-08-24 17:03:20Z gerd $ *) (* NOTE: Parts of this implementation depend very much of representation * details of O'Caml 3.xx. It is not guaranteed that this works in future * versions of O'Caml as well. *) (* representation types *) #ifdef WORDSIZE_64 type int4 = int (* faster on 64 bit platforms! *) type uint4 = int (* Note that values >= 0x8000_0000 are represented as negative ints, i.e. the bits 32-62 are all set to 1. *) #else type int4 = int32 type uint4 = int32 #endif type int8 = int64 type uint8 = int64 type fp4 = int32 (* string;; *) (* IEEE representation of fp numbers *) type fp8 = int64 exception Cannot_represent of string (* raised if numbers are too big to map them to other type *) exception Out_of_range module type ENCDEC = sig val read_int4 : string -> int -> int4 val read_int8 : string -> int -> int8 val read_uint4 : string -> int -> uint4 val read_uint8 : string -> int -> uint8 val read_int4_unsafe : string -> int -> int4 val read_int8_unsafe : string -> int -> int8 val read_uint4_unsafe : string -> int -> uint4 val read_uint8_unsafe : string -> int -> uint8 val write_int4 : string -> int -> int4 -> unit val write_int8 : string -> int -> int8 -> unit val write_uint4 : string -> int -> uint4 -> unit val write_uint8 : string -> int -> uint8 -> unit val write_int4_unsafe : string -> int -> int4 -> unit val write_int8_unsafe : string -> int -> int8 -> unit val write_uint4_unsafe : string -> int -> uint4 -> unit val write_uint8_unsafe : string -> int -> uint8 -> unit val int4_as_string : int4 -> string val int8_as_string : int8 -> string val uint4_as_string : uint4 -> string val uint8_as_string : uint8 -> string val write_fp4 : string -> int -> fp4 -> unit val write_fp8 : string -> int -> fp8 -> unit val fp4_as_string : fp4 -> string val fp8_as_string : fp8 -> string val read_fp4 : string -> int -> fp4 val read_fp8 : string -> int -> fp8 end let rec cannot_represent s = (* "rec" because this prevents this function from being inlined *) raise (Cannot_represent s) (**********************************************************************) (* cmp *) (**********************************************************************) #ifdef WORDSIZE_64 let lt_uint4 x y = if x < y then x >= 0 else y < x && y < 0 #else let lt_uint4 x y = if x < y then x >= 0l (* because: - if x < 0 && y < 0 ==> x >u y - if x < 0 && y >= 0 ==> x >u y - if x >= 0 && y => 0 ==> x y <= x *) y < x && y < 0l (* because: - if y < 0 && x < 0 ==> x = 0 ==> x = 0 && x >= 0 ==> x >u y *) #endif let le_uint4 x y = not(lt_uint4 y x) let gt_uint4 x y = lt_uint4 y x let ge_uint4 x y = not(lt_uint4 x y) let lt_uint8 x y = if x < y then x >= 0L else y < x && y < 0L let le_uint8 x y = not(lt_uint8 y x) let gt_uint8 x y = lt_uint8 y x let ge_uint8 x y = not(lt_uint8 x y) (**********************************************************************) (* mk_[u]intn *) (**********************************************************************) (* compatibility interface *) #ifdef WORDSIZE_64 let mk_int4 (c3,c2,c1,c0) = let n3 = (Char.code c3) in let n2 = (Char.code c2) in let n1 = (Char.code c1) in let n0 = (Char.code c0) in (* be careful to set the sign correctly: *) ((n3 lsl 55) asr 31) lor (n2 lsl 16) lor (n1 lsl 8) lor n0 #else let mk_int4 (c3,c2,c1,c0) = let n3 = Int32.of_int (Char.code c3) in let n2 = Int32.of_int (Char.code c2) in let n1 = Int32.of_int (Char.code c1) in let n0 = Int32.of_int (Char.code c0) in Int32.logor (Int32.shift_left n3 24) (Int32.logor (Int32.shift_left n2 16) (Int32.logor (Int32.shift_left n1 8) n0)) #endif let mk_int8 (c7,c6,c5,c4,c3,c2,c1,c0) = let n7 = Int64.of_int (Char.code c7) in let n6 = Int64.of_int (Char.code c6) in let n5 = Int64.of_int (Char.code c5) in let n4 = Int64.of_int (Char.code c4) in let n3 = Int64.of_int (Char.code c3) in let n2 = Int64.of_int (Char.code c2) in let n1 = Int64.of_int (Char.code c1) in let n0 = Int64.of_int (Char.code c0) in Int64.logor (Int64.shift_left n7 56) (Int64.logor (Int64.shift_left n6 48) (Int64.logor (Int64.shift_left n5 40) (Int64.logor (Int64.shift_left n4 32) (Int64.logor (Int64.shift_left n3 24) (Int64.logor (Int64.shift_left n2 16) (Int64.logor (Int64.shift_left n1 8) n0)))))) let mk_uint4 = mk_int4 let mk_uint8 = mk_int8 (**********************************************************************) (* dest_[u]intn *) (**********************************************************************) (* compatibility interface *) #ifdef WORDSIZE_64 let dest_int4 x = let n3 = (x lsr 24) land 0xff in let n2 = (x lsr 16) land 0xff in let n1 = (x lsr 8) land 0xff in let n0 = x land 0xff in (Char.chr n3, Char.chr n2, Char.chr n1, Char.chr n0) #else let dest_int4 x = let n3 = Int32.to_int (Int32.shift_right_logical x 24) land 0xff in let n2 = Int32.to_int (Int32.shift_right_logical x 16) land 0xff in let n1 = Int32.to_int (Int32.shift_right_logical x 8) land 0xff in let n0 = Int32.to_int (Int32.logand x 0xffl) in (Char.chr n3, Char.chr n2, Char.chr n1, Char.chr n0) #endif let dest_int8 x = let n7 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 56) 0xffL) in let n6 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 48) 0xffL) in let n5 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 40) 0xffL) in let n4 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 32) 0xffL) in let n3 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 24) 0xffL) in let n2 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 16) 0xffL) in let n1 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 8) 0xffL) in let n0 = Int64.to_int (Int64.logand x 0xffL) in (Char.chr n7, Char.chr n6, Char.chr n5, Char.chr n4, Char.chr n3, Char.chr n2, Char.chr n1, Char.chr n0) let dest_uint4 = dest_int4 let dest_uint8 = dest_int8 (**********************************************************************) (* int_of_[u]intn *) (**********************************************************************) let c_max_int_64 = Int64.of_int max_int let c_min_int_64 = Int64.of_int min_int let name_int_of_int4 = "int_of_int4" #ifdef WORDSIZE_64 let int_of_int4 x = x #else let int_of_int4 x = if x < (-0x4000_0000l) || x > 0x3fff_ffffl then cannot_represent name_int_of_int4; Int32.to_int x #endif let name_int_of_uint4 = "int_of_uint4" #ifdef WORDSIZE_64 let int_of_uint4 x = (* x land 0xffff_ffff - "Integer literal exceeds the range..." grrrmpf *) (x lsl 31) lsr 31 #else let int_of_uint4 x = if x >= 0l && x <= 0x3fff_ffffl then Int32.to_int x else cannot_represent name_int_of_uint4 #endif let name_int_of_int8 = "int_of_int8" let int_of_int8 x = if x >= c_min_int_64 && x <= c_max_int_64 then Int64.to_int x else cannot_represent name_int_of_int8 let name_int_of_uint8 = "int_of_uint8" let int_of_uint8 x = if x >= Int64.zero && x <= c_max_int_64 then Int64.to_int x else cannot_represent name_int_of_uint8 (**********************************************************************) (* intn_of_int *) (**********************************************************************) let name_int4_of_int = "int4_of_int" #ifdef WORDSIZE_64 let int4_of_int i = let j = i asr 31 in if j = 0 || j = (-1) then i else cannot_represent name_int4_of_int #else let int4_of_int i = Int32.of_int i #endif let name_uint4_of_int = "uint4_of_int" #ifdef WORDSIZE_64 let uint4_of_int i = let j = i asr 32 in if j = 0 then (i lsl 31) asr 31 (* fix sign *) else cannot_represent name_uint4_of_int #else let uint4_of_int i = if i >= 0 then Int32.of_int i else cannot_represent name_uint4_of_int #endif let int8_of_int = Int64.of_int let name_uint8_of_int = "uint8_of_int" let uint8_of_int i = if i >= 0 then Int64.of_int i else cannot_represent name_uint8_of_int (**********************************************************************) (* Int32 and Int64 support: int[32|64]_of_[u]intn *) (**********************************************************************) #ifdef WORDSIZE_64 let int32_of_int4 x = Int32.of_int x #else let int32_of_int4 x = x #endif let name_int32_of_uint4 = "int32_of_uint4" #ifdef WORDSIZE_64 let int32_of_uint4 x = if x >= 0 then Int32.of_int x else cannot_represent name_int32_of_uint4 #else let int32_of_uint4 x = if x >= 0l then x else cannot_represent name_int32_of_uint4 #endif let c_int32_min_int_64 = Int64.of_int32 Int32.min_int let c_int32_max_int_64 = Int64.of_int32 Int32.max_int let name_int32_of_int8 = "int32_of_int8" let int32_of_int8 x = if x >= (-0x8000_0000L) && x <= 0x7fff_0000L then Int64.to_int32 x else cannot_represent name_int32_of_int8 let name_int32_of_uint8 = "int32_of_uint8" let int32_of_uint8 x = if x >= 0L && x <= 0x7fff_0000L then Int64.to_int32 x else cannot_represent name_int32_of_uint8 #ifdef WORDSIZE_64 let int64_of_int4 = Int64.of_int #else let int64_of_int4 = Int64.of_int32 #endif #ifdef WORDSIZE_64 let int64_of_uint4 x = if x >= 0 then Int64.of_int x else Int64.add (Int64.of_int x) 0x1_0000_0000L #else let int64_of_uint4 x = if x >= 0l then Int64.of_int32 x else Int64.add (Int64.of_int32 x) 0x1_0000_0000L #endif let int64_of_int8 x = x let name_int64_of_uint8 = "int64_of_uint8" let int64_of_uint8 x = if x >= 0L then x else cannot_represent name_int64_of_uint8 (**********************************************************************) (* Int32 and Int64 support: [u]intn_of_int[32|64] *) (**********************************************************************) #ifdef WORDSIZE_64 let int4_of_int32 = Int32.to_int #else let int4_of_int32 x = x #endif let name_uint4_of_int32 = "uint4_of_int32" let uint4_of_int32 i = if i < 0l then cannot_represent name_uint4_of_int32; int4_of_int32 i let int8_of_int32 = Int64.of_int32 let name_uint8_of_int32 = "uint8_of_int32" let uint8_of_int32 i = if i < 0l then cannot_represent name_uint8_of_int32; Int64.of_int32 i let name_int4_of_int64 = "int4_of_int64" #ifdef WORDSIZE_64 let int4_of_int64 i = if i >= (-0x8000_0000L) && i <= 0x7fff_ffffL then Int64.to_int i else cannot_represent name_int4_of_int64 #else let int4_of_int64 i = if i >= (-0x8000_0000L) && i <= 0x7fff_ffffL then Int64.to_int32 i else cannot_represent name_int4_of_int64 #endif let name_uint4_of_int64 = "uint4_of_int64" let uint4_of_int64 i = if i < 0L || i > 0xffff_ffffL then cannot_represent name_uint4_of_int64; #ifdef WORDSIZE_64 Int64.to_int(Int64.shift_right (Int64.shift_left i 32) 32) (* sign! *) #else Int64.to_int32 i #endif let int8_of_int64 i = i let name_uint8_of_int64 = "uint8_of_int64" let uint8_of_int64 i = if i < 0L then cannot_represent name_uint8_of_int64; i (**********************************************************************) (* logical_xxx_of_xxx *) (**********************************************************************) #ifdef WORDSIZE_64 let logical_uint4_of_int32 x = Int32.to_int x let logical_int32_of_uint4 x = Int32.of_int x #else let logical_uint4_of_int32 x = x let logical_int32_of_uint4 x = x #endif let logical_uint8_of_int64 x = x let logical_int64_of_uint8 x = x (**********************************************************************) (* min/max *) (**********************************************************************) let min_int4 = int4_of_int32 Int32.min_int let min_uint4 = uint4_of_int 0 let min_int8 = int8_of_int64 Int64.min_int let min_uint8 = uint8_of_int 0 let max_int4 = int4_of_int32 Int32.max_int let max_uint4 = logical_uint4_of_int32 (-1l) let max_int8 = int8_of_int64 Int64.max_int let max_uint8 = logical_uint8_of_int64 (-1L) (**********************************************************************) (* floating point *) (**********************************************************************) let fp8_of_fp4 x = (* Requires O'Caml >= 3.08 *) Int64.bits_of_float (Int32.float_of_bits x) let fp4_of_fp8 x = (* Requires O'Caml >= 3.08 *) Int32.bits_of_float (Int64.float_of_bits x) let float_of_fp8 x = (* Requires O'Caml >= 3.01 *) Int64.float_of_bits x let float_of_fp4 x = (* Requires O'Caml >= 3.08 *) Int32.float_of_bits x (* Old: * float_of_fp8 (fp8_of_fp4 x) *) let fp8_of_float x = (* Requires O'Caml >= 3.01 *) Int64.bits_of_float x let fp4_of_float x = (* Requires O'Caml >= 3.08 *) Int32.bits_of_float x (* Old: * fp4_of_fp8 (fp8_of_float x) *) let mk_fp4 x = int32_of_int4 (mk_int4 x) let mk_fp8 = mk_int8 let dest_fp4 x = dest_int4 (int4_of_int32 x) let dest_fp8 = dest_int8 module BE : ENCDEC = struct (**********************************************************************) (* read_[u]intn *) (**********************************************************************) #ifdef WORDSIZE_64 #ifdef USE_NETSYS_XDR let read_int4_unsafe = Netsys_xdr.s_read_int4_64_unsafe #else let read_int4_unsafe s pos = let n3 = Char.code (String.unsafe_get s pos) in let x = (n3 lsl 55) asr 31 in (* sign! *) let n2 = Char.code (String.unsafe_get s (pos+1)) in let x = x lor (n2 lsl 16) in let n1 = Char.code (String.unsafe_get s (pos+2)) in let x = x lor (n1 lsl 8) in let n0 = Char.code (String.unsafe_get s (pos+3)) in x lor n0 #endif #else let read_int4_unsafe s pos = let n3 = Int32.of_int (Char.code (String.unsafe_get s pos)) in let x = Int32.shift_left n3 24 in let n2 = Int32.of_int (Char.code (String.unsafe_get s (pos+1))) in let x = Int32.logor x (Int32.shift_left n2 16) in let n1 = Int32.of_int (Char.code (String.unsafe_get s (pos+2))) in let x = Int32.logor x (Int32.shift_left n1 8) in let n0 = Int32.of_int (Char.code (String.unsafe_get s (pos+3))) in Int32.logor x n0 #endif (* seems to be slightly better than Int32.logor (Int32.shift_left n3 24) (Int32.logor (Int32.shift_left n2 16) (Int32.logor (Int32.shift_left n1 8) n0)) *) let read_int4 s pos = if pos < 0 || pos + 4 > String.length s then raise Out_of_range; read_int4_unsafe s pos #ifdef WORDSIZE_64 #ifdef USE_NETSYS_XDR #define FAST_READ_INT8 defined #endif #endif #ifdef FAST_READ_INT8 let read_int8_unsafe s pos = let x1 = Netsys_xdr.s_read_int4_64_unsafe s pos in let x0 = Netsys_xdr.s_read_int4_64_unsafe s (pos+4) in Int64.logor (Int64.logand (Int64.of_int x0) 0xFFFF_FFFFL) (Int64.shift_left (Int64.of_int x1) 32) #else let read_int8_unsafe s pos = let n7 = Int64.of_int (Char.code (String.unsafe_get s pos)) in let x = Int64.shift_left n7 56 in let n6 = Int64.of_int (Char.code (String.unsafe_get s (pos+1))) in let x = Int64.logor x (Int64.shift_left n6 48) in let n5 = Int64.of_int (Char.code (String.unsafe_get s (pos+2))) in let x = Int64.logor x (Int64.shift_left n5 40) in let n4 = Int64.of_int (Char.code (String.unsafe_get s (pos+3))) in let x = Int64.logor x (Int64.shift_left n4 32) in let n3 = Int64.of_int (Char.code (String.unsafe_get s (pos+4))) in let x = Int64.logor x (Int64.shift_left n3 24) in let n2 = Int64.of_int (Char.code (String.unsafe_get s (pos+5))) in let x = Int64.logor x (Int64.shift_left n2 16) in let n1 = Int64.of_int (Char.code (String.unsafe_get s (pos+6))) in let x = Int64.logor x (Int64.shift_left n1 8) in let n0 = Int64.of_int (Char.code (String.unsafe_get s (pos+7))) in Int64.logor x n0 #endif let read_int8 s pos = if pos < 0 || pos + 8 > String.length s then raise Out_of_range; read_int8_unsafe s pos let read_uint4 = read_int4 let read_uint8 = read_int8 let read_uint4_unsafe = read_int4_unsafe let read_uint8_unsafe = read_int8_unsafe;; (**********************************************************************) (* write_[u]intn *) (**********************************************************************) #ifdef WORDSIZE_64 #ifdef USE_NETSYS_XDR let write_int4_unsafe = Netsys_xdr.s_write_int4_64_unsafe #else let write_int4_unsafe s pos x = let n3 = (x lsr 24) land 0xff in String.unsafe_set s pos (Char.unsafe_chr n3); let n2 = (x lsr 16) land 0xff in String.unsafe_set s (pos+1) (Char.unsafe_chr n2); let n1 = (x lsr 8) land 0xff in String.unsafe_set s (pos+2) (Char.unsafe_chr n1); let n0 = x land 0xff in String.unsafe_set s (pos+3) (Char.unsafe_chr n0); () #endif #else let write_int4_unsafe s pos x = let n3 = Int32.to_int (Int32.shift_right_logical x 24) land 0xff in String.unsafe_set s pos (Char.unsafe_chr n3); let n2 = Int32.to_int (Int32.shift_right_logical x 16) land 0xff in String.unsafe_set s (pos+1) (Char.unsafe_chr n2); let n1 = Int32.to_int (Int32.shift_right_logical x 8) land 0xff in String.unsafe_set s (pos+2) (Char.unsafe_chr n1); let n0 = Int32.to_int (Int32.logand x 0xffl) in String.unsafe_set s (pos+3) (Char.unsafe_chr n0); () #endif ;; let write_int4 s pos x = if pos < 0 || pos + 4 > String.length s then raise Out_of_range; write_int4_unsafe s pos x #ifdef WORDSIZE_64 #ifdef USE_NETSYS_XDR #define FAST_WRITE_INT8 defined #endif #endif #ifdef FAST_WRITE_INT8 let write_int8_unsafe s pos x = Netsys_xdr.s_write_int4_64_unsafe s pos (Int64.to_int (Int64.shift_right x 32)); Netsys_xdr.s_write_int4_64_unsafe s (pos+4) (Int64.to_int (Int64.logand x 0xFFFF_FFFFL)) #else let write_int8_unsafe s pos x = let n7 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 56) 0xffL) in String.unsafe_set s pos (Char.unsafe_chr n7); let n6 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 48) 0xffL) in String.unsafe_set s (pos+1) (Char.unsafe_chr n6); let n5 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 40) 0xffL) in String.unsafe_set s (pos+2) (Char.unsafe_chr n5); let n4 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 32) 0xffL) in String.unsafe_set s (pos+3) (Char.unsafe_chr n4); let n3 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 24) 0xffL) in String.unsafe_set s (pos+4) (Char.unsafe_chr n3); let n2 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 16) 0xffL) in String.unsafe_set s (pos+5) (Char.unsafe_chr n2); let n1 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 8) 0xffL) in String.unsafe_set s (pos+6) (Char.unsafe_chr n1); let n0 = Int64.to_int (Int64.logand x 0xffL) in String.unsafe_set s (pos+7) (Char.unsafe_chr n0); () #endif let write_int8 s pos x = if pos < 0 || pos + 8 > String.length s then raise Out_of_range; write_int8_unsafe s pos x let write_uint4 = write_int4 let write_uint8 = write_int8 let write_uint4_unsafe = write_int4_unsafe let write_uint8_unsafe = write_int8_unsafe (**********************************************************************) (* [u]intn_as_string *) (**********************************************************************) let int4_as_string x = let s = String.create 4 in write_int4 s 0 x; s let uint4_as_string x = let s = String.create 4 in write_uint4 s 0 x; s let int8_as_string x = let s = String.create 8 in write_int8 s 0 x; s let uint8_as_string x = let s = String.create 8 in write_int8 s 0 x; s (**********************************************************************) (* floating-point numbers *) (**********************************************************************) let fp4_as_string x = int4_as_string (int4_of_int32 x) let fp8_as_string x = int8_as_string (int8_of_int64 x) let read_fp4 s pos = int32_of_int4(read_int4 s pos) let read_fp8 s pos = int64_of_int8(read_int8 s pos) let write_fp4 s pos x = write_int4 s pos (int4_of_int32 x) let write_fp8 s pos x = write_int8 s pos (int8_of_int64 x) end module LE : ENCDEC = struct (**********************************************************************) (* read_[u]intn *) (**********************************************************************) #ifdef WORDSIZE_64 (* IFDEF USE_NETSYS_XDR THEN let read_int4_unsafe = Netsys_xdr.s_read_int4_64_unsafe (* FIXME *) ELSE *) let read_int4_unsafe s pos = let n3 = Char.code (String.unsafe_get s (pos+3)) in let x = (n3 lsl 55) asr 31 in (* sign! *) let n2 = Char.code (String.unsafe_get s (pos+2)) in let x = x lor (n2 lsl 16) in let n1 = Char.code (String.unsafe_get s (pos+1)) in let x = x lor (n1 lsl 8) in let n0 = Char.code (String.unsafe_get s pos) in x lor n0 (* END *) #else let read_int4_unsafe s pos = let n3 = Int32.of_int (Char.code (String.unsafe_get s (pos+3))) in let x = Int32.shift_left n3 24 in let n2 = Int32.of_int (Char.code (String.unsafe_get s (pos+2))) in let x = Int32.logor x (Int32.shift_left n2 16) in let n1 = Int32.of_int (Char.code (String.unsafe_get s (pos+1))) in let x = Int32.logor x (Int32.shift_left n1 8) in let n0 = Int32.of_int (Char.code (String.unsafe_get s pos)) in Int32.logor x n0 #endif let read_int4 s pos = if pos < 0 || pos + 4 > String.length s then raise Out_of_range; read_int4_unsafe s pos let read_int8_unsafe s pos = let n7 = Int64.of_int (Char.code (String.unsafe_get s (pos+7))) in let x = Int64.shift_left n7 56 in let n6 = Int64.of_int (Char.code (String.unsafe_get s (pos+6))) in let x = Int64.logor x (Int64.shift_left n6 48) in let n5 = Int64.of_int (Char.code (String.unsafe_get s (pos+5))) in let x = Int64.logor x (Int64.shift_left n5 40) in let n4 = Int64.of_int (Char.code (String.unsafe_get s (pos+4))) in let x = Int64.logor x (Int64.shift_left n4 32) in let n3 = Int64.of_int (Char.code (String.unsafe_get s (pos+3))) in let x = Int64.logor x (Int64.shift_left n3 24) in let n2 = Int64.of_int (Char.code (String.unsafe_get s (pos+2))) in let x = Int64.logor x (Int64.shift_left n2 16) in let n1 = Int64.of_int (Char.code (String.unsafe_get s (pos+1))) in let x = Int64.logor x (Int64.shift_left n1 8) in let n0 = Int64.of_int (Char.code (String.unsafe_get s pos)) in Int64.logor x n0 let read_int8 s pos = if pos < 0 || pos + 8 > String.length s then raise Out_of_range; read_int8_unsafe s pos let read_uint4 = read_int4 let read_uint8 = read_int8 let read_uint4_unsafe = read_int4_unsafe let read_uint8_unsafe = read_int8_unsafe;; (**********************************************************************) (* write_[u]intn *) (**********************************************************************) #ifdef WORDSIZE_64 (* IFDEF USE_NETSYS_XDR THEN let write_int4_unsafe = Netsys_xdr.s_write_int4_64_unsafe ELSE *) let write_int4_unsafe s pos x = let n3 = (x lsr 24) land 0xff in String.unsafe_set s (pos+3) (Char.unsafe_chr n3); let n2 = (x lsr 16) land 0xff in String.unsafe_set s (pos+2) (Char.unsafe_chr n2); let n1 = (x lsr 8) land 0xff in String.unsafe_set s (pos+1) (Char.unsafe_chr n1); let n0 = x land 0xff in String.unsafe_set s pos (Char.unsafe_chr n0); () (* END *) #else let write_int4_unsafe s pos x = let n3 = Int32.to_int (Int32.shift_right_logical x 24) land 0xff in String.unsafe_set s (pos+3) (Char.unsafe_chr n3); let n2 = Int32.to_int (Int32.shift_right_logical x 16) land 0xff in String.unsafe_set s (pos+2) (Char.unsafe_chr n2); let n1 = Int32.to_int (Int32.shift_right_logical x 8) land 0xff in String.unsafe_set s (pos+1) (Char.unsafe_chr n1); let n0 = Int32.to_int (Int32.logand x 0xffl) in String.unsafe_set s pos (Char.unsafe_chr n0); () #endif ;; let write_int4 s pos x = if pos < 0 || pos + 4 > String.length s then raise Out_of_range; write_int4_unsafe s pos x let write_int8_unsafe s pos x = let n7 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 56) 0xffL) in String.unsafe_set s (pos+7) (Char.unsafe_chr n7); let n6 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 48) 0xffL) in String.unsafe_set s (pos+6) (Char.unsafe_chr n6); let n5 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 40) 0xffL) in String.unsafe_set s (pos+5) (Char.unsafe_chr n5); let n4 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 32) 0xffL) in String.unsafe_set s (pos+4) (Char.unsafe_chr n4); let n3 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 24) 0xffL) in String.unsafe_set s (pos+3) (Char.unsafe_chr n3); let n2 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 16) 0xffL) in String.unsafe_set s (pos+2) (Char.unsafe_chr n2); let n1 = Int64.to_int (Int64.logand (Int64.shift_right_logical x 8) 0xffL) in String.unsafe_set s (pos+1) (Char.unsafe_chr n1); let n0 = Int64.to_int (Int64.logand x 0xffL) in String.unsafe_set s pos (Char.unsafe_chr n0); () let write_int8 s pos x = if pos < 0 || pos + 8 > String.length s then raise Out_of_range; write_int8_unsafe s pos x let write_uint4 = write_int4 let write_uint8 = write_int8 let write_uint4_unsafe = write_int4_unsafe let write_uint8_unsafe = write_int8_unsafe (**********************************************************************) (* [u]intn_as_string *) (**********************************************************************) let int4_as_string x = let s = String.create 4 in write_int4 s 0 x; s let uint4_as_string x = let s = String.create 4 in write_uint4 s 0 x; s let int8_as_string x = let s = String.create 8 in write_int8 s 0 x; s let uint8_as_string x = let s = String.create 8 in write_int8 s 0 x; s (**********************************************************************) (* floating-point numbers *) (**********************************************************************) let fp4_as_string x = int4_as_string (int4_of_int32 x) let fp8_as_string x = int8_as_string (int8_of_int64 x) let read_fp4 s pos = int32_of_int4(read_int4 s pos) let read_fp8 s pos = int64_of_int8(read_int8 s pos) let write_fp4 s pos x = write_int4 s pos (int4_of_int32 x) let write_fp8 s pos x = write_int8 s pos (int8_of_int64 x) end #ifdef HOST_IS_BIG_ENDIAN module HO = BE #else module HO = LE #endif ;; ocamlnet-4.0.4/src/netstring/nethtml_scanner.mll0000644000175000017500000000665012541553661020462 0ustar gerdgerd(* $Id: nethtml_scanner.mll 1219 2009-04-14 13:28:56Z ChriS $ * ---------------------------------------------------------------------- * *) { type token = Lcomment (* *) | Mcomment (* within comment *) | Ldoctype (* *) | Mdoctype (* within declaration *) | Lpi (* or > *) | Mpi (* within processing instruction *) | Lelement of string | Lelementend of string | Relement (* > *) | Relement_empty (* />, for XML compat *) | Cdata of string | Space of int | Name of string | Is | Literal of string | Other | Eof } (* Simplified rules: Only ASCII is recognized as character set *) let letter = ['A'-'Z' 'a'-'z' ] let digit = ['0'-'9'] let hexdigit = ['0'-'9' 'A'-'F' 'a'-'f'] let namechar = letter | digit | '.' | ':' | '-' | '_' let name = ( letter | '_' | ':' ) namechar* let nmtoken = namechar+ let ws = [ ' ' '\t' '\r' '\n' ] let string_literal1 = '"' [^ '"' ]* '"' let string_literal2 = "'" [^ '\'' ]* "'" let string_literal3 = [^ '"' '\'' '>' '=' ' ' '\t' '\n' '\r' ]+ let string_literal4 = [^ '"' '\'' '>' ' ' '\t' '\n' '\r' ]+ (* This following rules reflect HTML as it is used, not the SGML * rules. *) rule scan_document = parse | "" { Rcomment } (* FIXME: There may be any number of ws between -- and > *) | "-" { Mcomment } | eof { Eof } | [^ '-']+ { Mcomment } and scan_doctype = parse | ">" (* Occurence in strings, and [ ] brackets ignored *) { Rdoctype } | eof { Eof } | [^ '>' ] + { Mdoctype } and scan_pi = parse | "?>" { Rpi } | ">" { Rpi } | eof { Eof } | '?' { Mpi } | [^ '>' '?' ] + { Mpi } and scan_element = parse | ">" { Relement } | "/>" { Relement_empty } | ws+ { Space (String.length (Lexing.lexeme lexbuf)) } | name { Name (Lexing.lexeme lexbuf) } | "=" { Is } | '"' { Other } | "'" { Other } | string_literal3 { Literal (Lexing.lexeme lexbuf) } | eof { Eof } | _ { Other } and scan_element_after_Is = parse | ">" { Relement } | "/>" { Relement_empty } | ws+ { Space (String.length (Lexing.lexeme lexbuf)) } | '"' { try Literal (scan_string_literal1 lexbuf) with | _ -> Other } | "'" { try Literal (scan_string_literal2 lexbuf) with | _ -> Other } | string_literal4 { Literal (Lexing.lexeme lexbuf) } | eof { Eof } | _ { Other } and scan_string_literal1 = parse | ( [^ '"' ]* as s) '"' { s } and scan_string_literal2 = parse | ( [^ '\'' ]* as s) '\'' { s } ocamlnet-4.0.4/src/netstring/netmime_tut.txt0000644000175000017500000003646012541553661017665 0ustar gerdgerd{1:tutorial Netmime Tutorial} {2 Structure of Mail Messages} Nowadays mail messages are in MIME format. This format allows us to attach files to messages, and to encode the main text in markup languages like HTML. In principle, mail messages have only one header block (with fields like "Subject", sender and receiver addresses, etc.) and one body block. However, this is only one view on the mail format, e.g. as seen by MTAs (mail transfer agents). The MIME format adds the possibility to structure the body block into "parts" by additional encoding sequences. The MTAs can simply ignore this additional stuff, but software creating and analyzing mails can usually not. In [Netmime], one can control whether one wants to see the parts or not. Logically, the parts of the mail body are small mail messages themselves. This means that every part has again a header and a body. The header can, in principal, contain any number of fields, and any kind of field, but in practice only a small subset of the possible fields are used, in particular only those fields that are necessary to describe the body of the part. The body can be a normal text or data block, but it is explicitly also allowed that the body is again structured into a sequence of parts. Thus complex mail messages are recursive data structures (to be exact, they are trees). For example, a message with two attachments usually looks like: {[ (mail_header, mail_body) | +-- (main_text_header, main_text_body) +-- (att1_header, att1_body) +-- (att2_header, att2_body) ]} The headers contains two crucial fields that control the structure of the message: - The [Content-type] describes the kind of data found in the body, e.g. "text/html". When the [Content-type] has the major type "multipart" (e.g. "multipart/mixed"), the body is composed of subparts. For all other types, the body is a leaf of the message tree. (To be exact, there is another major type that opens a further dimension of "message-in-message" composition: "message". This type is usually used when it is not clear whether the inner message is syntactically correct. [Netmime] handles this type always as leaf, but users of [Netmime] can try to parse these inner messages themselves.) - The [Content-transfer-encoding] describes how the body data is encoded as ASCII text. It is usually only set for leaves. Recommended values are ["quoted-printable"] for bodies that contain some kind of ASCII text, and ["base64"] for binary data. {2 Messages in [Netmime]} In [Netmime], the types of mail headers and mail bodies are defined before and independent of their implementations: We have the types - [class type mime_header]: Specification of possible header implementations - [class type mime_body]: Specification of possible body implementations - [type complex_mime_message]: The type of a message tree and the implementations - [class basic_mime_header]: A basic header implementation - [class memory_mime_body]: A body implementation storing the contents in an O'Caml string in-memory - [class file_mime_body]: A second body implementation storing the contents in an external file Of course, the implementation classes fulfill the specifications of the corresponding class types. For completeness, there are also reduced read-only class types that maybe helpful for signatures to indicate that a function does not modify a header or body. In principal, one can also define further implementations provided they fit to the class types. The type [complex_mime_message] represents the message as a tree. We have: {[ type complex_mime_message = mime_header * complex_mime_body and complex_mime_body = [ `Body of mime_body | `Parts of complex_mime_message list ] ]} For example, the above mentioned mail with two attachments has the following representation: {[ let tree = (mail_header, `Parts [ (main_text_header, `Body main_text_body); (att1_header, `Body att1_body); (att2_header, `Body att2_body) ] ) ]} Here, [*_header] are objects of type [mime_header], and [*_body] are objects of type [mime_body]. It is obvious how to create the tree once one has these objects: Just use the syntax in this expression. Beginners of O'Caml should recall that it is as easy to decompose such structured values by using the pattern matching feature of the language. For example, to get the [main_text_header] of [tree], use {[ let main_text_header = match tree with (_, `Parts ( (mth, _) :: _ )) -> mth | _ -> failwith "Message has unexpected structure" ]} (Note that [ [x1;x2;...] ] is just an abbreviation for [ x1 :: x2 :: ... :: [] ]; by switching to the "::" syntax the message may have any number of parts in order to be matching.) At the first glance, it looks a bit strange to access the inner parts of mail messages in this way, but pattern matching is a very powerful sword once one gets accustomed to it. Another hint: Because [complex_mime_message] is a quite challanging type for the compiler, it is often necessary to give type annotations, such as [ (tree : complex_mime_message) ] before passing such values to functions, otherwise you get compiler errors. {2 Accessing Headers} It is easy to get and set the fields of headers, e.g. [ mail_header # field "subject" ] returns the "Subject" header field as string (or raises [Not_found]). The names of header fields are case-insensitive. To set a field, use [update_field], e.g. [ mail_header # update_field "subject" "Ocamlnet is great" ]. The methods [field] and [update_field] process the field value as unparsed string (the parsers do only very little preprocessing, e.g. one can configure to remove all linefeeds). The module {!Netmime_string} has a lot functions to parse and generate field values with a certain syntax. For example, "Subject" may contain so-called encoded words to express text written in a character set other than ASCII. To parse this, use {[ let subject = mail_header # field "subject" in let word_list = Netmime_string.scan_encoded_text_value subject in ]} Now, the words contained in [word_list] can be accessed with a number of functions, e.g. {[ let word_val = Netmime_string.get_decoded_word word in let word_cset = Netmime_string.get_charset word ]} Here, the string [word_val] is the word written in the character set [word_cset]. For example, for the "Subject" field [=?iso-8859-1?q?this=20is=20some=20text?=] this method returns a [word_list] with one word, and for this word [word_val = "this is some text"] and [word_cset = "iso-8859-1"]. To create such structured header values, there is the function [write_value] in {!Netmime_string}. This function requires some more background beyond the scope of this tutorial. As this function also supports folding of header fields, we explain only this particular application. Folding means that long header values must be split into several lines. There is a soft limit of 78 bytes and a hard limit of 998 bytes (not counting the end-of-line sequence). The soft limit only ensures that values can be displayed in usual terminals or windows without needing horizontal scrolling. Values exceeding the hard limit may be truncated in mail transport, however. To fold a string [s] composed of words, first split it into its [words], make atoms of them, format them with [write_value], and put the result into the header field (note: this example can be programmed better, see below): {[ let name = "Subject" in let words = Str.split (Str.regexp "[ \t]+") s in let atoms = List.map (fun w -> Netmime_string.Atom w) in let buf = Buffer.create 100 in let ch = new Netchannels.output_buffer buf in Netmime_string.write_value ~maxlen1:(78 - String.length name - 2) ~maxlen:78 ~hardmaxlen1:(998 - String.length name - 2) ~hardmaxlen:998 ch; mail_header # update_field name (Buffer.contents buf) ]} Unfortunately, there is no general method that can fold any kind of string. The problem is that folding is only allowed at certain places in the string, but this depends on the type of the header field. The shown method works only for informational texts like "Subject". For other fields, like "Received", the method would have to be varied, especially how the list [atoms] is determined. The syntax of the field must be known to compute [atoms]. In the module {!Netsendmail} you can find formatting and folding functions for informational texts like "Subject", and for mail addresses. With these functions, the "Subject" field could also be set by {[ let atoms = Netsendmail.create_text_tokens s in mail_header # update_field name (Netsendmail.format_field_value name atoms) ]} {2 Accessing Bodies} Both types of bodies (in-memory, and file) support the following two ways of accessing: - Get/set the value as O'Caml string - Read/write the value as object channel (see {!Netchannels}) Note that when the value of a file-based body is changed, the file is overwritten, independently of which of the two ways is taken. The [string] access is very simple: To get the value, just call [value]: [ let s = body # value ] To set the value, just call [set_value]: [ body # set_value s ] The string returned by [value] is not transfer-encoded, or better, all such encodings (e.g. BASE-64) are decoded. Of course, [set_value] expects that the passed string is not decoded, too. Note that using [value] may be dangerous (or even fail) when the body is stored in a file and is very large. [value] forces that the file is completely read into memory. You may run into serious problems when there is not enough memory, or when the value is larger than [Sys.max_string_length] (16MB on 32 bit platforms). Fortunately, there is the channel-based access method. It does not need much memory, even when large bodies are accessed. However, one does not get access to the completely body at once, but only chunk by chunk. For example, to read a body line by line, use: {[ let ch = body # open_value_rd() in let line1 = ch # input_line() in let line2 = ch # input_line() in ... ch # close_in() ]} As for [value], there are no transfer encodings in the returned lines. The channel [ch] can be used whereever an Ocamlnet function allows it, i.e. it is a full implementation. For example, one can pass it to the HTML parser: {[ let ch = body # open_value_rd() in let html_doc = Nethtml.parse ch in ch # close_in() ]} To set the value using a channel, a body can also be opened for writing: {[ let ch = body # open_value_wr() in ch # output_string "First line\n"; ch # output_string "Second line\n"; ... ch # close_out() ]} {2 Parsing mail messages} The message to parse must be available as an object channel. Recall that you can create an object channel from a string with [ let ch = new Netchannels.input_string s ] and from a file with [ let ch = new Netchannels.input_channel (open_in "filename") ] so one can parse mail messages coming from any source. As only sequential access is needed, it is even possible to read directly from a Unix pipe. Now, it is required to create a so-called netstream from [ch]: [ let nstr = new Netstream.input_stream ch ] A netstream is an object channel with additional look-ahead features. We need it here because the parser can then recognize certain patterns in the message in a simpler manner, for example the escape sequences separating the parts of a structured body. Finally, one can invoke the parser: [ let tree = Netmime_channels.read_mime_message nstr ] There are a number of optional arguments for this function that can modify the way the message tree is generated. By default, all bodies are created in memory, and the tree is deeply parsed (i.e. inner multipart bodies are represented in tree form). When bodies should be written to disk, the argument [storage_style] can be passed: It is a function that is called whenever a header has been parsed, but before the corresponding body. The function must return the body object for representation and the output channel connected to the body object. For example, to write the bodies into numbered files: {[ let n = ref 1 let ext_storage_style header = let body = new file_mime_body ("file" ^ string_of_int !n) in incr n; (body, body#open_out_wr()) let tree = read_mime_message ~storage_style:ext_storage_style nstr ]} There is also the auxiliary function [storage] to create such a storage style argument. The [header] can be used to generate the file name from it. Often, the [filename] argument of the [Content-disposition] field is the original file name before the attachment was appended to the mail message. To get this name: {[ let filename = try let disp, disp_params = header # content_disposition() in (* disp is usually "attachment", but we don't check *) List.assoc "filename" disp_params with Not_found -> ... (* No such paramater, use other method to gen filename *) ]} It is usually a good idea to check for dangerous characters in this name ("/", "..") before constructing the name of the disk file. A final remark: Don't forget to close [nstr] after parsing (this implicitly closes [ch]). {2 Creating Mail Messages} For simple applications, the {!Netsendmail} module has a {!Netsendmail.compose} function. It can create a mail message with attachments, and performs all the encoding details. This function is well explained in its module mli. Of course, you can also do this yourself: Create the required headers and bodies, and put them together to the resulting [tree]. Example: {[ let date = Netdate.mk_mail_date ~zone:Netdate.localzone (Unix.time()) in let mail_header = new basic_mime_header [ "MIME-version", "1.0"; "Subject", "Sample mail"; "To", "recipient\@domain.net"; "From", "sender\@domain.net"; "Date", date; "Content-type", "multipart/mixed" ] in let main_text_header = new basic_mime_header [ "Content-type", "text/plain;charset=ISO-8859-1"; "Content-transfer-encoding", "quoted-printable"; ] in let main_text_body = new memory_mime_body "Hello world!\nThis is a sample mail.\n" in let att_header = new basic_mime_header [ "Content-type", "image/jpeg"; "Content-transfer-encoding", "base64"; "Content-disposition", "inline;description=\"My photo\""; ] in let att_body = new file_mime_body "photo.jpeg" in let tree = (mail_header, `Parts [ (main_text_header, `Body main_text_body); (att_header, `Body att_body) ] ) ]} {2 Printing Mail Messages} In order to print [tree] to the object channel [ch], simply call [ Netmime_channels.write_mime_message ch tree ] Before invoking this function, ensure the following: - The [Content-type] field of all leaves should be set - The [Content-transfer-encoding] field of all leaves should be set (in doubt use "base64"; if missing, the default is "7bit" - probably not what you want) - The [Content-type] field of multipart nodes should be set (it defaults to "multipart/mixed" if missing) - The [Content-transfer-encoding] fields of multipart nodes should {b not} be set - this is done by the function If the [boundary] parameter is missing, the function will invent one; you don't need to deal with this. The MIME message is written according to the found transfer encodings and the multi-part boundaries. Don't forget to close [ch] after writing! ocamlnet-4.0.4/src/netstring/netmech_digest_sasl.ml0000644000175000017500000002010712541553661021117 0ustar gerdgerd(* $Id: netmech_digest_sasl.ml 2195 2015-01-01 12:23:39Z gerd $ *) (* Unit tests: tests/netstring/bench/test_netmech.ml *) open Netmech_digest open Printf (* For parsing the messages, we just reuse the Nethttp function for the www-authenticate HTTP header. *) let parse_message = Nethttp.Header.parse_quoted_parameters module DIGEST_MD5 : Netsys_sasl_types.SASL_MECHANISM = struct let mechanism_name = "DIGEST-MD5" let client_first = `No let server_sends_final_data = true let supports_authz = true let available() = true let profile = { ptype = `SASL; hash_functions = [ `MD5 ]; mutual = true; } type credentials = (string * string * (string * string) list) list type client_session = Netmech_digest.client_session type server_session = Netmech_digest.server_session let init_credentials l = (l:credentials) let server_state ss = ss.sstate let create_server_session ~lookup ~params () = let params = Netsys_sasl_util.preprocess_params "Netmech_digestmd5_sasl.create_server_session:" [ "realm"; "nonce"; "mutual"; "secure" ] params in let srealm = try Some(List.assoc "realm" params) with Not_found -> None in let nonce = try List.assoc "nonce" params with Not_found -> create_nonce() in (* NB. "mutual" is enabled anyway, so no check here *) { sstate = `Emit; srealm; snonce = nonce; sresponse = None; snextnc = 1; sstale = false; sprofile = profile; sutf8 = true; snosess = false; lookup } let server_configure_channel_binding ss cb_list = failwith "Netmech_digest_sasl.server_configure_channel_binding: \ not supported" let format_kv l = String.concat "," (List.map (fun (k,v) -> k ^ "=" ^ v) l) let server_emit_challenge ss = if ss.sstate <> `Emit then failwith "Netmech_digestmd5_sasl.server_emit_challenge: bad state"; match ss.sresponse with | None -> let l = server_emit_initial_challenge_kv ~quote:true ss in format_kv l | Some _ -> let l = server_emit_final_challenge_kv ~quote:true ss in format_kv l let server_process_response ss msg = try let msg_params = parse_message msg in server_process_response_kv ss msg_params "AUTHENTICATE" with | Failure _ -> (* from parse_message *) ss.sstate <- `Auth_error "parse error" let server_process_response_restart ss msg set_stale = if ss.sstate <> `OK then failwith "Netmech_digestmd5_sasl.server_process_response_restart: \ bad state"; try let msg_params = parse_message msg in server_process_response_restart_kv ss msg_params set_stale "AUTHENTICATE" with | Failure _ -> (* from parse_message *) ss.sstate <- `Auth_error "parse error"; raise Not_found let server_channel_binding ss = `None let server_stash_session ss = server_stash_session_i ss let server_resume_session ~lookup s = server_resume_session_i ~lookup s let server_session_id ss = Some ss.snonce let server_prop ss key = server_prop_i ss key let server_gssapi_props ss = raise Not_found let server_user_name ss = match ss.sresponse with | None -> raise Not_found | Some(rp,_,_) -> to_utf8 rp.r_utf8 rp.r_user let server_authz_name ss = match ss.sresponse with | None -> raise Not_found | Some(rp,_,_) -> match rp.r_authz with | None -> raise Not_found | Some authz -> authz let create_client_session ~user ~authz ~creds ~params () = let params = Netsys_sasl_util.preprocess_params "Netmech_digestmd5_sasl.create_client_session:" [ "digest-uri"; "realm"; "cnonce"; "mutual"; "secure" ] params in let pw = try Netsys_sasl_util.extract_password creds with Not_found -> failwith "Netmech_digestmd5_sasl.create_client_session: no password \ found in credentials" in (* NB. mutual auth is enabled anyway *) { cstate = `Wait; cresp = None; cprofile = profile; cmethod = "AUTHENTICATE"; cdigest_uri = (try List.assoc "digest-uri" params with Not_found -> "generic/generic"); crealm = (try Some(List.assoc "realm" params) with Not_found -> None); cuser = user; cauthz = authz; cpasswd = pw; cnonce = (try List.assoc "cnonce" params with Not_found -> create_nonce()); } let client_configure_channel_binding cs cb = if cb <> `None then failwith "Netmech_digestmd5_sasl.client_configure_channel_binding: \ not supported" let client_state cs = cs.cstate let client_channel_binding cs = `None let client_restart cs = if cs.cstate <> `OK then failwith "Netmech_digestmd5_sasl.client_restart: unfinished auth"; client_restart_i cs let client_process_challenge cs msg = (* This can either be the initial challenge or the final server message *) try let msg_params = parse_message msg in if List.exists (fun (k,_) -> String.lowercase k = "rspauth") msg_params then client_process_final_challenge_kv cs msg_params else client_process_initial_challenge_kv cs msg_params with | Failure _ -> (* from parse_message *) cs.cstate <- `Auth_error "parse error" let client_emit_response cs = if cs.cstate <> `Emit && cs.cstate <> `Stale then failwith "Netmech_digestmd5_sasl.client_emit_response: bad state"; let l = client_emit_response_kv ~quote:true cs in format_kv l let client_stash_session cs = client_stash_session_i cs let client_resume_session s = client_resume_session_i s let client_session_id cs = None let client_prop cs key = client_prop_i cs key let client_gssapi_props cs = raise Not_found let client_user_name cs = cs.cuser let client_authz_name cs = cs.cauthz end (* #use "topfind";; #require "netstring";; open Netmech_digestmd5_sasl.DIGEST_MD5;; let creds = init_credentials ["password", "secret", []];; let lookup _ _ = Some creds;; let s = create_server_session ~lookup ~params:["realm", "elwood.innosoft.com", false; "nonce", "OA6MG9tEQGm2hh",false] ();; let s1 = server_emit_challenge s;; let c = create_client_session ~user:"chris" ~authz:"" ~creds ~params:["digest-uri", "imap/elwood.innosoft.com", false; "cnonce", "OA6MHXh6VqTrRk", false ] ();; client_process_challenge c s1;; let c1 = client_emit_response c;; (* response=d388dad90d4bbd760a152321f2143af7 *) server_process_response s c1;; let s2 = server_emit_challenge s;; assert(server_state s = `OK);; assert(s2 = "rspauth=ea40f60335c427b5527b84dbabcdfffd");; client_process_challenge c s2;; assert(client_state c = `OK);; (* Reauth, short path: *) client_restart c;; let c2 = client_emit_response c;; (* nc=2 *) let stoo = create_server_session ~lookup ~params:["realm", "elwood.innosoft.com", false; ] ();; server_process_response stoo c2;; assert(server_state stoo = `Restart "OA6MG9tEQGm2hh");; (* Now the server looks into the cache, and finds s under this ID *) server_process_response_restart s c2 false;; assert(server_state s = `Emit);; let s3 = server_emit_challenge s;; assert(s3 = "rspauth=73dd7feae8e84a22b0ad1f92666954d0");; assert(server_state s = `OK);; client_process_challenge c s3;; assert(client_state c = `OK);; (* Reauth, long path: *) client_restart c;; let c2 = client_emit_response c;; (* nc=2 *) let stoo = create_server_session ~lookup ~params:["realm", "elwood.innosoft.com", false; ] ();; server_process_response stoo c2;; assert(server_state stoo = `Restart "OA6MG9tEQGm2hh");; server_process_response_restart s c2 true;; (* stale *) let s4 = server_emit_challenge s;; (* s4: new nonce, stale=true *) client_process_challenge c s4;; assert(client_state c = `Stale);; let c3 = client_emit_response c;; (* c3: new cnonce *) server_process_response s c3;; let s5 = server_emit_challenge s;; assert(server_state s = `OK);; client_process_challenge c s5;; assert(client_state c = `OK);; *) ocamlnet-4.0.4/src/netstring/netaccel_link.mli0000644000175000017500000000024112541553661020054 0ustar gerdgerd(* $Id: netaccel_link.mli 798 2004-07-08 22:11:07Z stolpmann $ *) (** Enables accelerator module [Netaccel] * * This module exists for technical reasons. *) ocamlnet-4.0.4/src/netstring/Makefile0000644000175000017500000000611712541553661016226 0ustar gerdgerdTOP_DIR=../.. OBJECTS = netconst.cmo netstring_str.cmo netbuffer.cmo netunichar.cmo \ netaux.cmo netchannels.cmo netchannels_crypto.cmo netsockaddr.cmo \ netdb.cmo netmappings_asn1.cmo netmappings.cmo netconversion.cmo \ netulex.cmo netencoding.cmo netstream.cmo netdate.cmo \ netmime_string.cmo \ nethtml_scanner.cmo nethtml.cmo \ neturl.cmo netsaslprep_data.cmo netsaslprep.cmo \ netaddress.cmo netcompression.cmo \ netmime.cmo netmime_header.cmo netmime_channels.cmo \ netsendmail.cmo nethttp.cmo \ netpagebuffer.cmo netfs.cmo netglob_lex.cmo netglob.cmo \ netauth.cmo netnumber.cmo netxdr_mstring.cmo netxdr.cmo \ netasn1.cmo netoid.cmo netdn.cmo netx509.cmo \ netascii_armor.cmo nettls_support.cmo \ netgssapi_support.cmo netgssapi_auth.cmo \ netmech_scram.cmo netmech_scram_gssapi.cmo netmech_scram_sasl.cmo \ netmech_plain_sasl.cmo netmech_crammd5_sasl.cmo \ netmech_digest.cmo netmech_digest_sasl.cmo \ netmech_digest_http.cmo netmech_gs2_sasl.cmo netmech_krb5_sasl.cmo \ netmech_spnego_http.cmo PKGNAME = netstring REQUIRES = $(REGEXP_PROVIDER_MAKE) bigarray INCLUDES += $(INC_NETSYS) INCLUDES += -I ../netstring-pcre OCAMLOPT_OPTIONS_FOR_netbuffer.ml = -inline 10 INSTALL_EXTRA_CMO = netstring_top \ netaccel_link INSTALL_EXTRA_CMX = netconversion \ netbuffer netnumber netxdr INSTALL_EXTRA = $(INSTALL_EXTRA_CMO:=.cmo) \ $(INSTALL_EXTRA_CMX:=.cmx) $(INSTALL_EXTRA_CMX:=.p.cmx) \ $(INSTALL_EXTRA_CMX:=.o) $(INSTALL_EXTRA_CMX:=.p.o) \ dllnetaccel_c.* DOBJECTS = netconversion.mli netchannels.mli netstream.mli netmime_string.mli \ netmime.mli netsendmail.mli neturl.mli netaddress.mli netbuffer.mli \ netmime_header.mli netmime_channels.mli \ netdate.mli netencoding.mli netulex.mli netaccel.mli \ netaccel_link.mli nethtml.mli netstring_str.mli \ netmappings.mli netaux.mli nethttp.mli netpagebuffer.mli \ netfs.mli netglob.mli netauth.mli netsockaddr.mli \ netnumber.mli netxdr_mstring.mli netxdr.mli \ netcompression.mli netunichar.mli netasn1.mli netoid.mli \ netdn.mli netx509.mli netascii_armor.mli nettls_support.mli \ netmech_scram.mli netmech_scram_gssapi.mli netmech_scram_sasl.mli \ netgssapi_support.mli netgssapi_auth.mli netchannels_crypto.mli \ netsaslprep.mli \ netmech_plain_sasl.mli netmech_crammd5_sasl.mli \ netmech_digest_sasl.mli netmech_digest_http.mli \ netmech_krb5_sasl.mli netmech_gs2_sasl.mli netmech_spnego_http.mli \ netchannels_tut.txt netmime_tut.txt netsendmail_tut.txt \ netulex_tut.txt neturl_tut.txt PP_OPTIONS = -pp "$(CPPO) $(NETNUMBER_DEFS) $(REGEXP_DEFS)" ALL_EXTRA = netaccel.cma netaccel_link.cmo netstring_top.cmo netaccel.cma: netaccel_c.o netaccel.cmo $(OCAMLMKLIB) -o netaccel -oc netaccel_c netaccel_c.o netaccel.cmo NETNUMBER_DEFS = -D WORDSIZE_$(WORD_SIZE) -D HOST_IS_$(ENDIANESS) \ -D USE_NETSYS_XDR OCAMLOPT_OPTIONS_FOR_netnumber.ml = -inline 10 OCAMLOPT_OPTIONS_FOR_xdr.ml = -inline 5 OCAMLC_OPTIONS_FOR_netstring_top.ml = -I +compiler-libs include $(TOP_DIR)/Makefile.rules distclean:: $(MAKE) clean include depend ocamlnet-4.0.4/src/netstring/netmech_scram.ml0000644000175000017500000014041112541553661017724 0ustar gerdgerd(* $Id: netmech_scram.ml 2195 2015-01-01 12:23:39Z gerd $ *) (* Steps: client <-> server ---------------------------------------------------------------------- username, nonce -> <- salt, i, nonce' clientproof, nonce' -> (=algo(password, salt, i)) <- serversignature *) open Printf type ptype = [ `GSSAPI | `SASL | `HTTP ] type profile = { ptype : ptype; hash_function : Netsys_digests.iana_hash_fn; return_unknown_user : bool; iteration_count_limit : int; } type credentials = [ `Salted_password of string * string * int | `Stored_creds of string * string * string * int ] type cb = Netsys_sasl_types.cb type gs2_header = { gs2_cb : cb; gs2_authzname : string option } type client_first = (* actually client_first_bare *) { c1_username : string; (* "=xx" encoding not yet applied *) c1_gs2 : gs2_header; c1_nonce : string; (* anything but comma *) c1_extensions : (string * string) list } type server_first = { s1_nonce : string; (* anything but comma *) s1_salt : string; (* decoded *) s1_iteration_count : int; s1_extensions : (string * string) list } type client_final = { cf_gs2 : gs2_header; cf_nonce : string; (* anything but comma *) cf_extensions : (string * string) list; cf_proof : string option; (* decoded *) } type server_error = [ `Invalid_encoding | `Extensions_not_supported | `Invalid_proof | `Channel_bindings_dont_match | `Server_does_support_channel_binding | `Channel_binding_not_supported | `Unsupported_channel_binding_type | `Unknown_user | `Invalid_username_encoding | `No_resources | `Other_error | `Extension of string ] type server_error_or_verifier = [ `Error of server_error | `Verifier of string ] type server_final = { sf_error_or_verifier : server_error_or_verifier; sf_extensions : (string * string) list; } type specific_keys = { kc : string; ke : string; ki : string } type client_session = { cs_profile : profile; mutable cs_state : [ `Start | `C1 | `S1 | `CF | `SF | `Connected | `Error ]; mutable cs_c1 : client_first option; mutable cs_s1 : server_first option; mutable cs_s1_raw : string; mutable cs_cf : client_final option; mutable cs_sf : server_final option; mutable cs_salted_pw : string; mutable cs_auth_message : string; mutable cs_proto_key : string option; cs_username : string; cs_authzname : string; cs_password : string; cs_nonce : string option; mutable cs_cb : cb; } type server_session = { ss_profile : profile; mutable ss_state : [ `Start | `C1 | `S1 | `CF | `SF | `Connected | `Error ]; mutable ss_c1 : client_first option; mutable ss_c1_raw : string; mutable ss_s1 : server_first option; mutable ss_s1_raw : string; mutable ss_cf : client_final option; mutable ss_cf_raw : string; mutable ss_sf : server_final option; mutable ss_creds: (string * string) option; mutable ss_err : server_error option; mutable ss_proto_key : string option; ss_nonce : string option; ss_authenticate_opt : (string -> string -> credentials) option } (* Exported: *) exception Invalid_encoding of string * string exception Invalid_username_encoding of string * string exception Extensions_not_supported of string * string exception Protocol_error of string exception Invalid_server_signature exception Server_error of server_error (* Not exported: *) exception Invalid_proof of string module Debug = struct let enable = ref false end let dlog = Netlog.Debug.mk_dlog "Netmech_scram" Debug.enable let dlogr = Netlog.Debug.mk_dlogr "Netmech_scram" Debug.enable let () = Netlog.Debug.register_module "Netmech_scram" Debug.enable let profile ?(return_unknown_user=false) ?(iteration_count_limit=100000) pt h = { ptype = pt; hash_function = h; return_unknown_user = return_unknown_user; iteration_count_limit = iteration_count_limit; } let mechanism_name p = let iana_name = List.assoc p.hash_function Netsys_digests.iana_rev_alist in let uc = String.uppercase iana_name in "SCRAM-" ^ uc let saslprep s = (* We don't call SASLprep here, but leave this to the users. Only check for valid UTF-8. *) try Netconversion.verify `Enc_utf8 s; s with | _ -> raise(Invalid_encoding("Invalid UTF-8", s)) let username_saslprep s = try saslprep s with | Invalid_encoding(s1,s2) -> raise(Invalid_username_encoding(s1,s2)) let comma_re = Netstring_str.regexp "," let comma_split s = Netstring_str.split_delim comma_re s let n_value_re = Netstring_str.regexp "\\([a-zA-Z]\\)=\\(.*\\)" let n_value_split s = match Netstring_str.string_match n_value_re s 0 with | None -> raise (Invalid_encoding("n_value_split", s)) | Some r -> (Netstring_str.matched_group r 1 s, Netstring_str.matched_group r 2 s) let check_value_safe_chars s = let enc = `Enc_subset(`Enc_utf8, fun i -> i <> 0 && i <> 0x2c && i <> 0x3d) in try Netconversion.verify enc s with _ -> raise(Invalid_encoding("check_value_safe_chars",s)) let check_value_chars s = let enc = `Enc_subset(`Enc_utf8, fun i -> i <> 0 && i <> 0x2c) in try Netconversion.verify enc s with _ -> raise(Invalid_encoding("check_value_chars",s)) let check_printable s = for i = 0 to String.length s - 1 do match s.[i] with | '\x21'..'\x2b' -> () | '\x2d'..'\x7e' -> () | _ -> raise(Invalid_encoding("check_printable",s)) done let pos_re = Netstring_str.regexp "[1-9][0-9]+$" let check_positive_number s = match Netstring_str.string_match pos_re s 0 with | None -> raise(Invalid_encoding("check_positive_number",s)) | Some _ -> () let encode_saslname s = try Netgssapi_support.gs2_encode_saslname s with | Failure _ -> raise(Invalid_username_encoding("encode_saslname",s)) let decode_saslname s = try Netgssapi_support.gs2_decode_saslname s with | Failure _ -> raise(Invalid_username_encoding("decode_saslname",s)) let encode_gs2_sasl gs2 = (match gs2.gs2_cb with | `None -> "n" | `SASL_none_but_advertise -> "y" | `SASL_require(v,_) -> "p=" ^ v | `GSSAPI _ -> assert false ) ^ (match gs2.gs2_authzname with | None | Some "" -> "," | Some name -> ",a=" ^ encode_saslname name (* RFC 4422 does not allow SASLprep for the auth string *) ) ^ "," let encode_gs2_http gs2 = (match gs2.gs2_cb with | `None -> "n" | `SASL_none_but_advertise -> "y" | `SASL_require(v,_) -> "p=" ^ v | `GSSAPI _ -> assert false ) ^ "," let encode_gs2 ptype gs2 = match ptype with | `SASL -> encode_gs2_sasl gs2 | `HTTP -> "g=" ^ encode_gs2_http gs2 | `GSSAPI -> assert false let encode_cbind_input ptype gs2 = ( match ptype with | `SASL -> encode_gs2_sasl gs2 | `HTTP -> encode_gs2_http gs2 | `GSSAPI -> "" ) ^ ( match gs2.gs2_cb with | `SASL_require(_,data) -> data | _ -> "" ) let gs2_sasl_re = Netstring_str.regexp "\\(y\\|n\\|p=[^,]*\\),\\(a=[^,]*\\)?," let gs2_http_re = Netstring_str.regexp "\\(y\\|n\\|p=[^,]*\\)," let decode_gs2 ?(cb_includes_data=false) ptype s = let re, has_authz = match ptype with | `SASL -> gs2_sasl_re, true | `HTTP -> gs2_http_re, false | `GSSAPI -> assert false in match Netstring_str.string_match re s 0 with | Some m -> let m_end = Netstring_str.match_end m in let rest = String.sub s m_end (String.length s - m_end) in let cb = Netstring_str.matched_group m 1 s in let gs2_cb = if cb = "n" then `None else if cb = "y" then `SASL_none_but_advertise else ( let (n,v) = n_value_split cb in if n <> "p" then raise(Invalid_encoding("decode_gs2 [1]", s)); let data = if cb_includes_data then rest else "" in `SASL_require(v, data) ) in let authzname = if has_authz then try Netstring_str.matched_group m 2 s with Not_found -> "" else "" in let gs2_authzname = if authzname = "" then None else ( let (authzname_n, authzname_v) = n_value_split authzname in if authzname_n <> "a" then raise(Invalid_encoding("decode_gs2 [2]", s)); let authzname_v = decode_saslname authzname_v in (* No SASLprep. RFC 4422 is very clear that the auth string can use any Unicode chars. *) Some authzname_v ) in let gs2 = { gs2_cb; gs2_authzname } in (gs2, rest) | _ -> raise(Invalid_encoding("decode_gs2", s)) let remove_gs2 ptype s = match ptype with | `GSSAPI -> s | `SASL -> snd(decode_gs2 ptype s) | `HTTP -> if String.length s < 2 || s.[0] <> 'g' || s.[1] <> '=' then raise(Invalid_encoding("decode_c1_message",s)); let s1 = String.sub s 2 (String.length s - 2) in snd(decode_gs2 ptype s1) let encode_c1_message ptype c1 = let gs2_header = match ptype with | `SASL -> Some(encode_gs2 ptype c1.c1_gs2) | `HTTP -> let g = encode_gs2 ptype c1.c1_gs2 in Some("g=" ^ g) | `GSSAPI -> None in (gs2_header, [ "n", encode_saslname(username_saslprep c1.c1_username); "r", c1.c1_nonce; ] @ c1.c1_extensions ) let format_msg l = String.concat "," (List.map (fun (n,v) -> n ^ "=" ^ v) l) let format_client_msg (gs2_opt,l) = (match gs2_opt with | None -> "" | Some gs2_header -> gs2_header ) ^ format_msg l let decode_c1_message_after_gs2 s l gs2_header = match l with | [] -> raise(Invalid_encoding("decode_c1_mesage: empty", s)) | ("m",_) :: _ -> raise(Extensions_not_supported("decode_c1_mesage: unsupported", s)) | ("n", username_raw) :: ("r", nonce) :: l' -> let username = decode_saslname username_raw in let username' = username_saslprep username in if username <> username' then raise(Invalid_username_encoding("Netmech_scram.decode_c1_message", s)); { c1_username = username; c1_gs2 = gs2_header; c1_nonce = nonce; c1_extensions = l' } | _ -> raise(Invalid_encoding("decode_c1_mesage", s)) let decode_c1_message ptype s = match ptype with | `GSSAPI -> let l1 = comma_split s in let l2 = List.map n_value_split l1 in let gs2 = { gs2_authzname = None; gs2_cb = `None } in decode_c1_message_after_gs2 s l2 gs2 | `SASL -> let (gs2, rest) = decode_gs2 ptype s in let l1 = comma_split rest in let l2 = List.map n_value_split l1 in decode_c1_message_after_gs2 s l2 gs2 | `HTTP -> if String.length s < 2 || s.[0] <> 'g' || s.[1] <> '=' then raise(Invalid_encoding("decode_c1_message",s)); let s1 = String.sub s 2 (String.length s - 2) in let (gs2, rest) = decode_gs2 ptype s1 in let l1 = comma_split rest in let l2 = List.map n_value_split l1 in decode_c1_message_after_gs2 s l2 gs2 let encode_s1_message s1 = [ "r", s1.s1_nonce; "s", Netencoding.Base64.encode s1.s1_salt; "i", string_of_int s1.s1_iteration_count; ] @ s1.s1_extensions let decode_s1_message s = let l = List.map n_value_split (comma_split s) in match l with | [] -> raise(Invalid_encoding("decode_s1_mesage: empty", s)) | ("m",_) :: _ -> raise(Extensions_not_supported("decode_s1_mesage: unsupported", s)) | ("r",nonce) :: ("s",salt_b64) :: ("i",icount_raw) :: l' -> let salt = try Netencoding.Base64.decode salt_b64 with _ -> raise(Invalid_encoding("decode_s1_message: invalid s", s)) in check_positive_number icount_raw; let icount = try int_of_string icount_raw with _ -> raise(Invalid_encoding("decode_s1_message: invalid i", s)) in { s1_nonce = nonce; s1_salt = salt; s1_iteration_count = icount; s1_extensions = l' } | _ -> raise(Invalid_encoding("decode_s1_mesage", s)) (* About the inclusion of "c": RFC 5802 is not entirely clear about this. I asked the authors of the RFC what to do. The idea is that the GSS-API flavor of SCRAM is obtained by removing the GS2 (RFC 5801) part from the description in RFC 5802 for SASL. This leads to the interpretation that the "c" parameter is required, and it includes the channel binding string as-is, without any prefixed gs2-header. (Remember that GS2 is a wrapper around GSS-API, and it can then pass the right channel binding string down, i.e. a string that includes the gs2-header.) *) let encode_cf_message ptype cf = let cbind_input = encode_cbind_input ptype cf.cf_gs2 in [ "c", Netencoding.Base64.encode cbind_input; "r", cf.cf_nonce; ] @ cf.cf_extensions @ ( match cf.cf_proof with | None -> [] | Some p -> [ "p", Netencoding.Base64.encode p ] ) let decode_cf_message ptype expect_proof s = let l = List.map n_value_split (comma_split s) in match l with | [] -> raise(Invalid_encoding("decode_cf_mesage: empty", s)) | ("c",chanbind_b64) :: ("r",nonce) :: l' -> let chanbind = try Netencoding.Base64.decode chanbind_b64 with _ -> raise(Invalid_encoding("decode_cf_mesage: invalid c", s)) in let cf_gs2 = match ptype with | `GSSAPI -> { gs2_authzname = None; gs2_cb = `GSSAPI chanbind } | `SASL | `HTTP -> let gs2,_ = decode_gs2 ~cb_includes_data:true ptype chanbind in gs2 in let p, l'' = if expect_proof then match List.rev l' with | ("p", proof_b64) :: l''_rev -> let p = try Netencoding.Base64.decode proof_b64 with _ -> raise(Invalid_encoding("decode_cf_mesage: invalid p", s)) in (Some p, List.rev l''_rev) | _ -> raise(Invalid_encoding("decode_cf_mesage: proof not found", s)) else None, l' in { cf_gs2; cf_nonce = nonce; cf_extensions = l''; cf_proof = p } | _ -> raise(Invalid_encoding("decode_cf_mesage", s)) let strip_cf_proof s = let l = List.rev (List.map n_value_split (comma_split s)) in match l with | ("p",_) :: l' -> String.concat "," (List.map (fun (n,v) -> n ^ "=" ^ v) (List.rev l')) | _ -> assert false let string_of_server_error = function | `Invalid_encoding -> "invalid-encoding" | `Extensions_not_supported -> "extensions-not-supported" | `Invalid_proof -> "invalid-proof" | `Channel_bindings_dont_match -> "channel-bindings-dont-match" | `Server_does_support_channel_binding -> "server-does-support-channel-binding" | `Channel_binding_not_supported -> "channel-binding-not-supported" | `Unsupported_channel_binding_type -> "unsupported-channel-binding-type" | `Unknown_user -> "unknown-user" | `Invalid_username_encoding -> "invalid-username-encoding" | `No_resources -> "no-resources" | `Other_error -> "other-error" | `Extension s -> s let server_error_of_string = function | "invalid-encoding" -> `Invalid_encoding | "extensions-not-supported" -> `Extensions_not_supported | "invalid-proof" -> `Invalid_proof | "channel-bindings-dont-match" -> `Channel_bindings_dont_match | "server-does-support-channel-binding" -> `Server_does_support_channel_binding | "channel-binding-not-supported" -> `Channel_binding_not_supported | "unsupported-channel-binding-type" -> `Unsupported_channel_binding_type | "unknown-user" -> `Unknown_user | "invalid-username-encoding" -> `Invalid_username_encoding | "no-resources" -> `No_resources | "other-error" -> `Other_error | s -> `Extension s let () = Netexn.register_printer (Server_error `Invalid_encoding) (fun e -> match e with | Server_error token -> sprintf "Server_error(%s)" (string_of_server_error token) | _ -> assert false ) let encode_sf_message sf = ( match sf.sf_error_or_verifier with | `Error e -> [ "e", string_of_server_error e ] | `Verifier v -> [ "v", Netencoding.Base64.encode v ] ) @ sf.sf_extensions let decode_sf_message s = let l = List.map n_value_split (comma_split s) in match l with | [] -> raise(Invalid_encoding("decode_cf_mesage: empty", s)) | ("v",verf_raw) :: l' -> let verf = try Netencoding.Base64.decode verf_raw with _ -> raise(Invalid_encoding("decode_sf_message: invalid v", s)) in { sf_error_or_verifier = `Verifier verf; sf_extensions = l' } | ("e",error_s) :: l' -> let error = server_error_of_string error_s in { sf_error_or_verifier = `Error error; sf_extensions = l' } | _ -> raise(Invalid_encoding("decode_sf_mesage", s)) let hash h = try Netsys_digests.iana_find h with Not_found -> let name = List.assoc h Netsys_digests.name_rev_alist in failwith ("Netmech_scram: cannot find digest " ^ name ^ ". Is the crypto support initialized?") let hash_string h s = let dg = hash h in Netsys_digests.digest_string dg s let hmac h key = Netsys_digests.hmac (hash h) key let hmac_string h key str = let dg = hmac h key in Netsys_digests.digest_string dg str let hmac_mstrings h key ms_list = let dg = hmac h key in Netsys_digests.digest_mstrings dg ms_list let int_s i = let s = String.make 4 '\000' in s.[0] <- Char.chr ((i lsr 24) land 0xff); s.[1] <- Char.chr ((i lsr 16) land 0xff); s.[2] <- Char.chr ((i lsr 8) land 0xff); s.[3] <- Char.chr (i land 0xff); s let hi h str salt i = let rec uk k = if k=1 then let u = hmac_string h str (salt ^ int_s 1) in let h = u in (u,h) else ( let (u_pred, h_pred) = uk (k-1) in let u = hmac_string h str u_pred in let h = Netauth.xor_s u h_pred in (u,h) ) in snd (uk i) let lsb128 s = (* The least-significant 128 bits *) let l = String.length s in if l < 16 then failwith "Netmech_scram.lsb128"; String.sub s (l-16) 16 let create_random() = let s = String.make 16 ' ' in Netsys_rng.fill_random s; Digest.to_hex s let create_nonce() = create_random() let create_salt() = create_random() let create_client_session2 ?nonce profile username authzname password = ignore(saslprep username); ignore(saslprep authzname); ignore(saslprep password); (* Check for errors *) { cs_profile = profile; cs_state = `Start; cs_c1 = None; cs_s1 = None; cs_s1_raw = ""; cs_cf = None; cs_sf = None; cs_auth_message = ""; cs_salted_pw = ""; cs_username = username; cs_authzname = authzname; cs_password = password; cs_proto_key = None; cs_cb = `None; cs_nonce = nonce; } let create_client_session ?nonce profile username password = create_client_session2 ?nonce profile username "" password let client_emit_flag cs = match cs.cs_state with | `Start | `S1 -> true | _ -> false let client_recv_flag cs = match cs.cs_state with | `C1 | `CF -> true | _ -> false let client_finish_flag cs = cs.cs_state = `Connected let client_error_flag cs = cs.cs_state = `Error let catch_error cs f arg = try f arg with | error -> dlog (sprintf "Client caught error: %s" (Netexn.to_string error)); cs.cs_state <- `Error; raise error let client_protocol_key cs = cs.cs_proto_key let client_user_name cs = cs.cs_username let client_authz_name cs = cs.cs_authzname let client_password cs = cs.cs_password let client_configure_channel_binding cs cb = ( match cs.cs_state with | `Start | `C1 | `S1 -> () | _ -> failwith "Netmech_scram.client_configure_channel_binding" ); ( match cs.cs_profile.ptype, cb with | _, `None -> () | `GSSAPI, `GSSAPI _ -> () | (`SASL | `HTTP), (`SASL_none_but_advertise | `SASL_require _) -> () | _ -> failwith "Netmech_scram.client_configure_channel_binding" ); cs.cs_cb <- cb let client_channel_binding cs = cs.cs_cb let client_export cs = Marshal.to_string cs [] let client_import s = ( Marshal.from_string s 0 : client_session) let client_prop cs key = match key with | "snonce" -> ( match cs.cs_s1 with | None -> raise Not_found | Some s1 -> s1.s1_nonce ) | "cnonce" -> ( match cs.cs_c1 with | None -> raise Not_found | Some c1 -> c1.c1_nonce ) | "salt" -> ( match cs.cs_s1 with | None -> raise Not_found | Some s1 -> s1.s1_salt ) | "i" -> ( match cs.cs_s1 with | None -> raise Not_found | Some s1 -> string_of_int s1.s1_iteration_count ) | "protocol_key" -> ( match client_protocol_key cs with | None -> raise Not_found | Some key -> key ) | _ -> raise Not_found let salt_password h password salt iteration_count = let sp = hi h (saslprep password) salt iteration_count in (* eprintf "salt_password(%S,%S,%d) = %S\n" password salt iteration_count sp; *) sp let stored_key h password salt iteration_count = let salted_pw = salt_password h password salt iteration_count in let client_key = hmac_string h salted_pw "Client Key" in let stored_key = hash_string h client_key in let server_key = hmac_string h salted_pw "Server Key" in (stored_key, server_key) let client_emit_message_kv cs = let p = cs.cs_profile in let h = p.hash_function in let gs2 = { gs2_authzname = Some cs.cs_authzname; gs2_cb = cs.cs_cb } in catch_error cs (fun () -> match cs.cs_state with | `Start -> let c1 = { c1_username = cs.cs_username; c1_gs2 = gs2; c1_nonce = ( match cs.cs_nonce with | Some n -> n | None -> create_nonce() ); c1_extensions = [] } in cs.cs_c1 <- Some c1; cs.cs_state <- `C1; let (gs2_opt,m) = encode_c1_message p.ptype c1 in dlogr (fun () -> let ms = format_client_msg (gs2_opt,m) in sprintf "Client state `Start emitting message: %s" ms ); (gs2_opt,m) | `S1 -> let c1 = match cs.cs_c1 with None -> assert false | Some c1 -> c1 in let s1 = match cs.cs_s1 with None -> assert false | Some s1 -> s1 in let salted_pw = salt_password h cs.cs_password s1.s1_salt s1.s1_iteration_count in let client_key = hmac_string h salted_pw "Client Key" in let stored_key = hash_string h client_key in let cf_no_proof = format_msg (encode_cf_message p.ptype { cf_gs2 = gs2; cf_nonce = s1.s1_nonce; cf_extensions = []; cf_proof = None } ) in let c1_str = format_client_msg (None, snd (encode_c1_message p.ptype c1)) in let auth_message = c1_str ^ "," ^ cs.cs_s1_raw ^ "," ^ cf_no_proof in dlogr (fun () -> "Client auth_message: " ^ auth_message); let client_signature = hmac_string h stored_key auth_message in let proof = Netauth.xor_s client_key client_signature in let cf = { cf_gs2 = gs2; cf_nonce = s1.s1_nonce; cf_extensions = []; cf_proof = Some proof; } in cs.cs_cf <- Some cf; cs.cs_state <- `CF; cs.cs_auth_message <- auth_message; cs.cs_salted_pw <- salted_pw; cs.cs_proto_key <- Some ( lsb128 (hmac_string h stored_key ("GSS-API session key" ^ client_key ^ auth_message))); let m = encode_cf_message p.ptype cf in dlogr (fun () -> let ms = format_msg m in sprintf "Client state `S1 emitting message: %s" ms ); (None,m) | _ -> failwith "Netmech_scram.client_emit_message" ) () let client_emit_message cs = let (gs2_opt,m) = client_emit_message_kv cs in format_client_msg (gs2_opt,m) let client_recv_message cs message = let p = cs.cs_profile in let h = p.hash_function in catch_error cs (fun () -> match cs.cs_state with | `C1 -> dlog (sprintf "Client state `C1 receiving message: %s" message); let s1 = decode_s1_message message in let c1 = match cs.cs_c1 with None -> assert false | Some c1 -> c1 in if String.length s1.s1_nonce < String.length c1.c1_nonce then raise (Protocol_error "client_recv_message: Nonce from the server is too short"); if String.sub s1.s1_nonce 0 (String.length c1.c1_nonce) <> c1.c1_nonce then raise (Protocol_error "client_recv_message: bad nonce from the server"); if s1.s1_iteration_count > cs.cs_profile.iteration_count_limit then raise (Protocol_error "client_recv_message: iteration count too high"); cs.cs_state <- `S1; cs.cs_s1 <- Some s1; cs.cs_s1_raw <- message | `CF -> dlog (sprintf "Client state `CF receiving message: %s" message); let sf = decode_sf_message message in ( match sf.sf_error_or_verifier with | `Verifier v -> let salted_pw = cs.cs_salted_pw in let server_key = hmac_string h salted_pw "Server Key" in let server_signature = hmac_string h server_key cs.cs_auth_message in if v <> server_signature then raise Invalid_server_signature; cs.cs_state <- `Connected; dlog "Client is authenticated" | `Error e -> cs.cs_state <- `Error; dlog (sprintf "Client got error token from server: %s" (string_of_server_error e)); raise(Server_error e) ) | _ -> failwith "Netmech_scram.client_recv_message" ) () let create_server_session2 ?nonce profile auth = (* auth: called as: let (salted_pw, salt, i) = auth username *) { ss_profile = profile; ss_state = `Start; ss_c1 = None; ss_c1_raw = ""; ss_s1 = None; ss_s1_raw = ""; ss_cf = None; ss_cf_raw = ""; ss_sf = None; ss_authenticate_opt = Some auth; ss_creds = None; ss_err = None; ss_nonce = nonce; ss_proto_key = None; } let create_server_session ?nonce profile auth = create_server_session2 ?nonce profile (fun username _ -> auth username) let server_emit_flag ss = match ss.ss_state with | `C1 | `CF -> true | _ -> false let server_recv_flag ss = match ss.ss_state with | `Start | `S1 -> true | _ -> false let server_finish_flag ss = ss.ss_state = `Connected let server_error_flag ss = ss.ss_state = `Error let server_protocol_key ss = ss.ss_proto_key let server_export ss = Marshal.to_string { ss with ss_authenticate_opt = None } [] let server_import s = let ss = ( Marshal.from_string s 0 : server_session) in if ss.ss_state <> `Connected then failwith "Netmech_scram.server_import: session not finished"; ss let server_import_any2 s auth = let ss = ( Marshal.from_string s 0 : server_session) in { ss with ss_authenticate_opt = Some auth } let server_import_any s auth = server_import_any2 s (fun username _ -> auth username) let catch_condition ss f arg = let debug e = dlog (sprintf "Server caught error: %s" (Netexn.to_string e)) in try f arg with (* After such an error the protocol will continue, but the final server message will return the condition *) | Invalid_encoding(_,_) as e -> debug e; if ss.ss_err = None then ss.ss_err <- Some `Invalid_encoding | Invalid_username_encoding _ as e -> debug e; if ss.ss_err = None then ss.ss_err <- Some `Invalid_username_encoding | Extensions_not_supported(_,_) as e -> debug e; if ss.ss_err = None then ss.ss_err <- Some `Extensions_not_supported | Invalid_proof _ as e -> debug e; if ss.ss_err = None then ss.ss_err <- Some `Invalid_proof exception Skip_proto let server_emit_message_kv ss = let p = ss.ss_profile in let h = p.hash_function in match ss.ss_state with | `C1 -> let m = try let c1 = match ss.ss_c1 with | None -> raise Skip_proto | Some c1 -> c1 in let creds = match ss.ss_authenticate_opt with | Some auth -> let authzname = match c1.c1_gs2.gs2_authzname with | None -> c1.c1_username | Some n -> n in auth c1.c1_username authzname | None -> assert false in let (stkey,srvkey,salt, i) = match creds with | `Salted_password(spw,salt,i) -> let srvkey = hmac_string h spw "Server Key" in let client_key = hmac_string h spw "Client Key" in let stored_key = hash_string h client_key in (stored_key,srvkey,salt,i) | `Stored_creds(stkey,srvkey,salt,i) -> (stkey,srvkey,salt,i) in let nonce = match ss.ss_nonce with | None -> create_nonce() | Some n -> n in let s1 = { s1_nonce = c1.c1_nonce ^ nonce; s1_salt = salt; s1_iteration_count = i; s1_extensions = [] } in ss.ss_state <- `S1; ss.ss_s1 <- Some s1; ss.ss_creds <- Some(stkey,srvkey); let s1 = encode_s1_message s1 in ss.ss_s1_raw <- format_msg s1; s1 with Not_found | Skip_proto -> (* continue with a dummy auth *) dlog "Server does not know this user"; let c1_nonce = match ss.ss_c1 with | None -> create_nonce() | Some c1 -> c1.c1_nonce in let s1 = { s1_nonce = c1_nonce ^ create_nonce(); s1_salt = create_nonce(); s1_iteration_count = 4096; s1_extensions = [] } in ss.ss_state <- `S1; ss.ss_s1 <- Some s1; if ss.ss_err = None then ss.ss_err <- Some (if ss.ss_profile.return_unknown_user then `Unknown_user else `Invalid_proof); (* This will keep the client off being successful *) let s1 = encode_s1_message s1 in ss.ss_s1_raw <- format_msg s1; s1 in dlogr (fun () -> sprintf "Server state `C1 emitting message: %s" (format_msg m) ); m | `CF -> ( match ss.ss_err with | Some err -> let sf = { sf_error_or_verifier = `Error err; sf_extensions = [] } in ss.ss_sf <- Some sf; ss.ss_state <- `Error; let m = encode_sf_message sf in dlogr (fun () -> let ms = format_msg m in sprintf "Server state `CF[Err] emitting message: %s" ms ); m | None -> let server_key = match ss.ss_creds with | None -> assert false | Some(_,srvkey) -> srvkey in let cf_no_proof = strip_cf_proof ss.ss_cf_raw in let c1_bare = remove_gs2 p.ptype ss.ss_c1_raw in let auth_message = c1_bare ^ "," ^ ss.ss_s1_raw ^ "," ^ cf_no_proof in let server_signature = hmac_string h server_key auth_message in let sf = { sf_error_or_verifier = `Verifier server_signature; sf_extensions = [] } in ss.ss_sf <- Some sf; ss.ss_state <- `Connected; let m = encode_sf_message sf in dlogr (fun () -> sprintf "Server state `CF emitting message: %s" (format_msg m) ); m ) | _ -> failwith "Netmech_scram.server_emit_message" let server_emit_message ss = format_msg (server_emit_message_kv ss) let gs2_compatibility c1_gs2 cf_gs2 = (* check whether the GS2 headers from c1 and cf are the same *) c1_gs2.gs2_authzname = cf_gs2.gs2_authzname && match c1_gs2.gs2_cb, cf_gs2.gs2_cb with | `None, `None -> true | `SASL_none_but_advertise, `SASL_none_but_advertise -> true | `SASL_require(ty1,_), `SASL_require(ty2,_) -> ty1=ty2 | `None, `GSSAPI _ -> true (* c1_gs2 does not really exist... *) | `GSSAPI _, `GSSAPI _ -> true | _ -> false let server_recv_message ss message = let p = ss.ss_profile in let h = p.hash_function in match ss.ss_state with | `Start -> dlog (sprintf "Server state `Start receiving message: %s" message); catch_condition ss (fun () -> let c1 = decode_c1_message p.ptype message in ss.ss_c1 <- Some c1; ) (); ss.ss_c1_raw <- message; ss.ss_state <- `C1 (* Username is checked later *) | `S1 -> dlog (sprintf "Server state `S1 receiving message: %s" message); catch_condition ss (fun () -> try let c1 = match ss.ss_c1 with | None -> assert false | Some c1 -> c1 in let s1 = match ss.ss_s1 with | None -> raise Skip_proto | Some s1 -> s1 in let stored_key = match ss.ss_creds with | None -> raise Skip_proto | Some(stkey,_) -> stkey in let cf = decode_cf_message p.ptype true message in if s1.s1_nonce <> cf.cf_nonce then raise (Invalid_proof "nonce mismatch"); let cf_no_proof = strip_cf_proof message in let c1_bare = remove_gs2 p.ptype ss.ss_c1_raw in let auth_message = c1_bare ^ "," ^ ss.ss_s1_raw ^ "," ^ cf_no_proof in dlogr (fun () -> "Server auth_message: " ^ auth_message); let client_signature = hmac_string h stored_key auth_message in let decoded_client_key = match cf.cf_proof with | None -> assert false | Some cf_proof -> Netauth.xor_s cf_proof client_signature in let decoded_stored_key = hash_string h decoded_client_key in if decoded_stored_key <> stored_key then raise (Invalid_proof "bad client signature"); if not(gs2_compatibility c1.c1_gs2 cf.cf_gs2) then raise (Invalid_proof "invalid gs2 header"); ss.ss_cf <- Some cf; ss.ss_proto_key <- Some ( lsb128 (hmac_string h stored_key ("GSS-API session key" ^ decoded_client_key ^ auth_message))); with | Skip_proto -> () ) (); ss.ss_cf_raw <- message; ss.ss_state <- `CF | _ -> failwith "Netmech_scram.server_recv_message" let server_channel_binding ss = match ss.ss_cf with | None -> `None | Some cf -> cf.cf_gs2.gs2_cb let server_user_name ss = match ss.ss_c1 with | None -> None | Some c1 -> Some c1.c1_username let server_authz_name ss = match ss.ss_c1 with | None -> None | Some c1 -> c1.c1_gs2.gs2_authzname let server_prop ss key = match key with | "snonce" -> ( match ss.ss_s1 with | None -> raise Not_found | Some s1 -> s1.s1_nonce ) | "cnonce" -> ( match ss.ss_c1 with | None -> raise Not_found | Some c1 -> c1.c1_nonce ) | "salt" -> ( match ss.ss_s1 with | None -> raise Not_found | Some s1 -> s1.s1_salt ) | "i" -> ( match ss.ss_s1 with | None -> raise Not_found | Some s1 -> string_of_int s1.s1_iteration_count ) | "protocol_key" -> ( match server_protocol_key ss with | None -> raise Not_found | Some key -> key ) | _ -> raise Not_found (* Encryption for GSS-API *) module AES_CTS = struct (* FIXME: avoid copying strings all the time *) let aes128_err() = failwith "Netmech_scram: cannot find cipher AES-128. Is the crypto \ support initialized?" let aes128_ecb() = try Netsys_ciphers.find ("AES-128", "ECB") with | Not_found -> aes128_err() let aes128_cbc() = try Netsys_ciphers.find ("AES-128", "CBC") with | Not_found -> aes128_err() let c = 128 (* bits *) let m = 1 (* byte *) let encrypt key s = (* AES with CTS as defined in RFC 3962, section 5. It is a bit unclear why the RFC uses CTS because the upper layer already ensures that s consists of a whole number of cipher blocks *) let l = String.length s in if l <= 16 then ( (* Corner case: exactly one AES block of 128 bits or less *) let cipher = aes128_ecb() in let ctx = cipher # create key `Length in (* any padding is ok here *) ctx # encrypt_string s ) else ( (* Cipher-text stealing, also see http://en.wikipedia.org/wiki/Ciphertext_stealing *) let cipher = aes128_cbc() in let ctx = cipher # create key `CTS in ctx # set_iv (String.make 16 '\000'); ctx # encrypt_string s ) let encrypt_mstrings key ms_list = (* Exactly the same, but we get input as "mstring list" and return output in the same way *) let l = Netxdr_mstring.length_mstrings ms_list in if l <= 16 then ( let s = encrypt key (Netxdr_mstring.concat_mstrings ms_list) in [ Netxdr_mstring.string_to_mstring s ] ) else ( let cipher = aes128_cbc() in let ctx = cipher # create key `CTS in ctx # set_iv (String.make 16 '\000'); let ch = Netxdr_mstring.in_channel_of_mstrings ms_list in let enc_ch = Netchannels_crypto.encrypt_in ctx ch in Netxdr_mstring.mstrings_of_in_channel (enc_ch :> Netchannels.in_obj_channel) ) let decrypt key s = let l = String.length s in if l <= 16 then ( if l <> 16 then invalid_arg "Netmech_scram.AES256_CTS: bad length of plaintext"; let cipher = aes128_ecb() in let ctx = cipher # create key `None in ctx # set_iv (String.make 16 '\000'); ctx # decrypt_string s (* This string is still padded! *) ) else ( let cipher = aes128_cbc() in let ctx = cipher # create key `CTS in ctx # set_iv (String.make 16 '\000'); ctx # decrypt_string s ) let decrypt_mstrings key ms_list = let l = Netxdr_mstring.length_mstrings ms_list in if l <= 16 then ( let s = decrypt key (Netxdr_mstring.concat_mstrings ms_list) in [ Netxdr_mstring.string_to_mstring s ] ) else ( let cipher = aes128_cbc() in let ctx = cipher # create key `CTS in ctx # set_iv (String.make 16 '\000'); let ch = Netxdr_mstring.in_channel_of_mstrings ms_list in let dec_ch = Netchannels_crypto.decrypt_in ctx ch in Netxdr_mstring.mstrings_of_in_channel (dec_ch :> Netchannels.in_obj_channel) ) (* Test vectors from the RFC (for 128 bit AES): *) let k_128 = "\x63\x68\x69\x63\x6b\x65\x6e\x20\x74\x65\x72\x69\x79\x61\x6b\x69" let v1_in = "\x49\x20\x77\x6f\x75\x6c\x64\x20\x6c\x69\x6b\x65\x20\x74\x68\x65\x20" let v1_out = "\xc6\x35\x35\x68\xf2\xbf\x8c\xb4\xd8\xa5\x80\x36\x2d\xa7\xff\x7f\x97" let v2_in = "\x49\x20\x77\x6f\x75\x6c\x64\x20\x6c\x69\x6b\x65\x20\x74\x68\x65\x20\ \x47\x65\x6e\x65\x72\x61\x6c\x20\x47\x61\x75\x27\x73\x20" let v2_out = "\xfc\x00\x78\x3e\x0e\xfd\xb2\xc1\xd4\x45\xd4\xc8\xef\xf7\xed\x22\ \x97\x68\x72\x68\xd6\xec\xcc\xc0\xc0\x7b\x25\xe2\x5e\xcf\xe5" let v3_in = "\x49\x20\x77\x6f\x75\x6c\x64\x20\x6c\x69\x6b\x65\x20\x74\x68\x65\ \x20\x47\x65\x6e\x65\x72\x61\x6c\x20\x47\x61\x75\x27\x73\x20\x43" let v3_out = "\x39\x31\x25\x23\xa7\x86\x62\xd5\xbe\x7f\xcb\xcc\x98\xeb\xf5\xa8\ \x97\x68\x72\x68\xd6\xec\xcc\xc0\xc0\x7b\x25\xe2\x5e\xcf\xe5\x84" let v4_in = "\x49\x20\x77\x6f\x75\x6c\x64\x20\x6c\x69\x6b\x65\x20\x74\x68\x65\ \x20\x47\x65\x6e\x65\x72\x61\x6c\x20\x47\x61\x75\x27\x73\x20\x43\ \x68\x69\x63\x6b\x65\x6e\x2c\x20\x70\x6c\x65\x61\x73\x65\x2c" let v4_out = "\x97\x68\x72\x68\xd6\xec\xcc\xc0\xc0\x7b\x25\xe2\x5e\xcf\xe5\x84\ \xb3\xff\xfd\x94\x0c\x16\xa1\x8c\x1b\x55\x49\xd2\xf8\x38\x02\x9e\ \x39\x31\x25\x23\xa7\x86\x62\xd5\xbe\x7f\xcb\xcc\x98\xeb\xf5" let v5_in = "\x49\x20\x77\x6f\x75\x6c\x64\x20\x6c\x69\x6b\x65\x20\x74\x68\x65\ \x20\x47\x65\x6e\x65\x72\x61\x6c\x20\x47\x61\x75\x27\x73\x20\x43\ \x68\x69\x63\x6b\x65\x6e\x2c\x20\x70\x6c\x65\x61\x73\x65\x2c\x20" let v5_out = "\x97\x68\x72\x68\xd6\xec\xcc\xc0\xc0\x7b\x25\xe2\x5e\xcf\xe5\x84\ \x9d\xad\x8b\xbb\x96\xc4\xcd\xc0\x3b\xc1\x03\xe1\xa1\x94\xbb\xd8\ \x39\x31\x25\x23\xa7\x86\x62\xd5\xbe\x7f\xcb\xcc\x98\xeb\xf5\xa8" let v6_in = "\x49\x20\x77\x6f\x75\x6c\x64\x20\x6c\x69\x6b\x65\x20\x74\x68\x65\ \x20\x47\x65\x6e\x65\x72\x61\x6c\x20\x47\x61\x75\x27\x73\x20\x43\ \x68\x69\x63\x6b\x65\x6e\x2c\x20\x70\x6c\x65\x61\x73\x65\x2c\x20\ \x61\x6e\x64\x20\x77\x6f\x6e\x74\x6f\x6e\x20\x73\x6f\x75\x70\x2e" let v6_out = "\x97\x68\x72\x68\xd6\xec\xcc\xc0\xc0\x7b\x25\xe2\x5e\xcf\xe5\x84\ \x39\x31\x25\x23\xa7\x86\x62\xd5\xbe\x7f\xcb\xcc\x98\xeb\xf5\xa8\ \x48\x07\xef\xe8\x36\xee\x89\xa5\x26\x73\x0d\xbc\x2f\x7b\xc8\x40\ \x9d\xad\x8b\xbb\x96\xc4\xcd\xc0\x3b\xc1\x03\xe1\xa1\x94\xbb\xd8" let tests = [ k_128, v1_in, v1_out; k_128, v2_in, v2_out; k_128, v3_in, v3_out; k_128, v4_in, v4_out; k_128, v5_in, v5_out; k_128, v6_in, v6_out; ] let run_tests() = let j = ref 1 in List.for_all (fun (k, v_in, v_out) -> prerr_endline("Test: " ^ string_of_int !j); let e1 = encrypt k v_in in prerr_endline " enc ok"; let d1 = decrypt k v_out in prerr_endline " dec ok"; let ok1 = e1 = v_out in if not ok1 then prerr_endline " enc unexpected result"; let ok2 = d1 = v_in in if not ok2 then prerr_endline " dec unexpected result"; incr j; ok1 && ok2 ) tests let run_mtests() = let j = ref 1 in List.for_all (fun (k, v_in, v_out) -> prerr_endline("Test: " ^ string_of_int !j); let v_in_ms = Netxdr_mstring.string_to_mstring v_in in let v_out_ms = Netxdr_mstring.string_to_mstring v_out in let e = Netxdr_mstring.concat_mstrings (encrypt_mstrings k [v_in_ms]) in prerr_endline " enc ok"; let d = Netxdr_mstring.concat_mstrings (decrypt_mstrings k [v_out_ms]) in prerr_endline " dec ok"; incr j; e = v_out && d = v_in ) tests end module Cryptosystem = struct (* RFC 3961 section 5.3 *) module C = AES_CTS (* Cipher *) module I = struct (* Integrity *) let hmac = hmac_string `SHA_1 (* hmac-sha1 *) let hmac_mstrings = hmac_mstrings `SHA_1 let h = 12 end exception Integrity_error let derive_keys protocol_key usage = let k = 8 * String.length protocol_key in if k <> 128 && k <> 256 then invalid_arg "Netmech_scram.Cryptosystem.derive_keys"; let derive kt = Netauth.derive_key_rfc3961_simplified ~encrypt:(C.encrypt protocol_key) ~random_to_key:(fun s -> s) ~block_size:C.c ~k ~usage ~key_type:kt in { kc = derive `Kc; ke = derive `Ke; ki = derive `Ki; } let rec identity x = x let encrypt_and_sign s_keys message = let c_bytes = C.c/8 in let conf = String.make c_bytes '\000' in Netsys_rng.fill_random conf; let l = String.length message in let p = (l + c_bytes) mod (identity C.m) in (* Due to a bug in the ARM code generator, avoid "... mod 1" *) let pad = if p = 0 then "" else String.make (C.m - p) '\000' in let p1 = conf ^ message ^ pad in let c1 = C.encrypt s_keys.ke p1 in let h1 = I.hmac s_keys.ki p1 in c1 ^ String.sub h1 0 I.h let encrypt_and_sign_mstrings s_keys message = let c_bytes = C.c/8 in let conf = String.make c_bytes '\000' in Netsys_rng.fill_random conf; let l = Netxdr_mstring.length_mstrings message in let p = (l + c_bytes) mod C.m in let pad = if p = 0 then "" else String.make (C.m - p) '\000' in let p1 = ( ( Netxdr_mstring.string_to_mstring conf ) :: message ) @ [ Netxdr_mstring.string_to_mstring pad ] in let c1 = C.encrypt_mstrings s_keys.ke p1 in let h1 = I.hmac_mstrings s_keys.ki p1 in c1 @ [ Netxdr_mstring.string_to_mstring(String.sub h1 0 I.h) ] let decrypt_and_verify s_keys ciphertext = let c_bytes = C.c/8 in let l = String.length ciphertext in if l < I.h then invalid_arg "Netmech_scram.Cryptosystem.decrypt_and_verify"; let c1 = String.sub ciphertext 0 (l - I.h) in let h1 = String.sub ciphertext (l - I.h) I.h in let p1 = C.decrypt s_keys.ke c1 in let h1' = String.sub (I.hmac s_keys.ki p1) 0 I.h in if h1 <> h1' then raise Integrity_error; let q = String.length p1 in if q < c_bytes then raise Integrity_error; String.sub p1 c_bytes (q-c_bytes) (* This includes any padding or residue from the lower layer! *) let decrypt_and_verify_mstrings s_keys ciphertext = let c_bytes = C.c/8 in let l = Netxdr_mstring.length_mstrings ciphertext in if l < I.h then invalid_arg "Netmech_scram.Cryptosystem.decrypt_and_verify"; let c1 = Netxdr_mstring.shared_sub_mstrings ciphertext 0 (l - I.h) in let h1 = Netxdr_mstring.concat_mstrings (Netxdr_mstring.shared_sub_mstrings ciphertext (l - I.h) I.h) in let p1 = C.decrypt_mstrings s_keys.ke c1 in let h1' = String.sub (I.hmac_mstrings s_keys.ki p1) 0 I.h in if h1 <> h1' then raise Integrity_error; let q = Netxdr_mstring.length_mstrings p1 in if q < c_bytes then raise Integrity_error; Netxdr_mstring.shared_sub_mstrings p1 c_bytes (q-c_bytes) (* This includes any padding or residue from the lower layer! *) let get_ec s_keys n = if n < 16 then invalid_arg "Netmech_scram.Cryptosystem.get_ec"; 0 let get_mic s_keys message = String.sub (I.hmac s_keys.kc message) 0 I.h let get_mic_mstrings s_keys message = String.sub (I.hmac_mstrings s_keys.kc message) 0 I.h end (* SASL *) (* #use "topfind";; #require "netstring,nettls-gnutls";; open Netmech_scram;; Debug.enable := true;; let p = { ptype = `SASL; hash_function = `SHA_1; return_unknown_user=false; iteration_count_limit = 100000 };; test_nonce := Some "fyko+d2lbbFgONRv9qkxdawL";; let cs = create_client_session p "user" "pencil";; let c1 = client_emit_message cs;; assert(c1 = "n,,n=user,r=fyko+d2lbbFgONRv9qkxdawL");; client_recv_message cs "r=fyko+d2lbbFgONRv9qkxdawL3rfcNHYJY1ZVvWVs7j,s=QSXCR+Q6sek8bf92,i=4096";; let c2 = client_emit_message cs;; assert(c2 = "c=biws,r=fyko+d2lbbFgONRv9qkxdawL3rfcNHYJY1ZVvWVs7j,p=v0X8v3Bz2T0CJGbJQyF0X+HI4Ts=");; client_recv_message cs "v=rmF9pqV8S7suAoZWja4dJRkFsKQ=";; assert(client_finish_flag cs);; test_nonce := Some "3rfcNHYJY1ZVvWVs7j";; let salt = Netencoding.Base64.decode "QSXCR+Q6sek8bf92";; let ss = create_server_session p (fun _ -> salt_password `SHA_1 "pencil" salt 4096, salt, 4096);; server_recv_message ss "n,,n=user,r=fyko+d2lbbFgONRv9qkxdawL";; let s1 = server_emit_message ss;; assert(s1 = "r=fyko+d2lbbFgONRv9qkxdawL3rfcNHYJY1ZVvWVs7j,s=QSXCR+Q6sek8bf92,i=4096");; server_recv_message ss "c=biws,r=fyko+d2lbbFgONRv9qkxdawL3rfcNHYJY1ZVvWVs7j,p=v0X8v3Bz2T0CJGbJQyF0X+HI4Ts=";; let s2 = server_emit_message ss;; assert(s2 = "v=rmF9pqV8S7suAoZWja4dJRkFsKQ=");; assert(server_finish_flag ss);; *) (* HTTP *) (* #use "topfind";; #require "netstring,nettls-gnutls";; open Netmech_scram;; Debug.enable := true;; let p = { ptype = `HTTP; hash_function = `SHA_1; return_unknown_user=false; iteration_count_limit = 100000 };; test_nonce := Some "fyko+d2lbbFgONRv9qkxdawL";; let cs = create_client_session p "user" "pencil";; let c1 = client_emit_message cs;; assert(c1 = "g=n,n=user,r=fyko+d2lbbFgONRv9qkxdawL");; client_recv_message cs "r=fyko+d2lbbFgONRv9qkxdawL3rfcNHYJY1ZVvWVs7j,s=QSXCR+Q6sek8bf92,i=4096";; let c2 = client_emit_message cs;; assert(c2 = "c=biw=,r=fyko+d2lbbFgONRv9qkxdawL3rfcNHYJY1ZVvWVs7j,p=z0TYz4fr26P2eJYbU4IPQL2HBXA=");; client_recv_message cs "v=AE3w3+i1bvD1L/NrfGjiOwMRJQA=";; assert(client_finish_flag cs);; test_nonce := Some "3rfcNHYJY1ZVvWVs7j";; let salt = Netencoding.Base64.decode "QSXCR+Q6sek8bf92";; let ss = create_server_session p (fun _ -> salt_password `SHA_1 "pencil" salt 4096, salt, 4096);; server_recv_message ss "g=n,n=user,r=fyko+d2lbbFgONRv9qkxdawL";; let s1 = server_emit_message ss;; assert(s1 = "r=fyko+d2lbbFgONRv9qkxdawLfyko+d2lbbFgONRv9qkxdawL,s=QSXCR+Q6sek8bf92,i=4096");; server_recv_message ss "c=biw=,r=fyko+d2lbbFgONRv9qkxdawL3rfcNHYJY1ZVvWVs7j,p=z0TYz4fr26P2eJYbU4IPQL2HBXA=";; let s2 = server_emit_message ss;; assert(s2 = "v=AE3w3+i1bvD1L/NrfGjiOwMRJQA=");; assert(server_finish_flag ss);; *) ocamlnet-4.0.4/src/netstring/netunichar.mli0000644000175000017500000000103412541553661017422 0ustar gerdgerd(* $Id: netunichar.mli 1872 2013-07-30 23:15:31Z gerd $ *) (** Unicode character information *) val to_lower : int -> int (** Converts the input letter to lowercase. Returns the input unchanged if it is no letter, or there is no lowercase equivalent. This bases on the 1:1 lowercase transformation of letters, and ignores any transformation mapping one letter to several chars. *) val to_upper : int -> int (** Same for uppercase conversion *) val to_title : int -> int (** Same for titlecase conversion *) ocamlnet-4.0.4/src/netstring/netasn1.ml0000644000175000017500000005246012541553661016473 0ustar gerdgerd(* $Id: netasn1.ml 2195 2015-01-01 12:23:39Z gerd $ *) exception Out_of_range exception Parse_error of int module Type_name = struct type type_name = | Bool | Integer | Enum | Real | Bitstring | Octetstring | Null | Seq | Set | OID | ROID | ObjectDescriptor | External | Embedded_PDV | NumericString | PrintableString | TeletexString | VideotexString | VisibleString | IA5String | GraphicString | GeneralString | UniversalString | BMPString | UTF8String | CharString | UTCTime | GeneralizedTime end module Value = struct type pc = Primitive | Constructed type value = | Bool of bool | Integer of int_value | Enum of int_value | Real of real_value | Bitstring of bitstring_value | Octetstring of string | Null | Seq of value list | Set of value list | Tagptr of tag_class * int * pc * string * int * int | Tag of tag_class * int * pc * value | OID of int array | ROID of int array | ObjectDescriptor of string | External of value list | Embedded_PDV of value list | NumericString of string | PrintableString of string | TeletexString of string | VideotexString of string | VisibleString of string | IA5String of string | GraphicString of string | GeneralString of string | UniversalString of string | BMPString of string | UTF8String of string | CharString of string | UTCTime of time_value | GeneralizedTime of time_value and tag_class = | Universal | Application | Context | Private and int_value = string and real_value = string and bitstring_value = string and time_value = U of string | G of string let rec equal v1 v2 = match (v1, v2) with | (Seq s1, Seq s2) -> List.length s1 = List.length s2 && List.for_all2 equal s1 s2 | (Set s1, Set s2) -> (* FIXME: compare the set *) List.length s1 = List.length s2 && List.for_all2 equal s1 s2 | (Tag(c1,t1,pc1,sub1), Tag(c2,t2,pc2,sub2)) -> c1=c2 && t1=t2 && pc1=pc2 && equal sub1 sub2 | (Tagptr(c1,t1,pc1,s1,pos1,len1), Tagptr(c2,t2,pc2,s2,pos2,len2)) -> c1=c2 && t1=t2 && pc1=pc2 && String.sub s1 pos1 len1 = String.sub s2 pos2 len2 | (External s1, External s2) -> List.length s1 = List.length s2 && List.for_all2 equal s1 s2 | (Embedded_PDV s1, Embedded_PDV s2) -> List.length s1 = List.length s2 && List.for_all2 equal s1 s2 | _ -> v1 = v2 let get_int_str v = v let get_int_b256 v = if v = "\000" then [| |] else Array.init (String.length v) (fun k -> Char.code v.[k]) let get_int64 v = match get_int_b256 v with | [| |] -> 0L | [| x0 |] -> Int64.shift_right (Int64.shift_left (Int64.of_int x0) 56) 56 | i when Array.length i <= 8 -> let x = ref 0L in let shift = ref 64 in for k = 0 to Array.length i - 1 do shift := !shift - 8; x := Int64.logor !x (Int64.shift_left (Int64.of_int i.(k)) !shift); done; Int64.shift_right !x !shift | _ -> raise Out_of_range let max_intL = Int64.of_int max_int let min_intL = Int64.of_int min_int let max_int32L = Int64.of_int32 (Int32.max_int) let min_int32L = Int64.of_int32 (Int32.min_int) let get_int v = let x = get_int64 v in if x > max_intL || x < min_intL then raise Out_of_range; Int64.to_int x let get_int32 v = let x = get_int64 v in if x > max_int32L || x < min_int32L then raise Out_of_range; Int64.to_int32 x let get_real_str v = v let get_bitstring_size v = let n_unused = Char.code v.[0] in (String.length v - 1) * 8 - n_unused let get_bitstring_data v = String.sub v 1 (String.length v - 1) let get_bitstring_bits v = let size = get_bitstring_size v in Array.init size (fun k -> let p = k lsr 3 in let q = k land 7 in let x = Char.code v.[ p + 1 ] in (x lsl q) land 0x80 <> 0 ) let utc_re = Netstring_str.regexp "^\\([0-9][0-9]\\)\ \\([0-9][0-9]\\)\ \\([0-9][0-9]\\)\ \\([0-9][0-9]\\)\ \\([0-9][0-9]\\)\ \\([0-9][0-9]\\)Z$" let gentime_re = Netstring_str.regexp "^\\([0-9][0-9][0-9][0-9]\\)\ \\([0-9][0-9]\\)\ \\([0-9][0-9]\\)\ \\([0-9][0-9]\\)\ \\([0-9][0-9]\\)\ \\([0-9][0-9]\\)\ \\(.[0-9]+\\)?Z$" let get_time_str = function | U s -> s | G s -> s let get_time = function | U s -> (match Netstring_str.string_match utc_re s 0 with | Some m -> let y2 = int_of_string (Netstring_str.matched_group m 1 s) in let year = if y2 >= 50 then 1950 + y2 else 2000 + y2 in let month = int_of_string (Netstring_str.matched_group m 2 s) in let day = int_of_string (Netstring_str.matched_group m 3 s) in let hour = int_of_string (Netstring_str.matched_group m 4 s) in let minute = int_of_string (Netstring_str.matched_group m 5 s) in let second = int_of_string (Netstring_str.matched_group m 6 s) in if month = 0 || month > 12 || day = 0 || day > 31 || hour > 23 || minute > 59 || second > 59 then failwith "Netasn1.Value.get_time"; { Netdate.year; month; day; hour; minute; second; nanos = 0; zone = 0; week_day = (-1) } | None -> failwith "Netasn1.Value.get_time" ) | G s -> (match Netstring_str.string_match gentime_re s 0 with | Some m -> let year = int_of_string (Netstring_str.matched_group m 1 s) in let month = int_of_string (Netstring_str.matched_group m 2 s) in let day = int_of_string (Netstring_str.matched_group m 3 s) in let hour = int_of_string (Netstring_str.matched_group m 4 s) in let minute = int_of_string (Netstring_str.matched_group m 5 s) in let second = int_of_string (Netstring_str.matched_group m 6 s) in if month = 0 || month > 12 || day = 0 || day > 31 || hour > 23 || minute > 59 || second > 59 then failwith "Netasn1.Value.get_time"; let nanos = try let n1 = Netstring_str.matched_group m 7 s in let n2 = String.sub n1 1 (String.length n1 - 1) in let n3 = if String.length n2 > 9 then String.sub n2 0 9 else n2 in let n4 = n3 ^ String.make (9 - String.length n3) '0' in int_of_string n4 with Not_found -> 0 in { Netdate.year; month; day; hour; minute; second; nanos; zone = 0; week_day = (-1) } | None -> failwith "Netasn1.Value.get_time" ) end let type_of_tag = function | 1 -> Type_name.Bool | 2 -> Type_name.Integer | 3 -> Type_name.Bitstring | 4 -> Type_name.Octetstring | 5 -> Type_name.Null | 6 -> Type_name.OID | 7 -> Type_name.ObjectDescriptor | 8 -> Type_name.External | 9 -> Type_name.Real | 10 -> Type_name.Enum | 11 -> Type_name.Embedded_PDV | 12 -> Type_name.UTF8String | 13 -> Type_name.ROID | 16 -> Type_name.Seq | 17 -> Type_name.Set | 18 -> Type_name.NumericString | 19 -> Type_name.PrintableString | 20 -> Type_name.TeletexString | 21 -> Type_name.VideotexString | 22 -> Type_name.IA5String | 23 -> Type_name.UTCTime | 24 -> Type_name.GeneralizedTime | 25 -> Type_name.GraphicString | 26 -> Type_name.VisibleString | 27 -> Type_name.GeneralString | 28 -> Type_name.UniversalString | 29 -> Type_name.CharString | 30 -> Type_name.BMPString | _ -> raise Not_found let n_max = if Sys.word_size = 32 then 3 else 7 let decode_rel_oid s = (* will raise Not_found on parse error *) let cur = ref 0 in let end_pos = String.length s in let l = ref [] in while !cur < end_pos do let x = ref 0 in while s.[ !cur ] >= '\128' do x := (!x lsl 7) lor (Char.code s.[ !cur ] - 128); incr cur; if !cur > end_pos then raise Not_found; done; x := (!x lsl 7) lor (Char.code s.[ !cur ]); l := !x :: !l; incr cur; done; Array.of_list (List.rev !l) let decode_region ?(pos=0) ?len s = let pos_end = match len with | None -> String.length s | Some n -> pos+n in (pos, pos_end) let decode_ber_header ?pos ?len ?(skip_length_check=false) s = let pos, pos_end = decode_region ?pos ?len s in let cur = ref pos in let next() = if !cur < pos_end then ( let c = Char.code s.[!cur] in incr cur; c ) else raise(Parse_error !cur) in let id0 = next() in let pc = if (id0 land 0x20) <> 0 then Value.Constructed else Value.Primitive in let tc = match id0 land 0xc0 with | 0x00 -> Value.Universal | 0x40 -> Value.Application | 0x80 -> Value.Context | 0xc0 -> Value.Private | _ -> assert false in let tag0 = id0 land 0x1f in let tag = ( if tag0 < 31 then tag0 else ( let tag = ref 0 in let b = ref (next()) in let n = ref 1 in while !b > 127 do incr n; if !n = 5 then raise(Parse_error !cur); (* impl limit *) tag := (!tag lsl 7) lor (!b land 0x7f); b := next(); done; tag := (!tag lsl 7) lor !b; !tag ) ) in let length_opt = ( let l0 = next() in if l0 < 128 then Some l0 else ( let n = l0-128 in if n=0 then None (* indefinite length *) else ( if n > n_max then raise(Parse_error !cur); (* impl limit *) let l = ref 0 in for k = 1 to n do l := (!l lsl 8) lor (next()) done; Some !l ) ) ) in ( match length_opt with | None -> if pc = Value.Primitive then raise(Parse_error !cur) | Some n -> if not skip_length_check && n > pos_end - !cur then raise(Parse_error !cur) ); let hdr_len = !cur - pos in (hdr_len, tc, pc, tag, length_opt) let rec decode_ber_length ?pos ?len s = let pos, pos_end = decode_region ?pos ?len s in let (hdr_len, tc, pc, tag, length_opt) = decode_ber_header ~pos ~len:(pos_end - pos) s in match length_opt with | Some n -> hdr_len + n | None -> let cur = ref (pos + hdr_len) in let at_end_marker() = !cur+2 <= pos_end && s.[ !cur ] = '\000' && s.[ !cur+1 ] = '\000' in while not (at_end_marker()) do assert(!cur < pos_end); let n = decode_ber_length ~pos:!cur ~len:(pos_end - !cur) s in cur := !cur + n; done; (!cur - pos) + 2 let rec decode_homo_construction f pos pos_end indefinite expected_tag s = (* A construction where the primitives have all the same tag. The depth is arbitrary. [f] is called for every found primitive. *) let cur = ref pos in let at_end() = if indefinite then !cur+2 <= pos_end && s.[ !cur ] = '\000' && s.[ !cur+1 ] = '\000' else !cur = pos_end in while not (at_end()) do assert(!cur < pos_end); let (hdr_len, tc, pc, tag, length_opt) = decode_ber_header ~pos:!cur ~len:(pos_end - !cur) s in if tc <> Value.Universal then raise (Parse_error !cur); if tag <> expected_tag then raise (Parse_error !cur); ( match pc with | Value.Primitive -> let n = match length_opt with | None -> assert false | Some n -> n in f (!cur + hdr_len) n; cur := !cur + hdr_len + n | Value.Constructed -> let sub_pos_end = match length_opt with | None -> pos_end | Some n -> !cur + hdr_len + n in let real_n = decode_homo_construction f (!cur + hdr_len) sub_pos_end (length_opt = None) expected_tag s in ( match length_opt with | None -> () | Some n -> if n <> real_n then raise (Parse_error !cur) ); cur := !cur + hdr_len + real_n ); done; if indefinite then cur := !cur + 2; if not indefinite && !cur <> pos_end then raise (Parse_error !cur); !cur - pos let rec decode_ber ?pos ?len s = let pos, pos_end = decode_region ?pos ?len s in let (hdr_len, tc, pc, tag, length_opt) = decode_ber_header ~pos ~len:(pos_end - pos) s in match tc with | Value.Universal -> let cur = pos + hdr_len in let ty_name = try type_of_tag tag with Not_found -> raise(Parse_error cur) in let len = match length_opt with | None -> pos_end - cur | Some n -> n in let content_len, value = decode_ber_contents ~pos:cur ~len ~indefinite:(length_opt = None) s pc ty_name in ( match length_opt with | None -> () | Some n -> if content_len <> n then raise(Parse_error cur) ); (content_len + hdr_len, value) | _ -> let content_len = match length_opt with | None -> decode_ber_length ~pos ~len:(pos_end - pos) s - hdr_len - 2 | Some n -> n in let value = Value.Tagptr(tc, tag, pc, s, pos+hdr_len, content_len) in (content_len + hdr_len, value) and decode_ber_contents ?pos ?len ?(indefinite=false) s pc ty = let pos, pos_end = decode_region ?pos ?len s in let len = pos_end - pos in if indefinite && pc=Value.Primitive then invalid_arg "Netasn1.decode_ber_contents: only constructed values \ permit indefinite length"; match ty with | Type_name.Null -> if pc <> Value.Primitive then raise(Parse_error pos); if len<>0 then raise(Parse_error pos); (0, Value.Null) | Type_name.Bool -> if pc <> Value.Primitive then raise(Parse_error pos); if len=0 then raise(Parse_error pos); let v = Value.Bool( s.[pos] <> '\000' ) in (1, v) | Type_name.Integer -> if pc <> Value.Primitive then raise(Parse_error pos); if len=0 then raise(Parse_error pos); let u = String.sub s pos len in (* FIXME: value check *) let v = Value.Integer u in (len, v) | Type_name.Enum -> if pc <> Value.Primitive then raise(Parse_error pos); if len=0 then raise(Parse_error pos); let u = String.sub s pos len in (* FIXME: value check *) let v = Value.Enum u in (len, v) | Type_name.Real -> if pc <> Value.Primitive then raise(Parse_error pos); let u = String.sub s pos len in (* FIXME: value check *) let v = Value.Real u in (len, v) | Type_name.OID -> if pc <> Value.Primitive then raise(Parse_error pos); let u = String.sub s pos len in let r = try decode_rel_oid u with Not_found -> raise(Parse_error pos) in if Array.length r < 1 then raise(Parse_error pos); let x = if r.(0) < 40 then 0 else if r.(0) < 80 then 1 else 2 in let y = if x < 2 then r.(0) mod 40 else r.(0) - 80 in let oid = Array.append [| x; y |] (Array.sub r 1 (Array.length r - 1)) in let v = Value.OID oid in (len, v) | Type_name.ROID -> if pc <> Value.Primitive then raise(Parse_error pos); let u = String.sub s pos len in let r = try decode_rel_oid u with Not_found -> raise(Parse_error pos) in let v = Value.ROID r in (len, v) | Type_name.Octetstring -> let (len, octets) = decode_ber_octets pos pos_end indefinite s pc in (len, Value.Octetstring octets) | Type_name.ObjectDescriptor -> let (len, octets) = decode_ber_octets pos pos_end indefinite s pc in (len, Value.ObjectDescriptor octets) | Type_name.UTF8String -> let (len, octets) = decode_ber_octets pos pos_end indefinite s pc in (len, Value.UTF8String octets) | Type_name.NumericString -> let (len, octets) = decode_ber_octets pos pos_end indefinite s pc in (len, Value.NumericString octets) | Type_name.PrintableString -> let (len, octets) = decode_ber_octets pos pos_end indefinite s pc in (len, Value.PrintableString octets) | Type_name.TeletexString -> let (len, octets) = decode_ber_octets pos pos_end indefinite s pc in (len, Value.TeletexString octets) | Type_name.VideotexString -> let (len, octets) = decode_ber_octets pos pos_end indefinite s pc in (len, Value.VideotexString octets) | Type_name.IA5String -> let (len, octets) = decode_ber_octets pos pos_end indefinite s pc in (len, Value.IA5String octets) | Type_name.GraphicString -> let (len, octets) = decode_ber_octets pos pos_end indefinite s pc in (len, Value.GraphicString octets) | Type_name.VisibleString -> let (len, octets) = decode_ber_octets pos pos_end indefinite s pc in (len, Value.VisibleString octets) | Type_name.GeneralString -> let (len, octets) = decode_ber_octets pos pos_end indefinite s pc in (len, Value.GeneralString octets) | Type_name.UniversalString -> let (len, octets) = decode_ber_octets pos pos_end indefinite s pc in (len, Value.UniversalString octets) | Type_name.CharString -> let (len, octets) = decode_ber_octets pos pos_end indefinite s pc in (len, Value.CharString octets) | Type_name.BMPString -> let (len, octets) = decode_ber_octets pos pos_end indefinite s pc in (len, Value.BMPString octets) | Type_name.UTCTime -> let (len, octets) = decode_ber_octets pos pos_end indefinite s pc in (len, Value.UTCTime (Value.U octets)) | Type_name.GeneralizedTime -> let (len, octets) = decode_ber_octets pos pos_end indefinite s pc in (len, Value.GeneralizedTime (Value.G octets)) | Type_name.Bitstring -> let (len, bitstring) = decode_ber_bits pos pos_end indefinite s pc in (len, Value.Bitstring bitstring) | Type_name.Seq -> if pc <> Value.Constructed then raise(Parse_error pos); let (len, list) = decode_list_construction pos pos_end indefinite s in (len, Value.Seq list) | Type_name.Set -> if pc <> Value.Constructed then raise(Parse_error pos); let (len, list) = decode_list_construction pos pos_end indefinite s in (len, Value.Set list) | Type_name.External -> if pc <> Value.Constructed then raise(Parse_error pos); let (len, list) = decode_list_construction pos pos_end indefinite s in (len, Value.External list) | Type_name.Embedded_PDV -> if pc <> Value.Constructed then raise(Parse_error pos); let (len, list) = decode_list_construction pos pos_end indefinite s in (len, Value.Embedded_PDV list) and decode_ber_octets pos pos_end indefinite s pc = let len = pos_end - pos in match pc with | Value.Primitive -> (len, String.sub s pos len) | Value.Constructed -> let buf = Buffer.create 500 in let f p l = Buffer.add_substring buf s p l in let n = decode_homo_construction f pos pos_end indefinite 4 s in (n, Buffer.contents buf) and decode_ber_bits pos pos_end indefinite s pc = let len = pos_end - pos in match pc with | Value.Primitive -> if len = 0 then raise(Parse_error pos); let c0 = s.[pos] in if c0 >= '\008' || (len = 1 && c0 <> '\000') then raise(Parse_error pos); (len, String.sub s pos len) | Value.Constructed -> let c0_prev = ref '\000' in let buf = Buffer.create 500 in Buffer.add_char buf '\000'; let f p l = if !c0_prev <> '\000' then raise(Parse_error pos); if l = 0 then raise(Parse_error pos); let c0 = s.[p] in if c0 >= '\008' || (l = 1 && c0 <> '\000') then raise(Parse_error pos); c0_prev := c0; Buffer.add_substring buf s (p+1) (l-1) in let n = decode_homo_construction f pos pos_end indefinite 3 s in let bitstring = Buffer.contents buf in bitstring.[0] <- !c0_prev; (n, bitstring) and decode_list_construction pos pos_end indefinite s = let acc = ref [] in let cur = ref pos in let at_end() = if indefinite then !cur+2 <= pos_end && s.[ !cur ] = '\000' && s.[ !cur+1 ] = '\000' else !cur = pos_end in while not(at_end()) do assert(!cur < pos_end); let (ber_len, value) = decode_ber ~pos:!cur ~len:(pos_end - !cur) s in acc := value :: !acc; cur := !cur + ber_len; done; if indefinite then cur := !cur + 2; if not indefinite && !cur <> pos_end then raise (Parse_error !cur); (!cur - pos, List.rev !acc) ocamlnet-4.0.4/src/netstring/netsaslprep.mli0000644000175000017500000000123012541553661017620 0ustar gerdgerd(* $Id: netsaslprep.mli 2195 2015-01-01 12:23:39Z gerd $ *) (** The SASLprep algorithm (RFC 4013) *) (** This module implements the SASLprep string preparation algorithm, often used for normalizing passwords. Note that SASLprep is SLOOOOOOW, and should really only be used on short strings like passwords. This version of SASLprep doesn't check for unassigned codepoints. *) exception SASLprepError (** Raised when a string cannot be transformed *) val saslprep_a : int array -> int array (** Transform a string given as array of Unicode code points *) val saslprep : string -> string (** Transform a string given as UTF-8 string *) ocamlnet-4.0.4/src/netstring/netstream.mli0000644000175000017500000001177012541553661017274 0ustar gerdgerd(* $Id: netstream.mli 1003 2006-09-24 15:17:15Z gerd $ * ---------------------------------------------------------------------- * *) (** A netstream is an input channel that is read block by block. The * fragment of the channel currently loaded into memory is called the * current window of the netstream. The window can be thought as * look-ahead buffer. * * {b Picture:} * * {[ * 0 pos_in pos_in + window_length EOF * +------------------+-------------------+--------------------------+ * ==================== * The current window * ]} * * You can use a netstream like an [in_obj_channel], and read characters * and strings from the stream. The bytes come first from the look-ahead * buffer, and if there are not enough bytes, they are loaded from the * underlying channel. After every read operation it is tried to enlarge * the window such that it contains at least one block. * * If you want that the window becomes larger, you can call [want] (to * enlarge the window to a certain size) or [want_another_block] (to load * just another block from the underlying channel). Note that this affects only * the current window and not the future size of the window. * * Note [Buffer_underrun]: netstreams can cope with underruns of underlying * channels. An underrun happens when it is not possible to ensure the * minimum window size. However, it is possible that the window size * sinks under the minimum, but the [Buffer_underrun] is deferred until the * next call of an input method. Furthermore, there is a problem in the [skip] * method which may only be partially executed, i.e. the method skips some * bytes and then raises [Buffer_underrun]. *) (** An [in_obj_stream] extends [in_obj_channel] by look-ahead methods *) class type in_obj_stream = object inherit Netchannels.in_obj_channel (** The normal input operations work as usual. The window is moved after * every read sequence of bytes by exactly the number of bytes, and * if the window length becomes smaller than the block size, it will * be ensured that the window will be enlarged to the block size (or * to the rest of the stream until EOF, whatever is smaller). *) method block_size : int (** The block size of the stream *) method window : Netbuffer.t (** The look-ahead window. The first byte of the window is the byte that * would be read next by [input_char]. The length of the window is returned * by the method [window_length]. This length may be smaller than the * current length of the netbuffer, i.e. the netbuffer may contain * additional data that must be ignored. *) method want : int -> unit (** Increases the length of the window such that the length is at least * the passed number of bytes or that the window reaches EOF (whatever * happens first). *) method want_another_block : unit -> unit (** The same as: [want block_size] *) method window_length : int (** Returns the length of the window *) method window_at_eof : bool (** Whether the window is at eof *) method skip : int -> unit (** Skip the n bytes of the stream. It is not an error to skip more bytes * than available in the remaining stream. *) end class input_stream : ?len:int -> ?block_size:int -> Netchannels.in_obj_channel -> in_obj_stream (** Make an [in_obj_stream] on top of an [in_obj_channel]. The [block_size] * can be specified; it defaults to 4096. * * If [len] is passed, this parameter limits the length of the channel: * Only the first [len] bytes are read from the input channel, then an EOF * is simulated even if the input channel is longer. *) class sub_stream : ?len:int -> (* default: no maximum length *) ?delimiter:string -> (* default: no delimiter *) in_obj_stream -> in_obj_stream (** A sub stream is the part of the whole stream from the current position * to an arbitrary other position that is determined by [len] and * [delimiter]. [len] specifies the maximum length of the sub stream. * [delimiter] is an arbitrary string that indicates the end of the * sub stream (the delimiter is not part of the sub stream; i.e. the * sub stream ends immediately before the delimiter). * * While reading from the sub stream, not only the current position of * the sub stream moves, but also the current position of the main * stream. This means that it must be avoided to read data from the * main stream while the sub stream is in use. The typical pattern * is: * - Read from the main stream until the beginning of a section is * recognized * - Create a sub stream at this point * - Read from the sub stream until EOF * - Continue reading the main stream. The next character of the main * stream is exactly the character following the EOF of the sub stream *) val print_in_obj_stream : Format.formatter -> in_obj_stream -> unit (** A top-loop printer for streams *) ocamlnet-4.0.4/src/netstring/neturl_tut.txt0000644000175000017500000001657212541553661017542 0ustar gerdgerd{1:tutorial Neturl Tutorial} This module is a quite flexible parser for various kinds of URLs occuring in practice. The syntax is configurable such that one URL module can handle a lot of URL types in a generic way. {2 Generic Parsing} In order to parse an absolute URL (beginning with a scheme identifier like "http:...") of unknown type just call {[ let url = parse_url "http://me@server/directory" ]} By default, this function can parse all URL types listed at {!Neturl.common_url_syntax}. However, the default configuration implies also that - relative URLs cannot be parsed - fragment identifiers are rejected (i.e. the part after the hash mark like in "http://server/document#location") - characters are rejected when the most significant bit (MSB) is set The latter two features can be simply enabled by passing the arguments [~enable_fragment:true] and [~accept_8bits:true], respectively. The restriction that relative URLs are rejected has to do with the problem that context information is missing. Because the scheme identifier (like "http") is not available, the function does not know which syntax the relative URL should have. For example, the relative URL [dir/file?x=1] is differently parsed when it is taken relative to an [http] URL and when it is interpreted relative to an [ftp] URL. In the first case, the path component of the URL is ["dir/file"] and the query component is ["?x=1"], but in the latter case the path component is ["dir/file?x=1"], and a query component is not allowed. The solution is that the syntax of the base URL, relative to which the URL is seen, must be passed as additional argument. Under the assumption that [base_url] is the base URL, use {[ let url = parse_url ~base_syntax:(url_syntax_of_url base_url) "/dir/file?x=1" ]} Of course, this assumes that the base URL is known when the url is parsed. {2 Parsing For a Certain Syntax} The function [url_of_string] is also a parser, but you must pass the URL syntax as argument, e.g. {[ let url = url_of_string syntax "ipp://server/printer" ]} Pass as [syntax] one of the elements of {!Neturl.common_url_syntax}, e.g. {[ let syntax = Hashtbl.find common_url_syntax "ipp" ]} or a self-defined syntax. {2 Printing URLs} This is much easier, just call [string_of_url] to convert an URL to a string. It is ensured that every URL always has an unambiguous representation as string. {2 URL Components} Internally, the parsed URL is decomposed into its components. This module supports two ways of decomposition: + [scheme://user;userparams:password@host:port/path;params?query#fragment] + [scheme:other;params?query#fragment] The first form is used for services that directly connect to a certain service running on a certain host. The second form can be used for everything else not falling under this category. Examples: {ul {- [http://me:abrakadabra@server/dir?x=5#section1] scheme=["http"], user=["me"], password=["abrakadabra"], host=["server"], path=["/dir"], query=["x=5"], fragment=["section1"] } {- [pop://you;auth=digest-md5@mail] scheme=["pop"], user=["you"], user_params=[["auth=digest-md5"]], host=["mail"] } {- [mailto:gerd@gerd-stolpmann.de?cc=you@domain.com] scheme=["mailto"], other=["gerd@gerd-stolpmann.de"], query=["cc=you@domain.com"] } } It is important to mention that the decomposition is not fully performed, but only down to a certain level. For example, the query ["x=5"] could be further analysed and be split into the syntactic parts ["x"] and ["5"]. However, this is not done, just because the author seeked a compromise between the depth of analysis and the genericy of application. {2 URL Escaping} In order to represent the so-called unsafe characters, one can use [%]-escaping in URLs. For example, this URL contains a password with [@], an unsafe character encoded as [%40]: {[ http://user:!$%40?@server ]} The question is how this module handles such escapings. It is surprising that the URL parser does not decode these escaped forms (it checks, however, whether they are syntactically correct). Internally, the components are stored as parsed, and one can even retrieve them in their original form. The function [url_password] returns the password component. Applied to the above URL, one can get the password in its original, "encoded" form, or as decoded string: - [url_password ~encoded:true url] returns ["!$%40?"] - [url_password url] returns ["!$@?"] {2 Representation of URL Components} The URL components can be retrieved with the functions - [url_scheme] - [url_user] - [url_user_param] - [url_password] - [url_host] - [url_port] - [url_path] - [url_param] - [url_query] - [url_fragment] - [url_other] Most components are just strings. Of course, the port number is an integer. The path component ([url_path]) has a non-obvious representation. The path is represented as string list, e.g. "a/b/c" is represented as [ ["a";"b";"c"] ]. Note, however, that absolute paths have an empty string at the beginning of the list, e.g. "/a/b/" is [ [""; "a"; "b"; "" ] ]. In most cases, the paths found in URLs are absolute, and because of this it is quite common to find this empty string at the beginning of the path list. The corner cases are: - [ [] ] is used when the path is missing in the URL - [ [ "" ] ] is "/" - [ [ ""; "" ] ] is considered as illegal The last two cases are somewhat arbitrary. There is the helper function [split_path] to convert the string representation of paths into the list representation. The parameters ([url_user_param] and [url_param]) are lists, too. A parameter starts with a semicolon as delimiter and runs until the next component, which can be another parameter. The contents, i.e. the values after the semicolons are put into the list. For example, the parameter ";auth=unix;type=i" is represented as [ ["auth=unix"; "type=i"] ]. {2 Hint: Getting Query Arguments} The query component is represented as a single string. When queries use the standard syntax "name1=value1&name2=value2&...", one can parse this string using {[ let args = Netencoding.Url.dest_url_encoded_parameters (url_query ~encoded:true url) ]} Note that [encoded:true] is needed. {2 Creating and Modifying URLs} In order to create a URL for a certain syntax, call [make_url]: {[ let url = make_url ~scheme:"http" ~user:"user" ~password:"!$@?" ~host:"server" syntax ]} It is checked whether the URL conforms to the passed syntax. By default, the components are passed in decoded form, and [make_url] automatically encodes them if necessary (here, for example, the at sign in the password). Alternatively, one can set [~encoded:true], and pass the already escaped components. In this case, [make_url] checks whether the encoding is sufficient to represent the URL as string. The functions [modify_url], [default_url], [undefault_url], and [remove_from_url] can be used to modify an existing URL. {2 Relative URLs} A URL is relative when the scheme identifier at the beginning is omitted. In this case, the URL can be transformed to an absolute URL when the base URL is known. The algorithm for this is defined in RFC 1808, and quite complicated. It is implemented in [apply_relative_url], but usually {!Neturl.ensure_absolute_url} is the more convenient function. Just call {[ let url' = ensure_absolute_url ~base url ]} to convert [url] to its absolute counterpart [url'] when it is relative, and to pass the URL unchanged when it is already absolute. ocamlnet-4.0.4/src/netstring/netpagebuffer.ml0000644000175000017500000002504012541553661017731 0ustar gerdgerd(* $Id: netpagebuffer.ml 1651 2011-08-03 16:38:17Z gerd $ *) type t = { pgsize : int; mutable pages : Netsys_mem.memory array; (* Used pages have size pgsize. Unused pages are set to a dummy page *) mutable n_pages : int; (* The pages 0 .. n_pages-1 are used. n_pages >= 1 (exception below) *) mutable free_page : (unit -> unit) array; (* For each element of [pages] a function for freeing the page (quicker than by GC) *) mutable start_index : int; (* start_index: The first byte in the first page has this index *) mutable stop_index : int; (* stop_index: The first free byte in the last page *) mutable pool : Netsys_mem.memory_pool (* Pages that can be reclaimed *) } (* Except for one case we have this invariant: invariant: there is at least one free byte on the last page The exception is that we also tolerate n_pages=0, which is treated in the same way as an empty single page. When needed this empty single page is allocated to enforce the invariant (fix_invariant). *) let dummy_page = Bigarray.Array1.create Bigarray.char Bigarray.c_layout 0 let length buf = if buf.n_pages = 0 then 0 else buf.n_pages * buf.pgsize - buf.start_index - (buf.pgsize - buf.stop_index) let alloc_pages buf n = let need_resize = n + buf.n_pages > Array.length buf.pages in if need_resize then ( let new_size = max (min (2 * Array.length buf.pages) Sys.max_array_length) (buf.n_pages + n) in if new_size > Sys.max_array_length then failwith "Netpagebuffer: too large"; let pages' = Array.make new_size dummy_page in Array.blit buf.pages 0 pages' 0 buf.n_pages; let free_page' = Array.make new_size (fun () -> ()) in Array.blit buf.free_page 0 free_page' 0 buf.n_pages; buf.pages <- pages'; buf.free_page <- free_page' ); let n_pages' = buf.n_pages + n in for k = buf.n_pages to n_pages'-1 do let p, f = Netsys_mem.pool_alloc_memory2 buf.pool in buf.pages.(k) <- p; buf.free_page.(k) <- f done; buf.n_pages <- n_pages' let create pgsize = let sys_pgsize = Netsys_mem.pagesize in if pgsize mod sys_pgsize <> 0 then failwith "Netpagebuffer.create: invalid pagesize"; let pool = if pgsize = Netsys_mem.default_block_size then Netsys_mem.default_pool else if pgsize = Netsys_mem.small_block_size then Netsys_mem.small_pool else Netsys_mem.create_pool pgsize in { pgsize = pgsize; pages = [| dummy_page |]; n_pages = 0; free_page = [| fun () -> () |]; start_index = 0; stop_index = 0; pool = pool; } let fix_invariant buf = if buf.n_pages = 0 then ( alloc_pages buf 1; buf.start_index <- 0; buf.stop_index <- 0; ) let blit_to_string buf pos s s_pos len = let buf_len = length buf in let s_len = String.length s in if pos < 0 || s_pos < 0 || len < 0 || len > buf_len - pos || len > s_len - s_pos then invalid_arg "Netpagebuffer.blit_to_string"; let abs_pos1 = pos + buf.start_index in let pg1 = abs_pos1 / buf.pgsize in let idx1 = abs_pos1 mod buf.pgsize in (* let abs_pos2 = abs_pos1 + len in let pg2 = abs_pos2 / buf.pgsize in let idx2 = abs_pos2 mod buf.pgsize in *) let cur_pg = ref pg1 in let cur_s_pos = ref s_pos in let rem_len = ref len in while !rem_len > 0 do let l = min (if !cur_pg = pg1 then buf.pgsize - idx1 else buf.pgsize) !rem_len in Netsys_mem.blit_memory_to_string buf.pages.( !cur_pg ) (if !cur_pg = pg1 then idx1 else 0) s !cur_s_pos l; cur_s_pos := !cur_s_pos + l; rem_len := !rem_len - l; incr cur_pg; done let blit_to_memory buf pos m m_pos len = let buf_len = length buf in let m_len = Bigarray.Array1.dim m in if pos < 0 || m_pos < 0 || len < 0 || len > buf_len - pos || len > m_len - m_pos then invalid_arg "Netpagebuffer.blit_to_memory"; let abs_pos1 = pos + buf.start_index in let pg1 = abs_pos1 / buf.pgsize in let idx1 = abs_pos1 mod buf.pgsize in (* let abs_pos2 = abs_pos1 + len in let pg2 = abs_pos2 / buf.pgsize in let idx2 = abs_pos2 mod buf.pgsize in *) let cur_pg = ref pg1 in let cur_m_pos = ref m_pos in let rem_len = ref len in while !rem_len > 0 do let l = min (if !cur_pg = pg1 then buf.pgsize - idx1 else buf.pgsize) !rem_len in Bigarray.Array1.blit (Bigarray.Array1.sub buf.pages.( !cur_pg ) (if !cur_pg = pg1 then idx1 else 0) l) (Bigarray.Array1.sub m !cur_m_pos l); cur_m_pos := !cur_m_pos + l; rem_len := !rem_len - l; incr cur_pg; done let sub buf pos len = let buf_len = length buf in if pos < 0 || len < 0 || len > buf_len - pos then invalid_arg "Netpagebuffer.sub"; let s = String.create len in blit_to_string buf pos s 0 len; s let contents buf = sub buf 0 (length buf) let add_sub_string buf s pos len = let s_len = String.length s in if pos < 0 || len < 0 || len > s_len - pos then invalid_arg "Netpagebuffer.add_sub_string"; fix_invariant buf; let len_for_new_pages = len - (buf.pgsize - buf.stop_index) in let new_pages = if len_for_new_pages >= 0 then len_for_new_pages / buf.pgsize + 1 else 0 in let old_last_page = buf.n_pages - 1 in alloc_pages buf new_pages; let len_old_last_page = min len (buf.pgsize - buf.stop_index) in Netsys_mem.blit_string_to_memory s pos buf.pages.(old_last_page) buf.stop_index len_old_last_page; buf.stop_index <- buf.stop_index + len_old_last_page; if buf.stop_index = buf.pgsize then buf.stop_index <- 0; let len_remaining = ref (len - len_old_last_page) in let cur_pos = ref (pos + len_old_last_page) in let cur_pg = ref(old_last_page + 1) in while !len_remaining > 0 do let l = min !len_remaining buf.pgsize in Netsys_mem.blit_string_to_memory s !cur_pos buf.pages.(!cur_pg) 0 l; cur_pos := !cur_pos + l; len_remaining := !len_remaining - l; incr cur_pg; if !len_remaining = 0 then ( buf.stop_index <- l; if l = buf.pgsize then buf.stop_index <- 0 ) done let add_string buf s = add_sub_string buf s 0 (String.length s) let add_sub_memory buf m pos len = (* very similar to add_sub_string. For performance reasons this is a copy of the above algorithm *) let m_len = Bigarray.Array1.dim m in if pos < 0 || len < 0 || len > m_len - pos then invalid_arg "Netpagebuffer.add_sub_memory"; fix_invariant buf; let len_for_new_pages = len - (buf.pgsize - buf.stop_index) in let new_pages = if len_for_new_pages >= 0 then len_for_new_pages / buf.pgsize + 1 else 0 in let old_last_page = buf.n_pages - 1 in alloc_pages buf new_pages; let len_old_last_page = min len (buf.pgsize - buf.stop_index) in Bigarray.Array1.blit (Bigarray.Array1.sub m pos len_old_last_page) (Bigarray.Array1.sub buf.pages.(old_last_page) buf.stop_index len_old_last_page); buf.stop_index <- buf.stop_index + len_old_last_page; if buf.stop_index = buf.pgsize then buf.stop_index <- 0; let len_remaining = ref (len - len_old_last_page) in let cur_pos = ref (pos + len_old_last_page) in let cur_pg = ref(old_last_page + 1) in while !len_remaining > 0 do let l = min !len_remaining buf.pgsize in Bigarray.Array1.blit (Bigarray.Array1.sub m !cur_pos l) (Bigarray.Array1.sub buf.pages.(!cur_pg) 0 l); cur_pos := !cur_pos + l; len_remaining := !len_remaining - l; incr cur_pg; if !len_remaining = 0 then ( buf.stop_index <- l; if l = buf.pgsize then buf.stop_index <- 0 ) done let page_for_additions buf = fix_invariant buf; let last_page = buf.n_pages - 1 in ( buf.pages.(last_page), buf.stop_index, buf.pgsize - buf.stop_index ) let advance buf n = fix_invariant buf; if n < 0 || n > buf.pgsize - buf.stop_index then invalid_arg "Netpagebuffer.advance"; buf.stop_index <- buf.stop_index + n; if buf.stop_index = buf.pgsize then ( alloc_pages buf 1; buf.stop_index <- 0; ) let add_inplace buf f = let (page, pos, len) = page_for_additions buf in let n = f page pos len in if n < 0 || n > len then invalid_arg "Netpagebuffer.add_inplace"; advance buf n; n let page_for_consumption buf = fix_invariant buf; let stop = if buf.n_pages = 1 then buf.stop_index else buf.pgsize in ( buf.pages.(0), buf.start_index, stop ) let delete_hd buf n = let blen = length buf in if n < 0 || n > blen then invalid_arg "Netpagebuffer.delete_hd"; if n > 0 then ( (* hence, blen > 0, and the invariant holds *) let l_first_page = buf.pgsize - buf.start_index in if n < l_first_page then buf.start_index <- buf.start_index + n else ( let pages_to_delete = (n - l_first_page) / buf.pgsize + 1 in let new_start_index = (n - l_first_page) mod buf.pgsize in for k = 0 to pages_to_delete-1 do buf.free_page.(k) () done; let m = buf.n_pages - pages_to_delete in Array.blit buf.pages pages_to_delete buf.pages 0 m; Array.blit buf.free_page pages_to_delete buf.free_page 0 m; buf.n_pages <- buf.n_pages - pages_to_delete; buf.start_index <- new_start_index; for k = buf.n_pages to Array.length buf.pages - 1 do buf.pages.(k) <- dummy_page; buf.free_page.(k) <- (fun () -> ()) done ); if buf.n_pages = 1 && buf.start_index = buf.stop_index then ( buf.free_page.(0) (); buf.pages.(0) <- dummy_page; buf.free_page.(0) <- (fun () -> ()); buf.n_pages <- 0; buf.start_index <- 0; buf.stop_index <- 0; ) ) let clear buf = for k = 0 to buf.n_pages - 1 do buf.free_page.(k) (); buf.pages.(k) <- dummy_page; buf.free_page.(k) <- (fun () -> ()) done; buf.n_pages <- 0; buf.start_index <- 0; buf.stop_index <- 0 exception Found of int let index_from buf k c = if k < 0 || k > length buf then (* we allow k=length *) invalid_arg "Netpagebuffer.index_from"; let abs_pos1 = k + buf.start_index in let pg1 = abs_pos1 / buf.pgsize in let idx1 = abs_pos1 mod buf.pgsize in let pg = ref pg1 in let idx = ref idx1 in try while !pg < buf.n_pages do let page = buf.pages.( !pg ) in let stop_idx = if !pg = buf.n_pages - 1 then buf.stop_index else buf.pgsize in while !idx < stop_idx && Bigarray.Array1.unsafe_get page !idx <> c do incr idx done; if !idx < stop_idx then ( let pos = !pg * buf.pgsize + !idx - buf.start_index in raise(Found pos) ); incr pg; idx := 0 done; raise Not_found with | Found pos -> pos ocamlnet-4.0.4/src/netstring/netaux.mli0000644000175000017500000000432312541553661016572 0ustar gerdgerd(* $Id: netaux.mli 1003 2006-09-24 15:17:15Z gerd $ * ---------------------------------------------------------------------- * *) (** Internal auxiliary functions * * This is an internal module. *) (* Auxiliary stuff *) module KMP : sig (* An implementation of the Knuth-Morris-Pratt algorithm *) (* Credits go to Alain Frisch who suggested this algorithm *) type pattern val make_pattern : string -> pattern (* Prepares the passed pattern *) val find_pattern : pattern -> ?pos:int -> ?len:int -> string -> int (* Searches the position where the pattern or a prefix of the pattern * occurs in the substring from position [pos] to [pos+len-1]. * Possible return values p: * - pos <= p <= pos+len-length(pattern): * The pattern occurs at position p in the string, i.e. * string.[p+k] = pattern.[k], for all 0 <= k < length(pattern). * Furthermore, the returned position p is the first such position. * - pos+len-length(pattern) < p < pos+len * The string ends with a prefix of the pattern, i.e. * string.[p+k] = pattern[k], for all 0 <= k < pos+len-p. * - p = pos+len * Neither does the pattern occur in the string, nor is the * (non-empty) suffix of the string a prefix of the pattern. * * Defaults: * ~pos = 0 * ~len = length(string)-pos = "until the end of the string" *) end module ArrayAux : sig val int_blit : int array -> int -> int array -> int -> int -> unit (** A specialisation of [Array.blit] for int arrays. * (Performance reasons.) *) val int_series : int array -> int -> int array -> int -> int -> int -> unit (** [int_series src srcpos dst dstpos len n]: * Computes for every [i], [0 <= i < len]: * [dst.(dstpos+i) = n + SUM(j=0..(i-1): src.(srcpos+j)) ] * * It is expected that [src == dst] implies [srcpos >= dstpos]. *) (**/**) val int_blit_ref : (int array -> int -> int array -> int -> int -> unit) ref (* Used by [Netaccel] to override the built-in implementation *) val int_series_ref : (int array -> int -> int array -> int -> int -> int -> unit) ref (* Used by [Netaccel] to override the built-in implementation *) end ocamlnet-4.0.4/src/netstring/netmech_scram_gssapi.ml0000644000175000017500000012440312541553661021275 0ustar gerdgerd(* $Id: netmech_scram_gssapi.ml 2195 2015-01-01 12:23:39Z gerd $ *) (* FIXME: - export_sec_context: the token does not include the sequence numbers, and it does not include the flags *) open Netsys_gssapi open Netgssapi_support open Printf class scram_name (name_string:string) (name_type:oid) = object method otype = ( `Name : [`Name] ) method name_string = name_string method name_type = name_type end type cred = | Cred_server (* there are no server credentials! *) | Cred_client of string * string (* user name, password *) | Cred_none class scram_cred (name:scram_name) (cred:cred) = object method otype = ( `Credential : [`Credential] ) method name = name method cred = cred end type ctx = | Ctx_client of Netmech_scram.client_session | Ctx_server of Netmech_scram.server_session class scram_context ctx (init_flags : ret_flag list) = let valid = ref true in let server_cb = ref "" in let specific_keys = ref None in let seq_nr = ref 0L in let exp_seq_nr = ref None in let flags = ref init_flags in object method otype = ( `Context : [ `Context ] ) method valid = !valid method ctx = ctx method delete() = valid := false method server_cb = server_cb method is_acceptor = match ctx with | Ctx_client _ -> false | Ctx_server _ -> true method specific_keys = match !specific_keys with | Some(k_mic_c,k_mic_s,k_wrap_c,k_wrap_s) -> Some(k_mic_c,k_mic_s,k_wrap_c,k_wrap_s) | None -> let proto_key_opt = match ctx with | Ctx_client sess -> Netmech_scram.client_protocol_key sess | Ctx_server sess -> Netmech_scram.server_protocol_key sess in (* The usage numbers are defined in RFC 4121 *) (match proto_key_opt with | None -> None | Some proto_key -> let k_mic_c = Netmech_scram.Cryptosystem.derive_keys proto_key 25 in let k_mic_s = Netmech_scram.Cryptosystem.derive_keys proto_key 23 in let k_wrap_c = Netmech_scram.Cryptosystem.derive_keys proto_key 24 in let k_wrap_s = Netmech_scram.Cryptosystem.derive_keys proto_key 22 in (* eprintf "protocol key: %S\n" proto_key; eprintf "k_mic_c.kc: %S\n" k_mic_c.Netmech_scram.kc; eprintf "k_mic_s.kc: %S\n" k_mic_s.Netmech_scram.kc; eprintf "k_wrap_c.ke: %S\n" k_wrap_c.Netmech_scram.ke; eprintf "k_wrap_c.ki: %S\n" k_wrap_c.Netmech_scram.ki; eprintf "k_wrap_s.ke: %S\n" k_wrap_s.Netmech_scram.ke; eprintf "k_wrap_s.ki: %S\n%!" k_wrap_s.Netmech_scram.ki; *) specific_keys := Some(k_mic_c,k_mic_s,k_wrap_c,k_wrap_s); !specific_keys ) method seq_nr = let n = !seq_nr in seq_nr := Int64.succ !seq_nr; n method is_peer_seq_nr_ok n : suppl_status list = match !exp_seq_nr with | None -> exp_seq_nr := Some n; [] | Some e -> if n = e then ( exp_seq_nr := Some (Int64.succ e); [] ) else ( if n < e then [ `Unseq_token ] else [ `Gap_token ] ) method flags = flags end class type client_key_ring = object method password_of_user_name : string -> string method default_user_name : string option end let empty_client_key_ring : client_key_ring = object method password_of_user_name _ = raise Not_found method default_user_name = None end class type server_key_verifier = object method scram_credentials : string -> Netmech_scram.credentials end let empty_server_key_verifier : server_key_verifier = object method scram_credentials _ = raise Not_found end let scram_mech = [| 1; 3; 6; 1; 5; 5; 14 |] (* let as_string (sm,pos,len) = match sm with | `String s -> if pos=0 && len=String.length s then s else String.sub s pos len | `Memory m -> let s = String.create len in Netsys_mem.blit_memory_to_string m pos s 0 len; s *) (* let empty_msg = (`String "",0,0) *) exception Calling_error of calling_error exception Routine_error of routine_error module type PROFILE = sig val client_key_ring : client_key_ring val server_key_verifier : server_key_verifier val scram_profile : Netmech_scram.profile end module Make(P:PROFILE) : Netsys_gssapi.GSSAPI = struct type credential = scram_cred type context = scram_context type name = scram_name exception Credential of credential exception Context of context exception Name of name class type gss_api = [credential, name, context] Netsys_gssapi.poly_gss_api let scram_ret_flags = [ `Mutual_flag; `Conf_flag; `Integ_flag; `Replay_flag; `Sequence_flag ] let no_cred = ( object method otype = `Credential method name = assert false method cred = Cred_none end ) let no_name = ( object method otype = `Name method name_type = [| |] method name_string = "" end ) let interface = object(self) method provider = "Netmech_scram_gssapi.scram_gss_api" method no_credential = no_cred method no_name = no_name method is_no_credential cred = cred#cred = Cred_none method is_no_name name = name#name_type = [| |] method accept_sec_context : 't . context:context option -> acceptor_cred:credential -> input_token:token -> chan_bindings:channel_bindings option -> out:( src_name:name -> mech_type:oid -> output_context:context option -> output_token:token -> ret_flags:ret_flag list -> time_rec:time -> delegated_cred:credential -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~context ~acceptor_cred ~input_token ~chan_bindings ~out () -> let acc_name = new scram_name "@" nt_hostbased_service in let src_name = acc_name in try let cb_data = match chan_bindings with | None -> "" | Some (init_addr, acc_addr, cb_data) -> cb_data in (* We ignore init_addr and acc_addr... CHECK *) if acceptor_cred <> no_cred && acceptor_cred#cred <> Cred_server then raise(Routine_error `No_cred); let context, sess, is_first = match context with | None -> let sess = Netmech_scram.create_server_session P.scram_profile P.server_key_verifier#scram_credentials in let ctx = Ctx_server sess in let context = new scram_context ctx scram_ret_flags in (context # server_cb) := cb_data; (context, sess, true) | Some context -> if not context#valid then raise (Routine_error `No_context); let sess = match context#ctx with | Ctx_server sess -> sess | Ctx_client _ -> raise (Routine_error `No_context) in (context, sess, false) in let eff_input_token = if is_first then (* There is a header *) try let k = ref 0 in let (oid, tok) = Netgssapi_support.wire_decode_token input_token k in if !k <> String.length input_token then raise(Routine_error `Defective_token); if oid <> scram_mech then raise(Routine_error `Bad_mech); tok with | Failure _ -> raise(Routine_error `Defective_token); else input_token in (* The following call usually does not raise exceptions. Error codes are stored inside sess *) Netmech_scram.server_recv_message sess eff_input_token; let output_context = Some context in let output_token = Netmech_scram.server_emit_message sess in if Netmech_scram.server_error_flag sess then ( out ~src_name ~mech_type:scram_mech ~output_context ~output_token ~ret_flags:scram_ret_flags ~time_rec:`Indefinite ~delegated_cred:no_cred ~minor_status:0l ~major_status:(`None,`Failure,[]) () ) else if Netmech_scram.server_finish_flag sess then ( (* Finally check channel bindings: *) let scram_cb = match Netmech_scram.server_channel_binding sess with | `GSSAPI d -> d | _ -> assert false in if scram_cb <> !(context # server_cb) then raise(Routine_error `Bad_bindings); let ret_flags = [`Prot_ready_flag; `Trans_flag] @ scram_ret_flags in context # flags := ret_flags; out ~src_name ~mech_type:scram_mech ~output_context ~output_token ~ret_flags ~time_rec:`Indefinite ~delegated_cred:no_cred ~minor_status:0l ~major_status:(`None,`None,[]) () ) else ( out ~src_name ~mech_type:scram_mech ~output_context ~output_token ~ret_flags:scram_ret_flags ~time_rec:`Indefinite ~delegated_cred:no_cred ~minor_status:0l ~major_status:(`None,`None,[`Continue_needed]) () ) with | Calling_error code -> out ~src_name ~mech_type:scram_mech ~output_context:None ~output_token:"" ~ret_flags:scram_ret_flags ~time_rec:`Indefinite ~delegated_cred:no_cred ~minor_status:0l ~major_status:(code,`None,[]) () | Routine_error code -> out ~src_name ~mech_type:scram_mech ~output_context:None ~output_token:"" ~ret_flags:scram_ret_flags ~time_rec:`Indefinite ~delegated_cred:no_cred ~minor_status:0l ~major_status:(`None,code,[]) () method private get_client_cred user = (* or Not_found *) let pw = P.client_key_ring # password_of_user_name user in let name = new scram_name user nt_user_name in let cred = new scram_cred (name:>name) (Cred_client(user,pw)) in cred method private get_default_client_cred() = (* or Not_found *) match P.client_key_ring # default_user_name with | None -> raise Not_found | Some user -> self # get_client_cred user method acquire_cred : 't . desired_name:name -> time_req:time -> desired_mechs:oid_set -> cred_usage:cred_usage -> out:( cred:credential -> actual_mechs:oid_set -> time_rec:time -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~desired_name ~time_req ~desired_mechs ~cred_usage ~out () -> let error code = out ~cred:no_cred ~actual_mechs:[] ~time_rec:`Indefinite ~minor_status:0l ~major_status:(`None,code,[]) () in match cred_usage with | `Initiate -> (* For clients *) if List.mem scram_mech desired_mechs then ( let out_client_cred user = try let cred = self#get_client_cred user in out ~cred:(cred :> credential) ~actual_mechs:[ scram_mech ] ~time_rec:`Indefinite ~minor_status:0l ~major_status:(`None,`None,[]) () with | Not_found -> error `No_cred in (* Expect nt_user_name: *) if desired_name # name_type = Netsys_gssapi.nt_user_name then ( let user = desired_name # name_string in out_client_cred user ) else ( if desired_name = no_name then ( (* maybe we have a default: *) match P.client_key_ring # default_user_name with | None -> error `No_cred | Some user -> out_client_cred user ) else error `Bad_nametype ) ) else error `Bad_mech | `Accept -> (* For server: Effectively there are no credentials. So we accept any desired_name. *) if List.mem scram_mech desired_mechs then ( let server_name = new scram_name "@" nt_hostbased_service in let cred = new scram_cred (server_name :> name) Cred_server in out ~cred:(cred :> credential) ~actual_mechs:[ scram_mech ] ~time_rec:`Indefinite ~minor_status:0l ~major_status:(`None,`None,[]) () ) else error `Bad_mech | `Both -> (* Not supported - credentials are either for the client or for the server *) out ~cred:no_cred ~actual_mechs:[] ~time_rec:`Indefinite ~minor_status:0l ~major_status:(`None,`Bad_nametype,[]) () method add_cred : 't . input_cred:credential -> desired_name:name -> desired_mech:oid -> cred_usage:cred_usage -> initiator_time_req:time -> acceptor_time_req:time -> out:( output_cred:credential -> actual_mechs:oid_set -> initiator_time_rec:time -> acceptor_time_rec:time -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~input_cred ~desired_name ~desired_mech ~cred_usage ~initiator_time_req ~acceptor_time_req ~out () -> (* More or less it is not possible to add to credentials - we have here only one mechanism. So, the only thing to do here is to create the right error message. *) let error code = out ~output_cred:no_cred ~actual_mechs:[] ~initiator_time_rec:`Indefinite ~acceptor_time_rec:`Indefinite ~minor_status:0l ~major_status:(`None,code,[]) () in let add cred = if scram_mech = desired_mech then error `Duplicate_element else error `Bad_mech in if input_cred = no_cred then ( self # acquire_cred ~desired_name:(desired_name :> name) ~time_req:`Indefinite ~desired_mechs:[desired_mech] ~cred_usage ~out:( fun ~cred ~actual_mechs ~time_rec ~minor_status ~major_status () -> let (_,code,_) = major_status in if code = `None then add cred else error code ) () ) else add input_cred method canonicalize_name : 't . input_name:name -> mech_type:oid -> out:( output_name:name -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~input_name ~mech_type ~out () -> let error code = out ~output_name:no_name ~minor_status:0l ~major_status:(`None,code,[]) () in if mech_type <> scram_mech then error `Bad_mech else out ~output_name:(input_name :> name) ~minor_status:0l ~major_status:(`None,`None,[]) () method compare_name : 't . name1:name -> name2:name -> out:( name_equal:bool -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~name1 ~name2 ~out () -> let equal = name1 # name_type <> nt_anonymous && name2 # name_type <> nt_anonymous && (name1 = name2 || (name1#name_type = name2#name_type && name1#name_string = name2#name_string)) in out ~name_equal:equal ~minor_status:0l ~major_status:(`None,`None,[]) () method context_time : 't . context:context -> out:( time_rec:[ `Indefinite | `This of float] -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~context ~out () -> if not context#valid then out ~time_rec:`Indefinite ~minor_status:0l ~major_status:(`None,`No_context,[]) () else out ~time_rec:`Indefinite ~minor_status:0l ~major_status:(`None,`None,[]) () method delete_sec_context : 't . context:context -> out:( minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~context ~out () -> context#delete(); out ~minor_status:0l ~major_status:(`None,`None,[]) () method display_name : 't . input_name:name -> out:( output_name:string -> output_name_type:oid -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~input_name ~out () -> (* We just return the name_string *) out ~output_name:input_name#name_string ~output_name_type:input_name#name_type ~minor_status:0l ~major_status:(`None,`None,[]) () method display_minor_status : 't . status_value:minor_status -> mech_type: oid -> out:( status_strings: string list -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~status_value ~mech_type ~out () -> out ~status_strings:[""] ~minor_status:0l ~major_status:(`None,`None,[]) () method export_name : 't . name:name -> out:( exported_name:string -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~name ~out () -> let s1 = encode_exported_name name#name_type name#name_string in let s2 = encode_exported_name scram_mech s1 in out ~exported_name:s2 ~minor_status:0l ~major_status:(`None,`None,[]) () method export_sec_context : 't . context:context -> out:( interprocess_token:interprocess_token -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~context ~out () -> (* FIXME: Maybe we should also export the seq_nr *) if not context#valid then out ~interprocess_token:"" ~minor_status:0l ~major_status:(`None,`No_context,[]) () else ( try let interprocess_token = match context#ctx with | Ctx_client sess -> "C" ^ Netmech_scram.client_export sess | Ctx_server sess -> "S" ^ Netmech_scram.server_export sess in out ~interprocess_token ~minor_status:0l ~major_status:(`None,`None,[]) () with | Failure _ -> out ~interprocess_token:"" ~minor_status:0l ~major_status:(`None,`Unavailable,[]) () ) method get_mic : 't . context:context -> qop_req:qop -> message:message -> out:( msg_token:token -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~context ~qop_req ~message ~out () -> if not context#valid then out ~msg_token:"" ~minor_status:0l ~major_status:(`None,`No_context,[]) () else ( (* Reject any QOP: *) if qop_req <> 0l then out ~msg_token:"" ~minor_status:0l ~major_status:(`None,`Bad_QOP,[]) () else ( let sk_opt = context # specific_keys in match sk_opt with | None -> out ~msg_token:"" ~minor_status:0l ~major_status:(`None,`No_context,[]) () | Some (k_mic_c,k_mic_s,k_wrap_c,k_wrap_s) -> let sk_mic = if context#is_acceptor then k_mic_s else k_mic_c in let sequence_number = context # seq_nr in let sent_by_acceptor = context # is_acceptor in let token = Netgssapi_support.create_mic_token ~sent_by_acceptor ~acceptor_subkey:false ~sequence_number ~get_mic:( Netmech_scram.Cryptosystem.get_mic_mstrings sk_mic) ~message in out ~msg_token:token ~minor_status:0l ~major_status:(`None,`None,[]) () ) ) method import_name : 't . input_name:string -> input_name_type:oid -> out:( output_name:name -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~input_name ~input_name_type ~out () -> let out_name name_string name_type = let n = new scram_name name_string name_type in out ~output_name:(n :> name) ~minor_status:0l ~major_status:(`None,`None,[]) () in if input_name_type = nt_hostbased_service then try let (_service,_host) = parse_hostbased_service input_name in out_name input_name nt_hostbased_service with | _ -> out ~output_name:no_name ~minor_status:0l ~major_status:(`None,`Bad_name,[]) () else if input_name_type = nt_user_name then out_name input_name nt_user_name else if input_name_type = nt_export_name then try let k = ref 0 in let (mech_oid,s1) = decode_exported_name input_name k in if !k <> String.length input_name then failwith "too short"; if mech_oid <> scram_mech then out ~output_name:no_name ~minor_status:0l ~major_status:(`None,`Bad_name,[]) () else ( k := 0; let (name_oid,s2) = decode_exported_name s1 k in if !k <> String.length input_name then failwith "too short"; out_name s2 name_oid ) with | Failure _ -> out ~output_name:no_name ~minor_status:0l ~major_status:(`None,`Bad_name,[]) () else if input_name_type = [||] then out_name input_name nt_user_name else out ~output_name:no_name ~minor_status:0l ~major_status:(`None,`Bad_nametype,[]) () method import_sec_context : 't . interprocess_token:interprocess_token -> out:( context:context option -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~interprocess_token ~out () -> let error code = out ~context:None ~minor_status:0l ~major_status:(`None,code,[]) () in let l = String.length interprocess_token in if interprocess_token = "" then error `Defective_token else match interprocess_token.[0] with | 'C' -> let t = String.sub interprocess_token 1 (l-1) in let sess = Netmech_scram.client_import t in let context = new scram_context (Ctx_client sess) scram_ret_flags in out ~context:(Some (context :> context)) ~minor_status:0l ~major_status:(`None,`None,[]) () | 'S' -> let t = String.sub interprocess_token 1 (l-1) in let sess = Netmech_scram.server_import t in let context = new scram_context (Ctx_server sess) scram_ret_flags in out ~context:(Some (context :> context)) ~minor_status:0l ~major_status:(`None,`None,[]) () | _ -> error `Defective_token method indicate_mechs : 't . out:( mech_set:oid_set -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~out () -> out ~mech_set:[ scram_mech ] ~minor_status:0l ~major_status:(`None, `None, []) () method init_sec_context : 't . initiator_cred:credential -> context:context option -> target_name:name -> mech_type:oid -> req_flags:req_flag list -> time_req:float option -> chan_bindings:channel_bindings option -> input_token:token option -> out:( actual_mech_type:oid -> output_context:context option -> output_token:token -> ret_flags:ret_flag list -> time_rec:[ `Indefinite | `This of float ] -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~initiator_cred ~context ~target_name ~mech_type ~req_flags ~time_req ~chan_bindings ~input_token ~out () -> let actual_mech_type = scram_mech in try let cb_data = match chan_bindings with | None -> "" | Some (init_addr, acc_addr, cb_data) -> cb_data in (* We ignore init_addr and acc_addr... CHECK *) let eff_init_cred = if initiator_cred = no_cred then try self # get_default_client_cred() with | Not_found -> raise(Routine_error `No_cred); (* No default *) else initiator_cred in let user, pw = match eff_init_cred # cred with | Cred_client(user,pw) -> (user,pw) | _ -> raise(Routine_error `No_cred) in let context, sess, continuation = match context with | None -> let sess = Netmech_scram.create_client_session P.scram_profile user pw in let ctx = Ctx_client sess in let context = new scram_context ctx scram_ret_flags in Netmech_scram.client_configure_channel_binding sess (`GSSAPI cb_data); (context, sess, false) | Some context -> if not context#valid then raise(Routine_error `No_context); let sess = match context#ctx with | Ctx_client sess -> sess | Ctx_server _ -> raise (Routine_error `No_context) in (context, sess, true) in if mech_type <> [||] && mech_type <> scram_mech then raise(Routine_error `Bad_mech); (* Note that we ignore target_name entirely. It is not needed for SCRAM. *) if continuation then ( (* this may raise exceptions *) try match input_token with | Some intok -> Netmech_scram.client_recv_message sess intok | None -> raise(Calling_error `Bad_structure) with | Netmech_scram.Invalid_encoding(_,_) -> raise(Routine_error `Defective_token) | Netmech_scram.Invalid_username_encoding(_,_) -> raise(Routine_error `Defective_token) | Netmech_scram.Extensions_not_supported(_,_) -> raise(Routine_error `Failure) | Netmech_scram.Protocol_error _ -> raise(Routine_error `Failure) | Netmech_scram.Invalid_server_signature -> raise(Routine_error `Bad_mic) | Netmech_scram.Server_error e -> ( match e with | `Invalid_encoding | `Extensions_not_supported | `Invalid_proof | `Channel_bindings_dont_match | `Server_does_support_channel_binding | `Channel_binding_not_supported | `Unsupported_channel_binding_type | `Unknown_user | `Invalid_username_encoding | `No_resources | `Other_error | `Extension _ -> raise(Routine_error `Failure) ) ); if Netmech_scram.client_finish_flag sess then ( let ret_flags = [`Trans_flag; `Prot_ready_flag ] @ scram_ret_flags in context # flags := ret_flags; out ~actual_mech_type ~output_context:(Some (context :> context)) ~output_token:"" ~ret_flags ~time_rec:`Indefinite ~minor_status:0l ~major_status:(`None,`None,[]) () ) else ( let output_token_1 = Netmech_scram.client_emit_message sess in let output_token = if continuation then output_token_1 else Netgssapi_support.wire_encode_token scram_mech output_token_1 in let ret_flags = if Netmech_scram.client_protocol_key sess <> None then `Prot_ready_flag :: scram_ret_flags else scram_ret_flags in context # flags := ret_flags; out ~actual_mech_type ~output_context:(Some (context :> context)) ~output_token ~ret_flags ~time_rec:`Indefinite ~minor_status:0l ~major_status:(`None,`None,[`Continue_needed]) () ) with | Calling_error code -> out ~actual_mech_type ~output_context:None ~output_token:"" ~ret_flags:scram_ret_flags ~time_rec:`Indefinite ~minor_status:0l ~major_status:(code,`None,[]) () | Routine_error code -> out ~actual_mech_type ~output_context:None ~output_token:"" ~ret_flags:scram_ret_flags ~time_rec:`Indefinite ~minor_status:0l ~major_status:(`None,code,[]) () method inquire_context : 't . context:context -> out:( src_name:name -> targ_name:name -> lifetime_req : time -> mech_type:oid -> ctx_flags:ret_flag list -> locally_initiated:bool -> is_open:bool -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~context ~out () -> let error code = out ~src_name:no_name ~targ_name:no_name ~lifetime_req:`Indefinite ~mech_type:scram_mech ~ctx_flags:scram_ret_flags ~locally_initiated:false ~is_open:false ~minor_status:0l ~major_status:(`None, code, []) () in if context # valid then match context # ctx with | Ctx_client sess -> let src_name = new scram_name (Netmech_scram.client_user_name sess) nt_user_name in let src_name = (src_name :> name) in let targ_name = new scram_name "@" nt_hostbased_service in let targ_name = (targ_name :> name) in let is_open = Netmech_scram.client_finish_flag sess in out ~src_name ~targ_name ~lifetime_req:`Indefinite ~mech_type:scram_mech ~ctx_flags:!(context # flags) ~locally_initiated:true ~is_open ~minor_status:0l ~major_status:(`None, `None, []) () | Ctx_server sess -> let src_name = match Netmech_scram.server_user_name sess with | None -> no_name | Some u -> new scram_name u nt_user_name in let src_name = (src_name :> name) in let targ_name = new scram_name "@" nt_hostbased_service in let targ_name = (targ_name :> name) in let is_open = Netmech_scram.server_finish_flag sess in out ~src_name ~targ_name ~lifetime_req:`Indefinite ~mech_type:scram_mech ~ctx_flags:!(context # flags) ~locally_initiated:true ~is_open ~minor_status:0l ~major_status:(`None, `None, []) () else error `No_context method inquire_cred : 't . cred:credential -> out:( name:name -> lifetime: [ `Indefinite | `This of float ] -> cred_usage:cred_usage -> mechanisms:oid_set -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~cred ~out () -> let eff_cred = if cred = no_cred then try self # get_default_client_cred() with | Not_found -> no_cred (* We do not support a default initiator credential *) else cred in if eff_cred = no_cred then out ~name:no_name ~lifetime:`Indefinite ~cred_usage:`Initiate ~mechanisms:[] ~minor_status:0l ~major_status:(`None, `No_cred, []) () else out ~name:eff_cred#name ~lifetime:`Indefinite ~cred_usage:( match eff_cred#cred with | Cred_server -> `Accept | Cred_client _ -> `Initiate | _ -> assert false ) ~mechanisms:[ scram_mech ] ~minor_status:0l ~major_status:(`None, `None, []) () method inquire_cred_by_mech : 't . cred:credential -> mech_type:oid -> out:( name:name -> initiator_lifetime: [ `Indefinite | `This of float ] -> acceptor_lifetime: [ `Indefinite | `This of float ] -> cred_usage:cred_usage -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~cred ~mech_type ~out () -> let error code = out ~name:no_name ~initiator_lifetime:`Indefinite ~acceptor_lifetime:`Indefinite ~cred_usage:`Initiate ~minor_status:0l ~major_status:(`None,code,[]) () in if mech_type <> scram_mech then error `Bad_mech (* CHECK: not documented in RFC 2744 for this function *) else let eff_cred_opt = if cred = no_cred then try Some(self # get_default_client_cred()) with Not_found -> None else Some cred in match eff_cred_opt with | Some eff_cred -> out ~name:eff_cred#name ~initiator_lifetime:`Indefinite ~acceptor_lifetime:`Indefinite ~cred_usage:( match eff_cred#cred with | Cred_server -> `Accept | Cred_client _ -> `Initiate | _ -> assert false ) ~minor_status:0l ~major_status:(`None, `None, []) () | None -> error `No_cred (* No default initiator credentials *) method inquire_mechs_for_name : 't . name:name -> out:( mech_types:oid_set -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~name ~out () -> let l = if name#name_type = nt_hostbased_service || name#name_type = nt_user_name then [ scram_mech ] else [] in out ~mech_types:l ~minor_status:0l ~major_status:(`None,`None,[]) () method inquire_names_for_mech : 't . mechanism:oid -> out:( name_types:oid_set -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~mechanism ~out () -> let l = if mechanism = scram_mech then [ nt_hostbased_service; nt_user_name ] else [] in out ~name_types:l ~minor_status:0l ~major_status:(`None, `None, []) () method process_context_token : 't . context:context -> token:token -> out:( minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~context ~token ~out () -> (* There are no context tokens... *) out ~minor_status:0l ~major_status:(`None,`Defective_token,[]) () method unwrap : 't . context:context -> input_message:message -> output_message_preferred_type:[ `String | `Memory ] -> out:( output_message:message -> conf_state:bool -> qop_state:qop -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~context ~input_message ~output_message_preferred_type ~out () -> let sk_opt = context # specific_keys in let error code = out ~output_message:[] ~conf_state:false ~qop_state:0l ~minor_status:0l ~major_status:(`None,code,[]) () in if not context#valid then error `No_context else match sk_opt with | None -> error `No_context | Some (k_mic_c,k_mic_s,k_wrap_c,k_wrap_s) -> let sk_wrap = if context#is_acceptor then k_wrap_c else k_wrap_s in ( try let (sent_by_acceptor, _, _, tok_seq_nr) = Netgssapi_support.parse_wrap_token_header input_message in if sent_by_acceptor = context#is_acceptor then raise Netmech_scram.Cryptosystem.Integrity_error; let flags = context#is_peer_seq_nr_ok tok_seq_nr in let s = Netgssapi_support.unwrap_wrap_token_conf ~decrypt_and_verify:( Netmech_scram.Cryptosystem.decrypt_and_verify_mstrings sk_wrap) ~token:input_message in out ~output_message:s ~conf_state:true ~qop_state:0l ~minor_status:0l ~major_status:(`None,`None,flags) () with | Netmech_scram.Cryptosystem.Integrity_error -> error `Bad_mic | _ -> (* probable Invalid_argument *) error `Defective_token ) method verify_mic : 't . context:context -> message:message -> token:token -> out:( qop_state:qop -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~context ~message ~token ~out () -> let sk_opt = context # specific_keys in if not context#valid then out ~qop_state:0l ~minor_status:0l ~major_status:(`None,`No_context,[]) () else match sk_opt with | None -> out ~qop_state:0l ~minor_status:0l ~major_status:(`None,`No_context,[]) () | Some (k_mic_c,k_mic_s,k_wrap_c,k_wrap_s) -> let sk_mic = if context#is_acceptor then k_mic_c else k_mic_s in let (sent_by_acceptor,_,tok_seq_nr) = Netgssapi_support.parse_mic_token_header token in let flags = context#is_peer_seq_nr_ok tok_seq_nr in let ok = sent_by_acceptor <> context#is_acceptor && (Netgssapi_support.verify_mic_token ~get_mic:(Netmech_scram.Cryptosystem.get_mic_mstrings sk_mic) ~message ~token) in if ok then out ~qop_state:0l ~minor_status:0l ~major_status:(`None,`None,flags) () else out ~qop_state:0l ~minor_status:0l ~major_status:(`None,`Bad_mic,[]) () method wrap : 't . context:context -> conf_req:bool -> qop_req:qop -> input_message:message -> output_message_preferred_type:[ `String | `Memory ] -> out:( conf_state:bool -> output_message:message -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~context ~conf_req ~qop_req ~input_message ~output_message_preferred_type ~out () -> if not context#valid then out ~conf_state:false ~output_message:[] ~minor_status:0l ~major_status:(`None,`No_context,[]) () else let sk_opt = context # specific_keys in (* Reject any QOP: *) if qop_req <> 0l then out ~conf_state:false ~output_message:[] ~minor_status:0l ~major_status:(`None,`Bad_QOP,[]) () else ( match sk_opt with | None -> out ~conf_state:false ~output_message:[] ~minor_status:0l ~major_status:(`None,`No_context,[]) () | Some (k_mic_c,k_mic_s,k_wrap_c,k_wrap_s) -> let sk_wrap = if context#is_acceptor then k_wrap_s else k_wrap_c in let token = Netgssapi_support.create_wrap_token_conf ~sent_by_acceptor:context#is_acceptor ~acceptor_subkey:false ~sequence_number:context#seq_nr ~get_ec:( Netmech_scram.Cryptosystem.get_ec sk_wrap) ~encrypt_and_sign:( Netmech_scram.Cryptosystem.encrypt_and_sign_mstrings sk_wrap) ~message:input_message in out ~conf_state:true ~output_message:token ~minor_status:0l ~major_status:(`None,`None,[]) () ) method wrap_size_limit : 't . context:context -> conf_req:bool -> qop_req:qop -> req_output_size:int -> out:( max_input_size:int -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~context ~conf_req ~qop_req ~req_output_size ~out () -> (* We have: - 12 bytes for the MIC - the message is padded to a multiple of 16 bytes - the message includes a 16 bytes random header *) let p_size = (req_output_size - 12) / 16 * 16 in let m_size = max 0 (p_size - 16) in out ~max_input_size:m_size ~minor_status:0l ~major_status:(`None,`None,[]) () method duplicate_name : 't . name:'name -> out:( dest_name:'name -> minor_status:minor_status -> major_status:major_status -> unit -> 't ) -> unit -> 't = fun ~name ~out () -> let dest_name = new scram_name name#name_string name#name_type in out ~dest_name ~minor_status:0l ~major_status:(`None,`None,[]) () end end let scram_gss_api ?(client_key_ring = empty_client_key_ring) ?(server_key_verifier = empty_server_key_verifier) profile = let module P = struct let client_key_ring = client_key_ring let server_key_verifier = server_key_verifier let scram_profile = profile end in let module G = Make(P) in (module G : Netsys_gssapi.GSSAPI) ocamlnet-4.0.4/src/netstring/netgssapi_auth.ml0000644000175000017500000002752612541553661020145 0ustar gerdgerd(* $Id: netgssapi_auth.ml 2195 2015-01-01 12:23:39Z gerd $ *) module type CONFIG = sig val raise_error : string -> 'a end module Manage(G:Netsys_gssapi.GSSAPI) = struct let delete_context ctx_opt () = match ctx_opt with | None -> () | Some ctx -> G.interface # delete_sec_context ~context:ctx ~out:(fun ~minor_status ~major_status () -> ()) () let format_status ?fn ?minor_status ((calling_error,routine_error,_) as major_status) = if calling_error <> `None || routine_error <> `None then ( let error = Netsys_gssapi.string_of_major_status major_status in let minor_s = match minor_status with | None -> "" | Some n -> G.interface # display_minor_status ~mech_type:[||] ~status_value:n ~out:(fun ~status_strings ~minor_status ~major_status () -> " (details: " ^ String.concat "; " status_strings ^ ")" ) () in let s1 = match fn with | None -> "" | Some n -> " for " ^ n in "GSSAPI error" ^ s1 ^ ": " ^ error ^ minor_s ) else let s1 = match fn with | None -> "" | Some n -> " " ^ n in "GSSAPI call" ^ s1 ^ " is successful" end module Auth (G:Netsys_gssapi.GSSAPI)(C:CONFIG) = struct module M = Manage(G) let check_status ?fn ?minor_status ((calling_error,routine_error,_) as major_status) = if calling_error <> `None || routine_error <> `None then C.raise_error(M.format_status ?fn ?minor_status major_status) let get_initiator_name (config:Netsys_gssapi.client_config) = match config#initiator_name with | None -> G.interface # no_name (* means: default credential *) | Some(cred_string, cred_name_type) -> G.interface # import_name ~input_name:cred_string ~input_name_type:cred_name_type ~out:(fun ~output_name ~minor_status ~major_status () -> check_status ~fn:"import_name" ~minor_status major_status; output_name ) () let get_acceptor_name (config:Netsys_gssapi.server_config) = match config#acceptor_name with | None -> G.interface # no_name (* means: default credential *) | Some(cred_string, cred_name_type) -> G.interface # import_name ~input_name:cred_string ~input_name_type:cred_name_type ~out:(fun ~output_name ~minor_status ~major_status () -> check_status ~fn:"import_name" ~minor_status major_status; output_name ) () let acquire_initiator_cred ~initiator_name (config:Netsys_gssapi.client_config) = let mech_type = config#mech_type in G.interface # acquire_cred ~desired_name:initiator_name ~time_req:`Indefinite ~desired_mechs:(if mech_type = [| |] then [] else [mech_type]) ~cred_usage:`Initiate ~out:(fun ~cred ~actual_mechs ~time_rec ~minor_status ~major_status () -> check_status ~fn:"acquire_cred" ~minor_status major_status; cred ) () let get_initiator_cred ~initiator_name (config:Netsys_gssapi.client_config) = let mech_type = config#mech_type in match config#initiator_cred with | Some(G.Credential cred) -> (* Check that this is the cred for init_name *) if not(G.interface # is_no_name initiator_name) then ( G.interface # inquire_cred ~cred ~out:(fun ~name ~lifetime ~cred_usage ~mechanisms ~minor_status ~major_status () -> check_status ~fn:"inquire_cred" ~minor_status major_status; G.interface # compare_name ~name1:name ~name2:initiator_name ~out:(fun ~name_equal ~minor_status ~major_status () -> check_status ~fn:"compare_name" ~minor_status major_status; if not name_equal then C.raise_error "The user name does not \ match the credential" ) () ) () ); cred | _ -> acquire_initiator_cred ~initiator_name config let get_acceptor_cred ~acceptor_name (config:Netsys_gssapi.server_config) = G.interface # acquire_cred ~desired_name:acceptor_name ~time_req:`Indefinite ~desired_mechs:config#mech_types ~cred_usage:`Accept ~out:(fun ~cred ~actual_mechs ~time_rec ~minor_status ~major_status () -> check_status ~fn:"acquire_cred" ~minor_status major_status; cred ) () let get_target_name ?default (config:Netsys_gssapi.client_config) = if config#target_name=None && default=None then G.interface#no_name else let (name_string, name_type) = match config#target_name with | Some(n,t) -> (n,t) | None -> ( match default with | None -> assert false | Some(n,t) -> (n,t) ) in G.interface # import_name ~input_name:name_string ~input_name_type:name_type ~out:(fun ~output_name ~minor_status ~major_status () -> check_status ~fn:"import_name" ~minor_status major_status; output_name ) () let get_client_flags config = let flags1 = [ `Conf_flag, config#privacy; `Integ_flag, config#integrity ] @ config#flags in List.map fst (List.filter (fun (n,lev) -> lev <> `None) flags1) let get_server_flags = get_client_flags type t1 = < flags : (Netsys_gssapi.ret_flag * Netsys_gssapi.support_level) list; integrity : Netsys_gssapi.support_level; privacy : Netsys_gssapi.support_level; > let check_flags (config : t1) act_flags = let flags1 = [ `Conf_flag, config#privacy; `Integ_flag, config#integrity ] @ config#flags in let needed = List.map fst (List.filter (fun (n,lev) -> lev = `Required) flags1) in let missing = List.filter (fun flag -> not (List.mem flag act_flags) ) needed in if missing <> [] then C.raise_error ("GSSAPI error: the security mechanism could not \ grant the following required context flags: " ^ String.concat ", " (List.map Netsys_gssapi.string_of_flag missing)) let check_client_flags config act_flags = check_flags (config :> t1) act_flags let check_server_flags config act_flags = check_flags (config :> t1) act_flags let get_display_name name = G.interface # display_name ~input_name:name ~out:(fun ~output_name ~output_name_type ~minor_status ~major_status () -> check_status ~fn:"display_name" ~minor_status major_status; output_name, output_name_type ) () let get_exported_name name = G.interface # export_name ~name:name ~out:(fun ~exported_name ~minor_status ~major_status () -> check_status ~fn:"export_name" ~minor_status major_status; exported_name ) () let init_sec_context ~initiator_cred ~context ~target_name ~req_flags ~chan_bindings ~input_token config = let mech_type = config#mech_type in G.interface # init_sec_context ~initiator_cred ~context ~target_name ~mech_type ~req_flags ~time_req:None ~chan_bindings ~input_token ~out:(fun ~actual_mech_type ~output_context ~output_token ~ret_flags ~time_rec ~minor_status ~major_status () -> try check_status ~fn:"init_sec_context" ~minor_status major_status; let ctx = match output_context with | None -> assert false | Some ctx -> ctx in let (_,_,suppl) = major_status in let cont_flag = List.mem `Continue_needed suppl in if cont_flag then ( assert(output_token <> ""); (ctx, output_token, ret_flags, None) ) else ( check_client_flags config ret_flags; let props = ( object method mech_type = actual_mech_type method flags = ret_flags method time = time_rec end ) in (ctx, output_token, ret_flags, Some props) ) with | error -> M.delete_context output_context (); raise error ) () let accept_sec_context ~acceptor_cred ~context ~chan_bindings ~input_token config = G.interface # accept_sec_context ~context ~acceptor_cred ~input_token ~chan_bindings ~out:(fun ~src_name ~mech_type ~output_context ~output_token ~ret_flags ~time_rec ~delegated_cred ~minor_status ~major_status () -> try check_status ~fn:"accept_sec_context" ~minor_status major_status; let ctx = match output_context with | None -> assert false | Some ctx -> ctx in let (_,_,suppl) = major_status in let cont_flag = List.mem `Continue_needed suppl in if cont_flag then ( assert(output_token <> ""); (ctx, output_token, ret_flags, None) ) else ( check_server_flags config ret_flags; let (props : Netsys_gssapi.server_props) = ( object method mech_type = mech_type method flags = ret_flags method time = time_rec method initiator_name = get_display_name src_name method initiator_name_exported = get_exported_name src_name method deleg_credential = if List.mem `Deleg_flag ret_flags then let t = G.interface # inquire_cred ~cred:delegated_cred ~out:(fun ~name ~lifetime ~cred_usage ~mechanisms ~minor_status ~major_status () -> check_status ~fn:"inquire_cred" ~minor_status major_status; lifetime ) () in Some(G.Credential delegated_cred, t) else None end ) in (ctx, output_token, ret_flags, Some props) ) with | error -> M.delete_context output_context (); raise error ) () end ocamlnet-4.0.4/src/netstring/netxdr_mstring.mli0000644000175000017500000002367312541553661020346 0ustar gerdgerd(* $Id: netxdr_mstring.mli 2195 2015-01-01 12:23:39Z gerd $ *) (** Managed Strings *) (** Managed strings are used in XDR context for constant strings that are stored either as string or as memory (bigarray of char). A managed string [ms] is declared in the XDR file as in {[ typedef _managed string ms<>; ]} In the encoded XDR stream there is no difference between strings and managed strings, i.e. the wire representation is identical. Only the Ocaml type differs to which the managed string is mapped. This type is {!Netxdr_mstring.mstring} (below). In the RPC context there is often the problem that the I/O backend would profit from a different string representation than the user of the RPC layer. To bridge this gap, managed strings have been invented. Generally, the user can determine how to represent strings (usually either as an Ocaml string, or as memory), and the I/O backend can request to transform to a different representation when this leads to an improvement (i.e. copy operations can be saved). Only large managed strings result in a speedup of the program (at least several K). {2 How to practically use managed strings} There are two cases: The encoding case, and the decoding case. In the encoding case the [mstring] object is created by the user and passed to the RPC library. This happens when a client prepares an argument for calling a remote procedure, or when the server sends a response back to the caller. In the decoding case the client analyzes the response from an RPC call, or the server looks at the arguments of an RPC invocation. The difference here is that in the encoding case user code can directly create [mstring] objects by calling functions of this module, whereas in the decoding case the RPC library creates the [mstring] objects. For simplicity, let us only look at this problem from the perspective of an RPC client. {b Encoding.} Image a client wants to call an RPC, and one of the arguments is a managed string. This means we finally need an [mstring] object that can be put into the argument list of the call. This library supports two string representation specially: The normal Ocaml [string] type, and {!Netsys_mem.memory} which is actually just a bigarray of char's. There are two factories [fac], - {!Netxdr_mstring.string_based_mstrings}, and - {!Netxdr_mstring.memory_based_mstrings}, and both can be used to create the [mstring] to pass to the RPC layer. It should be noted that this layer can process the [memory] representation a bit better. So, if the original [data] value is a string, the factory for [string] should be used, and if it is a char bigarray, the factory for [memory] should be used. Now, the [mstring] object is created by - [let mstring = fac # create_from_string data pos len copy_flag], or by - [let mstring = fac # create_from_memory data pos len copy_flag]. Of course, if [fac] is the factory for strings, the [create_from_string] method works better, and if [fac] is for [memory], the [create_from_memory] method works better. [pos] and [len] can select a substring of [data]. If [copy_flag] is [false], the [mstring] object does not copy the data if possible, but just keeps a reference to [data] until it is accessed; otherwise if [copy_flag] is [true], a copy is made immediately. Of couse, delaying the copy is better, but this requires that [data] is not modified until the RPC call is completed. {b Decoding.} Now, the call is done, and the client looks at the result. There is also an [mstring] object in the result. As noted above, this [mstring] object was already created by the RPC library (and currently this library prefers string-based objects if not told otherwise). The user code can now access this [mstring] object with the access methods of the [mstring] class (see below). As these methods are quite limited, it makes normally only sense to output the [mstring] contents to a file descriptor. The user can request a different factory for managed strings. The function {!Rpc_client.set_mstring_factories} can be used for this purpose. (Similar ways exist for managed clients, and for RPC servers.) {b Potential.} Before introducing managed strings, a clean analysis was done how many copy operations can be avoided by using this technique. Example: The first N bytes of a file are taken as argument of an RPC call. Instead of reading these bytes into a normal Ocaml string, an optimal implementation uses now a [memory] buffer for this purpose. This gives: - Old implementation with strings and ocamlnet-2: Data is copied {b six} times from reading it from the file until writing it to the socket. - New implementation with memory-based mstrings: Data is copied only {b twice}! The first copy reads it from the file into the input buffer (a [memory] value), and the second copy writes the data into the socket. Part of the optimization is that [Unix.read] and [Unix.write] do a completely avoidable copy of the data which is prevented by switching to {!Netsys_mem.mem_read} and {!Netsys_mem.mem_write}, respectively. The latter two functions exploit an optimization that is only possible when the data is [memory]-typed. The possible optimizations for the decoding side of the problem are slightly less impressive, but still worth doing it. *) (** {2 Interface} *) open Netsys_mem (** The object holding the string value *) class type mstring = object method length : int (** The length of the managed string *) method blit_to_string : int -> string -> int -> int -> unit (** [blit_to_string mpos s spos len]: Copies the substring of the managed string from [mpos] to [mpos+len-1] to the substring of [s] from [spos] to [spos+len-1] *) method blit_to_memory : int -> memory -> int -> int -> unit (** [blit_to_string mpos mem mempos len]: Copies the substring of the managed string from [mpos] to [mpos+len-1] to the substring of [mem] from [mempos] to [mempos+len-1] *) method as_string : string * int (** Returns the contents as string. It is undefined whether the returned string is a copy or the underlying buffer. The int is the position where the contents start *) method as_memory : memory * int (** Returns the contents as memory. It is undefined whether the returned memory is a copy or the underlying buffer. The int is the position where the contents start *) method preferred : [ `Memory | `String ] (** Whether [as_memory] or [as_string] is cheaper *) end (** The object creating new [mstring] objects *) class type mstring_factory = object method create_from_string : string -> int -> int -> bool -> mstring (** [create_from_string s pos len must_copy]: Creates the [mstring] from the sub string of s starting at [pos] with length [len] If [must_copy] the mstring object must create a copy. Otherwise it can just keep the string passed in. *) method create_from_memory : memory -> int -> int -> bool -> mstring (** [create_from_memory m pos len must_copy]: Creates the [mstring] from the sub string of m starting at [pos] with length [len] If [must_copy] the mstring object must create a copy. Otherwise it can just keep the memory passed in. *) end val string_based_mstrings : mstring_factory (** Uses strings to represent mstrings *) val string_to_mstring : ?pos:int -> ?len:int -> string -> mstring (** Represent a string as mstring (no copy) *) val memory_based_mstrings : mstring_factory (** Uses memory to represent mstrings. The memory bigarrays are allocated with [Bigarray.Array1.create] *) val memory_to_mstring : ?pos:int -> ?len:int -> memory -> mstring (** Represent memory as mstring (no copy) *) val paligned_memory_based_mstrings : mstring_factory (** Uses memory to represent mstrings. The memory bigarrays are allocated with {!Netsys_mem.alloc_memory_pages} if available, and [Bigarray.Array1.create] if not. *) val memory_pool_based_mstrings : Netsys_mem.memory_pool -> mstring_factory (** Uses memory to represent mstrings. The memory bigarrays are obtained from the pool. The length of these mstrings is limited by the blocksize of the pool. *) val length_mstrings : mstring list -> int (** returns the sum of the lengths of the mstrings *) val concat_mstrings : mstring list -> string (** concatenates the mstrings and return them as single string. The returned string may be shared with one of the mstrings passed in. *) val prefix_mstrings : mstring list -> int -> string (** [prefix_mstrings l n]: returns the first [n] chars of the concatenated mstrings [l] as single string *) val blit_mstrings_to_memory : mstring list -> memory -> unit (** blits the mstrings one after the other to the memory, so that they appear there concatenated *) val shared_sub_mstring : mstring -> int -> int -> mstring (** [shared_sub_mstring ms pos len]: returns an mstring that includes a substring of [ms], starting at [pos], and with [len] bytes. The returned mstring shares the buffer with the original mstring [ms] *) val shared_sub_mstrings : mstring list -> int -> int -> mstring list (** Same for a list of mstrings *) val copy_mstring : mstring -> mstring (** Create a copy *) val copy_mstrings : mstring list -> mstring list (** Create a copy *) val in_channel_of_mstrings : mstring list -> Netchannels.in_obj_channel (** Returns a channel reading from the sequence of mstrings *) val mstrings_of_in_channel : Netchannels.in_obj_channel -> mstring list (** Returns the data of a channel as a sequence of mstrings *) (** See also {!Netsys_digests.digest_mstrings} for a utiliy function to compute cryptographic digests on mstrings *) type named_mstring_factories = (string, mstring_factory) Hashtbl.t ocamlnet-4.0.4/src/netstring/netcompression.mli0000644000175000017500000000176512541553661020345 0ustar gerdgerd(* $Id: netcompression.mli 1610 2011-05-30 08:03:45Z gerd $ *) (** Registry for compression algorithms *) (** This registry is initially empty. The {!Netgzip} module can be used to register the [gzip] algorithm, just run {[ Netgzip.init() ]} to get this effect. *) val register : iana_name:string -> ?encoder:(unit -> Netchannels.io_obj_channel) -> ?decoder:(unit -> Netchannels.io_obj_channel) -> unit -> unit (** Registers a compression algorithm. The algorithm is given as a pair of functions returning {!Netchannels.io_obj_channel}. *) val lookup_encoder : iana_name:string -> unit -> Netchannels.io_obj_channel (** Returns the encoder, or raises [Not_found] *) val lookup_decoder : iana_name:string -> unit -> Netchannels.io_obj_channel (** Returns the decoder, or raises [Not_found] *) val all_encoders : unit -> string list val all_decoders : unit -> string list (** The iana names of all encoders and decoders, resp. *) ocamlnet-4.0.4/src/netstring/netauth.mli0000644000175000017500000000552012541553661016736 0ustar gerdgerd(* $Id: netauth.mli 2195 2015-01-01 12:23:39Z gerd $ *) (** Some primitives for authentication *) val hmac : h:(string->string) -> b:int -> l:int -> k:string -> message:string -> string (** The HMAC algorithm of RFC 2104. The function [h] is the hash function. [b] and [l] are properties of [h] (see the RFC or below). The string [k] is the key, up to [b] bytes. The [message] is authenticated. The key [k] should ideally have length [l]. If this cannot be ensured by other means, one should pass [k = h any_k]. Common values of [b] and [l]: - For [h=MD5]: [b=64], [l=16] - For [h=SHA-1]: [b=64], [l=20] See also {!Netsys_digests.hmac} for a better implementation. *) type key_type = [ `Kc | `Ke | `Ki ] (** Key types: - [`Kc] is used for computing checksums - [`Ke] is used for encrypting confidential messages - [`Ki] is used for computing integrity checksums for encrypted messages *) val derive_key_rfc3961_simplified : encrypt:(string -> string) -> random_to_key:(string -> string) -> block_size:int -> k:int -> usage:int -> key_type:key_type -> string (** Derives a special key from a base key, as described in RFC 3961. - [encrypt]: Encrypts the argument with the base key and the initial cipher state. - [random_to_key]: Converts a random string of size [k] to a key - [block_size]: The block size of the cipher underlying [encrypt]. It is ensured that [encrypt] is called with strings having exactly this many bits. (The [c] parameter in the RFC text.) Minimum: 40. - [k]: The input size for [random_to_key] in bits. Must be divisible by 8. - [usage]: The usage number (here restricted to 0-255, although the RFC would allow 32 bits). Examples for usage numbers can be found in RFC 4121 section 2. - [key_type]: Which key type to derive The output is a key as produced by [random_to_key]. *) (** {2 Bitstring operations} *) val xor_s : string -> string -> string (** Performs the bitwise XOR of these strings (which must have the same length) *) val add_1_complement : string -> string -> string (** The addition algorithm for 1's-complement numbers. The two numbers to add are given as bitstrings (big endian), and must have the same length *) val rotate_right : int -> string -> string (** Rotate the (big-endian) bitstring to the right by n bits. This also works for negative n (left rotation), and for n whose absolute value is greater or equal than the bit length of the string. *) val n_fold : int -> string -> string (** Blumenthal's n-fold algorithm for an n that is divisible by 8. (RFC 3961, section 5.1) *) ocamlnet-4.0.4/src/netstring/netasn1.mli0000644000175000017500000001535512541553661016646 0ustar gerdgerd(* $Id: netasn1.mli 2195 2015-01-01 12:23:39Z gerd $ *) (** ASN.1 support functions *) exception Out_of_range exception Parse_error of int (** Byte position in string *) module Type_name : sig type type_name = | Bool | Integer | Enum | Real | Bitstring | Octetstring | Null | Seq | Set | OID | ROID | ObjectDescriptor | External | Embedded_PDV | NumericString | PrintableString | TeletexString | VideotexString | VisibleString | IA5String | GraphicString | GeneralString | UniversalString | BMPString | UTF8String | CharString | UTCTime | GeneralizedTime end module Value : sig type pc = Primitive | Constructed type value = | Bool of bool | Integer of int_value | Enum of int_value | Real of real_value | Bitstring of bitstring_value | Octetstring of string | Null | Seq of value list | Set of value list | Tagptr of tag_class * int * pc * string * int * int | Tag of tag_class * int * pc * value | OID of int array | ROID of int array | ObjectDescriptor of string | External of value list | Embedded_PDV of value list | NumericString of string | PrintableString of string | TeletexString of string | VideotexString of string | VisibleString of string | IA5String of string | GraphicString of string | GeneralString of string | UniversalString of string | BMPString of string | UTF8String of string | CharString of string | UTCTime of time_value | GeneralizedTime of time_value and tag_class = | Universal | Application | Context | Private and int_value and real_value and bitstring_value and time_value val get_int_str : int_value -> string (** Get an integer as bytes *) val get_int_b256 : int_value -> int array (** Get an integer in base 256 notation, big endian. Negative values are represented using two's complement (i.e. the first array element is >= 128). The empty array means 0. *) val get_int : int_value -> int (** Get an integer as [int] if representable, or raise [Out_of_range] *) val get_int32 : int_value -> int32 (** Get an integer as [int32] if representable, or raise [Out_of_range] *) val get_int64 : int_value -> int64 (** Get an integer as [int64] if representable, or raise [Out_of_range] *) val get_real_str : real_value -> string (** Get the byte representation of the real *) val get_bitstring_size : bitstring_value -> int (** Get the number of bits *) val get_bitstring_data : bitstring_value -> string (** Get the data. The last byte may be partial. The order of the bits in every byte: bit 7 (MSB) contains the first bit *) val get_bitstring_bits : bitstring_value -> bool array (** Get the bitstring as bool array *) val get_time_str : time_value -> string (** Get the raw time string *) val get_time : time_value -> Netdate.t (** Get the time. Notes: - UTCTime years are two-digit years, and interpreted so that 0-49 is understood as 2000-2049, and 50-99 is understood as 1950-1999 (as required by X.509). - [get_time_nsec] returns the fractional part as nanoseconds. Higher resolutions than that are truncated. - This function is restricted to the time formats occurring in DER *) val equal : value -> value -> bool (** Checks for equality. Notes: - [Tag] and [Tagptr] are considered different - [Tagptr] is checked by comparing the equality of the substring - [Set] is so far not compared as set, but as sequence (i.e. order matters) *) end val decode_ber : ?pos:int -> ?len:int -> string -> int * Value.value (** Decodes a BER-encoded ASN.1 value. Note that DER is a subset of BER, and can also be decoded. [pos] and [len] may select a substring for the decoder. By default, [pos=0], and [len] as large as necessary to reach to the end of the string. The function returns the number of interpreted bytes, and the value. It is not considered as an error if less than [len] bytes are consumed. The returned value represents implicitly tagged values as [Tagptr(class,tag,pc,pos,len)]. [pos] and [len] denote the substring containting the contents. Use {!Netasn1.decode_ber_contents} to further decode the value. You can use [Tag] to put the decoded value back into the tree. *) val decode_ber_contents : ?pos:int -> ?len:int -> ?indefinite:bool -> string -> Value.pc -> Type_name.type_name -> int * Value.value (** Decodes the BER-encoded contents of a data field. The contents are assumed to have the type denoted by [type_name]. [pos] and [len] may select a substring for the decoder. By default, [pos=0], and [len] as large as necessary to reach to the end of the string. If [indefinite], the extent of the contents region is considered as indefinite, and the special end marker is required. This is only allowed when [pc = Constructed]. The function returns the number of interpreted bytes, and the value. It is not considered as an error if less than [len] bytes are consumed. You need to use this function to recursively decode tagged values. If you get a [Tagptr(class,tag,pc,s,pos,len)] value, it depends on the kind of the tag how to proceed: - For explicit tags just invoke {!Netasn1.decode_ber} again with the given [pos] and [len] parameters. - For implicit tags you need to know the type of the field. Now call {!Netasn1.decode_ber_contents} with the right type name. The BER encoding doesn't include whether the tag is implicit or explicit, so the decode cannot do by itself the right thing here. *) val decode_ber_length : ?pos:int -> ?len:int -> string -> int (** Like [decode_ber], but returns only the length. This function skips many consistency checks. *) val decode_ber_header : ?pos:int -> ?len:int -> ?skip_length_check:bool -> string -> (int * Value.tag_class * Value.pc * int * int option) (** [let (hdr_len, tc, pc, tag, len_opt) = decode_ber_header s]: Decodes only the header: - [hdr_len] will be the length of the header in bytes - [tc] is the tag class - [pc] whether primitive or constructed - [tag] is the numeric tag value - [len_opt] is the length field, or [None] if the header selects indefinite length If [skip_length_check] is set, the function does not check whether the string is long enough to hold the whole data part. *) ocamlnet-4.0.4/src/netstring/netmech_digest.ml0000644000175000017500000005153212541553661020103 0ustar gerdgerd(* $Id: netmech_digest.ml 2211 2015-01-13 12:08:24Z gerd $ *) (* Unit tests: tests/netstring/bench/test_netmech.ml (SASL only) *) (* The core of digest authentication *) (* What is implemented in the client (when H is the name of the hash function): - HTTP: RFC-2069 mode - HTTP: RFC-2617 mode: qop="auth", both H and H-sess - HTTP: charset is iso-8859-1 - HTTP: user name hashing - SASL mode: qop="auth", H-sess, charset=utf-8 What is implemented in the server: - HTTP: NO RFC-2069 mode - HTTP: RFC-2617 mode: qop="auth", both H and H-sess (selected by ss.snosess) - HTTP: NO user name hashing - HTTP: charset can be iso-8859-1 or utf-8 - SASL mode: qop="auth", H-sess, charset=utf-8 So far: H=MD5. We are prepared for other hash functions, though. *) open Printf module StrMap = Map.Make(String) module StrSet = Set.Make(String) type ptype = [ `SASL | `HTTP ] type profile = { ptype : ptype; hash_functions : Netsys_digests.iana_hash_fn list; (* The server will only use the first one. The client will accept any of these *) mutual : bool; (* Only for clients: whether it is required that the server includes (for HTTP) or includes the right rspauth header. *) } type response_params = { r_ptype : ptype; r_hash : Netsys_digests.iana_hash_fn; r_no_sess : bool; (* simple scheme w/o -sess. Only HTTP *) r_rfc2069 : bool; r_user : string; (* UTF-8 or ISO-8859-1 *) r_authz : string option; r_realm : string; (* UTF-8 or ISO-8859-1 *) r_nonce : string; r_cnonce : string; r_nc : int; r_method : string; r_digest_uri : string; r_utf8 : bool; r_opaque : string option; (* only HTTP *) r_domain : string list; (* only HTTP *) r_userhash : bool; (* only HTTP *) } type credentials = (string * string * (string * string) list) list type server_session = { mutable sstate : Netsys_sasl_types.server_state; mutable sresponse : (response_params * string * string) option; mutable snextnc : int; mutable sstale : bool; mutable snonce : string; srealm : string option; (* always UTF-8 *) sprofile : profile; sutf8 : bool; (* whether to use UTF-8 on the wire *) snosess : bool; lookup : string -> string -> credentials option; } let create_nonce() = let nonce_data = String.create 16 in Netsys_rng.fill_random nonce_data; Netencoding.to_hex nonce_data let hash iana_name = if iana_name = `MD5 then Digest.string else Netsys_digests.digest_string (Netsys_digests.iana_find iana_name) let hash_available iana_name = iana_name = `MD5 || ( try ignore(Netsys_digests.iana_find iana_name); true with Not_found -> false ) (* Quotes strings: *) let qstring = Nethttp.qstring_of_value let hex s = Netencoding.to_hex ~lc:true s let compute_response (p:response_params) password a2_prefix = (* a2_prefix: either "AUTHENTICATE:" or ":" *) let nc = sprintf "%08x" p.r_nc in (* eprintf "compute_response user=%s authz=%s realm=%s password=%s nonce=%s cnonce=%s digest-uri=%s nc=%s a2_prefix=%s\n" p.r_user (match p.r_authz with None -> "n/a" | Some a -> a) p.r_realm password p.r_nonce p.r_cnonce p.r_digest_uri nc a2_prefix; *) (* Note that RFC-2617 has an error here (it would calculate a1_a = hex (h ...)), and this made it into the standard. So DIGEST-MD5 as SASL is incompatible with Digest Authentication for HTTP. *) let h = hash p.r_hash in let a1 = if p.r_no_sess then p.r_user ^ ":" ^ p.r_realm ^ ":" ^ password else let a1_a = h (p.r_user ^ ":" ^ p.r_realm ^ ":" ^ password) in let a1_a = match p.r_ptype with | `HTTP -> hex a1_a (* see comment above *) | `SASL -> a1_a in let a1_b = a1_a ^ ":" ^ p.r_nonce ^ ":" ^ p.r_cnonce in match p.r_authz with | None -> a1_b | Some authz -> a1_b ^ ":" ^ authz in let a2 = a2_prefix ^ p.r_digest_uri in let auth_body = if p.r_rfc2069 then (* RFC 2069 mode *) [ hex (h a1); p.r_nonce; hex (h a2) ] else [ hex (h a1); p.r_nonce; nc; p.r_cnonce; "auth"; hex (h a2) ] in hex (h (String.concat ":" auth_body)) let verify_utf8 s = try Netconversion.verify `Enc_utf8 s with _ -> failwith "UTF-8 mismatch" let to_utf8 is_utf8 s = (* Convert from client encoding to UTF-8 *) if is_utf8 then ( verify_utf8 s; s ) else (* it is ISO-8859-1 *) Netconversion.convert ~in_enc:`Enc_iso88591 ~out_enc:`Enc_utf8 s let to_client is_utf8 s = (* Convert from UTF-8 to client encoding *) if is_utf8 then ( verify_utf8 s; s (* client uses utf-8, too *) ) else try Netconversion.convert ~in_enc:`Enc_utf8 ~out_enc:`Enc_iso88591 s with | Netconversion.Malformed_code -> failwith "cannot convert to ISO-8859-1" let to_strmap l = (* will raise Not_found if a key appears twice *) fst (List.fold_left (fun (m,s) (name,value) -> if StrSet.mem name s then raise Not_found; (StrMap.add name value m, StrSet.add name s) ) (StrMap.empty, StrSet.empty) l ) let space_re = Netstring_str.regexp "[ \t]+" let space_split = Netstring_str.split space_re let nc_re = let hex = "[0-9a-f]" in Netstring_str.regexp (hex ^ hex ^ hex ^ hex ^ hex ^ hex ^ hex ^ hex ^ "$") let get_nc s = match Netstring_str.string_match nc_re s 0 with | None -> raise Not_found | Some _ -> ( try int_of_string ("0x" ^ s) with Failure _ -> raise Not_found ) let server_emit_initial_challenge_kv ?(quote=false) ss = (* for HTTP: "domain" is not returned *) let q s = if quote then qstring s else s in let h = List.hd ss.sprofile.hash_functions in let h_name = List.assoc h Netsys_digests.iana_rev_alist in let l = ( match ss.srealm with | None -> [] | Some realm -> [ "realm", q (to_utf8 ss.sutf8 realm) ] ) @ [ "nonce", q ss.snonce; "qpop", "auth" ] @ ( if ss.sstale then [ "stale", "true" ] else [] ) @ ( if ss.sutf8 then [ "charset", "utf-8" ] else [] ) @ [ "algorithm", String.uppercase h_name ^ (if ss.snosess then "" else "-sess") ] in ss.sstate <- `Wait; ss.sstale <- false; l let server_emit_final_challenge_kv ?(quote=false) ss = let q s = if quote then qstring s else s in match ss.sresponse with | None -> assert false | Some(rp,_,srv_resp) -> ss.sstate <- `OK; [ "rspauth", q srv_resp ] @ ( match ss.sprofile.ptype with | `SASL -> [] | `HTTP -> [ "qop", "auth"; "cnonce", q rp.r_cnonce; "nc", sprintf "%08x" rp.r_nc ] ) let iana_sess_alist = List.map (fun (name,code) -> (name ^ "-sess", code)) Netsys_digests.iana_alist let decode_response ptype msg_params method_name = let m = to_strmap msg_params in let user = StrMap.find "username" m in let realm = try StrMap.find "realm" m with Not_found -> "" in let nonce = StrMap.find "nonce" m in (* We only support qop="auth" in server mode, so there is always a cnonce and nc. *) let qop = StrMap.find "qop" m in if qop <>"auth" then failwith "bad qop"; let cnonce = StrMap.find "cnonce" m in let nc_str = StrMap.find "nc" m in let nc = get_nc nc_str in let digest_uri_name = match ptype with | `HTTP -> "uri" | `SASL -> "digest-uri" in let digest_uri = StrMap.find digest_uri_name m in let response = StrMap.find "response" m in let utf8 = if StrMap.mem "charset" m then ( let v = StrMap.find "charset" m in if v <> "utf-8" then failwith "bad charset"; true ) else false in let opaque = try Some(StrMap.find "opaque" m) with Not_found -> None in let authz0 = try Some(StrMap.find "authzid" m) with Not_found -> None in let authz = if authz0 = Some "" then None else authz0 in let userhash = try StrMap.find "userhash" m = "true" with Not_found -> false in let alg_lc = try StrMap.find "algorithm" m with Not_found -> "" in let hash, no_sess = try (List.assoc alg_lc Netsys_digests.iana_alist, true) with Not_found -> try (List.assoc alg_lc iana_sess_alist, false) with Not_found -> match ptype with | `SASL -> (`MD5, false) | `HTTP -> raise Not_found in let r = { r_ptype = ptype; r_hash = hash; r_no_sess = no_sess; r_user = user; r_authz = authz; r_realm = realm; r_nonce = nonce; r_cnonce = cnonce; r_nc = nc; r_method = method_name; r_digest_uri = digest_uri; r_utf8 = utf8; r_rfc2069 = false; (* not in the server *) r_opaque = opaque; r_domain = []; (* not repeated in response *) r_userhash = userhash; } in (r, response) let validate_response ss r response = let realm_utf8 = to_utf8 r.r_utf8 r.r_realm in ( match ss.srealm with | None -> () | Some expected_realm -> if expected_realm <> realm_utf8 then failwith "bad realm"; ); if r.r_hash <> List.hd ss.sprofile.hash_functions then failwith "unexpected hash function"; if r.r_no_sess <> ss.snosess then failwith "parameter mismatch"; if r.r_userhash then failwith "user name hashing not supported"; (* not supported on server side *) let user_utf8 = to_utf8 r.r_utf8 r.r_user in let authz = match r.r_authz with | None -> "" | Some authz -> verify_utf8 authz; authz in let password_utf8 = match ss.lookup user_utf8 authz with | None -> failwith "bad user" | Some creds -> Netsys_sasl_util.extract_password creds in let password = to_client r.r_utf8 password_utf8 in let expected_response = compute_response r password (r.r_method ^ ":") in if response <> expected_response then failwith "bad password"; password exception Restart of string let server_process_response_kv ss msg_params method_name = try let (r, response) = decode_response ss.sprofile.ptype msg_params method_name in if r.r_nc > 1 then raise(Restart r.r_nonce); if ss.sstate <> `Wait then raise Not_found; let password = validate_response ss r response in (* success: *) let srv_response = compute_response r password ":" in ss.snextnc <- r.r_nc + 1; ss.sresponse <- Some(r, response, srv_response); ss.sstate <- `Emit; with | Failure msg -> ss.sstate <- `Auth_error msg | Not_found -> ss.sstate <- `Auth_error "unspecified" | Restart id -> ss.sstate <- `Restart id let server_process_response_restart_kv ss msg_params set_stale method_name = try let old_r = match ss.sresponse with | None -> assert false | Some (r, _, _) -> r in let (new_r, response) = decode_response ss.sprofile.ptype msg_params method_name in if old_r.r_hash <> new_r.r_hash || old_r.r_no_sess <> new_r.r_no_sess || old_r.r_user <> new_r.r_user || old_r.r_authz <> new_r.r_authz || old_r.r_realm <> new_r.r_realm || old_r.r_nonce <> new_r.r_nonce || old_r.r_cnonce <> new_r.r_cnonce || old_r.r_nc + 1 <> new_r.r_nc (* || old_r.r_digest_uri <> new_r.r_digest_uri *) (* CHECK *) || old_r.r_utf8 <> new_r.r_utf8 then raise Not_found; let password = validate_response ss new_r response in (* success *) if set_stale then ( ss.sstale <- true; raise Not_found ) else ( let srv_response = compute_response new_r password ":" in ss.snextnc <- new_r.r_nc + 1; ss.sresponse <- Some(new_r, response, srv_response); ss.sstate <- `Emit; true ) with | Failure _ | Not_found -> ss.snonce <- create_nonce(); ss.snextnc <- 1; ss.sresponse <- None; ss.sstate <- `Emit; false let server_stash_session_i ss = let tuple = (ss.sprofile, ss.sstate, ss.sresponse, ss.snextnc, ss.sstale, ss.srealm, ss.snonce, ss.sutf8, ss.snosess) in "server,t=DIGEST;" ^ Marshal.to_string tuple [] let ss_re = Netstring_str.regexp "server,t=DIGEST;" let server_resume_session_i ~lookup s = match Netstring_str.string_match ss_re s 0 with | None -> failwith "Netmech_digest.server_resume_session" | Some m -> let p = Netstring_str.match_end m in let data = String.sub s p (String.length s - p) in let (sprofile,sstate, sresponse, snextnc, sstale, srealm, snonce, sutf8, snosess) = Marshal.from_string data 0 in { sprofile; sstate; sresponse; snextnc; sstale; srealm; snonce; sutf8; snosess; lookup } let server_prop_i ss key = match key with | "nonce" -> ss.snonce | _ -> ( match ss.sresponse with | None -> raise Not_found | Some(rp,_,_) -> match key with | "digest-uri" | "uri" -> rp.r_digest_uri | "cnonce" -> rp.r_cnonce | "nc" -> string_of_int rp.r_nc | "realm" -> (* may be in ISO-8859-1 *) to_utf8 rp.r_utf8 rp.r_realm | _ -> raise Not_found ) type client_session = { mutable cstate : Netsys_sasl_types.client_state; mutable cresp : response_params option; cdigest_uri : string; cmethod : string; cprofile : profile; crealm : string option; (* always UTF-8 *) cuser : string; (* always UTF-8 *) cauthz : string; (* always UTF-8 *) cpasswd : string; (* always UTF-8 *) mutable cnonce : string; } let client_restart_i cs = match cs.cresp with | None -> assert false | Some rp -> let rp_next = { rp with r_nc = rp.r_nc+1 } in cs.cresp <- Some rp_next; cs.cstate <- `Emit let client_process_final_challenge_kv cs msg_params = try if cs.cstate <> `Wait then raise Not_found; if cs.cprofile.mutual then ( let m = to_strmap msg_params in let rspauth = StrMap.find "rspauth" m in match cs.cresp with | None -> raise Not_found | Some rp -> let pw = to_client rp.r_utf8 cs.cpasswd in let resp = compute_response rp pw ":" in if resp <> rspauth then raise Not_found; cs.cstate <- `OK; ) else cs.cstate <- `OK with | Failure msg -> cs.cstate <- `Auth_error msg | Not_found -> cs.cstate <- `Auth_error "cannot authenticate server" let client_process_initial_challenge_kv cs msg_params = try if cs.cstate <> `Wait then raise Not_found; let m = to_strmap msg_params in let utf8 = try StrMap.find "charset" m = "utf-8" with Not_found -> false in (* UTF-8: we encode our message in UTF-8 when the server sets the utf-8 attribute *) let realm = try StrMap.find "realm" m with Not_found -> match cs.crealm with | Some r -> to_client utf8 r | None -> "" in let nonce = StrMap.find "nonce" m in let qop_s, rfc2069 = try (StrMap.find "qop" m, false) with Not_found -> ("auth", true) in let qop_l = space_split qop_s in if not (List.mem "auth" qop_l) then failwith "bad qop"; let stale = try StrMap.find "stale" m = "true" with Not_found -> false in if stale && cs.cresp = None then raise Not_found; if cs.cprofile.ptype = `SASL && not utf8 then failwith "missing utf-8"; let opaque = try Some(StrMap.find "opaque" m) with Not_found -> None in let domain = try space_split (StrMap.find "domain" m) with Not_found -> [] in let alg_lc = try String.lowercase(StrMap.find "algorithm" m) with Not_found when cs.cprofile.ptype = `HTTP -> "md5" in let hash, no_sess = try (List.assoc alg_lc Netsys_digests.iana_alist, true) with Not_found -> (List.assoc alg_lc iana_sess_alist, false) in let userhash = try StrMap.find "userhash" m = "true" with Not_found -> false in if cs.cprofile.ptype = `SASL && no_sess then raise Not_found; if not (List.mem hash cs.cprofile.hash_functions) then failwith "unsupported hash function"; (* If this is an initial challenge after we tried to resume the old session, we need a new conce *) let cnonce = match cs.cresp with | None -> cs.cnonce | Some _ -> create_nonce() in cs.cnonce <- cnonce; let rp = { r_ptype = cs.cprofile.ptype; r_hash = hash; r_no_sess = no_sess; r_user = to_client utf8 cs.cuser; r_authz = if cs.cauthz="" then None else Some(to_client utf8 cs.cauthz); r_realm = realm; r_nonce = nonce; r_cnonce = cnonce; r_nc = 1; r_method = cs.cmethod; r_digest_uri = cs.cdigest_uri; r_utf8 = utf8; r_rfc2069 = cs.cprofile.ptype=`HTTP && rfc2069; r_opaque = opaque; r_domain = domain; r_userhash = userhash; } in cs.cresp <- Some rp; cs.cstate <- if stale then `Stale else `Emit; with | Failure msg -> cs.cstate <- `Auth_error msg | Not_found -> cs.cstate <- `Auth_error "unspecified" let client_modify ?mod_method ?mod_uri cs = match cs.cresp with | None -> invalid_arg "Netmech_digest.client_modify" | Some rp -> let rp1 = { rp with r_method = (match mod_method with | None -> rp.r_method | Some m -> m ); r_digest_uri = (match mod_uri with | None -> rp.r_digest_uri | Some u -> u ) } in cs.cresp <- Some rp1 let client_emit_response_kv ?(quote=false) cs = (* SASL: method_name="AUTHENTICATE" *) let q s = if quote then qstring s else s in match cs.cresp with | None -> assert false | Some rp -> let pw = to_client rp.r_utf8 cs.cpasswd in let resp = compute_response rp pw (rp.r_method ^ ":") in let digest_uri_name = match cs.cprofile.ptype with | `SASL -> "digest-uri" | `HTTP -> "uri" in let username = if rp.r_userhash then let h = hash rp.r_hash in h (rp.r_user ^ ":" ^ rp.r_realm) else rp.r_user in let l = [ "username", q username; "realm", q rp.r_realm; "nonce", q rp.r_nonce; digest_uri_name, q rp.r_digest_uri; "response", q resp; ] @ ( if rp.r_rfc2069 then [] else [ "cnonce", q rp.r_cnonce; "nc", sprintf "%08x" rp.r_nc; "qop", "auth"; ] ) @ ( if rp.r_utf8 then [ "charset", "utf-8" ] else [] ) @ ( match rp.r_authz with | None -> [] | Some authz -> [ "authzid", q authz ] ) @ ( match rp.r_opaque with | None -> [] | Some s -> [ "opaque", q s ] ) @ ( if rp.r_ptype = `SASL && rp.r_hash = `MD5 then [] else let alg = String.uppercase (List.assoc rp.r_hash Netsys_digests.iana_rev_alist) in let suffix = if rp.r_no_sess then "" else "-sess" in [ "algorithm", alg ^ suffix ] ) in cs.cstate <- (if cs.cprofile.mutual then `Wait else `OK); l let client_stash_session_i cs = "client,t=DIGEST;" ^ Marshal.to_string cs [] let cs_re = Netstring_str.regexp "client,t=DIGEST;" let client_resume_session_i s = match Netstring_str.string_match cs_re s 0 with | None -> failwith "Netmech_digest.client_resume_session" | Some m -> let p = Netstring_str.match_end m in let data = String.sub s p (String.length s - p) in let cs = Marshal.from_string data 0 in (cs : client_session) let client_prop_i cs key = match key with | "cnonce" -> cs.cnonce | "digest-uri" | "uri" -> cs.cdigest_uri | _ -> (match cs.cresp with | None -> raise Not_found | Some rp -> match key with | "realm" -> rp.r_realm | "nonce" -> rp.r_nonce | "nc" -> string_of_int rp.r_nc | _ -> raise Not_found ) ocamlnet-4.0.4/src/netstring/netulex.ml0000644000175000017500000002665412541553661016614 0ustar gerdgerd(* $Id: netulex.ml 799 2004-07-08 23:04:25Z stolpmann $ * ---------------------------------------------------------------------- * PXP: The polymorphic XML parser for Objective Caml. * Copyright by Gerd Stolpmann. See LICENSE for details. *) module ULB = struct open Netaux.ArrayAux open Netconversion type unicode_lexbuf = { mutable ulb_encoding : encoding; mutable ulb_encoding_start : int; mutable ulb_rawbuf : string; mutable ulb_rawbuf_len : int; mutable ulb_rawbuf_end : int; mutable ulb_rawbuf_const : bool; mutable ulb_chars : int array; mutable ulb_chars_pos : int array; mutable ulb_chars_len : int; mutable ulb_eof : bool; mutable ulb_refill : string -> int -> int -> int; mutable ulb_enc_change_hook : unicode_lexbuf -> unit; mutable ulb_cursor : cursor } let from_function ?(raw_size = 512) ?(char_size = 250) ?(enc_change_hook = fun _ -> ()) ~refill enc = { ulb_encoding = enc; ulb_encoding_start = 0; ulb_rawbuf = String.create raw_size; ulb_rawbuf_len = 0; ulb_rawbuf_end = 0; ulb_rawbuf_const = false; ulb_chars = Array.make char_size (-1); ulb_chars_pos = ( let cp = Array.make (char_size+1) (-1) in cp.(0) <- 0; cp ); ulb_chars_len = 0; ulb_eof = false; ulb_refill = refill; ulb_enc_change_hook = enc_change_hook; ulb_cursor = create_cursor enc ""; } let from_in_obj_channel ?raw_size ?char_size ?enc_change_hook enc inch = let refill s k l = try let n = inch # input s k l in if n=0 then failwith "Netulex.ULB.from_in_obj_channel: non-blocking channel"; n with End_of_file -> 0 in from_function ?raw_size ?char_size ?enc_change_hook ~refill enc let from_string ?(enc_change_hook = fun _ -> ()) enc s = let char_size = 250 in { ulb_encoding = enc; ulb_encoding_start = 0; ulb_rawbuf = String.copy s; ulb_rawbuf_len = String.length s; ulb_rawbuf_end = 0; ulb_rawbuf_const = true; ulb_chars = Array.make char_size (-1); ulb_chars_pos = ( let cp = Array.make (char_size+1) (-1) in cp.(0) <- 0; cp ); ulb_chars_len = 0; ulb_eof = true; ulb_refill = (fun _ _ _ -> assert false); ulb_enc_change_hook = enc_change_hook; ulb_cursor = create_cursor enc ""; } let from_string_inplace ?(enc_change_hook = fun _ -> ()) enc s = let char_size = 250 in { ulb_encoding = enc; ulb_encoding_start = 0; ulb_rawbuf = s; ulb_rawbuf_len = String.length s; ulb_rawbuf_end = 0; ulb_rawbuf_const = true; ulb_chars = Array.make char_size (-1); ulb_chars_pos = ( let cp = Array.make (char_size+1) (-1) in cp.(0) <- 0; cp ); ulb_chars_len = 0; ulb_eof = true; ulb_refill = (fun _ _ _ -> assert false); ulb_enc_change_hook = enc_change_hook; ulb_cursor = create_cursor enc ""; } let delete n ulb = if n < 0 || n > ulb.ulb_chars_len then invalid_arg "Netulex.ULB.delete"; let m = ulb.ulb_chars_len - n in int_blit ulb.ulb_chars n ulb.ulb_chars 0 m; int_blit ulb.ulb_chars_pos n ulb.ulb_chars_pos 0 (m+1); if not ulb.ulb_rawbuf_const then ( let k = ulb.ulb_chars_pos.(0) in assert (ulb.ulb_rawbuf_end >= k); let m' = ulb.ulb_rawbuf_len - k in String.blit ulb.ulb_rawbuf k ulb.ulb_rawbuf 0 m'; let cp = ulb.ulb_chars_pos in for i = 0 to m do cp.(i) <- cp.(i) - k done; ulb.ulb_rawbuf_len <- m'; ulb.ulb_rawbuf_end <- ulb.ulb_rawbuf_end - k; ); ulb.ulb_chars_len <- m; ulb.ulb_encoding_start <- max 0 (ulb.ulb_encoding_start - n) let set_encoding enc ulb = if enc <> ulb.ulb_encoding then ( ulb.ulb_encoding <- enc; ulb.ulb_encoding_start <- ulb.ulb_chars_len; ulb.ulb_enc_change_hook ulb ) let close ulb = ulb.ulb_eof <- true let utf8_sub_string k n ulb = if k < 0 || k > ulb.ulb_chars_len || n < 0 || k+n > ulb.ulb_chars_len then invalid_arg "Netulex.ULB.utf8_sub_string"; if ulb.ulb_encoding = `Enc_utf8 && k >= ulb.ulb_encoding_start then ( (* Extract the substring from [ulb_rawbuf] ! *) let k' = ulb.ulb_chars_pos.(k) in let n' = ulb.ulb_chars_pos.(k+n) - k' in String.sub ulb.ulb_rawbuf k' n' ) else ( (* Create the UTF-8 string from [ulb_chars] *) ustring_of_uarray `Enc_utf8 ~pos:k ~len:n ulb.ulb_chars ) let utf8_sub_string_length k n ulb = if k < 0 || k > ulb.ulb_chars_len || n < 0 || k+n > ulb.ulb_chars_len then invalid_arg "Netulex.ULB.utf8_sub_string_length"; if ulb.ulb_encoding = `Enc_utf8 && k >= ulb.ulb_encoding_start then ( (* Extract the substring from [ulb_rawbuf] ! *) let k' = ulb.ulb_chars_pos.(k) in let n' = ulb.ulb_chars_pos.(k+n) - k' in n' ) else ( (* Count the UTF-8 string from [ulb_chars] *) (* Maybe better algorithm: divide into several slices, and call * ustring_of_uarray for them. Goal: Reduction of memory allocation *) let conv = ustring_of_uchar `Enc_utf8 in let n' = ref 0 in for i = k to k+n-1 do n' := !n' + String.length (conv ulb.ulb_chars.(i)) done; !n' ) let rec refill_aux ulb = (* Check whether we cannot add at least one byte to [ulb_chars] because * of EOF: *) if ulb.ulb_eof && ulb.ulb_rawbuf_len = ulb.ulb_rawbuf_end then 0 else ( (* Enlarge [ulb_chars] if necessary (need at least space for one character) *) if ulb.ulb_chars_len >= Array.length ulb.ulb_chars then ( let n = min (Sys.max_array_length-1) (2 * (Array.length ulb.ulb_chars)) in if n = Array.length ulb.ulb_chars then failwith "Netulex.ULB.refill: array too large"; let c = Array.make n (-1) in let cp = Array.make (n+1) (-1) in int_blit ulb.ulb_chars 0 c 0 ulb.ulb_chars_len; int_blit ulb.ulb_chars_pos 0 cp 0 (ulb.ulb_chars_len+1); ulb.ulb_chars <- c; ulb.ulb_chars_pos <- cp; ); (* If there is unanalysed material in [ulb_rawbuf], try to convert it. * It may happen, however, that there is only the beginning of a * multi-byte character, so this may not add any new character. *) let new_chars = if ulb.ulb_rawbuf_end < ulb.ulb_rawbuf_len then ( let cs = ulb.ulb_cursor in reinit_cursor ~range_pos:ulb.ulb_rawbuf_end ~range_len:(ulb.ulb_rawbuf_len - ulb.ulb_rawbuf_end) ~enc:ulb.ulb_encoding ulb.ulb_rawbuf cs; let counter = ref 0 in ( try while ulb.ulb_chars_len < Array.length ulb.ulb_chars do let space = Array.length ulb.ulb_chars - ulb.ulb_chars_len in (* cursor_blit may raise End_of_string, too *) let n = cursor_blit cs ulb.ulb_chars ulb.ulb_chars_len space in let n' = cursor_blit_positions cs ulb.ulb_chars_pos ulb.ulb_chars_len space in assert(n=n'); if n>0 then ( ulb.ulb_chars_len <- ulb.ulb_chars_len+n; counter := !counter + n; move ~num:n cs; (* may raise Malformed_code *) ) else ( (* We are at a special position in the string! *) try ignore(uchar_at cs); assert false with Byte_order_mark -> (* Skip the BOM: *) move cs (* may raise Malformed_code *) (* Note: this [move] does not count *) | Partial_character -> (* Stop here *) raise Exit (* End_of_string: already handled *) ) done with Exit -> () | End_of_string -> () ); let e = cursor_pos cs; in ulb.ulb_chars_pos.(ulb.ulb_chars_len) <- e; ulb.ulb_rawbuf_end <- e; (* Encoding might have changed: *) set_encoding (cursor_encoding cs) ulb; !counter ) else 0 in (* In the case we still did not add any char: Check if we are near * EOF (the last multi-byte character is not complete). *) if new_chars = 0 then ( if ulb.ulb_eof then raise Malformed_code; assert(not ulb.ulb_rawbuf_const); (* Now try to get new data into [ulb_rawbuf]. First, we check whether * we have enough free space in this buffer. We insist on at least * 50 bytes (quite arbitrary...). Then call the [ulb_refill] function * to get the data. *) if ulb.ulb_rawbuf_len + 50 >= String.length ulb.ulb_rawbuf then ( let n = min Sys.max_string_length (2 * (String.length ulb.ulb_rawbuf)) in if n = String.length ulb.ulb_rawbuf then failwith "Netulex.ULB.refill: string too large"; let s = String.create n in String.blit ulb.ulb_rawbuf 0 s 0 ulb.ulb_rawbuf_len; ulb.ulb_rawbuf <- s; ); (* Call now [ulb_refill]. If we detect EOF, record this. Anyway, * start over. *) let space = (String.length ulb.ulb_rawbuf) - ulb.ulb_rawbuf_len in let n = ulb.ulb_refill ulb.ulb_rawbuf ulb.ulb_rawbuf_len space in assert(n>=0); if n=0 then ( (* EOF *) ulb.ulb_eof <- true; ) else ( ulb.ulb_rawbuf_len <- ulb.ulb_rawbuf_len + n ); refill_aux ulb ) else new_chars ) let refill ulb = let n = refill_aux ulb in assert(n>=0); if n=0 then ( assert(ulb.ulb_eof); assert(ulb.ulb_rawbuf_len = ulb.ulb_rawbuf_end); raise End_of_file ) end module Ulexing = struct type lexbuf = { ulb : ULB.unicode_lexbuf; mutable offset : int; mutable pos : int; mutable start : int; mutable marked_pos : int; mutable marked_val : int; } exception Error let from_ulb_lexbuf ulb = { ulb = ulb; offset = 0; pos = 0; start = 0; marked_pos = 0; marked_val = 0; } let lexeme_start lexbuf = lexbuf.start + lexbuf.offset let lexeme_end lexbuf = lexbuf.pos + lexbuf.offset let lexeme_length lexbuf = lexbuf.pos - lexbuf.start let lexeme lexbuf = let buf = lexbuf.ulb.ULB.ulb_chars in Array.sub buf lexbuf.start (lexbuf.pos - lexbuf.start) let sub_lexeme lexbuf pos len = let buf = lexbuf.ulb.ULB.ulb_chars in Array.sub buf (lexbuf.start + pos) len let lexeme_char lexbuf pos = let buf = lexbuf.ulb.ULB.ulb_chars in buf.(lexbuf.start + pos) let utf8_lexeme lexbuf = ULB.utf8_sub_string lexbuf.start (lexbuf.pos - lexbuf.start) lexbuf.ulb let utf8_sub_lexeme lexbuf pos len = ULB.utf8_sub_string (lexbuf.start + pos) len lexbuf.ulb let utf8_sub_lexeme_length lexbuf pos len = ULB.utf8_sub_string_length (lexbuf.start + pos) len lexbuf.ulb (* "Internal" interface *) let start lexbuf = lexbuf.start <- lexbuf.pos; lexbuf.marked_pos <- lexbuf.pos; lexbuf.marked_val <- (-1) let mark lexbuf i = lexbuf.marked_pos <- lexbuf.pos; lexbuf.marked_val <- i let backtrack lexbuf = lexbuf.pos <- lexbuf.marked_pos; lexbuf.marked_val let rollback lexbuf = lexbuf.pos <- lexbuf.start let eof = (-1) let refill lexbuf = try (* Delete all characters in ulexbuf before the current lexeme: *) if lexbuf.start > 0 then ( let n = lexbuf.start in ULB.delete n lexbuf.ulb; lexbuf.offset <- lexbuf.offset + n; lexbuf.pos <- lexbuf.pos - n; lexbuf.marked_pos <- lexbuf.marked_pos - n; lexbuf.start <- 0; ); ULB.refill lexbuf.ulb; (* raises either End_of_file, or ensures there is one char in ulb *) lexbuf.ulb.ULB.ulb_chars.(lexbuf.pos) with End_of_file -> (* We cannot modify the buffer as the original Ulexing implementation *) eof let next lexbuf = let ulb = lexbuf.ulb in let i = if lexbuf.pos = ulb.ULB.ulb_chars_len then refill lexbuf else ulb.ULB.ulb_chars.(lexbuf.pos) in if i <> eof then lexbuf.pos <- lexbuf.pos + 1; i end ocamlnet-4.0.4/src/netstring/nethtml.mli0000644000175000017500000003776412541553661016760 0ustar gerdgerd(* $Id: nethtml.mli 2244 2015-06-21 13:07:46Z gerd $ * ---------------------------------------------------------------------- * *) (** Parsing of HTML *) (** The type [document] represents parsed HTML documents: * * {ul * {- [Element (name, args, subnodes)] is an element node for an element of * type [name] (i.e. written [...]) with arguments [args] * and subnodes [subnodes] (the material within the element). The arguments * are simply name/value pairs. Entity references (something like [&xy;]) * occuring in the values are {b not} resolved. * * Arguments without values (e.g. [