[Pkg-sks-commit] r236 - in sks/branches/upstream/sks/current: . bdb sampleConfig sampleConfig/debian sampleWeb sampleWeb/HTML5 sampleWeb/OpenPKG sampleWeb/XHTML+ES
Christoph Martin
chrism at alioth.debian.org
Wed May 30 15:11:06 UTC 2012
Author: chrism
Date: 2012-05-30 15:11:05 +0000 (Wed, 30 May 2012)
New Revision: 236
Added:
sks/branches/upstream/sks/current/ANNOUNCEMENT
sks/branches/upstream/sks/current/BUGS
sks/branches/upstream/sks/current/CHANGELOG
sks/branches/upstream/sks/current/COPYING
sks/branches/upstream/sks/current/FILES
sks/branches/upstream/sks/current/Makefile
sks/branches/upstream/sks/current/Makefile.local.unused
sks/branches/upstream/sks/current/README
sks/branches/upstream/sks/current/TODO
sks/branches/upstream/sks/current/VERSION
sks/branches/upstream/sks/current/add_mail.ml
sks/branches/upstream/sks/current/armor.ml
sks/branches/upstream/sks/current/bdb/
sks/branches/upstream/sks/current/bdb/Makefile
sks/branches/upstream/sks/current/bdb/bdb.ml
sks/branches/upstream/sks/current/bdb/bdb_stubs.c
sks/branches/upstream/sks/current/bdb/bdb_stubs.h
sks/branches/upstream/sks/current/bdb/db.ml
sks/branches/upstream/sks/current/bdb/db.mli
sks/branches/upstream/sks/current/bdb/dbstubs.c
sks/branches/upstream/sks/current/bdb/dbstubs.h
sks/branches/upstream/sks/current/bdb/ocextr.ml
sks/branches/upstream/sks/current/bdb/script.ml
sks/branches/upstream/sks/current/bdb/temp.ml
sks/branches/upstream/sks/current/bdb/templ.c
sks/branches/upstream/sks/current/bdb/test.ml
sks/branches/upstream/sks/current/bdbwrap.ml
sks/branches/upstream/sks/current/bitstring.ml
sks/branches/upstream/sks/current/bugscript.ml
sks/branches/upstream/sks/current/build.ml
sks/branches/upstream/sks/current/cMarshal.ml
sks/branches/upstream/sks/current/catchup.ml
sks/branches/upstream/sks/current/channel.ml
sks/branches/upstream/sks/current/channel.mli
sks/branches/upstream/sks/current/clean_keydb.ml
sks/branches/upstream/sks/current/client.ml
sks/branches/upstream/sks/current/common.ml
sks/branches/upstream/sks/current/crc.c
sks/branches/upstream/sks/current/cryptokit-1.0.tar.gz
sks/branches/upstream/sks/current/dbMessages.ml
sks/branches/upstream/sks/current/dbscript.ml
sks/branches/upstream/sks/current/dbserver.ml
sks/branches/upstream/sks/current/dbtest.ml
sks/branches/upstream/sks/current/decode.ml
sks/branches/upstream/sks/current/decode_test.ml
sks/branches/upstream/sks/current/ehandlers.ml
sks/branches/upstream/sks/current/eventloop.ml
sks/branches/upstream/sks/current/fastbuild.ml
sks/branches/upstream/sks/current/fingerprint.ml
sks/branches/upstream/sks/current/fixkey.ml
sks/branches/upstream/sks/current/foo.ml
sks/branches/upstream/sks/current/fqueue.ml
sks/branches/upstream/sks/current/getfileopts.ml
sks/branches/upstream/sks/current/heap.ml
sks/branches/upstream/sks/current/heap.mli
sks/branches/upstream/sks/current/htmlTemplates.ml
sks/branches/upstream/sks/current/incdump.ml
sks/branches/upstream/sks/current/index.ml
sks/branches/upstream/sks/current/int_comparators.ml
sks/branches/upstream/sks/current/key.ml
sks/branches/upstream/sks/current/keyHash.ml
sks/branches/upstream/sks/current/keyMerge.ml
sks/branches/upstream/sks/current/keydb.ml
sks/branches/upstream/sks/current/linearAlg.ml
sks/branches/upstream/sks/current/logdump.ml
sks/branches/upstream/sks/current/mArray.ml
sks/branches/upstream/sks/current/mArray.mli
sks/branches/upstream/sks/current/mList.ml
sks/branches/upstream/sks/current/mList.mli
sks/branches/upstream/sks/current/mRindex.ml
sks/branches/upstream/sks/current/mTimer.ml
sks/branches/upstream/sks/current/mTimer.mli
sks/branches/upstream/sks/current/mailsync.ml
sks/branches/upstream/sks/current/membership.ml
sks/branches/upstream/sks/current/membership.mli
sks/branches/upstream/sks/current/merge_keyfiles.ml
sks/branches/upstream/sks/current/meteredChannel.ml
sks/branches/upstream/sks/current/msgContainer.ml
sks/branches/upstream/sks/current/nbMsgContainer.ml
sks/branches/upstream/sks/current/number.ml
sks/branches/upstream/sks/current/number.mli
sks/branches/upstream/sks/current/number2.ml
sks/branches/upstream/sks/current/number_test.ml
sks/branches/upstream/sks/current/pMap.ml
sks/branches/upstream/sks/current/pMap.mli
sks/branches/upstream/sks/current/pSet.ml
sks/branches/upstream/sks/current/pSet.mli
sks/branches/upstream/sks/current/pTreeDB.ml
sks/branches/upstream/sks/current/packet.ml
sks/branches/upstream/sks/current/parsePGP.ml
sks/branches/upstream/sks/current/pbuild.ml
sks/branches/upstream/sks/current/pdiskTest.ml
sks/branches/upstream/sks/current/poly.ml
sks/branches/upstream/sks/current/poly_test.ml
sks/branches/upstream/sks/current/prefixTree.ml
sks/branches/upstream/sks/current/prefix_test.ml
sks/branches/upstream/sks/current/prime.ml
sks/branches/upstream/sks/current/pstyle.ml
sks/branches/upstream/sks/current/ptest.ml
sks/branches/upstream/sks/current/ptree_consistency_test.ml
sks/branches/upstream/sks/current/ptree_db_test.ml
sks/branches/upstream/sks/current/ptree_replay.ml
sks/branches/upstream/sks/current/ptscript.ml
sks/branches/upstream/sks/current/query.ml
sks/branches/upstream/sks/current/rMisc.ml
sks/branches/upstream/sks/current/recode.ml
sks/branches/upstream/sks/current/reconCS.ml
sks/branches/upstream/sks/current/reconComm.ml
sks/branches/upstream/sks/current/reconMessages.ml
sks/branches/upstream/sks/current/reconPTreeDb.ml
sks/branches/upstream/sks/current/reconserver.ml
sks/branches/upstream/sks/current/recoverList.ml
sks/branches/upstream/sks/current/recvmail.ml
sks/branches/upstream/sks/current/request.ml
sks/branches/upstream/sks/current/sStream.ml
sks/branches/upstream/sks/current/sampleConfig/
sks/branches/upstream/sks/current/sampleConfig/DB_CONFIG
sks/branches/upstream/sks/current/sampleConfig/aliases.sample
sks/branches/upstream/sks/current/sampleConfig/crontab.sample
sks/branches/upstream/sks/current/sampleConfig/debian/
sks/branches/upstream/sks/current/sampleConfig/debian/README
sks/branches/upstream/sks/current/sampleConfig/debian/forward.exim
sks/branches/upstream/sks/current/sampleConfig/debian/forward.postfix
sks/branches/upstream/sks/current/sampleConfig/debian/mailsync
sks/branches/upstream/sks/current/sampleConfig/debian/membership
sks/branches/upstream/sks/current/sampleConfig/debian/procmail
sks/branches/upstream/sks/current/sampleConfig/debian/sksconf
sks/branches/upstream/sks/current/sampleConfig/mailsync
sks/branches/upstream/sks/current/sampleConfig/membership
sks/branches/upstream/sks/current/sampleConfig/procmailrc
sks/branches/upstream/sks/current/sampleConfig/rc.sks
sks/branches/upstream/sks/current/sampleConfig/sksconf.minimal
sks/branches/upstream/sks/current/sampleConfig/sksconf.typical
sks/branches/upstream/sks/current/sampleWeb/
sks/branches/upstream/sks/current/sampleWeb/HTML5/
sks/branches/upstream/sks/current/sampleWeb/HTML5/README
sks/branches/upstream/sks/current/sampleWeb/HTML5/index.html
sks/branches/upstream/sks/current/sampleWeb/HTML5/robots.txt
sks/branches/upstream/sks/current/sampleWeb/OpenPKG/
sks/branches/upstream/sks/current/sampleWeb/OpenPKG/README
sks/branches/upstream/sks/current/sampleWeb/OpenPKG/index.html
sks/branches/upstream/sks/current/sampleWeb/OpenPKG/robots.txt
sks/branches/upstream/sks/current/sampleWeb/XHTML+ES/
sks/branches/upstream/sks/current/sampleWeb/XHTML+ES/README
sks/branches/upstream/sks/current/sampleWeb/XHTML+ES/index.xhtml
sks/branches/upstream/sks/current/sampleWeb/XHTML+ES/robots.txt
sks/branches/upstream/sks/current/sampleWeb/XHTML+ES/script.es
sks/branches/upstream/sks/current/script.ml
sks/branches/upstream/sks/current/sendmail.ml
sks/branches/upstream/sks/current/server.ml
sks/branches/upstream/sks/current/settings.ml
sks/branches/upstream/sks/current/sks.ml
sks/branches/upstream/sks/current/sks.pod
sks/branches/upstream/sks/current/sks_build.bc.sh
sks/branches/upstream/sks/current/sks_build.sh
sks/branches/upstream/sks/current/sks_do.ml
sks/branches/upstream/sks/current/sksdump.ml
sks/branches/upstream/sks/current/smtp_script.py
sks/branches/upstream/sks/current/spider.ml
sks/branches/upstream/sks/current/stats.ml
sks/branches/upstream/sks/current/tester.ml
sks/branches/upstream/sks/current/tz.c
sks/branches/upstream/sks/current/unit_tests.ml
sks/branches/upstream/sks/current/update_subkeys.ml
sks/branches/upstream/sks/current/utils.ml
sks/branches/upstream/sks/current/wserver.ml
sks/branches/upstream/sks/current/zZp.ml
sks/branches/upstream/sks/current/zZp.mli
sks/branches/upstream/sks/current/zZp2.ml
Log:
[svn-upgrade] new version sks (1.1.3)
Added: sks/branches/upstream/sks/current/ANNOUNCEMENT
===================================================================
--- sks/branches/upstream/sks/current/ANNOUNCEMENT (rev 0)
+++ sks/branches/upstream/sks/current/ANNOUNCEMENT 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,25 @@
+sks-1.0.5 is released!
+
+There are a number of big changes from 1.0.4. Here are the main ones:
+
+- SKS supports indexing by subkey keyids!
+
+- The SKS executables have been merged into one, improving maintainability.
+
+ this is an important one for current SKS admins. sks_recon, sks_db,
+ sks_fastbuild, etc, are all gone. There are only two executables, sks, and
+ sks_add_mail, which is a simple script used for getting incoming emails via
+ procmail. All other functions are invoked via sks. You can see the
+ various options of sks by typing "sks help".
+
+ You can upgrade your existing SKS installation with "sks update_subkeys".
+ Note that this will take a while, and you must shut down your server during
+ the update process.
+
+ WARNING! Make sure you delete the old executables, as they won't be
+ overwritten when you install the new version.
+
+- (Untested) support for running "sks db" on two ports simultaneously. This
+ is useful for servers that want to be available on port 80 (to allow
+ access through firewalls) and on port 11371, to allow tools like GPG to
+ access the server.
Added: sks/branches/upstream/sks/current/BUGS
===================================================================
--- sks/branches/upstream/sks/current/BUGS (rev 0)
+++ sks/branches/upstream/sks/current/BUGS 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,19 @@
+* Some keyids don't come up when they should.
+ The following link comes up when you look for "minsky", but the link itself
+ doesn't work.
+
+ http://sks.dnsalias.net:11371/pks/lookup?op=get&search=0x0D4F313F
+
+---------FIXED-----------------
+
+* GPG querying is broken:
+
+ $ gpg --keyserver sks.dnsalias.net --recv-key 8B4CBC9C
+ gpg: requesting key 8B4CBC9C from HKP keyserver sks.dnsalias.net
+ gpg: [fd 3]: read error: Connection reset by peer
+ gpg: no valid OpenPGP data found.
+ gpg: premature eof while reading hashed signature data
+ gpg: key 8B4CBC9C: not changed
+ gpg: Total number processed: 1
+ gpg: unchanged: 1
+
Added: sks/branches/upstream/sks/current/CHANGELOG
===================================================================
--- sks/branches/upstream/sks/current/CHANGELOG (rev 0)
+++ sks/branches/upstream/sks/current/CHANGELOG 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,99 @@
+1.1.3
+ - Makefile fix for 'make dep' if .depend does not exist. Issue #4
+ - Makefile fix: sks and sks_add_mail fail to link w/o '-ccopt -pg'
+ Issue #23
+ - Added -disable_mailsync and -disable_log_diffs to sks.pod
+ - Added file extensions .css, .jpeg, .htm, .es, .js, .xml, .shtml, .xhtm,
+ .xhtml and associated MIME types to server code. Part of Issue #6
+ - Added sample configuration files in sampleConfig directory
+ - Added sample web page files in sampleWeb directory. Issues #7, 9, 19
+ - Allow requests for non-official options hget, hash, status, & clean to
+ be preceded by '-x'. Closes issues #10, 11, 13, & 14.
+ - Allow &search with long subkey ID (16 digit) and subkey fingerprint
+ subkey lookup was failing with other than a short key ID. However,
+ public key lookup was working with short and long key ID and fingerprints.
+ This patch makes subkey lookup behave the same as full key lookup.
+ http://lists.gnupg.org/pipermail/gnupg-users/2012-January/043495.html
+ Initial patch sumbitted by Dan McGee (dpmcgee at gmail.com).
+ Cleanup by Yaron Minsky
+ - Patch recon script so that POST includes HTTP version number.
+ Patch submitted by Daniel Kahn Gilmor
+
+1.1.2:
+ - HTML generated by SKS has been cleaned up to pass XHTML 1.0 Strict
+ without error or warnings
+ - Added HTTP/1.0 after POST, '-' added to safe characters for webserver,
+ Add '.html' (text/html) to list of supported file extensions for web server
+ - Johan van Selst's patch implementing Phil Pennock's suggestion
+ of an X-HKP-Results-Count: header to returned web server queries
+ - Johan van Selst's patch to add Content-length header to web results
+ - DB Statistics are kept for 30 days instead of 7
+ - SIGUSR2 now triggers on-demand statistics
+ - sks dump should ignore -USR1 and -USR2
+ - Remove XA support which Oracle dropped in DB 4.8 (& restored in DB 5.2)
+ - Work-around in bdb_stubs.c for DB_XA_CREATE dropped after DB 4.7
+ - Import debian patch 508_build_fastbuild.patch for improved sks_build script
+ - always display number of hashes received for better statistics in recon.log
+ - Fix 'sks dump' usage: help message syntax
+ - Fix documentation to explicit that hkp_address and recon_address can
+ contain both IP addresses and domain names.
+ - Fix documentation with ambiguity of -n when used with build and fastbuild
+ - Spelling corrections
+ - BUGFIX: do not leak the joined cursor in Keydb.get_by_words.
+
+1.1.1:
+ - Fix tail recursion for reconciliation with huge differences.
+ - fixed bug in handling of send_mailsyncs flag
+ - BUGFIX: The last word of a user id was not properly case converted.
+ - Makefile fixes
+ - imported patch sksdump-recursion
+ - imported patch reconsever-resilience
+ - imported patch multiple-addresses
+ - imported patch full-rrset
+ - imported patch dbsyc-on-sigusr1
+ - imported patch ignore-sigusr2
+ - imported patch increase-wserver-timeout
+ - imported patch spider-set-starthost
+ - imported patch spider-add-buildtarget
+ - [mq]: dns-refresh-patch
+ - imported patch spider-target-fix
+ - [mq]: pdp-smallfixes
+
+1.1.0:
+ - Numerix has been ripped out. OCaml's Big_int implementation is
+ used instead.
+ - version of Berkeley DB has been upgraded to 4.6.
+ - The sks.pod file has been added to the src tarball
+ - Some small changes to index view
+
+1.0.5:
+ - subkey indexing added
+ - removal of most executables. Now single "sks" executable used for almost
+ everything.
+ - Numerix tarball updated to include GPL notices in each file
+ - SKS files updated to include GPL notices in each file
+ - SKS can be configured to listen to two ports for HKP access.
+
+1.0.3: added simple built-in webserver so that index page can be served by
+ sks_db. This should make it easier to put sks on port 80. Also,
+ sks can now be launched from any directory, as long as the -basedir
+ command-line option is used to specify the location of the sks
+ directory.
+
+1.0.2: Serious database corruption bug in fastbuild and build fixed. Also,
+ client.ml modified to avoid Yet Another Deadlock Bug.
+
+(...many versions skipped...)
+
+0.1.3: Added interoperability with PKS-style email synchronization, plus
+ numerous bugfixes.
+
+0.1.2: Omitted key fix from above upload having to do with key fetching
+ post-reconciliation. Key fetching should work now.
+
+0.1.1: Fixed HTML response pages to work better with GPG and other automated
+ systems. Also some Makefile fixes and documentation updates.
+
+0.1.0: Initial public release
+
+
Added: sks/branches/upstream/sks/current/COPYING
===================================================================
--- sks/branches/upstream/sks/current/COPYING (rev 0)
+++ sks/branches/upstream/sks/current/COPYING 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,285 @@
+This software is only available under the GNU General Public License (GNU
+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
+
+
Added: sks/branches/upstream/sks/current/FILES
===================================================================
--- sks/branches/upstream/sks/current/FILES (rev 0)
+++ sks/branches/upstream/sks/current/FILES 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,21 @@
+BUGS
+CHANGELOG
+COPYING
+FILES
+README
+TODO
+VERSION
+Makefile
+Makefile.local.unused
+cryptokit-1.0.tar.gz
+sks_build.sh
+bdb/*.ml
+bdb/*.mli
+bdb/Makefile
+bdb/*.c
+bdb/*.h
+.depend
+*.ml
+*.mli
+*.c
+sks.pod
Added: sks/branches/upstream/sks/current/Makefile
===================================================================
--- sks/branches/upstream/sks/current/Makefile (rev 0)
+++ sks/branches/upstream/sks/current/Makefile 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,407 @@
+#
+# This file is part of SKS. SKS 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
+#
+CINCLUDES=-I`ocamlc -where`
+CC=gcc
+CXX=g++
+CFLAGS=-O3 -Werror-implicit-function-declaration $(CINCLUDES) -I .
+CXXFLAGS=-O3 $(CINCLUDES) -I .
+
+ifndef OCAMLC
+ OCAMLC=ocamlc
+endif
+ifndef OCAMLOPT
+ OCAMLOPT=ocamlopt
+endif
+ifndef CAMLP4O
+ CAMLP4O=camlp4o
+endif
+
+export OCAMLC
+export OCAMLOPT
+export CAMLP4O
+
+include Makefile.local
+
+ifndef PREFIX
+ PREFIX=/usr/local
+endif
+ifeq ($(BDBLIB),)
+ OCAMLLIB=
+else
+ OCAMLLIB= -ccopt $(BDBLIB)
+endif
+
+CAMLP4=-pp $(CAMLP4O)
+CAMLINCLUDE= -I lib -I bdb
+COMMONCAMLFLAGS=$(CAMLINCLUDE) $(OCAMLLIB) -ccopt -Lbdb -dtypes -ccopt -pthread -ccopt -pg -warn-error A
+OCAMLDEP=ocamldep $(CAMLP4)
+CAMLLIBS=unix.cma str.cma bdb.cma nums.cma bigarray.cma cryptokit.cma
+OCAMLFLAGS=$(COMMONCAMLFLAGS) -g $(CAMLLIBS)
+OCAMLOPTFLAGS=$(COMMONCAMLFLAGS) -inline 40 $(CAMLLIBS:.cma=.cmxa)
+
+EXE=sks sks_add_mail
+ALL=$(EXE) sks.8.gz
+ALL.bc=$(EXE:=.bc) sks.8.gz
+
+all: $(ALL)
+all.bc: $(ALL.bc)
+
+COBJS=crc.o
+
+MOBJS.bc= pSet.cmo pMap.cmo utils.cmo heap.cmo mList.cmo \
+ mTimer.cmo mArray.cmo
+
+MOBJS=$(MOBJS.bc:.cmo=.cmx)
+
+ROBJS.bc= settings.cmo pstyle.cmo getfileopts.cmo \
+ common.cmo channel.cmo eventloop.cmo ehandlers.cmo \
+ bitstring.cmo meteredChannel.cmo \
+ number.cmo prime.cmo zZp.cmo rMisc.cmo \
+ linearAlg.cmo poly.cmo decode.cmo \
+ fqueue.cmo prefixTree.cmo msgContainer.cmo \
+ nbMsgContainer.cmo cMarshal.cmo reconMessages.cmo \
+ server.cmo client.cmo reconCS.cmo \
+ number_test.cmo decode_test.cmo poly_test.cmo
+ROBJS=$(ROBJS.bc:.cmo=.cmx)
+
+OBJS.bc=packet.cmo parsePGP.cmo sStream.cmo bdbwrap.cmo \
+ key.cmo keyHash.cmo keyMerge.cmo fixkey.cmo \
+ fingerprint.cmo keydb.cmo armor.cmo \
+ dbMessages.cmo htmlTemplates.cmo wserver.cmo \
+ membership.cmo tester.cmo request.cmo \
+ stats.cmo index.cmo mRindex.cmo pTreeDB.cmo \
+ sendmail.cmo recvmail.cmo mailsync.cmo \
+ clean_keydb.cmo build.cmo fastbuild.cmo pbuild.cmo merge_keyfiles.cmo \
+ sksdump.cmo incdump.cmo dbserver.cmo reconComm.cmo recoverList.cmo \
+ catchup.cmo reconserver.cmo update_subkeys.cmo sks_do.cmo unit_tests.cmo
+
+OBJS=$(OBJS.bc:.cmo=.cmx)
+
+RSERVOBJS.bc=reconComm.cmo recoverList.cmo catchup.cmo reconserver.cmo
+RSERVOBJS=$(RSERVOBJS.bc:.cmo=.cmx)
+
+ALLOBJS.bc=$(COBJS) $(MOBJS.bc) $(ROBJS.bc) $(OBJS.bc)
+ALLOBJS=$(ALLOBJS.bc:.cmo=.cmx)
+
+EXEOBJS.bc=$(RSERVOBJS.bc) build.cmo fastbuild.cmo dbserver.cmo pdiskTest.cmo
+
+LIBS.bc= lib/cryptokit.cma bdb/bdb.cma
+LIBS=$(LIBS.bc:.cma=.cmxa)
+
+VERSION := $(shell cat VERSION)
+VERSIONPREFIX = sks-$(VERSION)
+COMMA_VERSION := $(shell cat VERSION | sed y/./,/)
+FILES := $(shell sed s/.*/$(VERSIONPREFIX)\\/\&/ FILES)
+
+# Special case make rules for functions which require preprocessor directives
+
+common.cmx: common.ml VERSION
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) \
+ -pp "sed s/__VERSION__/$(COMMA_VERSION)/" -c $<
+
+common.cmo: common.ml VERSION
+ $(OCAMLC) $(OCAMLFLAGS) -pp "sed s/__VERSION__/$(COMMA_VERSION)/" -c $<
+
+keyMerge.cmo: keyMerge.ml
+ $(OCAMLC) $(OCAMLFLAGS) $(CAMLP4) -c $<
+
+keyMerge.cmx: keyMerge.ml
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) $(CAMLP4) -c $<
+
+# Special targets
+
+install:
+ mkdir -p $(PREFIX)/bin
+ install sks_build.sh sks sks_add_mail $(PREFIX)/bin
+ mkdir -p $(MANDIR)/man8
+ install sks.8.gz $(MANDIR)/man8
+
+install.bc:
+ mkdir -p $(PREFIX)/bin
+ install sks_build.bc.sh sks.bc sks_add_mail.bc $(PREFIX)/bin
+ mkdir -p $(MANDIR)/man8
+ install sks.8.gz $(MANDIR)/man8
+
+
+Makefile.local:
+ touch Makefile.local
+
+src:
+ if [ ! -x $(VERSIONPREFIX) ]; then ln -s . $(VERSIONPREFIX); fi
+ tar cfz $(VERSIONPREFIX).tgz $(FILES)
+ rm $(VERSIONPREFIX)
+
+# Ordinary targets
+
+sks.8.gz: sks.8
+ gzip -f sks.8
+
+sks.8: sks.pod
+ pod2man -c "SKS OpenPGP Key server" --section 8 -r 0.1 -name sks sks.pod sks.8
+
+spider: $(LIBS) $(ALLOBJS) spider.cmx
+ $(OCAMLOPT) -o spider $(OCAMLOPTFLAGS) $(ALLOBJS) spider.cmx
+
+spider.bc: $(LIBS.bc) $(ALLOBJS.bc) spider.cmo
+ $(OCAMLC) -o spider.bc $(OCAMLFLAGS) $(ALLOBJS.bc) spider.cmo
+
+sks: $(LIBS) $(ALLOBJS) sks.cmx
+ $(OCAMLOPT) -o sks $(OCAMLOPTFLAGS) $(ALLOBJS) sks.cmx
+
+sks.bc: $(LIBS.bc) $(ALLOBJS.bc) sks.cmo
+ $(OCAMLC) -o sks.bc $(OCAMLFLAGS) $(ALLOBJS.bc) sks.cmo
+
+nbtest.bc: $(LIBS.bc) $(ALLOBJS.bc) nbtest.cmo
+ $(OCAMLC) -o nbtest.bc $(OCAMLFLAGS) $(ALLOBJS.bc) nbtest.cmo
+
+ptest: $(LIBS) $(ALLOBJS) ptest.cmx
+ $(OCAMLOPT) -o ptest $(OCAMLOPTFLAGS) $(ALLOBJS) \
+ ptest.cmx
+
+ptree_consistency_test: $(LIBS) $(ALLOBJS) reconPTreeDb.cmx \
+ ptree_consistency_test.cmx
+ $(OCAMLOPT) -o ptree_consistency_test $(OCAMLOPTFLAGS) $(ALLOBJS) \
+ reconPTreeDb.cmx ptree_consistency_test.cmx
+
+ptree_consistency_test.bc: $(LIBS.bc) $(ALLOBJS.bc) reconPTreeDb.cmo \
+ ptree_consistency_test.cmo
+ $(OCAMLC) -o ptree_consistency_test.bc $(OCAMLFLAGS) $(ALLOBJS.bc) \
+ reconPTreeDb.cmo ptree_consistency_test.cmo
+
+ptree_db_test: $(LIBS) $(ALLOBJS) reconPTreeDb.cmx \
+ ptree_db_test.cmx
+ $(OCAMLOPT) -o ptree_db_test $(OCAMLOPTFLAGS) $(ALLOBJS) \
+ reconPTreeDb.cmx ptree_db_test.cmx
+
+ptree_db_test.bc: $(LIBS.bc) $(ALLOBJS.bc) reconPTreeDb.cmo \
+ ptree_db_test.cmo
+ $(OCAMLC) -o ptree_db_test.bc $(OCAMLFLAGS) $(ALLOBJS.bc) \
+ reconPTreeDb.cmo ptree_db_test.cmo
+
+sks_do.bc: $(LIBS.bc) $(ALLOBJS.bc) sks_do.cmo
+ $(OCAMLC) -o sks_do.bc $(OCAMLFLAGS) $(ALLOBJS.bc) sks_do.cmo
+
+sks_do: $(LIBS) $(ALLOBJS) sks_do.cmx
+ $(OCAMLOPT) -o sks_do $(OCAMLOPTFLAGS) $(ALLOBJS) sks_do.cmx
+
+
+sks_add_mail.bc: pMap.cmo pSet.cmo add_mail.cmo
+ $(OCAMLC) -o sks_add_mail.bc -g unix.cma \
+ pMap.cmo pSet.cmo add_mail.cmo
+
+sks_add_mail: $(LIBS) pMap.cmx pSet.cmx add_mail.cmx
+ $(OCAMLOPT) -o sks_add_mail -ccopt -pg unix.cmxa \
+ pMap.cmx pSet.cmx add_mail.cmx
+
+ocamldoc.out: $(ALLOBJS) $(EXEOBJS)
+ ocamldoc -hide Pervasives,UnixLabels,MoreLabels \
+ -dot $(CAMLP4O) -d doc -I lib -I bdb *.ml *.mli
+
+sks_logdump.bc: $(LIBS.bc) $(ALLOBJS.bc) logdump.cmo
+ $(OCAMLC) -o sks_logdump.bc $(OCAMLFLAGS) $(ALLOBJS.bc) logdump.cmo
+
+sks_logdump: $(LIBS) $(ALLOBJS) logdump.cmx
+ $(OCAMLOPT) -o sks_logdump $(OCAMLOPTFLAGS) $(ALLOBJS) \
+ logdump.cmx
+
+bugscript: $(LIBS) $(ALLOBJS) reconPTreeDb.cmx bugscript.cmx
+ $(OCAMLOPT) -o bugscript $(OCAMLOPTFLAGS) $(ALLOBJS) \
+ reconPTreeDb.cmx bugscript.cmx
+
+bugscript.bc: $(LIBS.bc) $(ALLOBJS.bc) reconPTreeDb.cmo bugscript.cmo
+ $(OCAMLC) -o bugscript.bc $(OCAMLFLAGS) $(ALLOBJS.bc) \
+ reconPTreeDb.cmo bugscript.cmo
+
+ptree_replay: $(LIBS) $(ALLOBJS) reconPTreeDb.cmx ptree_replay.cmx
+ $(OCAMLOPT) -o ptree_replay $(OCAMLOPTFLAGS) $(ALLOBJS) \
+ reconPTreeDb.cmx ptree_replay.cmx
+
+modules.dot: ocamldoc.out
+ ./recolor.py < ocamldoc.out > modules.dot
+
+modules.ps: modules.dot
+ dot -Nfontsize=200 modules.dot -Tps -o modules.ps
+
+doc: $(ALLOBJS) $(EXEOBJS)
+ mkdir -p doc
+ ocamldoc -hide Pervasives,UnixLabels,MoreLabels \
+ -html $(CAMLP4O) -d doc -I lib -I bdb *.ml *.mli
+
+dist:
+ cd .. && \
+ tar cvfz sks.tgz \
+ sks/*.ml sks/*.mli sks/*.c sks/Makefile \
+ sks/.depend sks/*.tar.gz \
+ sks/bdb/Makefile sks/bdb/*.ml sks/bdb/*.mli sks/bdb/*.c \
+ sks/bdb/*.h sks/README sks/COPYING sks/VERSION sks/FILES \
+ sks/Makefile.local.unused sks/sks.8
+
+##################################
+# LIBS
+##################################
+
+bdb/bdb.cmxa: bdb/bdb_stubs.c bdb/bdb_stubs.h
+ cd bdb && $(MAKE) bdb.cmxa
+
+bdb/bdb.cma: bdb/bdb_stubs.c bdb/bdb_stubs.h
+ cd bdb && $(MAKE) bdb.cma
+
+bdbclean:
+ cd bdb && $(MAKE) clean
+
+##################################
+
+
+prepared:
+ mkdir -p lib
+ mkdir -p tmp/bin
+ mkdir -p tmp/include
+ touch prepared
+
+
+CKDIR=cryptokit-1.0
+
+$(CKDIR)/README:
+ tar xmvfz $(CKDIR).tar.gz
+
+$(CKDIR)/cryptokit.cma: $(CKDIR)/README
+ cd $(CKDIR) && $(MAKE) all
+
+$(CKDIR)/cryptokit.cmxa: $(CKDIR)/README
+ cd $(CKDIR) && $(MAKE) allopt
+
+lib/cryptokit.cma: $(CKDIR)/cryptokit.cma $(CKDIR)/cryptokit.cmxa prepared
+ cp $(CKDIR)/cryptokit.cmi $(CKDIR)/cryptokit.cma \
+ $(CKDIR)/cryptokit.mli lib
+ cp $(CKDIR)/libcryptokit.a lib
+ if test -f $(CKDIR)/dllcryptokit.so; then \
+ cp $(CKDIR)/dllcryptokit.so lib; fi
+ if test -f $(CKDIR)/cryptokit.cmxa; then \
+ cp $(CKDIR)/cryptokit.cmxa $(CKDIR)/cryptokit.cmx \
+ $(CKDIR)/cryptokit.a lib; fi
+
+lib/cryptokit.cmxa: lib/cryptokit.cma
+
+################################
+# old stuff
+################################
+prefix_test: $(ALLOBJS) prefix_test.cmx
+ $(OCAMLOPT) -o prefix_test $(OCAMLOPTFLAGS) $(ALLOBJS) prefix_test.cmx
+
+prefix_test.opt: $(ROBJS.opt) prefix_test.cmx
+ $(OCAMLOPT) -o prefix_test.opt $(OCAMLOPTFLAGS) $(ROBJS.opt) \
+ prefix_test.cmx
+
+pdiskTest: $(LIBS) $(MOBJS) $(ROBJS) pdiskTest.cmo
+ $(OCAMLC) -o pdiskTest $(OCAMLFLAGS) $(MOBJS) $(ROBJS) pdiskTest.cmo
+
+pdiskTest.opt: $(LIBS.opt) $(MOBJS.opt) $(ROBJS.opt) pdiskTest.cmx
+ $(OCAMLOPT) -o pdiskTest.opt $(OCAMLOPTFLAGS) \
+ $(MOBJS.opt) $(ROBJS.opt) pdiskTest.cmx
+
+pdtcaml: $(LIBS) $(ROBJS) pdiskTest.cmo
+ ocamlmktop -o pdtcaml -custom $(CAMLLIBS) $(CAMLINCLUDE) \
+ $(ROBJS) pdiskTest.cmo
+
+script: $(LIBS) $(ALLOBJS) script.cmo
+ $(OCAMLC) -o script $(OCAMLFLAGS) $(ALLOBJS) script.cmo
+
+dbtest.bc: $(LIBS.bc) $(ALLOBJS.bc) dbtest.cmo
+ $(OCAMLC) -o dbtest.bc $(OCAMLFLAGS) $(ALLOBJS.bc) dbtest.cmo
+
+dbtest: $(LIBS) $(ALLOBJS) dbtest.cmx
+ $(OCAMLOPT) -o dbtest $(OCAMLOPTFLAGS) $(ALLOBJS) dbtest.cmx
+
+tester: $(LIBS) $(ALLOBJS) tester.cmo
+ $(OCAMLC) -o tester $(OCAMLFLAGS) $(ALLOBJS) tester.cmo
+
+dumbloop: $(LIBS) $(ALLOBJS) dumbloop.cmo
+ $(OCAMLC) -o dumbloop $(OCAMLFLAGS) $(ALLOBJS) dumbloop.cmo
+
+scan: $(OBJS) cryptokit dblib scan.ml
+ $(OCAMLC) -o scan $(OCAMLFLAGS) $(OBJS) scan.ml
+
+query: $(LIBS) $(ALLOBJS) query.cmo
+ $(OCAMLC) -o query $(OCAMLFLAGS) $(ALLOBJS) query.cmo
+
+printids: $(OBJS:.cmo=.cmx) cryptokit printids.ml
+ $(OCAMLOPT) -o printids $(OCAMLOPTFLAGS) $(OBJS:.cmo=.cmx) printids.ml
+
+printids.bc: $(OBJS) cryptokit printids.ml
+ $(OCAMLC) -o printids $(OCAMLFLAGS) $(OBJS) printids.ml
+
+krecode: $(ALLOBJS.opt) $(LIBS) recode.ml
+ $(OCAMLOPT) -o krecode $(OCAMLOPTFLAGS) $(ALLOBJS.opt) recode.ml
+
+rcaml: $(LIBS.bc) $(ALLOBJS.bc)
+ ocamlmktop -o rcaml -custom $(CAMLLIBS) $(CAMLINCLUDE) \
+ $(ALLOBJS.bc) $(OCAMLLIB)
+
+
+
+# Common rules
+.SUFFIXES: .ml .mli .cmo .cmi .cmx
+
+.ml.o:
+ $(OCAMLOPT) -output-obj $(OCAMLOPTFLAGS) $<
+
+.cpp.o:
+ $(CXX) $(CXXFLAGS) -c $<
+
+.c.o:
+ $(CC) $(CFLAGS) -c $<
+
+.c.obj:
+ $(CC) $(CFLAGS) /c $<
+
+.ml.cmo:
+ $(OCAMLC) $(OCAMLFLAGS) -c $<
+
+.mli.cmi:
+ $(OCAMLC) $(OCAMLFLAGS) -c $<
+
+.ml.cmx:
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -c $<
+
+
+# Clean up
+mlclean:
+ rm -f *.cm[iox]
+ rm -f *.annot
+ rm -f *.opt
+ rm -f *.bc
+ rm -f $(ALL) $(ALL.bc)
+
+clean: mlclean
+ rm -f *.o
+ rm -f prepared
+ rm -f sks.8.gz
+
+cleanall: clean bdbclean
+ rm -f lib/*
+ rm -rf $(CKDIR)
+ rm -rf $(NXDIR)
+ rm -rf
+
+# Dependencies
+
+dep:
+ $(OCAMLDEP) $(INCLUDES) *.ml *.mli > .depend
+
+-include .depend
+
+# DO NOT DELETE
Added: sks/branches/upstream/sks/current/Makefile.local.unused
===================================================================
--- sks/branches/upstream/sks/current/Makefile.local.unused (rev 0)
+++ sks/branches/upstream/sks/current/Makefile.local.unused 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,10 @@
+BDBLIB=-L/usr/lib
+BDBINCLUDE=-I/usr/include
+PREFIX=/usr/local
+LIBDB=-ldb-4.6
+MANDIR=/usr/share/man
+export BDBLIB
+export BDBINCLUDE
+export PREFIX
+export LIBDB
+export MANDIR
Added: sks/branches/upstream/sks/current/README
===================================================================
--- sks/branches/upstream/sks/current/README (rev 0)
+++ sks/branches/upstream/sks/current/README 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,174 @@
+The following is an incomplete guide to compiling, setting up and using SKS.
+The documentation still needs work, but hopefully this is enough to get you
+started.
+
+-- Prerequisites --------------------------
+
+There are a few prerequisites to building this code. You need:
+
+ * ocaml-3.10.2 or later. Get it from http://www.ocaml.org
+ * Berkeley DB version 4.6.* or later. You can find the
+ appropriate versions at
+ http://www.oracle.com/technetwork/database/berkeleydb/downloads/index.html
+
+-- Compilation and Installation -----------------------------
+
+* Install OCaml and Berkeley DB
+
+ When installing ocaml, make sure you do both the "make world" and the
+ "make opt" steps before installing. The later makes sure you get the
+ optimizing compilers. (do make opt.opt if you want faster compilation.
+ You can then set the environment variables OCAMLC, OCAMLOPT and CALMP4O to
+ ocamlc.opt, ocamlopt.opt and camlp4o.opt respectively.)
+
+ If your vendor or porting project supplies prebuilt binaries and libraries
+ for Berkeley DB, make sure to get the development package as you will need
+ the correct version include files.
+
+* Copy Makefile.local.unused to Makefile.local, and edit to match your
+ installation.
+
+* Compile
+
+ make dep
+ make all
+ make all.bc # if you want the bytecode versions
+ make install # puts executables in $PREFIX/bin, as defined
+ # in Makefile.local
+
+ There are some other useful compilation targets, mostly useful for
+ development.
+
+ - make doc
+ creates a doc directory with ocamldoc-generated documentation of
+ the individual modules. These are mostly useful as documentation
+ to the source code, not a user's guide.
+
+ - make modules.ps
+ Creates a ps-file that shows the dependencies between different
+ modules, and gives you a sense of the overall structure of the
+ system. For this to work you need to have AT&T's graphviz
+ installed, as well as python2. The python script that's used
+ actually requires that python2 be called python2, rather than
+ python. You can of course edit that script.
+
+-- Setup and Configuration ---------------------
+
+You need to set up a directory for the SKS installation. It will contain the
+database files along with configuration and log files.
+
+Configuration options can be passed in on the command-line or put in the
+"sksconf" file in the SKS directory. the -basedir option specifies the SKS
+directory itself, which defaults to the current working directory.
+
+* sksconf and commandline options
+
+ The format of the sksconf file is simply a bunch of lines of the form:
+
+ keyword: value
+
+ The '#' character is used for comments, and blank lines are ignored. The
+ keywords are just the command-line flags, minus the initial "-".
+
+ The one thing you probably want no matter what is a line that says
+
+ logfile: log
+
+ which ensures that sks will output messages to recon.log and db.log
+ respectively.
+
+* membership file
+
+ If you want your server to gossip with others, you will need a membership
+ file which tells the "sks recon" who else to gossip with. The membership
+ file should look something like:
+
+ epidemic.cs.cornell.edu 11370
+ athos.rutgers.edu 11370
+ ...
+
+ This file should be called "membership", and should be stored in the SKS
+ directory. Note that in order for synchronization to work, both hosts
+ have to have each other in their membership lists. Send mail to
+ <sks-devel at nongnu.org> to get other SKS administrators to add you to
+ their membership lsits.
+
+ IMPORTANT NOTE: if you include the server itself in the membership file, you
+ should make sure that you also specify the "hostname" option, and that the
+ selected hostname is exactly the same string listed in the membership file.
+ Otherwise, the "sks recon" will try to synchronize with itself and will
+ deadlock.p
+
+* outgoing PKS synchronization: mailsync file
+
+ The mailsync file contains a list of email addresses of PKS keyservers.
+ This file is important, because it ensures that keys submitted directly to
+ an SKS keyserver are also forwarded to PKS keyservers.
+
+ IMPORTANT: don't add someone to your mailsync file without getting their
+ permission first!
+
+ In order for outgoing email sync's to work, you need to specify a command
+ to actually send the email out. The default is "sendmail -t -oi", but you
+ may need something different.
+
+* incoming PKS synchronization
+
+ Incoming PKS synchronization is less critical than outgoing, since as long
+ as some SKS server gets the new data, it will be distributed to all.
+ Having more hosts receive the incoming PKS syncs does, however, increase
+ the fault-tolerance of the connection between the two systems.
+
+ In order to get incoming mail working, you should pipe the appropriate
+ incoming mail to the following command via procmail:
+
+ "sks_add_mail sks_directory_name"
+
+ Here's an example procmail entry:
+
+ PATH=/path/of/sks/exectuables
+
+ :0
+ * ^Subject: incremental
+ | sks_add_mail sks_directory_name
+
+
+* built-in webserver
+
+ You can server up a simple index page directly from the port you're using
+ for HKP. This is done by creating a subdirectory in your SKS directory
+ called "web". There, you can put an index file named "index.html",
+ "index.htm", "index.xhtm", or "index.xhtml", supporting files with
+ extensions .css, .es, or .js, and some image files with extensions
+ jpg, jpeg, png or gif. Subdirectories will be ignored, as will filenames
+ with anything other than alphanumeric characters and the '.' character.
+ This is particularly useful if you want to run your webserver off of port 80.
+ This can be done by using the -hkp_port command-line option.
+
+
+-- Building up the databases -------------------
+
+ - First, you need to get a keydump. If you're running a PKS server, you
+ should be able to convince PKS to generate one for you. If you're
+ starting from scratch, you'll need to download one from the net. You
+ should contact the pgp keyserver list <pgp-keyserver-folk at flame.org>
+
+ - in the SKS directory, put in a subdirectory called "dump" which contains
+ the keydump files from which the database is to be built.
+
+ - Run sks_build.sh. That script actually runs three utilities. You
+ might want to edit sks_build.sh if you want to trade off speed for space
+ usage. At the current settings, you could run out of ram if you try
+ this with less then 256 megs of RAM.
+
+DO NOT DELETE THE "dump" DIRECTORY, even after the database is built. The
+original keys are not copied to the database, and so the dump must be left in
+place.
+
+-- Platform specific issues ----------------
+
+FreeBSD:
+
+ On FreeBSD it appears that libdb is named differently than on some other
+ platforms. For that reason, you need to set the LIBDB environment value
+ to "-ldb46" instead of "-ldb-4.6" for other platfomrs.
Added: sks/branches/upstream/sks/current/TODO
===================================================================
--- sks/branches/upstream/sks/current/TODO (rev 0)
+++ sks/branches/upstream/sks/current/TODO 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,137 @@
+--- Feature Requests ----
+
++ Replace numerix with Big_int
++ Fix primary-UID detection
++ Allow for time-based dump of keys
++ Bind to specific IP address (low priority)
+
+--- Bug Reports ----
+
++ "sks db" seems to take too long to shut down. Is it really checkpointing?
++ From Bjoern Burger. SKS appears to fail on multiprocessor systems.
++ From Ryan Lackey. Compile bug on FreeBSD
+
+--- Highest Priority ----
+
++ Unify commands to reduce the number of executables generated
+
++ Fix build (and verify that fastbuild is fixed) so that it doesn't barf out
+ entirely if a deeply bogus key is found in the stream.
+
++ Fix partial
+
++ Allow for partial progress: if some elements are recovered, and then
+ there's a timeout, add those elements in.
+
++ if reconcilaition seems to always time-out, perhaps start reconciliation at
+ some sub-tree instead of trying to do everything at once.
+
++ Do a review of all <try...with> clauses to ensure that important exceptions
+ are let through. In particular, Sys.Break should always be let through,
+ and Eventloop.SigAlarm should be passed through (or handled specially) by
+ every function that could be called in a callback.
+
++ Add hash and fingerprint lines to verbose index, if selected
+
++ Change searches so that search strings are broken up into words using same
+ word-breaking algorithm. Optionally, you might want to check if actual
+ string appears as a whole. So typing "eva at kde.org" would pull up all keys
+ with "eva", "kde" and "org", and the optional part would be to check that
+ some UID actually contains the st ring "eva at kde.org" in its entirety.
+
+--- Lower Priority ----
+
++ review logging functions to set debug logging level sensibly
+
++ Ensure idempotence of all DB functions called by reconserver
+ - including deletion and insertion of keys
+
++ add revocation-first sorting when multiple certificates are present
+
++ Add periodic tester of invariants -- in particular to check that the inmem
+ count remains correct.
+
++ Add node-from-key hashtbl. Then, provide a node lookup mechanism that
+ first tries the hashtable and then tries the database, without ever loading
+ a node into the tree structure.
+
++ change error-handling code so that RunRecovery errors are handled
+ differently: namely, logged and then re-raised so the application exits, or
+ perhaps simply exiting the program immediatly.
+
++ Add syslog logging as an option. (still want file logging for verbose logs
+ needed for testing, and maybe for execption logging.)
+
++ enable limited retry-on-failure for gossip. That way, a few bum nodes
+ won't slow the system down.
+
+-----------Not Going To Do (probably) --------------------
+
++ implement no-modify tag (turns out this requires cryptography, which I
+ would like to avoid for now, at least.)
+
+-----------DONE--------------------
+
++ Modify eventloop to ensure fairness of sockets versus other events.
+
++ Disable both incoming and outgoing gossip until fetching of keys is complete.
+
++ Basic testing of key merging
+
++ Cut off reconciliation if difference appears too large, and require manual
+ intervention for huge updates in any case. (I think this is taken care of
+ by keeping the node threshold at some multiple of mbar.)
+
++ matching on upper-and-lowercase hex-strings
+
++ fix index output to be compatible with GPG (and other?) automatic indexing
+ (DONE. Needs testing.)
+
++ Currently hash requests will be sent to any host specified by gossip
+ partner. They should only be sent to the gossip partner host itself.
+
++ Add timeouts for ALL rpc calls. Currently only HTTP times out, and that
+ only on the server side. Lame.
+
++ Add mail interface for interfacing with other servers
+
++ increase initial timeout period. If host doesn't respond with config data
+ with 30 seconds, give up immediatly.
+
++ Update build and fastbuild to canonicalize all elements (and discard
+ non-canonicalized elements), as well as to mark the key with the
+ yminsky.dedup filter, as appropriate.
+
++ Update clean_keydb to apply canonicalize to all elements. Also add
+ metadata to database that includes the version of SKS, and so that
+ automatic updating of the database can be demanded.
+
++ Make sure that keys are canonicalized on ALL input paths.
+
++ modify "give-up" threshold so it doesn't depend on real depth of partition
+ tree. Make it configurable.
+
++ change timeouts on reconciliation so that if config does not come back
+ immediatly, you time out, and otherwise the timeout is lengthened
+ considerably.
+
++ improve error message for contact from unknown host. (now seems to raise
+ Not_found)
+
++ Make initiator of reconciliation act as server. That way, the one who
+ makes the requests also has to work harder.
+
++ Find source of occasional segfault on interrupt of sks_db
+
++ matching on long keyids and (maybe) fingerprints
+
++ fix fetch-by-word to allow for larger upper limit on indvidiual word and
+ shorter limit on number of keys actually returned. Turns out returning
+ keys is more expensive than lookups by a whole lot.
+
++ post-reconciliation key fetches seem to fail on occasion for no clear
+ reason. Fix.
+
++ add option for displaying notation packet
+
++ display revocation keys
Added: sks/branches/upstream/sks/current/VERSION
===================================================================
--- sks/branches/upstream/sks/current/VERSION (rev 0)
+++ sks/branches/upstream/sks/current/VERSION 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1 @@
+1.1.3
Added: sks/branches/upstream/sks/current/add_mail.ml
===================================================================
--- sks/branches/upstream/sks/current/add_mail.ml (rev 0)
+++ sks/branches/upstream/sks/current/add_mail.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,76 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Executable: interprets stdin as mail message and posts content to
+ specified HTTP address *)
+
+open StdLabels
+open MoreLabels
+open Printf
+module Unix = UnixLabels
+module Map = PMap.Map
+module Set = PSet.Set
+
+(** Argument parsing *)
+
+let anonymous = ref []
+
+let usage_string =
+ Sys.argv.(0) ^ " sks_directory_name"
+
+let anon_options option =
+ anonymous := option::!anonymous
+
+let parse_spec = [ ]
+
+let dirname =
+ Arg.parse parse_spec anon_options usage_string;
+ if List.length !anonymous <> 1
+ then (
+ printf "Wrong number (%d) of arguments given. %s\n"
+ (List.length !anonymous)
+ usage_string;
+ exit (-1)
+ ) else
+ Filename.concat (List.hd !anonymous) "messages"
+
+(** dumps contents of one file into another *)
+let pipe_file =
+ let blocksize = 100 * 1024 in
+ let buf = String.create blocksize in
+ let rec pipe_file file1 file2 =
+ let bytes_read = input file1 buf 0 blocksize in
+ if bytes_read <> 0 then (
+ output file2 buf 0 bytes_read;
+ pipe_file file1 file2
+ )
+ in
+ pipe_file
+
+let run () =
+ if not (Sys.file_exists dirname)
+ then Unix.mkdir dirname 0o700;
+ let fname = sprintf "msg-%08d" (Random.int 100000000) in
+ let fname = Filename.concat dirname fname in
+ let f = open_out fname in
+ pipe_file stdin f;
+ close_out f;
+ Sys.rename fname (fname ^ ".ready")
+
+let () =
+ Random.self_init ();
+ run ()
Added: sks/branches/upstream/sks/current/armor.ml
===================================================================
--- sks/branches/upstream/sks/current/armor.ml (rev 0)
+++ sks/branches/upstream/sks/current/armor.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,112 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Conversion to and from ASCII armor *)
+open StdLabels
+open MoreLabels
+open Printf
+
+external crc_of_string : string -> int = "caml_crc_octets"
+
+let base64crc input =
+ let encoder = Cryptokit.Base64.encode_multiline () in
+ encoder#put_string input;
+ encoder#finish;
+ let base64 = encoder#get_string in
+ let crc = crc_of_string input in
+ let encoder = Cryptokit.Base64.encode_compact () in
+ encoder#put_char (char_of_int ((crc lsr 16) land 0xFF));
+ encoder#put_char (char_of_int ((crc lsr 8) land 0xFF));
+ encoder#put_char (char_of_int (crc land 0xFF));
+ encoder#finish;
+ let base64 =
+ if base64.[String.length base64 - 1] <> '\n'
+ then base64 ^ "\n" else base64 in
+ base64 ^ "=" ^ encoder#get_string
+
+let pubkey_armor_header = "-----BEGIN PGP PUBLIC KEY BLOCK-----"
+let pubkey_armor_tail = "-----END PGP PUBLIC KEY BLOCK-----"
+
+(* pubkey *)
+let encode_pubkey key =
+ let armor_header = pubkey_armor_header
+ and armor_tail = pubkey_armor_tail
+ and version = (sprintf "Version: SKS %s" Common.version)
+ in
+ let input = Key.to_string key in
+ armor_header ^ "\n" ^
+ version ^ "\n\n" ^
+ base64crc input ^ "\n" ^
+ armor_tail
+
+let encode_pubkey_string keystr =
+ let armor_header = pubkey_armor_header
+ and armor_tail = pubkey_armor_tail
+ and version = (sprintf "Version: SKS %s" Common.version)
+ in
+ let input = keystr in
+ armor_header ^ "\n" ^
+ version ^ "\n\n" ^
+ base64crc input ^ "\n" ^
+ armor_tail
+
+let decode_crc s =
+ let decoder = Cryptokit.Base64.decode () in
+ decoder#put_string s;
+ decoder#finish;
+ let b1 = decoder#get_byte in
+ let b2 = decoder#get_byte in
+ let b3 = decoder#get_byte in
+ b1 lsl 16 + b2 lsl 8 + b3
+
+let eol = Str.regexp "[ \t]*\r?\n"
+
+let decode_pubkey text =
+ let decoder = Cryptokit.Base64.decode () in
+ let lines = Str.split eol text in
+ let rec read_adata lines = match lines with
+ [] -> failwith "Error while decoding ascii-armored key: text terminated before reaching CRC sum"
+ | line::tl ->
+ if line.[0] = '='
+ then ( (* close the decoder and return the CRC string *)
+ decoder#finish;
+ let crc = decode_crc (String.sub ~pos:1
+ ~len:(String.length line - 1) line)
+ and data = decoder#get_string in
+ (data,crc)
+ )
+ else (
+ decoder#put_string line;
+ read_adata tl
+ )
+ and read_full lines = match lines with
+ [] -> failwith "Error while decoding ascii-armored key: text terminated before reaching PGP public key header line"
+ | line::tl ->
+ if line = pubkey_armor_header then read_block tl
+ else read_full tl
+ and read_block lines = match lines with
+ [] -> failwith "Error while decoding ascii-armored key: text terminated before beginning of ascii block"
+ | line::tl ->
+ if line = "" then read_adata tl
+ else read_block tl
+ in
+ let (data,crc) = read_full lines in
+ let data_crc = crc_of_string data in
+ assert (data_crc = crc);
+ Key.of_string_multiple data
+
+
Added: sks/branches/upstream/sks/current/bdb/Makefile
===================================================================
--- sks/branches/upstream/sks/current/bdb/Makefile (rev 0)
+++ sks/branches/upstream/sks/current/bdb/Makefile 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,105 @@
+#########################################################################
+# #
+# Objective Caml #
+# #
+# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
+# #
+# Copyright 1999 Institut National de Recherche en Informatique et #
+# en Automatique. All rights reserved. This file is distributed #
+# under the terms of the GNU Library General Public License, with #
+# the special exception on linking described in file ../../LICENSE. #
+# #
+#########################################################################
+
+# $Id: Makefile,v 1.6 2003/07/05 15:16:29 yminsky Exp $
+
+CINCLUDES=-I`ocamlc -where` $(BDBINCLUDE)
+CC=gcc
+CXX=g++
+CFLAGS=-O3 -Werror-implicit-function-declaration $(CINCLUDES) $(BDBLIB) -I .
+CXXFLAGS=-O3 $(CINCLUDES) $(BDBLIB) -I .
+
+MKLIB=ocamlmklib
+RANLIB=ranlib
+OCAMLDEP=ocamldep $(PP)
+CAMLINCLUDE=
+COMMONCAMLFLAGS= $(CAMLINCLUDE) $(PP) #-thread
+CAMLLIBS=unix.cma str.cma mylibs.cma
+OCAMLFLAGS=$(COMMONCAMLFLAGS) -g
+OCAMLOPTFLAGS=$(COMMONCAMLFLAGS) -inline 40
+
+ifndef LIBDB
+LIBDB=-ldb-4.6
+endif
+
+COBJS = bdb_stubs.o
+
+ocextr: ocextr.ml
+ $(OCAMLOPT) -o ocextr ocextr.ml
+
+libbdb.a: $(COBJS)
+ $(MKLIB) -custom -o bdb $(COBJS)
+
+bdb_stubs.o: bdb_stubs.h bdb_stubs.c
+
+bdb.ml: ocextr bdb_stubs.c
+ ./ocextr bdb_stubs.c > bdb.ml
+
+bdb.cma: bdb.cmo libbdb.a
+ $(MKLIB) -custom -o bdb bdb.cmo -lbdb $(LIBDB)
+
+bdb.cmxa: bdb.cmx libbdb.a
+ $(MKLIB) -custom -o bdb bdb.cmx -lbdb $(LIBDB)
+
+bdbcaml: bdb.cma
+ ocamlmktop -o bdbcaml -custom unix.cma bdb.cma $^
+
+partialclean:
+ rm -f *.cm*
+
+clean: partialclean
+ rm -f *.a *.o
+
+install:
+ cp libmldb.a $(LIBDIR)/libmldb.a
+ cd $(LIBDIR); $(RANLIB) libmldb.a
+ cp db.cma db.cmi db.mli $(LIBDIR)
+
+installopt:
+ cp db.cmx db.cmxa db.a $(LIBDIR)
+ cd $(LIBDIR); $(RANLIB) db.a
+
+
+
+# Common rules
+.SUFFIXES: .ml .mli .cmo .cmi .cmx
+
+.ml.o:
+ $(OCAMLOPT) -output-obj $(OCAMLOPTFLAGS) $<
+
+.cpp.o:
+ $(CXX) $(CXXFLAGS) -c $<
+
+.c.o:
+ $(CC) $(CFLAGS) -c $<
+
+.c.obj:
+ $(CC) $(CFLAGS) /c $<
+
+.ml.cmo:
+ $(OCAMLC) $(OCAMLFLAGS) -c $<
+
+.mli.cmi:
+ $(OCAMLC) $(OCAMLFLAGS) -c $<
+
+.ml.cmx:
+ $(OCAMLOPT) $(OCAMLOPTFLAGS) -c $<
+
+# Dependencies
+#dep:
+# $(OCAMLDEP) $(INCLUDES) *.ml *.mli > .depend
+
+#include .depend
+
+
+# DO NOT DELETE
Added: sks/branches/upstream/sks/current/bdb/bdb.ml
===================================================================
--- sks/branches/upstream/sks/current/bdb/bdb.ml (rev 0)
+++ sks/branches/upstream/sks/current/bdb/bdb.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,168 @@
+(* Exception declarations *)
+
+exception DBError of string
+let _ = Callback.register_exception "dberror" (DBError "")
+
+exception Key_exists
+let _ = Callback.register_exception "keyexists" Key_exists
+
+exception Run_recovery
+let _ = Callback.register_exception "dbrunrecovery" Run_recovery
+
+external db_init : unit -> unit = "caml_db_init"
+let _ = db_init ()
+
+type txn
+type cursor
+type dbenv
+type db
+
+
+module Dbenv =
+struct
+
+ type t = dbenv
+
+ type open_flag =
+ JOINENV | INIT_CDB | INIT_LOCK | INIT_LOG
+ | INIT_MPOOL | INIT_TXN | RECOVER | RECOVER_FATAL
+ | USE_ENVIRON | USE_ENVIRON_ROOT | CREATE
+ | LOCKDOWN | PRIVATE | SYSTEM_MEM | THREAD
+
+ type verbose_flag =
+ VERB_CHKPOINT | VERB_DEADLOCK | VERB_RECOVERY | VERB_WAITSFOR
+
+ external create : unit -> t = "caml_dbenv_create"
+ external dopen : t -> string -> open_flag list -> int -> unit =
+ "caml_dbenv_open"
+ let sopen dirname flags mode =
+ let dbenv = create () in
+ dopen dbenv dirname flags mode;
+ dbenv
+ external close : t -> unit = "caml_dbenv_close"
+ external set_verbose_internal : t -> verbose_flag list ->
+ bool -> unit = "caml_dbenv_set_verbose"
+ let set_verbose dbenv flag onoff =
+ set_verbose_internal dbenv [flag] onoff
+ external set_cachesize : t -> gbytes:int -> bytes:int ->
+ ncache:int -> unit = "caml_dbenv_set_cachesize"
+
+end
+
+
+module Db =
+struct
+
+ type t = db
+
+ type create_flag
+
+ type open_flag =
+ CREATE | EXCL | NOMMAP | RDONLY | THREAD | TRUNCATE | AUTO_COMMIT
+
+ type db_type = BTREE | HASH | QUEUE | RECNO | UNKNOWN
+
+ type put_flag = APPEND | NODUPDATA | NOOVERWRITE
+
+ type get_flag = CONSUME | CONSUME_WAIT | SET_RECNO | RMW
+
+ type set_flag = DUP | DUPSORT | RECNUM | REVSPLITOFF
+ | RENUMBER | SNAPSHOT
+
+ external create : ?dbenv:Dbenv.t -> create_flag list -> t =
+ "caml_db_create"
+ external dopen : t -> string -> db_type -> open_flag list
+ -> int -> unit = "caml_db_open"
+ external close : t -> unit = "caml_db_close"
+ external del : t -> ?txn:txn -> string -> unit = "caml_db_del"
+ external put : t -> ?txn:txn -> key:string -> data:string
+ -> put_flag list -> unit = "caml_db_put"
+ external get : t -> ?txn:txn -> string -> get_flag list -> string
+ = "caml_db_get"
+ external set_flags : t -> set_flag list -> unit = "caml_db_set_flags"
+
+ let sopen ?dbenv fname dbtype ?moreflags flags mode =
+ let db = create ?dbenv [] in
+ (match moreflags with
+ None -> ()
+ | Some flags -> set_flags db flags );
+ dopen db fname dbtype flags mode;
+ db
+ external set_h_ffactor : t -> int -> unit
+ = "caml_db_set_h_ffactor"
+ external set_pagesize : t -> int -> unit
+ = "caml_db_set_pagesize"
+ external set_cachesize : t -> gbytes:int -> bytes:int
+ -> ncache:int -> unit = "caml_db_set_cachesize"
+ external sync : t -> unit = "caml_db_sync"
+ external get_size : t -> int = "caml_db_get_size"
+
+end
+
+
+module Cursor =
+struct
+
+ type t = cursor
+
+ type put_flag = AFTER | BEFORE | CURRENT
+
+ type kput_flag = KEYFIRST | KEYLAST | NODUPDATA
+
+ type get_type = CURRENT | FIRST | LAST
+ | NEXT | PREV | NEXT_DUP | NEXT_NODUP
+ | PREV_NODUP | NULL
+
+ type get_flag = RMW
+ (* Note: A cursor created with a transaction must be closed before
+ the transaction is committed or aborted *)
+ external create : ?writecursor:bool -> ?txn:txn -> Db.t -> t
+ = "caml_cursor_create"
+ external close : t -> unit = "caml_cursor_close"
+ external put : t -> string -> put_flag -> unit
+ = "caml_cursor_put"
+ external kput : t -> key:string -> data:string -> kput_flag -> unit
+ = "caml_cursor_kput"
+ external init : t -> string -> get_flag list -> string
+ = "caml_cursor_init"
+ external init_range : t -> string -> get_flag list -> string * string
+ = "caml_cursor_init_range"
+ external init_both : t -> key:string -> data:string
+ -> get_flag list -> unit = "caml_cursor_init_both"
+ external get : t -> get_type -> get_flag list -> string * string
+ = "caml_cursor_get"
+ external get_keyonly : t -> get_type -> get_flag list -> string
+ = "caml_cursor_get_keyonly"
+ external del : t -> unit = "caml_cursor_del"
+ external count : t -> int = "caml_cursor_count"
+ external dup : ?keep_position:bool -> t -> t = "caml_cursor_dup"
+ external ajoin : ?nosort:bool -> db -> cursor array -> get_flag list ->
+ cursor = "caml_join_cursors"
+ let join ?nosort db cursor_list get_flag_list =
+ ajoin ?nosort db (Array.of_list cursor_list) get_flag_list
+
+end
+
+
+module Txn =
+struct
+
+ type t = txn
+
+ type begin_flag = (* DIRTY_READ | *) NOSYNC | NOWAIT | SYNC
+
+ type checkpoint_flag = FORCE
+
+ type commit_flag = COM_NOSYNC | COM_SYNC
+
+ (* set max # of active transactions *)
+ external set_txn_max : dbenv -> int -> unit = "caml_set_txn_max"
+ external abort : t -> unit = "caml_txn_abort"
+ external txn_begin : dbenv -> t option -> begin_flag list -> t
+ = "caml_txn_begin"
+ external checkpoint: dbenv -> kbyte:int -> min:int
+ -> checkpoint_flag list -> unit = "caml_txn_checkpoint"
+ external commit: t -> commit_flag list -> unit = "caml_txn_commit"
+
+end
+
Added: sks/branches/upstream/sks/current/bdb/bdb_stubs.c
===================================================================
--- sks/branches/upstream/sks/current/bdb/bdb_stubs.c (rev 0)
+++ sks/branches/upstream/sks/current/bdb/bdb_stubs.c 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,1272 @@
+// Stubs appropriate for Berkeley DB 4.x
+#include <stdio.h>
+#include <stdlib.h>
+#include <errno.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+
+#include <sys/stat.h>
+#include <sys/types.h>
+#include <limits.h>
+#include <db.h>
+/* O_CREAT and others are not defined in db.h */
+#include <fcntl.h>
+
+#include <string.h>
+#include "bdb_stubs.h"
+
+#ifndef DB_XA_CREATE
+#define DB_XA_CREATE 0
+#endif
+
+#define True 1
+#define False 0
+
+
+void bzero(void* addr,size_t n) {
+ memset(addr,0,n);
+}
+
+#define test_cursor_closed(cursor) \
+ if (UW_cursor_closed(cursor)) \
+ invalid_argument("Attempt to use closed cursor")
+
+#define test_dbenv_closed(dbenv) \
+ if (UW_dbenv_closed(dbenv)) \
+ invalid_argument("Attempt to use closed dbenv")
+
+#define test_db_closed(db) \
+ if (UW_db_closed(db)) \
+ invalid_argument("Attempt to use closed db")
+
+#define test_txn_closed(txn) \
+ if (UW_txn_closed(txn)) \
+ invalid_argument("Attempt to use closed txn")
+
+// comments starting with "//+" are extracted automatically to create the .ml
+// file that forms the caml side of this interface.
+
+/************************************************************/
+/*** Custom Operations *************************************/
+/************************************************************/
+
+// ###### DB_ENV ######
+
+#define caml_dbenv_close_internal(dbenv) \
+ (!(UW_dbenv_closed(dbenv)) ? \
+ UW_dbenv_closed(dbenv) = True, \
+ UW_dbenv(dbenv)->close(UW_dbenv(dbenv),0) : \
+ 0 )
+
+static void finalize_caml_dbenv(value dbenv) {
+ //fprintf(stderr,"GC: Finalizing Dbenv\n"); fflush(stderr);
+ caml_dbenv_close_internal(dbenv);
+ //fprintf(stderr,"GC: Dbenv Finalized\n"); fflush(stderr);
+}
+
+static struct custom_operations dbenv_custom = {
+ "sks.bdb.dbenv",
+ finalize_caml_dbenv,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+};
+
+// ###### DB ######
+
+#define caml_db_close_internal(db) \
+ (!(UW_db_closed(db)) ? \
+ UW_db_closed(db) = True, \
+ UW_db(db)->close(UW_db(db),0) : \
+ 0 )
+
+static void finalize_caml_db(value db) {
+ //fprintf(stderr,"GC: Finalizing Db\n"); fflush(stderr);
+ caml_db_close_internal(db);
+ //fprintf(stderr,"GC: Db Finalized\n"); fflush(stderr);
+}
+
+static struct custom_operations db_custom = {
+ "sks.bdb.db",
+ finalize_caml_db,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+};
+
+// ###### Cursor ######
+
+#define caml_cursor_close_internal(cursor) \
+ (!(UW_cursor_closed(cursor)) ? \
+ (UW_cursor_closed(cursor) = True, \
+ UW_cursor(cursor)->c_close(UW_cursor(cursor))) : \
+ 0 )
+
+static void finalize_caml_cursor(value cursor) {
+ //fprintf(stderr,"GC: Finalizing Cursor\n"); fflush(stderr);
+ caml_cursor_close_internal(cursor);
+ //fprintf(stderr,"GC: Cursor Finalized\n"); fflush(stderr);
+}
+
+static struct custom_operations cursor_custom = {
+ "sks.bdb.cursor",
+ finalize_caml_cursor,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+};
+
+// ###### Transaction ######
+
+// ###### Cursor ######
+
+#define caml_cursor_close_internal(cursor) \
+ (!(UW_cursor_closed(cursor)) ? \
+ (UW_cursor_closed(cursor) = True, \
+ UW_cursor(cursor)->c_close(UW_cursor(cursor))) : \
+ 0 )
+
+static void finalize_caml_txn(value txn) {
+ //fprintf(stderr,"GC: Finalizing Txn\n"); fflush(stderr);
+
+ /* Try to abort any transaction that gets GC'd
+ without being closed first */
+ if (!UW_txn_closed(txn)) {
+ //fprintf(stderr,"GC: Aborting unclosed transaction\n");
+ //fflush(stderr);
+ UW_txn(txn)->abort(UW_txn(txn));
+ }
+
+ //fprintf(stderr,"GC: Txn Finalized\n"); fflush(stderr);
+}
+
+static struct custom_operations txn_custom = {
+ "sks.bdb.txn",
+ finalize_caml_txn,
+ custom_compare_default,
+ custom_hash_default,
+ custom_serialize_default,
+ custom_deserialize_default
+};
+
+/************************************************************/
+/************ Exception buckets *****************************/
+/************************************************************/
+
+static value *caml_db_exn = NULL;
+static value *caml_key_exists_exn = NULL;
+static value *caml_db_run_recovery_exn = NULL;
+
+value caml_db_init(value v){
+ CAMLparam1(v);
+ if (caml_db_exn == NULL)
+ caml_db_exn = caml_named_value("dberror");
+ if (caml_key_exists_exn == NULL)
+ caml_key_exists_exn = caml_named_value("keyexists");
+ if (caml_db_run_recovery_exn == NULL)
+ caml_db_run_recovery_exn = caml_named_value("dbrunrecovery");
+ CAMLreturn (Val_unit);
+}
+
+//+ (* Exception declarations *)
+//+
+//+ exception DBError of string
+//+ let _ = Callback.register_exception "dberror" (DBError "")
+//+
+//+ exception Key_exists
+//+ let _ = Callback.register_exception "keyexists" Key_exists
+//+
+//+ exception Run_recovery
+//+ let _ = Callback.register_exception "dbrunrecovery" Run_recovery
+//+
+//+ external db_init : unit -> unit = "caml_db_init"
+//+ let _ = db_init ()
+//+
+//+ type txn
+//+ type cursor
+//+ type dbenv
+//+ type db
+
+void raise_db(char *msg) {
+ raise_with_string(*caml_db_exn, msg);
+}
+
+void raise_key_exists() {
+ raise_constant(*caml_key_exists_exn);
+}
+
+void raise_run_recovery() {
+ raise_constant(*caml_db_run_recovery_exn);
+}
+
+// Used as callback by db infrastructure for setting errors. As a result,
+// calls to DB->err and DBENV->err lead to exceptions.
+
+// FIX: currently, prefix is ignored. Should be concatenated.
+void raise_db_cb(const DB_ENV *dbenv, const char *prefix, char *msg) {
+ raise_db(msg);
+}
+
+
+// #############################################################
+// Opening of Dbenv moudle
+//+
+//+
+//+ module Dbenv =
+//+ struct
+//+
+//+ type t = dbenv
+
+
+/** DBENV Flags ********************************************/
+
+// Declaration of flag enums in ocaml must be in same order as in C
+
+static int dbenv_open_flags[] = {
+ DB_JOINENV, DB_INIT_CDB, DB_INIT_LOCK, DB_INIT_LOG, DB_INIT_MPOOL,
+ DB_INIT_TXN, DB_RECOVER, DB_RECOVER_FATAL, DB_USE_ENVIRON,
+ DB_USE_ENVIRON_ROOT, DB_CREATE, DB_LOCKDOWN, DB_PRIVATE,
+ DB_SYSTEM_MEM, DB_THREAD
+};
+
+//+
+//+ type open_flag =
+//+ JOINENV | INIT_CDB | INIT_LOCK | INIT_LOG
+//+ | INIT_MPOOL | INIT_TXN | RECOVER | RECOVER_FATAL
+//+ | USE_ENVIRON | USE_ENVIRON_ROOT | CREATE
+//+ | LOCKDOWN | PRIVATE | SYSTEM_MEM | THREAD
+
+static int dbenv_verbose_flags[] = {
+ DB_VERB_DEADLOCK, DB_VERB_RECOVERY, DB_VERB_WAITSFOR
+};
+
+//+
+//+ type verbose_flag =
+//+ VERB_CHKPOINT | VERB_DEADLOCK | VERB_RECOVERY | VERB_WAITSFOR
+
+/** DBENV Calls *******************************************/
+//+
+
+//+ external create : unit -> t = "caml_dbenv_create"
+value caml_dbenv_create(value unit){
+ CAMLparam1(unit);
+ CAMLlocal1(rval);
+ int err;
+ int flags = 0;
+ DB_ENV *dbenv;
+
+ err = db_env_create(&dbenv,flags);
+ if (err != 0) { raise_db(db_strerror(err)); }
+
+ dbenv->set_errcall(dbenv,raise_db_cb);
+
+ rval = alloc_custom(&dbenv_custom,Camldbenv_wosize,0,1);
+ UW_dbenv(rval) = dbenv;
+ UW_dbenv_closed(rval) = False;
+ CAMLreturn (rval);
+}
+
+
+//+ external dopen : t -> string -> open_flag list -> int -> unit =
+//+ "caml_dbenv_open"
+value caml_dbenv_open(value dbenv, value vdirectory,
+ value vflags, value vmode){
+ CAMLparam4(dbenv,vdirectory,vflags,vmode);
+ int err;
+ char *directory = String_val(vdirectory);
+ int flags = convert_flag_list(vflags,dbenv_open_flags);
+
+ test_dbenv_closed(dbenv);
+
+ err = UW_dbenv(dbenv)->open(UW_dbenv(dbenv), directory,
+ flags,
+ Long_val(vmode) );
+ if (err != 0) {
+ UW_dbenv(dbenv)->err(UW_dbenv(dbenv),err,
+ "caml_dbenv_open: open failed.");
+ }
+
+ CAMLreturn (Val_unit);
+}
+// simple open, combination of create and open
+//+ let sopen dirname flags mode =
+//+ let dbenv = create () in
+//+ dopen dbenv dirname flags mode;
+//+ dbenv
+
+
+
+//+ external close : t -> unit = "caml_dbenv_close"
+value caml_dbenv_close(value dbenv) {
+ CAMLparam1(dbenv);
+ int err;
+
+ //fprintf(stderr,"Closing Dbenv\n"); fflush(stderr);
+ err = caml_dbenv_close_internal(dbenv);
+ if (err != 0) { raise_db(db_strerror(err)); }
+ //fprintf(stderr,"Dbenv Closed\n"); fflush(stderr);
+
+ CAMLreturn (Val_unit);
+}
+
+
+//+ external set_verbose_internal : t -> verbose_flag list ->
+//+ bool -> unit = "caml_dbenv_set_verbose"
+//+ let set_verbose dbenv flag onoff =
+//+ set_verbose_internal dbenv [flag] onoff
+value caml_dbenv_set_verbose(value dbenv, value vflags,
+ value v_onoff) {
+ CAMLparam3(dbenv,vflags,v_onoff);
+ int err;
+
+ int which = convert_flag_list(vflags,dbenv_verbose_flags) + 1;
+ int onoff = Bool_val(v_onoff);
+
+ test_dbenv_closed(dbenv);
+
+ err = UW_dbenv(dbenv)->set_verbose(UW_dbenv(dbenv),which,onoff);
+
+ if (err != 0) {
+ UW_dbenv(dbenv)->err(UW_dbenv(dbenv),err,
+ "caml_dbenv_set_verbose:");
+ }
+ CAMLreturn (Val_unit);
+}
+
+//+ external set_cachesize : t -> gbytes:int -> bytes:int ->
+//+ ncache:int -> unit = "caml_dbenv_set_cachesize"
+value caml_dbenv_set_cachesize(value dbenv, value gbytes,
+ value bytes, value ncache) {
+ CAMLparam4(dbenv, gbytes, bytes, ncache);
+ int err;
+
+ err = UW_dbenv(dbenv)->set_cachesize(UW_dbenv(dbenv),Int_val(gbytes),
+ Int_val(bytes), Int_val(ncache));
+ if (err != 0) { UW_dbenv(dbenv)->err(UW_dbenv(dbenv),err,
+ "caml_dbenv_set_cachesize"); }
+
+ CAMLreturn (Val_unit);
+}
+
+
+
+// Termination of Dbenv module
+//+
+//+ end
+
+
+// #############################################################
+// Opening of Db moudle
+//+
+//+
+//+ module Db =
+//+ struct
+//+
+//+ type t = db
+
+
+
+/** DB Flags ***********************************************/
+static int db_create_flags[] = {
+};
+
+//+
+//+ type create_flag
+
+static int db_open_flags[] = {
+ DB_CREATE, DB_EXCL, DB_NOMMAP, DB_RDONLY, DB_THREAD,
+ DB_TRUNCATE, DB_AUTO_COMMIT
+};
+
+//+
+//+ type open_flag =
+//+ CREATE | EXCL | NOMMAP | RDONLY | THREAD | TRUNCATE | AUTO_COMMIT
+
+static int db_types[] = {
+ DB_BTREE, DB_HASH, DB_QUEUE, DB_RECNO, DB_UNKNOWN
+};
+
+//+
+//+ type db_type = BTREE | HASH | QUEUE | RECNO | UNKNOWN
+
+
+static int db_put_flags[] = { DB_APPEND, DB_NODUPDATA, DB_NOOVERWRITE };
+
+//+
+//+ type put_flag = APPEND | NODUPDATA | NOOVERWRITE
+
+// DB_GET_BOTH is omitted because it doesn't make sense given our interface
+static int db_get_flags[] = {
+ DB_CONSUME, DB_CONSUME_WAIT, DB_SET_RECNO, DB_RMW
+};
+
+//+
+//+ type get_flag = CONSUME | CONSUME_WAIT | SET_RECNO | RMW
+
+
+static int db_set_flags[] = {
+ DB_DUP, DB_DUPSORT, DB_RECNUM, DB_REVSPLITOFF, DB_RENUMBER, DB_SNAPSHOT
+};
+
+//+
+//+ type set_flag = DUP | DUPSORT | RECNUM | REVSPLITOFF
+//+ | RENUMBER | SNAPSHOT
+
+/** DB Calls **************************************************/
+//+
+
+//+ external create : ?dbenv:Dbenv.t -> create_flag list -> t =
+//+ "caml_db_create"
+value caml_db_create(value dbenv_opt, value vflags){
+ CAMLparam2(dbenv_opt,vflags);
+ int err;
+ int flags;
+ DB *db;
+ DB_ENV *dbenv;
+ CAMLlocal1(rval);
+
+ /* The flags parameter is currently unused, and must be set to 0. */
+ if (vflags != Val_emptylist)
+ invalid_argument("DB.create invalid create flag");
+ flags = convert_flag_list(vflags,db_create_flags);
+
+ if (Is_None(dbenv_opt)) { dbenv = NULL; }
+ else {
+ test_dbenv_closed(Some_val(dbenv_opt));
+ dbenv = UW_dbenv(Some_val(dbenv_opt));
+ }
+
+ err = db_create(&db,dbenv,flags);
+ if (err != 0) { raise_db(db_strerror(err)); }
+
+ db->set_errcall(db,raise_db_cb);
+
+ rval = alloc_custom(&db_custom,Camldb_wosize,0,1);
+ UW_db(rval) = db;
+ UW_db_closed(rval) = False;
+ CAMLreturn (rval);
+
+}
+
+//+ external dopen : t -> string -> db_type -> open_flag list
+//+ -> int -> unit = "caml_db_open"
+value caml_db_open(value db, value vfname,
+ value vdbtype, value vflags,
+ value vmode){
+ CAMLparam5(db, vfname, vdbtype, vflags, vmode);
+ int err;
+ char *fname = String_val(vfname);
+ int flags = convert_flag_list(vflags,db_open_flags);
+ int dbtype = Flag_val(vdbtype,db_types);
+
+ test_db_closed(db);
+
+ err = UW_db(db)->open(UW_db(db),
+ NULL,
+ fname,
+ NULL, /* no support for multiple databases in
+ a single file */
+ dbtype,
+ flags, /* automatic transaction on database open */
+ Long_val(vmode) );
+ if (err != 0) {
+ UW_db(db)->err(UW_db(db),err,
+ "caml_db_open");
+ }
+
+ CAMLreturn (Val_unit);
+}
+
+//+ external close : t -> unit = "caml_db_close"
+value caml_db_close(value db) {
+ CAMLparam1(db);
+ int err;
+
+ //fprintf(stderr,"Closing Dbenv\n"); fflush(stderr);
+ err = caml_db_close_internal(db);
+ if (err != 0) { raise_db(db_strerror(err)); }
+ //fprintf(stderr,"Dbenv Closed\n"); fflush(stderr);
+
+ CAMLreturn (Val_unit);
+}
+
+//+ external del : t -> ?txn:txn -> string -> unit = "caml_db_del"
+value caml_db_del(value db, value txn_opt, value key) {
+ CAMLparam3(db,txn_opt,key);
+ DBT dbt; // static keyword initializes record to zero.
+ int err;
+ DB_TXN *txn;
+
+ if (Is_None(txn_opt)) { txn = NULL; }
+ else {
+ test_txn_closed(Some_val(txn_opt));
+ txn = UW_txn(Some_val(txn_opt));
+ }
+
+ test_db_closed(db);
+
+ bzero(&dbt,sizeof(DBT));
+
+ dbt.data = String_val(key);
+ dbt.size = string_length(key);
+
+
+ err = UW_db(db)->del(UW_db(db), txn, &dbt, 0);
+ if (err != 0) { UW_db(db)->err(UW_db(db),err, "caml_db_del"); }
+
+ CAMLreturn (Val_unit);
+}
+
+
+//+ external put : t -> ?txn:txn -> key:string -> data:string
+//+ -> put_flag list -> unit = "caml_db_put"
+value caml_db_put(value db, value txn_opt, value vkey,
+ value vdata, value vflags) {
+ CAMLparam5(db, txn_opt, vkey, vdata, vflags);
+ DBT key, data;
+ int flags, err;
+ DB_TXN *txn;
+
+ if (Is_None(txn_opt)) { txn = NULL; }
+ else {
+ test_txn_closed(Some_val(txn_opt));
+ txn = UW_txn(Some_val(txn_opt));
+ }
+
+ test_db_closed(db);
+
+ bzero(&key,sizeof(DBT)); bzero(&data,sizeof(DBT));
+
+ key.data = String_val(vkey);
+ key.size = string_length(vkey);
+ data.data = String_val(vdata);
+ data.size = string_length(vdata);
+ flags = convert_flag_list(vflags, db_put_flags);
+
+ err = UW_db(db)->put(UW_db(db), txn, &key, &data, flags);
+ if (err != 0) {
+ if (err == DB_KEYEXIST) {raise_key_exists();}
+ UW_db(db)->err(UW_db(db),err,"caml_db_put");
+ }
+
+ CAMLreturn (Val_unit);
+}
+
+
+//+ external get : t -> ?txn:txn -> string -> get_flag list -> string
+//+ = "caml_db_get"
+value caml_db_get(value db, value txn_opt, value vkey, value vflags) {
+ CAMLparam4(db, txn_opt, vkey, vflags);
+ DBT key,data;
+ int flags, err;
+ DB_TXN *txn;
+ CAMLlocal1(rval);
+
+ if (Is_None(txn_opt)) { txn = NULL; }
+ else {
+ test_txn_closed(Some_val(txn_opt));
+ txn = UW_txn(Some_val(txn_opt));
+ }
+
+ test_db_closed(db);
+
+ bzero(&key,sizeof(DBT)); bzero(&data,sizeof(DBT));
+
+ key.data = String_val(vkey);
+ key.size = string_length(vkey);
+ flags = convert_flag_list(vflags, db_get_flags);
+
+
+ err = UW_db(db)->get(UW_db(db), txn, &key, &data, flags);
+ if (err != 0) {
+ ////fprintf(stderr,"Error found: %d\n",err); fflush(stderr);
+ if (err == DB_NOTFOUND) { raise_not_found(); }
+ UW_db(db)->err(UW_db(db),err,"caml_db_get");
+ }
+
+ // FIX: this currently uses an extra, unnecessary copy in order to simplify
+ // memory management.
+ rval = alloc_string(data.size);
+ memcpy (String_val(rval), data.data, data.size);
+ CAMLreturn (rval);
+}
+
+//+ external set_flags : t -> set_flag list -> unit = "caml_db_set_flags"
+value caml_db_set_flags(value db, value vflags) {
+ CAMLparam2(db,vflags);
+ int flags=0,err;
+
+ test_db_closed(db);
+
+ flags = convert_flag_list(vflags,db_set_flags);
+
+ err = UW_db(db)->set_flags(UW_db(db),flags);
+ if (err != 0) { UW_db(db)->err(UW_db(db),err,"caml_db_set_flags"); }
+
+ CAMLreturn (Val_unit);
+}
+
+
+// More user-friendly version of dopen (simple open)
+//+
+//+ let sopen ?dbenv fname dbtype ?moreflags flags mode =
+//+ let db = create ?dbenv [] in
+//+ (match moreflags with
+//+ None -> ()
+//+ | Some flags -> set_flags db flags );
+//+ dopen db fname dbtype flags mode;
+//+ db
+
+
+
+//+ external set_h_ffactor : t -> int -> unit
+//+ = "caml_db_set_h_ffactor"
+value caml_db_set_h_ffactor(value db, value v) {
+ CAMLparam2(db,v);
+ int err;
+
+ test_db_closed(db);
+
+ err = UW_db(db)->set_h_ffactor(UW_db(db),Int_val(v));
+ if (err != 0) { UW_db(db)->err(UW_db(db),err,"caml_db_set_h_ffactor"); }
+
+ CAMLreturn (Val_unit);
+}
+
+//+ external set_pagesize : t -> int -> unit
+//+ = "caml_db_set_pagesize"
+value caml_db_set_pagesize(value db, value v) {
+ CAMLparam2(db,v);
+ int err;
+
+ test_db_closed(db);
+
+ err = UW_db(db)->set_pagesize(UW_db(db),Int_val(v));
+ if (err != 0) { UW_db(db)->err(UW_db(db),err,"caml_db_set_pagesize"); }
+
+ CAMLreturn (Val_unit);
+}
+
+//+ external set_cachesize : t -> gbytes:int -> bytes:int
+//+ -> ncache:int -> unit = "caml_db_set_cachesize"
+value caml_db_set_cachesize(value db, value gbytes, value bytes, value ncache) {
+ CAMLparam4(db, gbytes, bytes, ncache);
+ int err;
+
+ test_db_closed(db);
+
+ err = UW_db(db)->set_cachesize(UW_db(db),Int_val(gbytes), Int_val(bytes),
+ Int_val(ncache));
+ if (err != 0) { UW_db(db)->err(UW_db(db),err,"caml_db_set_cachesize"); }
+
+ CAMLreturn (Val_unit);
+}
+
+
+//+ external sync : t -> unit = "caml_db_sync"
+value caml_db_sync(value db) {
+ CAMLparam1(db);
+ int err;
+
+ test_db_closed(db);
+ err = UW_db(db)->sync(UW_db(db),0);
+ if (err != 0) { UW_db(db)->err(UW_db(db),err,"caml_db_sync"); }
+
+ CAMLreturn (Val_unit);
+}
+
+
+//+ external get_size : t -> int = "caml_db_get_size"
+value caml_db_get_size(value db) {
+ CAMLparam1(db);
+ int err;
+ void *stat;
+ int size;
+ DB_TXN *txn = NULL;
+
+ test_db_closed(db);
+ err = UW_db(db)->stat(UW_db(db),txn,&stat,0);
+ if (err != 0) { UW_db(db)->err(UW_db(db),err,"caml_db_get_size"); }
+ switch (*(u_int32_t*)stat) {
+ case DB_BTREEMAGIC:
+ size = ((DB_BTREE_STAT*)stat)->bt_ndata;
+ break;
+ case DB_HASHMAGIC:
+ size = ((DB_HASH_STAT*)stat)->hash_ndata;
+ break;
+ case DB_QAMMAGIC:
+ size = ((DB_QUEUE_STAT*)stat)->qs_ndata;
+ break;
+ default:
+ break;
+ }
+
+ free(stat);
+ CAMLreturn (Val_int(size));
+}
+
+
+
+
+// Termination of Db module
+//+
+//+ end
+//+
+
+//*******************************************************************
+//*******************************************************************
+
+// #############################################################
+// Opening of Cursor moudle
+//+
+//+ module Cursor =
+//+ struct
+//+
+//+ type t = cursor
+
+//*******************************************************************
+//*******************************************************************
+
+static int cursor_put_flags[] = {
+ DB_AFTER, DB_BEFORE, DB_CURRENT
+};
+
+//+
+//+ type put_flag = AFTER | BEFORE | CURRENT
+
+static int cursor_kput_flags[] = {
+ DB_KEYFIRST, DB_KEYLAST, DB_NODUPDATA
+};
+
+//+
+//+ type kput_flag = KEYFIRST | KEYLAST | NODUPDATA
+
+static int cursor_get_type[] = {
+ DB_CURRENT, DB_FIRST, DB_LAST,
+ DB_NEXT, DB_PREV, DB_NEXT_DUP, DB_NEXT_NODUP, DB_PREV_NODUP, 0
+};
+
+//+
+//+ type get_type = CURRENT | FIRST | LAST
+//+ | NEXT | PREV | NEXT_DUP | NEXT_NODUP
+//+ | PREV_NODUP | NULL
+
+static int cursor_get_flags[] = { DB_RMW };
+
+//+
+//+ type get_flag = RMW
+
+//*******************************************************************
+//*******************************************************************
+
+//+ (* Note: A cursor created with a transaction must be closed before
+//+ the transaction is committed or aborted *)
+//+ external create : ?writecursor:bool -> ?txn:txn -> Db.t -> t
+//+ = "caml_cursor_create"
+value caml_cursor_create(value vwritecursor, value txn_opt, value db) {
+ CAMLparam3(vwritecursor,txn_opt,db);
+ int err;
+ int flags = 0;
+ CAMLlocal1(rval);
+ DBC *cursor;
+ DB_TXN *txn;
+
+ if (Is_None(txn_opt)) { txn = NULL; }
+ else {
+ test_txn_closed(Some_val(txn_opt));
+ txn = UW_txn(Some_val(txn_opt));
+ }
+
+ test_db_closed(db);
+
+ // setup flags from vwritecursor
+ if (Is_Some(vwritecursor) && Bool_val(Some_val(vwritecursor))) {
+ flags = DB_WRITECURSOR;
+ }
+
+ // printf("%d\n",ctr++); fflush(stdout);
+
+ err = UW_db(db)->cursor(UW_db(db),txn,&cursor,flags);
+ if (err != 0) {
+ UW_db(db)->err(UW_db(db),err, "caml_cursor_create");
+ }
+
+ rval = alloc_custom(&cursor_custom,Camlcursor_wosize,0,1);
+
+ UW_cursor(rval) = cursor;
+ UW_cursor_closed(rval) = False;
+ CAMLreturn (rval);
+}
+
+//+ external close : t -> unit = "caml_cursor_close"
+value caml_cursor_close(value cursor) {
+ CAMLparam1(cursor);
+ int err;
+
+ //fprintf(stderr,"Closing Dbenv\n"); fflush(stderr);
+ err = caml_cursor_close_internal(cursor);
+ if (err != 0) { raise_db(db_strerror(err)); }
+ //fprintf(stderr,"Dbenv Closed\n"); fflush(stderr);
+
+ CAMLreturn (Val_unit);
+}
+
+//+ external put : t -> string -> put_flag -> unit
+//+ = "caml_cursor_put"
+value caml_cursor_put(value cursor, value vdata, value vflag) {
+ CAMLparam3(cursor,vdata,vflag);
+ DBT key, data;
+ int flags, err;
+
+ test_cursor_closed(cursor);
+
+ bzero(&key,sizeof(DBT)); bzero(&data,sizeof(DBT));
+
+ data.data = String_val(vdata);
+ data.size = string_length(vdata);
+ flags = Flag_val(vflag, cursor_put_flags);
+
+ err = UW_cursor(cursor)->c_put(UW_cursor(cursor), &key, &data, flags);
+ if (err != 0) {
+ if (err == DB_KEYEXIST) { raise_key_exists(); }
+ raise_db(db_strerror(err));
+ }
+
+ CAMLreturn (Val_unit);
+}
+
+//+ external kput : t -> key:string -> data:string -> kput_flag -> unit
+//+ = "caml_cursor_kput"
+value caml_cursor_kput(value cursor, value vkey, value vdata, value vflag) {
+ CAMLparam4(cursor,vkey,vdata,vflag);
+ DBT key, data;
+ int flags, err;
+
+ test_cursor_closed(cursor);
+
+ bzero(&key,sizeof(DBT)); bzero(&data,sizeof(DBT));
+
+ key.data = String_val(vkey);
+ key.size = string_length(vkey);
+ data.data = String_val(vdata);
+ data.size = string_length(vdata);
+ flags = Flag_val(vflag,cursor_kput_flags);
+
+ err = UW_cursor(cursor)->c_put(UW_cursor(cursor), &key, &data, flags);
+ if (err != 0) {
+ if (err == DB_KEYEXIST) { raise_key_exists(); }
+ raise_db(db_strerror(err));
+ }
+
+ CAMLreturn (Val_unit);
+}
+
+
+//+ external init : t -> string -> get_flag list -> string
+//+ = "caml_cursor_init"
+value caml_cursor_init(value cursor, value vkey, value vflags) {
+ CAMLparam3(cursor,vkey,vflags);
+ CAMLlocal1(rval);
+ DBT key,data;
+ int flags = convert_flag_list(vflags,cursor_get_flags) | DB_SET;
+ int err;
+
+ test_cursor_closed(cursor);
+
+ bzero(&key,sizeof(DBT)); bzero(&data,sizeof(DBT));
+
+ key.data = String_val(vkey);
+ key.size = string_length(vkey);
+
+ err = UW_cursor(cursor)->c_get(UW_cursor(cursor), &key, &data, flags);
+ if (err != 0) {
+ if (err == DB_NOTFOUND) { raise_not_found(); }
+ raise_db(db_strerror(err));
+ }
+
+ rval = alloc_string(data.size);
+ memcpy (String_val(rval), data.data, data.size);
+ CAMLreturn (rval);
+}
+
+
+//+ external init_range : t -> string -> get_flag list -> string * string
+//+ = "caml_cursor_init_range"
+value caml_cursor_init_range(value cursor, value vkey, value vflags) {
+ CAMLparam3(cursor,vkey,vflags);
+ CAMLlocal3(rkey,rdata,rpair);
+ DBT key,data;
+ int flags = convert_flag_list(vflags,cursor_get_flags) | DB_SET_RANGE;
+ int err;
+
+ bzero(&key,sizeof(DBT)); bzero(&data,sizeof(DBT));
+
+ test_cursor_closed(cursor);
+
+ key.data = String_val(vkey);
+ key.size = string_length(vkey);
+
+ err = UW_cursor(cursor)->c_get(UW_cursor(cursor), &key, &data, flags);
+ if (err != 0) {
+ if (err == DB_NOTFOUND) { raise_not_found(); }
+ raise_db(db_strerror(err));
+ }
+
+ rdata = alloc_string(data.size);
+ memcpy (String_val(rdata), data.data, data.size);
+
+ rkey = alloc_string(key.size);
+ memcpy (String_val(rkey), key.data, key.size);
+
+ rpair = alloc(2,0);
+
+ Store_field(rpair,0,rkey);
+ Store_field(rpair,1,rdata);
+
+ CAMLreturn (rpair);
+}
+
+//+ external init_both : t -> key:string -> data:string
+//+ -> get_flag list -> unit = "caml_cursor_init_both"
+value caml_cursor_init_both(value cursor, value vkey,
+ value vdata , value vflags
+ ) {
+ CAMLparam4(cursor,vkey,vdata,vflags);
+ DBT key,data;
+ int flags;
+ int err;
+
+ int ctr = 0;
+
+ flags = convert_flag_list(vflags,cursor_get_flags) | DB_GET_BOTH;
+ test_cursor_closed(cursor);
+
+ bzero(&key,sizeof(DBT)); bzero(&data,sizeof(DBT));
+
+ key.data = String_val(vkey);
+ key.size = string_length(vkey);
+
+ data.data = String_val(vdata);
+ data.size = string_length(vdata);
+
+ err = UW_cursor(cursor)->c_get(UW_cursor(cursor), &key, &data, flags);
+ if (err != 0) {
+ if (err == DB_NOTFOUND) { raise_not_found (); }
+ raise_db(db_strerror(err));
+ }
+
+ CAMLreturn (Val_unit);
+}
+
+
+//+ external get : t -> get_type -> get_flag list -> string * string
+//+ = "caml_cursor_get"
+value caml_cursor_get(value cursor, value vtype, value vflags) {
+ CAMLparam3(cursor,vtype,vflags);
+ CAMLlocal3(rpair,rkey,rdata);
+ DBT key,data;
+ int flags = Flag_val(vtype,cursor_get_type) |
+ convert_flag_list(vflags,cursor_get_flags);
+ int err;
+ bzero(&key,sizeof(DBT)); bzero(&data,sizeof(DBT));
+
+ test_cursor_closed(cursor);
+
+ err = UW_cursor(cursor)->c_get(UW_cursor(cursor), &key, &data,flags);
+ if (err != 0) {
+ if (err == DB_NOTFOUND) { raise_not_found(); }
+ raise_db(db_strerror(err));
+ }
+
+ rkey = alloc_string(key.size);
+ memcpy (String_val(rkey), key.data, key.size);
+ rdata = alloc_string(data.size);
+ memcpy (String_val(rdata), data.data, data.size);
+ rpair = alloc(2,0);
+ Store_field(rpair,0,rkey);
+ Store_field(rpair,1,rdata);
+ CAMLreturn (rpair);
+}
+
+
+//+ external get_keyonly : t -> get_type -> get_flag list -> string
+//+ = "caml_cursor_get_keyonly"
+value caml_cursor_get_keyonly(value cursor, value vtype, value vflags) {
+ CAMLparam3(cursor,vtype,vflags);
+ CAMLlocal1(rkey);
+ DBT key,data;
+ int flags = Flag_val(vtype,cursor_get_type) |
+ convert_flag_list(vflags,cursor_get_flags);
+ int err;
+ bzero(&key,sizeof(DBT)); bzero(&data,sizeof(DBT));
+
+ test_cursor_closed(cursor);
+
+ err = UW_cursor(cursor)->c_get(UW_cursor(cursor), &key, &data,flags);
+ if (err != 0) {
+ if (err == DB_NOTFOUND) { raise_not_found(); }
+ raise_db(db_strerror(err));
+ }
+
+ rkey = alloc_string(key.size);
+ memcpy (String_val(rkey), key.data, key.size);
+ CAMLreturn (rkey);
+}
+
+
+
+//+ external del : t -> unit = "caml_cursor_del"
+value caml_cursor_del(value cursor) {
+ CAMLparam1(cursor);
+ int err;
+
+ test_cursor_closed(cursor);
+
+ err = UW_cursor(cursor)->c_del(UW_cursor(cursor), 0);
+ if (err != 0) { raise_db(db_strerror(err)); }
+
+ CAMLreturn (Val_unit);
+}
+
+
+//+ external count : t -> int = "caml_cursor_count"
+value caml_cursor_count(value cursor) {
+ CAMLparam1(cursor);
+ int err;
+ db_recno_t counter;
+
+ test_cursor_closed(cursor);
+
+ err = UW_cursor(cursor)->c_count(UW_cursor(cursor), &counter,0);
+ if (err != 0) { raise_db(db_strerror(err)); }
+
+ CAMLreturn (Val_long(counter));
+}
+
+//+ external dup : ?keep_position:bool -> t -> t = "caml_cursor_dup"
+value caml_cursor_dup(value vkeep_position, value cursor) {
+ CAMLparam2(vkeep_position,cursor);
+ CAMLlocal1(rval);
+ int flags = 0, err;
+ DBC *newcursor;
+
+ test_cursor_closed(cursor);
+
+ if (Is_Some(vkeep_position) && Bool_val(vkeep_position)) {
+ flags = DB_POSITION;
+ }
+
+ err = UW_cursor(cursor)->c_dup(UW_cursor(cursor), &newcursor, flags);
+ if (err != 0) { raise_db(db_strerror(err)); }
+
+ rval = alloc_custom(&cursor_custom,Camlcursor_wosize,0,1);
+ UW_cursor(rval) = newcursor;
+ UW_cursor_closed(rval) = False;
+
+ CAMLreturn (rval);
+}
+
+
+//+ external ajoin : ?nosort:bool -> db -> cursor array -> get_flag list ->
+//+ cursor = "caml_join_cursors"
+//+ let join ?nosort db cursor_list get_flag_list =
+//+ ajoin ?nosort db (Array.of_list cursor_list) get_flag_list
+value caml_join_cursors(value vnosort, value db,
+ value vcursors, value vflags) {
+ CAMLparam4(vnosort,db,vcursors,vflags);
+ CAMLlocal1(rval);
+ DBC *jcurs; // pointer to joined cursor
+ int carray_len = Wosize_val(vcursors);
+ int flags = convert_flag_list(vflags,cursor_get_flags);
+ DBC *cursors[carray_len + 1];
+ int i;
+
+ if (Is_Some(vnosort) && Bool_val(vnosort)) {
+ flags = flags | DB_JOIN_NOSORT;
+ }
+
+ for (i=0; i < carray_len; i++) {
+ if (UW_cursor_closed(Field(vcursors,i))) {
+ invalid_argument("caml_join_cursors: Attempt to use closed cursor");
+ }
+ cursors[i] = UW_cursor(Field(vcursors,i));
+ }
+ cursors[i] = NULL;
+ test_db_closed(db);
+
+ UW_db(db)->join(UW_db(db),cursors,&jcurs,flags);
+
+
+ rval = alloc_custom(&cursor_custom,Camlcursor_wosize,0,1);
+ UW_cursor(rval) = jcurs;
+ UW_cursor_closed(rval) = False;
+ CAMLreturn (rval);
+}
+
+// Termination of Cursor module
+//+
+//+ end
+//+
+
+
+// #############################################################
+// Opening of Transaction module
+//+
+//+ module Txn =
+//+ struct
+//+
+//+ type t = txn
+
+
+static int txn_begin_flags[] = {
+ /* DB_DIRTY_READ, */ DB_TXN_NOSYNC, DB_TXN_NOWAIT, DB_TXN_SYNC
+};
+
+//+
+//+ type begin_flag = (* DIRTY_READ | *) NOSYNC | NOWAIT | SYNC
+
+static int txn_checkpoint_flags[] = { DB_FORCE };
+
+//+
+//+ type checkpoint_flag = FORCE
+
+static int txn_commit_flags[] = { DB_TXN_NOSYNC, DB_TXN_SYNC };
+
+//+
+//+ type commit_flag = COM_NOSYNC | COM_SYNC
+
+
+//+
+//+ (* set max # of active transactions *)
+//+ external set_txn_max : dbenv -> int -> unit = "caml_set_txn_max"
+value caml_set_txn_max(value dbenv, value vmax) {
+ CAMLparam2(dbenv,vmax);
+ int err;
+ int max = Int_val(vmax);
+
+ test_dbenv_closed(dbenv);
+
+ err = UW_dbenv(dbenv)->set_tx_max(UW_dbenv(dbenv),max);
+ if (err != 0) {
+ //fprintf(stderr,"Error found: %d\n",err); fflush(stderr);
+ if (err == EINVAL) {
+ invalid_argument("set_txn_max called after dbenv opened");
+ } else {
+ UW_dbenv(dbenv)->err(UW_dbenv(dbenv), err, "caml_set_txn_max");
+ }
+ }
+
+ CAMLreturn(Val_unit);
+
+}
+
+//+ external abort : t -> unit = "caml_txn_abort"
+value caml_txn_abort(value txn) {
+ CAMLparam1(txn);
+ int err;
+
+ test_txn_closed(txn);
+
+ err = UW_txn(txn)->abort(UW_txn(txn));
+ UW_txn_closed(txn) = True;
+ if (err != 0) {
+ //fprintf(stderr,"Error found: %d\n",err); fflush(stderr);
+ if (err == DB_RUNRECOVERY) { raise_run_recovery(); }
+ else { raise_db(db_strerror(err)); }
+ }
+
+ CAMLreturn(Val_unit);
+}
+
+//+ external txn_begin : dbenv -> t option -> begin_flag list -> t
+//+ = "caml_txn_begin"
+value caml_txn_begin(value dbenv, value parent_opt, value vflags) {
+ CAMLparam3(dbenv,parent_opt,vflags);
+ CAMLlocal1(rval);
+ int err,flags;
+ DB_TXN *parent, *newtxn;
+
+ test_dbenv_closed(dbenv);
+
+ flags = convert_flag_list(vflags,txn_begin_flags);
+
+ if (Is_None(parent_opt)) { parent = NULL; }
+ else {
+ test_txn_closed(Some_val(parent_opt));
+ parent = UW_txn(Some_val(parent_opt));
+ //printf("********* parented transaction ***************\n"); fflush(stdout);
+ }
+
+ err = UW_dbenv(dbenv)->txn_begin(UW_dbenv(dbenv), parent, &newtxn, flags);
+ if (err != 0) {
+ if (err == ENOMEM) {
+ failwith("Maximum # of concurrent transactions reached");
+ } else {
+ UW_dbenv(dbenv)->err(UW_dbenv(dbenv), err,"caml_txn_begin");
+ }
+ }
+
+ rval = alloc_custom(&txn_custom,Camltxn_wosize,0,1);
+ UW_txn(rval) = newtxn;
+ UW_txn_closed(rval) = False;
+ CAMLreturn(rval);
+}
+
+
+//+ external checkpoint: dbenv -> kbyte:int -> min:int
+//+ -> checkpoint_flag list -> unit = "caml_txn_checkpoint"
+value caml_txn_checkpoint(value dbenv, value vkbyte, value vmin,
+ value vflags) {
+ CAMLparam4(dbenv,vkbyte,vmin,vflags);
+ int err, kbyte, min, flags;
+
+ test_dbenv_closed(dbenv);
+
+ kbyte = Int_val(vkbyte);
+ min = Int_val(vmin);
+ flags = convert_flag_list(vflags,txn_checkpoint_flags);
+
+ err = UW_dbenv(dbenv)->txn_checkpoint(UW_dbenv(dbenv),kbyte,min,flags);
+ if (err != 0) {
+ //fprintf(stderr,"Error found: %d\n",err); fflush(stderr);
+ if (err = EINVAL) {
+ invalid_argument("caml_txn_checkpoint: no reason specified");
+ } else {
+ UW_dbenv(dbenv)->err(UW_dbenv(dbenv), err, "caml_txn_checkpoint");
+ }
+ }
+
+ CAMLreturn(Val_unit);
+}
+
+//+ external commit: t -> commit_flag list -> unit = "caml_txn_commit"
+value caml_txn_commit(value txn, value vflags) {
+ CAMLparam2(txn,vflags);
+ int err, flags;
+
+ test_txn_closed(txn);
+ flags = convert_flag_list(vflags,txn_commit_flags);
+
+ err = UW_txn(txn)->commit(UW_txn(txn),flags);
+ UW_txn_closed(txn) = True; // transaction can never be used again
+
+ if (err != 0) {
+ //fprintf(stderr,"Error found: %d\n",err); fflush(stderr);
+ if (err == DB_RUNRECOVERY) raise_run_recovery();
+ else raise_db(db_strerror(err));
+ }
+
+ CAMLreturn(Val_unit);
+}
+
+// Termination of Txn module
+//+
+//+ end
+//+
Added: sks/branches/upstream/sks/current/bdb/bdb_stubs.h
===================================================================
--- sks/branches/upstream/sks/current/bdb/bdb_stubs.h (rev 0)
+++ sks/branches/upstream/sks/current/bdb/bdb_stubs.h 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,64 @@
+/*****************************************************************/
+/** DBENV *******************************************************/
+/*****************************************************************/
+
+struct camldbenv {
+ DB_ENV *dbenv;
+ int closed;
+};
+
+/*****************************************************************/
+/*** DB ********************************************************/
+/*****************************************************************/
+
+struct camldb {
+ DB *db;
+ int closed;
+};
+
+/*****************************************************************/
+/*** DB_CURSOR *************************************************/
+/*****************************************************************/
+
+struct camlcursor {
+ DBC *cursor;
+ int closed;
+};
+
+/*****************************************************************/
+/*** DB_TXN ****************************************************/
+/*****************************************************************/
+
+struct camltxn {
+ DB_TXN *txn;
+ int closed;
+};
+
+/*****************************************************************/
+/** DB and DBENV macros ****************************************/
+/*****************************************************************/
+
+// datatype syzes
+#define Camldbenv_wosize (sizeof(struct camldbenv))
+#define Camldb_wosize (sizeof(struct camldb))
+#define Camlcursor_wosize (sizeof(struct camlcursor))
+#define Camltxn_wosize (sizeof(struct camltxn))
+
+// Unwrapping functions
+#define UW_dbenv(v) (((struct camldbenv *)Data_custom_val(v))->dbenv)
+#define UW_dbenv_closed(v) (((struct camldbenv *)Data_custom_val(v))->closed)
+
+#define UW_db(v) (((struct camldb *)Data_custom_val(v))->db)
+#define UW_db_closed(v) (((struct camldb *)Data_custom_val(v))->closed)
+
+#define UW_cursor(v) (((struct camlcursor *)Data_custom_val(v))->cursor)
+#define UW_cursor_closed(v) (((struct camlcursor *)Data_custom_val(v))->closed)
+
+#define UW_txn(v) (((struct camltxn *)Data_custom_val(v))->txn)
+#define UW_txn_closed(v) (((struct camltxn *)Data_custom_val(v))->closed)
+
+#define Is_string(v) (Is_block(v) && (Tag_val(v) == String_tag))
+#define Is_None(v) (!Is_block(v))
+#define Is_Some(v) (Is_block(v))
+#define Some_val(v) (Field(v,0))
+#define Flag_val(vflag,flags) (flags[Long_val(vflag)])
Added: sks/branches/upstream/sks/current/bdb/db.ml
===================================================================
--- sks/branches/upstream/sks/current/bdb/db.ml (rev 0)
+++ sks/branches/upstream/sks/current/bdb/db.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,116 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Francois Rouaix, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU Library General Public License, with *)
+(* the special exception on linking described in file ../../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+(* $Id: db.ml,v 1.1.1.1 2002/10/01 00:10:14 yminsky Exp $ *)
+
+(* Module [Db]: interface to the DB databases *)
+
+(* this collides with Unix *)
+type open_flag =
+ O_CREAT
+ | O_EXCL
+ | O_RDONLY
+ | O_RDWR
+ | O_TRUNC
+
+type routine_flag =
+ R_CURSOR
+ | R_FIRST
+ | R_LAST
+ | R_NEXT
+ | R_NOOVERWRITE
+ | R_PREV
+ | R_SETCURSOR
+
+
+(* All other fields have default values *)
+type btree_flag =
+ Duplicates (* means R_DUP *)
+ | Cachesize of int
+
+
+type file_perm = int
+
+exception DB_error of string
+ (* Raised by the following functions when an error is encountered. *)
+
+external caml_db_init : unit -> unit
+ = "caml_db_init"
+
+let _ = Callback.register_exception "dberror" (DB_error "")
+let _ = caml_db_init()
+
+type key = string
+type data = string
+type t
+
+(* Raw access *)
+external dbopen : string -> open_flag list -> file_perm -> btree_flag list -> t
+ = "caml_db_open"
+ (* [dbopen file flags mode dupentries] *)
+
+(* The common subset of available primitives *)
+external close : t -> unit
+ = "caml_db_close"
+
+external del : t -> key -> routine_flag list -> unit
+ = "caml_db_del"
+ (* raise Not_found if the key was not in the file *)
+
+external get : t -> key -> routine_flag list -> data
+ = "caml_db_get"
+ (* raise Not_found if the key was not in the file *)
+
+external put : t -> key:key -> data:data -> routine_flag list -> unit
+ = "caml_db_put"
+
+external seq : t -> key -> routine_flag list -> (key * data)
+ = "caml_db_seq"
+
+external sync : t -> unit
+ = "caml_db_sync"
+
+
+(* Wrap-up as for other table-like types *)
+let add db ~key:x ~data:v = put db x v [R_NOOVERWRITE]
+let find db x = get db x []
+let find_all db x =
+ try
+ match seq db x [R_CURSOR] with
+ k, v when k = x ->
+ let l = ref [v] in
+ begin
+ try
+ while true do
+ let k, v = seq db x [R_NEXT] in
+ if k = x then l := v :: !l
+ else raise Exit
+ done;
+ !l
+ with
+ Exit | Not_found -> !l
+ end
+ | _ -> (* its greater than x *) []
+ with
+ Not_found -> []
+
+let remove db x = del db x []
+
+let iter ~f db =
+ let rec walk = function
+ None -> ()
+ | Some(k, v) ->
+ f ~key:k ~data:v;
+ walk (try Some(seq db k [R_NEXT]) with Not_found -> None)
+ in
+ walk (try Some(seq db "" [R_FIRST]) with Not_found -> None)
Added: sks/branches/upstream/sks/current/bdb/db.mli
===================================================================
--- sks/branches/upstream/sks/current/bdb/db.mli (rev 0)
+++ sks/branches/upstream/sks/current/bdb/db.mli 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,82 @@
+(***********************************************************************)
+(* *)
+(* Objective Caml *)
+(* *)
+(* Francois Rouaix, projet Cristal, INRIA Rocquencourt *)
+(* *)
+(* Copyright 1996 Institut National de Recherche en Informatique et *)
+(* en Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU Library General Public License, with *)
+(* the special exception on linking described in file ../../LICENSE. *)
+(* *)
+(***********************************************************************)
+
+(* $Id: db.mli,v 1.1.1.1 2002/10/01 00:10:14 yminsky Exp $ *)
+
+(* Module [Db]: interface to the DB databases of type btree. Cf dbopen(3) *)
+
+(* this collides with Unix *)
+type open_flag =
+ O_CREAT
+ | O_EXCL
+ | O_RDONLY
+ | O_RDWR
+ | O_TRUNC
+
+type routine_flag =
+ R_CURSOR
+ | R_FIRST
+ | R_LAST
+ | R_NEXT
+ | R_NOOVERWRITE
+ | R_PREV
+ | R_SETCURSOR
+
+(* All other fields have default values *)
+type btree_flag =
+ Duplicates (* means R_DUP *)
+ | Cachesize of int
+
+type file_perm = int
+
+exception DB_error of string
+ (* Raised by the following functions when an error is encountered. *)
+
+type key = string
+type data = string
+
+type t
+
+(* Raw access *)
+external dbopen :
+ string -> open_flag list -> file_perm -> btree_flag list -> t
+ = "caml_db_open"
+ (* [dbopen file flags mode] *)
+
+(* The common subset of available primitives *)
+external close : t -> unit
+ = "caml_db_close"
+
+external del : t -> key -> routine_flag list -> unit
+ = "caml_db_del"
+ (* raise Not_found if the key was not in the file *)
+
+external get : t -> key -> routine_flag list -> data
+ = "caml_db_get"
+ (* raise Not_found if the key was not in the file *)
+
+external put : t -> key:key -> data:data -> routine_flag list -> unit
+ = "caml_db_put"
+
+external seq : t -> key -> routine_flag list -> (key * data)
+ = "caml_db_seq"
+
+external sync : t -> unit
+ = "caml_db_sync"
+
+
+val add : t -> key:key -> data:data -> unit
+val find : t -> key -> data
+val find_all : t -> key -> data list
+val remove : t -> key -> unit
+val iter : f:(key:string -> data:string -> unit) -> t -> unit
Added: sks/branches/upstream/sks/current/bdb/dbstubs.c
===================================================================
--- sks/branches/upstream/sks/current/bdb/dbstubs.c (rev 0)
+++ sks/branches/upstream/sks/current/bdb/dbstubs.c 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,274 @@
+/***********************************************************************/
+/* */
+/* Objective Caml */
+/* */
+/* Francois Rouaix, projet Cristal, INRIA Rocquencourt */
+/* */
+/* Copyright 1996 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the GNU Library General Public License, with */
+/* the special exception on linking described in file ../../LICENSE. */
+/* */
+/***********************************************************************/
+
+/* $Id: dbstubs.c,v 1.1.1.1 2002/10/01 00:10:14 yminsky Exp $ */
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/fail.h>
+#include <caml/callback.h>
+
+
+#include <sys/types.h>
+#include <limits.h>
+#include <db.h>
+/* O_CREAT and others are not defined in db.h */
+#include <fcntl.h>
+
+#include <string.h>
+#include "dbstubs.h"
+
+/* This MUST be in the same order as in dbm.mli
+ * We take a minimum (check O_NONBLOCK ?)
+ */
+static int db_open_flags[] = {
+ O_CREAT, O_EXCL, O_RDONLY, O_RDWR, O_TRUNC
+};
+
+/* R_IAFTER, R_IBEFORE, , R_RECNOSYNC : not relevant for btrees */
+static int db_other_flags[] = {
+};
+
+/* Exception bucket for Db.error */
+static value *caml_db_exn = NULL;
+
+void raise_db(errmsg)
+ char *errmsg;
+{
+ raise_with_string(*caml_db_exn, errmsg);
+}
+
+
+
+value caml_open_dbenv(value name) {
+ DB *dbp;
+ int err;
+
+ err = db_env_create(&dbenv,0);
+ if (err != 0) { printf(raise_db("db_env_create error: ")); }
+
+ err = dbenv->open(dbenv,
+ DIRNAME,
+ DB_CREATE | DB_INIT_MPOOL,
+ S_IRUSR | S_IWUSR );
+ if (err != 0) { raise_db("dbenv open error: "); }
+ camldbenv {
+
+ }
+
+}
+
+
+
+
+
+
+/* Finalisation function : occurs once at most !*/
+int caml_db_close_internal(value cdb)
+{
+ /* close the db if needed */
+ // DB_ENV dbenv;
+ // DBENV->close(&dbenv,0);
+ if (!Camldb_closed(cdb)) {
+ Camldb_closed(cdb) = 1;
+ return Camldb_db(cdb)->close(Camldb_db(cdb));
+ }
+ else
+ return 0;
+}
+
+static void caml_db_free(value cdb)
+{
+ /* close the db if needed */
+ caml_db_close_internal(cdb);
+ /* free the structure */
+ // stat_free((void *)Camldb_info(cdb));
+}
+
+/*
+ * The primitives
+ */
+value caml_db_close(value cdb) /* ML */
+{
+ if (caml_db_close_internal(cdb) == 0)
+ return Val_unit;
+ else
+ raise_db("close");
+}
+
+value caml_db_del(value cdb, value key, value vflags) /* ML */
+{
+ /* Note: we could check that db is still open */
+ DBT dbt;
+ int flags;
+
+ Assert(Is_string(key));
+ dbt.data = String_val(key);
+ dbt.size = string_length(key);
+ flags = convert_flag_list(vflags, db_other_flags);
+
+ if ( 0 == Camldb_db(cdb)->del(Camldb_db(cdb), &dbt, flags))
+ return Val_unit;
+ else
+ raise_db("del");
+}
+
+/* fd: is said to be obsolete */
+value caml_db_get(value cdb, value vkey, value vflags) /* ML */
+{
+ DBT key;
+ DBT data;
+ int flags;
+
+ key.data = String_val(vkey);
+ key.size = string_length(vkey);
+ flags = convert_flag_list(vflags, db_other_flags);
+
+ switch (Camldb_db(cdb)->get(Camldb_db(cdb), &key, &data, flags)) {
+ case 0: /* success */
+ {
+ value res = alloc_string(data.size);
+ memmove (String_val (res), data.data, data.size);
+ return res;
+ }
+ case 1: /* not found */
+ raise_not_found();
+ default:
+ raise_db("get");
+ }
+}
+
+value caml_db_put(value cdb, value vkey, value vdata, value vflags) /* ML */
+{
+ DBT key;
+ DBT data;
+ int flags;
+
+ key.data = String_val(vkey);
+ key.size = string_length(vkey);
+ data.data = String_val(vdata);
+ data.size = string_length(vdata);
+ flags = convert_flag_list(vflags, db_other_flags);
+
+ switch (Camldb_db(cdb)->put(Camldb_db(cdb), &key, &data, flags)) {
+ case 0: /* success */
+ return Val_unit;
+ case 1: /* R_NOOVERWRITE + exists */
+ raise_db("Entry already exists");
+ default:
+ raise_db("put");
+ }
+}
+
+
+value caml_db_seq(value cdb, value vkey, value vflags) /* ML */
+{
+ DBT key;
+ DBT data;
+ int flags;
+
+ key.data = String_val(vkey);
+ key.size = string_length(vkey);
+
+ flags = convert_flag_list(vflags, db_other_flags);
+ switch (Camldb_db(cdb)->seq(Camldb_db(cdb), &key, &data, flags)) {
+ case 0: /* success */
+ {
+ value reskey = Val_unit, resdata = Val_unit, res = Val_unit;
+ Begin_roots3(reskey, resdata, res);
+ reskey = alloc_string(key.size);
+ resdata = alloc_string(data.size);
+ res = alloc_small(2, 0);
+ memmove (String_val (reskey), key.data, key.size);
+ memmove (String_val (resdata), data.data, data.size);
+ Field(res, 0) = reskey;
+ Field(res, 1) = resdata;
+ End_roots();
+ return res;
+ }
+ case 1:
+ raise_not_found();
+ default:
+ raise_db("seq");
+ }
+}
+
+
+value caml_db_sync(value cdb) /* ML */
+{
+ if (0 == Camldb_db(cdb)->sync(Camldb_db(cdb), 0))
+ return Val_unit;
+ else
+ raise_db("sync");
+}
+
+value caml_db_open(value vfile, value vflags, value vmode, value vpars) /* ML */
+{
+ char *file = String_val(vfile);
+ int flags = convert_flag_list(vflags, db_open_flags);
+ int mode = Int_val(vmode);
+ BTREEINFO *info;
+ DB *db;
+
+ /* Infos for btree structure : 0 is default everywhere */
+ info = stat_alloc(sizeof(BTREEINFO));
+ bzero(info, sizeof(BTREEINFO));
+
+ while (Is_block(vpars)) {
+ value par = Field(vpars, 0);
+ if (Is_block(par)) { /* It's a non-constant constructor */
+ switch(Tag_val(par)) {
+ case 0: /* Cachesize */
+ info->cachesize = Int_val(Field(par, 0));
+ default:
+ break;
+ }
+ } else { /* It's a constant constructor */
+ switch (Int_val(par)) {
+ case 0: /* Duplicates */
+ info->flags |= R_DUP;
+ break;
+ default:
+ break;
+ }
+ }
+ vpars = Field(vpars, 1);
+ }
+
+ db = dbopen(file,flags,mode,DB_BTREE,info);
+ if (db == NULL) {
+ stat_free(info);
+ raise_db("Can't open file");
+ }
+ else {
+ /* Allocate our structure */
+ value res = alloc_final(Camldb_wosize, caml_db_free, 1, Max_dballoc);
+ Camldb_db(res) = db;
+ Camldb_closed(res) = 0;
+ // Camldb_info(res) = info;
+ return res;
+ }
+}
+
+/* Requires the following Caml code:
+exception DBError of string
+let _ = Callback.register_exception "dberror" (DBError "")
+as well as a call to the init function.
+*/
+value caml_db_init(value v) /* ML */
+{
+ if (caml_db_exn == NULL)
+ caml_db_exn = caml_named_value("dberror");
+ return Val_unit;
+}
Added: sks/branches/upstream/sks/current/bdb/dbstubs.h
===================================================================
--- sks/branches/upstream/sks/current/bdb/dbstubs.h (rev 0)
+++ sks/branches/upstream/sks/current/bdb/dbstubs.h 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,52 @@
+/***********************************************************************/
+/* */
+/* Objective Caml */
+/* */
+/* Francois Rouaix, projet Cristal, INRIA Rocquencourt */
+/* */
+/* Copyright 1996 Institut National de Recherche en Informatique et */
+/* en Automatique. All rights reserved. This file is distributed */
+/* under the terms of the GNU Library General Public License, with */
+/* the special exception on linking described in file ../../LICENSE. */
+/* */
+/***********************************************************************/
+
+#define Max_dballoc 1000000
+
+
+struct camldbenv {
+ final_fun f;
+ DBENV *dbenv;
+ int closed;
+}
+
+#define Camldbenv_wosize \
+ ((sizeof(struct camldbenv) + sizeof(value) - 1) / sizeof(value))
+
+#define Camldbenv_dbenv(v) (((struct camldbenv *)(Bp_val(v)))->dbenv)
+#define Camldbenv_closed(v) (((struct camldbenv *)(Bp_val(v)))->closed)
+
+#define Is_string(v) (Is_block(v) && (Tag_val(v) == String_tag))
+
+
+/* A DB is a finalized value containing
+ * a pointer to the DB,
+ * a pointer to the openstruct
+ * (this could be removed if we were sure that the library doesn't keep
+ * a pointer to it !)
+ */
+struct camldb {
+ final_fun f;
+ DB *db;
+ // BTREEINFO *info;
+ int closed;
+};
+
+
+#define Camldb_wosize \
+ ((sizeof(struct camldb) + sizeof(value) - 1) / sizeof(value))
+
+#define Camldb_db(v) (((struct camldb *)(Bp_val(v)))->db)
+#define Camldb_closed(v) (((struct camldb *)(Bp_val(v)))->closed)
+
+#define Is_string(v) (Is_block(v) && (Tag_val(v) == String_tag))
Added: sks/branches/upstream/sks/current/bdb/ocextr.ml
===================================================================
--- sks/branches/upstream/sks/current/bdb/ocextr.ml (rev 0)
+++ sks/branches/upstream/sks/current/bdb/ocextr.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,26 @@
+open StdLabels
+open MoreLabels
+open Printf
+
+let fname = try Sys.argv.(1) with _ ->
+ eprintf "No file specified\n";
+ exit (-1)
+
+let file = open_in fname
+let () =
+ try
+ while true do
+ let line = input_line file in
+ let length = String.length line in
+ if length >= 3 &&
+ String.sub line ~pos:0 ~len:3 = "//+"
+ then
+ if length = 3 then print_string "\n"
+ else
+ if line.[3] = ' ' then
+ printf "%s\n" (String.sub line ~pos:4 ~len:(length - 4))
+ else
+ printf "%s\n" (String.sub line ~pos:3 ~len:(length - 3))
+ done
+ with
+ End_of_file -> ()
Property changes on: sks/branches/upstream/sks/current/bdb/ocextr.ml
___________________________________________________________________
Added: svn:executable
+ *
Added: sks/branches/upstream/sks/current/bdb/script.ml
===================================================================
--- sks/branches/upstream/sks/current/bdb/script.ml (rev 0)
+++ sks/branches/upstream/sks/current/bdb/script.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,27 @@
+open Db3
+open Printf
+
+(* let _ = popt (Some 8)
+ let _ = popt None *)
+
+(* let _ = Dbenv.sopen dbe "DBTEST"
+ [Dbenv.DB_CREATE ; Dbenv.DB_INIT_MPOOL] 0o777 *)
+
+let db = Db.sopen "testdb" Db.BTREE [Db.CREATE] 0o777
+let _ =
+ (try
+ let rval = Db.get db "foobar" [] in
+ printf "Result unexpectedly found: %s\n" rval
+ with
+ Not_found -> printf "Not_found\n");
+ Db.put db ~key:"foo" ~data:"bar" [];
+ let data = Db.get db "foo" [] in
+ printf "key: %s, data: %s\n" "foo" data;
+ Db.del db "foo";
+ (try
+ let rval = Db.get db "foobar" [] in
+ printf "Result unexpectedly found: %s\n" rval
+ with
+ Not_found -> printf "Not_found\n")
+
+
Added: sks/branches/upstream/sks/current/bdb/temp.ml
===================================================================
--- sks/branches/upstream/sks/current/bdb/temp.ml (rev 0)
+++ sks/branches/upstream/sks/current/bdb/temp.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,169 @@
+(* Exception declarations *)
+
+exception DBError of string
+let _ = Callback.register_exception "dberror" (DBError "")
+
+exception Key_exists
+let _ = Callback.register_exception "keyexists" Key_exists
+
+exception Run_recovery
+let _ = Callback.register_exception "dbrunrecovery" Run_recovery
+
+external db_init : unit -> unit = "caml_db_init"
+let _ = db_init ()
+
+type txn
+type cursor
+type dbenv
+type db
+
+
+module Dbenv =
+struct
+
+ type t = dbenv
+
+ type create_flag = CLIENT
+
+ type open_flag =
+ JOINENV | INIT_CDB | INIT_LOCK | INIT_LOG
+ | INIT_MPOOL | INIT_TXN | RECOVER | RECOVER_FATAL
+ | USE_ENVIRON | USE_ENVIRON_ROOT | CREATE
+ | LOCKDOWN | PRIVATE | SYSTEM_MEM | THREAD
+
+ type verbose_flag =
+ VERB_CHKPOINT | VERB_DEADLOCK | VERB_RECOVERY | VERB_WAITSFOR
+
+ external create : create_flag list -> t = "caml_dbenv_create"
+ external dopen : t -> string -> open_flag list -> int -> unit =
+ "caml_dbenv_open"
+ let sopen dirname flags mode =
+ let dbenv = create [] in
+ dopen dbenv dirname flags mode;
+ dbenv
+ external close : t -> unit = "caml_dbenv_close"
+ external set_verbose_internal : t -> verbose_flag list ->
+ bool -> unit = "caml_dbenv_set_verbose"
+ let set_verbose dbenv flag onoff =
+ set_verbose_internal dbenv [flag] onoff
+ external set_cachesize : t -> gbytes:int -> bytes:int ->
+ ncache:int -> unit = "caml_dbenv_set_cachesize"
+
+end
+
+
+module Db =
+struct
+
+ type t = db
+
+ type create_flag = XA_CREATE
+
+ type open_flag =
+ CREATE | EXCL | NOMMAP | RDONLY | THREAD | TRUNCATE
+
+ type db_type = BTREE | HASH | QUEUE | RECNO | UNKNOWN
+
+ type put_flag = APPEND | NODUPDATA | NOOVERWRITE
+
+ type get_flag = CONSUME | CONSUME_WAIT | SET_RECNO | RMW
+
+ type set_flag = DUP | DUPSORT | RECNUM | REVSPLITOFF
+ | RENUMBER | SNAPSHOT
+
+ external create : ?dbenv:Dbenv.t -> create_flag list -> t =
+ "caml_db_create"
+ external dopen : t -> string -> db_type -> open_flag list
+ -> int -> unit = "caml_db_open"
+ external close : t -> unit = "caml_db_close"
+ external del : t -> ?txn:txn -> string -> unit = "caml_db_del"
+ external put : t -> ?txn:txn -> key:string -> data:string
+ -> put_flag list -> unit = "caml_db_put"
+ external get : t -> ?txn:txn -> string -> get_flag list -> string
+ = "caml_db_get"
+ external set_flags : t -> set_flag list -> unit = "caml_db_set_flags"
+
+ let sopen ?dbenv fname dbtype ?moreflags flags mode =
+ let db = create ?dbenv [] in
+ (match moreflags with
+ None -> ()
+ | Some flags -> set_flags db flags );
+ dopen db fname dbtype flags mode;
+ db
+ external set_h_ffactor : t -> int -> unit
+ = "caml_db_set_h_ffactor"
+ external set_pagesize : t -> int -> unit
+ = "caml_db_set_pagesize"
+ external set_cachesize : t -> gbytes:int -> bytes:int
+ -> ncache:int -> unit = "caml_db_set_cachesize"
+ external sync : t -> unit = "caml_db_sync"
+
+end
+
+
+module Cursor =
+struct
+
+ type t = cursor
+
+ type put_flag = AFTER | BEFORE | CURRENT
+
+ type kput_flag = KEYFIRST | KEYLAST | NODUPDATA
+
+ type get_type = CURRENT | FIRST | LAST
+ | NEXT | PREV | NEXT_DUP | NEXT_NODUP
+ | PREV_NODUP | NULL
+
+ type get_flag = RMW
+ (* Note: A cursor created with a transaction must be closed before
+ the transaction is committed or aborted *)
+ external create : ?writecursor:bool -> ?txn:txn -> Db.t -> t
+ = "caml_cursor_create"
+ external close : t -> unit = "caml_cursor_close"
+ external put : t -> string -> put_flag -> unit
+ = "caml_cursor_put"
+ external kput : t -> key:string -> data:string -> kput_flag -> unit
+ = "caml_cursor_kput"
+ external init : t -> string -> get_flag list -> string
+ = "caml_cursor_init"
+ external init_range : t -> string -> get_flag list -> string * string
+ = "caml_cursor_init_range"
+ external init_both : t -> key:string -> data:string
+ -> get_flag list -> unit = "caml_cursor_init_both"
+ external get : t -> get_type -> get_flag list -> string * string
+ = "caml_cursor_get"
+ external get_keyonly : t -> get_type -> get_flag list -> string
+ = "caml_cursor_get_keyonly"
+ external del : t -> unit = "caml_cursor_del"
+ external count : t -> int = "caml_cursor_count"
+ external dup : ?keep_position:bool -> t -> t = "caml_cursor_dup"
+ external ajoin : ?nosort:bool -> db -> cursor array -> get_flag list ->
+ cursor = "caml_join_cursors"
+ let join ?nosort db cursor_list get_flag_list =
+ ajoin ?nosort db (Array.of_list cursor_list) get_flag_list
+
+end
+
+
+module Txn =
+struct
+
+ type t = txn
+
+ type begin_flag = (* DIRTY_READ | *) NOSYNC | NOWAIT | SYNC
+
+ type checkpoint_flag = FORCE
+
+ type commit_flag = COM_NOSYNC | COM_SYNC
+
+ (* set max # of active transactions *)
+ external set_txn_max : dbenv -> int -> unit = "caml_set_txn_max"
+ external abort : t -> unit = "caml_txn_abort"
+ external txn_begin : dbenv -> t option -> begin_flag list -> t
+ = "caml_txn_begin"
+ external checkpoint: dbenv -> kbyte:int -> min:int
+ -> checkpoint_flag list -> unit = "caml_txn_checkpoint"
+ external commit: t -> commit_flag list -> unit = "caml_txn_commit"
+
+end
+
Added: sks/branches/upstream/sks/current/bdb/templ.c
===================================================================
--- sks/branches/upstream/sks/current/bdb/templ.c (rev 0)
+++ sks/branches/upstream/sks/current/bdb/templ.c 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,10 @@
+//+ external CAMLFUNC : TYPESIG
+//+ = "CFUNC"
+value CFUNC(VALUELIST) {
+ CAMLparamX(VALUES);
+ CAMLlocalX(LOCAL);
+
+ CODE
+
+ CAMLreturn (RVAL);
+}
Added: sks/branches/upstream/sks/current/bdb/test.ml
===================================================================
--- sks/branches/upstream/sks/current/bdb/test.ml (rev 0)
+++ sks/branches/upstream/sks/current/bdb/test.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,154 @@
+(* Module for testing out the functionality of the Berkeley DB interface *)
+
+open StdLabels
+open MoreLabels
+module Unix = UnixLabels
+open Printf
+open Bdb
+module SMap = Map.Make(struct type t = string let compare = compare end)
+module Set = PSet.Set
+
+exception TestFailed of string
+
+let _ = Random.self_init ()
+
+let chars = "abcdefghijklmnopqrstuvwxyz123456789"
+let rand_string len =
+ let s = String.create len in
+ for i = 0 to String.length s - 1 do
+ s.[i] <- chars.[Random.int (String.length chars)]
+ done;
+ s
+
+let prepare_dir dirname =
+ if MUnix.exists dirname then
+ ignore (Unix.system (sprintf "rm -r %s" dirname));
+ Unix.mkdir dirname
+
+let prepare_file fname =
+ if MUnix.exists fname then Unix.unlink fname
+
+
+let simple_test () =
+ let fname = "FOO" in
+ prepare_file fname;
+ let db = Db.sopen fname Db.HASH [ Db.CREATE ] 0o777 in
+ let map = ref SMap.empty in
+ for i = 0 to 1000 do
+ let key = rand_string 5
+ and data = rand_string 10
+ in
+ map := SMap.add key data !map;
+ Db.put db ~key ~data []
+ done;
+ SMap.iter ~f:(fun ~key ~data ->
+ let dbdata = Db.get db key [] in
+ if dbdata <> data
+ then raise (TestFailed "simple_test: values do not agree")) !map;
+ SMap.iter ~f:(fun ~key ~data -> Db.del db key) !map;
+ SMap.iter ~f:(fun ~key ~data ->
+ try
+ let dbdata = Db.get db key [] in
+ raise (TestFailed "simple_test: deleted value found anyway")
+ with
+ Not_found -> ()
+ ) !map;
+ print_string "Simple Test passed\n"
+
+
+let leak_test () =
+ let size = 10000 in
+ for i = 1 to size do
+ let x = Dbenv.create [] in
+ Dbenv.close x
+ done;
+ for i = 1 to size do
+ let x = Db.create [] in
+ Db.close x
+ done;
+ for i = 1 to size do
+ let x = Db.create [] in
+ Db.close x
+ done;
+ let fname = "FOO" in
+ prepare_file fname;
+ let db = Db.sopen fname Db.BTREE [ Db.CREATE ] 0o777 in
+ for i = 1 to size do
+ let x = Cursor.create db in
+ Cursor.close x
+ done;
+ print_string "Leak Test completed\n"
+
+let cursor_get_all c =
+ let rec loop list =
+ try loop (Cursor.get c Cursor.NEXT_DUP [] :: list)
+ with Not_found -> list
+ in
+ let first = Cursor.get c Cursor.CURRENT [] in
+ loop [first]
+
+let jcursor_get_all c =
+ let rec loop list =
+ match (try Some (Cursor.get c Cursor.NULL [])
+ with Not_found -> None)
+ with
+ Some (key,data) -> loop (data::list)
+ | None -> list
+ in
+ loop []
+
+let cursor_test () =
+ let idbname = "FOO" and pdbname = "BAR" in
+ prepare_file idbname; prepare_file pdbname;
+ let idb = Db.sopen idbname Db.HASH
+ ~moreflags:[Db.DUP] [ Db.CREATE ] 0o777 in
+ let pdb = Db.sopen pdbname Db.HASH [ Db.CREATE ] 0o777 in
+ let ci = Cursor.create idb and cp = Cursor.create pdb in
+ let common =
+ Set.of_list (MList.init 10 ~f:(fun i -> rand_string 30)) in
+ let s1 = Set.union common
+ (Set.of_list (MList.init 10 ~f:(fun i -> rand_string 30)))
+ and s2 = Set.union common
+ (Set.of_list (MList.init 10 ~f:(fun i -> rand_string 30)))
+ and s3 = Set.union common
+ (Set.of_list (MList.init 10 ~f:(fun i -> rand_string 30)))
+ and key1 = rand_string 10
+ and key2 = rand_string 10
+ and key3 = rand_string 10
+ in
+ Set.iter ~f:(fun data ->
+ Cursor.kput cp ~key:data ~data:data Cursor.KEYLAST;
+ Cursor.kput ci ~key:key1 ~data:data Cursor.KEYLAST) s1;
+ Set.iter ~f:(fun data ->
+ Cursor.kput cp ~key:data ~data:data Cursor.KEYLAST;
+ Cursor.kput ci ~key:key2 ~data:data Cursor.KEYLAST) s2;
+ Set.iter ~f:(fun data ->
+ Cursor.kput cp ~key:data ~data:data Cursor.KEYLAST;
+ Cursor.kput ci ~key:key3 ~data:data Cursor.KEYLAST) s3;
+ Cursor.close cp;
+ Cursor.close ci;
+
+ let c1 = Cursor.create idb
+ and c2 = Cursor.create idb
+ and c3 = Cursor.create idb in
+ ignore (Cursor.init c1 key1 []);
+ ignore (Cursor.init c2 key2 []);
+ ignore (Cursor.init c3 key3 []);
+ let cj = Cursor.join pdb [c1;c2;c3] [] in
+ let jcommon = Set.of_list (jcursor_get_all cj) in
+ (*
+ let rs1 = Set.of_list (cursor_get_all c1)
+ and rs2 = Set.of_list (cursor_get_all c2)
+ and rs3 = Set.of_list (cursor_get_all c3) in
+ let rcommon = Set.inter (Set.inter rs1 rs2) rs3 in
+ *)
+ if not (Set.equal jcommon common)
+ then raise (TestFailed "sets not equal");
+ print_string "Cursor Test passed\n"
+
+
+
+ let _ =
+ simple_test ();
+ leak_test ();
+ cursor_test ()
Added: sks/branches/upstream/sks/current/bdbwrap.ml
===================================================================
--- sks/branches/upstream/sks/current/bdbwrap.ml (rev 0)
+++ sks/branches/upstream/sks/current/bdbwrap.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,117 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Wrapper module for Bdb to allow for logging of database operations *)
+open Common
+open Printf
+
+exception Key_exists = Bdb.Key_exists
+
+let wrap name f =
+ plerror 10 "( Starting %s" name;
+ try
+ let rval = f () in
+ plerror 10 " %s Done )" name;
+ rval
+ with
+ e ->
+ plerror 10 " %s Done <%s>)" name (Printexc.to_string e);
+ raise e
+
+
+module Dbenv =
+struct
+ include Bdb.Dbenv
+ let create x = wrap "Dbenv.create" (fun () -> create x)
+ let dopen x y z w = wrap "Dbenv.dopen" (fun () -> dopen x y z w)
+ let sopen x y z = wrap "Dbenv.sopen" (fun () -> sopen x y z)
+ let close x = wrap "Dbenv.close" (fun () -> close x)
+ let set_verbose_internal x y z =
+ wrap "Dbenv.set_verbose_internal" (fun () -> set_verbose_internal x y z)
+ let set_verbose x y z = wrap "Dbenv.set_verbose"
+ (fun () -> set_verbose x y z)
+ let set_cachesize x ~gbytes ~bytes ~ncache =
+ wrap "Dbenv.set_cachesize" (fun () -> set_cachesize x
+ ~gbytes ~bytes ~ncache)
+end
+
+
+module Db =
+struct
+ include Bdb.Db
+
+ let create ?dbenv y = wrap "Db.create" (fun () -> create ?dbenv y)
+ let dopen x y z w u = wrap "Db.dopen" (fun () -> dopen x y z w u)
+ let close x = wrap "Db.close" (fun () -> close x)
+ let del x ?txn y = wrap "Db.del" (fun () -> del x ?txn y)
+ let put x ?txn ~key ~data y = wrap "Db.put"
+ (fun () -> put x ?txn ~key ~data y)
+ let get x ?txn y z = wrap "Db.get" (fun () -> get x ?txn y z )
+ let set_flags x y = wrap "Db.set_flags" (fun () -> set_flags x y)
+ let sopen ?dbenv x y ?moreflags z w =
+ wrap "Db.sopen" (fun () -> sopen ?dbenv x y ?moreflags z w )
+
+ let set_h_ffactor x y = wrap "Db.set_h_ffactor"
+ (fun () -> set_h_ffactor x y)
+ let set_pagesize x y = wrap "Db.set_pagesize" (fun () -> set_pagesize x y)
+ let set_cachesize x ~gbytes ~bytes ~ncache =
+ wrap "Db.set_cachesize" (fun () -> set_cachesize x ~gbytes ~bytes ~ncache)
+ let sync x = wrap "Db.sync" (fun () -> sync x)
+end
+
+
+module Cursor =
+struct
+ include Bdb.Cursor
+
+ let create ?writecursor ?txn x =
+ wrap "Cursor.create" (fun () -> create ?writecursor ?txn x)
+ let close x = wrap "Cursor.close" (fun () -> close x)
+ let put x y z = wrap "Cursor.put" (fun () -> put x y z)
+ let kput x ~key ~data y = wrap "Cursor.kput"
+ (fun () -> kput x ~key ~data y )
+ let init x y z = wrap "Cursor.init" (fun () -> init x y z )
+ let init_range x y z = wrap "Cursor.init_range"
+ (fun () -> init_range x y z )
+ let init_both x ~key ~data y =
+ wrap "Cursor.init_both" (fun () -> init_both x ~key ~data y)
+ let get x y z = wrap "Cursor.get" (fun () -> get x y z )
+ let get_keyonly x y z = wrap "Cursor.get_keyonly"
+ (fun () -> get_keyonly x y z )
+ let del x = wrap "Cursor.del" (fun () -> del x)
+ let count x = wrap "Cursor.count" (fun () -> count x )
+ let dup ?keep_position x = wrap "Cursor.dup"
+ (fun () -> dup ?keep_position x)
+ let ajoin ?nosort x y z = wrap "Cursor.ajoin"
+ (fun () -> ajoin ?nosort x y z)
+ let join ?nosort x y z = wrap "Cursor.join"
+ (fun () -> join ?nosort x y z)
+end
+
+
+module Txn =
+struct
+ include Bdb.Txn
+ let set_txn_max x y = wrap "Txn.set_txn_max" (fun () -> set_txn_max x y)
+ let abort x = wrap "Txn.abort" (fun () -> abort x)
+ let txn_begin x y z = wrap "Txn.txn_begin" (fun () -> txn_begin x y z)
+ let checkpoint x ~kbyte ~min y =
+ wrap "Txn.checkpoint" (fun () -> checkpoint x ~kbyte ~min y)
+ let commit x y = wrap "Txn.commit" (fun () -> commit x y)
+end
+
+
Added: sks/branches/upstream/sks/current/bitstring.ml
===================================================================
--- sks/branches/upstream/sks/current/bitstring.ml (rev 0)
+++ sks/branches/upstream/sks/current/bitstring.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,303 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+
+module Unix=UnixLabels
+
+exception Error of string
+exception LengthError of string
+
+let width = 8
+
+type t = { a: string;
+ bitlength: int;
+ }
+
+let bytelength bits =
+ bits / width + (if bits mod width = 0 then 0 else 1)
+
+let create bits =
+ let bytes = bytelength bits
+ in
+ { a = String.create bytes;
+ bitlength = bits;
+ }
+
+let get ba bit =
+ let byte_pos = bit / width
+ and bit_pos = bit mod width in
+ let intval = int_of_char (String.get ba.a byte_pos) in
+ (intval lsr (width - bit_pos - 1)) land 1
+
+let lget ba bit = get ba bit = 1
+
+let flip ba bit =
+ let byte_pos = bit / width
+ and bit_pos = bit mod width in
+ let intval = int_of_char (String.get ba.a byte_pos) in
+ let new_char = char_of_int ((1 lsl (width - bit_pos - 1)) lxor intval)
+ in
+ String.set ba.a byte_pos new_char
+
+let set ba bit =
+ let byte_pos = bit / width
+ and bit_pos = bit mod width in
+ let intval = int_of_char (String.get ba.a byte_pos) in
+ let new_char = char_of_int ((1 lsl (width - bit_pos - 1)) lor intval)
+ in
+ String.set ba.a byte_pos new_char
+
+let unset ba bit =
+ let byte_pos = bit / width
+ and bit_pos = bit mod width in
+ let intval = int_of_char (String.get ba.a byte_pos) in
+ let new_char = char_of_int ((lnot (1 lsl (width - bit_pos - 1)))
+ land intval)
+ in
+ String.set ba.a byte_pos new_char
+
+let setval ba bit bool =
+ if bool then set ba bit else unset ba bit
+
+(************************************************************)
+(* Printing and Conversions *********************************)
+(************************************************************)
+
+let print ba =
+ for i = 0 to ba.bitlength - 1 do
+ if get ba i = 0
+ then print_string "0"
+ else print_string "1"
+ done
+
+let hexprint ba =
+ print_string (Utils.hexstring ba.a)
+
+let to_bool_array ba =
+ Array.init ~f:(fun i -> lget ba i) ba.bitlength
+
+let to_string ba =
+ let string = String.create ba.bitlength in
+ for i = 0 to ba.bitlength -1 do
+ if get ba i = 0 then string.[i] <- '0' else string.[i] <- '1'
+ done;
+ string
+
+let to_bytes ba =
+ let lastbit = (bytelength ba.bitlength)*width - 1 in
+ for i = ba.bitlength to lastbit do
+ unset ba i
+ done;
+ String.sub ~pos:0 ~len:(bytelength ba.bitlength) ba.a
+
+let of_bytes string bitlength =
+ { bitlength = bitlength;
+ a = String.copy string;
+ }
+
+let of_byte b =
+ { bitlength = width;
+ a = String.make 1 (char_of_int (b land 0xFF));
+ }
+
+let of_bytes_all string =
+ { bitlength = (String.length string) * width;
+ a = String.copy string;
+ }
+
+let of_int i =
+ { bitlength = width * 4;
+ a = Utils.bstring_of_int i;
+ }
+
+let of_bytes_nocopy string bitlength =
+ { bitlength = bitlength;
+ a = string;
+ }
+
+let of_bytes_all_nocopy string =
+ { bitlength = (String.length string) * width;
+ a = string;
+ }
+
+let to_bytes_nocopy ba =
+ let lastbit = (bytelength ba.bitlength)*8 - 1 in
+ for i = ba.bitlength to lastbit do
+ unset ba i
+ done;
+ ba.a
+
+(************************************************************)
+(************************************************************)
+(************************************************************)
+
+let copy ba = { ba with a = String.copy ba.a }
+
+(** returns a copy of bitstring copied into a new bitstring of a new length.
+ No guarantees are made as to the contents of the remainder of the bitstring
+ if the bitstring length is extended.
+ *)
+let copy_len ba bitlength =
+ let bytes = bytelength bitlength in
+ let str = String.create bytes in
+ String.blit ~src:ba.a ~src_pos:0
+ ~dst:str ~dst_pos:0 ~len:(String.length ba.a);
+ { a = str; bitlength = bitlength }
+
+(********************************************************************)
+(*** Shifting *****************************************************)
+(********************************************************************)
+
+let shift_pair_left c1 c2 bits=
+ let i1 = int_of_char c1
+ and i2 = int_of_char c2 in
+ let shifted_int =
+ (i1 lsl bits) lor (i2 lsr (width - bits))
+ in
+ char_of_int (shifted_int land 0xFF)
+
+let shift_pair_right c1 c2 bits =
+ let i1 = int_of_char c1
+ and i2 = int_of_char c2 in
+ let shifted_int =
+ (i1 lsl (width - bits)) lor (i2 lsr bits)
+ in
+ char_of_int (shifted_int land 0xFF)
+
+(**********************************)
+
+let shift_left_small ba bits =
+ if bits > 0 then
+ let bytes = bytelength ba.bitlength in
+ for i = 0 to bytes-2 do
+ ba.a.[i] <- shift_pair_left ba.a.[i] ba.a.[i+1] bits
+ done;
+ ba.a.[bytes-1] <- shift_pair_left ba.a.[bytes-1] '\000' bits
+
+let shift_right_small ba bits =
+ if bits > 0 then
+ let bytes = bytelength ba.bitlength in
+ for i = bytes-1 downto 1 do
+ ba.a.[i] <- shift_pair_right ba.a.[i-1] ba.a.[i] bits
+ done;
+ ba.a.[0] <- shift_pair_right '\000' ba.a.[0] bits
+
+(**********************************)
+
+let rec shift_left ba bits =
+ if bits < 0 then
+ shift_right ba (-bits)
+ else
+ let bytelength = bytelength ba.bitlength
+ and bytes = bits / width
+ and bits = bits mod width in
+ if bytes > 0
+ then
+ begin
+ for i = 0 to bytelength - 1 - bytes do
+ ba.a.[i] <- ba.a.[i+bytes];
+ done;
+ for i = bytelength - bytes to bytelength - 1 do
+ ba.a.[i] <- '\000'
+ done
+ end;
+ shift_left_small ba bits
+
+and shift_right ba bits =
+ if bits < 0 then
+ shift_left ba (-bits)
+ else
+ let bytelength = bytelength ba.bitlength
+ and bytes = bits / width
+ and bits = bits mod width in
+ if bytes > 0
+ then
+ begin
+ for i = bytelength - 1 downto bytes do
+ ba.a.[i] <- ba.a.[i-bytes];
+ done;
+ for i = bytes - 1 downto 0 do
+ ba.a.[i] <- '\000'
+ done
+ end;
+ shift_right_small ba bits
+
+let num_bits ba = ba.bitlength
+let num_bytes ba = bytelength ba.bitlength
+
+(********************************************************************)
+(********************************************************************)
+(********************************************************************)
+
+let rmasks =
+ Array.init width ~f:(fun i -> 0xFF lsl (width - i))
+
+(* Later, extend to have optional initial-position arguments *)
+let blit ~src ~dst ~len =
+ (* these tests are probably redundant, since they'll cause
+ exceptions deeper in. OCaml's lousy traceback features, however, make
+ it somewhat useful to have these here. *)
+ if len < 0
+ then raise (Invalid_argument "Bitstring.blit: negative len");
+ if dst.bitlength < len
+ then raise (Invalid_argument "Bitstring.blit: dst too short");
+ if src.bitlength < len
+ then raise (Invalid_argument "Bitstring.blit: src too short");
+ let bytelen = len / width
+ and bitlen = len mod width in
+ String.blit
+ ~src:src.a ~src_pos:0
+ ~dst:dst.a ~dst_pos:0 ~len:bytelen;
+ if bitlen > 0 then
+ let srcval = int_of_char (String.get src.a bytelen)
+ and dstval = int_of_char (String.get dst.a bytelen) in
+ let newdst = (rmasks.(bitlen) land srcval) lor
+ ((lnot rmasks.(bitlen)) land dstval)
+ in
+ dst.a.[bytelen] <- char_of_int newdst
+
+
+(* let full_blit ~src ~src_pos ~dst ~dst_pos ~len = *)
+
+
+let zero_out bs =
+ String.fill bs.a ~pos:0 ~len:(String.length bs.a) '\000'
+
+(*
+let extract bs ~pos ~len =
+ let first_bit = pos % 8
+ let first_byte = pos / 8 in
+ let last_byte = (pos + len) / 8 +
+ (if (pos + len) % 8 > 0 then 1 else 0) in
+ let byte_len = last_byte - first_byte + 1 in
+ let newbs = Bitstring.create len in
+ String.blit
+ ~src:bs.a ~src_pos:src_first_byte
+ ~dst:newbs.a ~dst_pos:0 ~len:byte_len;
+ shift_left newbs first_bit;
+*)
+
+
+(*
+let concat bs1 bs2 =
+ let newbs = create (bs1.bits + bs2.bits) in
+ blit ~src:bs1 ~dst:newbs ~len:(bs1.bits);
+*)
+
+
Added: sks/branches/upstream/sks/current/bugscript.ml
===================================================================
--- sks/branches/upstream/sks/current/bugscript.ml (rev 0)
+++ sks/branches/upstream/sks/current/bugscript.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,267 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open Common
+open StdLabels
+open MoreLabels
+open Printf
+(*open Pstyle *)
+module Set = PSet.Set
+open ReconPTreeDb
+
+(*
+ #directory "/home/yminsky/Work/projects/keyserver/sks"
+ #load "reconPTreeDb.cmo"
+*)
+
+let rec read_lines f accum =
+ let line =
+ try Some (input_line f)
+ with End_of_file -> None
+ in
+ match line with
+ Some line -> read_lines f (line::accum)
+ | None -> List.rev accum
+
+let read_lines f = read_lines f []
+
+let entry_hash entry = match entry with
+ | Add hash -> hash
+ | Delete hash -> hash
+
+let ch_piece ch pos line =
+ if pos >= String.length line then raise Not_found;
+ try
+ let newpos = String.index_from line pos ch in
+ (newpos+1,
+ String.sub line ~pos ~len:(newpos - pos))
+ with
+ Not_found -> (String.length line,
+ String.sub line ~pos ~len:(String.length line - pos))
+
+let rec ch_pieces ch pos line =
+ let (newpos,piece) = ch_piece ch pos line in
+ try piece::(ch_pieces ch newpos line)
+ with Not_found -> piece::[]
+
+let ws = Str.regexp " "
+
+let line_to_entry line =
+ let pieces = Array.of_list (ch_pieces ' ' 0 line) in
+ let hash = KeyHash.dehexify pieces.(3) in
+ match pieces.(2) with
+ | "Add" -> Add hash
+ | "Del" -> Delete hash
+ | _ -> failwith "unparseable line"
+
+
+(** compute the symmetric difference between two arrays
+ sorted in increasing order
+*)
+let array_diff a1 a2 =
+ let c1 = ref 0 and c2 = ref 0 in
+ let diff1 = ref [] and diff2 = ref [] in
+
+ let add1 () =
+ diff1 := a1.(!c1)::!diff1;
+ incr c1
+ and add2 () =
+ diff2 := a2.(!c2)::!diff2;
+ incr c2
+ in
+
+ while !c1 < Array.length a1 || !c2 < Array.length a2 do
+ if !c1 >= Array.length a1 then add2 ()
+ else if !c2 >= Array.length a2 then add1 ()
+ else if a1.(!c1) = a2.(!c2) then ( incr c1; incr c2; )
+ else if a1.(!c1) < a2.(!c2) then add1 ()
+ else add2 ()
+ done;
+ (List.rev !diff1,List.rev !diff2)
+
+
+let rec read_entries f accum =
+ let line =
+ try Some (input_line f)
+ with End_of_file -> None
+ in
+ match line with
+ Some line -> read_entries f (line_to_entry line::accum)
+ | None -> Array.of_list (List.rev accum)
+
+let read_entries fname =
+ let f = open_in fname in
+ let run () =
+ ignore (input_line f);
+ read_entries f []
+ in
+ protect ~f:run ~finally:(fun () -> close_in f)
+
+let get_entries fname =
+ let f = open_in fname in
+ let run () =
+ let lines = read_lines f in
+ let lines = Array.of_list lines in
+ Array.map ~f:line_to_entry lines
+ in
+ protect ~f:run ~finally:(fun () -> close_in f)
+
+let zz_of_hstr hstr =
+ let hash = KeyHash.dehexify hstr in
+ ZZp.of_bytes hash
+
+let ptree_mem hstr =
+ let zz = zz_of_hstr hstr in
+ let rec loop depth =
+ match (PTree.get_node ~sef:true !ptree zz depth).PTree.children with
+ | PTree.Children _ -> loop (depth+1)
+ | PTree.Leaf elements -> Set.mem (ZZp.to_bytes zz) elements
+ in
+ loop 0
+
+let rec get_groups entries pos group accum =
+ if pos >= Array.length entries then
+ if group = [] then accum
+ else group::accum
+ else (
+ match group with
+ | [] -> get_groups entries (pos+1) [entries.(pos)] accum
+ | group_hd::_ ->
+ if entry_hash entries.(pos) = entry_hash group_hd
+ then get_groups entries (pos+1) (entries.(pos)::group) accum
+ else get_groups entries (pos+1) [entries.(pos)] (group::accum)
+ )
+
+let get_groups entries = get_groups entries 0 [] []
+
+let rec last list = match list with
+ [hd] -> hd
+ | hd::tl -> last tl
+ | [] -> raise Not_found
+
+let simplify_groups groups =
+ Array.of_list (List.rev_map ~f:last groups)
+
+let bad_entry entry = match entry with
+ | Add hash -> if ptree_mem hash then false else true
+ | Delete hash -> if ptree_mem hash then true else false
+
+let trunc s = String.sub ~pos:0 ~len:16 s
+
+let get_ptree_hashes () =
+ PTree.summarize_tree
+ ~lagg:(fun set -> Array.map ~f:trunc
+ (Array.of_list (Set.elements set)))
+ ~cagg:(fun alist -> Array.concat (Array.to_list alist))
+ !ptree
+
+let lpush el lref = lref := el::!lref
+
+let get_entry_droplist entries =
+ let droplist = ref [] in
+ for i = 0 to Array.length entries - 2 do
+ if entry_hash entries.(i) = entry_hash entries.(i+1) then
+ lpush i droplist
+ done;
+ List.rev !droplist
+
+let dedup_entries entries =
+ let droplist = get_entry_droplist entries in
+ let drops = Set.of_list droplist in
+ let new_entries = Array.make (Array.length entries - List.length droplist)
+ entries.(0)
+ in
+ let pos = ref 0 in
+ for i = 0 to Array.length entries - 1 do
+ if not (Set.mem i drops) then (
+ new_entries.(!pos) <- entries.(i);
+ incr pos
+ )
+ done;
+ new_entries
+
+let get_simplified_entries fname =
+ perror "reading entries from log";
+ let entries = read_entries fname in
+ perror "sorting log entries";
+ Array.stable_sort entries
+ ~cmp:(fun x y -> compare (entry_hash x) (entry_hash y));
+ perror "deduping log entries";
+ dedup_entries entries
+
+let count_adds entries =
+ Array.fold_left ~init:0 entries
+ ~f:(fun count entry -> match entry with
+ Add hash -> count + 1
+ | _ -> count)
+
+let get_hashes simplified_entries =
+ perror "extracting adds";
+ let adds = count_adds simplified_entries in
+ let hashes = Array.create adds "" in
+ let pos = ref 0 in
+ Array.iter simplified_entries
+ ~f:(function Add hash ->
+ hashes.(!pos) <- hash; incr pos
+ | Delete hash -> ());
+ hashes
+
+
+let get_diffs () =
+ let hashes = get_hashes (get_simplified_entries "log.real") in
+ perror "Getting hashes from prefix tree...";
+ let phashes = get_ptree_hashes () in
+
+ perror "computing difference...";
+ let (diff1,diff2) = array_diff hashes phashes in
+
+ (Set.of_list diff1,Set.of_list diff2)
+
+let rec line_iter ~f file =
+ let line =
+ try Some (input_line file)
+ with End_of_file -> None
+ in
+ match line with
+ | Some line -> f line; line_iter ~f file
+ | None -> ()
+
+let rewrite_log diff1 diff2 =
+ let infile = open_in "log.real" in
+ let outfile = open_out "log.real.annot" in
+ output_string outfile (input_line infile);
+ output_string outfile "\n";
+ line_iter infile
+ ~f:(fun line ->
+ output_string outfile line;
+ let entry = line_to_entry line in
+ if Set.mem (entry_hash entry) diff1 then
+ output_string outfile " <--- INLOG"
+ else if Set.mem (entry_hash entry) diff2 then
+ output_string outfile " <--- INPTR";
+ output_string outfile "\n"
+ );
+ close_in infile;
+ close_out outfile
+
+let runtest () =
+ let (diff1,diff2) = get_diffs () in
+ perror "Rewriting log";
+ rewrite_log diff1 diff2
+
+let () = runtest ()
+
Added: sks/branches/upstream/sks/current/build.ml
===================================================================
--- sks/branches/upstream/sks/current/build.ml (rev 0)
+++ sks/branches/upstream/sks/current/build.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,118 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Executable: Builds up the key database from a multi-file database dump.
+ dump files are taken from the command-line
+*)
+module F(M:sig end) =
+struct
+ open StdLabels
+ open MoreLabels
+ open Printf
+ open Arg
+ open Common
+ module Set = PSet.Set
+ open Packet
+ let settings = {
+ Keydb.withtxn = false;
+ Keydb.cache_bytes = !Settings.cache_bytes;
+ Keydb.pagesize = !Settings.pagesize;
+ Keydb.dbdir = Lazy.force Settings.dbdir;
+ Keydb.dumpdir = Lazy.force Settings.dumpdir;
+ }
+
+ module Keydb = Keydb.Safe
+
+ let n = match !Settings.n with 0 -> 1 | x -> x
+ let fnames = !Settings.anonlist
+
+ let rec get_keys_rec nextkey partial = match nextkey () with
+ Some key ->
+ (try
+ let ckey = Fixkey.canonicalize key in
+ get_keys_rec nextkey (ckey::partial)
+ with
+ Fixkey.Bad_key -> get_keys_rec nextkey partial
+ )
+ | None -> partial
+
+ let get_keys nextkey = get_keys_rec nextkey []
+
+ let timestr sec =
+ sprintf "%.2f min" (sec /. 60.)
+
+ let rec nsplit n list = match n with
+ 0 -> ([],list)
+ | n -> match list with
+ [] -> ([],[])
+ | hd::tl ->
+ let (beginning,ending) = nsplit (n-1) tl in
+ (hd::beginning,ending)
+
+ let rec batch_iter ~f n list =
+ match nsplit n list with
+ ([],_) -> ()
+ | (firstn,rest) -> f firstn; batch_iter ~f n rest
+
+ let get_keys_fname fname start =
+ let cin = new Channel.sys_in_channel (open_in fname) in
+ protect
+ ~f:(fun () ->
+ let nextkey = Key.next_of_channel cin in
+ get_keys_rec nextkey start
+ )
+ ~finally:(fun () -> cin#close)
+
+ let get_keys_multi flist =
+ List.fold_left ~f:(fun keys fname -> get_keys_fname fname keys)
+ flist ~init:[]
+
+ let dbtimer = MTimer.create ()
+ let timer = MTimer.create ()
+ let run () =
+ set_logfile "build";
+
+ if Sys.file_exists (Lazy.force Settings.dbdir) then (
+ printf "KeyDB directory already exists. Exiting.\n";
+ exit (-1)
+ );
+ Unix.mkdir (Lazy.force Settings.dbdir) 0o700;
+
+ Keydb.open_dbs settings;
+ Keydb.set_meta ~key:"filters" ~data:"yminsky.dedup";
+
+ protect
+ ~f:(fun () ->
+ batch_iter n fnames
+ ~f:(fun fnames ->
+ MTimer.start timer;
+ printf "Loading keys..."; flush stdout;
+ let keys = get_keys_multi fnames in
+ printf "done\n"; flush stdout;
+ MTimer.start dbtimer;
+ Keydb.add_keys keys;
+ MTimer.stop dbtimer;
+ MTimer.stop timer;
+ printf "DB time: %s. Total time: %s.\n"
+ (timestr (MTimer.read dbtimer))
+ (timestr (MTimer.read timer));
+ flush stdout;
+ )
+ )
+ ~finally:(fun () -> Keydb.close_dbs ())
+
+end
Added: sks/branches/upstream/sks/current/cMarshal.ml
===================================================================
--- sks/branches/upstream/sks/current/cMarshal.ml (rev 0)
+++ sks/branches/upstream/sks/current/cMarshal.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,133 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Marshaling into and out of channels (see [Channel] module) *)
+
+open StdLabels
+open MoreLabels
+module ZSet = ZZp.Set
+
+let marshal_string cout string =
+ ignore (cout:>Channel.out_channel_obj);
+ cout#write_int (String.length string);
+ cout#write_string string
+
+let unmarshal_string cin =
+ let length = cin#read_int in
+ cin#read_string length
+
+(*****)
+
+let marshal_lstring cout string =
+ cout#write_string string
+
+let unmarshal_lstring length cin =
+ cin#read_string length
+
+
+(*****)
+
+let rec marshal_array ~f cout array =
+ cout#write_int (Array.length array);
+ Array.iter ~f:(f cout) array
+
+let rec unmarshal_array ~f cin =
+ let len = cin#read_int in
+ Array.init len ~f:(fun i -> f cin)
+
+(*****)
+
+let rec marshal_list ~f cout list =
+ cout#write_int (List.length list);
+ List.iter ~f:(f cout) list
+
+let rec unmarshal_list ~f cin =
+ Array.to_list (unmarshal_array ~f cin)
+
+(*****)
+
+let marshal_fixed_sarray cout sarray =
+ let len = try String.length sarray.(0) with _ -> 0 in
+ Array.iter ~f:(fun s ->
+ if String.length s <> len
+ then failwith ("Strings not same length in " ^
+ "marshal_fixed_sarray")) sarray;
+ cout#write_int len;
+ marshal_array ~f:marshal_lstring cout sarray
+
+let unmarshal_fixed_sarray cin sarray =
+ let len = cin#read_int in
+ unmarshal_array ~f:(unmarshal_lstring len) cin
+
+(*****)
+
+
+let marshal_bitstring cout bs =
+ cout#write_int (Bitstring.num_bits bs);
+ marshal_string cout (Bitstring.to_bytes_nocopy bs)
+
+let unmarshal_bitstring cin =
+ let bitlength = cin#read_int
+ and string = unmarshal_string cin in
+ Bitstring.of_bytes_nocopy string bitlength
+
+(*****)
+
+let marshal_set ~f cout set =
+ let array = Array.of_list (ZSet.elements set) in
+ marshal_array ~f cout array
+
+
+let unmarshal_set ~f cin =
+ let array = unmarshal_array ~f cin in
+ ZZp.zset_of_list (Array.to_list array)
+
+(*************************************************************)
+
+let marshal_sockaddr cout sockaddr =
+ match sockaddr with
+ | Unix.ADDR_UNIX s ->
+ cout#write_byte 0; marshal_string cout s
+ | Unix.ADDR_INET (s,i) ->
+ cout#write_byte 1;
+ marshal_string cout (Unix.string_of_inet_addr s);
+ cout#write_int i
+
+let unmarshal_sockaddr cin =
+ match cin#read_byte with
+ 0 -> Unix.ADDR_UNIX (unmarshal_string cin)
+ | 1 ->
+ let s = unmarshal_string cin in
+ let i = cin#read_int in
+ Unix.ADDR_INET (Unix.inet_addr_of_string s,i)
+ | _ -> failwith "Unmarshalling failed: malformed sockaddr"
+
+(************************************************************)
+
+let marshal_to_string ~f x =
+ let cout = Channel.new_buffer_outc 0 in
+ f cout x;
+ cout#contents
+
+let unmarshal_from_string ~f s =
+ let cin = new Channel.string_in_channel s 0 in
+ f cin
+
+
+let int_to_string x = marshal_to_string ~f:(fun cout x -> cout#write_int x) x
+let int_of_string s = unmarshal_from_string ~f:(fun cin -> cin#read_int) s
+
Added: sks/branches/upstream/sks/current/catchup.ml
===================================================================
--- sks/branches/upstream/sks/current/catchup.ml (rev 0)
+++ sks/branches/upstream/sks/current/catchup.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,133 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** code used by the reconserver to catch up on whatever updates have
+ been made to the key database *)
+
+open StdLabels
+open MoreLabels
+open Printf
+open Common
+open DbMessages
+open PTreeDB
+
+(***************************************************************)
+(* Catchup Code *********************************************)
+(***************************************************************)
+
+let rec last_ts log = match log with
+ [] -> raise Not_found
+ | (ts,event)::[] -> ts
+ | hd::tl -> last_ts tl
+
+let event_to_hash event = match event with
+ | Add hash -> hash
+ | Delete hash -> hash
+
+(** sort log in hash order, respecting ordering of adds/deletes
+ within a single hash
+*)
+let sortlog log =
+ List.stable_sort log
+ ~cmp:(fun (_,ev1) (_,ev2) ->
+ compare (event_to_hash ev1) (event_to_hash ev2)
+ )
+
+let rec applylog txn log = match log with
+ [] -> ()
+ | (ts,Add hash)::tl ->
+ PTree.insert_str (get_ptree ()) txn hash;
+ applylog txn tl
+ | (ts,Delete hash)::tl ->
+ PTree.delete_str (get_ptree ()) txn hash;
+ applylog txn tl
+
+
+let combine ~f list = match list with
+ [] -> failwith "combine needs at least one element"
+ | first::rest -> List.fold_left ~init:first ~f rest
+
+let max_timestamp log = combine ~f:max (List.map ~f:fst log)
+
+let applylog txn log =
+ applylog txn (sortlog log);
+ let ts = max_timestamp log in
+ plerror 5 "setting synctime to %f" ts;
+ PTree.set_synctime (get_ptree ()) ts
+
+(** does a single catchup-run, returning true if no results were retrieved
+ by the catchup *)
+let single_catchup count =
+ let resp = ReconComm.send_dbmsg
+ (LogQuery (count,PTree.get_synctime (get_ptree ()))) in
+ let log =
+ match resp with
+ | LogResp log -> log
+ | _ -> failwith "Unexpected response"
+ in
+ match log with
+ | [] -> true
+ | _ ->
+ let length = List.length log in
+ let newts = last_ts log in
+ let old_timeout = Unix.alarm 0 in
+ Eventloop.waiting_for_alarm := false;
+ let txn = new_txnopt () in
+ begin
+ try
+ applylog txn log;
+ plerror (if length = 0 then 5 else 3)
+ "Added %d hash-updates. Caught up to %f"
+ length newts;
+ PTree.clean txn (get_ptree ());
+ commit_txnopt txn
+ with
+ | Sys.Break ->
+ abort_txnopt txn;
+ raise Sys.Break
+ | e ->
+ eplerror 1 e
+ "Raising Sys.Break -- PTree may be corrupted";
+ abort_txnopt txn;
+ raise Sys.Break
+ end;
+ Eventloop.waiting_for_alarm := true;
+ ignore (Unix.alarm old_timeout);
+ false
+
+
+let count = 5000
+
+let rec uninterruptable_catchup () =
+ if single_catchup count
+ then ()
+ else uninterruptable_catchup ()
+
+let rec catchup () =
+ if single_catchup count
+ then []
+ else
+ let now = Unix.gettimeofday () in
+ [ Eventloop.Event
+ (now,
+ Eventloop.make_tc ~name:"further catchup"
+ ~timeout:max_int ~cb:catchup
+ )
+ ]
+
+let catchup_interval = 5.
+
Added: sks/branches/upstream/sks/current/channel.ml
===================================================================
--- sks/branches/upstream/sks/current/channel.ml (rev 0)
+++ sks/branches/upstream/sks/current/channel.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,440 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+open Common
+module Unix=UnixLabels
+
+(******************************************************************)
+
+let rec lmax list = match list with
+ [] -> raise Not_found
+ | x::[] -> x
+ | x::y::tl -> lmax ((max x y)::tl)
+
+let char_width = 8
+let int_size = 4
+let int32_size = 4
+let int64_size = 8
+
+let byte64 = Int64.of_int 0xFF
+let byte32 = Int32.of_int 0xFF
+
+(** creates function for reading strings that is safe for use with
+ non-blocking channels *)
+let create_nb_really_input inchan =
+ let stringopt = ref None
+ and pos = ref 0
+ in
+ let input len =
+ let string =
+ match !stringopt with
+ None ->
+ let string = String.create len in
+ stringopt := Some string;
+ pos := 0;
+ string
+ | Some string -> string
+ in
+ if String.length string <> len then
+ failwith ("create_nb_really_input: attempt to redo incomplete " ^
+ "read with different size");
+
+ (* try to read all remaining bytes *)
+ begin
+ try
+ while !pos < len do
+ let r = input inchan string !pos (len - !pos) in
+ if r = 0 then (raise End_of_file)
+ else pos := !pos + r
+ done
+ with
+ | Unix.Unix_error (Unix.EAGAIN,_,_)
+ | Unix.Unix_error (Unix.EWOULDBLOCK,_,_)
+ | Sys_blocked_io ->
+ raise Sys_blocked_io
+ end;
+
+ (* if we get here, then read was complete *)
+ stringopt := None;
+ string
+ in
+ input
+
+
+(* let intbuf = String.create (lmax [int_size;int32_size;int64_size]) *)
+
+let read_binary_int64_internal cin ~size =
+ let intbuf = cin#read_string size in
+ let value = ref Int64.zero in
+ for i = 0 to size - 1 do
+ value := Int64.add (Int64.shift_left !value char_width)
+ (Int64.of_int (int_of_char intbuf.[i]))
+ done;
+ !value
+
+let read_binary_int32_internal cin ~size =
+ let intbuf = cin#read_string size in
+ let value = ref Int32.zero in
+ for i = 0 to size - 1 do
+ value := Int32.add (Int32.shift_left !value char_width)
+ (Int32.of_int (int_of_char intbuf.[i]))
+ done;
+ !value
+
+let read_binary_int_internal cin ~size =
+ let intbuf = cin#read_string size in
+ let value = ref 0 in
+ for i = 0 to size - 1 do
+ value := (!value lsl char_width) + (int_of_char intbuf.[i])
+ done;
+ !value
+
+(***********************************************************************)
+
+let rec read_all_rec cin sbuf buf =
+ let status = input cin sbuf 0 (String.length sbuf) in
+ if status = 0 then ()
+ else (
+ Buffer.add_substring buf sbuf 0 status;
+ read_all_rec cin sbuf buf
+ )
+
+let read_all cin ?len ()=
+ let len = match len with
+ None -> 1024 * 100
+ | Some x -> x
+ in
+ let sbuf = String.create len
+ and buf = Buffer.create len in
+ read_all_rec cin sbuf buf;
+ Buffer.contents buf
+
+(*********************************************************************)
+
+class virtual out_channel_obj =
+object (self)
+ method upcast = (self :> out_channel_obj)
+
+ method write_int x =
+ self#write_byte (0xFF land (x lsr 24));
+ self#write_byte (0xFF land (x lsr 16));
+ self#write_byte (0xFF land (x lsr 8));
+ self#write_byte (0xFF land (x lsr 0))
+ method virtual write_string : string -> unit
+ method virtual write_string_pos : buf:string -> pos:int -> len:int -> unit
+ method virtual write_char : char -> unit
+ method virtual write_byte : int -> unit
+ method write_int32 x =
+ for i = int32_size - 1 downto 0 do
+ let shifted = (Int32.shift_right_logical x (i * 8) ) in
+ self#write_byte (Int32.to_int (Int32.logand byte32 shifted))
+ done
+ method write_int64 x =
+ for i = int64_size - 1 downto 0 do
+ let shifted = (Int64.shift_right_logical x (i * 8) ) in
+ self#write_byte (Int64.to_int (Int64.logand byte64 shifted))
+ done
+ method write_float x =
+ let bits = Int64.bits_of_float x in
+ self#write_int64 bits
+end
+
+class virtual in_channel_obj =
+object (self)
+ method upcast = (self :> in_channel_obj)
+
+ method virtual read_string_pos : buf:string -> pos:int -> len:int -> unit
+ method virtual read_char : char
+ method read_string len =
+ let buf = String.create len in
+ self#read_string_pos ~buf ~pos:0 ~len;
+ buf
+ method read_byte = int_of_char self#read_char
+ method read_int_size size = read_binary_int_internal self ~size
+ method read_int = read_binary_int_internal self ~size:int_size
+ method read_int32 = read_binary_int32_internal self ~size:int32_size
+ method read_int64 = read_binary_int64_internal self ~size:int64_size
+ method read_int64_size size = read_binary_int64_internal self ~size
+ method read_float =
+ let bits = read_binary_int64_internal self ~size:int64_size in
+ Int64.float_of_bits bits
+end
+
+(****************************************************)
+
+
+class sys_out_channel cout =
+object (self)
+ inherit out_channel_obj
+ method flush = flush cout
+ method close = close_out cout
+ method write_string str = output_string cout str
+ method write_string_pos ~buf ~pos ~len= output cout buf pos len
+ method write_char char = output_char cout char
+ method write_byte byte = output_byte cout byte
+ method write_buf buf = Buffer.output_buffer cout buf
+
+ method outchan = cout
+ method fd = Unix.descr_of_out_channel cout
+ method skip n =
+ let skipped = Unix.lseek self#fd n ~mode:Unix.SEEK_CUR in
+ if skipped <> n then raise End_of_file
+
+ initializer
+ set_binary_mode_out cout true
+end
+
+(****************************************************)
+
+class sys_in_channel cin =
+ let input = create_nb_really_input cin in
+object (self)
+ inherit in_channel_obj
+
+ method close = close_in cin
+ method read_all = read_all cin ()
+ method read_string len = input len
+ method read_string_pos ~buf ~pos ~len =
+ let s = input len in
+ String.blit ~src:s ~dst:buf ~src_pos:0 ~dst_pos:pos ~len
+
+ method read_char =
+ input_char cin
+
+ method inchan = cin
+ method fd = Unix.descr_of_in_channel cin
+
+ initializer
+ set_binary_mode_in cin true
+end
+
+(****************************************************)
+
+class buffer_out_channel buf =
+object (self)
+ inherit out_channel_obj
+
+ method contents = Buffer.contents buf
+ method buffer_nocopy = buf
+
+ method write_string str = Buffer.add_string buf str
+ method write_string_pos ~buf:string ~pos ~len =
+ Buffer.add_substring buf string pos len
+ method write_char char = Buffer.add_char buf char
+ method write_byte byte = Buffer.add_char buf (char_of_int (0xFF land byte))
+end
+
+
+(****************************************************)
+
+class string_in_channel string pos =
+object (self)
+ inherit in_channel_obj
+
+ val slength = String.length string
+ val mutable pos = pos
+
+ method read_string len =
+ if pos + len > slength then raise End_of_file;
+ let rval = String.sub string ~pos ~len in
+ pos <- pos + len;
+ rval
+
+ method read_rest =
+ if pos >= slength then ""
+ else
+ let rval = String.sub string ~pos ~len:(slength - pos) in
+ pos <- slength;
+ rval
+
+ method read_string_pos ~buf ~pos:dst_pos ~len =
+ if pos + len > slength then raise End_of_file;
+ String.blit ~src:string ~src_pos:pos
+ ~dst:buf ~dst_pos ~len;
+ pos <- pos + len
+
+ method read_char =
+ if pos + 1 > slength then raise End_of_file;
+ let char = string.[pos] in
+ pos <- pos + 1;
+ char
+
+ method read_byte =
+ if pos + 1 > slength then raise End_of_file;
+ let byte = int_of_char string.[pos] in
+ pos <- pos + 1;
+ byte
+
+ method skip bytes =
+ if pos + bytes > slength then raise End_of_file;
+ pos <- pos + bytes
+
+end
+
+
+
+let new_buffer_outc size = new buffer_out_channel (Buffer.create size)
+let sys_out_from_fd fd = new sys_out_channel (Unix.out_channel_of_descr fd)
+let sys_in_from_fd fd = new sys_in_channel (Unix.in_channel_of_descr fd)
+let sys_out_of_fd fd = sys_out_from_fd
+let sys_in_of_fd fd = sys_in_from_fd
+
+(****************************************************)
+(* In Development: nonblocking operations *******)
+(****************************************************)
+(*
+
+let mem_limit = 1024 * 1024 * 2 (* msgs can't be more than 2 megs *)
+let sanity_check_length len =
+ if len < 0 then failwith "Channel.sanity_check_length: negative length";
+ if len > mem_limit then failwith
+ (Printf.sprintf
+ "Channel.sanity_check_length: length exceeds limit of %d bytes"
+ mem_limit)
+
+(****************************************************)
+
+
+
+type posbuf = { mutable pos: int;
+ data: string;
+ }
+
+let nb_write fd b =
+ let len = String.length b.data in
+ assert (b.pos < len);
+ let bytes_written =
+ Unix.write fd ~buf:b.data ~pos:b.pos ~len:(len - b.pos)
+ in
+ b.pos <- b.pos + bytes_written;
+ if b.pos >= len then
+ begin
+ assert (b.pos = len);
+ true
+ end
+ else
+ false
+
+
+let nb_read fd b =
+ let len = String.length b.data in
+ assert (b.pos < len);
+ let bytes_read =
+ Unix.read fd ~buf:b.data ~pos:b.pos ~len:(len - b.pos)
+ in
+ b.pos <- b.pos + bytes_read;
+ if b.pos >= len then
+ begin
+ assert (b.pos = len);
+ true
+ end
+ else
+ false
+
+
+(****************************)
+
+class nonblocking_reader fd =
+object (self)
+
+ val lenbuf = { pos = 0; data = String.create int_size; }
+ val mutable databuf = { pos = 0; data = ""; }
+ val mutable data_ready = false
+
+ method private reset =
+ lenbuf.pos <- 0;
+ data_ready <- false;
+ databuf <- { pos = 0; data = ""; }
+
+ method private read_header =
+ if nb_read fd lenbuf
+ then
+ let len = Utils.int_from_bstring lenbuf.data
+ ~pos:0 ~len:(String.length lenbuf.data)
+ in
+ databuf <- { pos = 0; data = String.create len; };
+ data_ready <- true;
+ self#read_data
+ else
+ None
+
+ method private read_data =
+ if nb_read fd databuf
+ then
+ let rval = Some (new string_in_channel databuf.data 0) in
+ self#reset;
+ rval
+ else None
+
+ method read = match data_ready with
+ | true -> self#read_header
+ | false -> self#read_data
+
+ initializer
+ Unix.set_nonblock fd
+end
+
+(**************************************************************)
+
+let write_int_to_string str i =
+ str.[3] <- char_of_int (0xFF land (i lsl 24));
+ str.[2] <- char_of_int (0xFF land (i lsl 16));
+ str.[1] <- char_of_int (0xFF land (i lsl 8));
+ str.[0] <- char_of_int (0xFF land i)
+
+(****************************)
+
+type writestate = | Header | Data | Not_ready
+
+class nonblocking_writer fd =
+object (self)
+
+ val lenbuf = { pos = 0; data = String.create int_size; }
+ val mutable databuf = { pos = 0; data = ""; }
+ val mutable state = Not_ready
+
+ method set_data data =
+ state <- Header;
+ databuf <- { pos = 0; data = data; };
+ lenbuf.pos <- 0;
+ write_int_to_string lenbuf.data (String.length data)
+
+ method private reset =
+ state <- Not_ready;
+ databuf <- { pos = 0; data = ""; }
+
+ method private write_header =
+ if nb_write fd lenbuf
+ then (state <- Data; self#write_data)
+ else false
+
+ method private write_data =
+ if nb_write fd databuf
+ then (self#reset; true)
+ else false
+
+ method write = match state with
+ | Header -> self#write_header
+ | Data -> self#write_data
+ | Not_ready -> failwith "Write called when writer in Not_ready state"
+
+ initializer
+ Unix.set_nonblock fd
+end
+*)
Added: sks/branches/upstream/sks/current/channel.mli
===================================================================
--- sks/branches/upstream/sks/current/channel.mli (rev 0)
+++ sks/branches/upstream/sks/current/channel.mli 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,146 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** A generic, object-based channel interface for binary input/output *)
+
+class virtual out_channel_obj :
+ object
+ method upcast : out_channel_obj
+ method virtual write_byte : int -> unit
+ method virtual write_char : char -> unit
+ method write_float : float -> unit
+ method write_int : int -> unit
+ method write_int32 : int32 -> unit
+ method write_int64 : int64 -> unit
+ method virtual write_string : string -> unit
+ method virtual write_string_pos :
+ buf:string -> pos:int -> len:int -> unit
+ end
+
+class virtual in_channel_obj :
+ object
+ method virtual read_byte : int
+ method virtual read_char : char
+ method read_float : float
+ method read_int : int
+ method read_int32 : int32
+ method read_int64 : int64
+ method read_int64_size : int -> int64
+ method read_int_size : int -> int
+ method virtual read_string : int -> string
+ method virtual read_string_pos : buf:string -> pos:int -> len:int -> unit
+ method upcast : in_channel_obj
+ end
+
+(******************************************************************)
+
+class sys_out_channel :
+ out_channel ->
+ object
+ method close : unit
+ method fd : Unix.file_descr
+ method flush : unit
+ method outchan : out_channel
+ method skip : int -> unit
+ method upcast : out_channel_obj
+ method write_buf : Buffer.t -> unit
+ method write_byte : int -> unit
+ method write_char : char -> unit
+ method write_float : float -> unit
+ method write_int : int -> unit
+ method write_int32 : int32 -> unit
+ method write_int64 : int64 -> unit
+ method write_string : string -> unit
+ method write_string_pos : buf:string -> pos:int -> len:int -> unit
+ end
+
+class sys_in_channel :
+ in_channel ->
+ object
+ method close : unit
+ method fd : Unix.file_descr
+ method inchan : in_channel
+ method read_all : string
+ method read_byte : int
+ method read_char : char
+ method read_float : float
+ method read_int : int
+ method read_int32 : int32
+ method read_int64 : int64
+ method read_int64_size : int -> int64
+ method read_int_size : int -> int
+ method read_string : int -> string
+ method read_string_pos : buf:string -> pos:int -> len:int -> unit
+ method upcast : in_channel_obj
+ end
+
+class buffer_out_channel :
+ Buffer.t ->
+ object
+ method buffer_nocopy : Buffer.t
+ method contents : string
+ method upcast : out_channel_obj
+ method write_byte : int -> unit
+ method write_char : char -> unit
+ method write_float : float -> unit
+ method write_int : int -> unit
+ method write_int32 : int32 -> unit
+ method write_int64 : int64 -> unit
+ method write_string : string -> unit
+ method write_string_pos : buf:string -> pos:int -> len:int -> unit
+ end
+
+class string_in_channel :
+ string ->
+ int ->
+ object
+ method read_byte : int
+ method read_char : char
+ method read_float : float
+ method read_int : int
+ method read_int32 : int32
+ method read_int64 : int64
+ method read_int64_size : int -> int64
+ method read_int_size : int -> int
+ method read_string : int -> string
+ method read_string_pos : buf:string -> pos:int -> len:int -> unit
+ method read_rest : string
+ method skip : int -> unit
+ method upcast : in_channel_obj
+ val mutable pos : int
+ end
+
+(*******************************************************************)
+
+val new_buffer_outc : int -> buffer_out_channel
+val sys_out_from_fd : Unix.file_descr -> sys_out_channel
+val sys_in_from_fd : Unix.file_descr -> sys_in_channel
+
+(*
+class nonblocking_reader :
+ Unix.file_descr ->
+ object
+ method read : string_in_channel option
+ end
+
+class nonblocking_writer :
+ Unix.file_descr ->
+ object
+ method set_data : string -> unit
+ method write : bool
+ end
+*)
Added: sks/branches/upstream/sks/current/clean_keydb.ml
===================================================================
--- sks/branches/upstream/sks/current/clean_keydb.ml (rev 0)
+++ sks/branches/upstream/sks/current/clean_keydb.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,364 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Executable: Cleans up various problems that occur in key databases.
+
+ Currently, this includes:
+ - Merging all mergeable keys
+ - Eliminating duplicates
+ (note, this doesn't get rid of ALL duplicates, for instance, if the
+ same signature is used to sign two different keys, it is not removed.
+ Removal is only done if it leaves a reasonable packet structure in
+ place.)
+ - Eliminating keys with unparseable packet sequences
+*)
+
+module F(M:sig end) =
+struct
+ open StdLabels
+ open MoreLabels
+ open Printf
+ open Arg
+ open Common
+ module Set = PSet.Set
+ module Map = PMap.Map
+ module Unix = UnixLabels
+ open Packet
+ open Bdb
+
+ let settings = {
+ Keydb.withtxn = !Settings.transactions;
+ Keydb.cache_bytes = !Settings.cache_bytes;
+ Keydb.pagesize = !Settings.pagesize;
+ Keydb.dbdir = Lazy.force Settings.dbdir;
+ Keydb.dumpdir = Lazy.force Settings.dumpdir;
+ }
+
+ (** we need full keydb access because we're playing directly with
+ databases and cursors and such
+ *)
+ module Keydb = Keydb.Unsafe
+
+
+ let ( |= ) map key = Map.find key map
+ let ( |< ) map (key,data) = Map.add ~key ~data map
+
+ let ctr = ref 0
+ let tick () =
+ incr ctr;
+ if !ctr mod 10000 = 0 then
+ perror "%d thousand steps processed" (!ctr/1000)
+
+
+ type action = Delete of key | Swap of (key * key)
+
+ let do_action action = match action with
+ | Swap (key1,key2) -> Keydb.swap_keys key1 key2
+ | Delete key -> Keydb.delete_key key
+
+ let do_opt f opt = match opt with
+ | None -> ()
+ | Some x -> f x
+
+ (** Canonicalize a key if it is required. This assumes that the given
+ key is actually in the database *)
+ let canonicalize_key key =
+ try
+ let ckey = Fixkey.canonicalize key in
+ if KeyHash.hash ckey <> KeyHash.hash key then
+ begin
+ perror "Swap found: %s -> %s"
+ (KeyHash.hexify (KeyHash.hash key))
+ (KeyHash.hexify (KeyHash.hash ckey));
+ Some (Swap (key,ckey))
+ end
+ else None
+ with
+ Fixkey.Bad_key ->
+ perror "Key to be deleted: %s" (KeyHash.hexify (KeyHash.hash key));
+ Some (Delete key)
+
+
+ let at_once = match !Settings.n with
+ 0 -> 10000
+ | n -> n
+
+ let canonicalize_indirect () =
+ ctr := 0;
+ perror "Starting indirect canonicalization";
+
+ let dbs = Keydb.get_dbs () in
+ let filearray = dbs.Keydb.dump.Keydb.filearray in
+
+ let actions = ref [] in
+ let num_actions = ref 0 in
+
+ let filter_actions actions =
+ let actions = List.map actions
+ ~f:(function
+ | Delete key as action ->
+ (KeyHash.hash key, action)
+ | Swap (key1,key2) as action ->
+ (KeyHash.hash key1, action)
+ )
+ in
+ let actions = List.sort ~cmp:compare actions in
+ let actions = List.filter actions
+ ~f:(fun (hash,action) -> Keydb.has_hash hash)
+ in
+ List.map ~f:(fun (hash,action) -> action) actions
+ in
+
+ let run_stored_actions () =
+ let filt_actions = filter_actions !actions in
+ perror "doing %d out of %d update actions"
+ (List.length filt_actions) (List.length !actions);
+ let dbactions =
+ List.fold_left ~init:[] filt_actions
+ ~f:(fun list action -> match action with
+ Delete key ->
+ (Keydb.key_to_metadata key, Keydb.DeleteKey)::list
+ | Swap (key1,key2) ->
+ (Keydb.key_to_metadata key1, Keydb.DeleteKey)::
+ (Keydb.key_to_metadata key2, Keydb.AddKey)::list
+ )
+ in
+ Keydb.apply_md_updates (Array.of_list dbactions);
+ Keydb.unconditional_checkpoint ();
+ actions := [];
+ num_actions := 0
+ in
+
+ let add_action action =
+ actions := action::!actions;
+ incr num_actions;
+
+ if !num_actions >= at_once then
+ run_stored_actions ()
+
+ in
+
+
+ Array.iteri filearray
+ ~f:(fun i inchan ->
+ perror "Starting keydump %d" i;
+ seek_in inchan 0;
+ let cin = new Channel.sys_in_channel inchan in
+ let get = Key.get_of_channel cin in
+ try
+ while true do
+ tick ();
+ let key = get () in
+ let action = canonicalize_key key in
+ do_opt add_action action
+ done
+ with
+ Not_found -> ()
+ );
+
+ run_stored_actions ();
+ perror "Indirect canonicalization complete"
+
+
+ (** iterate through the entire database, replacing all non-canonical keys
+ with canonicalized versions. Delete all non-canonicalizable keys. Only
+ work on keys stored directly in the database. Keys stored indirectly
+ will be fixed by scanning the initial keydump.
+
+ Note that this is not nearly so highly-optimized as canonicalize_indirect.
+ However, for most keyservers, most of the keys will be in the indirect
+ keydump anyway.
+ *)
+ let canonicalize_direct () =
+ ctr := 0;
+ perror "Starting direct canonicalization";
+ let clean ~hash ~keystr =
+ let skey = Keydb.skey_of_string keystr in
+ if not (Keydb.skey_is_offset skey) then
+ let key = Keydb.key_of_skey skey in
+ tick ();
+ (* ignore offsets, they're handled elsewhere *)
+ do_opt do_action (canonicalize_key key)
+ in
+ Keydb.raw_iter clean;
+ perror "Direct canonicalization complete"
+
+ let canonicalize () =
+ canonicalize_indirect ();
+ canonicalize_direct ()
+
+ (***************************************************************)
+ (***************************************************************)
+ (***************************************************************)
+
+ (** internal function: retrieves list of (key,data) duplicates for a given
+ cursor *)
+ let rec get_dups_rec cursor accum =
+ try
+ let (key,data) = Cursor.get cursor Cursor.NEXT_DUP [] in
+ get_dups_rec cursor ((key,data)::accum)
+ with
+ Not_found -> accum
+
+ (** returns pair of key and duplicate data for the given cursor *)
+ let get_dups cursor =
+ let pairs = get_dups_rec cursor [] in
+ match pairs with
+ [] -> failwith "get_dups retrieved empty list"
+ | (key,data)::tail ->
+ let dtail = List.map tail
+ ~f:(fun (tkey,tdata) -> if tkey <> key
+ then failwith "get_dups retrieved non-duplicate"
+ else tdata
+ )
+ in
+ (key,data::dtail)
+
+ (** checks if a sorted list has duplicates *)
+ let rec has_dups list = match list with
+ [] -> false
+ | [hd] -> false
+ | hd1::hd2::tl ->
+ if hd1 = hd2 then true
+ else has_dups (hd2::tl)
+
+ (** merges keys given the key hashes. The [keyid] argument is there just to
+ make logging more understandable *)
+ let merge_from_hashes keyid hashes =
+ (* Sort hashes and remove duplicates, if any *)
+ let hashes = List.sort ~cmp:compare hashes in
+ let hashes =
+ if has_dups hashes then (
+ perror "Duplicates found in hash list";
+ MList.dedup hashes
+ ) else hashes
+ in
+
+ (** fetches a key from its hash *)
+ let key_from_hash hash =
+ try
+ let key = Keydb.get_by_hash hash in
+ let newhash = KeyHash.hash key in
+ if newhash <> hash then
+ perror "Key hashes do not match up:\n\trequested: %s\n\tfound: %s"
+ (KeyHash.hexify hash) (KeyHash.hexify newhash);
+ Some key
+ with
+ Not_found ->
+ perror "Database corruption: Key matched up to keyid not found in database:\n\tkeyid: %s\n\thash: %s"
+ (Fingerprint.keyid_to_string keyid) (KeyHash.hexify hash);
+ None
+ in
+ let keys = strip_opt (List.map ~f:key_from_hash hashes) in
+ (* compute the list of replacements and apply them *)
+ let replacements = Fixkey.compute_merge_replacements keys in
+ if List.length replacements > 0
+ then perror "%d replacements found" (List.length replacements);
+ List.iter replacements
+ ~f:(fun (delete_list,newkey) ->
+ perror "replacing %d keys with single merged key"
+ (List.length delete_list);
+ List.iter delete_list
+ ~f:(fun key -> perror "removing: %s"
+ (KeyHash.hexify (KeyHash.hash key)));
+ perror "adding: %s"
+ (KeyHash.hexify (KeyHash.hash newkey));
+ Keydb.replace delete_list newkey;
+ perror "Transaction complete"
+ )
+
+
+
+
+
+ (** find all sets of key with the same keyid and merge them if possible *)
+ let merge () =
+ ctr := 0;
+
+ perror "Starting key merge";
+ let dbs = Keydb.get_dbs () in
+ let c = Cursor.create dbs.Keydb.keyid in
+
+ let (first_keyid,first_hash) = Cursor.get c Cursor.FIRST [] in
+
+ let finished = ref false
+ and keyid = ref first_keyid
+ and hash = ref first_hash
+ in
+ while not !finished do
+ tick ();
+ if Cursor.count c > 1 then (
+ let (dup_keyid,hashes) = get_dups c in
+ if dup_keyid <> !keyid then failwith "Failure retrieving duplicates";
+ let hashes = !hash::hashes in
+ perror "%s" ("Multiple keys found with same ID. " ^
+ "merge_from_hashes called");
+ List.iter hashes
+ ~f:(fun hash -> perror "Hash: %s" (KeyHash.hexify hash));
+ merge_from_hashes !keyid hashes
+ );
+ try
+ let (new_keyid,new_hash) = Cursor.get c Cursor.NEXT [] in
+ keyid := new_keyid;
+ hash := new_hash
+ with
+ Not_found -> finished := true
+ done;
+ perror "Completed key merge"
+
+
+ (** Run filters that are not already contained in [applied_filters] *)
+ let run applied_filters =
+
+ (* only do canonicalize if it's necessary *)
+ if not (List.mem "yminsky.dedup" applied_filters) then (
+ perror "Deduping keys in database";
+ canonicalize ();
+ Keydb.set_meta ~key:"filters" ~data:"yminsky.dedup";
+ Keydb.unconditional_checkpoint ();
+ ) else perror "Database already deduped";
+
+
+ (* note: if dedup was done, merge should be done again *)
+ if not (List.mem "yminsky.dedup" applied_filters)
+ || not (List.mem "yminsky.merge" applied_filters)
+ then (
+ perror "Merging keys in database";
+ merge ();
+ Keydb.set_meta ~key:"filters" ~data:"yminsky.dedup,yminsky.merge";
+ Keydb.unconditional_checkpoint ();
+ )
+ else perror "Database already merged"
+
+
+
+ let comma = Str.regexp ","
+
+ let run () =
+ set_logfile "clean";
+ Keydb.open_dbs settings;
+ perror "Keydb opened";
+
+ let applied_filters =
+ try Str.split comma (Keydb.get_meta "filters")
+ with Not_found -> []
+ in
+ run applied_filters;
+
+ Keydb.close_dbs ()
+
+end
Added: sks/branches/upstream/sks/current/client.ml
===================================================================
--- sks/branches/upstream/sks/current/client.ml (rev 0)
+++ sks/branches/upstream/sks/current/client.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,202 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Client side of set-reconciliation algorithm *)
+open StdLabels
+open MoreLabels
+module Unix=UnixLabels
+open Common
+
+open Printf
+open ReconMessages
+
+module Set = PSet.Set
+module Map = PMap.Map
+module PTree = PrefixTree
+(* module ZZp = RMisc.ZZp *)
+
+exception Bug of string
+
+(***************************************************************)
+(* Diagnostic Timers *****************************************)
+(***************************************************************)
+
+let flushcount = ref 0
+
+let timer = MTimer.create ()
+let tstart () =
+ MTimer.start timer
+let tstop accum =
+ MTimer.stop timer;
+ accum := !accum +. MTimer.read_ms timer
+
+let get_flushcount () = !flushcount
+
+(***************************************************************)
+(***************************************************************)
+(***************************************************************)
+
+type 'a bottomQ_entry = FlushEnded | Bottom of 'a
+type reconbound = { num_completed: int;
+ verified_partitions: Bitstring.t Set.t;
+ }
+
+
+(*
+let reconbound_exceeded rb =
+ !Settings.mbar * (Set.cardinal rb.verified_partitions)
+ + rb.num_recovered
+ > Settings.max_recover
+*)
+
+exception Continue
+
+(** Send request and update [bottomQ] appropriately *)
+let send_request cout tree ~bottomQ (node,key) =
+ let request =
+ if PTree.is_leaf node ||
+ PTree.num_elements tree node <
+ !Settings.recon_thresh_mult * !Settings.mbar
+ then ReconRqst_Full
+ { rf_prefix = key;
+ rf_elements = PTree.elements tree node;
+ }
+ else ReconRqst_Poly
+ { rp_prefix = key;
+ rp_size = PTree.size node;
+ rp_samples = PTree.svalues node;
+ }
+ in
+ marshal_noflush cout request;
+ Queue.push (Bottom (node,key)) bottomQ
+
+(** Handle reply message and update [requestQ] appropriately *)
+let handle_reply cout tree ~requestQ reply (node,key) setref =
+ match reply.msg with
+ | SyncFail ->
+ if PTree.is_leaf node then
+ raise (Bug ("Unexpected error. Syncfail received" ^
+ "at leaf node"));
+ let children = PTree.child_keys tree key in
+ let nodes =
+ List.map
+ ~f:(fun key -> try PTree.get_node_key tree key
+ with Not_found ->
+ raise (Bug ("Client.read: PTree.get_node_key " ^
+ "should not fail")))
+ children in
+ (* update requestQ with requests corresponding to
+ children of present node *)
+ List.iter ~f:(fun req -> Queue.push req requestQ)
+ (List.combine nodes children)
+
+ | Elements elements -> setref := (ZSet.union !setref elements)
+
+ (* required for case where reconciliation terminates for due to the end
+ of the prefix tree *)
+ | FullElements elements ->
+ let local = PTree.get_zzp_elements tree node in
+ let localdiff = ZSet.diff local elements in
+ let remotediff = ZSet.diff elements local in
+ marshal_noflush cout (Elements localdiff);
+ setref := ZSet.union !setref remotediff
+
+ | _ -> failwith ( "Unexpected message: " ^
+ msg_to_string reply.msg )
+
+
+(* after a timeout, give an extra 10 seconds to actually extract the data built up so far *)
+let recover_timeout = 10
+
+(** manages reconciliation connection, determining when messages are sent and
+ received on the channel. *)
+let connection_manager cin cout tree initial_request =
+ let set = ref ZSet.empty in
+ let requestQ = Queue.create ()
+ and bottomQ = Queue.create () in
+
+ Queue.push initial_request requestQ;
+
+ (* state variables *)
+ let flushing = ref false (* whether a flush has been sent and not
+ yet bounced back. *)
+ in
+
+ let flush_queue () =
+ marshal_noflush cout Flush;
+ cout#flush;
+ Queue.push FlushEnded bottomQ;
+ flushing := true
+ in
+
+
+ try
+ (* Once both queues are empty, the reconciliation is done *)
+ while not (Queue.is_empty requestQ && Queue.is_empty bottomQ) do
+ match (try Some (Queue.top bottomQ) with Queue.Empty -> None) with
+ | None ->
+ (* following pop is safe, because requestQ can't be empty *)
+ let (node,key) = Queue.pop requestQ in
+ send_request cout tree ~bottomQ (node,key)
+ | Some FlushEnded ->
+ ignore (Queue.pop bottomQ);
+ flushing := false
+ | Some (Bottom (node,key)) ->
+ plerror 10 "Queue length: %d" (Queue.length bottomQ);
+ match try_unmarshal cin with
+ | Some reply ->
+ ignore (Queue.pop bottomQ);
+ handle_reply cout tree ~requestQ reply (node,key) set
+ | None ->
+ match (
+ if Queue.length bottomQ > !Settings.max_outstanding_recon_requests
+ then None
+ else
+ try Some (Queue.pop requestQ)
+ with Queue.Empty -> None
+ )
+ with
+ | None ->
+ if not !flushing then flush_queue ()
+ else (
+ ignore (Queue.pop bottomQ);
+ let reply = unmarshal cin in
+ handle_reply cout tree ~requestQ reply (node,key) set
+ )
+ | Some (node,key) ->
+ send_request cout tree ~bottomQ (node,key)
+ done;
+ marshal cout Done;
+ !set
+ with
+ | Eventloop.SigAlarm ->
+ ignore (Unix.alarm recover_timeout);
+ plerror 2 "%s" ("Reconciliation failed due to timeout. " ^
+ "Returning elements returned so far");
+ !set
+ | End_of_file | Sys_error _ as e ->
+ ignore (Unix.alarm recover_timeout);
+ eplerror 2 e "%s" ("Reconciliation failed. " ^
+ "Returning elements returned so far");
+ !set
+
+
+(* Main reconciliation code *)
+let handle tree cin cout =
+ flushcount := 0; (* number of round-trips *)
+ let startkey = Bitstring.create 0 in
+ connection_manager cin cout tree (PTree.root tree, startkey)
Added: sks/branches/upstream/sks/current/common.ml
===================================================================
--- sks/branches/upstream/sks/current/common.ml (rev 0)
+++ sks/branches/upstream/sks/current/common.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,235 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Common services, including error reporting, logging,
+ exception handling and port definitions *)
+
+open Printf
+open StdLabels
+open MoreLabels
+module Unix = UnixLabels
+
+exception Bug of string
+exception Transaction_aborted of string
+exception Argument_error of string
+exception Unit_test_failure of string
+
+module Map = PMap.Map
+let (|<) map key = (fun data -> Map.add ~key ~data map)
+let (|=) map key = Map.find key map
+
+(** Function sequencing *)
+let (|!) x f = f x
+
+(********************************************************************)
+
+(** filters applied to all incoming keys *)
+let enforced_filters = ["yminsky.dedup"]
+
+let version_tuple = (__VERSION__)
+let compatible_version_tuple = (0,1,5)
+let version =
+ let (maj_version,min_version,release) = version_tuple in
+ sprintf "%d.%d.%d" maj_version min_version release
+
+let period_regexp = Str.regexp "[.]"
+
+let parse_version_string vstr =
+ let ar = Array.of_list (Str.bounded_split period_regexp vstr 3) in
+ (int_of_string ar.(0), int_of_string ar.(1), int_of_string ar.(2))
+
+let err_to_string err = match err with
+ Unix.Unix_error (enum,fname,param) ->
+ sprintf "Unix error: %s - %s(%s)"
+ (Unix.error_message enum) fname param
+ | e -> Printexc.to_string e
+
+(**************************************************************************)
+(** Logfile control *)
+
+let logfile = ref stdout
+let stored_logfile_name = ref None
+
+(**************************************************************************)
+
+let plerror level format =
+ kprintf (fun s ->
+ if !Settings.debug && level <= !Settings.debuglevel
+ then (
+ let tm = Unix.localtime (Unix.time ()) in
+ fprintf !logfile "%04d-%02d-%02d %02d:%02d:%02d "
+ (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1)
+ tm.Unix.tm_mday (* date *)
+ tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec; (* time *)
+ output_string !logfile s;
+ output_string !logfile "\n";
+ flush !logfile;
+ ) )
+ format
+
+(**************************************************************************)
+
+let set_logfile extension =
+ if !Settings.filelog then
+ let fname = (Filename.concat !Settings.basedir extension) ^ ".log" in
+ stored_logfile_name := Some fname;
+ logfile := open_out_gen [ Open_wronly; Open_creat; Open_append; ]
+ 0o600 fname;
+ plerror 0 "Opening log"
+
+let reopen_logfile () =
+ match !stored_logfile_name with
+ | None -> ()
+ | Some name ->
+ close_out !logfile;
+ logfile := open_out_gen [ Open_wronly; Open_creat; Open_append; ]
+ 0o600 name
+
+(**************************************************************************)
+
+let perror x = plerror 3 x
+
+let eplerror level e format =
+ kprintf (fun s ->
+ if !Settings.debug && level <= !Settings.debuglevel
+ then (
+ let tm = Unix.localtime (Unix.time ()) in
+ fprintf !logfile "%04d-%02d-%02d %02d:%02d:%02d "
+ (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1)
+ tm.Unix.tm_mday (* date *)
+ tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec;
+ output_string !logfile s;
+ fprintf !logfile ": %s\n" (err_to_string e);
+ flush !logfile;
+ )
+ )
+ format
+
+let eperror x = eplerror 3 x
+
+(********************************************************************)
+(** Setup signals. In particular, most of the time we want to catch and
+ gracefully handle both sigint and sigterm *)
+
+let catch_break = ref false
+let handle_interrupt i =
+ if !catch_break
+ then raise Sys.Break
+
+
+let () = Sys.set_signal Sys.sigterm (Sys.Signal_handle handle_interrupt)
+let () = Sys.set_signal Sys.sigint (Sys.Signal_handle handle_interrupt)
+let () = Sys.set_signal Sys.sigpipe Sys.Signal_ignore
+let () = Sys.set_signal Sys.sigusr2 Sys.Signal_ignore
+let () = Sys.set_signal Sys.sighup
+ (Sys.Signal_handle (fun _ -> reopen_logfile ()))
+
+let set_catch_break bool =
+ catch_break := bool
+ (* Sys.catch_break bool; *)
+
+let () = set_catch_break true
+
+(********************************************************************)
+
+let protect ~f ~finally =
+ let result = ref None in
+ let pfinally () =
+ set_catch_break false;
+ (try (finally () : unit)
+ with ee ->
+ set_catch_break true;
+ raise ee);
+ set_catch_break true;
+ in
+ try
+ result := Some (f ());
+ raise Exit
+ with
+ Exit as e ->
+ pfinally ();
+ (match !result with Some x -> x | None -> raise e)
+ | e ->
+ pfinally ();
+ raise e
+
+let fprotect ~f ~finally () = protect ~f ~finally
+
+let rec filter_opts optlist = match optlist with
+ [] -> []
+ | (Some x)::tl -> x::(filter_opts tl)
+ | None::tl -> filter_opts tl
+
+let decomment l =
+ try
+ let pos = String.index l '#' in
+ String.sub l ~pos:0 ~len:pos
+ with
+ Not_found -> l
+
+let rec strip_opt list = match list with
+ [] -> []
+ | None::tl -> strip_opt tl
+ | (Some hd)::tl -> hd::(strip_opt tl)
+
+let apply_opt ~f opt = match opt with
+ None -> None
+ | Some x -> Some (f x)
+
+(***************************)
+
+type event = | Add of string
+ | Delete of string
+
+type timestamp = float
+
+(************************************************************)
+(************************************************************)
+(** Network Related definitions *)
+
+let whitespace = Str.regexp "[ \t\n]+"
+let make_addr_list address_string port =
+ let addrlist = Str.split whitespace address_string in
+ let servname = if port = 0 then "" else (string_of_int port) in
+ let resolver host = List.map ~f:(fun ai -> ai.Unix.ai_addr)
+ (Unix.getaddrinfo host servname [Unix.AI_SOCKTYPE Unix.SOCK_STREAM]) in
+ List.flatten (List.map ~f:resolver addrlist)
+
+let recon_port = !Settings.recon_port
+let recon_address = !Settings.recon_address
+let http_port = !Settings.hkp_port
+let http_address = !Settings.hkp_address
+let db_command_name = Filename.concat !Settings.basedir "db_com_sock"
+let recon_command_name = Filename.concat !Settings.basedir "recon_com_sock"
+
+let db_command_addr = Unix.ADDR_UNIX db_command_name
+let recon_command_addr = Unix.ADDR_UNIX recon_command_name
+
+let recon_addr_to_http_addr addr = match addr with
+ Unix.ADDR_UNIX _ -> failwith "Can't convert UNIX address"
+ | Unix.ADDR_INET (inet_addr,port) -> Unix.ADDR_INET (inet_addr,port + 1)
+
+
+let get_client_recon_addr () =
+ make_addr_list recon_address 0
+let get_client_recon_addr =
+ Utils.unit_memoize get_client_recon_addr
+
+let match_client_recon_addr addr =
+ let family = Unix.domain_of_sockaddr addr in
+ List.find ~f:(fun caddr -> family = Unix.domain_of_sockaddr caddr)
+ (get_client_recon_addr ())
Added: sks/branches/upstream/sks/current/crc.c
===================================================================
--- sks/branches/upstream/sks/current/crc.c (rev 0)
+++ sks/branches/upstream/sks/current/crc.c 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,65 @@
+/*
+ This file is part of SKS. SKS 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
+*/
+
+#include <stdlib.h>
+#include <time.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+#define CRC24_INIT 0xb704ceL
+#define CRC24_POLY 0x1864cfbL
+
+typedef long crc24;
+crc24 crc_octets(unsigned char *octets, size_t len) {
+ crc24 crc = CRC24_INIT;
+ int i;
+
+ while (len--) {
+ crc ^= (*octets++) << 16;
+ for (i = 0; i < 8; i++) {
+ crc <<= 1;
+ if (crc & 0x1000000)
+ crc ^= CRC24_POLY;
+ }
+ }
+ return crc & 0xffffffL;
+}
+
+value caml_crc_octets(value data) {
+ CAMLparam1(data);
+ CAMLlocal1(rval);
+ unsigned char *octets = String_val(data);
+ size_t len = string_length(data);
+ long crc = crc_octets(octets,len);
+
+ rval = Val_int(crc);
+ CAMLreturn(rval);
+}
+
+
+value caml_get_tzname(value none) {
+ CAMLparam1(none);
+ CAMLlocal1(rval);
+ tzset();
+ rval = alloc_tuple(2);
+ Store_field(rval,0,copy_string(tzname[0]));
+ Store_field(rval,1,copy_string(tzname[1]));
+ CAMLreturn(rval);
+}
Added: sks/branches/upstream/sks/current/cryptokit-1.0.tar.gz
===================================================================
(Binary files differ)
Property changes on: sks/branches/upstream/sks/current/cryptokit-1.0.tar.gz
___________________________________________________________________
Added: svn:mime-type
+ application/octet-stream
Added: sks/branches/upstream/sks/current/dbMessages.ml
===================================================================
--- sks/branches/upstream/sks/current/dbMessages.ml (rev 0)
+++ sks/branches/upstream/sks/current/dbMessages.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,222 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Message types for communicating with com ports on dbserver and reconserver *)
+open MoreLabels
+open StdLabels
+open Packet
+open CMarshal
+open Common
+open Printf
+module Unix=UnixLabels
+module Set = PSet.Set
+
+
+(***********************************)
+
+type configvar = [ `int of int | `float of float | `string of string | `none ]
+
+let marshal_config cout (s,cvar) =
+ marshal_string cout s;
+ match cvar with
+ | `int x -> cout#write_byte 0; cout#write_int x
+ | `float x -> cout#write_byte 1; cout#write_float x
+ | `string x -> cout#write_byte 2; marshal_string cout x
+ | `none -> cout #write_byte 3
+
+let unmarshal_config cin =
+ let s = unmarshal_string cin in
+ let cvar =
+ match cin#read_byte with
+ | 0 -> `int cin#read_int
+ | 1 -> `float cin#read_float
+ | 2 -> `string (unmarshal_string cin)
+ | 3 -> `none
+ | _ -> failwith "Type failure unmarshalling config variable"
+ in
+ (s,cvar)
+
+(***********************************)
+(* Data Types ********************)
+(***********************************)
+
+type msg = | WordQuery of string list
+ | LogQuery of (int * timestamp) (* must make other changes.... *)
+ | HashRequest of string list
+ | LogResp of ( timestamp * event) list
+ | Keys of key list
+ | KeyStrings of string list
+ | Ack of int
+ | MissingKeys of (string list * Unix.sockaddr) (* DEPRECATED *)
+ | Synchronize
+ | RandomDrop of int
+ | ProtocolError
+ | DeleteKey of string
+ | Config of (string * configvar)
+ | Filters of string list
+
+(**** data specific marshallers ****)
+
+let marshal_timestamp cout timestamp = cout#write_float timestamp
+let unmarshal_timestamp cin = cin#read_float
+
+let marshal_logquery cout logquery =
+ let (count,timestamp) = logquery in
+ cout#write_int count;
+ marshal_timestamp cout timestamp
+
+let unmarshal_logquery cin =
+ let count = cin#read_int in
+ let timestamp = unmarshal_timestamp cin in
+ (count,timestamp)
+
+let marshal_event cout event = match event with
+ | Add hash -> cout#write_byte 0; marshal_string cout hash
+ | Delete hash -> cout#write_byte 1; marshal_string cout hash
+
+let unmarshal_event cin =
+ match cin#read_byte with
+ 0 -> Add (unmarshal_string cin)
+ | 1 -> Delete (unmarshal_string cin)
+ | _ -> failwith "Unexpected code for event"
+
+let marshal_log_entry cout ( timestamp , event ) =
+ marshal_timestamp cout timestamp;
+ marshal_event cout event
+
+let unmarshal_log_entry cin =
+ let timestamp = unmarshal_timestamp cin in
+ let event = unmarshal_event cin in
+ (timestamp,event)
+
+let marshal_key cout key = marshal_string cout (Key.to_string key)
+let unmarshal_key cin = Key.of_string (unmarshal_string cin)
+
+let marshal_key_list l = marshal_list ~f:marshal_key l
+let unmarshal_key_list l = unmarshal_list ~f:unmarshal_key l
+
+let marshal_missingkeys cout (list,sockaddr) =
+ marshal_list ~f:marshal_string cout list;
+ marshal_sockaddr cout sockaddr
+
+let unmarshal_missingkeys cin =
+ let list = unmarshal_list ~f:unmarshal_string cin in
+ let sockaddr = unmarshal_sockaddr cin in
+ (list,sockaddr)
+
+(********************************************************)
+
+let marshal_msg cout msg =
+ match msg with
+ | WordQuery x -> cout#write_byte 0; marshal_list ~f:marshal_string cout x
+ | LogQuery x -> cout#write_byte 1; marshal_logquery cout x
+ | LogResp x -> cout#write_byte 2; marshal_list ~f:marshal_log_entry cout x
+ | Keys x -> cout#write_byte 3; marshal_list ~f:marshal_key cout x
+ (* keystrings is just an alias for keys. They're sent over the wire
+ in the same form *)
+ | KeyStrings x -> cout#write_byte 3; marshal_list ~f:marshal_string cout x
+ | Ack x -> cout#write_byte 4; cout#write_int x
+ | MissingKeys x -> failwith "DO NOT USE MissingKeys"
+ (* cout#write_byte 5; marshal_missingkeys cout x*)
+ | Synchronize -> cout#write_byte 6
+ | RandomDrop x -> cout#write_byte 7; cout#write_int x
+ | ProtocolError -> cout#write_byte 8
+ | DeleteKey s -> cout#write_byte 9; marshal_string cout s
+ | HashRequest x -> cout#write_byte 10; marshal_list ~f:marshal_string cout x
+ | Config x -> cout#write_byte 11; marshal_config cout x
+ | Filters x -> cout#write_byte 12; marshal_list ~f:marshal_string cout x
+
+
+let rec unmarshal_msg cin =
+ let rval =
+ match cin#read_byte with
+ | 0 -> WordQuery (unmarshal_list ~f:unmarshal_string cin)
+ | 1 -> LogQuery (unmarshal_logquery cin)
+ | 2 ->
+ LogResp (unmarshal_list ~f:unmarshal_log_entry cin)
+ | 3 -> Keys (unmarshal_list ~f:unmarshal_key cin)
+ | 4 -> Ack cin#read_int
+ | 5 -> MissingKeys (unmarshal_missingkeys cin)
+ | 6 -> Synchronize
+ | 7 -> RandomDrop cin#read_int
+ | 8 -> ProtocolError
+ | 9 -> DeleteKey (unmarshal_string cin)
+ | 10 -> HashRequest (unmarshal_list ~f:unmarshal_string cin)
+ | 11 -> Config (unmarshal_config cin)
+ | 12 -> Filters (unmarshal_list ~f:unmarshal_string cin)
+ | _ -> failwith "Unexpected message type"
+ in
+ rval
+
+let sockaddr_to_string sockaddr = match sockaddr with
+ Unix.ADDR_UNIX s -> sprintf "<ADDR_UNIX %s>" s
+ | Unix.ADDR_INET (addr,p) -> sprintf "<ADDR_INET [%s]:%d>" (Unix.string_of_inet_addr addr) p
+
+let msg_to_string msg =
+ match msg with
+ WordQuery words -> "WordQuery: " ^ (String.concat ", " words)
+ | LogQuery (count,timestamp) -> sprintf "LogQuery: (%d,%f)" count timestamp
+ | LogResp list ->
+ let length = List.length list in
+ sprintf "LogResp: %d events" length
+ | Keys keys ->
+ let length = List.length keys in
+ sprintf "Keys: %d keys" length
+ | KeyStrings keystrings ->
+ let length = List.length keystrings in
+ sprintf "KeyStrings: %d keystrings" length
+ | Ack i ->
+ sprintf "Ack: %d" i
+ | MissingKeys (keys,sockaddr) ->
+ if List.length keys > 20 then
+ sprintf "MissingKeys: %d keys from %s"
+ (List.length keys) (sockaddr_to_string sockaddr)
+ else
+ sprintf "MissingKeys from %s: [ %s ]"
+ (sockaddr_to_string sockaddr)
+ (String.concat ~sep:""
+ (List.map ~f:(sprintf "\n\t%s")
+ (List.map Utils.hexstring keys)))
+ | Synchronize -> sprintf "Synchronize"
+ | RandomDrop i ->
+ sprintf "RandomDrop: %d" i
+ | ProtocolError -> "ProtocolError"
+ | DeleteKey x -> sprintf "DeleteKey %s" (Utils.hexstring x)
+ | HashRequest x -> sprintf "HashRequest(%d)" (List.length x)
+ | Config (s,cvar) -> sprintf "Config(s," ^
+ (match cvar with
+ `int x -> sprintf "%d)" x
+ | `float x -> sprintf "%f)" x
+ | `string x -> sprintf "%s)" x
+ | `none -> "none)"
+ )
+ | Filters filters -> sprintf "Filters(%s)"
+ (String.concat ~sep:"," filters)
+
+
+module M =
+ MsgContainer.Container(
+ struct
+ type msg_t = msg
+ let marshal = marshal_msg
+ let unmarshal = unmarshal_msg
+ let to_string = msg_to_string
+ let print = (fun s -> plerror 7 "%s" s)
+ end
+ )
+
+include M
Added: sks/branches/upstream/sks/current/dbscript.ml
===================================================================
--- sks/branches/upstream/sks/current/dbscript.ml (rev 0)
+++ sks/branches/upstream/sks/current/dbscript.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,50 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+open Printf
+open Common
+open Packet
+
+module Kdb = Keydb.MakeUnrestricted(
+ struct
+ let withtxn = !Settings.transactions
+ and cache_bytes = !Settings.cache_bytes
+ and pagesize = !Settings.pagesize
+ and dbdir = "/usr/share/keyfiles/sks_the_2/KDB"
+ and dumpdir = "/usr/share/keyfiles/sks_the_2/dump"
+ end
+)
+
+
+
+(*
+let unwrap x = match x with Some x -> x | None -> failwith "unwrapping None"
+let () = Keydb.open_dbs ()
+let (stream,close) = Keydb.create_hashstream ()
+
+
+let weirdhash_str = "C2A6E1C3749690E04AC6AFC2A2679A4E"
+let weirdhash = KeyHash.dehexify weirdhash_str
+let last = ref ""
+let x =
+ while
+ last := (unwrap (SStream.next stream));
+ !last < weirdhash
+ do () done
+*)
Added: sks/branches/upstream/sks/current/dbserver.ml
===================================================================
--- sks/branches/upstream/sks/current/dbserver.ml (rev 0)
+++ sks/branches/upstream/sks/current/dbserver.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,733 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Executable: server process that handles database and
+ database queries. *)
+
+module F(M:sig end) =
+struct
+ open StdLabels
+ open MoreLabels
+ open Printf
+ open Common
+ open Packet
+ module Unix = UnixLabels
+ open Unix
+ open DbMessages
+ open Request
+ open Pstyle
+
+ let () =
+ set_logfile "db";
+ plerror 0 "sks_db, SKS version %s" version;
+ plerror 0 "Copyright Yaron Minsky 2002, 2003, 2004";
+ plerror 0 "Licensed under GPL. See COPYING file for details";
+ plerror 3 "http port: %d" http_port
+
+ let settings = {
+ Keydb.withtxn = !Settings.transactions;
+ Keydb.cache_bytes = !Settings.cache_bytes;
+ Keydb.pagesize = !Settings.pagesize;
+ Keydb.dbdir = Lazy.force Settings.dbdir;
+ Keydb.dumpdir = Lazy.force Settings.dumpdir;
+ }
+ module Keydb = Keydb.Safe
+
+ (* Simple server code for handling DB requests. This is the main control
+ code for the DB. *)
+
+ let withtxn = !Settings.transactions
+ let dbdir = Lazy.force Settings.dbdir
+ let () =
+ if not withtxn then
+ failwith "Running sks_db without transactions is no longer supported."
+
+ let websocks =
+ List.map ~f:Eventloop.create_sock
+ ((if !Settings.use_port_80 then make_addr_list http_address 80 else [])
+ @ make_addr_list http_address http_port)
+
+ let () =
+ if Sys.file_exists db_command_name
+ then Unix.unlink db_command_name
+ let comsock = Eventloop.create_sock db_command_addr
+
+
+ (*********************************************************************)
+ (** Database checkpointing and syncing *)
+
+ let sync () =
+ perror "Syncing database";
+ Keydb.sync ();
+ perror "Syncing complete"
+
+ let sync_interval = !Settings.db_sync_interval
+
+ let checkpoint () =
+ perror "Checkpointing database";
+ Keydb.checkpoint ();
+ perror "Checkpointing complete"
+
+ let checkpoint_interval = !Settings.checkpoint_interval
+
+ (***************************************************************)
+ (* Helper functions for http request handler ****************)
+ (***************************************************************)
+
+ let ascending = compare
+ let descending x y = compare y x
+
+ (** sorts keys by time, dropping keys with no time *)
+ let tsort_keys keys =
+ let kpairs =
+ List.fold_left ~init:[] keys
+ ~f:(fun list key ->
+ try
+ let ki = ParsePGP.parse_pubkey_info (List.hd key) in
+ (ki.pk_ctime,key)::list
+ with
+ | Sys.Break as e -> raise e
+ | e -> list
+ )
+ in
+ let kpairs = List.sort ~cmp:descending kpairs in
+ List.map ~f:snd kpairs
+
+ (******************************************************************)
+
+ let get_stats () =
+ let today = Stats.round_up_to_day (Unix.gettimeofday ()) in
+ let log =
+ let maxsize = 180000 in
+ let last_month = today -. (180. *. 24. *. 60. *. 60.) in
+ Keydb.reverse_logquery ~maxsize last_month
+ in
+ let size = Keydb.get_num_keys () in
+ (log,size)
+
+ let last_stat_page = ref (Stats.generate_html_stats_page_nostats ())
+
+ let calculate_stats_page () =
+ plerror 3 "Calculating DB stats";
+ let (log,size) = get_stats () in
+ last_stat_page := Stats.generate_html_stats_page log size;
+ plerror 3 "Done calculating DB stats";
+ []
+
+ let get_keys_by_keyid keyid =
+ let keyid_length = String.length keyid in
+ let short_keyid = String.sub ~pos:(keyid_length - 4) ~len:4 keyid in
+ let keys = Keydb.get_by_short_subkeyid short_keyid in
+ match keyid_length with
+ | 4 -> (* 32-bit keyid. No further filtering required. *)
+ keys
+
+ | 8 -> (* 64-bit keyid *)
+ List.filter keys
+ ~f:(fun key -> keyid = (Fingerprint.from_key key).Fingerprint.keyid ||
+ (** Return keys i& subkeys with matching long keyID *)
+ let (mainkeyid,subkeyids) = Fingerprint.keyids_from_key ~short:false key in
+ List.exists (fun x -> x = keyid) subkeyids)
+
+ | 20 -> (* 160-bit v. 4 fingerprint *)
+ List.filter keys
+ ~f:(fun key -> keyid = (Fingerprint.from_key key).Fingerprint.fp ||
+ (** Return keys & subkeys with matching fingerprints *)
+ let (mainkeyfp,subkeyfps) = Fingerprint.fps_from_key key in
+ List.exists (fun x -> x = keyid) subkeyfps)
+
+ | 16 -> (* 128-bit v3 fingerprint. Not supported *)
+ failwith "128-bit v3 fingerprints not implemented"
+
+ | _ -> failwith "unknown keyid type"
+
+
+ (** returns list of keys readied for presentation *)
+ let clean_keys request keys =
+ if request.clean
+ then Utils.filter_map ~f:Fixkey.presentation_filter keys
+ else keys
+
+ (** return uid given keyid *)
+ let get_uids request keyid =
+ let keys = get_keys_by_keyid keyid in
+ let keys = clean_keys request keys in
+ match keys with
+ | [] | _::_::_ -> []
+ | key::tl ->
+ let pkey = KeyMerge.key_to_pkey key in
+ pkey.KeyMerge.uids
+
+ (******************************************************************)
+ (******************************************************************)
+
+ let check_prefix string prefix =
+ String.length string >= String.length prefix &&
+ (String.sub ~pos:0 ~len:(String.length prefix) string = prefix)
+
+ let lookup_keys search_terms =
+ let keys =
+ match search_terms with
+ | [] -> []
+ | first::rest ->
+ if check_prefix first "0x" then
+ (* keyid search *)
+ let keyid_string_length = String.length first - 2 in
+ let keyid =
+ try
+ KeyHash.dehexify
+ (String.sub ~pos:2 ~len:keyid_string_length first)
+ with e ->
+ let exn_str = sprintf "Unable to parse hash string: %s"
+ (Printexc.to_string e) in
+ raise (Wserver.Misc_error exn_str)
+ in
+ let keys = (try get_keys_by_keyid keyid
+ with Failure s -> raise (Wserver.Misc_error s))
+ in
+ keys
+ else
+ let keys = Keydb.get_by_words ~max:!Settings.max_matches
+ search_terms
+ in
+ tsort_keys keys
+ in
+ if keys = [] then raise (Wserver.Misc_error "No keys found")
+ else keys
+
+
+ (******************************************************************)
+ let truncate count keys =
+ let rec trunc_c result orig num =
+ match orig with
+ | [] -> result
+ | h::tail ->
+ if (num = 0)
+ then result
+ else (trunc_c (result @ [h]) tail (num-1))
+ in
+ if count > 0
+ then trunc_c [] keys count
+ else keys
+
+ let handle_get_request request =
+ match request.kind with
+ | Stats ->
+ plerror 4 "/pks/lookup: DB Stats request";
+ ("text/html; charset=UTF-8", -1, !last_stat_page)
+ | Get ->
+ plerror 4 "/pks/lookup: Get request (%s)"
+ (String.concat " " request.search);
+ let keys = lookup_keys request.search in
+ let keys = clean_keys request keys in
+ let count = List.length keys in
+ let keys = truncate request.limit keys in
+ let keystr = Key.to_string_multiple keys in
+ let aakeys = Armor.encode_pubkey_string keystr in
+ ("text/html; charset=UTF-8",
+ count,
+ HtmlTemplates.page
+ ~title:(sprintf "Public Key Server -- Get ``%s ''"
+ (String.concat ~sep:" " request.search))
+ ~body:(sprintf "\r\n<pre>\r\n%s\r\n</pre>\r\n" aakeys)
+ )
+ | HGet ->
+ let hash_str = List.hd request.search in
+ plerror 4 "/pks/lookup: Hash search: %s" hash_str;
+ let hash = KeyHash.dehexify hash_str in
+ flush Pervasives.stdout;
+ let key =
+ try Keydb.get_by_hash hash with Not_found ->
+ raise (Wserver.Misc_error "Requested hash not found")
+ in
+ let key =
+ if request.clean then
+ match Fixkey.presentation_filter key with
+ None -> raise (Wserver.Misc_error "No valid key found for hash")
+ | Some key -> key
+ else key
+ in
+ let keystr = Key.to_string key in
+ let aakeys = Armor.encode_pubkey_string keystr in
+ ("text/html; charset=UTF-8",
+ 1,
+ HtmlTemplates.page
+ ~title:(sprintf "Public Key Server -- Get ``%s ''" hash_str)
+ ~body:(sprintf "\r\n<pre>\r\n%s\r\n</pre>\r\n" aakeys)
+ )
+
+ | Index | VIndex ->
+ (* VIndex requests are treated indentically to index requests *)
+ plerror 4 "/pks/lookup: Index request: (%s)"
+ (String.concat " " request.search);
+ let keys = lookup_keys request.search in
+ let count = List.length keys in
+ let keys = truncate request.limit keys in
+ let hashes = List.map ~f:KeyHash.hash keys in
+ let keys = clean_keys request keys in
+ if request.machine_readable then
+ ("text/plain",
+ count,
+ MRindex.keys_to_index keys)
+ else
+ begin
+ try
+ let output =
+ if request.kind = VIndex then
+ List.map2 keys hashes
+ ~f:(Index.key_to_lines_verbose
+ ~get_uids:(get_uids request) request)
+ else
+ List.map2 keys hashes
+ ~f:(Index.key_to_lines_normal request)
+ in
+ let output = List.flatten output in
+ let pre = HtmlTemplates.preformat_list
+ (Index.keyinfo_header request :: output)
+ in
+ ("text/html; charset=UTF-8",
+ count,
+ HtmlTemplates.page ~body:pre
+ ~title:(sprintf "Search results for '%s'"
+ (String.concat ~sep:" " request.search))
+ )
+
+ with
+ | Invalid_argument "Insufficiently specific words" ->
+ raise (Wserver.Misc_error
+ ("Insufficiently specific words: provide " ^
+ "at least one more specific keyword"))
+
+ | Invalid_argument "Too many responses" ->
+ raise (Wserver.Misc_error
+ "Too many responses, unable to process query")
+ end
+
+ let string_to_oplist s =
+ let s = Wserver.strip s in
+ try
+ let (base,op_string) = chsplit '?' s in
+ let oplist = Str.split amp op_string in
+ let pairs = List.map ~f:(chsplit '=') oplist in
+ let oplist =
+ List.map pairs
+ ~f:(fun (key,value) -> (key, Wserver.decode value))
+ in
+ (base,oplist)
+ with
+ Not_found -> (s,[])
+
+ let get_extension s =
+ let pos = String.rindex s '.' in
+ s </> (pos,0)
+
+ let bool_to_string b = if b then "true" else "false"
+ let print_request cout r =
+ fprintf cout " kind: %s\n" (
+ (function
+ Index -> "index" | VIndex -> "vindex" | Stats -> "stats"
+ | Get -> "get" | HGet -> "hashget")
+ r.kind);
+ fprintf cout " fingerprint: %s\n" (bool_to_string r.fingerprint);
+ fprintf cout " exact: %s\n" (bool_to_string r.exact);
+ fprintf cout " search: %s\n"
+ (MList.to_string ~f:(fun x -> x) r.search)
+
+ let get_keystrings_from_hashes hashes =
+ let rec loop hashes keystrings = match hashes with
+ [] -> keystrings
+ | hash::tl ->
+ try
+ let keystring = Keydb.get_keystring_by_hash hash in
+ loop tl (keystring::keystrings)
+ with
+ e ->
+ eplerror 2 e "Error fetching key from hash %s"
+ (KeyHash.hexify hash);
+ loop tl keystrings
+ in
+ loop hashes []
+
+ let read_file ?(binary=false) fname =
+ if not (Sys.file_exists fname) then raise (Wserver.Page_not_found fname);
+ let f = (if binary then open_in_bin else open_in) fname in
+ protect ~f:(fun () ->
+ let length = in_channel_length f in
+ let buf = String.create length in
+ really_input f buf 0 length;
+ buf
+ )
+ ~finally:(fun () -> close_in f)
+
+
+ let is_safe char =
+ (char >= 'A' && char <= 'Z') || (char >= 'a' && char <= 'z') ||
+ (char >= '0' && char <= '9') || (char = '.') || (char = '-')
+
+
+ let verify_web_fname fname =
+ let bad = ref false in
+ let pos = ref 0 in
+ while not !bad && !pos < String.length fname do
+ if not (is_safe fname.[!pos]) then bad := true;
+ incr pos
+ done;
+ not !bad
+
+ let convert_web_fname fname =
+ if verify_web_fname fname then
+ Filename.concat !Settings.basedir (Filename.concat "web" fname)
+ else raise (Wserver.Misc_error "Malformed requst")
+
+ let supported_extensions =
+ [ ".jpg", "image/jpeg";
+ ".jpeg", "image/jpeg";
+ ".gif", "image/gif";
+ ".ico", "image/x-icon";
+ ".png", "image/png";
+ ".htm", "text/html";
+ ".html", "text/html";
+ ".shtml", "text/html";
+ ".txt", "text/plain";
+ ".css", "text/css";
+ ".xhtml", "application/xhtml+xml";
+ ".xhtm", "application/xhtml+xml";
+ ".xml", "application/xhtml+xml";
+ ".es", "application/ecmascript";
+ ".js", "application/javascript";
+ ]
+
+ (** Handler for HTTP requests *)
+ let webhandler addr msg cout =
+ match msg with
+ | Wserver.GET (request,headers) ->
+ plerror 5 "Get request: %s => %s"
+ (sockaddr_to_string addr) request;
+ let (base,oplist) = string_to_oplist request in
+ if base = "/pks/lookup" then (
+ let request = request_of_oplist oplist in
+ let (mimetype,count,body) = handle_get_request request in
+ cout#write_string body;
+ (mimetype, count)
+ ) else (
+ if (base = "/index.html" || base = "/index.htm"
+ || base = "/" || base = "")
+ then
+ let fname = convert_web_fname "index.html" in
+ let text = read_file fname in
+ cout#write_string text;
+ ("text/html; charset=UTF-8", -1)
+ else
+ (try
+ let extension = get_extension base in
+ let mimetype =
+ try List.assoc extension supported_extensions
+ with Not_found ->
+ raise (Wserver.Misc_error
+ ("internal error: no mimetype " ^
+ "for given extension"))
+ in
+ let base = base </> (1,0) in
+ let data = read_file ~binary:true (convert_web_fname base) in
+ cout#write_string data;
+ (mimetype, -1)
+ with
+ Not_found -> raise (Wserver.Page_not_found base)
+ )
+ )
+ | Wserver.POST (request,headers,body) ->
+ let request = Wserver.strip request in
+ match request with
+ "/pks/add" ->
+ let keytext = Scanf.sscanf body "keytext=%s" (fun s -> s) in
+ let keytext = Wserver.decode keytext in
+ let keys = Armor.decode_pubkey keytext in
+ plerror 3 "Handling /pks/add for %d keys"
+ (List.length keys);
+ cout#write_string "<html><body>";
+ let ctr = ref 0 in
+ List.iter keys
+ ~f:(fun origkey ->
+ try
+ let key = Fixkey.canonicalize origkey in
+ plerror 3 "/pks/add: key %s added to database"
+ (KeyHash.hexify (KeyHash.hash key));
+ Keydb.add_key_merge ~newkey:true key;
+ incr ctr;
+ with
+ | Fixkey.Bad_key | KeyMerge.Unparseable_packet_sequence ->
+ cout#write_string
+ ("Add failed: Malformed Key --- unexpected packet " ^
+ "type and/or order of packets<br>");
+ plerror 2 "key %s %s"
+ (KeyHash.hexify (KeyHash.hash origkey))
+ "could not be parsed by KeyMerge.canonicalize"
+ | Bdb.Key_exists as e ->
+ cout#write_string
+ ("Add failed: identical key already " ^
+ "exists in database<br>");
+ eperror e "Key add failed"
+ | e ->
+ Eventloop.reraise e;
+ cout#write_string "Add failed<br>";
+ eperror e "Key add failed"
+ );
+ if !ctr > 0 then (
+ cout#write_string
+ ("Key block added to key server database.\n " ^
+ "New public keys added: <br>");
+ cout#write_string (sprintf "%d key(s) added successfully.<br>" !ctr)
+ );
+ cout#write_string "</html></body>";
+ ("text/html; charset=UTF-8", List.length keys)
+ | "/pks/hashquery" ->
+ plerror 4 "Handling /pks/hashquery";
+ let sin = new Channel.string_in_channel body 0 in
+ let hashes =
+ CMarshal.unmarshal_list ~f:CMarshal.unmarshal_string sin
+ in
+ let keystrings = get_keystrings_from_hashes hashes in
+ perror "%d keys found" (List.length keystrings);
+ CMarshal.marshal_list ~f:CMarshal.marshal_string cout
+ keystrings;
+ ("pgp/keys" (* This is a bogus content-type *),
+ List.length keystrings)
+ | _ ->
+ cout#write_string (HtmlTemplates.page
+ ~title:"Unexpected POST request"
+ ~body:"");
+ ("text/html; charset=UTF-8", -1)
+
+
+ (** Prepare handler for use with eventloop by transforming system
+ channels to Channel objects and by returning empty list instead
+ of unit *)
+ let eventify_handler handle =
+ (fun addr cin cout ->
+ let cin = (new Channel.sys_in_channel cin)
+ and cout = (new Channel.sys_out_channel cout) in
+ handle addr cin cout;
+ []
+ )
+
+ let get_filters =
+ Utils.unit_memoize
+ (fun () ->
+ try Str.split comma_rxp (Keydb.get_meta "filters")
+ with Not_found -> []
+ )
+
+
+ (** Handler for commands coming off of the db_command_addr *)
+ let command_handler addr cin cout =
+ match (unmarshal cin).msg with
+ | LogQuery (count,timestamp) ->
+ let logresp = Keydb.logquery ~maxsize:count timestamp in
+ let length = List.length logresp in
+ if length > 0 then
+ plerror 3 "Sending LogResp size %d" length;
+ marshal cout (LogResp logresp)
+
+ | WordQuery words ->
+ plerror 3 "Handling WordQuery";
+ let keys = Keydb.get_by_words ~max:!Settings.max_matches words in
+ marshal cout (Keys keys)
+
+ | Keys keys ->
+ let keys = List.fold_left ~init:[] keys
+ ~f:(fun list key ->
+ try (Fixkey.canonicalize key)::list
+ with KeyMerge.Unparseable_packet_sequence | Fixkey.Bad_key -> list
+ )
+ in
+ marshal cout (Ack 0);
+ (try Keydb.add_keys_merge keys
+ with e -> eplerror 2 e "Key addition failed")
+
+ | DeleteKey hash ->
+ plerror 3 "Handling DeleteKey";
+ ( try
+ let hash = RMisc.truncate hash KeyHash.hash_bytes in
+ let key = Keydb.get_by_hash hash in
+ Keydb.delete_key ~hash key;
+ marshal cout (Ack 0);
+ with
+ e ->
+ marshal cout (Ack (-1));
+ raise e
+ )
+ | HashRequest hashes ->
+ plerror 3 "Handling HashRequest";
+ let keys =
+ List.fold_left hashes ~init:[]
+ ~f:(fun list hash ->
+ try (Keydb.get_by_hash hash)::list
+ with
+ Not_found ->
+ plerror 2 "Requested key %s not found"
+ (Utils.hexstring hash);
+ list
+ )
+ in
+ plerror 3 "Returning set of %d keys" (List.length keys);
+ marshal cout (Keys keys)
+
+
+ | Config (s,cvar) ->
+ plerror 4 "Received config message";
+ (match (s,cvar) with
+ | ("checkpoint", `none) ->
+ checkpoint ()
+ | ("filters", `none) ->
+ marshal cout (Filters (get_filters ()))
+ | (str,value) ->
+ perror "Unexpected config request <%s>" str
+ )
+
+
+ | m ->
+ marshal cout ProtocolError;
+ perror "Unexpected (%s) message" (msg_to_string m)
+
+
+ (***********************************************************************)
+
+ (** dequeues and transmits single key. Returns true if there
+ might be more keys to be handled. *)
+ let rec transmit_single_key () =
+ let txn = Keydb.txn_begin () in
+ try
+ match (try Some (Keydb.dequeue_key ~txn)
+ with Not_found -> None)
+ with
+ | Some (time,key) ->
+ let body = Armor.encode_pubkey key in
+ let to_header = ("To", String.concat ~sep:", "
+ (Membership.get_mailsync_partners ()))
+ in
+ let msg = { Sendmail.headers =
+ [ to_header;
+ "From", Settings.get_from_addr ();
+ "Reply-To", Settings.get_from_addr ();
+ "Errors-To", Settings.get_from_addr ();
+ "Subject","incremental";
+ "Precedence","list";
+ "Content-type", "application/pgp-keys";
+ "X-KeyServer-Sent", Settings.get_from_addr ();
+ ] ;
+ Sendmail.body = body;
+ }
+ in
+ let string = Sendmail.msg_to_string msg in
+ plerror 3 "Message transmitted for key %s"
+ (KeyHash.hexify (KeyHash.hash key));
+ plerror 6 "%s" string;
+ Sendmail.send msg;
+ Keydb.txn_commit txn;
+ plerror 5 "transmission queue transaction committed";
+ true
+ | None ->
+ (* nothing was done, so commiting and aborting are same here *)
+ Keydb.txn_abort txn;
+ false
+ with
+ e ->
+ Keydb.txn_abort txn;
+ raise e
+
+
+ (** Transmit all enqueued keys to other hosts *)
+ let transmit_keys () =
+ while transmit_single_key () do () done;
+ []
+
+ (***********************************************************************)
+
+ let sync_db_on_sig () =
+ sync ();
+ checkpoint ()
+
+ let () = Sys.set_signal Sys.sigusr1
+ (Sys.Signal_handle (fun _ -> sync_db_on_sig ()))
+
+ let () = Sys.set_signal Sys.sigusr2
+ (Sys.Signal_handle (fun _ ->
+ Eventloop.add_events Eventloop.heap
+ [Eventloop.Event(0.0, Eventloop.Callback calculate_stats_page)]))
+
+ (***********************************************************************)
+
+ let run () =
+ Keydb.open_dbs settings;
+ if !Settings.initial_stat then ignore (calculate_stats_page ());
+ plerror 2 "Database opened";
+ plerror 0 "Applied filters: %s" (String.concat ~sep:", "
+ (get_filters ()));
+ Eventloop.evloop
+
+ (
+ (if withtxn
+ then (Ehandlers.repeat_forever_simple checkpoint_interval checkpoint)
+ else (Ehandlers.repeat_forever_simple sync_interval sync))
+ @
+ Ehandlers.repeat_forever_simple !Settings.membership_reload_time
+ Membership.reset_membership_time
+ @
+ (if !Settings.send_mailsyncs then
+ (Ehandlers.repeat_forever 10.
+ (Eventloop.make_tc ~cb:transmit_keys ~timeout:0
+ ~name:"mail transmit keys" )
+ )
+ else [])
+ @
+ (Ehandlers.repeat_forever 10.
+ (Eventloop.make_tc ~name:"mailsync" ~timeout:0
+ ~cb:(Mailsync.load_mailed_keys
+ ~addkey:(Keydb.add_key_merge ~newkey:false)))
+ )
+ @
+ (Ehandlers.repeat_at_hour !Settings.stat_calc_hour
+ calculate_stats_page)
+ )
+
+ (
+ (comsock, Eventloop.make_th ~name:"command handler"
+ ~timeout:!Settings.command_timeout
+ ~cb:(eventify_handler command_handler))
+ ::
+ (List.map websocks
+ ~f:(fun sock ->
+ (sock, Eventloop.make_th ~name:"webserver"
+ ~timeout:!Settings.wserver_timeout
+ ~cb:(Wserver.accept_connection webhandler ~recover_timeout:1))))
+ )
+
+
+
+ let run () =
+ protect ~f:run
+ ~finally:(fun () ->
+ set_catch_break false;
+ plerror 0 "Shutting down database";
+ Keydb.sync ();
+ plerror 0 "Database sync'd";
+ Keydb.unconditional_checkpoint ();
+ plerror 0 "Database checkpointed";
+ Keydb.close_dbs ();
+ plerror 0 "Database closed"
+ )
+end
Added: sks/branches/upstream/sks/current/dbtest.ml
===================================================================
--- sks/branches/upstream/sks/current/dbtest.ml (rev 0)
+++ sks/branches/upstream/sks/current/dbtest.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,72 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+open Printf
+open Common
+open Packet
+
+module Kdb = Keydb.Unsafe
+
+let settings = {
+ Keydb.withtxn = !Settings.transactions;
+ Keydb.cache_bytes = !Settings.cache_bytes;
+ Keydb.pagesize = !Settings.pagesize;
+ Keydb.dbdir = "/usr/share/keyfiles/sks_blackhole/KDB";
+ Keydb.dumpdir = "/usr/share/keyfiles/sks_blackhole/dump";
+}
+let () = Kdb.open_dbs settings
+
+let rec strip_opt list = match list with
+ [] -> []
+ | None::tl -> strip_opt tl
+ | (Some hd)::tl -> hd::(strip_opt tl)
+
+
+let rec beginning n list =
+ if n = 0 then []
+ else match list with
+ [] -> []
+ | hd::tl -> hd::(beginning (n-1) tl)
+
+let merge_all keys =
+ let keys = Array.to_list keys in
+ match keys with
+ hd::tl ->
+ List.fold_left ~init:hd tl
+ ~f:(fun key1 key2 -> match KeyMerge.merge key1 key2 with
+ None -> failwith "hit unparseable key"
+ | Some key -> key)
+ | [] -> failwith "List too short"
+
+let mergeable key1 key2 =
+ match KeyMerge.merge key1 key2 with
+ None -> false
+ | Some key -> true
+
+exception KeyFail of string
+
+let ctr = ref 0
+let click () =
+ incr ctr;
+ if !ctr mod 100 = 0
+ then (
+ printf "%d\n" !ctr;
+ flush stdout;
+ )
+
Added: sks/branches/upstream/sks/current/decode.ml
===================================================================
--- sks/branches/upstream/sks/current/decode.ml (rev 0)
+++ sks/branches/upstream/sks/current/decode.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,168 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open ZZp.Infix
+
+(** Handles decoding aspect of set-reconciliation algorithm. *)
+open StdLabels
+open MoreLabels
+module Unix=UnixLabels
+open Printf
+
+module ZSet = ZZp.Set
+open LinearAlg
+open ZZp.Infix
+
+exception Low_mbar
+exception Interpolation_failure
+
+
+(** takes [values], an array of evaluations of an unknown rational function,
+ evaluated at [points], and [d], the degree difference between the numerator
+ and the denominator. Returns the numerator,denominator pair describing the
+ reduced rational function, if such exists.
+*)
+let interpolate ~values ~points ~d =
+ if (abs d) > Array.length values
+ then raise Interpolation_failure;
+ let mbar = Array.length values in
+ let mbar =
+ if (mbar + d) mod 2 <> 0
+ then mbar - 1 else mbar
+ in
+ let ma = (mbar + d) / 2 and mb = (mbar - d) / 2 in
+ let matrix = Matrix.make ~rows:mbar ~columns:(mbar + 1)
+ ZZp.zero in
+ for j = 0 to mbar - 1 do
+ let accum = ref ZZp.one in
+ let kj = points.(j) in
+ let fj = values.(j) in
+
+ for i = 0 to ma - 1 do
+ Matrix.set matrix i j !accum;
+ accum := ZZp.mul kj !accum
+ done;
+ let kjma = !accum in
+
+ accum := ZZp.neg fj;
+ for i = ma to mbar - 1 do
+ Matrix.set matrix i j !accum;
+ accum := ZZp.mul kj !accum
+ done;
+ let fjkjmb = ZZp.neg !accum in
+
+ Matrix.set matrix mbar j (ZZp.sub fjkjmb kjma)
+ done;
+
+ (try reduce matrix
+ with Failure s -> raise Interpolation_failure);
+
+ let acoeffs = Array.init (ma + 1)
+ ~f:(fun j -> if j = ma then ZZp.one
+ else Matrix.get matrix mbar j)
+ and bcoeffs = Array.init (mb + 1)
+ ~f:(fun j -> if j = mb then ZZp.one
+ else Matrix.get matrix mbar (j + ma)) in
+ let apoly = Poly.of_array acoeffs and bpoly = Poly.of_array bcoeffs in
+ let g = Poly.gcd apoly bpoly in
+ (Poly.div apoly g, Poly.div bpoly g)
+
+
+
+(*********************************************************************)
+(*********************************************************************)
+
+let mult modulus x y = Poly.modulo (Poly.mult x y) modulus
+let square modulus x = Poly.modulo (Poly.mult x x) modulus
+
+let powmod ~modulus x n =
+ let nbits = Number.nbits n in
+ let rval = ref Poly.one in
+ let x2n = ref x in
+ for bit = 0 to nbits do
+ if Number.nth_bit n bit then
+ rval := mult modulus !rval !x2n;
+ x2n := square modulus !x2n
+ done;
+ !rval
+
+(************************************************************)
+
+let rand_ZZp () =
+ let primebits = !ZZp.nbits in
+ let random = Prime.randbits Random.bits primebits in
+ ZZp.of_number random
+
+(** Checks preconditions of factorizability. In particular, that the
+ polynomial is *)
+let factor_check x =
+ if Poly.degree x = 1 || Poly.degree x = 0 then true
+ else
+ let z = Poly.of_array [| ZZp.zero; ZZp.one |] in
+ let zq = powmod ~modulus:x z !ZZp.order in
+ let mz = Poly.scmult z (ZZp.of_int (-1)) in
+ let zqmz = Poly.modulo (Poly.add zq mz) x in
+ Poly.eq zqmz Poly.zero
+
+let gen_splitter f =
+ let q = ZZp.neg ZZp.one /: ZZp.two in
+ let a = rand_ZZp () in
+ let za = Poly.of_array [| a ; ZZp.one |] in
+ let zaq = powmod ~modulus:f za (ZZp.to_number q) in
+ let zaqo = Poly.sub zaq Poly.one in
+ zaqo
+
+let rec rand_split f =
+ let splitter = gen_splitter f in
+ let first = Poly.gcd splitter f in
+ let second = Poly.div f first in
+ (first,second)
+
+let rec factor f =
+ let degree = Poly.degree f in
+ if degree = 1
+ then ZSet.add (ZZp.neg (Poly.const_coeff f)) ZSet.empty
+ else if degree = 0
+ then ZSet.empty
+ else
+ let (f1,f2) = rand_split f in
+ flush stdout;
+ ZSet.union (factor f1) (factor f2)
+
+let shorten array =
+ Array.init (Array.length array - 1) ~f:(fun i -> array.(i))
+
+let reconcile ~values ~points ~d =
+ let len = Array.length points in
+ let (num,denom) =
+ try interpolate
+ ~values:(shorten values)
+ ~points:(shorten points) ~d
+ with Interpolation_failure -> raise Low_mbar
+ in
+ let val_from_poly = ZZp.div (Poly.eval num points.(len - 1))
+ (Poly.eval denom points.(len - 1)) in
+ if val_from_poly <>: values.(len - 1) ||
+ not (factor_check num) || not (factor_check denom)
+ then raise Low_mbar;
+ let aset = factor num
+ and bset = factor denom
+ in (aset,bset)
+
+let array_to_set array =
+ Array.fold_left ~f:(fun set el -> ZSet.add el set) ~init:ZSet.empty array
+
Added: sks/branches/upstream/sks/current/decode_test.ml
===================================================================
--- sks/branches/upstream/sks/current/decode_test.ml (rev 0)
+++ sks/branches/upstream/sks/current/decode_test.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,173 @@
+open StdLabels
+open MoreLabels
+open Printf
+open Decode
+open Common
+
+(** Unit tests for number.ml *)
+
+open ZZp.Infix
+module ZSet = ZZp.Set
+
+let rand_int = Random.State.int RMisc.det_rng
+let rand_bits () = Random.State.bits RMisc.det_rng
+
+(*************************************************************************)
+(** Simple counter table *)
+
+let ctr_table = Hashtbl.create 0
+
+let incr_count name =
+ try
+ let ctr_ref = Hashtbl.find ctr_table name in
+ incr ctr_ref
+ with
+ Not_found ->
+ Hashtbl.add ctr_table ~key:name ~data:(ref 1)
+
+let read_count name =
+ try !(Hashtbl.find ctr_table name)
+ with Not_found -> 0
+
+(*************************************************************************)
+
+let test name cond =
+ printf ".%!";
+ incr_count name;
+ if not cond then raise
+ (Unit_test_failure (sprintf "Decode test <%s:%d> failed"
+ name (read_count name)))
+
+(** creates a random monic polynomial of desired dimension *)
+let rand_poly dim =
+ let poly = Array.init (dim + 1)
+ ~f:(fun i ->
+ if i = dim then ZZp.one
+ else ZZp.rand rand_bits)
+ in
+ Poly.of_array poly
+
+let interp_test () =
+ let deg = rand_int 10 + 1 in
+ let num_deg = rand_int deg in
+ let denom_deg = deg - num_deg in
+ let num = rand_poly num_deg in
+ let denom = rand_poly denom_deg in
+ test "poly construction"
+ (Poly.degree num == num_deg && Poly.degree denom = denom_deg );
+
+ let mbar = rand_int 9 + 1 in
+ let n = mbar + 1 in
+
+ let toobig = deg + 1 > mbar in
+ let values = ZZp.mut_array_to_array (ZZp.svalues n) in
+ let points = ZZp.points n in
+ for i = 0 to Array.length values - 1 do
+ values.(i) <- Poly.eval num points.(i) /: Poly.eval denom points.(i)
+ done;
+ try
+ let (found_num,found_denom) =
+ Decode.interpolate ~values ~points ~d:(num_deg - denom_deg)
+ in
+(* printf "mbar: %d, num_deg: %d, denom_deg: %d\n" mbar num_deg denom_deg;
+ printf "num: %s\ndenom: %s\n%!" (Poly.to_string num) (Poly.to_string denom);
+ printf "gcd: %s\n" (Poly.to_string (Poly.gcd num denom));
+ printf "found num: %s\nfound denom: %s\n%!"
+ (Poly.to_string found_num) (Poly.to_string found_denom); *)
+ test "degree equality" (toobig
+ || (Poly.degree found_num = Poly.degree num
+ && Poly.degree found_denom = Poly.degree denom));
+ test "num equality" (toobig || Poly.eq found_num num);
+ test "denom equality" (toobig || Poly.eq found_denom denom);
+ with
+ Interpolation_failure ->
+ test (sprintf "interpolation failed (deg:%d,mbar:%d)" deg mbar)
+ (deg + 1 > mbar)
+
+
+let set_init ~f n =
+ let rec loop n set =
+ if n = 0 then set
+ else loop (n - 1) (ZSet.add (f ()) set)
+ in
+ loop n ZSet.empty
+
+let ( &> ) f g x = f (g x)
+let ( &< ) g f x = f (g x)
+let ( @@ ) f x = f x
+
+(** Test full reconciliation, from beginning to end *)
+let reconcile_test () =
+ let mbar = rand_int 20 + 1 in (* maximum recoverable # of points *)
+ let n = mbar + 1 in (* Number of sample values to capture *)
+ let points = ZZp.points n in (* Array of evaluation points *)
+ let svalues1 = ZZp.svalues n in (* sample values 1 *)
+ let svalues2 = ZZp.svalues n in (* sample values 2 *)
+ let m = rand_int (mbar * 2) + 1 in (* diff size to be reconciled *)
+ (* m1 and m2 are a partitioning of m *)
+ let m1 = rand_int m in
+ let m2 = m - m1 in
+ let set1 = set_init m1 ~f:(fun () -> ZZp.rand rand_bits) in
+ let set2 = set_init m2 ~f:(fun () -> ZZp.rand rand_bits) in
+ (* printf "mbar: %d, m: %d, m1: %d, m2: %d\n%!" mbar m m1 m2; *)
+ test "full sets" (ZSet.cardinal set1 = m1 && ZSet.cardinal set2 = m2);
+ test "empty intersection" (ZSet.is_empty @@ ZSet.inter set1 set2);
+ ZSet.iter ~f:(fun x -> ZZp.add_el ~svalues:svalues1 ~points x) set1;
+ ZSet.iter ~f:(fun x -> ZZp.add_el ~svalues:svalues2 ~points x) set2;
+ let values = ZZp.mut_array_div svalues1 svalues2 in
+ try
+ let (diff1,diff2) =
+ Decode.reconcile ~values ~points ~d:(m1 - m2)
+ in
+ test "size equality set1"
+ (ZSet.cardinal set1 = ZSet.cardinal diff1);
+ test "size equality set2"
+ (ZSet.cardinal set2 = ZSet.cardinal diff2);
+ test "recon compare" (ZSet.equal diff1 set1 && ZSet.equal diff2 set2)
+ with
+ Low_mbar -> test "low mbar" (m > mbar)
+
+let factorization_test () =
+ let deg = rand_int 10 + 1 in
+ let terms = Array.to_list (Array.init deg (fun _ -> rand_poly 1)) in
+ let poly = List.fold_left ~init:Poly.one ~f:Poly.mult terms in
+ let roots = Decode.factor poly in
+ let orig_roots =
+ ZZp.zset_of_list (List.map ~f:(fun p -> ZZp.neg (Poly.to_array p).(0)) terms)
+ in
+ test "factor equality" (ZSet.equal orig_roots roots)
+
+let interp_run () =
+ let deg = rand_int 10 + 1 in
+ let num_deg = rand_int deg in
+ let denom_deg = deg - num_deg in
+ let num = rand_poly num_deg in
+ let denom = rand_poly denom_deg in
+ if not (Poly.degree num == num_deg && Poly.degree denom = denom_deg )
+ then `poly_gen_falure (deg,num_deg,denom_deg,num,denom)
+ else
+
+ let mbar = rand_int 9 + 1 in
+ let n = mbar + 1 in
+
+ let values = ZZp.mut_array_to_array (ZZp.svalues n) in
+ let points = ZZp.points n in
+ for i = 0 to Array.length values - 1 do
+ values.(i) <- Poly.eval num points.(i) /: Poly.eval denom points.(i)
+ done;
+ try
+ let (found_num,found_denom) =
+ Decode.interpolate ~values ~points ~d:(num_deg - denom_deg)
+ in
+ `succ ((num,denom),(found_num,found_denom),mbar)
+ with
+ Interpolation_failure ->
+ `fail ((num,denom),mbar)
+
+
+let run () =
+ begin
+ for i = 1 to 100 do factorization_test () done;
+ for i = 1 to 100 do interp_test () done;
+ for i = 1 to 100 do reconcile_test () done;
+ end
Added: sks/branches/upstream/sks/current/ehandlers.ml
===================================================================
--- sks/branches/upstream/sks/current/ehandlers.ml (rev 0)
+++ sks/branches/upstream/sks/current/ehandlers.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,108 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** functions for constructing event handlers for use with [Eventloop] module *)
+open StdLabels
+open MoreLabels
+open Printf
+
+open Common
+open Eventloop
+module Unix = UnixLabels
+
+(** Repeat callback ~request with a gap of redo_timeout, until
+ either (test ()) is true or full_timeout has expired.
+ In the former case, invoke success, int the latter, failure.
+
+ Callbacks can return a list of events, which will be placed
+ on the queue upon their completion.
+ *)
+let repeat_until ~redo_timeout ~full_timeout ~test
+ ~init ~request ~success ~failure =
+ init ();
+ let start = Unix.gettimeofday () in
+ let rec loop () =
+ let now = Unix.gettimeofday () in
+ if test ()
+ then success ()
+ else if now > start +. full_timeout
+ then failure ()
+ else
+ (request ()) @
+ [ Event (now +. redo_timeout, Callback loop) ]
+ in
+ let now = Unix.gettimeofday () in
+ [ Event (now, Callback loop) ]
+
+
+(** returns smallest floating point number larger than the argument *)
+let float_incr x = x +. x *. epsilon_float
+let float_decr x = x -. x *. epsilon_float
+
+let strftime time =
+ let tm = Unix.localtime time in
+ sprintf "%02d:%02d:%02d" tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
+
+
+(** repeat provided callback forever, with one invocation occuring timeout
+ seconds after the last one completed. *)
+let repeat_forever ?(jitter=0.0) ?start timeout callback =
+ let rec loop () =
+ let delay = timeout +. (Random.float jitter -. jitter /. 2.) *. timeout in
+ let next_time = Unix.gettimeofday () +. delay in
+ [ Event (next_time, callback);
+ Event (float_incr next_time, Callback loop);
+ ]
+ in
+ let start = match start with
+ None -> Unix.gettimeofday ()
+ | Some time -> time
+ in
+ [ Event (start, Callback loop); ]
+
+
+let repeat_forever_simple timeout callback =
+ repeat_forever timeout (Callback (fun () -> callback (); []))
+
+
+let incr_day time =
+ let tm = Unix.localtime time in
+ let tm = {tm with Unix.tm_mday = tm.Unix.tm_mday + 1; } in
+ let (time,tm) = Unix.mktime tm in
+ time
+
+let set_hour time hour =
+ let tm = Unix.localtime time in
+ let tm = {tm with
+ Unix.tm_sec = 0;
+ Unix.tm_min = 0;
+ Unix.tm_hour = hour;
+ Unix.tm_mday = tm.Unix.tm_mday +
+ if hour < tm.Unix.tm_hour then 1 else 0
+ }
+ in
+ let (time,tm) = Unix.mktime tm in
+ time
+
+let repeat_at_hour hour callback =
+ let rec loop oldtime () =
+ let newtime = incr_day oldtime in
+ [ Event (oldtime, Callback callback);
+ Event (newtime, Callback (loop newtime)) ]
+ in
+ let start = set_hour (Unix.gettimeofday ()) hour in
+ [Event (start, Callback (loop start)) ]
Added: sks/branches/upstream/sks/current/eventloop.ml
===================================================================
--- sks/branches/upstream/sks/current/eventloop.ml (rev 0)
+++ sks/branches/upstream/sks/current/eventloop.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,253 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Basic eventloop for picking up timer and socket events *)
+open StdLabels
+open MoreLabels
+open Printf
+open Common
+open Packet
+module Unix = UnixLabels
+open Unix
+
+
+(** Timeout code.
+ Allows the addition of generic timeouts for actions *)
+
+exception SigAlarm
+let waiting_for_alarm = ref false
+let sigalarm_handler _ =
+ if !waiting_for_alarm
+ then raise SigAlarm
+ else ()
+
+let _ =
+ Sys.set_signal Sys.sigalrm (Sys.Signal_handle sigalarm_handler)
+
+type timed_event =
+ Event of float * callback
+and timed_callback = { callback: unit -> timed_event list;
+ timeout: int;
+ name: string option;
+ }
+and callback = | Callback of (unit -> timed_event list)
+ | TimedCallback of timed_callback
+
+
+type timed_handler =
+ { h_callback: sockaddr -> in_channel -> out_channel -> timed_event list;
+ h_timeout: int;
+ h_name: string option;
+ }
+type handler =
+ | Handler of (sockaddr -> in_channel -> out_channel -> timed_event list)
+ | TimedHandler of timed_handler
+
+
+let unwrap opt = match !opt with
+ None -> failwith "unwrap failure"
+ | Some x -> x
+
+let make_tc ~name ~timeout ~cb =
+ TimedCallback { callback = cb;
+ name = Some name;
+ timeout = timeout;
+ }
+
+let make_th ~name ~timeout ~cb =
+ TimedHandler { h_callback = cb;
+ h_name = Some name;
+ h_timeout = timeout;
+ }
+
+(** reraises an exception if it is a user-initiated break or a SigAlarm *)
+let reraise e = match e with
+ Sys.Break | SigAlarm -> raise e
+ | _ -> ()
+
+(*************************************************************)
+
+(** executes function with timeout enforced using Unix.alarm *)
+let do_with_timeout f timeout =
+ ignore (Unix.alarm timeout);
+ waiting_for_alarm := true;
+ protect ~f
+ ~finally:(fun () ->
+ waiting_for_alarm := false;
+ ignore (Unix.alarm 0);)
+
+
+let cbname cb = match cb.name with
+ None -> ""
+ | Some s -> sprintf "<%s> " s
+
+
+(** Does timed callback, including possible recovery action,
+ with timeouts enforced by Unix.alarm *)
+let do_timed_callback cb =
+ try
+ do_with_timeout cb.callback cb.timeout
+ with
+ | Sys.Break as e ->
+ perror "%scallback interrupted by break." (cbname cb);
+ raise e
+ | SigAlarm ->
+ perror "%scallback timed out." (cbname cb);
+ []
+ | e ->
+ eplerror 2 e "%serror in callback." (cbname cb);
+ []
+
+let do_callback cb = match cb with
+ | TimedCallback cb -> do_timed_callback cb
+ | Callback cb -> cb ()
+
+
+(** Socket handling functions *)
+
+let create_sock addr =
+ try
+ let domain =
+ Unix.domain_of_sockaddr addr in
+ let sock =
+ socket ~domain ~kind:SOCK_STREAM ~protocol:0 in
+ setsockopt sock SO_REUSEADDR true;
+ bind sock ~addr;
+ listen sock ~max:20;
+ sock
+ with
+ | Unix_error (_,"bind",_) ->
+ failwith "Failure while binding socket. Probably another socket bound to this address"
+ | e -> raise e
+let add_events heap evlist =
+ List.iter ~f:(fun (Event (time, callback)) ->
+ Heap.push heap ~key:time ~data:callback)
+ evlist
+
+(***************************************************************)
+(* Event Handlers *******************************************)
+(***************************************************************)
+
+let handle_socket handler sock =
+ let (s,caller) = accept sock in
+ let inchan = in_channel_of_descr s in
+ let outchan = out_channel_of_descr s in
+ protect ~f:(fun () -> handler caller inchan outchan)
+ ~finally:(fun () -> Unix.close s)
+
+
+let handler_to_callback handler sock =
+ match handler with
+ Handler handler ->
+ Callback (fun () ->
+ let (s,caller) = accept sock in
+ let inchan = in_channel_of_descr s in
+ let outchan = out_channel_of_descr s in
+ protect ~f:(fun () -> handler caller inchan outchan)
+ ~finally:(fun () -> Unix.close s)
+ )
+ | TimedHandler handler ->
+ TimedCallback
+ { callback =
+ (fun () ->
+ let (s,caller) = accept sock in
+ let inchan = in_channel_of_descr s
+ and outchan = out_channel_of_descr s in
+ protect ~f:(fun () -> handler.h_callback
+ caller inchan outchan)
+ ~finally:(fun () -> Unix.close s)
+ );
+ timeout = handler.h_timeout;
+ name = handler.h_name;
+ }
+
+(***************************************************************)
+(* Event Loop ***********************************************)
+(***************************************************************)
+
+let some opt = match opt with
+ None -> false
+ | Some x -> true
+
+(***************************************************************)
+
+(** Does all events occuring at or before time [now], updating heap
+ appropriately. Returns the time left until the next undone event
+ on the heap
+*)
+let rec do_current_events heap now =
+ match (try Some (Heap.top heap)
+ with Not_found -> None)
+ with
+ | Some (time,callback) ->
+ let timeout = time -. now in
+ if timeout <= 0.0 then (
+ ignore (Heap.pop heap);
+ add_events heap (do_callback callback);
+ do_current_events heap now;
+ ) else timeout
+ | None -> -1.0
+
+(** function for adding to heap callbacks for handling
+ incoming socket connections *)
+let add_socket_handlers heap now fdlist sockets =
+ List.iter sockets
+ ~f:(fun sock ->
+ try
+ let handler = List.assoc sock fdlist in
+ add_events heap
+ [ Event (now, handler_to_callback handler sock) ]
+ with
+ Not_found ->
+ plerror 0 "%s" ("BUG: eventloop -- socket without " ^
+ "handler. Event dropped")
+ )
+(** Do all available events in FIFO order *)
+let do_next_event heap fdlist =
+ let now = gettimeofday () in
+ let timeout = do_current_events heap now in
+ let (fds,_) = List.split fdlist in
+ let (rd,_,_) = select ~read:fds ~write:[] ~except:[] ~timeout in
+ add_socket_handlers heap now fdlist rd
+
+(***************************************************************)
+(***************************************************************)
+
+let heap = Heap.empty (<) 20
+
+let evloop events socklist =
+ add_events heap events;
+ try
+ while true do
+ try
+ do_next_event heap socklist
+ with
+ | Sys.Break ->
+ eprintf "Ctrl-C. Exiting eventloop\n";
+ flush Pervasives.stderr;
+ raise Exit
+ | Unix_error (error,func_name,param) ->
+ if error <> Unix.EINTR
+ (* EINTR just means the alarm interrupted select *)
+ then
+ plerror 2 "%s" ("eventloop: Unix Error: " ^
+ (Unix.error_message error) ^ ", " ^
+ func_name ^ ", " ^ param ^ "\n")
+ | e -> eplerror 2 e "eventloop"
+ done
+ with
+ Exit -> ()
Added: sks/branches/upstream/sks/current/fastbuild.ml
===================================================================
--- sks/branches/upstream/sks/current/fastbuild.ml (rev 0)
+++ sks/branches/upstream/sks/current/fastbuild.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,194 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Executable: Builds up the key database from a multi-file database dump.
+ This version works faster by virtue of not actually copying the keys out of
+ the datbaase dump, and only storing the locations of those keys.
+*)
+module F(M:sig end) =
+struct
+ open StdLabels
+ open MoreLabels
+ open Printf
+ open Arg
+ open Common
+ module Set = PSet.Set
+ module Unix = UnixLabels
+ open Packet
+
+ let settings = {
+ Keydb.withtxn = false;
+ Keydb.cache_bytes = !Settings.cache_bytes;
+ Keydb.pagesize = !Settings.pagesize;
+ Keydb.dbdir = Lazy.force Settings.dbdir;
+ Keydb.dumpdir = Lazy.force Settings.dumpdir;
+ }
+
+ module Keydb = Keydb.Unsafe
+
+ let n = match !Settings.n with 0 -> 1 | x -> x
+ let maxkeys = n * 15000
+ let dumpdir = Lazy.force Settings.dumpdir
+
+ let lsdir dir =
+ let dirhandle = Unix.opendir dir in
+ let rec loop accum = match (try Some (Unix.readdir dirhandle)
+ with End_of_file -> None)
+ with
+ Some fname -> loop (fname::accum)
+ | None -> accum
+ in
+ loop []
+
+ let rec list_mapi list ~f =
+ let rec loop list i ~f =
+ match list with
+ [] -> []
+ | x::tl -> (f i x)::(loop tl (i + 1) ~f)
+ in
+ loop list 0 ~f
+
+ let timestr sec =
+ sprintf "%.2f min" (sec /. 60.)
+
+ (******************************************************)
+
+ type 'a badoption = Bad | Good of 'a | Done
+
+ (** get single md using nextkey function *)
+ let get_keymd fnum nextkey =
+ match (try nextkey ()
+ with e ->
+ perror "error parsing key in file %d: %s. Skipping rest of file"
+ fnum (Printexc.to_string e);
+ None
+ )
+ with
+ | Some (pos,key) ->
+ begin
+ try
+ let ckey = Fixkey.canonicalize key in
+
+ if ckey = key then
+ (* no need to canonicalize key *)
+
+ let offset = { Keydb.fnum = fnum;
+ Keydb.pos = pos;
+ }
+ in
+ Good (Keydb.key_to_metadata_large_offset offset key)
+ else
+ (* must use canonicalized version of key *)
+ Good (Keydb.key_to_metadata ckey)
+ with
+ Fixkey.Bad_key -> Bad
+ end
+ | None ->
+ Done
+
+ let rec get_keymds_rec ~max fnum nextkey accum =
+ if max = 0
+ then (accum,0)
+ else
+ match get_keymd fnum nextkey with
+ | Done -> (accum,max)
+ | Bad -> get_keymds_rec ~max fnum nextkey accum
+ | Good md ->
+ get_keymds_rec ~max:(max-1) fnum nextkey
+ (md::accum)
+
+
+ (** Fetches a collection of no more than max keys. Returns (keys,bool), with
+ the second argument being true of there is more to read from the given
+ file. *)
+ let rec get_keymds ~max fnum nextkey =
+ get_keymds_rec ~max fnum nextkey []
+
+
+ let inchan_to_nextkey inchan =
+ let cin = new Channel.sys_in_channel inchan in
+ Key.pos_next_of_channel cin
+
+ let rec get_keymds_list ~max nflist partial =
+ match nflist with
+ [] -> (partial,[])
+ | (fnum,nextkey)::tl ->
+ if max = 0 then (partial,nflist)
+ else
+ let (mds,remaining) = get_keymds ~max fnum nextkey in
+ flush stdout;
+ if remaining > 0 then (
+ (* file must be done with, so don't pass it on *)
+ get_keymds_list ~max:remaining tl (List.rev_append mds partial)
+ ) else (
+ (* file is not (necessarily) done,
+ but we've got the key mds we need *)
+ (List.rev_append mds partial,nflist)
+ )
+
+ let get_keymds_list ~max nflist = get_keymds_list ~max nflist []
+
+ let dbtimer = MTimer.create ()
+ let timer = MTimer.create ()
+ let run () =
+ set_logfile "fastbuild";
+
+ if Sys.file_exists (Lazy.force Settings.dbdir) then (
+ perror "KeyDB directory already exists. Exiting.";
+ eprintf "KeyDB directory already exists. Exiting.\n";
+ exit (-1)
+ );
+ Unix.mkdir (Lazy.force Settings.dbdir) 0o700;
+
+ Keydb.open_dbs settings;
+ Keydb.set_meta ~key:"filters" ~data:"yminsky.dedup";
+
+ let filearray = Keydb.get_dump_filearray () in
+ let nfarray = Array.mapi ~f:(fun i x -> (i,inchan_to_nextkey x))
+ filearray in
+ let nflist = Array.to_list nfarray in
+
+ perror "Loading %d keys at a time" maxkeys;
+
+ protect
+ ~f:(fun () ->
+ let rec loop nflist = match nflist with
+ [] -> ()
+ | nflist ->
+ MTimer.start timer;
+
+ perror "Loading metadata..."; flush stdout;
+ let (mds,nflist) = get_keymds_list ~max:maxkeys nflist in
+ perror " %d keys loaded, %d files left"
+ (List.length mds) (List.length nflist);
+ MTimer.start dbtimer;
+ Keydb.add_mds mds;
+ MTimer.stop dbtimer;
+
+ MTimer.stop timer;
+ perror " DB time: %s. Total time: %s."
+ (timestr (MTimer.read dbtimer))
+ (timestr (MTimer.read timer));
+ flush stdout;
+ loop nflist
+
+ in
+ loop nflist
+ )
+ ~finally:(fun () -> Keydb.close_dbs ())
+
+end
Added: sks/branches/upstream/sks/current/fingerprint.ml
===================================================================
--- sks/branches/upstream/sks/current/fingerprint.ml (rev 0)
+++ sks/branches/upstream/sks/current/fingerprint.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,208 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Computes PGP fingerprints and keyids *)
+open Printf
+open StdLabels
+open MoreLabels
+open Common
+
+open Packet
+module Set = PSet.Set
+
+(* Compute PGP Key Fingerprint and PGP KeyIDs *)
+
+(* v3 and v4 fingerprints and keyids are quite different.
+
+ v3 fingerprint: MD5 sum of concatenation of bodies of MPI's
+ for modulus and exponent of RSA key
+
+ v3 keyid: low 64 bits of public modulus of RSA key
+
+ v4 fingerprint: 160-bit SHA-1 hash of:
+ Packet Tag (1 octet)
+ packet length (2 octets)
+ entire public key packet (starting with version field)
+
+ v4 KeyID: first 64 bits of fingerprint
+*)
+
+
+type result = { fp : string;
+ keyid : string;
+ }
+
+let from_packet packet =
+ let cin = new Channel.string_in_channel packet.packet_body 0 in
+ let version = cin#read_byte in
+ match version with
+ 2 | 3 ->
+ let hash = Cryptokit.Hash.md5 () in
+ (* print_string "v3 pubkey\n"; *)
+ cin#skip 7;
+ (* skip creation time (4 octets), days of validity (2 octets)
+ and algorithm type (1 octet) *)
+ let n = ParsePGP.read_mpi cin in (* modulus *)
+ let e = ParsePGP.read_mpi cin in (* exponent *)
+ hash#add_substring n.mpi_data 0 ((n.mpi_bits + 7)/8);
+ hash#add_substring e.mpi_data 0 ((e.mpi_bits + 7)/8);
+ let fingerprint = hash#result
+ and keyid =
+ let len = String.length n.mpi_data in
+ String.sub n.mpi_data ~pos:(len - 8) ~len:8
+ in
+ hash#wipe;
+ { fp = fingerprint;
+ keyid = keyid;
+ }
+
+ | 4 ->
+ let hash = Cryptokit.Hash.sha1 () in
+ hash#add_byte 0x99;
+ (* This seems wrong. The spec suggests that packet.packet_tag
+ is what should be used here. But this is what's done in the GPG
+ codebase, so I'm copying it. *)
+ hash#add_byte ((packet.packet_length lsr 8) land 0xFF);
+ hash#add_byte (packet.packet_length land 0xFF);
+ hash#add_string packet.packet_body;
+ let fingerprint = hash#result in
+ let keyid =
+ let len = String.length fingerprint in
+ String.sub fingerprint ~pos:(len - 8) ~len:8
+ in
+ hash#wipe;
+ { fp = fingerprint;
+ keyid = keyid;
+ }
+
+ | _ ->
+ failwith "Fingerprint.from_packet: Unexpected version number"
+
+let rec from_key key = match key with
+ packet::key_tail ->
+ if packet.packet_type = Public_Key_Packet
+ then from_packet packet
+ else from_key key_tail
+ | [] ->
+ raise Not_found
+
+let fp_to_string fp =
+ let bs = if (String.length fp) = 20 then 4 else 2 in
+ (* standard practice is to bunch long fingerprints by 4 and short ones by
+ 2. An extra space is added in the middle *)
+ let hex = Utils.hexstring fp in
+ let buf = Buffer.create 0 in
+ let extraspace_pos = if (String.length fp) = 20 then 4 else 7 in
+ for i = 0 to String.length hex / bs - 1 do
+ Buffer.add_substring buf hex (i * bs) bs;
+ Buffer.add_string buf " ";
+ if i = extraspace_pos then Buffer.add_string buf " "
+ done;
+ Buffer.contents buf
+
+let keyid_to_string ?(short=true) keyid =
+ let hex = Utils.hexstring keyid in
+ if short
+ then String.sub ~pos:(String.length hex - 8) ~len:8 hex
+ else hex
+
+let max32 = Int64.shift_left Int64.one 32
+let is_32bit int64 =
+ int64 < max32
+
+let keyid32_of_string s =
+ let s =
+ if not (s.[0] = '0' && s.[1] = 'x')
+ then "0x" ^ s else s
+ in
+ let x = Int64.of_string s in
+ let x = Int64.to_int32 x in
+ let cout = Channel.new_buffer_outc 4 in
+ cout#write_int32 x;
+ cout#contents
+
+let keyid_of_string s =
+ let x = Int64.of_string s in
+ if is_32bit x then (
+ let x = Int64.to_int32 x in
+ let cout = Channel.new_buffer_outc 4 in
+ cout#write_int32 x;
+ cout#contents
+ ) else (
+ let cout = Channel.new_buffer_outc 8 in
+ cout#write_int64 x;
+ cout#contents
+ )
+
+let shorten ~short keyid =
+ if short then String.sub ~pos:4 ~len:4 keyid else keyid
+
+let fp_from_key key = (from_key key).fp
+let keyid_from_key ?(short=true) key =
+ let keyid = (from_key key).keyid in
+ shorten ~short keyid
+
+(** Returns a pair of the [result]s describing the fingerprint of the public key
+ paired with the list of results describing the fingerprints of the subkeys.
+ Raises `Not_found` if the information in question can't be found *)
+let key_and_subkey_results key =
+ match key with
+ | [] -> raise Not_found
+ | ({ packet_type = Public_Key_Packet} as lead_packet)::tl ->
+ let rec loop packets = match packets with
+ | [] -> []
+ | ({ packet_type = Public_Subkey_Packet} as pack)::tl ->
+ from_packet pack :: loop tl
+ | pack :: tl -> loop tl
+ in
+ (from_packet lead_packet, loop tl)
+ | _ -> raise Not_found
+;;
+
+(** [key_and_subkey_ids key ~get] Returns the result of applying [get] to the
+ [result] of the lead key, paired with the unique results of applying get to
+ the [result] of the subkeys. The ids of the subkey won't include the ids of
+ the lead key.
+*)
+let key_and_subkey_ids key ~get =
+ let (key_result,subkey_results) = key_and_subkey_results key in
+ let key_id = get key_result in
+ let subkey_ids =
+ List.map ~f:get subkey_results
+ |! Set.of_list |! Set.remove key_id |! Set.elements
+ in
+ (key_id,subkey_ids)
+;;
+
+(** returns main keyid and list of subkey keyids. The keyid is guaranteed not
+ to appear among the subkey keyids, and there are no duplicates among the
+ subkey keyids.
+*)
+let keyids_from_key ?(short=true) key =
+ key_and_subkey_ids key ~get:(fun r -> shorten ~short r.keyid)
+;;
+
+(** returns main key fingerprint and list of subkey fingerprints. The
+ fingerprint is guaranteed not to appear among the subkey fingerprints, and
+ there are no duplicates among the subkey fingerprints. This list is made to
+ facilitate searching by long keyid (16 digit) or fingerprint. This was in
+ response to a 28-Dec-Patch to all trees of GnuPG allowing key lookup by
+ short keyID (8 digit), long KeyID, or fingerprint
+*)
+let fps_from_key key =
+ key_and_subkey_ids key ~get:(fun r -> r.fp)
+;;
Added: sks/branches/upstream/sks/current/fixkey.ml
===================================================================
--- sks/branches/upstream/sks/current/fixkey.ml (rev 0)
+++ sks/branches/upstream/sks/current/fixkey.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,146 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+open Common
+open Packet
+
+exception Bad_key
+
+
+(** list of filters currently applied on incoming keys. Filter types are
+ included in comma-separated list, and should not include commas or
+ whitespace
+
+ meaning of filter types:
+
+ - yminsky.merge:
+ Merges all keys in database that can be merged.
+ - yminsky.dedup:
+ Parses all keys and removes duplicates. Unparseable keys
+ are removed from the database.
+*)
+let filters = [ "yminsky.dedup"; "yminsky.merge" ]
+
+(**********************************************************************)
+(*** Key Merging ****************************************************)
+(**********************************************************************)
+
+let get_keypacket pkey = pkey.KeyMerge.key
+
+let ( |= ) map key = Map.find key map
+let ( |< ) map (key,data) = Map.add ~key ~data map
+
+let rec join_by_keypacket map keylist = match keylist with
+ | [] -> map
+ | key::tl ->
+ let keypacket = get_keypacket key in
+ let map =
+ try
+ let keylist_ref = map |= keypacket in
+ keylist_ref := key::!keylist_ref;
+ map
+ with
+ Not_found ->
+ map |< (keypacket,ref [key])
+ in
+ join_by_keypacket map tl
+
+(** Given a list of parsed keys, returns a list of parsed key lists,
+ grouped by keypacket *)
+let join_by_keypacket keys =
+ Map.fold ~f:(fun ~key ~data list -> !data::list) ~init:[]
+ (join_by_keypacket Map.empty keys)
+
+
+(** merges a list of pkeys, throwing a failure if the merge cannot procede *)
+let merge_pkeys pkeys = match pkeys with
+ | [] -> failwith "Attempt to merge empty list of keys"
+ | hd::tl ->
+ List.fold_left ~init:hd tl
+ ~f:(fun key1 key2 ->
+ match KeyMerge.merge_pkeys key1 key2 with
+ None -> failwith "PKey merge failed"
+ | Some key -> key
+ )
+
+(** Accepts collection of keys, which should comprise all keys in the
+ database with the same keyid. Returns list of pairs, first part of pair
+ being a list of keys to delete, last part being a list of keys to add
+*)
+let compute_merge_replacements keys =
+ let pkeys = List.map ~f:KeyMerge.key_to_pkey keys in
+ (* put parsed keys into list of lists, grouped by key packet *)
+ let kp_list = join_by_keypacket pkeys in
+ let replacements =
+ List.fold_left ~init:[] kp_list
+ ~f:(fun list pkeys ->
+ if List.length pkeys > 1 then
+ (Some (List.map ~f:KeyMerge.flatten pkeys,
+ KeyMerge.flatten (merge_pkeys pkeys)))::list
+ else
+ None::list
+ )
+ in
+ strip_opt replacements
+
+
+(**********************************************************************)
+(*** Key Canonicalization *******************************************)
+(**********************************************************************)
+
+(** Returns canonicalized version of key. Raises Bad_key if key should simply
+ be discarded
+*)
+let canonicalize key =
+ try KeyMerge.dedup_key key
+ with KeyMerge.Unparseable_packet_sequence -> raise Bad_key
+
+
+open KeyMerge
+
+let good_key pack =
+ try ignore (ParsePGP.parse_pubkey_info pack); true
+ with e -> false
+
+let good_signature pack =
+ try ignore (ParsePGP.parse_signature pack); true
+ with e -> false
+
+let drop_bad_sigs packlist =
+ List.filter ~f:good_signature packlist
+
+let sig_filter_sigpair (pack,sigs) =
+ let sigs = List.filter ~f:good_signature sigs in
+ if sigs = [] then None
+ else Some (pack,sigs)
+
+let presentation_filter key =
+ let pkey = key_to_pkey key in
+ if not (good_key pkey.key)
+ then None
+ else
+ let selfsigs = drop_bad_sigs pkey.selfsigs in
+ let subkeys = Utils.filter_map ~f:sig_filter_sigpair pkey.subkeys in
+ let uids = Utils.filter_map ~f:sig_filter_sigpair pkey.uids in
+ let subkeys = List.filter ~f:(fun (key,_) -> good_key key) subkeys in
+ Some (flatten { pkey with
+ selfsigs = selfsigs;
+ uids = uids;
+ subkeys = subkeys;
+ })
Added: sks/branches/upstream/sks/current/foo.ml
===================================================================
--- sks/branches/upstream/sks/current/foo.ml (rev 0)
+++ sks/branches/upstream/sks/current/foo.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,39 @@
+open StdLabels
+open Printf
+open ZZp
+open Number.Infix
+
+
+let rec gcd_ex' a b =
+ if b =! zero then (one,zero,a)
+ else
+ let (q,r) = quomod_big_int a b in
+ let (u',v',gcd) = gcd_ex' b r in
+ (v',u' -! v' *! q, gcd)
+
+let gcd_ex a b =
+ if b <=! a then gcd_ex' a b
+ else
+ let (u,v,gcd) = gcd_ex' b a in
+ (v,u,gcd)
+
+let gcd_ex_test a b =
+ let (a,b) = (big_int_of_int a,big_int_of_int b) in
+ let (u,v,gcd) = gcd_ex a b in
+ if (u *! a +! v *! b <>! gcd)
+ then failwith (sprintf "gcd_ex failed on %s and %s"
+ (string_of_big_int a) (string_of_big_int b))
+
+
+let run_test () =
+ begin
+ gcd_ex_test 95 25;
+ gcd_ex_test 25 95;
+ gcd_ex_test 1 95;
+ gcd_ex_test 95 1;
+ gcd_ex_test 22 21;
+ gcd_ex_test 21 22;
+ gcd_ex_test 12 6;
+ gcd_ex_test 6 12;
+ gcd_ex_test 6 12;
+ end
Added: sks/branches/upstream/sks/current/fqueue.ml
===================================================================
--- sks/branches/upstream/sks/current/fqueue.ml (rev 0)
+++ sks/branches/upstream/sks/current/fqueue.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,120 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Simple implementation of a polymorphic functional queue *)
+open StdLabels
+open MoreLabels
+module Unix=UnixLabels
+
+
+(** push and top are O(1).
+ pop and take are O(1) amortized.
+ to_list and length are O(n).
+*)
+
+(* Invariant:
+ if queue is not empty, outlist is not empty
+ queue.length = List.length(queue.outlist) + List.length(queue.inlist)*)
+
+exception Empty
+
+type 'a t = { inlist: 'a list;
+ outlist: 'a list;
+ length: int;
+ }
+
+(*****************************************)
+
+(*
+let test_invariants queue =
+ assert
+ begin
+ queue.length = (List.length queue.outlist) + (List.length queue.inlist)
+ end;
+ assert
+ begin
+ (queue.length = 0) || List.length queue.outlist > 0
+ end
+*)
+
+let empty = { inlist = [];
+ outlist = [];
+ length = 0;
+ }
+
+(*****************************************)
+
+let push el queue =
+ if queue.outlist = [] then
+ let outlist = List.rev (el::queue.inlist)
+ in { inlist = [];
+ outlist = outlist;
+ length = queue.length + 1;
+ }
+ else
+ { inlist = el::queue.inlist;
+ outlist = queue.outlist;
+ length = queue.length + 1;
+ }
+
+let enq = push
+(*****************************************)
+
+let top queue =
+ match queue.outlist with
+ [] -> (if queue.inlist != []
+ then failwith "FQueue.top: BUG. inlist should be empty but isn't"
+ else raise Empty)
+ | hd::tl -> hd
+
+(*****************************************)
+
+let pop queue = match queue.outlist with
+ hd::[] -> (hd, { inlist = [];
+ outlist = (List.rev queue.inlist);
+ length = queue.length - 1})
+ | hd::tl -> (hd, { inlist = queue.inlist;
+ outlist = tl;
+ length = queue.length - 1;})
+ | [] ->
+ if queue.inlist = []
+ then raise Empty
+ else (match List.rev queue.inlist with
+ [] -> failwith "FQueue.top: BUG. inlist should not be empty here"
+ | hd::tl -> (hd, { inlist=[];
+ outlist=tl;
+ length = queue.length - 1;
+ }))
+
+(*****************************************)
+
+let discard queue =
+ let (el,new_q) = pop queue in
+ new_q
+
+let deq = pop
+
+(*****************************************)
+
+let to_list queue =
+ queue.inlist @ (List.rev (queue.outlist))
+
+(*****************************************)
+
+let length queue = queue.length
+
+let is_empty queue = queue.length = 0
Added: sks/branches/upstream/sks/current/getfileopts.ml
===================================================================
--- sks/branches/upstream/sks/current/getfileopts.ml (rev 0)
+++ sks/branches/upstream/sks/current/getfileopts.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,149 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Loads settings from settings file. *)
+open StdLabels
+open MoreLabels
+open Printf
+open Settings
+open Pstyle
+
+let protect ~f ~(finally: unit -> unit) =
+ let result = ref None in
+ try
+ result := Some (f ());
+ raise Exit
+ with
+ Exit as e ->
+ finally ();
+ (match !result with Some x -> x | None -> raise e)
+ | e ->
+ finally (); raise e
+
+let whitespace c = c = '\t' || c = ' ' || c = '\n'
+
+let strip s =
+ let lower = ref 0 in
+ while !lower < String.length s && whitespace s.[!lower] do
+ incr lower
+ done;
+
+ let upper = ref (String.length s - 1) in
+ while !upper >= 0 && whitespace s.[!upper] do
+ decr upper
+ done;
+
+ if !upper < !lower then ""
+ else
+ String.sub s ~pos:!lower ~len:(!upper - !lower + 1)
+
+let csplit c s =
+ let i = String.index s c in
+ (strip (String.sub ~pos:0 ~len:i s),
+ strip (String.sub ~pos:(i+1) ~len:(String.length s - i - 1) s)
+ )
+
+let decomment l =
+ let l =
+ try
+ let pos = String.index l '#' in
+ String.sub l ~pos:0 ~len:pos
+ with
+ Not_found -> l
+ in
+ strip l
+
+(** convert a line of the config line to command-line format *)
+let line_convert l =
+ let l = decomment l in
+ if String.length l = 0 then None
+ else
+ let (command,arg) = csplit ':' l in
+ Some [ "-" ^ command ; arg ]
+
+(** read in file and convert it to command-line format *)
+let file_convert f =
+ let rec loop accum =
+ match (try Some (input_line f) with End_of_file -> None)
+ with
+ | Some l -> (
+ match line_convert l with
+ None -> loop accum
+ | Some l -> loop (l :: accum)
+ )
+ | None -> "" :: List.concat (List.rev accum)
+ in
+ Array.of_list (loop [])
+
+let fname_convert fname =
+ if Sys.file_exists fname then
+ try
+ let f = open_in fname in
+ protect ~f:(fun () -> file_convert f)
+ ~finally:(fun () -> close_in f)
+ with
+ Sys_error _ as e -> failwith
+ (sprintf "Sys error while parsing config file: %s"
+ (Printexc.to_string e) )
+ else
+ [||]
+
+(**************************************************************)
+(**************************************************************)
+(**************************************************************)
+
+let config_fname = "sksconf"
+
+let parse args =
+ Arg.current := 0;
+ Arg.parse_argv args parse_spec anon_options usage_string
+
+let () =
+
+ try
+ let pos = ref 0 in
+ while !pos < Array.length Sys.argv && Sys.argv.(!pos) <>
+ "-read_config_file"
+ do incr pos done;
+
+ if !pos = Array.length Sys.argv
+ then (
+ parse Sys.argv;
+ let from_file_commandline =
+ fname_convert (Filename.concat !basedir config_fname)
+ in
+ parse from_file_commandline
+ )
+ else (
+ parse (Sys.argv <|> (0,!pos));
+ let from_file_commandline =
+ fname_convert (Filename.concat !basedir config_fname)
+ in
+ parse from_file_commandline;
+ parse (Array.append [|""|] (Sys.argv <|> (!pos + 1,0)))
+ );
+
+ anonlist := List.rev !anonlist;
+ anonlist := List.filter ~f:(( <> ) "") !anonlist
+ with
+ | Arg.Bad s ->
+ print_string s;
+ exit (-1)
+ | Arg.Help s ->
+ print_string s;
+ exit 0
+
Added: sks/branches/upstream/sks/current/heap.ml
===================================================================
--- sks/branches/upstream/sks/current/heap.ml (rev 0)
+++ sks/branches/upstream/sks/current/heap.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,150 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Simple heap implementation, adapted from CLR *)
+open StdLabels
+open MoreLabels
+
+(* Adapted from CLR *)
+
+type ('key,'data) heap_el = { key: 'key;
+ data: 'data;
+ }
+
+type ('key,'data) heap = { mutable a: ('key,'data) heap_el option array;
+ mutable length: int;
+ minsize: int;
+ cmp: 'key -> 'key -> bool;
+ }
+
+let length heap = heap.length
+let true_length heap = Array.length heap.a
+
+(***************************************************************)
+
+let parent i = (i-1)/2
+let left i = 2 * i + 1
+let right i = 2 * i + 2
+let get heap i = match heap.a.(i) with
+ None -> raise (Failure "Heap.get: Attempt to examine None")
+ | Some el -> el
+
+let exchange heap i j =
+ let temp = heap.a.(i) in
+ heap.a.(i) <- heap.a.(j);
+ heap.a.(j) <- temp
+
+(***************************************************************)
+
+let resize heap =
+ if heap.length > Array.length heap.a
+ then heap.a <-
+ Array.init ((Array.length heap.a) * 2)
+ ~f:(fun i ->
+ if i < (Array.length heap.a)
+ then heap.a.(i)
+ else None)
+
+ else
+ if heap.length <= (Array.length heap.a)/3
+ && (Array.length heap.a)/2 >= heap.minsize
+ then heap.a <-
+ Array.init ((Array.length heap.a)/ 2) ~f:(fun i -> heap.a.(i))
+
+
+(***************************************************************)
+
+let rec heapify heap i =
+ let left = left i in
+ let right = right i in
+ let largest =
+ if left < heap.length &&
+ heap.cmp (get heap left).key (get heap i).key
+ then left else i in
+ let largest =
+ if right < heap.length &&
+ heap.cmp (get heap right).key (get heap largest).key
+ then right
+ else largest
+ in
+ if i <> largest then
+ begin
+ exchange heap i largest;
+ heapify heap largest
+ end
+
+(***************************************************************)
+
+let build_heap_from_array cmp array length =
+ let heap = { a = array;
+ length = length;
+ minsize = length;
+ cmp = cmp
+ }
+ in
+ let rec loop i =
+ heapify heap i;
+ loop (i-1)
+ in
+ loop (parent length)
+
+(***************************************************************)
+
+let top heap = match heap.length with
+ 0 -> raise Not_found
+ | _ -> let max = get heap 0 in
+ (max.key, max.data)
+
+
+(***************************************************************)
+
+let rec pop heap = match heap.length with
+ 0 -> raise Not_found;
+ | _ -> let max = (get heap 0) in
+ heap.a.(0) <- heap.a.(heap.length - 1);
+ heap.length <- (heap.length - 1);
+ heapify heap 0;
+ resize heap;
+ (max.key, max.data)
+
+
+(***************************************************************)
+
+let push heap ~key ~data =
+ heap.length <- (heap.length + 1);
+ resize heap;
+ let rec loop i =
+ if i > 0 && heap.cmp key (get heap (parent i)).key then
+ begin
+ heap.a.(i) <- heap.a.(parent i);
+ loop (parent i)
+ end
+ else i
+ in
+ let i = loop (heap.length - 1) in
+ heap.a.(i) <- Some { key = key; data = data; }
+
+
+(***************************************************************)
+
+let empty cmp i =
+ { a = Array.create i None;
+ length = 0;
+ minsize = i;
+ cmp = cmp;
+ }
+
Added: sks/branches/upstream/sks/current/heap.mli
===================================================================
--- sks/branches/upstream/sks/current/heap.mli (rev 0)
+++ sks/branches/upstream/sks/current/heap.mli 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,23 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+type ('key,'data) heap
+val length : ('key,'data) heap -> int
+val top : ('key,'data) heap -> 'key * 'data
+val pop : ('key,'data) heap -> 'key * 'data
+val push : ('key,'data) heap -> key:'key -> data:'data -> unit
+val empty : ('key -> 'key -> bool) -> int -> ('key,'data) heap
Added: sks/branches/upstream/sks/current/htmlTemplates.ml
===================================================================
--- sks/branches/upstream/sks/current/htmlTemplates.ml (rev 0)
+++ sks/branches/upstream/sks/current/htmlTemplates.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,84 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open Printf
+open StdLabels
+open MoreLabels
+module Unix = UnixLabels
+open Unix
+
+open Packet
+
+let html_quote string =
+ let sin = new Channel.string_in_channel string 0 in
+ let sout = Channel.new_buffer_outc (String.length string + 10) in
+ try
+ while true do
+ match sin#read_char with
+ | '<' -> sout#write_string "<"
+ | '>' -> sout#write_string ">"
+ | '&' -> sout#write_string "&"
+ | '"' -> sout#write_string """
+ | c -> sout#write_char c
+ done;
+ ""
+ with
+ End_of_file ->
+ sout#contents
+
+let br_regexp = Str.regexp_case_fold "<br />"
+let page ~title ~body =
+ sprintf
+ "<?xml version=\"1.0\" encoding=\"utf-8\"?>\r\n<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\" >\r\n<html xmlns=\"http://www.w3.org/1999/xhtml\">\r\n<head>\r\n<title>%s</title>\r\n<meta http-equiv=\"Content-Type\" content=\"text/html;charset=utf-8\" />\r\n<style type=\"text/css\">\r\n/*<![CDATA[*/\r\n .uid { color: green; text-decoration: underline; }\r\n .warn { color: red; font-weight: bold; }\r\n/*]]>*/\r\n</style></head><body><h1>%s</h1>%s</body></html>"
+ (Str.global_replace br_regexp " | " title) title body
+
+let link ~op ~hash ~fingerprint ~keyid =
+ sprintf "/pks/lookup?op=%s%s%s&search=0x%s"
+ op
+ (if hash then "&hash=on" else "")
+ (if fingerprint then "&fingerprint=on" else "")
+ keyid
+
+let keyinfo_header = "Type bits/keyID Date User ID"
+
+let keyinfo_pks pki revoked ~keyid ~link ~userids =
+ let tm = gmtime (Int64.to_float pki.pk_ctime) in
+ let algo = pk_alg_to_ident pki.pk_alg in
+ let base =
+ sprintf "pub %4d%s/<a href=\"%s\">%8s</a> %4d-%02d-%02d%s "
+ pki.pk_keylen algo link keyid
+ (1900 + tm.tm_year)
+ (tm.tm_mon + 1)
+ tm.tm_mday
+ (if revoked then " *** KEY REVOKED *** [not verified]\r\n "
+ else "")
+ in
+ let uidstr = String.concat ~sep:"\r\n " userids in
+ base ^ uidstr
+
+let fingerprint ~fp =
+ sprintf "\t Fingerprint=%s" fp
+
+let hash_link ~hash =
+ sprintf "/pks/lookup?op=hget&search=%s" hash
+
+let hash ~hash =
+ sprintf "\t Hash=<a href=%s>%s</a>" (hash_link ~hash) hash
+
+let preformat_list elements =
+ sprintf "<pre>%s</pre>"
+ (String.concat ~sep:"\r\n" elements ^ "\r\n")
Added: sks/branches/upstream/sks/current/incdump.ml
===================================================================
--- sks/branches/upstream/sks/current/incdump.ml (rev 0)
+++ sks/branches/upstream/sks/current/incdump.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,88 @@
+(* This file is part of SKS. SKS 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 *)
+
+(* Copyright 2002, 2003, 2004 Yaron M. Minsky *)
+(* Copyright 2004 Peter Palfrader *)
+(***********************************************************************)
+
+(** creates keydump consisting of recently added keys *)
+
+open StdLabels
+open MoreLabels
+open Printf
+open Common
+open Packet
+module Set = PSet.Set
+
+let settings = {
+ Keydb.withtxn = !Settings.transactions;
+ Keydb.cache_bytes = !Settings.cache_bytes;
+ Keydb.pagesize = !Settings.pagesize;
+ Keydb.dbdir = Lazy.force Settings.dbdir;
+ Keydb.dumpdir = Lazy.force Settings.dumpdir;
+}
+
+module Keydb = Keydb.Unsafe
+
+let dump_database timestamp fname =
+ let maxsize = 250_000 in
+ let log = Keydb.reverse_logquery ~maxsize timestamp in
+ if List.length log = 0 then
+ printf "No changes since timestamp\n"
+ else
+ let file = open_out fname in
+ let run () =
+ let newkeys = List.fold_left log ~init:Set.empty
+ ~f:(fun set (_,change) -> match change with
+ Add hash -> Set.add hash set
+ | Delete hash -> Set.remove hash set)
+ in
+ printf "%d new keys in log.\n%!" (Set.cardinal newkeys);
+ Set.iter newkeys
+ ~f:(fun hash ->
+ try
+ let keystring = Keydb.get_keystring_by_hash hash in
+ output_string file keystring;
+ with
+ e ->
+ eprintf "Error fetching keystring from hash %s: %s\n%!"
+ (Utils.hexstring hash)
+ (Printexc.to_string e)
+ )
+ in
+ protect ~f:run ~finally:(fun () -> close_out file)
+
+let run () =
+ List.iter !Settings.anonlist
+ ~f:(fun x -> printf "\"%s\" " x);
+ printf "\n%!";
+ match !Settings.anonlist with
+ | timestamp::tl ->
+ let name = match tl with
+ | [] -> "incdump.pgp"
+ | [name] -> name
+ | _ -> raise (Argument_error "too many arguments")
+ in
+ printf "saving to file %s\n%!" name;
+ set_logfile "incdump";
+ Keydb.open_dbs settings;
+ protect ~f:(fun () ->
+ let timestamp = float_of_string timestamp in
+ dump_database timestamp name )
+ ~finally:(fun () -> Keydb.close_dbs ())
+
+ | _ ->
+ raise (Argument_error "no timestamp provided")
+
Added: sks/branches/upstream/sks/current/index.ml
===================================================================
--- sks/branches/upstream/sks/current/index.ml (rev 0)
+++ sks/branches/upstream/sks/current/index.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,636 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** code for generating pretty PGP key indices *)
+
+open StdLabels
+open MoreLabels
+open Printf
+open Common
+open Packet
+open Request
+open Pstyle
+
+module Map = PMap.Map
+
+(********************************************************************)
+
+type siginfo = { mutable userid: string option;
+ mutable policy_url: string option;
+ mutable notation_data: (string * string) option;
+ mutable revocation_key: string option;
+ mutable is_primary_uid: bool;
+ mutable keyid: string option;
+ mutable sigtype: int;
+ mutable sig_creation_time: int64 option;
+ mutable sig_expiration_time: int64 option;
+ mutable key_expiration_time: int64 option;
+ }
+
+(********************************************************************)
+
+let empty_siginfo () =
+ { userid = None;
+ policy_url = None;
+ notation_data = None;
+ revocation_key = None;
+ is_primary_uid = false;
+ keyid = None;
+ sigtype = 0;
+ sig_creation_time = None;
+ sig_expiration_time = None;
+ key_expiration_time = None;
+ }
+
+(********************************************************************)
+
+let keyinfo_header request =
+ if request.kind = VIndex then
+ "Type bits/keyID cr. time exp time key expir"
+ else
+ HtmlTemplates.keyinfo_header
+
+(********************************************************************)
+
+let sig_to_siginfo sign =
+ let siginfo = empty_siginfo () in
+ begin
+ match ParsePGP.parse_signature sign with
+ | V3sig s ->
+ siginfo.sigtype <- s.v3s_sigtype;
+ siginfo.keyid <- Some s.v3s_keyid;
+ siginfo.sig_creation_time <- Some s.v3s_ctime
+ | V4sig s ->
+ let update_siginfo ssp =
+ match ssp.ssp_type with
+
+ | 2 -> (* sign. expiration time *)
+ if ssp.ssp_length = 4 then
+ siginfo.sig_creation_time <-
+ Some (ParsePGP.int64_of_string ssp.ssp_body)
+
+ | 3 -> (* sign. expiration time *)
+ if ssp.ssp_length = 4 then
+ siginfo.sig_expiration_time <-
+ let exp = ParsePGP.int64_of_string ssp.ssp_body in
+ if Int64.compare exp Int64.zero = 0
+ then None else Some exp
+
+ | 9 -> (* key expiration time *)
+ if ssp.ssp_length = 4 then
+ siginfo.key_expiration_time <-
+ let exp = ParsePGP.int64_of_string ssp.ssp_body in
+ if Int64.compare exp Int64.zero = 0
+ then None else Some exp
+
+ | 12 -> (* revocation key *)
+ let cin = new Channel.string_in_channel ssp.ssp_body 0 in
+ let _revclass = cin#read_int_size 1 in
+ let _algid = cin#read_int_size 1 in
+ let fingerprint = cin#read_string 20 in
+ siginfo.revocation_key <- Some fingerprint
+
+ | 16 -> (* issuer keyid *)
+ if ssp.ssp_length = 8 then
+ siginfo.keyid <- Some ssp.ssp_body
+ else
+ printf "Argh! that makes no sense: %d\n" ssp.ssp_length
+
+ | 20 -> (* notation data *)
+ let cin = new Channel.string_in_channel ssp.ssp_body 0 in
+ let flags = cin#read_string 4 in
+ let name_len = cin#read_int_size 2 in
+ let value_len = cin#read_int_size 2 in
+ let name_data = cin#read_string name_len in
+ let value_data = cin#read_string value_len in
+
+ if Char.code flags.[0] = 0x80 then
+ (* human-readable notation data *)
+ siginfo.notation_data <- Some (name_data,value_data)
+
+ | 25 -> (* primary userid (bool) *)
+ if ssp.ssp_length = 1 then
+ let v = int_of_char ssp.ssp_body.[0] in
+ siginfo.is_primary_uid <- v <> 0
+
+ | 26 -> (* policy URL *)
+ siginfo.policy_url <- Some ssp.ssp_body
+
+ | 28 -> (* signer's userid *)
+ siginfo.userid <- Some ssp.ssp_body
+
+ | _ -> (* miscellaneous other packet *)
+ ()
+ in
+ siginfo.sigtype <- s.v4s_sigtype;
+ List.iter (s.v4s_hashed_subpackets @ s.v4s_unhashed_subpackets)
+ ~f:(fun ssp -> try update_siginfo ssp with End_of_file -> ())
+ end;
+ siginfo
+
+(********************************************************************)
+
+(** sort signatures in ascending time order *)
+let sort_siginfo_list list =
+ List.stable_sort list
+ ~cmp:(fun x y -> compare x.sig_creation_time y.sig_creation_time)
+
+(********************************************************************)
+
+let is_selfsig ~keyid siginfo = siginfo.keyid = Some keyid
+
+(********************************************************************)
+
+let is_primary ~keyid (uid,siginfo_list) =
+ List.exists ~f:(fun siginfo ->
+ is_selfsig ~keyid siginfo
+ && siginfo.is_primary_uid
+ && uid.packet_type = User_ID_Packet
+ )
+ siginfo_list
+
+(********************************************************************)
+
+(** returns time of most recent self-sig on uid *)
+let max_selfsig_time ~keyid (uid,siginfo_list) =
+ let selfsigs = List.filter ~f:(fun si -> is_selfsig ~keyid si)
+ siginfo_list in
+ let times = filter_opts
+ (List.map selfsigs
+ ~f:(function x -> match x.sig_creation_time with
+ None -> None
+ | Some time -> Some (Int64.to_float time)))
+ in
+ List.fold_left ~init:min_float ~f:max times
+
+(********************************************************************)
+
+let split_list ~f l =
+ let rec loop l a b = match l with
+ [] -> (List.rev a, List.rev b)
+ | hd::tl ->
+ if f hd then loop tl (hd::a) b
+ else loop tl a (hd::b)
+ in
+ loop l [] []
+
+(********************************************************************)
+
+let move_primary_to_front ~keyid uids =
+ let (primary,normal) = split_list ~f:(is_primary ~keyid) uids in
+ let primary = List.stable_sort primary
+ ~cmp:(fun x y -> compare
+ (max_selfsig_time ~keyid y)
+ (max_selfsig_time ~keyid x)
+ )
+ in
+ primary @ normal
+
+(********************************************************************)
+
+let convert_sigpair (uid,sigs) =
+ (uid,List.map ~f:sig_to_siginfo sigs)
+
+(********************************************************************)
+
+let blank_datestr = "__________"
+let no_datestr = " "
+let datestr_of_int64 i =
+ let tm = Unix.gmtime (Int64.to_float i) in
+ sprintf "%04d-%02d-%02d" (1900 + tm.Unix.tm_year) (1 + tm.Unix.tm_mon)
+ (tm.Unix.tm_mday)
+
+(********************************************************************)
+
+let siginfo_to_lines ~get_uid ?key_creation_time request self_keyid today siginfo =
+
+ let sig_creation_string = match siginfo.sig_creation_time with
+ | None -> blank_datestr
+ | Some time -> datestr_of_int64 time
+ in
+
+ let key_expiration_string =
+ match (key_creation_time,
+ siginfo.key_expiration_time)
+ with
+ | (None,_) | (_,None) -> blank_datestr
+ | (Some x,Some y) -> datestr_of_int64 (Int64.add x y)
+ in
+
+ let sig_expiration_string =
+ match (siginfo.sig_creation_time,
+ siginfo.sig_expiration_time)
+ with
+ | (None,_) | (_,None) -> blank_datestr
+ | (Some x,Some y) -> datestr_of_int64 (Int64.add x y)
+ in
+
+ let sig_expired =
+ match (siginfo.sig_creation_time,
+ siginfo.sig_expiration_time)
+ with
+ | (None,_) | (_,None) -> false
+ | (Some x,Some y) -> (Int64.to_float (Int64.add x y)) < today
+ in
+
+ let sigtype_string =
+ match siginfo.sigtype with
+ | 0x10 ->
+ if sig_expired then "<span class=\"warn\"> exp </span>"
+ else " sig "
+ | 0x11 ->
+ if sig_expired then "<span class=\"warn\"> exp1 </span>"
+ else " sig1 "
+ | 0x12 ->
+ if sig_expired then "<span class=\"warn\"> exp2 </span>"
+ else " sig2 "
+ | 0x13 ->
+ if sig_expired then "<span class=\"warn\"> exp3 </span>"
+ else " sig3 "
+ | 0x20 | 0x28 | 0x30 -> "<span class=\"warn\">revok </span>"
+ | 0x1f -> "dirct "
+ | 0x18 -> "sbind "
+ | x -> sprintf " 0x%02x" x
+ in
+
+ let uid_string = match siginfo.userid with
+ | Some s -> s
+ | None ->
+ if Some self_keyid = siginfo.keyid then "[selfsig]"
+ else
+ match apply_opt get_uid siginfo.keyid with
+ | None | Some None -> "[]"
+ | Some (Some uid) -> uid
+ in
+ let uid_string = HtmlTemplates.html_quote uid_string in
+ let uid_string = match siginfo.keyid with
+ None -> uid_string
+ | Some keyid ->
+ if uid_string = "" then ""
+ else
+ let long = Fingerprint.keyid_to_string ~short:false keyid in
+ let link =
+ HtmlTemplates.link ~op:"vindex"
+ ~hash:request.hash ~fingerprint:request.fingerprint ~keyid:long
+ in
+ sprintf "<a href=\"%s\">%s</a>" link uid_string
+ in
+
+ let keyid_string = match siginfo.keyid with
+ | Some keyid ->
+ let short = Fingerprint.keyid_to_string ~short:true keyid in
+ let long = Fingerprint.keyid_to_string ~short:false keyid in
+ let link =
+ HtmlTemplates.link ~op:"get"
+ ~hash:request.hash ~fingerprint:request.fingerprint ~keyid:long
+ in
+ sprintf "<a href=\"%s\">%s</a>" link short
+ | None ->
+ "no keyid"
+ in
+
+ let firstline = sprintf "sig %-6s %s %s %s %s %s"
+ sigtype_string keyid_string
+ sig_creation_string sig_expiration_string
+ key_expiration_string
+ uid_string
+ in
+
+ let policy_url_opt =
+ apply_opt siginfo.policy_url
+ ~f:(fun policy_url ->
+ let policy_url = HtmlTemplates.html_quote policy_url in
+ sprintf " Policy URL: <a href=\"%s\">%s</a>"
+ policy_url policy_url
+ )
+ in
+ let notation_data_opt =
+ apply_opt siginfo.notation_data
+ ~f:(fun (name,value) ->
+ sprintf " Notation data: <span class=\"text-decoration: underline;\">%s</span> %s"
+ (HtmlTemplates.html_quote name)
+ (HtmlTemplates.html_quote value)
+ )
+ in
+ let revocation_key_opt =
+ apply_opt siginfo.revocation_key
+ ~f:(fun fingerprint ->
+ sprintf " Revocation key fingerprint: <a href=\"%s\">%s</a>"
+ (HtmlTemplates.link ~hash:request.hash ~op:"vindex"
+ ~fingerprint:request.fingerprint
+ ~keyid:(Utils.hexstring fingerprint)
+ )
+ (Fingerprint.fp_to_string fingerprint)
+ )
+ in
+ firstline :: filter_opts [policy_url_opt; notation_data_opt;
+ revocation_key_opt]
+
+
+(********************************************************************)
+
+let selfsigs_to_lines request key_creation_time keyid selfsigs today =
+ let lines =
+ List.map ~f:(fun sign -> siginfo_to_lines ~get_uid:(fun _ -> None)
+ ~key_creation_time request keyid today
+ (sig_to_siginfo sign))
+ selfsigs
+ in
+ List.concat lines
+
+(********************************************************************)
+
+let uid_to_lines ~get_uid request key_creation_time keyid today
+ (uid,siginfo_list) =
+ let siginfo_list = sort_siginfo_list siginfo_list in
+ let uid_line = match uid.packet_type with
+ | User_ID_Packet ->
+ sprintf "<strong>uid</strong> <span class=\"uid\">%s</span>"
+ (HtmlTemplates.html_quote uid.packet_body)
+
+ | _ -> sprintf "<strong>uat</strong> [contents omitted]"
+ in
+ let siginfo_lines =
+ List.concat
+ (List.map ~f:(siginfo_to_lines ~get_uid ~key_creation_time
+ request keyid today)
+ siginfo_list)
+ in
+ ""::uid_line::siginfo_lines
+
+let uids_to_lines ~get_uid request key_creation_time keyid uids today =
+ List.concat
+ (List.map ~f:(uid_to_lines ~get_uid request key_creation_time keyid today) uids)
+
+(********************************************************************)
+
+let key_packet_to_line ~is_subkey pki keyid =
+ let prefix = if is_subkey then "<strong>sub</strong>" else "<strong>pub</strong>" in
+ let creation_string = datestr_of_int64 pki.pk_ctime in
+ let expiration_string =
+ if pki.pk_version = 4 then no_datestr
+ else
+ match pki.pk_expiration with
+ | None -> blank_datestr
+ | Some days ->
+ let time = Int64.add (Int64.of_int (days * 24 * 60 * 60))
+ pki.pk_ctime in
+ datestr_of_int64 time
+ in
+ let keyid = keyid in
+ let keyid_short = Fingerprint.keyid_to_string ~short:true keyid in
+ let keyid_long = Fingerprint.keyid_to_string ~short:false keyid in
+
+ let keyid_string =
+ if is_subkey then sprintf "%8s" keyid_short
+ else
+ sprintf "<a href=\"%s\">%8s</a>"
+ (HtmlTemplates.link ~op:"get" ~hash:false ~fingerprint:false
+ ~keyid:keyid_long )
+ keyid_short
+ in
+ let algo = pk_alg_to_ident pki.pk_alg in
+ let line = sprintf "%s %4d%s/%s %s %s "
+ prefix
+ pki.pk_keylen algo
+ keyid_string
+ creation_string expiration_string
+ in
+ (line,keyid)
+
+(********************************************************************)
+
+let subkey_to_lines request today (subkey,siginfo_list) =
+ let pki = ParsePGP.parse_pubkey_info subkey in
+ let keyid = (Fingerprint.from_packet subkey).Fingerprint.keyid in
+ let (subkey_line,keyid) = key_packet_to_line ~is_subkey:true pki keyid in
+ let key_creation_time = pki.pk_ctime in
+ let siginfo_lines =
+ List.concat (List.map ~f:(siginfo_to_lines ~get_uid:(fun _ -> None)
+ ~key_creation_time request keyid today)
+ siginfo_list)
+ in
+ ""::subkey_line::siginfo_lines
+
+let subkeys_to_lines request subkeys today =
+ List.concat (List.map ~f:(subkey_to_lines request today) subkeys)
+
+(********************************************************************)
+(* new style verbose key index **************************************)
+(********************************************************************)
+
+(** if f is true for any element of list, then return (Some x,newlist), where
+ x is one such element, and newlist is list with x removed. Otherwise,
+ return (None,list)
+*)
+let rec extract ~f list = match list with
+ [] -> (None,[])
+ | hd::tl ->
+ if f hd then (Some hd,tl)
+ else let (x,new_tl) = extract ~f tl in (x,hd::new_tl)
+
+(** if there is an element in list for which f returns true, then return list
+ with one such element moved to the front. *)
+let move_to_front ~f list =
+ match extract ~f list with
+ | (None,list) -> list
+ | (Some x,list) -> x::list
+
+(********************************************************************)
+
+(** fetches UID from keyid, stopping fater first [max_uid_fetches] *)
+let get_uid get_uids =
+ let ctr = ref 0 in
+ (fun keyid ->
+ try
+ incr ctr;
+ if !ctr > !Settings.max_uid_fetches then None
+ else
+ let uids = get_uids keyid in
+ let uids = List.filter uids
+ ~f:(fun (uid,_) -> uid.packet_type = User_ID_Packet) in
+ let uids = List.map ~f:convert_sigpair uids in
+ match move_primary_to_front ~keyid uids with
+ | [] -> None
+ | (uid,_)::tl -> Some uid.packet_body
+ with
+ | e ->
+ eplerror 3 e
+ "Error fetching uid during VIndex for keyid 0x%s"
+ (KeyHash.hexify keyid);
+ None
+ )
+
+(********************************************************************)
+
+(** computes fingerprint and hash lines if required *)
+let get_extra_lines request key hash meta =
+
+ let extra_lines =
+ if request.fingerprint then
+ [HtmlTemplates.fingerprint ~fp:(Fingerprint.fp_to_string
+ meta.Fingerprint.fp)]
+ else []
+ in
+
+ let extra_lines =
+ if request.hash then
+ let hash_line = HtmlTemplates.hash ~hash:(KeyHash.hexify hash) in
+ hash_line::extra_lines
+ else
+ extra_lines
+ in
+
+ extra_lines
+
+(********************************************************************)
+
+(** computes key to verbose set of lines. Note that these lines should be
+ embedded inside of a <pre></pre> environment *)
+let key_to_lines_verbose ~get_uids request key hash =
+ try
+ let get_uid = get_uid get_uids in
+ let pkey = KeyMerge.key_to_pkey key in
+ let selfsigs = pkey.KeyMerge.selfsigs
+ and uids = List.map ~f:convert_sigpair pkey.KeyMerge.uids
+ and subkeys = List.map ~f:convert_sigpair pkey.KeyMerge.subkeys
+ and pubkey = pkey.KeyMerge.key in
+
+ (* sort subkeys by creation time in ascending order *)
+ let subkeys =
+ List.map ~f:(fun (uid,siginfo) ->
+ (uid,sort_siginfo_list siginfo)) subkeys
+ in
+
+ let pki = ParsePGP.parse_pubkey_info pubkey in
+ let meta = Fingerprint.from_packet pubkey in
+ let keyid = meta.Fingerprint.keyid in
+ let key_creation_time = pki.pk_ctime in
+
+ let today = Stats.round_up_to_day (Unix.gettimeofday ()) in
+
+
+ (** move primary keyid to front of the list *)
+ let uids = move_primary_to_front ~keyid uids in
+
+ (* let primary_uid_string = (fst (List.hd uids)).packet_body in *)
+ let (pubkey_line,keyid) =
+ key_packet_to_line ~is_subkey:false pki keyid in
+
+ let extra_lines = get_extra_lines request key hash meta in
+
+ (* note: ugly hack here. </pre> and <pre> are used to allow for an <hr>
+ inside of a pre-formatted region. So this code only works if the
+ lines are being generated to be put inside of a <pre></pre> block> *)
+ ("</pre><hr /><pre>" ^ pubkey_line) ::
+ List.concat [
+ selfsigs_to_lines request key_creation_time keyid selfsigs today;
+ extra_lines;
+ uids_to_lines ~get_uid request key_creation_time keyid uids today;
+ subkeys_to_lines request subkeys today;
+ ]
+
+ with
+ | Sys.Break | Eventloop.SigAlarm as e -> raise e
+ | e ->
+ eplerror 2 e
+ "Unable to print key from query '%s'"
+ (String.concat ~sep:" " request.search);
+ []
+
+
+(********************************************************************)
+(* old style key index **********************************************)
+(********************************************************************)
+
+let sig_is_revok siginfo =
+ match siginfo.sigtype with
+ | 0x20 | 0x28 | 0x30 -> true
+ | _ -> false
+
+let is_revoked key =
+ let pkey = KeyMerge.key_to_pkey key in
+ let selfsigs = pkey.KeyMerge.selfsigs in
+ List.exists ~f:(fun sign ->
+ sig_is_revok (sig_to_siginfo sign)
+ )
+ selfsigs
+
+(** oldstyle index lines *)
+let key_to_lines_normal request key hash =
+ try
+ let pkey = KeyMerge.key_to_pkey key in
+ let uids = List.map ~f:convert_sigpair pkey.KeyMerge.uids in
+
+ let meta = Fingerprint.from_key key in
+ let keyid = meta.Fingerprint.keyid in
+ let keyid_short = Fingerprint.keyid_to_string ~short:true keyid in
+ let keyid_long = Fingerprint.keyid_to_string ~short:false keyid in
+ let link = HtmlTemplates.link ~op:"get" ~hash:false ~fingerprint:false
+ ~keyid:keyid_long in
+ let ilink = HtmlTemplates.link ~op:"vindex"
+ ~hash:request.hash ~fingerprint:request.fingerprint
+ ~keyid:keyid_long in
+
+ let uids = move_primary_to_front ~keyid uids in
+
+ let userids =
+ List.map ~f:(fun (uid,sigs) ->
+ match uid.packet_type with
+ User_ID_Packet ->
+ HtmlTemplates.html_quote uid.packet_body
+ | User_Attribute_Packet -> "[user attribute packet]"
+ | _ -> "[unexpected packet type]"
+ )
+ uids
+ in
+ let userids = match userids with [] -> []
+ | hd::tl -> (sprintf "<a href=\"%s\">%s</a>" ilink hd)::tl in
+ let pki = ParsePGP.parse_pubkey_info (List.hd key) in
+ let keystr = HtmlTemplates.keyinfo_pks pki (is_revoked key)
+ ~keyid:keyid_short ~link ~userids in
+ let lines = [] in
+ let lines =
+ if request.fingerprint then
+ let fingerprint = HtmlTemplates.fingerprint
+ ~fp:(Fingerprint.fp_to_string
+ (meta.Fingerprint.fp))
+ in
+ fingerprint::lines
+ else
+ lines
+ in
+ let lines =
+ if request.hash then
+ let hash = HtmlTemplates.hash ~hash:(KeyHash.hexify hash) in
+ hash::lines
+ else
+ lines
+ in
+ let lines =
+ keystr::lines
+ in
+ "</pre><hr /><pre>"::lines
+ with
+ | Sys.Break | Eventloop.SigAlarm as e -> raise e
+ | e ->
+ eplerror 2 e
+ "Unable to print key from query '%s'"
+ (String.concat ~sep:" " request.search);
+ []
+
+
Added: sks/branches/upstream/sks/current/int_comparators.ml
===================================================================
--- sks/branches/upstream/sks/current/int_comparators.ml (rev 0)
+++ sks/branches/upstream/sks/current/int_comparators.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,15 @@
+(* rename the polymorphic comparators *)
+let ( <>: ) = ( <> )
+let ( =: ) = ( = )
+let ( <: ) = ( < )
+let ( >: ) = ( > )
+let ( <=: ) = ( <= )
+let ( >=: ) = ( >= )
+
+(* and then constraint the usual ones to ints *)
+let ( <> ) (x :int) y : bool = x <> y
+let ( = ) (x :int) y : bool = x = y
+let ( < ) (x :int) y : bool = x < y
+let ( > ) (x :int) y : bool = x > y
+let ( <= ) (x :int) y : bool = x <= y
+let ( >= ) (x :int) y : bool = x >= y
Added: sks/branches/upstream/sks/current/key.ml
===================================================================
--- sks/branches/upstream/sks/current/key.ml (rev 0)
+++ sks/branches/upstream/sks/current/key.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,154 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Basic key-related operations *)
+open StdLabels
+open MoreLabels
+open Packet
+module Set = PSet.Set
+
+exception Bug of string
+
+
+(*************************************************************)
+
+let rec pos_next_rec ps partial =
+ match SStream.peek ps with
+ None -> Some (List.rev partial)
+ | Some (_,packet) ->
+ if packet.packet_type = Public_Key_Packet
+ then Some (List.rev partial)
+ else (
+ SStream.junk ps;
+ pos_next_rec ps (packet::partial)
+ )
+
+let pos_next ps =
+ match SStream.peek ps with
+ None -> None
+ | Some (pos,pack) ->
+ SStream.junk ps;
+ match pos_next_rec ps [pack] with
+ Some key -> Some (pos,key)
+ | None -> None
+
+let pos_get ps =
+ match pos_next ps with
+ None -> raise Not_found
+ | Some key -> key
+
+let pos_next_of_channel cin =
+ let ps =
+ SStream.make (fun () -> (try Some (ParsePGP.offset_read_packet cin)
+ with End_of_file -> None))
+ in
+ (fun () -> pos_next ps)
+
+let pos_get_of_channel cin =
+ let ps =
+ SStream.make (fun () -> (try Some (ParsePGP.offset_read_packet cin)
+ with End_of_file -> None))
+ in
+ (fun () -> pos_get ps)
+
+(*************************************************************)
+
+let rec next_rec ps partial =
+ match SStream.peek ps with
+ None -> Some (List.rev partial)
+ | Some packet ->
+ if packet.packet_type = Public_Key_Packet
+ then Some (List.rev partial)
+ else (
+ SStream.junk ps;
+ next_rec ps (packet::partial)
+ )
+
+let next ps =
+ match SStream.peek ps with
+ None -> None
+ | Some pack ->
+ SStream.junk ps;
+ next_rec ps [pack]
+
+let get ps =
+ match next ps with
+ None -> raise Not_found
+ | Some key -> key
+
+let next_of_channel cin =
+ let ps =
+ SStream.make (fun () -> (try Some (ParsePGP.read_packet cin)
+ with End_of_file -> None))
+ in
+ (fun () -> next ps)
+
+let get_of_channel cin =
+ let ps =
+ SStream.make (fun () -> (try Some (ParsePGP.read_packet cin)
+ with End_of_file -> None))
+ in
+ (fun () -> get ps)
+
+
+(*************************************************************)
+
+let rec get_ids key = match key with
+ [] -> []
+ | packet::tail ->
+ if packet.packet_type = User_ID_Packet
+ then packet.packet_body::(get_ids tail)
+ else get_ids tail
+
+(*************************************************************)
+
+let write key cout =
+ List.iter ~f:(fun packet -> write_packet packet cout) key
+
+let to_string key =
+ let cout = Channel.new_buffer_outc 0 in
+ write key cout;
+ cout#contents
+
+let of_string keystr =
+ let cin = new Channel.string_in_channel keystr 0 in
+ match next_of_channel cin () with
+ None -> raise (Bug "key should have appeared")
+ | Some key -> key
+
+let of_string_multiple keystr =
+ let cin = new Channel.string_in_channel keystr 0 in
+ let next = next_of_channel cin in
+ let rec loop () =
+ match next () with
+ None -> []
+ | Some key -> key::(loop ())
+ in
+ loop ()
+
+let to_string_multiple keys =
+ let cout = Channel.new_buffer_outc 0 in
+ List.iter ~f:(fun key -> write key cout) keys;
+ cout#contents
+
+(*************************************************************)
+
+let to_words key =
+ let userids = get_ids key in
+ let wordsets = List.map ~f:Utils.extract_word_set userids in
+ Set.elements (List.fold_left ~init:Set.empty ~f:Set.union
+ wordsets)
Added: sks/branches/upstream/sks/current/keyHash.ml
===================================================================
--- sks/branches/upstream/sks/current/keyHash.ml (rev 0)
+++ sks/branches/upstream/sks/current/keyHash.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,80 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Sorts key and generates MD5 hash of sorted key *)
+
+(** Note that hash should not depend on whether old or new-style packets are
+ used, although for nested packets, packet format will make a difference *)
+
+open StdLabels
+open MoreLabels
+
+open Packet
+open Printf
+
+let hash_bytes = 16
+
+let packet_cmp p1 p2 =
+ let c = compare p1.content_tag p2.content_tag in
+ if c <> 0 then c
+ else compare p1.packet_body p2.packet_body
+
+(* takes a key and dumps all of its contents into one long string *)
+let concat key =
+ let length = List.fold_left
+ ~f:(fun sum p -> sum + 4 + p.packet_length)
+ ~init:0 key
+ in
+ let bufc = Channel.new_buffer_outc length in
+ List.iter ~f:(fun p ->
+ bufc#write_int p.content_tag ;
+ bufc#write_int p.packet_length;
+ bufc#write_string p.packet_body)
+ key;
+ bufc#contents
+
+let sort key =
+ List.sort ~cmp:packet_cmp key
+
+let hash key =
+ let keystring = concat (sort key) in
+ let hash = Digest.string keystring in
+ (hash : string)
+
+
+let hexify s = Utils.hexstring s
+
+let hexchar_to_int c =
+ let ic = int_of_char c in
+ if ic >= int_of_char '0' && ic <= int_of_char '9' then
+ ic - int_of_char '0'
+ else (
+ if not (ic <= int_of_char 'F' && ic >= int_of_char 'A')
+ then failwith "char out of range for hex conversion";
+ ic - int_of_char 'A' + 10
+ )
+
+let dehexify s =
+ let s = String.uppercase s in
+ let ns = String.create (String.length s / 2) in (* new string *)
+ for i = 0 to String.length ns - 1 do
+ let first = hexchar_to_int s.[2 * i]
+ and second = hexchar_to_int s.[2 * i + 1]
+ in
+ ns.[i] <- char_of_int ((first lsl 4) + second)
+ done;
+ ns
Added: sks/branches/upstream/sks/current/keyMerge.ml
===================================================================
--- sks/branches/upstream/sks/current/keyMerge.ml (rev 0)
+++ sks/branches/upstream/sks/current/keyMerge.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,257 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Logic for merging PGP keys with the same public key *)
+open StdLabels
+open MoreLabels
+open Printf
+open Common
+open Packet
+
+module Set = PSet.Set
+module Map = PMap.Map
+
+exception Unparseable_packet_sequence
+
+(** This is my understanding of the grammar of allowable public keys:
+
+{[ ATOMS = v3_pubkey v4_pubkey signature pubsubkey uid e]}
+
+ The above correspond to packet types, except for e, which corresponds to
+ the empty string.
+
+ Here's the grammar:
+
+{[ KEY := V3 | V4
+ V3 := v3_pubkey SIGLIST UIDLIST
+ V4 := v4_pubkey SIGLIST UIDLIST SUBKEYLIST
+ SIGLIST := e | signature SIGLIST
+ UIDLIST := e | UID UIDLIST
+ UID := uid SIGLIST | uid
+ SUBKEYLIST := e | SUBKEY SUBKEYLIST
+ SUBKEY := subkey SIGLIST ]}
+
+(shouldn't the last one be:
+ {[SUBKEY := subkey signature SIGLIST]}
+ since there must be at least one signature?)
+
+ My only purpose in doing this parsing is to allow for the proper merging
+ of two public keys.
+ To merge two keys, I join the SIGLISTs and UIDLISTs and SUBKEYLISTs.
+ + Merging SIGLISTs is straightforward: just concatentate the lists and drop
+ duplicates.
+ + Merging UIDLISTs and SUBKEYLISTs is somewhat more complicated. I
+ join siglists corresponding to the same UID.
+
+ The current implementation explicitly distinguishes between v3 and v4
+ keys, which really it doesn't need to do as it presently stands. But if a
+ fuller handler of revocation becomes necessary, then distinguishing
+ between the two may be necessary.
+
+ There is no special handling of revocations --- I don't check if they're
+ valid, and multiple revocations can pop up.
+*)
+
+
+(*******************************************************************)
+(* Types for representing the structure of a key *)
+
+type sigpair = packet * packet list
+
+type pkey = { key : packet;
+ selfsigs: packet list; (* revocations only in v3 keys *)
+ uids: sigpair list;
+ subkeys: sigpair list;
+ }
+
+let packets_equal p1 p2 = p1 = p2
+
+(*******************************************************************)
+(** Code for flattening out the above structure back to the original key *)
+
+let rec flatten_sigpair_list list = match list with
+ [] -> []
+ | (pack,sigs)::tl -> pack :: (sigs @ flatten_sigpair_list tl)
+
+let flatten key =
+ key.key :: List.concat [ key.selfsigs;
+ flatten_sigpair_list key.uids;
+ flatten_sigpair_list key.subkeys ]
+
+
+(************************************************************)
+
+let print_pkey key =
+ printf "%d selfsigs, %d uids, %d subkeys\n"
+ (List.length key.selfsigs)
+ (List.length key.uids)
+ (List.length key.subkeys)
+
+
+(*******************************************************************)
+
+let get_version packet =
+ match packet.packet_type with
+ Public_Key_Packet -> int_of_char packet.packet_body.[0]
+ | Signature_Packet -> int_of_char packet.packet_body.[0]
+ | _ -> raise Not_found
+
+let key_to_stream key =
+ let ptype_list = List.map ~f:(fun pack -> (pack.packet_type,pack)) key in
+ Stream.of_list ptype_list
+
+
+
+
+(*******************************************************************)
+(*** Key Parsing ***************************************************)
+(*******************************************************************)
+
+let rec parse_keystr = parser
+ | [< '(Public_Key_Packet,p) ; s >] ->
+ match get_version p with
+ | 4 ->
+ (match s with parser [< selfsigs = siglist;
+ uids = uidlist;
+ subkeys = subkeylist;
+ >]
+ -> { key = p;
+ selfsigs = selfsigs;
+ uids = uids;
+ subkeys = subkeys;
+ })
+ | 2 | 3 ->
+ (match s with parser [< revocations = siglist;
+ uids = uidlist;
+ >] ->
+ { key = p ;
+ selfsigs = revocations;
+ uids = uids;
+ subkeys = [];
+ })
+ | _ -> failwith "Unexpected key packet version number"
+and siglist = parser
+ | [< '(Signature_Packet,p); tl = siglist >] -> p::tl
+ | [< >] -> []
+and uidlist = parser
+ | [< '(User_ID_Packet,p); sigs = siglist; tl = uidlist >] ->
+ (p,sigs)::tl
+ | [< '(User_Attribute_Packet,p); sigs = siglist; tl = uidlist >] ->
+ (p,sigs)::tl
+ (*
+ (p,sigs)::(match s with parser
+ | [< '(User_ID_Packet,p); sigs = siglist; tl = uidlist >] ->
+ (p,sigs)::tl
+ | [< >] -> [])
+ *)
+ | [< >] -> []
+and subkeylist = parser
+ | [< '(Public_Subkey_Packet,p); sigs = siglist; tl = subkeylist >] ->
+ (p,sigs)::tl
+ | [< >] -> []
+
+(*******************************************************************)
+(*** Key Merging Code *********************************************)
+(*******************************************************************)
+
+let set_of_list list = List.fold_left ~init:Set.empty list
+ ~f:(fun set x -> Set.add x set)
+
+let merge_sigpairs pairs =
+ let map =
+ List.fold_left pairs
+ ~f:(fun map (pack,sigs) ->
+ try
+ let old_sigs = Map.find pack map in
+ (* If front packet is already there, add in new sigs,
+ discarding duplicates *)
+ Map.add ~key:pack ~data:(Utils.dedup (old_sigs @ sigs)) map
+ with
+ (* otherwise, add in data by itself *)
+ Not_found -> Map.add ~key:pack ~data:sigs map)
+ ~init:Map.empty
+ in
+ Map.fold ~f:(fun ~key:pack ~data:sigs list -> (pack,sigs)::list) map ~init:[]
+
+let merge_sigpair_lists l1 l2 =
+ merge_sigpairs (l1 @ l2)
+
+(*******************************************************************)
+
+let merge_pkeys key1 key2 =
+ if not (packets_equal key1.key key2.key)
+ then None (* merge can only work if keys are the same *)
+ else
+ Some { key = key1.key;
+ selfsigs = Utils.dedup (key1.selfsigs @ key2.selfsigs);
+ (* this might be wrong. Must the revocations
+ be separated out to go before the other self
+ signatures? *)
+ uids = merge_sigpair_lists key1.uids key2.uids;
+ subkeys = merge_sigpair_lists key1.subkeys key2.subkeys;
+ }
+
+(*******************************************************************)
+(*******************************************************************)
+(*******************************************************************)
+
+let key_to_pkey key =
+ try
+ let keystream = key_to_stream key in
+ let pkey = parse_keystr keystream in
+ Stream.empty keystream;
+ pkey
+ with
+ Stream.Failure | Stream.Error _ ->
+ raise Unparseable_packet_sequence
+
+
+let merge key1 key2 =
+ try
+ let pkey1 = key_to_pkey key1
+ and pkey2 = key_to_pkey key2 in
+ let mkey = merge_pkeys pkey1 pkey2 in
+ apply_opt ~f:flatten mkey
+ with
+ Unparseable_packet_sequence -> None
+
+let dedup_sigpairs pairs =
+ let map =
+ List.fold_left pairs ~init:Map.empty
+ ~f:(fun map (pack,sigs) ->
+ try
+ let old_sigs = Map.find pack map in
+ Map.add ~key:pack ~data:(Utils.dedup (sigs @ old_sigs)) map
+ with
+ Not_found -> Map.add ~key:pack ~data:sigs map
+ )
+ in
+ Map.to_alist map
+
+
+let dedup_pkey pkey =
+ { pkey with
+ selfsigs = Utils.dedup pkey.selfsigs;
+ uids = dedup_sigpairs pkey.uids;
+ subkeys = dedup_sigpairs pkey.subkeys;
+ }
+
+let dedup_key key = flatten (dedup_pkey (key_to_pkey key))
+
+let parseable key =
+ try ignore (key_to_pkey key); true
+ with Unparseable_packet_sequence -> false
Added: sks/branches/upstream/sks/current/keydb.ml
===================================================================
--- sks/branches/upstream/sks/current/keydb.ml (rev 0)
+++ sks/branches/upstream/sks/current/keydb.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,1354 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Interface for dealing with underlying key database *)
+open StdLabels
+open MoreLabels
+open Printf
+open Common
+module Set = PSet.Set
+
+(** Invariants to check:
+
+ - All cursors that are created are deleted, even in the case of exceptions
+ - All transactions are either committed xor aborted
+ - transaction-protected operations are aborted when exceptions occur.
+ - Keys are atomically added to and removed from word, key,
+ and keyid databases. Appropriate updates to time db are also made
+ atomically.
+*)
+
+open Bdb
+open Packet
+
+type dbsettings = { withtxn: bool;
+ cache_bytes: int option;
+ pagesize: int option;
+ dbdir: string;
+ dumpdir: string;
+ }
+
+
+module type RestrictedKeydb =
+sig
+ type txn
+
+ val open_dbs : dbsettings -> unit
+ val close_dbs : unit -> unit
+ val sync : unit -> unit
+ val txn_begin : ?parent:txn -> unit -> txn option
+ val txn_commit : txn option -> unit
+ val txn_abort : txn option -> unit
+ val checkpoint : unit -> unit
+ val unconditional_checkpoint : unit -> unit
+
+ (* val extract_words : string -> string list *)
+
+ (** access methods *)
+ val get_num_keys : unit -> int
+ val get_dump_filearray : unit -> in_channel array
+ val get_by_words : max:int -> string list -> key list
+ val get_by_hash : string -> key
+ val get_keystring_by_hash : string -> string
+ val iter : f:(hash:string -> key:key -> 'a) -> unit
+ val keyiter : f:(string -> 'a) -> unit
+ val get_by_short_subkeyid : string -> key list
+ val logquery : ?maxsize:int -> float -> (float * Common.event) list
+ val reverse_logquery : ?maxsize:int -> float -> (float * Common.event) list
+ val create_hashstream : unit -> string SStream.sstream * (unit -> unit)
+ val create_hash_skey_stream :
+ unit -> (string * string) SStream.sstream * (unit -> unit)
+ val last_ts : unit -> float
+ val enqueue_key : txn:txn option -> key -> unit
+ val dequeue_key : txn:txn option -> float * key
+
+ type 'a offset = { fnum : int; pos : 'a; }
+ and skey =
+ KeyString of string
+ | Key of Packet.packet list
+ | Offset of int offset
+ | LargeOffset of int64 offset
+ type key_metadata = {
+ md_hash : string;
+ md_words : string list;
+ md_keyid : string;
+ md_subkey_keyids : string list;
+ md_time : float;
+ md_skey : skey;
+ }
+ val key_to_metadata : ?hash:Digest.t -> key -> key_metadata
+ val key_to_metadata_large_offset :
+ int64 offset -> Packet.packet list -> key_metadata
+ val add_mds : key_metadata list -> unit
+ val add_key : ?parent:txn -> ?hash:Digest.t -> Packet.packet list -> unit
+ val add_keys : Packet.packet list list -> unit
+ val add_key_merge : newkey:bool -> Packet.packet list -> unit
+ val add_keys_merge : Packet.packet list list -> unit
+ val swap_keys : Packet.packet list -> Packet.packet list -> unit
+ val get_meta : string -> string
+ val set_meta : key:string -> data:string -> unit
+ val replace : Packet.packet list list -> Packet.packet list -> unit
+ val delete_key : ?hash:'a -> Packet.packet list -> unit
+end
+
+
+module Unsafe =
+struct
+ type txn = Bdb.txn
+
+ let word_db_name = "word"
+ let key_db_name = "key"
+ let keyid_db_name = "keyid"
+ let subkey_keyid_db_name = "subkeyid"
+ let time_db_name = "time"
+ let tqueue_db_name = "tqueue"
+ let meta_db_name = "meta"
+
+ let max_internal_matches = !Settings.max_internal_matches
+
+ (**********************************************************)
+ (* Types ************************************************)
+ (**********************************************************)
+
+ type action = DeleteKey | AddKey
+
+ type 'a offset = { fnum: int; pos: 'a; }
+
+ (** Stored key. Can have a number of formats.
+ Eventually this may include death certificates
+ *)
+ type skey =
+ | KeyString of string
+ | Key of packet list
+ | Offset of int offset
+ | LargeOffset of int64 offset
+
+ type dbdump =
+ { directory: string;
+ filearray: in_channel array;
+ }
+
+ type dbstate =
+ { settings: dbsettings;
+ dbenv: Dbenv.t;
+ key: Db.t;
+ word: Db.t;
+ keyid: Db.t;
+ subkey_keyid: Db.t;
+ time: Db.t;
+ tqueue: Db.t; (** queue of hashes that need
+ to be transmitted to other hosts *)
+ meta: Db.t; (** Queue contains metadata, including version
+ information and data about what filters
+ have been applied
+ *)
+ dump: dbdump; (** info @ dump files where initial
+ keydump is stored *)
+ }
+
+ let dbstate = ref None
+ exception No_db
+
+ (***********************************************************************)
+
+ let get_dbs () =
+ match !dbstate with
+ None -> raise No_db
+ | Some dbs -> dbs
+
+ let get_dump_filearray () =
+ let dbs = get_dbs () in
+ dbs.dump.filearray
+
+ (***********************************************************************)
+ (* Key conversions ****************************************************)
+ (***********************************************************************)
+
+ let marshal_offset cout offset =
+ cout#write_int offset.fnum;
+ cout#write_int offset.pos
+
+ let unmarshal_offset cin =
+ let fnum = cin#read_int in
+ let offset = cin#read_int in
+ { fnum = fnum; pos = offset; }
+
+ (***********************************************************************)
+
+ let marshal_large_offset cout offset =
+ cout#write_int offset.fnum;
+ cout#write_int64 offset.pos
+
+ let unmarshal_large_offset cin =
+ let fnum = cin#read_int in
+ let offset = cin#read_int64 in
+ { fnum = fnum; pos = offset; }
+
+
+ (***********************************************************************)
+
+ let skey_of_string s =
+ let cin = new Channel.string_in_channel s 0 in
+ match cin#read_byte with
+ 0 -> KeyString cin#read_rest
+ | 1 -> Offset (unmarshal_offset cin)
+ | 2 -> LargeOffset (unmarshal_large_offset cin)
+ | _ -> failwith "Unexpected skey type"
+
+ let skey_to_string skey =
+ let cout = Channel.new_buffer_outc 0 in
+ (match skey with
+ KeyString s -> cout#write_byte 0; cout#write_string s
+ | Key key -> cout#write_byte 0; Key.write key cout
+ | Offset offset -> cout#write_byte 1; marshal_offset cout offset
+ | LargeOffset offset -> cout#write_byte 2;
+ marshal_large_offset cout offset
+ );
+ cout#contents
+
+ let skey_is_offset skey = match skey with
+ | KeyString _ | Key _ -> false
+ | Offset _ | LargeOffset _ -> true
+
+ let keystring_of_offset offset_union =
+ let offset = match offset_union with
+ `large_offset offset | `offset offset -> offset
+ in
+ let dbs = get_dbs () in
+ if Array.length dbs.dump.filearray = 0
+ then failwith ("Key could not be fetched from offset: " ^
+ "No key dump found");
+ if offset.fnum > Array.length dbs.dump.filearray
+ then failwith ("Key could not be fetched from offset: " ^
+ "File number exceeds number of dump files");
+ let file = dbs.dump.filearray.(offset.fnum) in
+ (match offset_union with
+ | `large_offset offset -> LargeFile.seek_in file offset.pos;
+ | `offset offset -> seek_in file offset.pos);
+ let key = Key.get_of_channel (new Channel.sys_in_channel file) () in
+ Key.to_string key
+
+ let keystring_of_skey skey = match skey with
+ | KeyString s -> s
+ | Key key -> Key.to_string key
+ | Offset offset -> keystring_of_offset (`offset offset)
+ | LargeOffset offset -> keystring_of_offset (`large_offset offset)
+
+ let keystring_of_string string =
+ keystring_of_skey (skey_of_string string)
+
+ let key_of_skey skey =
+ match skey with
+ KeyString s -> Key.of_string s
+ | Key key -> key
+ | Offset offset ->
+ let dbs = get_dbs () in
+ if Array.length dbs.dump.filearray = 0
+ then failwith ("Key could not be fetched from offset: " ^
+ "No key dump found");
+ if offset.fnum > Array.length dbs.dump.filearray
+ then failwith ("Key could not be fetched from offset: " ^
+ "File number exceeds number of dump files");
+ let file = dbs.dump.filearray.(offset.fnum) in
+ seek_in file offset.pos;
+ Key.get_of_channel (new Channel.sys_in_channel file) ()
+ | LargeOffset offset ->
+ let dbs = get_dbs () in
+ if Array.length dbs.dump.filearray = 0
+ then failwith ("Key could not be fetched from offset: " ^
+ "No key dump found");
+ if offset.fnum > Array.length dbs.dump.filearray
+ then failwith ("Key could not be fetched from offset: " ^
+ "File number exceeds number of dump files");
+ let file = dbs.dump.filearray.(offset.fnum) in
+ LargeFile.seek_in file offset.pos;
+ Key.get_of_channel (new Channel.sys_in_channel file) ()
+
+
+ let key_to_string key = skey_to_string (Key key)
+ let key_of_string s = key_of_skey (skey_of_string s)
+
+ (***********************************************************************)
+
+ (** returns a list of all elements of the specified directory
+ with the given suffix *)
+ let read_dir_suff dir suff =
+ let dh = Unix.opendir dir in
+ let run () =
+ let dirs = ref [] in
+ while
+ match (try Some (Unix.readdir dh)
+ with End_of_file -> None)
+ with
+ Some fname ->
+ if Filename.check_suffix fname suff
+ then dirs := fname::!dirs;
+ true
+ | None ->
+ false
+ do () done;
+ List.rev !dirs
+ in
+ protect ~f:run ~finally:(fun () -> Unix.closedir dh)
+ (***********************************************************************)
+
+ (** Initialization code for database *)
+ let open_dbs settings =
+ plerror 3 "Opening KeyDB database";
+ match !dbstate with
+ Some x -> failwith ("Keydb.open_dbs: Attempt to open when " ^
+ "close_dbs hasn't been called")
+ | None ->
+ let dbenv = Dbenv.create () in
+ ( match settings.cache_bytes with None -> ()
+ | Some cache_bytes -> Dbenv.set_cachesize dbenv
+ ~gbytes:0 ~bytes:cache_bytes ~ncache:0);
+ Dbenv.dopen dbenv settings.dbdir
+ ( [ Dbenv.INIT_MPOOL; Dbenv.CREATE; (* Dbenv.INIT_LOCK *) ]
+ @ ( if settings.withtxn then [ Dbenv.INIT_TXN; Dbenv.RECOVER ]
+ else [] ) )
+ 0o600;
+
+ let openflags = (if settings.withtxn then [Db.CREATE; Db.AUTO_COMMIT]
+ else [Db.CREATE])
+ in
+ let key = Db.create ~dbenv [] in
+ (match settings.pagesize with None -> ()
+ | Some pagesize -> Db.set_pagesize key pagesize);
+ Db.dopen key key_db_name Db.BTREE openflags 0o600;
+
+ let word = Db.sopen ~dbenv word_db_name Db.BTREE
+ ~moreflags:[Db.DUPSORT] openflags 0o600
+ in
+ let keyid = Db.sopen ~dbenv keyid_db_name Db.BTREE
+ ~moreflags:[Db.DUPSORT] openflags 0o600
+ in
+ let subkey_keyid = Db.sopen ~dbenv subkey_keyid_db_name Db.BTREE
+ ~moreflags:[Db.DUPSORT] openflags 0o600
+ in
+ let time = Db.sopen ~dbenv time_db_name Db.BTREE
+ ~moreflags:[Db.DUPSORT] openflags 0o600
+ in
+ let tqueue = Db.sopen ~dbenv tqueue_db_name Db.BTREE
+ ~moreflags:[] openflags 0o600
+ in
+ let meta = Db.sopen ~dbenv meta_db_name Db.BTREE
+ ~moreflags:[] openflags 0o600
+ in
+
+ (** Sets up array of dump files for entries where
+ file offset is stored instead of key contents *)
+ let dump =
+ let dir = settings.dumpdir in
+ if (Sys.file_exists dir &&
+ (Unix.stat dir).Unix.st_kind = Unix.S_DIR)
+ then
+ let pgpfiles = read_dir_suff dir ".pgp" in
+ let pgpfiles = List.sort ~cmp:compare pgpfiles in
+ let pgpfiles =
+ List.map ~f:(fun f -> Filename.concat dir f) pgpfiles in
+ let pgpfiles = Array.of_list pgpfiles in
+ { directory = dir;
+ filearray =
+ Array.map
+ ~f:(open_in_gen [Open_rdonly; Open_binary] 0o600)
+ pgpfiles
+ }
+ else
+ { directory = "";
+ filearray = Array.make 0 stdin;
+ }
+ in
+
+ if settings.withtxn then Txn.checkpoint dbenv ~kbyte:0 ~min:0 [];
+ dbstate := Some { settings = settings;
+ dbenv = dbenv;
+ word = word;
+ key = key;
+ keyid = keyid;
+ subkey_keyid = subkey_keyid;
+ time = time;
+ dump = dump;
+ meta = meta;
+ tqueue = tqueue;
+ }
+
+ (***********************************************************************)
+
+ let close_dump dbs =
+ let files = dbs.dump.filearray in
+ Array.iter files ~f:(fun file -> close_in file)
+
+ (***********************************************************************)
+
+ let close_dbs () = match !dbstate with
+ None -> raise No_db
+ | Some dbs ->
+ Db.close dbs.key;
+ Db.close dbs.word;
+ Db.close dbs.time;
+ Db.close dbs.keyid;
+ Db.close dbs.subkey_keyid;
+ Db.close dbs.tqueue;
+ Db.close dbs.meta;
+ Dbenv.close dbs.dbenv;
+ close_dump dbs;
+ dbstate := None
+
+ (***********************************************************************)
+
+ let sync () =
+ let dbs = get_dbs () in
+ Db.sync dbs.key;
+ Db.sync dbs.word;
+ Db.sync dbs.time;
+ Db.sync dbs.keyid;
+ Db.sync dbs.subkey_keyid;
+ Db.sync dbs.tqueue;
+ Db.sync dbs.meta
+
+ (***********************************************************************)
+
+ let txn_begin ?parent () =
+ let dbs = get_dbs () in
+ if dbs.settings.withtxn then Some (Txn.txn_begin dbs.dbenv parent [])
+ else None
+
+ (***********************************************************************)
+
+ let txn_commit txn = match txn with
+ None -> () | Some txn -> Txn.commit txn []
+
+ (***********************************************************************)
+
+ let txn_abort txn = match txn with
+ None -> () | Some txn -> Txn.abort txn
+
+ (***********************************************************************)
+
+ let checkpoint () =
+ let dbs = get_dbs () in
+ if dbs.settings.withtxn then
+ Txn.checkpoint dbs.dbenv ~kbyte:(1024 * 5) ~min:0 []
+
+ (***********************************************************************)
+
+ let unconditional_checkpoint () =
+ let dbs = get_dbs () in
+ if dbs.settings.withtxn then
+ Txn.checkpoint dbs.dbenv ~kbyte:0 ~min:0 []
+
+
+ (***********************************************************************)
+ (** Entry preparation code: utilities for formatting data for placement in
+ database *)
+ (***********************************************************************)
+
+ let float_to_string f =
+ let cout = Channel.new_buffer_outc 8 in
+ cout#write_float f;
+ cout#contents
+
+ let float_of_string s =
+ let cin = new Channel.string_in_channel s 0 in
+ cin#read_float
+
+ let event_to_string event =
+ let cout = Channel.new_buffer_outc 9 in
+ ( match event with
+ Add hash -> cout#write_byte 0; cout#write_string hash
+ | Delete hash -> cout#write_byte 1; cout#write_string hash
+ );
+ cout#contents
+
+ let event_of_string string =
+ let cin = new Channel.string_in_channel string 0 in
+ match cin#read_byte with
+ 0 -> Add cin#read_rest
+ | 1 -> Delete cin#read_rest
+ | _ -> failwith "Failure parsing event string"
+
+ let flatten_array_of_lists a =
+ (** chooses element from lists in a *)
+ let rec choose i =
+ if i >= Array.length a then raise Not_found
+ else
+ match a.(i) with
+ [] -> choose (i+1)
+ | hd::tl -> hd
+ in
+
+ let total_length =
+ Array.fold_left ~init:0
+ ~f:(fun sum list -> sum + List.length list) a
+ in
+ try
+ let newarray = Array.make total_length (choose 0) in
+
+ (* fill newarray *)
+ let ctr = ref 0 in
+ Array.iter a
+ ~f:(List.iter ~f:(fun el -> newarray.(!ctr) <- el; incr ctr));
+ newarray
+ with
+ Not_found -> [||]
+
+ (***********************************************************************)
+ (* Access methods ***************************************************)
+ (***********************************************************************)
+
+
+ (** fetch all matches from a joined cursor *)
+ let jcursor_get_all ~max c =
+ let rec loop max list =
+ if max = 0 then list
+ else (
+ match (try Some (Cursor.get c Cursor.NULL [])
+ with Not_found -> None)
+ with
+ Some (key,data) -> loop (max - 1) (data :: list)
+ | None -> list
+ )
+ in
+ loop max []
+
+ (** retrieve keys based on words found in uid strings *)
+ let get_by_words ~max wordlist =
+ let dbs = get_dbs () in
+ try
+ let cursors = List.map ~f:(fun word ->
+ let c = Cursor.create dbs.word in
+ ignore (Cursor.init c word []);
+ c )
+ wordlist in
+ let run () =
+ let lengths = List.map ~f:Cursor.count cursors in
+ if MList.min lengths > max_internal_matches
+ then raise (Invalid_argument "Insufficiently specific words");
+ let keystrings =
+ let cj = Cursor.join dbs.key cursors [] in
+ protect ~f:(fun () -> jcursor_get_all ~max cj)
+ ~finally:(fun () -> Cursor.close cj)
+ in
+ if List.length keystrings >= max then
+ raise (Invalid_argument "Too many responses")
+ else
+ List.map ~f:key_of_string keystrings
+ in
+ protect ~f:run ~finally:(fun () -> List.iter cursors ~f:Cursor.close)
+ with
+ Not_found -> []
+
+ (***********************************************************************)
+
+ let get_skeystring_by_hash hash =
+ let dbs = get_dbs () in
+ Db.get dbs.key hash []
+
+ let get_keystring_by_hash hash =
+ keystring_of_string (get_skeystring_by_hash hash)
+
+ (***********************************************************************)
+
+ (** retrieves key by hash *)
+ let get_by_hash hash =
+ key_of_string (get_skeystring_by_hash hash)
+
+ (** returns true iff db contains specified hash *)
+ let has_hash hash =
+ try ignore (get_skeystring_by_hash hash); true
+ with Not_found -> false
+
+ (** Verification functions *)
+
+ let check_word_hash_pair ~word ~hash =
+ let dbs = get_dbs () in
+ let c = Cursor.create dbs.word in
+ let run () =
+ try
+ Cursor.init_both c ~key:word ~data:hash [];
+ true
+ with
+ Not_found -> false
+ in
+ protect ~f:run ~finally:(fun () -> Cursor.close c)
+
+ let check_keyid_hash_pair ~keyid ~hash =
+ let dbs = get_dbs () in
+ let c = Cursor.create dbs.keyid in
+ let run () =
+ try
+ Cursor.init_both c ~key:keyid ~data:hash [];
+ true
+ with
+ Not_found -> false
+ in
+ protect ~f:run ~finally:(fun () -> Cursor.close c)
+
+ (***********************************************************************)
+
+
+ let get_keystrings_by_hashes hashes =
+ (* sort to improve performance, although this should
+ only really help for very large lists. *)
+ let hashes = List.sort ~cmp:compare hashes in
+ let keystr_opts =
+ List.map ~f:(fun hash ->
+ try Some (get_keystring_by_hash hash)
+ with Not_found -> None)
+ hashes
+ in
+ MList.strip_opt keystr_opts
+
+
+ (***********************************************************************)
+
+ let keyid_iter ~f =
+ let dbs = get_dbs () in
+ let c = Cursor.create dbs.keyid in
+ let rec loop get_type =
+ match (try Some (Cursor.get c get_type []) with Not_found -> None)
+ with
+ | Some (key,data) ->
+ f ~keyid:key ~hash:data;
+ loop Cursor.NEXT
+ | None -> ()
+ in
+ protect ~f:(fun () -> loop Cursor.FIRST)
+ ~finally:(fun () -> Cursor.close c)
+
+ (***********************************************************************)
+
+ let raw_iter ~f =
+ let dbs = get_dbs () in
+ let c = Cursor.create dbs.key in
+ let rec loop get_type =
+ match (try Some (Cursor.get c get_type []) with Not_found -> None)
+ with
+ | Some (key,data) ->
+ f ~hash:key ~keystr:data;
+ loop Cursor.NEXT
+ | None -> ()
+ in
+ protect ~f:(fun () -> loop Cursor.FIRST)
+ ~finally:(fun () -> Cursor.close c)
+
+ (***********************************************************************)
+
+ let iter ~f =
+ raw_iter ~f:(fun ~hash ~keystr ->
+ f ~hash ~key:(key_of_string keystr))
+
+ (***********************************************************************)
+
+ let keyiter ~f =
+ let dbs = get_dbs () in
+ let c = Cursor.create dbs.key in
+ let rec loop get_type =
+ match (try Some (Cursor.get_keyonly c get_type [])
+ with Not_found -> None)
+ with
+ | Some key -> f key; loop Cursor.NEXT
+ | None -> ()
+ in
+ protect ~f:(fun () -> loop Cursor.FIRST)
+ ~finally:(fun () -> Cursor.close c)
+
+ (***********************************************************************)
+
+ let get_hashes_by_keyid db keyid =
+ let c = Cursor.create db in
+ let run () =
+ let rec loop list =
+ match (try Some (Cursor.get c Cursor.NEXT_DUP [])
+ with Not_found -> None)
+ with
+ | Some (key,data) -> loop (data::list)
+ | None -> List.rev list
+ in
+ try
+ let first = Cursor.init c keyid [] in
+ let hashes = loop [first] in
+ hashes
+ with
+ Not_found -> []
+ in
+ protect ~f:run ~finally:(fun () -> Cursor.close c)
+
+
+ let get_skeystrings_by_keyid db keyid =
+ let hashes = get_hashes_by_keyid db keyid in
+ MList.strip_opt
+ (List.map ~f:(fun hash ->
+ try Some (get_skeystring_by_hash hash)
+ with Not_found ->
+ plerror 3 "%s %s"
+ "Failed lookup of skeystring from hash"
+ (KeyHash.hexify hash);
+ None
+ )
+ hashes)
+
+ (** returns list of keys with a primary key with the given short keyid *)
+ let get_by_short_keyid keyid =
+ if String.length keyid <> 4
+ then failwith (sprintf "wrong keyid length %d" (String.length keyid));
+ let dbs = get_dbs () in
+ let skeystrings = get_skeystrings_by_keyid dbs.keyid keyid in
+ List.map ~f:key_of_string skeystrings
+
+ (** returns list of keys with a primary key or subkey with the given short keyid *)
+ let get_by_short_subkeyid keyid =
+ if String.length keyid <> 4
+ then failwith (sprintf "wrong keyid length %d" (String.length keyid));
+ let dbs = get_dbs () in
+ let skeystrings =
+ get_skeystrings_by_keyid dbs.keyid keyid @
+ get_skeystrings_by_keyid dbs.subkey_keyid keyid
+ in
+ List.map ~f:key_of_string skeystrings
+
+ (** return up to [maxsize] keys strictly after provided timestamp *)
+ let logquery ?(maxsize=5000) timestamp =
+
+ let dbs = get_dbs () in
+ let c = Cursor.create dbs.time in
+ let run () =
+ try
+ let (timestr,eventstr) =
+ Cursor.init_range c (float_to_string timestamp) [] in
+ let fst_time = float_of_string timestr in
+ let fst_event = event_of_string eventstr in
+ assert (fst_time >= timestamp);
+ let rec loop count list = match count with
+ | 0 -> List.rev list
+ | _ ->
+ match (try Some (Cursor.get c Cursor.NEXT [])
+ with Not_found -> None)
+ with
+ None -> List.rev list
+ | Some (time,event) ->
+ let (time,event) = (float_of_string time,
+ event_of_string event)
+ in
+ loop (count - 1) ((time,event)::list)
+ in
+ if fst_time = timestamp then loop maxsize []
+ else loop (maxsize - 1) [(fst_time,fst_event)]
+ with
+ Not_found -> []
+ in
+ protect ~f:run ~finally:(fun () -> Cursor.close c)
+
+ (***********************************************************************)
+
+ (** return up to [maxsize] keys counting back from the end of the
+ database, and going no farther back then [timestamp] *)
+
+ let reverse_logquery ?(maxsize=5000) timestamp =
+ let dbs = get_dbs () in
+ let c = Cursor.create dbs.time in
+ let run () =
+ try
+ let (timestr,eventstr) =
+ Cursor.get c Cursor.LAST [] in
+ let fst_time = float_of_string timestr in
+ let fst_event = event_of_string eventstr in
+ if fst_time < timestamp then []
+ else
+ let rec loop count list = match count with
+ | 0 -> list
+ | _ ->
+ begin
+ match (try Some (Cursor.get c Cursor.PREV [])
+ with Not_found -> None)
+ with
+ None -> list
+ | Some (time,event) ->
+ let (time,event) = (float_of_string time,
+ event_of_string event)
+ in
+ if time < timestamp then list
+ else loop (count - 1) ((time,event)::list)
+ end
+ in
+ loop (maxsize - 1) [(fst_time,fst_event)]
+ with
+ Not_found -> []
+ in
+ protect ~f:run ~finally:(fun () -> Cursor.close c)
+
+ (***********************************************************************)
+
+ let create_hashstream () =
+ let dbs = get_dbs () in
+ let c = Cursor.create dbs.keyid in
+ let first = snd (Cursor.get c Cursor.FIRST []) in
+ let close () = Cursor.close c in
+ let next () = (try Some (snd (Cursor.get c Cursor.NEXT []))
+ with Not_found -> None) in
+ let stream = SStream.make ~first next in
+ (stream,close)
+
+ let create_hash_skey_stream () =
+ let dbs = get_dbs () in
+ let c = Cursor.create dbs.key in
+ let first = Cursor.get c Cursor.FIRST [] in
+ let close () = Cursor.close c in
+ let next () = (try Some (Cursor.get c Cursor.NEXT [])
+ with Not_found -> None) in
+ let stream = SStream.make ~first next in
+ (stream,close)
+
+
+ (***********************************************************************)
+
+ let last_ts () =
+ let dbs = get_dbs () in
+ let c = Cursor.create dbs.time in
+ protect ~f:(fun () -> float_of_string (Cursor.get_keyonly c
+ Cursor.LAST []))
+ ~finally:(fun () -> Cursor.close c)
+
+
+ (**************************************************************)
+ (** Functions for updating key database *)
+ (**************************************************************)
+
+ (**********************************************************)
+
+ (** Add key to transmission queue for sending to other
+ (non-SKS) keyservers. *)
+ let enqueue_key ~txn key =
+ let txn =
+ match txn with Some txn -> txn
+ | None -> failwith "transaction required for Keydb.enqueue_key"
+ in
+ let dbs = get_dbs () in
+ let c = Cursor.create ~txn dbs.tqueue in
+ let run () =
+ let timestr = float_to_string (Unix.gettimeofday ()) in
+ Cursor.kput c ~key:timestr ~data:(key_to_string key) Cursor.KEYLAST
+ in
+ protect ~f:run ~finally:(fun () -> Cursor.close c)
+
+ (** Extract key from transmission queue for receiving from
+ (non-SKS) keyservers. *)
+ let dequeue_key ~txn =
+ let txn = match txn with Some txn -> txn
+ | None -> failwith "transaction required for Keydb.dequeue_key"
+ in
+ let dbs = get_dbs () in
+ let c = Cursor.create ~txn dbs.tqueue in
+ let run () =
+ let (timestr,keystr) = Cursor.get c Cursor.FIRST [] in
+ Cursor.del c;
+ (float_of_string timestr, key_of_string keystr)
+ in
+ protect ~f:run ~finally:(fun () -> Cursor.close c)
+
+
+ (***********************************************************************)
+
+ type key_metadata = { md_hash: string;
+ md_words: string list;
+ md_keyid: string;
+ md_subkey_keyids: string list;
+ md_time: float;
+ md_skey: skey;
+ }
+
+ let shorten_offset offset =
+ if offset.pos <= Int64.of_int max_int then
+ Offset { fnum = offset.fnum;
+ pos = Int64.to_int offset.pos;
+ }
+ else
+ LargeOffset offset
+
+ let key_to_metadata_large_offset offset key =
+ let (keyid,subkey_keyids) = Fingerprint.keyids_from_key ~short:true key in
+ { md_hash = KeyHash.hash key;
+ md_words = Key.to_words key;
+ md_keyid = keyid;
+ md_subkey_keyids = subkey_keyids;
+ md_time = Unix.gettimeofday ();
+ md_skey = shorten_offset offset;
+ }
+
+ let key_to_metadata_offset offset key =
+ let (keyid,subkey_keyids) = Fingerprint.keyids_from_key ~short:true key in
+ { md_hash = KeyHash.hash key;
+ md_words = Key.to_words key;
+ md_keyid = keyid;
+ md_subkey_keyids = subkey_keyids;
+ md_time = Unix.gettimeofday ();
+ md_skey = Offset offset;
+ }
+
+ let key_to_metadata ?hash key =
+ let (keyid,subkey_keyids) = Fingerprint.keyids_from_key ~short:true key in
+ { md_hash = (match hash with
+ | None -> KeyHash.hash key
+ | Some hash -> hash);
+ md_words = Key.to_words key;
+ md_keyid = keyid;
+ md_subkey_keyids = subkey_keyids;
+ md_time = Unix.gettimeofday ();
+ md_skey = Key key;
+ }
+
+ (***********************************************************************)
+
+ (** Bulk addition of key-metadata. Used by fastbuild, so no transactional
+ support required or provided. *)
+ let add_mds mds =
+
+ let dbs = get_dbs () in
+ let mds = Array.of_list mds in
+
+ (* Add hash-key mappings *)
+ Array.sort mds ~cmp:(fun md1 md2 -> compare md1.md_hash md2.md_hash);
+ Array.iter
+ ~f:(fun md ->
+ try Db.put dbs.key ~key:md.md_hash
+ ~data:(skey_to_string md.md_skey)
+ [Db.NOOVERWRITE]
+ with Key_exists -> ()
+ )
+ mds;
+
+ let multi_add db getindices =
+ let pair_array =
+ Array.map
+ ~f:(fun md ->
+ let indices = getindices md in
+ List.rev_map ~f:(fun index -> (index,md.md_hash)) indices)
+ mds
+ in
+ let pairs = flatten_array_of_lists pair_array in
+ Array.sort ~cmp:compare pairs;
+ Array.iter ~f:(fun (index,hash) ->
+ try Db.put db ~key:index ~data:hash [Db.NODUPDATA]
+ with Key_exists -> ()
+ )
+ pairs
+ in
+
+ multi_add dbs.word (fun md -> md.md_words);
+ multi_add dbs.subkey_keyid (fun md -> md.md_subkey_keyids);
+ multi_add dbs.keyid (fun md -> [md.md_keyid]);
+
+ (* Add time-hash mappings. No sorting required *)
+ Array.sort mds ~cmp:(fun md1 md2 -> compare md1.md_time md2.md_time);
+ Array.iter mds
+ ~f:(fun md ->
+ let timestr = float_to_string md.md_time
+ and eventstr = event_to_string (Add md.md_hash) in
+ Db.put dbs.time ~key:timestr ~data:eventstr [Db.NODUPDATA])
+
+
+ (****************************************************************)
+
+ let apply_md_updates_txn ~txn updates =
+ let dbs = get_dbs () in
+
+ (* action is included in sort, to ensure that deletes get
+ processed before additions. *)
+ Array.sort updates ~cmp:(fun (md1,action) (md2,action) ->
+ compare (md1.md_hash,action)
+ (md2.md_hash,action)
+ );
+
+ (* Check for hash duplicates *)
+ for i = 0 to Array.length updates - 2 do
+ if (fst updates.(i)).md_hash = (fst updates.(i+1)).md_hash
+ then failwith ("Keydb.apply_md_updates_txn: duplicate hashes " ^
+ "found in update list")
+ done;
+
+ begin
+ (* add hash-key mappings to database *)
+ let c = Cursor.create ?txn dbs.key in
+ let run () =
+ Array.iter updates
+ ~f:(function
+ | (md,AddKey) ->
+ Db.put dbs.key ?txn ~key:md.md_hash
+ ~data:(skey_to_string md.md_skey) [Db.NOOVERWRITE]
+ | (md,DeleteKey) ->
+ try
+ ignore (Cursor.init c md.md_hash [] : string);
+ Cursor.del c
+ with Not_found -> ()
+ )
+ in
+ protect ~f:run ~finally:(fun () -> Cursor.close c);
+ end;
+
+ (* function for doing multiple updates at once *)
+ let multi_update db getindices options =
+
+ let triple_array =
+ Array.map updates
+ ~f:(fun (md,action) ->
+ let indices = getindices md in
+ List.rev_map indices
+ ~f:(fun index -> (index,md.md_hash,action))
+ )
+ in
+ let triples = flatten_array_of_lists triple_array in
+ Array.sort ~cmp:compare triples;
+
+ let c = Cursor.create ?txn db in
+ let run () =
+ Array.iter triples
+ ~f:(function
+ | (index,hash,AddKey) ->
+ Db.put db ?txn ~key:index ~data:hash options
+ | (index,hash,DeleteKey) ->
+ try
+ Cursor.init_both c ~key:index ~data:hash [];
+ Cursor.del c
+ with
+ Not_found -> ()
+ )
+ in
+ protect ~f:run ~finally:(fun () -> Cursor.close c);
+ in
+
+ multi_update dbs.word (fun md -> md.md_words) [Db.NODUPDATA];
+ multi_update dbs.subkey_keyid (fun md -> md.md_subkey_keyids) [];
+ multi_update dbs.keyid (fun md -> [md.md_keyid]) [];
+
+ (* Add time-hash mappings. Note that there are no hash duplicates,
+ so the time ordering does not matter *)
+ Array.sort updates ~cmp:(fun (md1,action) (md2,action) ->
+ compare md1.md_time md2.md_time);
+ Array.iter updates
+ ~f:(fun (md,action) ->
+ let timestr = float_to_string md.md_time in
+ let event = match action with
+ AddKey -> Add md.md_hash | DeleteKey -> Delete md.md_hash
+ in
+ let eventstr = event_to_string event in
+ Db.put ?txn dbs.time ~key:timestr ~data:eventstr [Db.NODUPDATA]
+ )
+
+
+ (****************************************************************)
+
+ let apply_md_updates updates =
+ let txn = txn_begin () in
+ try
+ apply_md_updates_txn ~txn updates;
+ txn_commit txn
+ with
+ | Bdb.DBError s as e ->
+ eplerror 0 e "Fatal database error";
+ raise Sys.Break
+ | e ->
+ eplerror 1 e "apply_md_updates failed -- aborting txn";
+ txn_abort txn;
+ raise e
+
+
+ (****************************************************************)
+
+ let add_md_txn ?txn md =
+ apply_md_updates_txn ~txn [| md,AddKey |]
+
+ (**********************************************************)
+
+ (** add a single key with transaction possibly passed in *)
+ let add_key_txn ?txn ?hash key =
+ let md = key_to_metadata ?hash key in
+ add_md_txn ?txn md
+
+ (**********************************************************)
+
+ (** Does the required transactional wrapping around add_key_txn *)
+ let add_key ?parent ?hash key =
+ let txn = txn_begin ?parent () in
+ try
+ add_key_txn ?txn ?hash key;
+ txn_commit txn
+ with
+ | Bdb.DBError s as e ->
+ eplerror 0 e "Fatal database error";
+ raise Sys.Break
+ | e ->
+ eplerror 2 e "Keydb.add_key -- Aborting transaction";
+ txn_abort txn;
+ raise e
+
+(****************************************************************)
+
+ (** Does transactional wrapping around key adding,
+ allowing multiple keys to be added in a single transaction.*)
+ let add_multi_keys keys =
+ let txn = txn_begin () in
+ try
+ List.iter
+ ~f:(fun key ->
+ try
+ add_key ?parent:txn key
+ with
+ | Key_exists ->
+ plerror 2 "%s"
+ ("add_multi_keys: Key_exists. " ^
+ "continuing transaction");
+ let hashstr = KeyHash.hexify (KeyHash.hash key) in
+ plerror 4 "Hash of duplicate key: %s" hashstr
+ | e ->
+ eplerror 2 e "%s"
+ ("add_multi_keys: unexpected error. " ^
+ "Continuing transaction on other keys")
+ )
+ keys;
+ txn_commit txn
+ with
+ | Bdb.DBError s as e ->
+ eplerror 0 e "Fatal database error";
+ raise Sys.Break
+
+ | e ->
+ txn_abort txn;
+ eplerror 2 e "Keydb.add_multi_key -- Aborting transaction";
+ raise e
+
+ (***********************************************************************)
+
+ (** Adds multiple keys at once --- no transactional support *)
+ let add_keys keys =
+ let mds = List.map ~f:key_to_metadata keys in
+ add_mds mds
+
+ (***********************************************************************)
+
+ let key_to_merge_updates key =
+ let hash = KeyHash.hash key in
+ try
+ if has_hash hash then [] else
+ let keyid = Fingerprint.keyid_from_key ~short:true key in
+ let potential_merges = List.filter ~f:(fun x -> x <> key)
+ (get_by_short_keyid keyid)
+ in
+ plerror 4 "%d potential merges found for keyid %s"
+ (List.length potential_merges) (KeyHash.hexify keyid);
+ let (deletions,mergedkey) =
+ List.fold_left ~init:([],key) potential_merges
+ ~f:(fun (updates,key) x ->
+ match KeyMerge.merge key x with
+ | None -> (updates,key)
+ | Some mergedkey ->
+ ((x, DeleteKey)::updates,
+ mergedkey)
+ )
+ in
+ let addition = (mergedkey,AddKey) in
+ let updates = addition::deletions in
+ let updates = List.rev updates in
+ let updates = List.map updates
+ ~f:(fun (key,action) -> (key_to_metadata key,action))
+ in
+ plerror 4 "%d updates found before filtering" (List.length updates);
+ updates
+ with
+ | Sys.Break | Eventloop.SigAlarm as e -> raise e
+ | Bdb.DBError s as e ->
+ eplerror 0 e "Fatal database error";
+ raise Sys.Break
+ | e ->
+ eplerror 2 e "Keydb.key_to_merge_updates: error in key %s"
+ (KeyHash.hexify hash);
+ []
+
+
+ (**********************************************************)
+
+ let sort_remove updates =
+ let updates = List.stable_sort updates
+ ~cmp:(fun (md1,action) (md2,action) ->
+ compare md1.md_hash md2.md_hash)
+ in
+ let rec clean updates list = match updates with
+ | [] -> List.rev list
+ | [el] -> clean [] (el::list)
+ | (md1,action1)::(md2,action2)::tl ->
+ if md1.md_hash = md2.md_hash &&
+ (action1 = DeleteKey && action2 = AddKey
+ || action2 = DeleteKey && action1 = AddKey
+ )
+ then clean tl list
+ else clean ((md2,action2)::tl) ((md1,action1)::list)
+ in
+ clean updates []
+
+ (**********************************************************)
+
+ let add_keys_merge_txn ~txn keys =
+ let updates = List.map ~f:key_to_merge_updates keys in
+ let updates = List.concat updates in
+ let updates = sort_remove updates in
+ plerror 3 "Applying %d changes" (List.length updates);
+ List.iter updates
+ ~f:(function
+ | (md,AddKey) ->
+ plerror 3 "Adding hash %s" (KeyHash.hexify md.md_hash)
+ | (md,DeleteKey) ->
+ plerror 3 "Del'ng hash %s" (KeyHash.hexify md.md_hash)
+ );
+ apply_md_updates_txn ~txn (Array.of_list updates);
+ List.length updates
+
+ (**********************************************************)
+
+ let add_keys_merge keys =
+ let txn = txn_begin () in
+ try
+ ignore (add_keys_merge_txn ~txn keys);
+ txn_commit txn
+ with
+ | Bdb.DBError s as e ->
+ eplerror 0 e "Fatal database error";
+ raise Sys.Break
+
+ | e ->
+ eplerror 1 e "add_keys_merge failed";
+ txn_abort txn;
+ raise e
+
+ (**********************************************************)
+
+ let add_key_merge ~newkey key =
+ let txn = txn_begin () in
+ try
+ let number_of_updates = add_keys_merge_txn ~txn [key] in
+ if newkey && number_of_updates > 0 then (
+ plerror 4 "%s" ("Keydb.add_key_merge: Enqueing new key " ^
+ "for transmission to other hosts");
+ enqueue_key ~txn key
+ );
+ txn_commit txn
+ with
+ | Bdb.DBError s as e ->
+ eplerror 0 e "Fatal database error";
+ raise Sys.Break
+
+ | e ->
+ txn_abort txn;
+ raise e
+
+ (**********************************************************)
+
+ let delete_key_txn ?txn ?hash key =
+ let md = key_to_metadata ?hash key in
+ apply_md_updates_txn ~txn [| md,DeleteKey |]
+
+ (***********************************************************************)
+
+ (** replace [key1] with [key2] in the database *)
+ let swap_keys key1 key2 =
+ let txn = txn_begin () in
+ try
+ delete_key_txn ?txn key1;
+ add_key_txn ?txn key2;
+ (match txn with None -> () | Some txn -> Txn.commit txn [])
+ with
+ | Bdb.DBError s as e ->
+ eplerror 0 e "Fatal database error";
+ raise Sys.Break
+
+ | e ->
+ eplerror 2 e "Keydb.swap_keys -- Aborting transaction";
+ txn_abort txn;
+ raise e
+
+
+ (**********************************************************)
+
+ let delete_key ?hash key =
+ let txn = txn_begin () in
+ try
+ delete_key_txn ?txn key;
+ (match txn with None -> () | Some txn -> Txn.commit txn [])
+ with
+ | Bdb.DBError s as e ->
+ eplerror 0 e "Fatal database error";
+ raise Sys.Break
+
+ | e ->
+ txn_abort txn;
+ eplerror 2 e "Keydb.delete_key -- Aborting transaction";
+ raise e
+
+
+ (**********************************************************)
+
+ (** Operations on metadata *)
+
+ let get_meta key =
+ let dbs = get_dbs () in
+ Db.get dbs.meta key []
+
+ let set_meta_txn ~txn ~key ~data =
+ let dbs = get_dbs () in
+ Db.put ?txn dbs.meta ~key ~data []
+
+ let set_meta ~key ~data =
+ let txn = txn_begin () in
+ try
+ set_meta_txn ~txn ~key ~data;
+ txn_commit txn
+ with
+ | Bdb.DBError s as e ->
+ eplerror 0 e "Fatal database error";
+ raise Sys.Break
+ | e ->
+ txn_abort txn;
+ raise e
+
+ (**********************************************************)
+
+ (** atomically remove all keys on [delete_list] and add key [newkey] *)
+ let replace delete_list newkey =
+ let txn = txn_begin () in
+ try
+ let newkey_update = (key_to_metadata newkey, AddKey) in
+ let delete_updates =
+ List.map ~f:(fun key -> (key_to_metadata key,DeleteKey)) delete_list in
+ apply_md_updates_txn ~txn (Array.of_list (sort_remove (newkey_update::delete_updates)));
+ txn_commit txn
+ with
+ | Bdb.DBError s as e ->
+ eplerror 0 e "Fatal database error";
+ raise Sys.Break
+ | e ->
+ txn_abort txn;
+ raise e
+
+
+ let get_num_keys () =
+ let ctr = ref 0 in
+ keyid_iter ~f:(fun ~keyid ~hash -> incr ctr);
+ !ctr
+
+end
+
+
+module Safe = (Unsafe : RestrictedKeydb)
Added: sks/branches/upstream/sks/current/linearAlg.ml
===================================================================
--- sks/branches/upstream/sks/current/linearAlg.ml (rev 0)
+++ sks/branches/upstream/sks/current/linearAlg.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,349 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+module Unix=UnixLabels
+open Printf
+open ZZp.Infix
+
+exception Bug of string
+exception LayoutMismatch
+
+let rec riter ~f low high =
+ if low >= high then ()
+ else (
+ f low;
+ riter ~f (low + 1) high
+ )
+
+let rec rfind ~f low high =
+ if low >= high then raise Not_found
+ else if f(low) then low
+ else rfind ~f (low + 1) high
+
+
+
+(*********************************************************************)
+(*********************************************************************)
+(*********************************************************************)
+
+module MatrixSlow =
+struct
+
+ type t = { columns: int;
+ rows: int;
+ array: ZZp.zz array;
+ }
+
+ let columns m = m.columns
+ let rows m = m.rows
+ let dims t = (t.columns,t.rows)
+
+ let copy m = { m with array = Array.copy m.array; }
+
+ let make ~columns ~rows init =
+ let array = Array.create (columns * rows) init in
+ { columns = columns;
+ rows = rows;
+ array = array;
+ }
+
+ let init ~columns ~rows ~f =
+ { columns = columns;
+ rows = rows;
+ array =
+ Array.init (columns * rows)
+ ~f:(fun i ->
+ let (i,j) = i mod columns, i / columns in
+ f i j)
+ }
+
+ let get m i j =
+ m.array.(i + j * m.columns)
+
+ let set m i j v =
+ m.array.(i + j * m.columns) <- v
+
+ let scmult_ip m sc =
+ for i = 0 to Array.length m.array - 1 do
+ m.array.(i) <- ZZp.mult m.array.(i) sc
+ done
+
+ let scmult m v =
+ { m with
+ array = Array.map ~f:(fun x -> ZZp.mult v x) m.array
+ }
+
+ let scmult_row m j sc =
+ let start = j * m.columns in
+ for i = 0 to m.columns - 1 do
+ m.array.(start + i) <- ZZp.mult m.array.(start + i) sc
+ done
+
+ let swap_rows m j1 j2 =
+ let start1 = j1 * m.columns
+ and start2 = j2 * m.columns in
+ riter 0 m.columns
+ ~f:(fun i ->
+ let tmp = m.array.(start1 + i) in
+ m.array.(start1 + i) <- m.array.(start2 + i);
+ m.array.(start2 + i) <- tmp)
+
+ let add_ip m1 m2 =
+ if m1.columns <> m2.columns || m1.rows <> m2.rows then
+ raise LayoutMismatch;
+ for i = 0 to Array.length m1.array - 1 do
+ m1.array.(i) <- ZZp.add m1.array.(i) m2.array.(i)
+ done
+
+ let add m1 m2 =
+ if m1.columns <> m2.columns || m1.rows <> m2.rows then
+ raise LayoutMismatch;
+ { m1 with
+ array = Array.init (m1.columns * m1.rows)
+ ~f:(fun i -> ZZp.add m1.array.(i) m2.array.(i))
+ }
+
+ let rec idot_rec m1 m2 ~i ~pos1 ~pos2 sum =
+ if i >= m1.columns then sum
+ else
+ idot_rec m1 m2 ~i:(i+1) ~pos1:(pos1 + 1) ~pos2:(pos2 + m2.columns)
+ (ZZp.add sum (ZZp.mult m1.array.(pos1) m2.array.(pos2)))
+
+ let idot m1 m2 i j =
+ idot_rec m1 m2 ~i:0 ~pos1:(m1.columns * i) ~pos2:j ZZp.zero
+
+ let mult m1 m2 =
+ if m1.columns <> m2.rows then
+ raise LayoutMismatch;
+ init ~columns:m2.columns ~rows:m1.rows
+ ~f:(fun i j -> idot m1 m2 i j)
+
+
+ let transpose m =
+ init ~columns:m.rows ~rows:m.columns ~f:(fun i j -> get m j i)
+
+
+ let rowadd m ~src ~dst ~scmult =
+ for i = 0 to m.columns - 1 do
+ let newval = ZZp.add (ZZp.mult (get m i src) scmult) (get m i dst) in
+ set m i dst newval
+ done
+
+ let rowsub m ~src ~dst ~scmult =
+ if scmult <>: ZZp.one then
+ for i = 0 to m.columns - 1 do
+ let sval = get m i src in
+ if sval <>: ZZp.zero then
+ let newval = ZZp.sub (get m i dst) (ZZp.mult_fast sval scmult) in
+ set m i dst newval
+ done
+ else
+ for i = 0 to m.columns - 1 do
+ let sval = get m i src in
+ if sval <>: ZZp.zero then
+ let newval = ZZp.sub (get m i dst) sval in
+ set m i dst newval
+ done
+
+ let print m =
+ for j = 0 to m.rows - 1 do
+ print_string "| ";
+ for i = 0 to m.columns - 1 do
+ ZZp.print (get m i j);
+ print_string " "
+ done;
+ print_string " |\n"
+ done
+
+end
+
+(*********************************************************************************)
+(*********************************************************************************)
+(*********************************************************************************)
+
+(* Does everything in-place, using the in-place numerix operators *)
+module Matrix =
+struct
+
+ type t = { columns: int;
+ rows: int;
+ array: ZZp.zzref array;
+ }
+
+ let columns m = m.columns
+ let rows m = m.rows
+ let dims t = (t.columns,t.rows)
+
+ let copy m = { m with array = Array.copy m.array; }
+
+ let init ~columns ~rows ~f =
+ { columns = columns;
+ rows = rows;
+ array =
+ Array.init (columns * rows)
+ ~f:(fun i ->
+ let (i,j) = i mod columns, i / columns in
+ ZZp.make_ref (f i j))
+ }
+
+ let make ~columns ~rows x =
+ init ~columns ~rows ~f:(fun i j -> x)
+
+ let lget m i j =
+ ZZp.look (m.array.(i + j * m.columns))
+
+ let rget m i j =
+ m.array.(i + j * m.columns)
+
+ let get m i j = ZZp.copy_out m.array.(i + j * m.columns)
+
+ let set m i j v =
+ ZZp.copy_in m.array.(i + j * m.columns) v
+
+ let scmult_row ?(scol=0) m j sc =
+ let start = j * m.columns in
+ for i = scol to m.columns - 1 do
+ let v = m.array.(start + i) in
+ ZZp.mult_in v (ZZp.look v) sc
+ done
+
+ let swap_rows m j1 j2 =
+ let start1 = j1 * m.columns
+ and start2 = j2 * m.columns in
+ riter 0 m.columns
+ ~f:(fun i ->
+ let tmp = ZZp.copy_out m.array.(start1 + i) in
+ ZZp.copy_in m.array.(start1 + i) (ZZp.look m.array.(start2 + i));
+ ZZp.copy_in m.array.(start2 + i) tmp)
+
+ let transpose m =
+ init ~columns:m.rows ~rows:m.columns ~f:(fun i j -> lget m j i)
+
+ let rowsub ?(scol=0) m ~src ~dst ~scmult =
+ if scmult <>: ZZp.one then
+ for i = scol to m.columns - 1 do
+ let sval = rget m i src in
+ if ZZp.look sval <>: ZZp.zero then
+ let v = rget m i dst in
+ ZZp.sub_in v (ZZp.look v) (ZZp.mult_fast (ZZp.look sval) scmult)
+ done
+ else
+ for i = scol to m.columns - 1 do
+ let sval = rget m i src in
+ if ZZp.look sval <>: ZZp.zero then
+ let v = rget m i dst in
+ ZZp.sub_in v (ZZp.look v) (ZZp.look sval)
+ done
+
+ let print m =
+ for j = 0 to m.rows - 1 do
+ print_string "| ";
+ for i = 0 to m.columns - 1 do
+ ZZp.print (lget m i j);
+ print_string " "
+ done;
+ print_string " |\n"
+ done
+
+end
+
+
+(*********************************************************************************)
+(*********************************************************************************)
+(*********************************************************************************)
+
+(****** Gauss-Jordan Reduction *****************)
+
+let process_row m j =
+ try
+ let v =
+ let v = Matrix.rget m j j in
+ if ZZp.look v <>: ZZp.zero then v
+ else
+ let jswap =
+ try
+ rfind (j + 1) (Matrix.rows m)
+ ~f:(fun jswap -> Matrix.lget m j jswap <>: ZZp.zero)
+ with Not_found -> raise Exit
+ in
+ Matrix.swap_rows m j jswap;
+ Matrix.rget m j j
+ in
+ if ZZp.look v <>: ZZp.one then Matrix.scmult_row m j (ZZp.inv (ZZp.look v));
+ for j2 = 0 to Matrix.rows m - 1 do
+ if j2 <> j
+ then Matrix.rowsub m ~src:j ~dst:j2 ~scmult:(Matrix.get m j j2)
+ done
+ with
+ Exit -> ()
+
+let reduce m =
+ let (columns,rows) = Matrix.dims m in
+ if columns < rows then raise (Bug "Matrix is too narrow to reduce");
+ for j = 0 to Matrix.rows m - 1 do
+ process_row m j;
+ done
+
+
+(****** Gaussian Reduction *****************)
+
+let process_row_forward m j =
+ try
+ let v =
+ let v = Matrix.rget m j j in
+ if ZZp.look v <>: ZZp.zero then v
+ else
+ let jswap =
+ try
+ rfind (j + 1) (Matrix.rows m)
+ ~f:(fun jswap -> Matrix.lget m j jswap <>: ZZp.zero)
+ with Not_found -> raise Exit
+ in
+ Matrix.swap_rows m j jswap;
+ Matrix.rget m j j
+ in
+ if ZZp.look v <>: ZZp.one then Matrix.scmult_row ~scol:j m j (ZZp.inv (ZZp.look v));
+ for j2 = j + 1 to Matrix.rows m - 1 do
+ Matrix.rowsub ~scol:j m ~src:j ~dst:j2 ~scmult:(Matrix.get m j j2)
+ done
+ with
+ Exit -> ()
+
+let backsubstitute m j =
+ if Matrix.lget m j j =: ZZp.one
+ then (
+ let last = Matrix.rows m - 1 in
+ for j2 = j - 1 downto 0 do
+ Matrix.rowsub ~scol:last m ~src:j ~dst:j2 ~scmult:(Matrix.get m j j2);
+ Matrix.set m j j2 ZZp.zero
+ done
+ )
+
+let greduce m =
+ let (columns,rows) = Matrix.dims m in
+ if columns < rows then raise (Bug "Matrix is too narrow to reduce");
+ for j = 0 to Matrix.rows m - 1 do
+ process_row_forward m j;
+ done;
+ for j = Matrix.rows m - 1 downto 1 do
+ backsubstitute m j;
+ done
+
+
+let reduce = greduce
Added: sks/branches/upstream/sks/current/logdump.ml
===================================================================
--- sks/branches/upstream/sks/current/logdump.ml (rev 0)
+++ sks/branches/upstream/sks/current/logdump.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,63 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+open Printf
+open Common
+open Packet
+module Unix = UnixLabels
+open Unix
+open DbMessages
+
+module Keydb = Keydb.Make(struct
+ let withtxn = !Settings.transactions
+ and cache_bytes = !Settings.cache_bytes
+ and pagesize = !Settings.pagesize
+ and dbdir = !Settings.dbdir
+ and dumpdir = !Settings.dumpdir
+ end)
+
+let print_entry (time,event) =
+ let tm = Unix.localtime time in
+ printf "%04d-%02d-%02d %02d:%02d:%02d "
+ (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1)
+ tm.Unix.tm_mday (* date *)
+ tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec;
+ (match event with
+ | Add hash -> printf "Add %s" (KeyHash.hexify hash)
+ | Delete hash -> printf "Del %s" (KeyHash.hexify hash)
+ );
+ printf "\n"
+
+let rec last list = match list with
+ [] -> raise Not_found
+ | [x] -> x
+ | hd::tl -> last tl
+
+let rec printlog ts =
+ let entries = Keydb.logquery ts in
+ if entries = [] then ()
+ else
+ let (new_ts,_) = last entries in
+ List.iter entries ~f:print_entry;
+ printlog new_ts
+
+
+let () =
+ Keydb.open_dbs ();
+ printlog 0.
Added: sks/branches/upstream/sks/current/mArray.ml
===================================================================
--- sks/branches/upstream/sks/current/mArray.ml (rev 0)
+++ sks/branches/upstream/sks/current/mArray.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,111 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Various array operations *)
+open StdLabels
+open MoreLabels
+
+
+let to_string ~f array =
+ let buf = Buffer.create ((Array.length array) * 5) in
+ Buffer.add_string buf "[| ";
+ Array.iter ~f:(fun el ->
+ Buffer.add_string buf (f el);
+ Buffer.add_string buf " "; )
+ array;
+ Buffer.add_string buf "|]";
+ Buffer.contents buf
+
+let print ~f array =
+ print_string "[| ";
+ Array.iter ~f:(fun el ->
+ f el;
+ print_string " ")
+
+ array;
+ print_string "|]"
+
+
+
+(************************************************************************)
+(* START: Array Operations *********************************************)
+(************************************************************************)
+
+let all_true array =
+ Array.fold_left ~f:(&&) ~init:true array
+
+let for_all ~f:test array =
+ Array.fold_left ~f:(fun a b -> a && (test b)) ~init:true array
+
+let exists ~f:test array =
+ Array.fold_left ~f:(fun a b -> a or (test b)) ~init:false array
+
+let mem el array =
+ let length = Array.length array in
+ let rec mem i el array =
+ if i >= length then false
+ else if el = array.(i) then true
+ else mem (i+1) el array
+ in mem 0 el array
+
+
+let choose_best best_chooser array =
+ let n = Array.length array in
+ let rec choose_best ~i ~best =
+ if i = n then best
+ else choose_best ~i:(i+1) ~best:(best_chooser best array.(i))
+ in
+ if Array.length array < 1
+ then raise (Failure "Attempt to get best element of empty array")
+ else choose_best ~i:1 ~best:array.(0)
+
+let max ar = choose_best max ar
+let min ar = choose_best min ar
+
+let count ~f array =
+ Array.fold_left ~f:(fun count el ->
+ if f el then count + 1
+ else count)
+ ~init:0 array
+
+let count_true array =
+ let n = Array.length array in
+ let rec count_true array ~i ~partial =
+ if i >= n then partial
+ else count_true array ~i:(i+1)
+ ~partial:(if array.(i) then partial + 1 else partial)
+ in count_true array ~i:0 ~partial:0
+
+let average array =
+ let sum = Array.fold_left ~f:(+.) ~init:0.0 array in
+ sum /. (float_of_int (Array.length array))
+
+let iaverage array =
+ average (Array.map ~f:(fun i -> float_of_int i) array)
+
+let median array =
+ let n = Array.length array in
+ let sorted_array = Array.copy array in
+ Array.stable_sort ~cmp:compare sorted_array;
+ array.(n/2)
+
+let zip array1 array2 =
+ if Array.length array1 <> Array.length array2
+ then failwith "Zipping arrays of different lengths"
+ else Array.init (Array.length array1) ~f:(fun i -> (array1.(i), array2.(i)))
+
+
Added: sks/branches/upstream/sks/current/mArray.mli
===================================================================
--- sks/branches/upstream/sks/current/mArray.mli (rev 0)
+++ sks/branches/upstream/sks/current/mArray.mli 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,33 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+val to_string : f:('a -> string) -> 'a array -> string
+val print : f:('a -> 'b) -> 'a array -> unit
+
+val all_true : bool array -> bool
+val for_all : f:('a -> bool) -> 'a array -> bool
+val exists : f:('a -> bool) -> 'a array -> bool
+val mem : 'a -> 'a array -> bool
+val choose_best : ('a -> 'a -> 'a) -> 'a array -> 'a
+val max : 'a array -> 'a
+val min : 'a array -> 'a
+val count : f:('a -> bool) -> 'a array -> int
+val count_true : bool array -> int
+val average : float array -> float
+val iaverage : int array -> float
+val median : 'a array -> 'a
+val zip : 'a array -> 'b array -> ('a * 'b) array
Added: sks/branches/upstream/sks/current/mList.ml
===================================================================
--- sks/branches/upstream/sks/current/mList.ml (rev 0)
+++ sks/branches/upstream/sks/current/mList.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,303 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Various list operations *)
+open StdLabels
+open MoreLabels
+
+open Printf
+
+(************************************************************************)
+(* START: List Operations **********************************************)
+(************************************************************************)
+
+(****** Numeric *************)
+let average list =
+ let sum = List.fold_left ~f:(+.) ~init:0.0 list in
+ sum /. (float_of_int (List.length list))
+
+let iaverage list =
+ let sum = List.fold_left ~f:(+) ~init:0 list in
+ (float sum) /. (float (List.length list))
+
+
+(****** Initialization *************)
+
+let init n ~f =
+ let rec list_init ~n ~partial =
+ match n with
+ 0 -> partial
+ | _ -> list_init ~n:(n-1) ~partial:((f (n-1))::partial)
+ in list_init ~n ~partial:[]
+
+let init_by_value n ~value =
+ let rec init_list_rec n value partial = match n with
+ 0 -> partial
+ | _ -> init_list_rec (n - 1) value (value::partial)
+ in init_list_rec n value []
+
+
+(******** Printing *****************)
+
+let to_string ~f list =
+ let buf = Buffer.create ((List.length list) * 5) in
+ Buffer.add_string buf "[ ";
+ List.iter ~f:(fun el ->
+ Buffer.add_string buf (f el);
+ Buffer.add_string buf " "; )
+ list;
+ Buffer.add_string buf "]";
+ Buffer.contents buf
+
+let print ~f list =
+ let rec print_list_rec list = match list with
+ [] -> ()
+ | hd::tl ->
+ f hd;
+ print_string " ";
+ print_list_rec tl
+ in
+ print_string "[ ";
+ print_list_rec list;
+ print_string "]"
+
+let print_int_list = print ~f:(printf "%d ")
+
+let print2 ~f list =
+ let rec print_list_rec list = match list with
+ [] -> ()
+ | hd::tl ->
+ f hd;
+ print_string "\n ";
+ print_list_rec tl
+ in
+ print_string "[ ";
+ print_list_rec list;
+ print_string " ]"
+
+(***********************************************)
+
+
+
+let rec swap_pairs_rec list partial = match list with
+ [] -> partial
+| (a,b)::tail -> swap_pairs_rec tail ( (b,a)::partial )
+
+let swap_pairs list = swap_pairs_rec list []
+
+(* tail recursive, constructs list from
+ lower_bound (incl) to upper_bound (excl) *)
+let range lower_bound upper_bound =
+ let rec range_rec lower_bound upper_bound list =
+ if lower_bound = upper_bound
+ then list
+ else range_rec lower_bound (upper_bound-1) ((upper_bound -1)::list)
+ in range_rec lower_bound upper_bound []
+
+let srange ?(step=1) lower_bound upper_bound =
+ let rec range lower_bound partial =
+ if lower_bound >= upper_bound
+ then partial
+ else range (lower_bound + step) (lower_bound::partial)
+ in List.rev(range lower_bound [])
+
+let rand_elem list =
+ if (List.length list) = 0
+ then raise (Failure "attempt to select random element of empty list")
+ else List.nth list (Random.int (List.length list))
+
+(* return list with first element dropped *)
+let omit_first list = match list with
+ [] -> raise (Failure "attempt to drop element from empty list")
+| hd::tl -> tl;;
+
+(* return list with kth element dropped *)
+let rec drop_kth ~k list = match list, k with
+ [],_ -> []
+ | list,0 -> omit_first list
+ | hd::tail,k -> hd::(drop_kth ~k:(k-1) tail)
+
+(* return list with only the first k elements *)
+let first_k ~k list =
+ let rec first_k_rec list k partial = match list,k with
+ [],_ -> partial
+ | _,0 -> partial
+ | hd::tl,k -> first_k_rec tl (k-1) (hd::partial)
+ in List.rev (first_k_rec list k [])
+
+let k_split ~k ~list =
+ let rec k_split ~k part1 part2 =
+ if k = 0 then (part1, part2)
+ else (
+ match part2 with
+ [] -> (part1,[])
+ | hd::tail -> k_split ~k:(k-1) (hd::part1) tail
+ )
+ in
+ let (part1, part2) = k_split ~k [] list
+ in (List.rev part1, part2)
+
+
+let rec last_elem list = match list with
+ [] -> raise (Failure "Attempt to get end of empty list")
+ | [hd] -> hd
+ | hd::tl -> last_elem tl
+
+let rec last_k ~k list = match list with
+ [] -> []
+| hd::tl -> if k >= (List.length list)
+ then list
+ else last_k tl ~k
+
+(* return list with all but first k *)
+let rec drop_k ~k list = match list, k with
+ [],_ -> []
+| list,0 -> list
+| hd::tail,k -> drop_k tail ~k:(k-1)
+
+let drop_last_k ~k list =
+ let rec drop_rec list k partial =
+ if (List.length list) <= k
+ then partial
+ else match list with
+ [] -> raise (Failure "drop_last_k: Unexpected error")
+ | hd::tl -> drop_rec tl k (hd::partial)
+ in List.rev (drop_rec list k [])
+
+let drop_last list = drop_last_k ~k:1 list
+
+let all_true list =
+ List.fold_left ~f:(fun a b -> a && b) ~init:true list
+
+let pri_split pri list =
+ let rec pri_split_rec list low exact high = match list with
+ [] -> (low,exact,high)
+ | ((el_pri,_) as hd)::tl ->
+ if el_pri < pri then pri_split_rec tl (hd::low) exact high
+ else if el_pri > pri then pri_split_rec tl low exact (hd::high)
+ else pri_split_rec tl low (hd::exact) high
+ in let (low,exact,high)= pri_split_rec list [] [] [] in
+ assert ( (List.length low) + (List.length exact) + (List.length high) =
+ (List.length list) );
+ (low,exact,high)
+
+let has_dups list =
+ let slist = Sort.list (fun x y -> x < y) list in
+ let rec dup_scan list = match list with
+ [] -> false
+ | hd::[] -> false
+ | hd1::hd2::tl -> if hd1 = hd2 then true else dup_scan (hd2::tl)
+ in dup_scan slist
+
+let dedup list =
+ let slist = Sort.list (fun x y -> x < y) list in
+ let rec dedup ~list ~partial = match list with
+ [] -> partial
+ | hd::[] -> dedup ~list:[] ~partial:(hd::partial)
+ | hd1::hd2::tl ->
+ if hd1 = hd2
+ then dedup ~list:(hd2::tl) ~partial
+ else dedup ~list:(hd2::tl) ~partial:(hd1::partial)
+ in List.rev (dedup ~list:slist ~partial:[]);;
+
+let choose_best ~f:best_chooser list =
+ let rec choose_best ~list best_so_far =
+ match list with
+ [] -> best_so_far
+ | hd::tl -> choose_best ~list:tl (best_chooser hd best_so_far)
+ in match list with
+ [] -> raise (Failure "Attempt to get best element of empty list")
+ | hd::tl -> choose_best ~list:tl hd
+
+let count_true list =
+ let rec count_true list partial = match list with
+ [] -> partial
+ | hd::tl -> count_true tl (partial + if hd then 1 else 0)
+ in count_true list 0
+
+let max list = choose_best ~f:max list
+let min list = choose_best ~f:min list
+
+
+(******************************************************)
+(*** Some functions that should be in module List ... *)
+(******************************************************)
+
+(* UNTESTED *)
+let rec iteri_rec ~f list i = match list with
+ [] -> ()
+ | hd::tl -> f ~i hd; iteri_rec ~f tl (i+1)
+
+let iteri ~f list =
+ iteri_rec ~f list 0
+
+(******************************************************)
+
+(* UNTESTED *)
+let rec mapi_rec ~f list i partial = match list with
+ [] -> partial
+ | hd::tl -> mapi_rec ~f tl (i+1) ((f ~i hd)::partial)
+
+let mapi ~f list =
+ List.rev (mapi_rec ~f list 0 [])
+
+(******************************************************)
+
+let map ~f list = List.rev (List.rev_map ~f list)
+
+(******************************************************)
+
+(* UNTESTED *)
+let rec filteri_rec ~f list i partial = match list with
+ [] -> partial
+ | hd::tl ->
+ if f ~i hd
+ then filteri_rec ~f tl (i+1) (hd::partial)
+ else filteri_rec ~f tl (i+1) partial
+
+let filteri ~f list =
+ List.rev (filteri_rec ~f list 0 [])
+
+(******************************************************)
+
+let find_index el list =
+ let rec find_index list loc = match list with
+ [] -> -1
+ | hd::tl ->
+ if hd = el then loc
+ else find_index tl (loc + 1)
+ in
+ find_index list 0
+
+let cons_opt opt list = match opt with
+ None -> list
+ | Some x -> x::list
+
+let strip_opt list =
+ let rec loop list stripped = match list with
+ [] -> List.rev stripped
+ | None::tl -> loop tl stripped
+ | (Some x)::tl -> loop tl (x::stripped)
+ in
+ loop list []
+
+let rec reduce ~f list = match list with
+ [] -> failwith "MList.reduce: list has two few elements"
+ | hd::tl -> List.fold_left ~f tl ~init:hd
+
+
+
Added: sks/branches/upstream/sks/current/mList.mli
===================================================================
--- sks/branches/upstream/sks/current/mList.mli (rev 0)
+++ sks/branches/upstream/sks/current/mList.mli 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,59 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+val average : float list -> float
+val iaverage : int list -> float
+val init : int -> f:(int -> 'a) -> 'a list
+val init_by_value : int -> value:'a -> 'a list
+
+val to_string : f:('a -> string) -> 'a list -> string
+val print_int_list : int list -> unit
+val print : f:('a -> 'b) -> 'a list -> unit
+val print2 : f:('a -> 'b) -> 'a list -> unit
+
+val swap_pairs_rec : ('a * 'b) list -> ('b * 'a) list -> ('b * 'a) list
+val swap_pairs : ('a * 'b) list -> ('b * 'a) list
+val range : int -> int -> int list
+val srange : ?step:int -> int -> int -> int list
+val rand_elem : 'a list -> 'a
+val omit_first : 'a list -> 'a list
+val drop_kth : k:int -> 'a list -> 'a list
+val first_k : k:int -> 'a list -> 'a list
+val k_split : k:int -> list:'a list -> 'a list * 'a list
+val last_elem : 'a list -> 'a
+val last_k : k:int -> 'a list -> 'a list
+val drop_k : k:int -> 'a list -> 'a list
+val drop_last_k : k:int -> 'a list -> 'a list
+val drop_last : 'a list -> 'a list
+val all_true : bool list -> bool
+val pri_split : 'a -> ('a * 'b) list -> ('a * 'b) list * ('a * 'b) list * ('a * 'b) list
+val has_dups : 'a list -> bool
+val dedup : 'a list -> 'a list
+val choose_best : f:('a -> 'a -> 'a) -> 'a list -> 'a
+val count_true : bool list -> int
+val max : 'a list -> 'a
+val min : 'a list -> 'a
+
+val iteri : f:(i:int -> 'a -> 'b) -> 'a list -> unit
+val mapi : f:(i:int -> 'a -> 'b) -> 'a list -> 'b list
+val map : f:('a -> 'b) -> 'a list -> 'b list
+val filteri : f:(i:int -> 'a -> bool) -> 'a list -> 'a list
+
+val find_index : 'a -> 'a list -> int
+val cons_opt : 'a option -> 'a list -> 'a list
+val strip_opt : 'a option list -> 'a list
+val reduce : f : ( 'a -> 'a -> 'a ) -> 'a list -> 'a
Added: sks/branches/upstream/sks/current/mRindex.ml
===================================================================
--- sks/branches/upstream/sks/current/mRindex.ml (rev 0)
+++ sks/branches/upstream/sks/current/mRindex.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,135 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Code for generating machine-readable index *)
+
+open StdLabels
+open MoreLabels
+open Printf
+
+open Common
+open Packet
+
+let mr_version = 1
+
+(** Does escaping of uid strings *)
+let escape_uid_string string =
+ let buf = Buffer.create (String.length string) in
+ for i = 0 to String.length string - 1 do
+ if string.[i] = '%' then (
+ Buffer.add_char buf '%';
+ Buffer.add_char buf string.[i]
+ )
+ else if int_of_char string.[i] >= 128 || string.[i] = ':' then
+ let v = int_of_char string.[i] in
+ Buffer.add_string buf (sprintf "%%%X" v)
+ else
+ Buffer.add_char buf string.[i]
+ done;
+ Buffer.contents buf
+
+let get_signature_keyid sign =
+ match sign with
+ | V3sig s -> Some s.v3s_keyid
+ | V4sig s ->
+ let issuer_subpackets =
+ List.filter ~f:(fun ssp -> ssp.ssp_type = 16)
+ (s.v4s_hashed_subpackets @ s.v4s_unhashed_subpackets)
+ in
+ match issuer_subpackets with
+ | [ssp] ->
+ if String.length ssp.ssp_body = 8
+ then Some ssp.ssp_body else None
+ | _ -> None
+
+
+let get_sigtype sign = match sign with
+ V3sig sign -> sign.v3s_sigtype | V4sig sign -> sign.v4s_sigtype
+
+let get_self_sigs keyid sigs =
+ let sigs = List.map ~f:ParsePGP.parse_signature sigs in
+ List.filter
+ ~f:(fun sign ->
+ (match int_to_sigtype (get_sigtype sign) with
+ | Generic_certification_of_a_User_ID_and_Public_Key_packet
+ | Persona_certification_of_a_User_ID_and_Public_Key_packet
+ | Casual_certification_of_a_User_ID_and_Public_Key_packet
+ | Positive_certification_of_a_User_ID_and_Public_Key_packet
+ -> true
+ | _ -> false) &&
+ (match get_signature_keyid sign with
+ | Some sig_keyid -> sig_keyid = keyid
+ | None -> false)
+ )
+ sigs
+
+let time_to_string time = match time with
+ | None -> ""
+ | Some x -> sprintf "%Ld" x
+
+let uid_to_line keyid uid_packet sigs =
+ let uid_string = escape_uid_string uid_packet.packet_body in
+ let sigs = get_self_sigs keyid sigs in
+ let times = List.map ~f:ParsePGP.get_times sigs in
+ let (ctime,exptime) =
+ List.fold_left ~init:(None,None) ~f:max times
+ in
+ sprintf "uid:%s:%s:%s:"
+ uid_string (time_to_string ctime) (time_to_string exptime)
+
+(** number of seconds in a day *)
+let daysecs = Int64.of_int (60 * 60 * 24)
+
+let key_to_lines key =
+ let full_keyid = Fingerprint.keyid_from_key ~short:false key in
+ let keyid = Fingerprint.keyid_to_string ~short:true full_keyid in
+ let pkey = KeyMerge.key_to_pkey key in
+ let key_packet = pkey.KeyMerge.key in
+ let pki = ParsePGP.parse_pubkey_info key_packet in
+ let uids = pkey.KeyMerge.uids in
+ let exp_string = match pki.pk_expiration with
+ | None -> ""
+ | Some 0 -> "-"
+ | Some days -> sprintf "%Ld"
+ (Int64.add pki.pk_ctime (Int64.mul daysecs (Int64.of_int days)))
+ in
+ let key_line = sprintf "pub:%s:%d:%d:%Ld:%s:%s"
+ keyid
+ pki.pk_alg
+ pki.pk_keylen
+ pki.pk_ctime
+ exp_string
+ (if (Index.is_revoked key) then "r" else "")
+ in
+ let uid_lines =
+ List.map ~f:(fun (uid,sigs) ->
+ match uid.packet_type with
+ User_ID_Packet -> uid_to_line full_keyid uid sigs
+ | User_Attribute_Packet -> "uat::::"
+ | _ -> "???::::"
+ ) uids
+ in
+ key_line::uid_lines
+
+
+let keys_to_lines keys =
+ let first = sprintf "info:%d:%d" mr_version (List.length keys) in
+ let keylines = List.concat (List.map ~f:key_to_lines keys) in
+ first::keylines
+
+let keys_to_index keys =
+ (String.concat ~sep:"\n" (keys_to_lines keys)) ^ "\n"
Added: sks/branches/upstream/sks/current/mTimer.ml
===================================================================
--- sks/branches/upstream/sks/current/mTimer.ml (rev 0)
+++ sks/branches/upstream/sks/current/mTimer.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,53 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Simple timer module *)
+open StdLabels
+open MoreLabels
+
+type t = { mutable start_time : float;
+ mutable stop_time : float;
+ mutable running : bool;
+ }
+
+let create () = { start_time = 0.0;
+ stop_time = 0.0;
+ running = false;
+ }
+
+let reset timer =
+ timer.start_time <- 0.0;
+ timer.stop_time <- 0.0;
+ timer.running <- false
+
+let start timer =
+ ( timer.start_time <- Unix.gettimeofday ();
+ timer.running <- true )
+
+let stop timer =
+ if not timer.running then failwith "Timer stopped when not running."
+ else ( timer.stop_time <- Unix.gettimeofday ();
+ timer.running <- false )
+
+let read timer =
+ if timer.running
+ then failwith "Timer read at wrong time"
+ else timer.stop_time -. timer.start_time
+
+let read_ms timer = 1000.0 *. (read timer)
+let read_us timer = (1000.0 *. 1000.0) *. (read timer)
+
Added: sks/branches/upstream/sks/current/mTimer.mli
===================================================================
--- sks/branches/upstream/sks/current/mTimer.mli (rev 0)
+++ sks/branches/upstream/sks/current/mTimer.mli 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,25 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+type t
+val create : unit -> t
+val start : t -> unit
+val stop : t -> unit
+val reset : t -> unit
+val read : t -> float
+val read_us : t -> float
+val read_ms : t -> float
Added: sks/branches/upstream/sks/current/mailsync.ml
===================================================================
--- sks/branches/upstream/sks/current/mailsync.ml (rev 0)
+++ sks/branches/upstream/sks/current/mailsync.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,110 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Code for reading in and processing files received from
+ PKS-style email-based sync *)
+open Common
+open StdLabels
+open MoreLabels
+open Printf
+
+
+let max_filesize = 200 * 1024
+let input_msg f =
+ let b = Buffer.create (min max_filesize (in_channel_length f)) in
+ Buffer.add_channel b f (in_channel_length f);
+ Buffer.contents b
+
+
+let dirname = "messages"
+
+let lsdir dir =
+ let dirhandle = Unix.opendir dir in
+ let run () =
+ let rec loop accum =
+ match (try Some (Unix.readdir dirhandle)
+ with End_of_file -> None)
+ with
+ Some fname -> loop (fname::accum)
+ | None -> accum
+ in
+ List.map ~f:(Filename.concat dir) (loop [])
+ in
+ protect ~f:run ~finally:(fun () -> Unix.closedir dirhandle)
+
+(** reads specified mail file and returns key if any *)
+let load_message fname =
+ let file = open_in fname in
+ let run () =
+ let text = input_msg file in
+ (*let msg = Recvmail.parse text in
+ msg.Sendmail.body *)
+ text
+ in
+ protect ~f:run ~finally:(fun () -> close_in file)
+
+
+let get_mtime fname = (Unix.stat fname).Unix.st_mtime
+
+let demote fname =
+ if Sys.file_exists fname then
+ let destdir = Lazy.force Settings.failed_msgdir in
+ if not (Sys.file_exists destdir) then
+ Unix.mkdir destdir 0o700;
+ Sys.rename fname (Filename.concat destdir (Filename.basename fname))
+
+(****************************************************************************)
+(* Event Handlers **********************************************************)
+(****************************************************************************)
+
+(** read any mails in queue directory, process them, and remove them *)
+let rec load_mailed_keys ~addkey () =
+ plerror 7 "checking for key emails";
+ let files = try lsdir (Lazy.force Settings.msgdir) with Unix.Unix_error _ -> [] in
+ let ready_files =
+ List.filter ~f:(fun file -> Filename.check_suffix file ".ready") files
+ in
+ List.iter ready_files
+ ~f:(fun fname ->
+ try
+ let text = load_message fname in
+ let keys = Armor.decode_pubkey text in
+ plerror 3 "Adding list of %d keys from file %s"
+ (List.length keys) fname;
+ List.iter
+ ~f:(fun origkey ->
+ try
+ let key = Fixkey.canonicalize origkey in
+ addkey key
+ with
+ Bdb.Key_exists -> ()
+ | Fixkey.Bad_key ->
+ plerror 2 "Fixkey.canonicalize couldn't parse key %s"
+ (KeyHash.hexify (KeyHash.hash origkey))
+ )
+ keys;
+ Sys.remove fname
+ with
+ | Eventloop.SigAlarm | Sys.Break as e -> raise e
+ | e ->
+ eplerror 2 e "Failure adding keys from file %s. %s"
+ fname "Moving to failed_messages.";
+ demote fname
+ );
+ []
+
+
Added: sks/branches/upstream/sks/current/membership.ml
===================================================================
--- sks/branches/upstream/sks/current/membership.ml (rev 0)
+++ sks/branches/upstream/sks/current/membership.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,229 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Simple module for loading membership information. Currently only loads
+ membership from membership file.
+ @author Yaron M. Minsky
+*)
+open StdLabels
+open MoreLabels
+module Unix=UnixLabels
+open Printf
+open Scanf
+open Common
+
+exception Bug of string
+exception Lookup_failure of string
+exception Malformed_entry of string
+exception Empty_line
+
+let membership = ref ([| |],-1.)
+
+let whitespace = Str.regexp "[ \t]+"
+
+let lookup_hostname string service =
+ Unix.getaddrinfo string service [Unix.AI_SOCKTYPE Unix.SOCK_STREAM]
+
+let local_recon_addr () =
+ lookup_hostname !Settings.hostname (string_of_int recon_port)
+
+let local_recon_addr = Utils.unit_memoize local_recon_addr
+
+let convert_address l =
+ try
+ if String.length l = 0 then raise Empty_line else
+ sscanf l "%s %s"
+ (fun addr service ->
+ if addr = "" || service = "" then failwith "Blank line";
+ addr, service)
+ with
+ Scanf.Scan_failure _ | End_of_file | Failure _ -> raise (Malformed_entry l)
+
+let load_membership_file file =
+ let rec loop list =
+ try
+ let line = decomment (input_line file) in
+ let addr = convert_address line in
+ addr :: loop list
+ with
+ | Empty_line -> loop list
+ | End_of_file -> list
+ | Malformed_entry line ->
+ perror "Malformed entry %s" line;
+ loop list
+ in
+ loop []
+
+let get_mtime fname =
+ try
+ if Sys.file_exists fname
+ then Some (Unix.stat fname).Unix.st_mtime
+ else None
+ with
+ Unix.Unix_error _ -> None
+
+let load_membership fname =
+ let file = open_in fname in
+ protect ~f:(fun () ->
+ load_membership_file file)
+ ~finally:(fun () -> close_in file)
+
+let ai_to_string = function
+ | { Unix.ai_addr = Unix.ADDR_UNIX s } -> sprintf "<ADDR_UNIX %s>" s
+ | { Unix.ai_addr = Unix.ADDR_INET (addr,p) } -> sprintf "<ADDR_INET [%s]:%d>"
+ (Unix.string_of_inet_addr addr) p
+
+let ai_list_to_string ai_list =
+ "[" ^ (String.concat ~sep:", " (List.map ~f:ai_to_string ai_list)) ^ "]"
+
+let membership_string () =
+ let (mshp,_) = !membership in
+ let to_string (addr, (host, service)) =
+ sprintf "(%s %s)%s" host service (ai_list_to_string addr)
+ in
+ let strings = List.map ~f:to_string (Array.to_list mshp) in
+ "Membership: " ^ String.concat ~sep:", " strings
+
+(* Refresh member n's address *)
+let refresh_member members n =
+ match members.(n) with
+ (addr, (host, service as line)) ->
+ let fresh_addr = lookup_hostname host service in
+ if addr <> fresh_addr then begin
+ members.(n) <- (fresh_addr, line);
+ plerror 3 "address for %s:%s changed from %s to %s"
+ host service (ai_list_to_string addr) (ai_list_to_string fresh_addr)
+ end
+
+let reload_if_changed () =
+ let fname = Lazy.force Settings.membership_file in
+ let (mshp,old_mtime) = !membership in
+ match get_mtime fname with
+ | None ->
+ plerror 2 "%s" ("Unable to get mtime for membership file. " ^
+ "Can't decide whether to reload")
+ | Some mtime ->
+ if old_mtime <> mtime then
+ ( let memberlines = load_membership fname in
+ let old = Array.to_list mshp in
+ let f line =
+ try
+ List.find ~f:(fun (_, old_line) -> line = old_line) old
+ with
+ Not_found -> ([], line)
+ in
+ let merged = Array.of_list (List.map ~f memberlines) in
+ membership := (merged, mtime);
+ plerror 5 "%s" (membership_string ());
+ (* Try to lookup unknown names *)
+ Array.iteri
+ ~f:(fun i mb -> if fst mb = [] then refresh_member merged i)
+ merged
+ )
+
+let get_names () =
+ let file = Lazy.force Settings.membership_file in
+ let mshp =
+ if not (Sys.file_exists file) then [||]
+ else (
+ reload_if_changed ();
+ let (m,_) = !membership in
+ m
+ )
+ in
+ Array.map ~f:(function (_, (host, service)) -> host ^ " " ^ service) mshp
+
+
+let reset_membership_time () =
+ let (m,mtime) = !membership in
+ membership := (m,0.)
+
+let same_inet_addr addr1 addr2 =
+ match (addr1,addr2) with
+ (Unix.ADDR_INET (ip1,_), Unix.ADDR_INET (ip2,_)) -> ip1 = ip2
+ | _ -> false
+
+let rec choose () =
+ if Sys.file_exists (Lazy.force Settings.membership_file) then begin
+ reload_if_changed ();
+ let (mshp, _) = !membership in
+ let choice = Random.int (Array.length mshp) in
+ refresh_member mshp choice;
+ match fst mshp.(choice) with
+ [] -> choose ()
+ | addrlist ->
+ let saddr = (List.hd addrlist).Unix.ai_addr in
+ let same_addr thisaddr = same_inet_addr saddr thisaddr.Unix.ai_addr in
+ if List.exists ~f:same_addr (local_recon_addr ()) then
+ choose () else
+ addrlist
+ end else
+ raise Not_found
+
+let test addr =
+ reload_if_changed ();
+ let (m,_) = !membership in
+ let same_as_addr this_addr = same_inet_addr addr this_addr.Unix.ai_addr in
+ List.exists (Array.to_list m)
+ ~f:(fun x -> List.exists ~f:same_as_addr (fst x))
+
+(************************************************************)
+(** Code for keeping track of hosts to send mail updates to *)
+(************************************************************)
+
+let mailsync_partners = ref ([ ],-1.)
+
+let rec load_mailsync_partners_file file =
+ try
+ let email = Wserver.strip (decomment (input_line file)) in
+ if String.contains email '@'
+ then email::(load_mailsync_partners_file file)
+ else load_mailsync_partners_file file
+ with
+ End_of_file -> []
+
+let load_mailsync_partners fname =
+ let file = open_in fname in
+ let run () =
+ match get_mtime fname with
+ | Some mtime ->
+ mailsync_partners := (load_mailsync_partners_file file,mtime)
+ | None ->
+ plerror 2 "Failed to find mtime -- can't load mailsync file"
+ in
+ protect ~f:run ~finally:(fun () -> close_in file)
+
+let reload_mailsync_if_changed () =
+ let fname = Lazy.force Settings.mailsync_file in
+ let (msync,old_mtime) = !mailsync_partners in
+ match get_mtime fname with
+ None -> plerror 2 "%s"
+ ("Failed to find mtime, can't decide whether to" ^
+ " load mailsync file")
+ | Some mtime -> if old_mtime <> mtime then load_mailsync_partners fname
+
+let get_mailsync_partners () =
+ let partners =
+ if Sys.file_exists (Lazy.force Settings.membership_file) then (
+ reload_mailsync_if_changed ();
+ let (m,mtime) = !mailsync_partners in
+ m
+ )
+ else []
+ in
+ if partners = [] then failwith "No partners specified"
+ else partners
Added: sks/branches/upstream/sks/current/membership.mli
===================================================================
--- sks/branches/upstream/sks/current/membership.mli (rev 0)
+++ sks/branches/upstream/sks/current/membership.mli 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,20 @@
+(** Module for tracking gossip membership and mailsync peers *)
+
+(** Reset the last time the mtime was read to zero, to force the membership file to be
+ reloaded from disk *)
+val reset_membership_time : unit -> unit
+
+(** Get human-readable names of gossip peers. *)
+val get_names : unit -> string array
+
+(** Picks single gossip partner from list of possible partners, and returns list of all
+ known addresses for that host *)
+val choose : unit -> Common.Unix.addr_info list
+
+(** Returns true iff the address in question belongs to one of the hosts on the gossip
+ membership list. *)
+val test : Common.Unix.sockaddr -> bool
+
+(** Returns the list of email addresses for use in PKS-style key distribution *)
+val get_mailsync_partners : unit -> string list
+
Added: sks/branches/upstream/sks/current/merge_keyfiles.ml
===================================================================
--- sks/branches/upstream/sks/current/merge_keyfiles.ml (rev 0)
+++ sks/branches/upstream/sks/current/merge_keyfiles.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,142 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Executable: Adds keys from key files to existing database. *)
+
+module F(M:sig end) =
+struct
+ open StdLabels
+ open MoreLabels
+ open Printf
+ open Arg
+ open Common
+ module Set = PSet.Set
+ open Packet
+
+ let settings = {
+ Keydb.withtxn = false;
+ Keydb.cache_bytes = !Settings.cache_bytes;
+ Keydb.pagesize = !Settings.pagesize;
+ Keydb.dbdir = Lazy.force Settings.dbdir;
+ Keydb.dumpdir = Lazy.force Settings.dumpdir;
+ }
+
+ module Keydb = Keydb.Safe
+
+ let n = match !Settings.n with 0 -> 1 | x -> x
+ let maxkeys = n * 15000
+ let fnames = List.filter ~f:(fun x -> x <> "") (List.rev !Settings.anonlist)
+
+ let timestr sec =
+ sprintf "%.2f min" (sec /. 60.)
+
+ (* ******************************************************************** *)
+ (** data type and functions for dealing with collection of files as
+ one big stream *)
+
+ type keydump_stream =
+ { getkey: unit -> packet list;
+ current: in_channel;
+ fnames: string list;
+ ctr: int;
+ }
+
+ let create_keydump_stream ctr fnames =
+ match fnames with
+ | [] -> raise End_of_file
+ | hd::tl ->
+ let file = open_in hd in
+ let cin = new Channel.sys_in_channel file in
+ let getkey = Key.get_of_channel cin in
+ { getkey = getkey;
+ current = file;
+ fnames = tl;
+ ctr = ctr;
+ }
+
+ let rec get_key stream =
+ try (!stream).getkey ()
+ with Not_found | End_of_file ->
+ close_in (!stream).current;
+ stream := create_keydump_stream ((!stream).ctr + 1) (!stream).fnames;
+ get_key stream
+
+ let create_keydump_stream fnames = ref (create_keydump_stream 0 fnames)
+
+ let lpush el list = list := el::!list
+
+ let get_n_keys stream n =
+ let data = ref [] in
+ (try
+ for i = 1 to n do
+ lpush (get_key stream) data
+ done
+ with
+ End_of_file ->
+ stream := { !stream with getkey = (fun () -> raise End_of_file) }
+ );
+ !data
+
+ (* *************************************************** *)
+
+ let dbtimer = MTimer.create ()
+ let timer = MTimer.create ()
+ let run () =
+ set_logfile "merge";
+ if not (Sys.file_exists (Lazy.force Settings.dbdir)) then (
+ printf "No existing KeyDB database. Exiting.\n";
+ exit (-1)
+ );
+
+ Keydb.open_dbs settings;
+ if fnames = [] then failwith "No files provided";
+ let finished = ref false in
+ let stream = create_keydump_stream fnames in
+ try
+ protect
+ ~f:(fun () ->
+ while not !finished do
+
+ MTimer.start timer;
+
+ printf "Loading keys...\n"; flush stdout;
+ let keys = get_n_keys stream maxkeys in
+ if keys = [] then raise Exit;
+ printf " %d keys loaded, %d files left\n"
+ (List.length keys) (List.length !stream.fnames);
+ flush stdout;
+
+ MTimer.start dbtimer;
+ Keydb.add_keys_merge keys;
+ MTimer.stop dbtimer;
+
+ MTimer.stop timer;
+
+ printf " DB time: %s. Total time: %s.\n"
+ (timestr (MTimer.read dbtimer))
+ (timestr (MTimer.read timer));
+ flush stdout;
+ done
+ )
+ ~finally:(fun () ->
+ perror "closing database...";
+ Keydb.close_dbs ();
+ perror "...database closed";
+ )
+ with
+ Exit -> ()
+end
Added: sks/branches/upstream/sks/current/meteredChannel.ml
===================================================================
--- sks/branches/upstream/sks/current/meteredChannel.ml (rev 0)
+++ sks/branches/upstream/sks/current/meteredChannel.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,85 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Version of the [Channel] objects that keeps track of the number of bytes
+ sent through them. *)
+open StdLabels
+open MoreLabels
+module Unix=UnixLabels
+
+
+class metered_out_channel outc =
+object (self)
+ inherit Channel.out_channel_obj
+
+ val mutable count = 0
+
+ method private incr c = count <- count + c
+
+ method write_string str =
+ outc#write_string str;
+ self#incr (String.length str)
+
+ method write_string_pos ~buf ~pos ~len =
+ outc#write_string_pos ~buf ~pos ~len;
+ self#incr len
+
+ method write_char char =
+ outc#write_char char;
+ self#incr 1
+
+ method write_byte byte =
+ outc#write_byte byte;
+ self#incr 1
+
+ method flush : unit = outc#flush
+ method upcast = (self :> Channel.out_channel_obj)
+ method reset = count <- 0
+ method bytes = count
+
+end
+
+
+class metered_in_channel inc =
+object (self)
+ inherit Channel.in_channel_obj
+
+ val mutable count = 0
+
+ method private incr c = count <- count + c
+
+ method read_string len =
+ self#incr len;
+ inc#read_string len
+
+ method read_string_pos ~buf ~pos ~len =
+ self#incr len;
+ inc#read_string_pos ~buf ~pos ~len
+
+ method read_char =
+ self#incr 1;
+ inc#read_char
+
+ method read_byte =
+ self#incr 1;
+ inc#read_byte
+
+ method upcast = (self :> Channel.in_channel_obj)
+ method reset = count <- 0
+ method bytes = count
+
+end
Added: sks/branches/upstream/sks/current/msgContainer.ml
===================================================================
--- sks/branches/upstream/sks/current/msgContainer.ml (rev 0)
+++ sks/branches/upstream/sks/current/msgContainer.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,57 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+module Unix=UnixLabels
+
+open Printf
+
+module type MsgMarshal =
+sig
+ type msg_t
+ val marshal: Channel.out_channel_obj -> msg_t -> unit
+ val unmarshal: Channel.in_channel_obj -> msg_t
+ val to_string: msg_t -> string
+ val print: string -> unit
+end
+
+module Container =
+ functor (Msg:MsgMarshal) ->
+struct
+
+ type msg_container =
+ { msg: Msg.msg_t;
+ (* nonce: int; *)
+ }
+
+ let marshal_noflush cout msg =
+ Msg.print (sprintf "Marshalling: %s" (Msg.to_string msg));
+ Msg.marshal cout#upcast msg
+
+ let marshal cout msg =
+ marshal_noflush cout msg;
+ cout#flush
+
+ let unmarshal cin =
+ let msg = Msg.unmarshal cin#upcast in
+ Msg.print (sprintf "Unmarshalling: %s" (Msg.to_string msg));
+ { msg = msg; }
+
+end
+
+
Added: sks/branches/upstream/sks/current/nbMsgContainer.ml
===================================================================
--- sks/branches/upstream/sks/current/nbMsgContainer.ml (rev 0)
+++ sks/branches/upstream/sks/current/nbMsgContainer.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,109 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** message wrapper that allows for non-blocking reads. Warning: this should
+ be used only with one channel, since it keeps track of the last size read.
+*)
+open Common
+open StdLabels
+open MoreLabels
+module Unix=UnixLabels
+
+open Printf
+
+module type MsgMarshal =
+sig
+ type msg_t
+ val marshal: Channel.out_channel_obj -> msg_t -> unit
+ val unmarshal: Channel.in_channel_obj -> msg_t
+ val to_string: msg_t -> string
+ val print: string -> unit
+end
+
+module Container =
+ functor (Msg:MsgMarshal) ->
+struct
+
+ let bufc = Channel.new_buffer_outc 512
+
+ type msg_container =
+ { msg: Msg.msg_t;
+ (* nonce: int; *)
+ }
+
+ let marshal_noflush cout msg =
+ Buffer.clear bufc#buffer_nocopy;
+ Msg.print (sprintf "Marshalling: %s" (Msg.to_string msg));
+ Msg.marshal bufc#upcast msg;
+ cout#write_int (Buffer.length bufc#buffer_nocopy);
+ Buffer.output_buffer cout#outchan bufc#buffer_nocopy
+
+ let marshal cout msg =
+ marshal_noflush cout msg;
+ cout#flush
+
+ let last_length = (ref None : int option ref)
+
+ (** Do a non-blocking message read *)
+ let try_unmarshal cin =
+ let oldalarm = Unix.alarm 0 in
+ Unix.set_nonblock cin#fd;
+ let run () =
+ try
+ let length = match !last_length with
+ | Some x -> x
+ | None ->
+ let x = cin#read_int in
+ last_length := Some x;
+ x
+ in
+ let msgstr = cin#read_string length in
+ last_length := None;
+ let sin = new Channel.string_in_channel msgstr 0 in
+ let msg = Msg.unmarshal sin#upcast
+ in
+ Msg.print (sprintf "Unmarshalling: %s (NB)" (Msg.to_string msg));
+ Some { msg = msg; }
+ with
+ | Unix.Unix_error (Unix.EAGAIN,_,_)
+ | Unix.Unix_error (Unix.EWOULDBLOCK,_,_)
+ | Sys_blocked_io ->
+ Msg.print "Operation would have blocked";
+ None
+ in
+ protect ~f:run ~finally:(fun () ->
+ Unix.clear_nonblock cin#fd;
+ ignore (Unix.alarm oldalarm);
+ )
+
+ (** Do a blocking message read *)
+ let unmarshal cin =
+ (* skip over the length, since we only need it in the nonblocking case *)
+ let length = match !last_length with
+ | Some x -> x
+ | None -> cin#read_int
+ in
+ last_length := None;
+ let msgstr = cin#read_string length in
+ let sin = new Channel.string_in_channel msgstr 0 in
+ let msg = Msg.unmarshal sin#upcast in
+ Msg.print (sprintf "Unmarshalling: %s" (Msg.to_string msg));
+ { msg = msg; }
+
+end
+
+
Added: sks/branches/upstream/sks/current/number.ml
===================================================================
--- sks/branches/upstream/sks/current/number.ml (rev 0)
+++ sks/branches/upstream/sks/current/number.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,176 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Basic operations and definitions for multi-precistion integers. *)
+
+open Big_int
+open StdLabels
+open MoreLabels
+open Printf
+open Common
+
+type z = Big_int.big_int
+
+module Infix =
+struct
+ let two = big_int_of_int 2
+ let one = unit_big_int
+ let zero = zero_big_int
+ let neg_one = big_int_of_int (-1)
+
+ let ( *! ) = mult_big_int
+ let ( +! ) = add_big_int
+ let ( -! ) = sub_big_int
+ let ( %! ) = mod_big_int
+ let ( /! ) = div_big_int
+ let ( **! ) = power_big_int_positive_int
+ let ( <>! ) x y = not (eq_big_int x y)
+ let ( =! ) = eq_big_int
+ let ( <! ) = lt_big_int
+ let ( >! ) = gt_big_int
+ let ( <=! ) = le_big_int
+ let ( >=! ) = ge_big_int
+end
+
+open Infix
+
+let int_mult = mult_int_big_int
+let int_posint_power = power_int_positive_int
+
+let width = 8
+let width_pow = power_int_positive_int 2 width
+
+let revstring s =
+ let len = String.length s in
+ let copy = String.create len in
+ for i = 0 to len - 1 do
+ copy.[i] <- s.[len - 1 - i]
+ done;
+ copy
+
+let revstring_inplace s =
+ let len = String.length s in
+ for i = 0 to (len - 2)/2 do
+ let j = len - 1 - i in
+ let tmp = s.[i] in
+ s.[i] <- s.[j];
+ s.[j] <- tmp
+ done
+
+let to_bytes ~nbytes n =
+ if sign_big_int n = -1
+ then raise (Invalid_argument "N.to_bytes: negative argument");
+ let string = String.create nbytes in
+ let rec loop n i =
+ if i < 0 then string
+ else
+ let (a,b) = quomod_big_int n width_pow in
+ string.[i] <- char_of_int (int_of_big_int b);
+ loop a (i - 1)
+ in
+ let str = loop n (nbytes - 1) in
+ revstring_inplace str;
+ str
+
+let of_bytes str =
+ let str = revstring str in
+ let nbytes = String.length str in
+ let rec loop n i =
+ if i >= nbytes then n
+ else
+ let m = big_int_of_int (int_of_char str.[i]) in
+ loop (n *! width_pow +! m) (i+1)
+ in
+ loop zero 0
+
+
+
+open Big_int
+open Nat
+
+let nbits_slow x =
+ let rec loop i two_to_i =
+ if two_to_i >! x then i
+ else loop (succ i) (two *! two_to_i)
+ in
+ if x =! zero then 1 else loop 1 two
+
+let nbits_less_slow x =
+ let nwords = num_digits_big_int x in
+ let wsize = Sys.word_size in
+ let lowbits = (nwords - 1) * wsize in
+ let lastword = x /! two **! lowbits in
+ nbits_slow lastword + (nwords - 1) * wsize
+
+(** returns the number of bits required to represent the number, i.e.,
+ the index (starting from 1) of the most significant non-zero bit *)
+let nbits x =
+ let nat = nat_of_big_int (abs_big_int x) in
+ let nwords = num_digits_nat nat 0 (length_nat nat) in
+ Sys.word_size * nwords - num_leading_zero_bits_in_digit nat (nwords - 1)
+
+let nth_bit x n =
+ one =! ( x /! (two **! n)) %! two
+
+let print_bits x =
+ for i = nbits x - 1 downto 0 do
+ if nth_bit x i then print_string "1" else print_string "0"
+ done
+
+let squaremod x m =
+ (x *! x) %! m
+
+let rec powmod x y m =
+ if y =! zero then one
+ else
+ let base = squaremod (powmod x ( y /! two) m) m in
+ if y %! two =! zero then base
+ else (base *! x) %! m
+
+let dumb_powmod x y m =
+ (x **! int_of_big_int y) %! m
+
+let rec gcd_ex' a b =
+ if b =! zero then (one,zero,a)
+ else
+ let (q,r) = quomod_big_int a b in
+ let (u',v',gcd) = gcd_ex' b r in
+ (v',u' -! v' *! q, gcd)
+
+let gcd_ex a b =
+ if b <=! a then gcd_ex' a b
+ else
+ let (u,v,gcd) = gcd_ex' b a in
+ (v,u,gcd)
+
+let gcd_ex_test a b =
+ let (a,b) = (big_int_of_int a,big_int_of_int b) in
+ let (u,v,gcd) = gcd_ex a b in
+ if (u *! a +! v *! b <>! gcd)
+ then failwith (sprintf "gcd_ex failed on %s and %s"
+ (string_of_big_int a) (string_of_big_int b))
+
+
+(** conversion functions *)
+
+let of_int = big_int_of_int
+let to_int = int_of_big_int
+let to_string = string_of_big_int
+let of_string = big_int_of_string
+let compare = compare_big_int
+
+
Added: sks/branches/upstream/sks/current/number.mli
===================================================================
--- sks/branches/upstream/sks/current/number.mli (rev 0)
+++ sks/branches/upstream/sks/current/number.mli 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,42 @@
+type z
+module Infix :
+sig
+ val two : z
+ val one : z
+ val zero : z
+ val neg_one : z
+ val ( *! ) : z -> z -> z
+ val ( +! ) : z -> z -> z
+ val ( -! ) : z -> z -> z
+ val ( %! ) : z -> z -> z
+ val ( /! ) : z -> z -> z
+ val ( **! ) : z -> int -> z
+ val ( <>! ) : z -> z -> bool
+ val ( =! ) : z -> z -> bool
+ val ( <! ) : z -> z -> bool
+ val ( >! ) : z -> z -> bool
+ val ( <=! ) : z -> z -> bool
+ val ( >=! ) : z -> z -> bool
+end
+val width : int
+val width_pow : z
+val nbits : z -> int
+val nth_bit : z -> int -> bool
+val print_bits : z -> unit
+val squaremod : z -> z -> z
+val powmod : z -> z -> z -> z
+val dumb_powmod : z -> z -> z -> z
+val gcd_ex : z -> z -> z * z * z
+
+val int_mult : int -> z -> z
+val int_posint_power : int -> int -> z
+
+(** conversion functions *)
+
+val to_bytes : nbytes:int -> z -> string
+val of_bytes : string -> z
+val of_int : int -> z
+val to_int : z -> int
+val to_string : z -> string
+val of_string : string -> z
+val compare : z -> z -> int
Added: sks/branches/upstream/sks/current/number2.ml
===================================================================
--- sks/branches/upstream/sks/current/number2.ml (rev 0)
+++ sks/branches/upstream/sks/current/number2.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,166 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Basic operations and definitions for multi-precistion integers. *)
+
+open Big_int
+
+let two = big_int_of_int 2
+let one = unit_big_int
+let zero = zero_big_int
+let neg_one = big_int_of_int (-1)
+
+let ( *! ) = mult_big_int
+let ( +! ) = add_big_int
+let ( -! ) = sub_big_int
+let ( %! ) = quomod_big_int
+let ( /! ) = div_big_int
+let ( **! ) = power_big_int_positive_big_int
+let ( <>! ) x y = not (eq_big_int x y)
+let ( =! ) = eq_big_int
+let ( <! ) = lt_big_int
+let ( >! ) = gt_big_int
+let ( <=! ) = le_big_int
+let ( >=! ) = ge_big_int
+
+
+let width = 8
+let width_pow = power_int_positive_int 2 width
+
+let revstring s =
+ let len = String.length s in
+ let copy = String.create len in
+ for i = 0 to len - 1 do
+ copy.[i] <- s.[len - 1 - i]
+ done;
+ copy
+
+let revstring_inplace s =
+ let len = String.length s in
+ for i = 0 to (len - 2)/2 do
+ let j = len - 1 - i in
+ let tmp = s.[i] in
+ s.[i] <- s.[j];
+ s.[j] <- tmp
+ done
+
+let bigint_to_bytes ~nbytes n =
+ if sign_big_int n = -1
+ then raise (Invalid_argument "N.to_bytes: negative argument");
+ let string = String.create nbytes in
+ let rec loop n i =
+ if i < 0 then string
+ else
+ let (a,b) = n %! width_pow in
+ string.[i] <- char_of_int (int_of_big_int b);
+ loop a (i - 1)
+ in
+ let str = loop n (nbytes - 1) in
+ revstring_inplace str;
+ str
+
+let bigint_of_bytes str =
+ let str = revstring str in
+ let nbytes = String.length str in
+ let rec loop n i =
+ if i >= nbytes then n
+ else
+ let m = big_int_of_int (int_of_char str.[i]) in
+ loop (n *! width_pow +! m) (i+1)
+ in
+ loop zero 0
+
+module type ZZpType =
+sig
+ type t
+ type tref
+ type zzarray
+ val nbits : int
+ val nbytes : int
+ val of_bytes : string -> t
+ val to_bytes : t -> string
+ val of_int : int -> t
+ val to_N : t -> big_int
+ val of_N : big_int -> t
+
+ val one : t
+ val zero : t
+
+ val add : t -> t -> t
+ val div : t -> t -> t
+ val mul : t -> t -> t
+ val mult : t -> t -> t
+ val inv : t -> t
+ val neg : t -> t
+ val shl : t -> int -> t
+
+ val imult : t -> int -> t
+
+ val add_fast : t -> t -> t
+ val mul_fast : t -> t -> t
+ val mult_fast : t -> t -> t
+ val square : t -> t
+ val square_fast : t -> t
+ val canonicalize : t -> t
+
+ val sub : t -> t -> t
+ val print : t -> unit
+
+ val imul : t -> int -> t
+
+ val lt : t -> t -> bool
+ val gt : t -> t -> bool
+ val eq : t -> t -> bool
+ val neq : t -> t -> bool
+
+ val look : tref -> t
+ val mult_in : tref -> t -> t -> unit
+ val mult_fast_in : tref -> t -> t -> unit
+ val add_in : tref -> t -> t -> unit
+ val add_fast_in : tref -> t -> t -> unit
+ val sub_in : tref -> t -> t -> unit
+ val sub_fast_in : tref -> t -> t -> unit
+ val copy_in : tref -> t -> unit
+ val copy_out : tref -> t
+ val make_ref : t -> tref
+ val canonicalize_in : tref -> unit
+
+ val points : int -> t array
+ val svalues : int -> zzarray
+ val to_string : t -> string
+
+ val add_el_array : points: t array -> t -> t array
+ val del_el_array : points: t array -> t -> t array
+ val mult_array : svalues: zzarray -> t array -> unit
+
+
+ val add_el : svalues:zzarray -> points:t array ->
+ t -> unit (* modifies svalues *)
+ val del_el : svalues:zzarray -> points:t array ->
+ t -> unit (* modifies svalues *)
+
+ val length : zzarray -> int
+ val zzarray_to_array : zzarray -> t array
+ val zzarray_of_array : t array -> zzarray
+ val zzarray_div : zzarray -> zzarray -> zzarray
+ val zzarray_copy : zzarray -> zzarray
+
+ val cmp : t -> t -> int
+
+ val order : big_int
+end
+
Added: sks/branches/upstream/sks/current/number_test.ml
===================================================================
--- sks/branches/upstream/sks/current/number_test.ml (rev 0)
+++ sks/branches/upstream/sks/current/number_test.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,37 @@
+open Big_int
+open StdLabels
+open MoreLabels
+open Printf
+open Number
+open Number.Infix
+open Common
+
+(** Unit tests for number.ml *)
+
+let rand_int = Random.State.int RMisc.det_rng
+let rand_bits () = Random.State.bits RMisc.det_rng
+
+let ctr = ref 0
+let test cond =
+ printf ".%!";
+ incr ctr;
+ if not cond then raise (Unit_test_failure (sprintf "Number test %d failed" !ctr))
+
+
+let conversion_test () =
+ let nbits = rand_int 400 + 1 in
+ let nbytes = nbits / 8 + (if nbits mod 8 = 0 then 0 else 1) in
+ let x = Prime.randbits rand_bits nbits in
+ let xstr = to_bytes ~nbytes x in
+ test (of_bytes xstr =! x)
+
+let powmod_test () =
+ let x = Prime.randbits rand_bits (rand_int 12 + 1) in
+ let y = Prime.randbits rand_bits (rand_int 12 + 1) in
+ let m = Prime.randbits rand_bits (rand_int 12 + 1) in
+ test (powmod x y m =! dumb_powmod x y m)
+
+
+let run () =
+ for i = 1 to 100 do conversion_test () done;
+ for i = 1 to 100 do powmod_test () done;
Added: sks/branches/upstream/sks/current/pMap.ml
===================================================================
--- sks/branches/upstream/sks/current/pMap.ml (rev 0)
+++ sks/branches/upstream/sks/current/pMap.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,167 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+
+
+module type OrderedType =
+ sig val compare: 'a -> 'a -> int end
+
+module ClassicalType =
+ struct let compare = Pervasives.compare end
+
+module type S =
+ sig
+ type ('key,'data) t
+ val empty: ('key,'data) t
+ val add: key:'key -> data:'data -> ('key,'data) t -> ('key,'data) t
+ val find: 'key -> ('key,'data) t -> 'data
+ val remove: 'key -> ('key,'data) t -> ('key,'data) t
+ val mem: 'key -> ('key,'data) t -> bool
+ val iter: f:(key:'key -> data:'data -> unit) -> ('key,'data) t -> unit
+ val map: f:('data -> 'a) -> ('key,'data) t -> ('key,'a) t
+ val mapi: f:(key:'key -> data:'data -> 'a) ->
+ ('key,'data) t -> ('key,'a) t
+ val fold: f:(key:'key -> data:'data -> 'a -> 'a) ->
+ ('key,'data) t -> init:'a -> 'a
+ val of_alist: ('key * 'data) list -> ('key,'data) t
+ val to_alist: ('key,'data) t -> ('key * 'data) list
+ end
+
+module Make(Ord: OrderedType) = struct
+
+ type ('key,'data) t =
+ Empty
+ | Node of ('key,'data) t * 'key * 'data * ('key,'data) t * int
+
+ let empty = Empty
+
+ let height = function
+ Empty -> 0
+ | Node(_,_,_,_,h) -> h
+
+ let create l x d r =
+ let hl = height l and hr = height r in
+ Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+ let bal l x d r =
+ let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in
+ let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in
+ if hl > hr + 2 then begin
+ match l with
+ Empty -> invalid_arg "Map.bal"
+ | Node(ll, lv, ld, lr, _) ->
+ if height ll >= height lr then
+ create ll lv ld (create lr x d r)
+ else begin
+ match lr with
+ Empty -> invalid_arg "Map.bal"
+ | Node(lrl, lrv, lrd, lrr, _)->
+ create (create ll lv ld lrl) lrv lrd (create lrr x d r)
+ end
+ end else if hr > hl + 2 then begin
+ match r with
+ Empty -> invalid_arg "Map.bal"
+ | Node(rl, rv, rd, rr, _) ->
+ if height rr >= height rl then
+ create (create l x d rl) rv rd rr
+ else begin
+ match rl with
+ Empty -> invalid_arg "Map.bal"
+ | Node(rll, rlv, rld, rlr, _) ->
+ create (create l x d rll) rlv rld (create rlr rv rd rr)
+ end
+ end else
+ Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))
+
+ let rec add ~key:x ~data = function
+ Empty ->
+ Node(Empty, x, data, Empty, 1)
+ | Node(l, v, d, r, h) ->
+ let c = Ord.compare x v in
+ if c = 0 then
+ Node(l, x, data, r, h)
+ else if c < 0 then
+ bal (add ~key:x ~data l) v d r
+ else
+ bal l v d (add ~key:x ~data r)
+
+ let rec find x = function
+ Empty ->
+ raise Not_found
+ | Node(l, v, d, r, _) ->
+ let c = Ord.compare x v in
+ if c = 0 then d
+ else find x (if c < 0 then l else r)
+
+ let rec mem x = function
+ Empty ->
+ false
+ | Node(l, v, d, r, _) ->
+ let c = Ord.compare x v in
+ c = 0 || mem x (if c < 0 then l else r)
+
+ let rec merge t1 t2 =
+ match (t1, t2) with
+ (Empty, t) -> t
+ | (t, Empty) -> t
+ | (Node(l1, v1, d1, r1, h1), Node(l2, v2, d2, r2, h2)) ->
+ bal l1 v1 d1 (bal (merge r1 l2) v2 d2 r2)
+
+ let rec remove x = function
+ Empty ->
+ Empty
+ | Node(l, v, d, r, h) ->
+ let c = Ord.compare x v in
+ if c = 0 then
+ merge l r
+ else if c < 0 then
+ bal (remove x l) v d r
+ else
+ bal l v d (remove x r)
+
+ let rec iter ~f = function
+ Empty -> ()
+ | Node(l, v, d, r, _) ->
+ iter ~f l; f ~key:v ~data:d; iter ~f r
+
+ let rec map ~f = function
+ Empty -> Empty
+ | Node(l, v, d, r, h) -> Node(map ~f l, v, f d, map ~f r, h)
+
+ let rec mapi ~f = function
+ Empty -> Empty
+ | Node(l, v, d, r, h) ->
+ Node(mapi ~f l, v, f ~key:v ~data:d, mapi ~f r, h)
+
+ let rec fold ~f m ~init:accu =
+ match m with
+ Empty -> accu
+ | Node(l, v, d, r, _) ->
+ fold ~f l ~init:(f ~key:v ~data:d (fold ~f r ~init:accu))
+
+ let of_alist alist =
+ List.fold_left ~f:(fun map (key,data) -> add ~key ~data map)
+ ~init:empty alist
+
+ let to_alist map =
+ fold ~f:(fun ~key ~data list -> (key,data)::list)
+ ~init:[] map
+end
+
+module Map = Make(ClassicalType)
Added: sks/branches/upstream/sks/current/pMap.mli
===================================================================
--- sks/branches/upstream/sks/current/pMap.mli (rev 0)
+++ sks/branches/upstream/sks/current/pMap.mli 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,107 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Association tables over ordered types.
+
+ This module implements applicative association tables, also known as
+ finite maps or dictionaries, given a total ordering function
+ over the keys.
+ All operations over maps are purely applicative (no side-effects).
+ The implementation uses balanced binary trees, and therefore searching
+ and insertion take time logarithmic in the size of the map.
+*)
+
+module type OrderedType =
+ sig
+ val compare : 'a -> 'a -> int
+ (** A total ordering function over the keys.
+ This is a two-argument function [f] such that
+ [f e1 e2] is zero if the keys [e1] and [e2] are equal,
+ [f e1 e2] is strictly negative if [e1] is smaller than [e2],
+ and [f e1 e2] is strictly positive if [e1] is greater than [e2].
+ Example: a suitable ordering function is
+ the generic structural comparison function {!Pervasives.compare}. *)
+ end
+(** Input signature of the functor {!Map.Make}. *)
+
+module type S =
+ sig
+ type ('key,'data) t
+ (** The type of maps from type [key] to type ['a]. *)
+
+ val empty: ('key,'data) t
+ (** The empty map. *)
+
+ val add: key:'key -> data:'data -> ('key,'data) t -> ('key,'data) t
+ (** [add x y m] returns a map containing the same bindings as
+ [m], plus a binding of [x] to [y]. If [x] was already bound
+ in [m], its previous binding disappears. *)
+
+ val find: 'key -> ('key,'data) t -> 'data
+ (** [find x m] returns the current binding of [x] in [m],
+ or raises [Not_found] if no such binding exists. *)
+
+ val remove: 'key -> ('key,'data) t -> ('key,'data) t
+ (** [remove x m] returns a map containing the same bindings as
+ [m], except for [x] which is unbound in the returned map. *)
+
+ val mem: 'key -> ('key,'data) t -> bool
+ (** [mem x m] returns [true] if [m] contains a binding for [x],
+ and [false] otherwise. *)
+
+ val iter: f:(key:'key -> data:'data -> unit) -> ('key,'data) t -> unit
+ (** [iter f m] applies [f] to all bindings in map [m].
+ [f] receives the key as first argument, and the associated value
+ as second argument. The order in which the bindings are passed to
+ [f] is unspecified. Only current bindings are presented to [f]:
+ bindings hidden by more recent bindings are not passed to [f]. *)
+
+ val map: f:('data -> 'a) -> ('key,'data) t -> ('key,'a) t
+ (** [map f m] returns a map with same domain as [m], where the
+ associated value [a] of all bindings of [m] has been
+ replaced by the result of the application of [f] to [a].
+ The order in which the associated values are passed to [f]
+ is unspecified. *)
+
+ val mapi: f:(key:'key -> data:'data -> 'a) ->
+ ('key,'data) t -> ('key,'a) t
+ (** Same as {!Map.S.map}, but the function receives as arguments both the
+ key and the associated value for each binding of the map. *)
+
+ val fold: f:(key:'key -> data:'data -> 'a -> 'a) ->
+ ('key,'data) t -> init:'a -> 'a
+ (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)],
+ where [k1 ... kN] are the keys of all bindings in [m],
+ and [d1 ... dN] are the associated data.
+ The order in which the bindings are presented to [f] is
+ unspecified. *)
+
+ val of_alist: ('key * 'data) list -> ('key,'data) t
+ (* [of_alist alist] converts the association list [alist] into
+ the corresponding map *)
+
+ val to_alist: ('key,'data) t -> ('key * 'data) list
+ (* [of_alist map] converts the map [map] into
+ the corresponding association list *)
+ end
+(** Output signature of the functor {!Map.Make}. *)
+
+module Make (Ord : OrderedType) : S
+(** Functor building an implementation of the map structure
+ given a totally ordered type. *)
+
+module Map : S
Added: sks/branches/upstream/sks/current/pSet.ml
===================================================================
--- sks/branches/upstream/sks/current/pSet.ml (rev 0)
+++ sks/branches/upstream/sks/current/pSet.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,318 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(* Sets over ordered types *)
+
+open StdLabels
+open MoreLabels
+
+module type OrderedType =
+ sig val compare: 'elt -> 'elt -> int end
+
+module ClassicalType =
+ struct let compare = Pervasives.compare end
+
+module type S =
+ sig
+ type 'elt t
+ val empty: 'elt t
+ val is_empty: 'elt t -> bool
+ val mem: 'elt -> 'elt t -> bool
+ val add: 'elt -> 'elt t -> 'elt t
+ val singleton: 'elt -> 'elt t
+ val remove: 'elt -> 'elt t -> 'elt t
+ val union: 'elt t -> 'elt t -> 'elt t
+ val inter: 'elt t -> 'elt t -> 'elt t
+ val diff: 'elt t -> 'elt t -> 'elt t
+ val compare: 'elt t -> 'elt t -> int
+ val equal: 'elt t -> 'elt t -> bool
+ val subset: 'elt t -> 'elt t -> bool
+ val iter: f:('elt -> unit) -> 'elt t -> unit
+ val fold: f:('elt -> 'a -> 'a) -> 'elt t -> init:'a -> 'a
+ val for_all: f:('elt -> bool) -> 'elt t -> bool
+ val exists: f:('elt -> bool) -> 'elt t -> bool
+ val filter: f:('elt -> bool) -> 'elt t -> 'elt t
+ val partition: f:('elt -> bool) -> 'elt t -> 'elt t * 'elt t
+ val cardinal: 'elt t -> int
+ val elements: 'elt t -> 'elt list
+ val min_elt: 'elt t -> 'elt
+ val max_elt: 'elt t -> 'elt
+ val choose: 'elt t -> 'elt
+ val of_list: 'elt list -> 'elt t
+ end
+
+
+module Make(Ord: OrderedType) =
+ struct
+ type 'elt t = Empty | Node of 'elt t * 'elt * 'elt t * int
+
+ (* Sets are represented by balanced binary trees (the heights of the
+ children differ by at most 2 *)
+
+ let height = function
+ Empty -> 0
+ | Node(_, _, _, h) -> h
+
+ (* Creates a new node with left son l, value x and right son r.
+ l and r must be balanced and | height l - height r | <= 2.
+ Inline expansion of height for better speed. *)
+
+ let create l x r =
+ let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
+ let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+ Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1))
+
+ (* Same as create, but performs one step of rebalancing if necessary.
+ Assumes l and r balanced.
+ Inline expansion of create for better speed in the most frequent case
+ where no rebalancing is required. *)
+
+ let bal l x r =
+ let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
+ let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
+ if hl > hr + 2 then begin
+ match l with
+ Empty -> invalid_arg "Set.bal"
+ | Node(ll, lv, lr, _) ->
+ if height ll >= height lr then
+ create ll lv (create lr x r)
+ else begin
+ match lr with
+ Empty -> invalid_arg "Set.bal"
+ | Node(lrl, lrv, lrr, _)->
+ create (create ll lv lrl) lrv (create lrr x r)
+ end
+ end else if hr > hl + 2 then begin
+ match r with
+ Empty -> invalid_arg "Set.bal"
+ | Node(rl, rv, rr, _) ->
+ if height rr >= height rl then
+ create (create l x rl) rv rr
+ else begin
+ match rl with
+ Empty -> invalid_arg "Set.bal"
+ | Node(rll, rlv, rlr, _) ->
+ create (create l x rll) rlv (create rlr rv rr)
+ end
+ end else
+ Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1))
+
+ (* Same as bal, but repeat rebalancing until the final result
+ is balanced. *)
+
+ let rec join l x r =
+ match bal l x r with
+ Empty -> invalid_arg "Set.join"
+ | Node(l', x', r', _) as t' ->
+ let d = height l' - height r' in
+ if d < -2 || d > 2 then join l' x' r' else t'
+
+ (* Merge two trees l and r into one.
+ All elements of l must precede the elements of r.
+ Assumes | height l - height r | <= 2. *)
+
+ let rec merge t1 t2 =
+ match (t1, t2) with
+ (Empty, t) -> t
+ | (t, Empty) -> t
+ | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+ bal l1 v1 (bal (merge r1 l2) v2 r2)
+
+ (* Same as merge, but does not assume anything about l and r. *)
+
+ let rec concat t1 t2 =
+ match (t1, t2) with
+ (Empty, t) -> t
+ | (t, Empty) -> t
+ | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+ join l1 v1 (join (concat r1 l2) v2 r2)
+
+ (* Splitting *)
+
+ let rec split x = function
+ Empty ->
+ (Empty, None, Empty)
+ | Node(l, v, r, _) ->
+ let c = Ord.compare x v in
+ if c = 0 then (l, Some v, r)
+ else if c < 0 then
+ let (ll, vl, rl) = split x l in (ll, vl, join rl v r)
+ else
+ let (lr, vr, rr) = split x r in (join l v lr, vr, rr)
+
+ (* Implementation of the set operations *)
+
+ let empty = Empty
+
+ let is_empty = function Empty -> true | _ -> false
+
+ let rec mem x = function
+ Empty -> false
+ | Node(l, v, r, _) ->
+ let c = Ord.compare x v in
+ c = 0 || mem x (if c < 0 then l else r)
+
+ let rec add x = function
+ Empty -> Node(Empty, x, Empty, 1)
+ | Node(l, v, r, _) as t ->
+ let c = Ord.compare x v in
+ if c = 0 then t else
+ if c < 0 then bal (add x l) v r else bal l v (add x r)
+
+ let singleton x = Node(Empty, x, Empty, 1)
+
+ let rec remove x = function
+ Empty -> Empty
+ | Node(l, v, r, _) ->
+ let c = Ord.compare x v in
+ if c = 0 then merge l r else
+ if c < 0 then bal (remove x l) v r else bal l v (remove x r)
+
+ let rec union s1 s2 =
+ match (s1, s2) with
+ (Empty, t2) -> t2
+ | (t1, Empty) -> t1
+ | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
+ if h1 >= h2 then
+ if h2 = 1 then add v2 s1 else begin
+ let (l2, _, r2) = split v1 s2 in
+ join (union l1 l2) v1 (union r1 r2)
+ end
+ else
+ if h1 = 1 then add v1 s2 else begin
+ let (l1, _, r1) = split v2 s1 in
+ join (union l1 l2) v2 (union r1 r2)
+ end
+
+ let rec inter s1 s2 =
+ match (s1, s2) with
+ (Empty, t2) -> Empty
+ | (t1, Empty) -> Empty
+ | (Node(l1, v1, r1, _), t2) ->
+ match split v1 t2 with
+ (l2, None, r2) ->
+ concat (inter l1 l2) (inter r1 r2)
+ | (l2, Some _, r2) ->
+ join (inter l1 l2) v1 (inter r1 r2)
+
+ let rec diff s1 s2 =
+ match (s1, s2) with
+ (Empty, t2) -> Empty
+ | (t1, Empty) -> t1
+ | (Node(l1, v1, r1, _), t2) ->
+ match split v1 t2 with
+ (l2, None, r2) ->
+ join (diff l1 l2) v1 (diff r1 r2)
+ | (l2, Some _, r2) ->
+ concat (diff l1 l2) (diff r1 r2)
+
+ let rec compare_aux l1 l2 =
+ match (l1, l2) with
+ ([], []) -> 0
+ | ([], _) -> -1
+ | (_, []) -> 1
+ | (Empty :: t1, Empty :: t2) ->
+ compare_aux t1 t2
+ | (Node(Empty, v1, r1, _) :: t1, Node(Empty, v2, r2, _) :: t2) ->
+ let c = Ord.compare v1 v2 in
+ if c <> 0 then c else compare_aux (r1::t1) (r2::t2)
+ | (Node(l1, v1, r1, _) :: t1, t2) ->
+ compare_aux (l1 :: Node(Empty, v1, r1, 0) :: t1) t2
+ | (t1, Node(l2, v2, r2, _) :: t2) ->
+ compare_aux t1 (l2 :: Node(Empty, v2, r2, 0) :: t2)
+
+ let compare s1 s2 =
+ compare_aux [s1] [s2]
+
+ let equal s1 s2 =
+ compare s1 s2 = 0
+
+ let rec subset s1 s2 =
+ match (s1, s2) with
+ Empty, _ ->
+ true
+ | _, Empty ->
+ false
+ | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) ->
+ let c = Ord.compare v1 v2 in
+ if c = 0 then
+ subset l1 l2 && subset r1 r2
+ else if c < 0 then
+ subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2
+ else
+ subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2
+
+ let rec iter ~f = function
+ Empty -> ()
+ | Node(l, v, r, _) -> iter ~f l; f v; iter ~f r
+
+ let rec fold ~f s ~init:accu =
+ match s with
+ Empty -> accu
+ | Node(l, v, r, _) -> fold ~f l ~init:(f v (fold ~f r ~init:accu))
+
+ let rec for_all ~f:p = function
+ Empty -> true
+ | Node(l, v, r, _) -> p v && for_all ~f:p l && for_all ~f:p r
+
+ let rec exists ~f:p = function
+ Empty -> false
+ | Node(l, v, r, _) -> p v || exists ~f:p l || exists ~f:p r
+
+ let filter ~f:p s =
+ let rec filt accu = function
+ | Empty -> accu
+ | Node(l, v, r, _) ->
+ filt (filt (if p v then add v accu else accu) l) r in
+ filt Empty s
+
+ let partition ~f:p s =
+ let rec part (t, f as accu) = function
+ | Empty -> accu
+ | Node(l, v, r, _) ->
+ part (part (if p v then (add v t, f) else (t, add v f)) l) r in
+ part (Empty, Empty) s
+
+ let rec cardinal = function
+ Empty -> 0
+ | Node(l, v, r, _) -> cardinal l + 1 + cardinal r
+
+ let rec elements_aux accu = function
+ Empty -> accu
+ | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l
+
+ let elements s =
+ elements_aux [] s
+
+ let rec min_elt = function
+ Empty -> raise Not_found
+ | Node(Empty, v, r, _) -> v
+ | Node(l, v, r, _) -> min_elt l
+
+ let rec max_elt = function
+ Empty -> raise Not_found
+ | Node(l, v, Empty, _) -> v
+ | Node(l, v, r, _) -> max_elt r
+
+ let choose = min_elt
+
+ let of_list list =
+ List.fold_left ~f:(fun set el -> add el set) ~init:empty list
+
+ end
+
+module Set = Make(ClassicalType)
Added: sks/branches/upstream/sks/current/pSet.mli
===================================================================
--- sks/branches/upstream/sks/current/pSet.mli (rev 0)
+++ sks/branches/upstream/sks/current/pSet.mli 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,150 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Sets over ordered types.
+
+ This module implements the set data structure, given a total ordering
+ function over the set elements. All operations over sets
+ are purely applicative (no side-effects).
+ The implementation uses balanced binary trees, and is therefore
+ reasonably efficient: insertion and membership take time
+ logarithmic in the size of the set, for instance.
+*)
+
+module type OrderedType =
+ sig
+ val compare : 'elt -> 'elt -> int
+ (** A total ordering function over the set elements.
+ This is a two-argument function [f] such that
+ [f e1 e2] is zero if the elements [e1] and [e2] are equal,
+ [f e1 e2] is strictly negative if [e1] is smaller than [e2],
+ and [f e1 e2] is strictly positive if [e1] is greater than [e2].
+ Example: a suitable ordering function is
+ the generic structural comparison function {!Pervasives.compare}. *)
+ end
+(** Input signature of the functor {!Set.Make}. *)
+
+module type S =
+ sig
+
+ type 'elt t
+ (** The type of sets. *)
+
+ val empty: 'elt t
+ (** The empty set. *)
+
+ val is_empty: 'elt t -> bool
+ (** Test whether a set is empty or not. *)
+
+ val mem: 'elt -> 'elt t -> bool
+ (** [mem x s] tests whether [x] belongs to the set [s]. *)
+
+ val add: 'elt -> 'elt t -> 'elt t
+ (** [add x s] returns a set containing all elements of [s],
+ plus [x]. If [x] was already in [s], [s] is returned unchanged. *)
+
+ val singleton: 'elt -> 'elt t
+ (** [singleton x] returns the one-element set containing only [x]. *)
+
+ val remove: 'elt -> 'elt t -> 'elt t
+ (** [remove x s] returns a set containing all elements of [s],
+ except [x]. If [x] was not in [s], [s] is returned unchanged. *)
+
+ val union: 'elt t -> 'elt t -> 'elt t
+ (** Set union. *)
+
+ val inter: 'elt t -> 'elt t -> 'elt t
+ (** Set interseection. *)
+
+ (** Set difference. *)
+ val diff: 'elt t -> 'elt t -> 'elt t
+
+ val compare: 'elt t -> 'elt t -> int
+ (** Total ordering between sets. Can be used as the ordering function
+ for doing sets of sets. *)
+
+ val equal: 'elt t -> 'elt t -> bool
+ (** [equal s1 s2] tests whether the sets [s1] and [s2] are
+ equal, that is, contain equal elements. *)
+
+ val subset: 'elt t -> 'elt t -> bool
+ (** [subset s1 s2] tests whether the set [s1] is a subset of
+ the set [s2]. *)
+
+ val iter: f:('elt -> unit) -> 'elt t -> unit
+ (** [iter f s] applies [f] in turn to all elements of [s].
+ The order in which the elements of [s] are presented to [f]
+ is unspecified. *)
+
+ val fold: f:('elt -> 'a -> 'a) -> 'elt t -> init:'a -> 'a
+ (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)],
+ where [x1 ... xN] are the elements of [s].
+ The order in which elements of [s] are presented to [f] is
+ unspecified. *)
+
+ val for_all: f:('elt -> bool) -> 'elt t -> bool
+ (** [for_all p s] checks if all elements of the set
+ satisfy the predicate [p]. *)
+
+ val exists: f:('elt -> bool) -> 'elt t -> bool
+ (** [exists p s] checks if at least one element of
+ the set satisfies the predicate [p]. *)
+
+ val filter: f:('elt -> bool) -> 'elt t -> 'elt t
+ (** [filter p s] returns the set of all elements in [s]
+ that satisfy predicate [p]. *)
+
+ val partition: f:('elt -> bool) -> 'elt t -> 'elt t * 'elt t
+ (** [partition p s] returns a pair of sets [(s1, s2)], where
+ [s1] is the set of all the elements of [s] that satisfy the
+ predicate [p], and [s2] is the set of all the elements of
+ [s] that do not satisfy [p]. *)
+
+ val cardinal: 'elt t -> int
+ (** Return the number of elements of a set. *)
+
+ val elements: 'elt t -> 'elt list
+ (** Return the list of all elements of the given set.
+ The returned list is sorted in increasing order with respect
+ to the ordering [Ord.compare], where [Ord] is the argument
+ given to {!Set.Make}. *)
+
+ val min_elt: 'elt t -> 'elt
+ (** Return the smallest element of the given set
+ (with respect to the [Ord.compare] ordering), or raise
+ [Not_found] if the set is empty. *)
+
+ val max_elt: 'elt t -> 'elt
+ (** Same as {!Set.S.min_elt}, but returns the largest element of the
+ given set. *)
+
+ val choose: 'elt t -> 'elt
+ (** Return one element of the given set, or raise [Not_found] if
+ the set is empty. Which element is chosen is unspecified,
+ but equal elements will be chosen for equal sets. *)
+
+ val of_list: 'elt list -> 'elt t
+ (** Returns a set constructed from the list elements *)
+
+ end
+(** Output signature of the functor {!Set.Make}. *)
+
+module Make (Ord : OrderedType) : S
+(** Functor building an implementation of the set structure
+ given a totally ordered type. *)
+
+module Set : S
Added: sks/branches/upstream/sks/current/pTreeDB.ml
===================================================================
--- sks/branches/upstream/sks/current/pTreeDB.ml (rev 0)
+++ sks/branches/upstream/sks/current/pTreeDB.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,188 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+open Bdb
+open Common
+module Unix = UnixLabels
+
+type ptree_settings = { mbar: int;
+ bitquantum: int;
+ treetype: [ `ondisk | `transactional | `inmem ];
+ max_nodes: int;
+ dbdir: string;
+ cache_bytes: int option;
+ pagesize: int option;
+ }
+
+exception No_db
+
+type dbstate = { settings: ptree_settings;
+ dbenv: Dbenv.t;
+ db: Db.t;
+ }
+
+(* let num_samples = mbar + 1 *)
+
+(***************************************************************)
+(* Database and PTree setup ************************************)
+(***************************************************************)
+
+(** DB access methods. The following will be passed on to the prefixtree *)
+
+let dbstate = ref None
+
+let get_dbs () =
+ match !dbstate with
+ | None -> raise No_db
+ | Some dbs -> dbs
+
+let dbs () = get_dbs ()
+let settings () = (get_dbs ()).settings
+
+let closedb () =
+ match !dbstate with
+ None -> ()
+ | Some dbs ->
+ Db.close dbs.db;
+ Dbenv.close dbs.dbenv
+
+let load key =
+ let dbs = get_dbs () in
+ let rval = Db.get dbs.db key [] in
+ rval
+
+let save txn ~key ~data =
+ let dbs = get_dbs () in
+ Db.put ?txn dbs.db ~key ~data []
+
+let delete txn key =
+ let dbs = get_dbs () in
+ Db.del ?txn dbs.db key
+
+(*****************************************************************)
+(** txnopt operations do nothing if transactions are not enabled *)
+
+let new_txnopt () =
+ let dbs = get_dbs () in
+ if dbs.settings.treetype = `transactional then
+ Some (Txn.txn_begin dbs.dbenv None [])
+ else None
+
+let commit_txnopt txn =
+ (match txn with None -> () | Some txn -> Txn.commit txn [])
+
+let abort_txnopt txn =
+ (match txn with None -> () | Some txn -> Txn.abort txn)
+
+let checkpoint ?(kbyte=0) ?(min=0) () =
+ match !dbstate with
+ None -> ()
+ | Some dbs ->
+ if dbs.settings.treetype = `transactional then (
+ plerror 5 "Checkpointing database";
+ Txn.checkpoint dbs.dbenv ~kbyte ~min [];
+ )
+
+(*****************************************************************)
+(** Returns a tuple containing database information needed by ptree *)
+let get_db () = match !dbstate with
+ None -> None
+ | Some dbs ->
+ Some (load,save,delete,
+ (new_txnopt,commit_txnopt,abort_txnopt),
+ dbs.settings.max_nodes)
+
+(*****************************************************************)
+
+(** Set up ptree database if such is necessary *)
+let open_ptree_db settings =
+ match settings.treetype with
+
+ | `inmem -> None
+
+ | `ondisk | `transactional as treetype ->
+ plerror 3 "Opening PTree database";
+
+ if not (Sys.file_exists settings.dbdir )
+ then Unix.mkdir settings.dbdir ~perm:0o700;
+ let dbenv = Dbenv.create () in
+ ( match settings.cache_bytes with None -> ()
+ | Some cache_bytes -> Dbenv.set_cachesize dbenv
+ ~gbytes:0 ~bytes:cache_bytes ~ncache:0);
+ Dbenv.dopen dbenv settings.dbdir
+ ([Dbenv.INIT_MPOOL; (*Dbenv.INIT_LOCK;*) Dbenv.CREATE] @ (
+ match treetype with
+ | `transactional -> [Dbenv.INIT_TXN; Dbenv.RECOVER]
+ | `ondisk -> []))
+ 0o600;
+ let db = Db.create ~dbenv [] in
+ ( match settings.pagesize with
+ | None -> ()
+ | Some pagesize -> Db.set_pagesize db pagesize );
+ Db.dopen db "ptree" Db.BTREE
+ ( match treetype with
+ | `transactional -> [Db.CREATE; Db.AUTO_COMMIT]
+ | `ondisk -> [Db.CREATE] )
+ 0o600;
+ Some { settings = settings;
+ dbenv = dbenv;
+ db = db;
+ }
+
+let init_db settings =
+ match !dbstate with
+ Some _ -> failwith "Attempt to re-initialize PTreeDB";
+ | None -> dbstate := open_ptree_db settings
+
+(** Code for initiating in-memory ptree that reflects on-disk version *)
+
+module PTree = PrefixTree
+
+exception No_ptree
+
+let ptree_ref = ref None
+
+let get_ptree () = match !ptree_ref with
+ | None -> raise No_ptree
+ | Some ptree -> ptree
+
+(** Setup prefix tree, using disk-based access and transactions
+ as specified *)
+let init_ptree settings =
+ plerror 3 "Setting up PTree data structure";
+ let txn = new_txnopt () in
+ try
+ let db = get_db () in
+ let ptree =
+ PTree.create ?db
+ ~txn ~num_samples:(settings.mbar + 1) ~bitquantum:settings.bitquantum
+ ~thresh:(settings.mbar * !Settings.ptree_thresh_mult)
+ ()
+ in
+ commit_txnopt txn;
+ plerror 3 "PTree setup complete";
+ ptree_ref := Some ptree
+ with
+ e ->
+ abort_txnopt txn;
+ closedb ();
+ raise e
+
+
+
Added: sks/branches/upstream/sks/current/packet.ml
===================================================================
--- sks/branches/upstream/sks/current/packet.ml (rev 0)
+++ sks/branches/upstream/sks/current/packet.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,280 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Type definitions and simple functions related to PGP packets *)
+
+open Printf
+
+type ptype = | Reserved
+ | Public_Key_Encrypted_Session_Key_Packet
+ | Signature_Packet
+ | Symmetric_Key_Encrypted_Session_Key_Packet
+ | One_Pass_Signature_Packet
+ | Secret_Key_Packet
+ | Public_Key_Packet
+ | Secret_Subkey_Packet
+ | Compressed_Data_Packet
+ | Symmetrically_Encrypted_Data_Packet
+ | Marker_Packet
+ | Literal_Data_Packet
+ | Trust_Packet
+ | User_ID_Packet
+ | User_Attribute_Packet
+ | Sym_Encrypted_and_Integrity_Protected_Data_Packet
+ | Modification_Detection_Code_Packet
+ | Public_Subkey_Packet
+ | Private_or_Experimental_ptype
+ | Unexpected_ptype
+
+type packet = { content_tag: int;
+ packet_type: ptype;
+ packet_length: int;
+ packet_body: string;
+ }
+
+type sigsubpacket =
+ { ssp_length: int;
+ ssp_type: int;
+ ssp_body: string;
+ }
+
+let ssp_type_to_string i = match i with
+ | 2 -> "signature creation time"
+ | 3 -> "signature expiration time"
+ | 4 -> "exportable certification"
+ | 5 -> "trust signature"
+ | 6 -> "regular expression"
+ | 7 -> "revocable"
+ | 9 -> "key expiration time"
+ | 10 -> "placeholder for backward compatibility"
+ | 11 -> "preferred symmetric algorithms"
+ | 12 -> "revocation key"
+ | 16 -> "issuer key ID"
+ | 20 -> "notation data"
+ | 21 -> "preferred hash algorithms"
+ | 22 -> "preferred compression algorithms"
+ | 23 -> "key server preferences"
+ | 24 -> "preferred key server"
+ | 25 -> "primary user id"
+ | 26 -> "policy URL"
+ | 27 -> "key flags"
+ | 28 -> "signer's user id"
+ | 29 -> "reason for revocation"
+ | x when x >= 100 && x <= 110 -> "internal or user-defined"
+ | _ -> failwith "Unexpected sigsubpacket type"
+
+type key = packet list
+
+let sigtype_to_string sigtype = match sigtype with
+ | 0x00 -> "signature of binary document"
+ | 0x01 -> "signature of canonical text document"
+ | 0x02 -> "Standalone signature"
+ | 0x10 -> "Generic certification of a User ID and Public Key packet"
+ | 0x11 -> "Persona certification of a User ID and Public Key packet"
+ | 0x12 -> "Casual certification of a User ID and Public Key packet"
+ | 0x13 -> "Positive certification of a User ID and Public Key packet"
+ | 0x18 -> "Subkey Binding Signature"
+ | 0x1F -> "Signature directly on a key"
+ | 0x20 -> "Key revocation signature"
+ | 0x28 -> "Subkey revocation signature"
+ | 0x30 -> "Certification revocation signature"
+ | 0x40 -> "Timestamp signature"
+ | _ -> "UNEXPECTED SIGTYPE"
+
+let content_tag_to_ptype tag = match tag with
+ | 0 -> Reserved
+ | 1 -> Public_Key_Encrypted_Session_Key_Packet
+ | 2 -> Signature_Packet
+ | 3 -> Symmetric_Key_Encrypted_Session_Key_Packet
+ | 4 -> One_Pass_Signature_Packet
+ | 5 -> Secret_Key_Packet
+ | 6 -> Public_Key_Packet
+ | 7 -> Secret_Subkey_Packet
+ | 8 -> Compressed_Data_Packet
+ | 9 -> Symmetrically_Encrypted_Data_Packet
+ | 10 -> Marker_Packet
+ | 11 -> Literal_Data_Packet
+ | 12 -> Trust_Packet
+ | 13 -> User_ID_Packet
+ | 14 -> Public_Subkey_Packet
+ | 17 -> User_Attribute_Packet
+ | 18 -> Sym_Encrypted_and_Integrity_Protected_Data_Packet
+ | 19 -> Modification_Detection_Code_Packet
+ | 60 | 61 | 62 | 63 -> Private_or_Experimental_ptype
+ | _ -> Unexpected_ptype
+
+let ptype_to_string ptype = match ptype with
+ | Reserved -> "Reserved - a packet tag must not have this value"
+ | Public_Key_Encrypted_Session_Key_Packet -> "Public-Key Encrypted Session Key Packet"
+ | Signature_Packet -> "Signature Packet"
+ | Symmetric_Key_Encrypted_Session_Key_Packet -> "Symmetric-Key Encrypted Session Key Packet"
+ | One_Pass_Signature_Packet -> "One-Pass Signature Packet"
+ | Secret_Key_Packet -> "Secret Key Packet"
+ | Public_Key_Packet -> "Public Key Packet"
+ | Secret_Subkey_Packet -> "Secret Subkey Packet"
+ | Compressed_Data_Packet -> "Compressed Data Packet"
+ | Symmetrically_Encrypted_Data_Packet -> "Symmetrically Encrypted Data Packet"
+ | Marker_Packet -> "Marker Packet"
+ | Literal_Data_Packet -> "Literal Data Packet"
+ | Trust_Packet -> "Trust Packet"
+ | User_ID_Packet -> "User ID Packet"
+ | Public_Subkey_Packet -> "Public Subkey Packet"
+ | User_Attribute_Packet -> "User Attribute Packet"
+ | Sym_Encrypted_and_Integrity_Protected_Data_Packet ->
+ "Sym Encrypted and Integrity Protected Data Packet"
+ | Modification_Detection_Code_Packet -> "Modification Detection Code Packet"
+ | Private_or_Experimental_ptype -> "Private or Experimental Values"
+ | Unexpected_ptype -> "Unexpected value"
+
+type mpi = { mpi_bits: int;
+ mpi_data: string;
+ }
+
+let pubkey_algorithm_string i = match i with
+ | 1 -> "RSA (Encrypt or Sign)"
+ | 2 -> "RSA Encrypt-Only"
+ | 3 -> "RSA Sign-Only"
+ | 16 -> "Elgamal (Encrypt-Only), see [ELGAMAL]"
+ | 17 -> "DSA (Digital Signature Standard)"
+ | 18 -> "Reserved for Elliptic Curve"
+ | 19 -> "Reserved for ECDSA"
+ | 20 -> "Elgamal (Encrypt or Sign)"
+ | 21 -> "Reserved for Diffie-Hellman (X9.42) as defined for IETF-S/MIME"
+ | x when x >= 100 && x <= 110 -> "Private/Experimental algorithm."
+ | _ -> "Unknown Public Key Algorithm"
+
+
+type pubkeyinfo =
+ { pk_version: int;
+ pk_ctime: int64;
+ pk_expiration: int option;
+ pk_alg: int;
+ pk_keylen: int;
+ }
+
+
+
+type sigtype = | Signature_of_a_binary_document
+ | Signature_of_a_canonical_text_document
+ | Standalone_signature
+ | Generic_certification_of_a_User_ID_and_Public_Key_packet
+ | Persona_certification_of_a_User_ID_and_Public_Key_packet
+ | Casual_certification_of_a_User_ID_and_Public_Key_packet
+ | Positive_certification_of_a_User_ID_and_Public_Key_packet
+ | Subkey_Binding_Signature
+ | Signature_directly_on_a_key
+ | Key_revocation_signature
+ | Subkey_revocation_signature
+ | Certification_revocation_signature
+ | Timestamp_signature
+ | Unexpected_sigtype
+
+type v3sig =
+ { v3s_sigtype: int;
+ v3s_ctime: int64;
+ v3s_keyid: string;
+ v3s_pk_alg: int;
+ v3s_hash_alg: int;
+ v3s_hash_value: string;
+ v3s_mpis: mpi list;
+ }
+
+type v4sig =
+ { v4s_sigtype: int;
+ v4s_pk_alg: int;
+ v4s_hashed_subpackets: sigsubpacket list;
+ v4s_unhashed_subpackets: sigsubpacket list;
+ v4s_hash_value: string;
+ v4s_mpis: mpi list;
+ }
+
+type signature = V3sig of v3sig | V4sig of v4sig
+
+let int_to_sigtype byte =
+ match byte with
+ | 0x00 -> Signature_of_a_binary_document
+ | 0x01 -> Signature_of_a_canonical_text_document
+ | 0x02 -> Standalone_signature
+ | 0x10 -> Generic_certification_of_a_User_ID_and_Public_Key_packet
+ | 0x11 -> Persona_certification_of_a_User_ID_and_Public_Key_packet
+ | 0x12 -> Casual_certification_of_a_User_ID_and_Public_Key_packet
+ | 0x13 -> Positive_certification_of_a_User_ID_and_Public_Key_packet
+ | 0x18 -> Subkey_Binding_Signature
+ | 0x1F -> Signature_directly_on_a_key
+ | 0x20 -> Key_revocation_signature
+ | 0x28 -> Subkey_revocation_signature
+ | 0x30 -> Certification_revocation_signature
+ | 0x40 -> Timestamp_signature
+ | _ -> Unexpected_sigtype
+
+let content_tag_to_string tag =
+ ptype_to_string (content_tag_to_ptype tag)
+
+let print_packet packet =
+ printf "%s\n" (ptype_to_string packet.packet_type);
+ printf "Length: %d\n" packet.packet_length;
+ if packet.packet_type = User_ID_Packet
+ then (print_string packet.packet_body; print_string "\n")
+
+(** write out new-style packet *)
+let write_packet_new packet cout =
+ (* specify new packet format *)
+ cout#write_byte (packet.content_tag lor 0xC0);
+ cout#write_byte 0xFF;
+ cout#write_int packet.packet_length;
+ cout#write_string packet.packet_body
+
+let pk_alg_to_ident i = match i with
+ | 1 -> "R" (* RSA sign and encrypt *)
+ | 2 -> "r" (* RSA encrypt *)
+ | 3 -> "s" (* RSA sign *)
+ | 16 -> "g" (* ElGamal encrypt *)
+ | 20 -> "G" (* ElGamal sign and encrypt *)
+ | 17 -> "D" (* DSA *)
+ | _ -> "?" (* NoClue *)
+
+(** writes out packet, using old-style packets when possible *)
+let write_packet_old packet cout =
+ if packet.content_tag >= 16
+ then (* write new-style packet *)
+ write_packet_new packet cout
+ else (* write old-style packet *)
+ begin
+ let length_type =
+ if packet.packet_length < 256 then 0
+ else if packet.packet_length < 65536 then 1
+ else 2
+ in
+ cout#write_byte ((packet.content_tag lsl 2) lor 0x80 lor length_type);
+ (match length_type with
+ 0 -> cout#write_byte packet.packet_length
+ | 1 ->
+ cout#write_byte ((packet.packet_length lsr 8) land 0xFF);
+ cout#write_byte (packet.packet_length land 0xFF);
+ | 2 ->
+ cout#write_byte ((packet.packet_length lsr 24) land 0xFF);
+ cout#write_byte ((packet.packet_length lsr 16) land 0xFF);
+ cout#write_byte ((packet.packet_length lsr 8) land 0xFF);
+ cout#write_byte (packet.packet_length land 0xFF);
+ | _ ->
+ failwith "Packet.write_packet_old: Bug -- bad packet length"
+ );
+ cout#write_string packet.packet_body
+ end
+
+
+let write_packet = write_packet_old
Added: sks/branches/upstream/sks/current/parsePGP.ml
===================================================================
--- sks/branches/upstream/sks/current/parsePGP.ml (rev 0)
+++ sks/branches/upstream/sks/current/parsePGP.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,290 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+
+open Common
+open Packet
+open Printf
+
+exception Overlong_mpi
+exception Partial_body_length of int
+
+(********************************************************)
+
+(** parse new-style packet length *)
+let parse_new_packet_length cin =
+ let byte1 = cin#read_byte in
+ if byte1 <= 191 then byte1 (* one-octet length *)
+ else if byte1 <= 223 then (* two-octet length *)
+ let byte2 = cin#read_byte in
+ (byte1 - 192) lsl 8 + byte2 + 192
+ else if byte1 = 255 then (* five-octet length *)
+ let byte2 = cin#read_byte in
+ let byte3 = cin#read_byte in
+ let byte4 = cin#read_byte in
+ let byte5 = cin#read_byte in
+ (byte2 lsl 24) lor (byte3 lsl 16) lor (byte4 lsl 8) lor byte5
+ else (* partial body length *)
+ raise (Partial_body_length (1 lsl (byte1 land 0x1f)))
+
+(********************************************************)
+
+let read_packet cin =
+ let packet_tag = cin#read_byte in
+ if ((packet_tag lsr 7) land 1 <> 1)
+ then failwith (sprintf "Bit 7 of packet tag was not 1 as expected: %x"
+ packet_tag);
+ match (packet_tag lsr 6) land 1 with
+
+ 0 -> (* old format *)
+ let content_tag = (packet_tag land 0b111100) lsr 2
+ and length_type = packet_tag land 0b11
+ in
+ (match length_type with
+ 0 | 1 | 2 ->
+ let length_length = 1 lsl length_type in
+ let length_str = cin#read_string length_length in
+ let length = Utils.int_from_bstring length_str
+ ~pos:0 ~len:length_length in
+ { content_tag = content_tag;
+ packet_type = content_tag_to_ptype content_tag;
+ packet_length = length;
+ packet_body = cin#read_string length;
+ }
+
+ | 3 -> (* indeterminate length header --- extends to end of file *)
+ failwith "Unexpected indeterminate length packet"
+ | _ ->
+ failwith "Unexpected length type"
+ )
+
+ | 1 -> (* new_format *)
+ let content_tag = packet_tag land 0b111111 in
+ let length = parse_new_packet_length cin in
+ { (* packet_tag = packet_tag; *)
+ content_tag = content_tag;
+ packet_type = content_tag_to_ptype content_tag;
+ packet_length = length;
+ packet_body = cin#read_string length;
+ }
+
+ | _ -> raise (Bug "ParsePGP.read_packet: expected 0/1 value")
+
+
+(********************************************************)
+
+let offset_read_packet cin =
+ let offset = LargeFile.pos_in cin#inchan in
+ let packet = read_packet cin in
+ (offset,packet)
+
+(********************************************************)
+
+let offset_length_read_packet cin =
+ let offset = pos_in cin#inchan in
+ let packet = read_packet cin in
+ let final_offset = pos_in cin#inchan in
+ (packet,offset,final_offset - offset)
+
+(********************************************************)
+
+let read_mpi cin =
+ let byte1 = cin#read_byte in
+ try
+ let byte2 = cin#read_byte in
+ let length = (byte1 lsl 8) + byte2 in
+ let data = cin#read_string
+ ((length + 7)/8)
+ in
+ { mpi_bits = length; mpi_data = data }
+ with
+ End_of_file -> raise Overlong_mpi
+
+(********************************************************)
+
+let read_mpis cin =
+ let rec loop list =
+ match (try (Some (read_mpi cin))
+ with End_of_file -> None)
+ with
+ | Some mpi -> loop (mpi::list)
+ | None -> List.rev list
+ in
+ loop []
+
+(********************************************************)
+
+let parse_pubkey_info packet =
+ let cin = new Channel.string_in_channel packet.packet_body 0 in
+ let version = cin#read_byte in
+ let creation_time = cin#read_int64_size 4 in
+ let (algorithm,mpis,expiration) =
+ match version with
+ | 4 ->
+ let algorithm = cin#read_byte in
+ let mpis = read_mpis cin in
+ (algorithm,mpis,None)
+ | 2 | 3 ->
+ let expiration = cin#read_int_size 2 in
+ let algorithm = cin#read_byte in
+ let mpis = read_mpis cin in
+ (algorithm,mpis,Some expiration)
+ | _ -> failwith (sprintf "Unexpected pubkey version: %d" version)
+ in
+ let mpi = List.hd mpis in
+ { pk_version = version;
+ pk_ctime = creation_time;
+ pk_expiration = (match expiration with Some 0 -> None | x -> x);
+ pk_alg = algorithm;
+ pk_keylen = mpi.mpi_bits;
+ }
+
+(********************************************************)
+
+
+(** Parsing of signature subpackets *)
+
+(** parse sigsubpacket length *)
+let parse_sigsubpacket_length cin =
+ let byte1 = cin#read_byte in
+ if byte1 < 192 then byte1 (* one octet length *)
+ else if byte1 < 255 then
+ let byte2 = cin#read_byte in
+ ((byte1 - 192) lsl 8) + (byte2) + 192
+ else if byte1 = 255 then (* five-octet length *)
+ let byte2 = cin#read_byte in
+ let byte3 = cin#read_byte in
+ let byte4 = cin#read_byte in
+ let byte5 = cin#read_byte in
+ (byte2 lsl 24) lor (byte3 lsl 16) lor (byte4 lsl 8) lor byte5
+ else
+ failwith "Unable to parse sigsubpacket length"
+
+let read_sigsubpacket cin =
+ let length = parse_sigsubpacket_length cin in
+ let ssp_type = cin#read_byte land 0x7f in
+ let body = cin#read_string (length - 1) in
+ { ssp_length = length - 1;
+ ssp_type = ssp_type;
+ ssp_body = body;
+ }
+
+let get_hashed_subpacket_string cin =
+ let version = cin#read_byte in
+ if version <> 4 then
+ failwith "Attempt to parse non-v4 signature as v4 signature";
+ let _sigtype = cin#read_byte in
+ let _key_alg = cin#read_byte in
+ let _hash_alg = cin#read_byte in
+ let hashed_subpacket_count = cin#read_int_size 2 in
+ (* now we can start reading the hashed sub-packets *)
+ cin#read_string hashed_subpacket_count
+
+(** return list of signature sub-packets *)
+let read_subpackets cin length =
+ let subpacket_string = cin#read_string length in
+ let cin = new Channel.string_in_channel subpacket_string 0 in
+ let rec loop list =
+ match (try Some (read_sigsubpacket cin)
+ with End_of_file -> None)
+ with
+ | Some subpack -> loop (subpack::list)
+ | None -> List.rev list
+ in
+ loop []
+
+let parse_signature packet =
+ let cin = new Channel.string_in_channel packet.packet_body 0 in
+ let version = cin#read_byte in
+ match version with
+
+ | 2 | 3 ->
+ cin#skip 1; (* length packet which must be 5 *)
+ let sigtype = cin#read_byte in
+ let ctime = cin#read_int64_size 4 in
+ let keyid = cin#read_string 8 in
+ let pk_alg = cin#read_byte in
+ let hash_alg = cin#read_byte in
+ let hash_value = cin#read_string 2 in
+ let mpis = read_mpis cin in
+ V3sig { v3s_sigtype = sigtype;
+ v3s_ctime = ctime;
+ v3s_keyid = keyid;
+ v3s_pk_alg = pk_alg;
+ v3s_hash_alg = hash_alg;
+ v3s_hash_value = hash_value;
+ v3s_mpis = mpis;
+ }
+
+ | 4 ->
+ let sigtype = cin#read_byte in
+ let pk_alg = cin#read_byte in
+ let _hash_alg = cin#read_byte in
+
+ let hashed_subpacket_bytes = cin#read_int_size 2 in
+ let hashed_subpackets = read_subpackets cin hashed_subpacket_bytes in
+
+ let unhashed_subpacket_bytes = cin#read_int_size 2 in
+ let unhashed_subpackets = read_subpackets cin unhashed_subpacket_bytes in
+
+ let hash_value = cin#read_string 2 in
+ let mpis = read_mpis cin in
+ V4sig { v4s_sigtype = sigtype;
+ v4s_pk_alg = pk_alg;
+ v4s_hashed_subpackets = hashed_subpackets;
+ v4s_unhashed_subpackets = unhashed_subpackets;
+ v4s_hash_value = hash_value;
+ v4s_mpis = mpis;
+ }
+
+
+ | _ -> failwith (sprintf "Unexpected signature version: %d" version)
+
+
+let ssp_ctime_id = 2
+let ssp_exptime_id = 3
+
+let int32_of_string s =
+ let cin = new Channel.string_in_channel s 0 in
+ cin#read_int32
+
+let int64_of_string s =
+ let cin = new Channel.string_in_channel s 0 in
+ cin#read_int64_size (String.length s)
+
+let get_times sign = match sign with
+ | V3sig sign ->
+ (Some sign.v3s_ctime, None)
+ | V4sig sign ->
+ let hashed_subpackets = sign.v4s_hashed_subpackets in
+ let (ctime,exptime_delta) =
+ List.fold_left hashed_subpackets ~init:(None,None)
+ ~f:(fun (ctime,exptime) ssp ->
+ if ssp.ssp_type = ssp_ctime_id && ssp.ssp_length = 4 then
+ (Some (int64_of_string ssp.ssp_body),exptime)
+ else if ssp.ssp_type = ssp_exptime_id && ssp.ssp_length = 4 then
+ (ctime,Some (int64_of_string ssp.ssp_body))
+ else
+ (ctime,exptime)
+ )
+ in
+ match (ctime,exptime_delta) with
+ | (Some x,None) -> (Some x,None)
+ | (None,_) -> (None,None)
+ | (Some x,Some y) -> (Some x,Some (Int64.add x y))
Added: sks/branches/upstream/sks/current/pbuild.ml
===================================================================
--- sks/branches/upstream/sks/current/pbuild.ml (rev 0)
+++ sks/branches/upstream/sks/current/pbuild.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,104 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Executable: Builds a prefix-tree database from an existing Keydb *)
+
+module F(M:sig end) =
+struct
+ open StdLabels
+ open MoreLabels
+ open Printf
+ open Common
+ open Bdb
+ module PTree = PrefixTree
+
+ let keydb_settings = {
+ Keydb.withtxn = false;
+ Keydb.cache_bytes = !Settings.cache_bytes;
+ Keydb.pagesize = !Settings.pagesize;
+ Keydb.dbdir = (Lazy.force Settings.dbdir);
+ Keydb.dumpdir = (Lazy.force Settings.dumpdir);
+ }
+
+ module Keydb = Keydb.Safe
+
+ open PTreeDB
+
+ let ptree_settings = {
+ mbar = !Settings.mbar;
+ bitquantum = !Settings.bitquantum;
+ treetype = `ondisk;
+ max_nodes = !Settings.max_ptree_nodes;
+ dbdir = Lazy.force Settings.ptree_dbdir;
+ cache_bytes = !Settings.ptree_cache_bytes;
+ pagesize = !Settings.ptree_pagesize;
+ }
+
+ let num_samples = ptree_settings.mbar + 1
+
+
+ let rec get_n n str = match n with
+ 0 -> []
+ | _ ->
+ match SStream.next str with
+ None -> []
+ | Some x -> x::(get_n (n-1) str)
+
+ let process_hashes hashes ptree =
+ List.iter ~f:(PTree.insert_str ptree None) hashes
+
+ let run str () =
+ let ptree = PTree.create ?db:(get_db ()) ~txn:None
+ ~num_samples ~bitquantum:ptree_settings.bitquantum
+ ~thresh:(ptree_settings.mbar * !Settings.ptree_thresh_mult) ()
+ in
+ let count = ref 0 in
+ while
+ match get_n 5000 str with
+ [] -> false
+ | hashes ->
+ process_hashes hashes ptree;
+ count := !count + List.length hashes;
+ perror "%d hashes processed" !count;
+ true
+ do () done;
+ let last_ts = Keydb.last_ts () in
+ PTree.set_synctime ptree last_ts;
+ perror "Cleaning Tree.";
+ PTree.clean None ptree
+
+ let run () =
+ set_logfile "pbuild";
+
+ if Sys.file_exists (Lazy.force Settings.ptree_dbdir) then (
+ printf "PTree directory already exists. Exiting.\n";
+ exit (-1)
+ );
+
+ PTreeDB.init_db ptree_settings;
+
+ perror "Opening dbs...";
+ Keydb.open_dbs keydb_settings;
+
+ let (hstr,hstr_close) = Keydb.create_hashstream () in
+ protect ~f:(run hstr)
+ ~finally:(fun () ->
+ PTreeDB.closedb ();
+ hstr_close ();
+ Keydb.close_dbs ();
+ )
+end
Added: sks/branches/upstream/sks/current/pdiskTest.ml
===================================================================
--- sks/branches/upstream/sks/current/pdiskTest.ml (rev 0)
+++ sks/branches/upstream/sks/current/pdiskTest.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,130 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+open Printf
+open Common
+open Packet
+module Unix = UnixLabels
+module PTree = PrefixTree
+open Bdb
+
+module Set = PSet.Set
+
+let mbar = !Settings.mbar
+let bitquantum = !Settings.bitquantum
+
+let num_samples = mbar + 1
+let bytes = ZZp.num_bytes () - 1
+
+(* Generate DB *)
+let db_fname = "ptree.db"
+let () = if Sys.file_exists db_fname then Unix.unlink db_fname
+let db = Db.sopen db_fname Db.BTREE [Db.CREATE] 0o600
+
+let load key = Db.get db key []
+let save (txn: unit option) ~key ~data = Db.put db ~key ~data []
+let delete (txn: unit option) key = Db.del db key
+let dbtup = (load,save,delete,!Settings.max_ptree_nodes)
+
+let db_ptree =
+ PTree.create ?db:(Some dbtup) ~txn:None
+ ~num_samples ~bitquantum ~thresh:mbar ()
+
+let (ptree:unit PTree.tree) =
+ PTree.create ?db:None ~txn:None
+ ~num_samples ~bitquantum ~thresh:mbar ()
+
+let set = ref Set.empty
+
+let add_element () =
+ let rstring = RMisc.random_string Random.bits bytes in
+ set := Set.add rstring !set;
+ PTree.insert_str ptree None rstring;
+ PTree.insert_str db_ptree None rstring
+
+let del_element () =
+ if PTree.size (PTree.root ptree) < 10
+ then ()
+ else
+ let element = PTree.get_random ptree (PTree.root ptree) in
+ PTree.delete_str ptree None element;
+ PTree.delete_str db_ptree None element;
+ set := Set.remove element !set
+
+
+let node_eq n1 n2 =
+ (n1.PTree.svalues = n2.PTree.svalues) &&
+ (n1.PTree.num_elements = n2.PTree.num_elements) &&
+ (n1.PTree.key = n2.PTree.key) &&
+ match (n1.PTree.children,n2.PTree.children) with
+ (PTree.Leaf _, PTree.Children _)
+ | (PTree.Children _, PTree.Leaf _) -> false
+ | (PTree.Leaf e1,PTree.Leaf e2) -> Set.equal e1 e2
+ | (PTree.Children e1, PTree.Children e2) -> true
+ (* we don't test the children *)
+
+let sef = true
+let rec eqtest (tree1,node1) (tree2,node2) =
+ if node_eq node1 node2 then (
+ if PTree.is_leaf node1 && PTree.is_leaf node2
+ then `passed
+ else
+ let keys = PTree.child_keys tree1 node1.PTree.key in
+ let rec loop keys = match keys with
+ [] -> `passed
+ | key::tl ->
+ let nnode1 = PTree.get_node_key ~sef tree1 key
+ and nnode2 = PTree.get_node_key ~sef tree2 key in
+ match eqtest (tree1,nnode1) (tree2,nnode2) with
+ `passed -> loop tl
+ | x -> x
+ in
+ loop keys
+ ) else
+ `failed (node1,node2)
+
+
+let eqtest tree1 tree2 =
+ eqtest (tree1, PTree.root tree1) (tree2, PTree.root tree2)
+
+let rec runtest n =
+ if n > 0 then (
+ if Random.float 1. > !Settings.prob
+ then add_element () else del_element ();
+ runtest (n - 1)
+ ) else (
+ printf "-------- Running Equality Test -------------\n";
+ match eqtest ptree db_ptree with
+ `passed -> printf "All tests passed\n"
+ | `failed (n1,n2) ->
+ printf "Equality tests failed. Differing nodes have keys:\n";
+ printf " %s, %s\n"
+ (Bitstring.to_string n1.PTree.key)
+ (Bitstring.to_string n2.PTree.key)
+ )
+
+let n = !Settings.n
+let timer = MTimer.create ()
+let () =
+ if not !Sys.interactive then (
+ MTimer.start timer;
+ runtest n;
+ MTimer.stop timer;
+ printf "Time elapsed: %f secs\n" (MTimer.read timer)
+ )
Added: sks/branches/upstream/sks/current/poly.ml
===================================================================
--- sks/branches/upstream/sks/current/poly.ml (rev 0)
+++ sks/branches/upstream/sks/current/poly.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,224 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Simple polynomial implementation *)
+open StdLabels
+open MoreLabels
+module Unix = UnixLabels
+open Printf
+open Scanf
+open ZZp.Infix
+module Map = PMap.Map
+
+let rec rfind ~f low high =
+ if low >= high then raise Not_found
+ else if f(low) then low
+ else rfind ~f (low + 1) high
+
+type t = { a : ZZp.zz array;
+ (** coefficients, listed from lowest to highest degree *)
+ degree : int; (** degree of polynomial *)
+ }
+
+let compute_degree a =
+ let rec loop a i =
+ if i <= 0 then 0
+ else (
+ if a.(i) =: ZZp.zero
+ then loop a (i - 1)
+ else i
+ )
+ in
+ loop a (Array.length a - 1)
+
+let init degree ~f =
+ let a = Array.init (degree + 1) ~f:(fun i -> f i) in
+ let degree = compute_degree a in
+ { a = (if degree + 1 < Array.length a
+ then Array.sub a ~pos:0 ~len:(degree + 1)
+ else a);
+ degree = degree;
+ }
+
+let make degree x =
+ if x =: ZZp.zero then { a = [| ZZp.zero |]; degree = 0; }
+ else
+ { a = Array.init (degree + 1) ~f:(fun i -> x);
+ degree = degree;
+ }
+
+let zero = make 0 ZZp.zero
+let one = make 0 ZZp.one
+
+(* Get and set coeffs *)
+(*let getc x i = x.a.(i)
+ let setc x i v = x.a.(i) <- v
+ let lgetc x i = x.a.(i)
+ let rgetc x i = x.a.(i) *)
+let degree x = x.degree
+let length x = Array.length x.a
+
+let copy x = { x with a = Array.copy x.a }
+
+let to_string x =
+ let buf = Buffer.create 0 in
+ for i = degree x downto 1 do
+ bprintf buf "%s z^%d + " (ZZp.to_string x.a.(i)) i;
+ done;
+ if degree x >= 0
+ then bprintf buf "%s" (ZZp.to_string x.a.(0))
+ else bprintf buf "0";
+ Buffer.contents buf
+
+let splitter = Str.regexp "[ \t]+\\+[ \t]+"
+
+let parse_digit s =
+ try sscanf s "%s z^%d" (fun digit degree -> (degree,ZZp.of_string digit))
+ with End_of_file -> (0,ZZp.of_string s)
+
+let map_keys map =
+ Map.fold ~init:[] ~f:(fun ~key ~data keylist -> key::keylist) map
+
+
+let of_string s =
+ let digits = List.map ~f:parse_digit (Str.split splitter s) in
+ let digitmap = Map.of_alist digits in
+ let degree = MList.reduce ~f:max (map_keys digitmap) in
+ init degree ~f:(fun deg ->
+ try Map.find deg digitmap
+ with Not_found -> ZZp.zero)
+
+
+
+let print x =
+ for i = degree x downto 1 do
+ ZZp.print x.a.(i);
+ printf " z^%d + " i;
+ done;
+ if degree x >= 0 then
+ ZZp.print x.a.(0)
+ else
+ print_string "0"
+
+exception NotEqual
+
+let eq x y =
+ try
+ if x.degree <> y.degree then raise NotEqual;
+ for i = 0 to x.degree do
+ if x.a.(i) <>: y.a.(i)
+ then raise NotEqual
+ done;
+ true
+ with
+ NotEqual -> false
+
+
+let of_array array =
+ if Array.length array = 0 then zero
+ else
+ let deg = compute_degree array in
+ { a = Array.init (deg + 1) ~f:(fun i -> array.(i));
+ degree = deg;
+ }
+
+let term deg c =
+ init ~f:(fun i -> if i = deg then c else ZZp.zero) deg
+
+let set_length length x =
+ assert (length + 1 > degree x);
+ { a = Array.init (length + 1)
+ ~f:(fun i ->
+ if i <= x.degree
+ then x.a.(i)
+ else ZZp.zero);
+ degree = x.degree
+ }
+
+let to_array x = Array.copy x.a
+let is_monic x = x.a.(degree x) =: ZZp.one
+
+let eval poly z =
+ let zd = ref ZZp.one
+ and sum = ref ZZp.zero in
+ for deg = 0 to degree poly do
+ sum := !sum +: poly.a.(deg) *: !zd;
+ zd := !zd *: z
+ done;
+ !sum
+
+let mult x y =
+ let mdegree = degree x + degree y in
+ let prod = { a = Array.make ( mdegree + 1 ) ZZp.zero;
+ degree = mdegree ;
+ }
+ in
+ for i = 0 to degree x do
+ for j = 0 to degree y do
+ prod.a.(i + j) <- prod.a.(i + j) +: x.a.(i) *: y.a.(j)
+ done
+ done;
+ prod
+
+(** scalar multiplication *)
+let scmult x c =
+ { x with a = Array.map ~f:(fun z -> z *: c) x.a; }
+
+let add x y =
+ let deg = max x.degree y.degree in
+ init deg
+ ~f:(fun i ->
+ (if i <= x.degree then x.a.(i) else ZZp.zero) +:
+ (if i <= y.degree then y.a.(i) else ZZp.zero))
+
+let neg x = { x with a = Array.map ~f:(fun c -> ZZp.neg c) x.a }
+
+let sub x y = add x (neg y)
+
+let rec divmod x y =
+ if eq x zero then (zero,zero)
+ else if degree y > degree x then (zero,x)
+ else
+ let degdiff = degree x - degree y in
+ assert (degdiff >= 0);
+ let c = x.a.(degree x) /: y.a.(degree y) in
+ let m = term degdiff c in
+ let new_x = sub x (mult m y) in
+ assert (degree new_x < degree x || degree x = 0);
+ let (q,r) = divmod new_x y in
+ (add q m,r)
+
+let modulo x y = let (q,r) = divmod x y in r
+let div x y = let (q,r) = divmod x y in q
+
+let const_coeff x = x.a.(0)
+let nth_coeff x n = x.a.(n)
+let const c = make 0 c
+
+
+let rec gcd_rec x y =
+ if eq y zero then x
+ else
+ let (q,r) = divmod x y in
+ gcd_rec y r
+
+let gcd x y =
+ let result = gcd_rec x y in
+ (* force the GCD to be monic *)
+ mult result (const (ZZp.inv result.a.(degree result)))
+
+
Added: sks/branches/upstream/sks/current/poly_test.ml
===================================================================
--- sks/branches/upstream/sks/current/poly_test.ml (rev 0)
+++ sks/branches/upstream/sks/current/poly_test.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,93 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** unit tests for Poly module *)
+open Common
+open StdLabels
+open MoreLabels
+module Unix = UnixLabels
+open Printf
+open ZZp.Infix
+
+
+let rand_int n = Random.State.int RMisc.det_rng n
+let rand_bits () = Random.State.bits RMisc.det_rng
+
+let ctr = ref 0
+let test name cond =
+ printf ".%!";
+ incr ctr;
+ if not cond then raise
+ (Unit_test_failure (sprintf "Poly test %s:%d failed" name !ctr))
+
+
+let divtest () =
+ let x = Poly.of_array [| ZZp.one; ZZp.one; ZZp.one; ZZp.one |] in
+ let c = ZZp.of_int 5 in
+ let y = Poly.of_array [| c; c; c |] in
+ let (q,r) = Poly.divmod x y in
+ test "invtest" (Poly.eq x (Poly.add (Poly.mult y q) r));
+ test "rtest" (Poly.eq r (Poly.of_array [| ZZp.one |]));
+ test "qtest" (Poly.eq q (Poly.of_array [| ZZp.zero; ZZp.inv c |]))
+
+let rand_divtest () =
+ let p1 = Poly.of_array (Array.init (1 + rand_int 20)
+ ~f:(fun i -> ZZp.rand rand_bits)) in
+ let p2 = Poly.of_array (Array.init (1 + rand_int 20)
+ ~f:(fun i -> ZZp.rand rand_bits)) in
+ let (q,r) = Poly.divmod p1 p2 in
+ let z = ZZp.rand rand_bits in
+ let r_z = Poly.eval r z
+ and q_z = Poly.eval q z
+ and p1_z = Poly.eval p1 z
+ and p2_z = Poly.eval p2 z
+ in
+ test "rand_divtest" (p1_z =: p2_z *: q_z +: r_z)
+
+(** returns true iff y divides x *)
+let divides x y =
+ Poly.eq (Poly.modulo x y) Poly.zero
+
+let gcd_test () =
+ let p1 = Poly.of_array (Array.init (1 + rand_int 20)
+ ~f:(fun i -> ZZp.rand rand_bits)) in
+ let p2 = Poly.of_array (Array.init (1 + rand_int 20)
+ ~f:(fun i -> ZZp.rand rand_bits)) in
+ let p3 = Poly.of_array (Array.init (1 + rand_int 20)
+ ~f:(fun i -> ZZp.rand rand_bits)) in
+ let p1 = Poly.mult p1 p3 in
+ let p2 = Poly.mult p2 p3 in
+ let gcd = Poly.gcd p1 p2 in
+ test "gcd - p3 div" (divides gcd p3);
+ test "gcd - gcd div 1" (divides p1 gcd);
+ test "gcd - gcd div 2" (divides p2 gcd);
+ let p1 = Poly.div p1 gcd in
+ let p2 = Poly.div p2 gcd in
+ let gcd = Poly.gcd p1 p2 in
+ test "gcd - zero" (Poly.degree gcd = 0)
+
+
+let run () =
+ begin
+ for i = 1 to 100 do
+ rand_divtest ()
+ done;
+ for i = 1 to 100 do
+ gcd_test ()
+ done;
+ divtest ();
+ end
Added: sks/branches/upstream/sks/current/prefixTree.ml
===================================================================
--- sks/branches/upstream/sks/current/prefixTree.ml (rev 0)
+++ sks/branches/upstream/sks/current/prefixTree.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,1023 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+open Printf
+open Common
+module Unix=UnixLabels
+(*module ZZp = RMisc.ZZp *)
+module Set = PSet.Set
+module ZSet = ZZp.Set
+
+exception Bug of string
+
+(** Invariants:
+ - Parent of dirty node is dirty.
+ - A dirty non-leaf node has at least one dirty child
+ - dirty nodes are reachable from the root
+ - All nodes not InMem are mirrored on disk.
+ - All nodes on disk are in real tree.
+*)
+
+(** TODO:
+ - Make sure that newly created nodes (in particular, in a split)
+ start out Dirty
+ - Nodes that are destroyed should have their backing store on disk
+ destroyed as well. In particular, in a join.
+*)
+
+
+type key = Bitstring.t
+
+module WHash =
+ Weak.Make(struct
+ type t = key
+ let equal = (=)
+ and hash = Hashtbl.hash
+ end)
+
+type writestatus = Clean | Dirty
+type 'a disk = OnDisk of key | InMem of 'a
+
+type children = | Leaf of string Set.t
+ | Children of node disk array
+
+and node = { svalues: ZZp.mut_array;
+ key: key;
+ mutable num_elements: int;
+ mutable children: children;
+ mutable wstatus: writestatus;
+ }
+
+
+type 'txn db = { load : string -> string;
+ save : 'txn option -> key:string -> data:string -> unit;
+ delete : 'txn option -> string -> unit;
+ create_txn : unit -> 'txn option;
+ commit_txn : 'txn option -> unit;
+ abort_txn : 'txn option -> unit;
+ mutable maxnodes : int;
+ mutable inmem_count : int;
+ }
+
+type 'txn tree = { root: node;
+ num_samples: int;
+ split_thresh: int; (* threshold for splitting node *)
+ join_thresh: int; (* threshold for deleting node.
+ Should be less than split_thresh *)
+ bitquantum: int; (* amount by which depths differ
+ from each other *)
+ points: ZZp.zz array;
+ db: 'txn db option;
+ mutable synctime: float;
+ }
+
+type dheader = { d_num_samples: int;
+ d_split_thresh: int;
+ d_join_thresh: int;
+ d_bitquantum: int;
+ d_points: ZZp.zz array;
+ }
+
+(******************************************************************)
+
+let op_unwrap x = match x with
+ Some y -> y
+ | None -> failwith "Attempt to unwrap None"
+
+let op_apply ~f x = match x with
+ None -> None
+ | Some x -> Some (f x)
+
+let op_map ~f list = List.map ~f:(op_apply ~f) list
+
+(******************************************************************)
+(******************************************************************)
+(******************************************************************)
+
+(** Returns all extensions of bs to length ~len,
+ * starting at bit ~bit
+ *)
+let rec child_keys_rec bs ~bit ~len =
+ if bit >= len
+ then
+ Set.add (Bitstring.copy bs) Set.empty
+ else (
+ Bitstring.set bs bit;
+ let keys_1 = child_keys_rec bs ~bit:(bit+1) ~len in
+ Bitstring.unset bs bit;
+ let keys_2 = child_keys_rec bs ~bit:(bit+1) ~len in
+ Set.union keys_1 keys_2
+ )
+
+(** Return 2^t.bitquantum bitstrings which consist of all possible
+ * t.bitquantum-bit extensions of the key.
+ *)
+let child_keys_raw bitquantum key =
+ let len = Bitstring.num_bits key in
+ let newlen = len + bitquantum in
+ let bs = Bitstring.copy_len key newlen in
+ let keys = child_keys_rec bs ~bit:len ~len:newlen in
+ Set.elements keys
+
+let child_keys t key = child_keys_raw t.bitquantum key
+
+(******************************************************************)
+(******************************************************************)
+(******************************************************************)
+
+let marshal_to_string ~f x =
+ let bufc = Channel.new_buffer_outc 1000 in
+ f (bufc#upcast) x;
+ bufc#contents
+
+let unmarshal_of_string ~f s =
+ let strc = new Channel.string_in_channel s 0 in
+ f (strc#upcast)
+
+(******************************************************************)
+(******************************************************************)
+(******************************************************************)
+
+let samesize set =
+ let sizes = Set.fold ~init:Set.empty set
+ ~f:(fun string set -> Set.add (String.length string) set)
+ in
+ let nsizes = Set.cardinal sizes in
+ nsizes = 1 || nsizes = 0
+
+let marshal_node (cout:Channel.out_channel_obj) n =
+ cout#write_int n.num_elements;
+ cout#write_int (Bitstring.num_bits n.key);
+ cout#write_string (Bitstring.to_bytes n.key);
+ Array.iter ~f:(fun zz -> cout#write_string (ZZp.to_bytes zz))
+ (ZZp.mut_array_to_array n.svalues);
+ (match n.children with
+ Leaf set ->
+ cout#write_byte 1;
+ assert (samesize set);
+ cout#write_int (Set.cardinal set);
+ Set.iter ~f:(fun s -> cout#write_string s) set
+ | Children _ ->
+ cout#write_byte 0)
+
+let unmarshal_node ~bitquantum ~num_samples (cin:Channel.in_channel_obj) =
+ let zzp_len = ZZp.num_bytes () in
+ let num_elements = cin#read_int in
+ let keybits = cin#read_int in
+ let keybytes = Bitstring.bytelength keybits in
+ let keydata = cin#read_string keybytes in
+ let key = Bitstring.of_bytes keydata keybits in
+ let svalues = Array.init num_samples
+ ~f:(fun _ -> ZZp.of_bytes (cin#read_string zzp_len)) in
+ let isleaf = cin#read_byte = 1 in
+ let children =
+ if isleaf then
+ let size = cin#read_int in
+ let a = Array.init size ~f:( fun i -> cin#read_string zzp_len ) in
+ Leaf (Set.of_list (Array.to_list a))
+ else
+ let ckeys = child_keys_raw bitquantum key in
+ Children (Array.map ~f:(fun key -> OnDisk key)
+ (Array.of_list ckeys))
+ in
+ { svalues = ZZp.mut_array_of_array svalues;
+ num_elements = num_elements;
+ children = children;
+ wstatus = Clean;
+ key = key;
+ }
+
+let node_to_string n = marshal_to_string ~f:marshal_node n
+let node_of_string_raw ~bitquantum ~num_samples s =
+ unmarshal_of_string ~f:(unmarshal_node ~bitquantum ~num_samples) s
+let node_of_string tree s =
+ node_of_string_raw ~bitquantum:tree.bitquantum
+ ~num_samples:tree.num_samples s
+
+(******************************************************************)
+
+let marshal_header cout tree =
+ ignore (cout :> Channel.out_channel_obj);
+ cout#write_int tree.num_samples;
+ cout#write_int tree.split_thresh;
+ cout#write_int tree.join_thresh;
+ cout#write_byte tree.bitquantum;
+ Array.iter ~f:(fun zz -> cout#write_string (ZZp.to_bytes zz))
+ tree.points
+
+let unmarshal_dheader cin =
+ ignore (cin :> Channel.in_channel_obj);
+ let zzp_len = ZZp.num_bytes () in
+ let num_samples = cin#read_int in
+ let split_thresh = cin#read_int in
+ let join_thresh = cin#read_int in
+ let bitquantum = cin#read_byte in
+ let points = Array.init num_samples
+ ~f:(fun zz -> ZZp.of_bytes (cin#read_string zzp_len))
+ in
+ { d_num_samples = num_samples;
+ d_split_thresh = split_thresh;
+ d_join_thresh = join_thresh;
+ d_bitquantum = bitquantum;
+ d_points = points;
+ }
+
+(************)
+
+let header_to_string tree =
+ marshal_to_string ~f:marshal_header tree
+
+let dheader_of_string s =
+ unmarshal_of_string ~f:unmarshal_dheader s
+
+let dheader_to_header db root dh synctime =
+ { num_samples = dh.d_num_samples;
+ split_thresh = dh.d_split_thresh;
+ join_thresh = dh.d_join_thresh;
+ bitquantum = dh.d_bitquantum;
+ points = dh.d_points;
+ db = db;
+ root = root;
+ synctime = synctime;
+ }
+
+(******************************************************************)
+
+let marshal_synctime cout time = cout#write_float time
+let unmarshal_synctime cin = cin#read_float
+
+let synctime_to_string time =
+ marshal_to_string ~f:marshal_synctime time
+
+let synctime_of_string time =
+ unmarshal_of_string ~f:unmarshal_synctime time
+
+
+(******************************************************************)
+
+(** converts bitstring to dbkey by writing the bitlength of the key followed
+ by the bytes of the key itself.
+
+ Note that a more efficient coding is possible, since really you only need 3
+ bits, to tell you how much of the last byte is used.
+*)
+let dbkey_of_key key =
+ let bufc = Channel.new_buffer_outc 8 in
+ let length = Bitstring.num_bits key in
+ let data = Bitstring.to_bytes key in
+ bufc#write_int length;
+ bufc#write_string data;
+ bufc#contents
+
+(** dbkey for storing header *)
+let int_to_bstring i =
+ let bufc = Channel.new_buffer_outc 1 in
+ bufc#write_int i;
+ bufc#contents
+
+let root_dbkey = dbkey_of_key (Bitstring.create 0)
+let header_dbkey = int_to_bstring (-1)
+let synctime_dbkey = int_to_bstring (-2)
+
+(******************************************************************)
+
+(** returns the on-disk version of the node corresponding to dbkey.
+ No changes are made to the in-memory tree *)
+let load_node tree dbkey =
+ let db = op_unwrap tree.db in
+ let nodestr = db.load dbkey in
+ node_of_string tree nodestr
+
+(** Returns the node corresponding to the [cindex]'th child from the
+ [children] array. If an OnDisk node has been loaded into memory, [children]
+ is updated accordingly.
+*)
+let load_child t children cindex =
+ match children.(cindex) with
+ | OnDisk key ->
+ let db = op_unwrap t.db in
+ let cnode = load_node t (dbkey_of_key key) in
+ children.(cindex) <- InMem cnode;
+ db.inmem_count <- db.inmem_count + 1;
+ cnode
+ | InMem cnode -> cnode
+
+(** side-effect-free version of load_child *)
+let load_child_sef t children cindex =
+ match children.(cindex) with
+ | OnDisk key -> load_node t (dbkey_of_key key)
+ | InMem cnode -> cnode
+
+(******************************************************************)
+
+let save_node t txn node =
+ match t.db with
+ None -> ()
+ | Some db ->
+ let dbkey = dbkey_of_key node.key in
+ db.save txn ~key:dbkey ~data:(node_to_string node)
+
+let save_synctime tree txn =
+ match tree.db with
+ None -> ()
+ | Some db ->
+ db.save txn ~key:synctime_dbkey
+ ~data:(synctime_to_string tree.synctime)
+
+
+(******************************************************************)
+(******************************************************************)
+(******************************************************************)
+
+let rec clean_subtree tree txn node = match node.wstatus with
+ | Dirty ->
+ ( match node.children with
+ Leaf _ -> ()
+ | Children children ->
+ Array.iter children
+ ~f:(function
+ OnDisk key -> ()
+ | InMem cnode -> clean_subtree tree txn cnode)
+ );
+ save_node tree txn node;
+ node.wstatus <- Clean;
+
+ | Clean -> ()
+
+let clean txn tree =
+ match tree.db with
+ None -> ()
+ | Some _ ->
+ clean_subtree tree txn tree.root;
+ save_synctime tree txn
+
+
+(*************************************************************)
+
+let rec delete_subtree_rec txn tree disknode =
+ let node = match disknode with
+ InMem node -> node
+ | OnDisk key -> load_node tree (dbkey_of_key key)
+ in
+ let db = op_unwrap tree.db in
+ db.delete txn (dbkey_of_key node.key);
+ match node.children with
+ Leaf _ -> ()
+ | Children children ->
+ Array.iter ~f:(delete_subtree_rec txn tree) children
+
+let delete_subtree txn tree node =
+ perror "Fix this!";
+ delete_subtree_rec txn tree (InMem node)
+
+(******************************************************************)
+(* Full Tree Summaries ******************************************)
+(******************************************************************)
+
+let rec summarize_tree_rec ~lagg ~cagg tree nodedisk =
+ let node = match nodedisk with
+ InMem node -> node
+ | OnDisk key -> load_node tree (dbkey_of_key key)
+ in
+ match node.children with
+ | Leaf elements ->
+ lagg elements
+ | Children children ->
+ let values =
+ Array.map ~f:(summarize_tree_rec ~lagg ~cagg tree) children
+ in
+ cagg values
+
+let summarize_tree ~lagg ~cagg tree =
+ summarize_tree_rec ~lagg ~cagg tree (InMem tree.root)
+
+(******************************************************************)
+
+let depth tree =
+ summarize_tree
+ ~lagg:(fun _ -> 1)
+ ~cagg:(fun depths -> 1 + MArray.max depths)
+ tree
+
+let count_nodes tree =
+ summarize_tree
+ ~lagg:(fun _ -> 1)
+ ~cagg:(fun counts -> 1 + Array.fold_left ~f:(+) ~init:0 counts)
+ tree
+
+let (<+>) (x1,y1) (x2,y2) = (x1 + x2, y1 + y2)
+
+(* returns (# internal nodes, # leaf nodes) below & including current node *)
+let count_node_types tree =
+ summarize_tree
+ ~lagg:(fun _ -> (0,1))
+ ~cagg:(fun counts ->
+ (1,0) <+>
+ Array.fold_left ~f:(<+>) ~init:(0,0) counts
+ )
+ tree
+
+let get_elements tree node =
+ summarize_tree_rec
+ ~lagg:(fun x -> x)
+ ~cagg:(fun sets -> Array.fold_left ~f:Set.union ~init:Set.empty sets)
+ tree (InMem node)
+
+let get_zzp_elements tree node =
+ let selem = get_elements tree node in
+ Set.fold selem ~init:ZSet.empty
+ ~f:(fun x set -> ZSet.add (ZZp.of_bytes x) set)
+
+let iter ~f tree =
+ summarize_tree
+ ~lagg:(Set.iter ~f)
+ ~cagg:(fun _ -> ())
+ tree
+
+(******************************************************************)
+
+(** returns the number of inmem nodes below and including
+ the present node *)
+let rec count_inmem node = match node.children with
+ Leaf _ -> 1
+ | Children children ->
+ let counts = Array.map ~f:(function
+ OnDisk x -> 0
+ | InMem cnode -> count_inmem cnode)
+ children
+ in
+ 1 + Array.fold_left ~f:(+) ~init:0 counts
+
+(** returns the number of inmen nodes in the tree,
+ not counting the root. *)
+let count_inmem_tree tree = count_inmem tree.root - 1
+
+let get_inmem_count tree =
+ match tree.db with
+ None -> raise Not_found
+ | Some db -> db.inmem_count
+
+let set_inmem_count tree newcount =
+ match tree.db with
+ None -> raise Not_found
+ | Some db -> db.inmem_count <- newcount
+
+
+
+(*************************************************************)
+(* Code for limiting number of InMem nodes ****************)
+(*************************************************************)
+
+let rec list_extract ~f list = match list with
+ [] -> []
+ | hd::tl -> match f hd with
+ None -> list_extract ~f tl
+ | Some x -> x::(list_extract ~f tl)
+
+let rec list_prefix k list = match k with
+ 0 -> []
+ | _ -> match list with
+ [] -> failwith "Requested prefix longer than list"
+ | hd::tl -> hd::(list_prefix (k-1) tl)
+
+let list_prefix_suffix k list =
+ let rec loop k list prefix =
+ match k with
+ 0 -> (List.rev prefix,list)
+ | _ -> match list with
+ [] -> failwith "Requested prefix longer than list"
+ | hd::tl ->
+ loop (k-1) tl (hd::prefix)
+ in
+ loop k list []
+
+
+let inmem_children node = match node.children with
+ Leaf _ -> []
+ | Children children ->
+ list_extract ~f:(function
+ InMem x -> Some x
+ | OnDisk _ -> None
+ )
+ (Array.to_list children)
+
+let rec get_frontier tree ~frontier ~newfrontier ~n ~count =
+ if count > n then failwith "get_frontier called with count>n"
+ else
+ match frontier, newfrontier with
+ | [],[] ->
+ raise (Bug "frontier and newfrontier both empty")
+ | [],newfrontier ->
+ get_frontier tree ~frontier:newfrontier ~newfrontier:[]
+ ~n ~count
+ | hd::tl,newfrontier ->
+ let children = inmem_children hd in
+ let num_kids = List.length children in
+ if num_kids + count >= n then
+ (List.rev_append frontier newfrontier, count)
+ else
+ let newfrontier =
+ List.rev_append children newfrontier
+ in
+ let frontier = tl in
+ get_frontier tree ~frontier ~newfrontier ~n ~count:(count + num_kids)
+
+
+(*
+let inmem_children node = match node.children with
+ Leaf _ -> []
+ | Children children ->
+ list_extract ~f:(function
+ (i,InMem x) -> Some (i,x)
+ | (i,OnDisk _) -> None )
+ (Array.to_list (Array.mapi ~f:(fun i x -> (i,x)) children))
+
+let rec get_frontier tree ~frontier ~newfrontier ~n ~count =
+ if count > n then raise (Bug (sprintf "count(%d) exceeded n(%d)" count n))
+ else if count = n then (frontier,None)
+ else
+ match frontier, newfrontier with
+ [],[] ->
+ raise (Bug "frontier and newfrontier should never both be empty")
+ | [],newfrontier ->
+ get_frontier tree ~frontier:newfrontier ~newfrontier:[]
+ ~n ~count
+ | hd::tl, newfrontier ->
+ let children = inmem_children hd in
+ if List.length children + count <= n then
+ let children = List.map ~f:snd children in
+ get_frontier tree
+ ~frontier:tl
+ ~newfrontier:(List.rev_append children newfrontier)
+ ~n ~count:(count + List.length children)
+ else
+ let needed = List.length children + count - n in
+ let (needed_children,unneeded_children) =
+ list_prefix_suffix needed children in
+ (tl @ newfrontier,
+ Some (hd,
+ List.map ~f:(fun (i,x) -> x) needed_children,
+ List.map ~f:(fun (i,x) -> i) unneeded_children)
+ )
+*)
+
+
+(** marks all the children of a node as being OnDisk *)
+let disconnect_children node =
+ if node.wstatus = Dirty then
+ failwith "Disconnect children called on Dirty node";
+ match node.children with
+ | Leaf _ -> ()
+ | Children children ->
+ for i = 0 to Array.length children - 1 do
+ match children.(i) with
+ | OnDisk key -> ()
+ | InMem node -> children.(i) <- OnDisk node.key
+ done
+
+(** Reduce number of InMem nodes to no more than n *)
+let shrink_tree tree txn n =
+ clean txn tree;
+ let (frontier,count) = get_frontier tree
+ ~frontier:[ tree.root ]
+ ~newfrontier:[]
+ ~n ~count:0 (* we don't count the root since it's
+ always in memory *)
+ in
+ List.iter frontier ~f:disconnect_children;
+ let real_count = count_inmem_tree tree in
+ if count <> real_count then
+ failwith (sprintf "%s. expected %d, found %d"
+ "tree shrinkage failed to produce tree of expected size"
+ count real_count) ;
+ set_inmem_count tree count
+
+let shrink_tree_if_necessary tree txn =
+ match tree.db with
+ None -> ()
+ | Some db ->
+ if db.inmem_count > db.maxnodes
+ then shrink_tree tree txn (db.maxnodes / 2)
+
+
+(******************************************************************)
+(******************************************************************)
+
+let width = 8
+let rmask i = 0xFF lsl (width - i)
+let lmask i = 0xFF lsr (width - i)
+
+let string_index t depth string =
+ let q = t.bitquantum in
+ let lowbit = depth * q in
+ let highbit = lowbit + q - 1
+ in
+ let lowbyte = lowbit / 8
+ and lowbit = lowbit mod 8
+ and highbyte = highbit / 8
+ and highbit = highbit mod 8
+ in
+ if lowbyte = highbyte then
+ let byte = int_of_char string.[lowbyte] in
+ let key = (byte lsr (7 - highbit)) land
+ (lmask (highbit - lowbit + 1)) in
+ key
+ else (* extract from two adjacent bytes *)
+ let byte1 = int_of_char string.[lowbyte] in
+ let byte2 = int_of_char string.[highbyte] in
+ let key1 = (byte1 land (lmask (8 - lowbit))) lsl (highbit + 1) in
+ let key2 = (byte2 land (rmask (highbit + 1))) lsr (7 - highbit) in
+ let key = key1 lor key2 in
+ key
+
+(******************************************************************)
+
+let create_svalues points =
+ ZZp.svalues (Array.length points)
+
+let incr_inmem_count tree =
+ match tree.db with
+ None -> ()
+ | Some db ->
+ db.inmem_count <- db.inmem_count + 1
+
+let decr_inmem_count tree =
+ match tree.db with
+ None -> ()
+ | Some db ->
+ db.inmem_count <- db.inmem_count - 1
+
+let create_node_basic key points =
+ { svalues = create_svalues points;
+ num_elements = 0;
+ children = Leaf Set.empty;
+ key = key;
+ wstatus = Dirty;
+ }
+
+let create_node tree key =
+ let points = tree.points in
+ incr_inmem_count tree;
+ create_node_basic key points
+
+let add_to_node t node zz zzs marray =
+ ZZp.mult_array ~svalues:node.svalues marray;
+ node.num_elements <- node.num_elements + 1;
+ node.wstatus <- Dirty;
+ match node.children with
+ | Leaf elements ->
+ node.children <-
+ if Set.mem zzs elements
+ then failwith "add_to_node: attempt to reinsert element into prefix tree"
+ else Leaf (Set.add zzs elements)
+ | _ -> ()
+
+let remove_from_node t node zz zzs marray =
+ ZZp.mult_array ~svalues:node.svalues marray;
+ node.num_elements <- node.num_elements - 1;
+ node.wstatus <- Dirty;
+ match node.children with
+ | Leaf elements ->
+ if not (Set.mem zzs elements)
+ then failwith "remove_from_node: attempt to delete non-existant element from prefix tree"
+ else node.children <- Leaf (Set.remove zzs elements)
+ | _ -> ()
+
+
+(******************************************************************)
+
+let split_at_depth t zz zzs node depth =
+ match node.children with
+ Children _ -> raise (Bug "split of non-leaf node.");
+ | Leaf elements ->
+ let ckeys = Array.of_list (child_keys t node.key) in
+ let children =
+ Array.map ~f:(fun key -> InMem (create_node t key)) ckeys
+ in
+ node.children <- Children children;
+ Set.iter elements
+ ~f:(fun (zzs) ->
+ let zz = ZZp.of_bytes zzs in
+ let idx = string_index t depth zzs in
+ let marray = ZZp.add_el_array ~points:t.points zz in
+ let cnode = load_child t children idx in
+ add_to_node t cnode zz zzs marray
+ )
+
+(******************************************************************)
+
+let pad string bytes =
+ let len = String.length string in
+ if bytes > len then
+ let nstr = String.create bytes in
+ String.fill nstr ~pos:len ~len:(bytes - len) '\000';
+ String.blit ~src:string ~dst:nstr ~src_pos:0 ~dst_pos:0 ~len;
+ nstr
+ else
+ string
+
+
+
+(******************************************************************)
+(* Interface functions *******************************************)
+(******************************************************************)
+
+let create_empty_header ~points ~bitquantum ~num_samples ~thresh ~dbopt =
+ { root = create_node_basic (Bitstring.create 0) points;
+ num_samples = num_samples;
+ bitquantum = bitquantum;
+ split_thresh = thresh;
+ join_thresh = thresh / 2;
+ points = points;
+ db = dbopt;
+ synctime = 0.0;
+ }
+
+let create ?db:dbopt ~txn ~num_samples ~bitquantum ~thresh () =
+ let points = ZZp.points num_samples in
+ let dbopt =
+ match dbopt with
+ None -> None
+ | Some (load,save,delete,(create,commit,abort),maxnodes) ->
+ Some { load = load;
+ save = save;
+ delete = delete;
+ create_txn = create;
+ commit_txn = commit;
+ abort_txn = abort;
+ maxnodes = maxnodes;
+ inmem_count = 0;
+ }
+ in
+ match dbopt with
+ Some db ->
+ begin
+ try
+ let header_string = db.load header_dbkey in
+ let dheader = dheader_of_string header_string in
+
+ let root_string = db.load root_dbkey in
+ let root = node_of_string_raw ~bitquantum:dheader.d_bitquantum
+ ~num_samples:dheader.d_num_samples root_string in
+
+ let synctime_string = db.load synctime_dbkey in
+ let synctime = synctime_of_string synctime_string in
+
+ dheader_to_header dbopt root dheader synctime
+ with
+ Not_found ->
+ (* no header found on disk. Start from scratch *)
+ let tree = create_empty_header ~points ~bitquantum
+ ~num_samples ~thresh ~dbopt in
+ (* header and root must now be written to disk *)
+ let header_string = header_to_string tree in
+ let root_string = node_to_string tree.root in
+ let synctime_string = synctime_to_string tree.synctime in
+ db.save txn ~key:header_dbkey ~data:header_string;
+ db.save txn ~key:root_dbkey ~data:root_string;
+ db.save txn ~key:synctime_dbkey ~data:synctime_string;
+ tree
+ end
+ | None ->
+ (* No way of accessing the disk, so create a blank tree *)
+ create_empty_header ~points ~bitquantum ~num_samples ~thresh ~dbopt
+
+(******************************************************************)
+
+let rec insert_at_depth t zz zzs node marray depth =
+ add_to_node t node zz zzs marray;
+ (match node.children with
+ | Leaf elements ->
+ if node.num_elements > t.split_thresh
+ then split_at_depth t zz zzs node depth
+ | Children children -> (* insertion must continue at next depth *)
+ let cindex = string_index t depth zzs in
+ let cnode = load_child t children cindex in
+ insert_at_depth t zz zzs cnode marray (depth + 1)
+ )
+
+let insert_both t txn zz zzs =
+ let zzs = pad zzs (ZZp.num_bytes ()) in
+ if String.length zzs <> ZZp.num_bytes ()
+ then raise (Invalid_argument
+ (sprintf "%s. %d found, %d expected"
+ "PrefixTree.insert_both: zzs has wrong length"
+ (String.length zzs) (ZZp.num_bytes ())
+ ));
+ let marray = ZZp.add_el_array ~points:t.points zz in
+ let root = t.root in
+ insert_at_depth t zz zzs root marray 0;
+ shrink_tree_if_necessary t txn
+
+let insert t txn zz =
+ let zzs = ZZp.to_bytes zz in
+ insert_both t txn zz zzs
+
+let insert_str t txn zzs =
+ let zz = ZZp.of_bytes zzs in
+ insert_both t txn zz zzs
+
+(******************************************************************)
+
+let rec get_ondisk_subkeys tree db key =
+ try
+ ignore (db.load (dbkey_of_key key));
+ let ckeys = child_keys tree key in
+ let sets = List.map ~f:(get_ondisk_subkeys tree db) ckeys in
+ Set.add key (List.fold_left ~f:Set.union sets ~init:Set.empty)
+ with
+ Not_found -> (* has no subkeys, so emptyset *)
+ Set.empty
+
+let rec delete_at_depth t txn zz zzs node marray depth =
+ remove_from_node t node zz zzs marray;
+ match node.children with
+ | Children children ->
+ if node.num_elements <= t.join_thresh then (
+ let elements = Set.remove zzs (get_elements t node) in
+ node.children <- Leaf elements;
+ match t.db with
+ None -> ()
+ | Some db ->
+ let subkeys = get_ondisk_subkeys t db node.key in
+ let subkeys = Set.remove node.key subkeys in
+ let inmem_delta = count_inmem node - 1 in
+ Set.iter ~f:(fun key -> db.delete txn (dbkey_of_key key))
+ subkeys;
+ db.inmem_count <- db.inmem_count - inmem_delta
+ ) else (
+ let cindex = string_index t depth zzs in
+ let cnode = load_child t children cindex in
+ delete_at_depth t txn zz zzs cnode marray (depth + 1)
+ )
+ | _ -> ()
+
+let delete_both t txn zz zzs =
+ let zzs = pad zzs (ZZp.num_bytes ()) in
+ if String.length zzs <> ZZp.num_bytes ()
+ then raise (Invalid_argument
+ "PrefixTree.delete_both: zzs has wrong length");
+ let marray = ZZp.del_el_array ~points:t.points zz in
+ let root = t.root in
+ delete_at_depth t txn zz zzs root marray 0
+
+
+let delete t txn zz =
+ let zzs = ZZp.to_bytes zz in
+ delete_both t txn zz zzs
+
+let delete_str t txn zzs =
+ let zz = ZZp.of_bytes zzs in
+ delete_both t txn zz zzs
+
+(******************************************************************)
+(******************************************************************)
+(******************************************************************)
+
+let set_maxnodes tree txn n =
+ match tree.db with
+ None -> ()
+ | Some db ->
+ db.maxnodes <- n;
+ shrink_tree_if_necessary tree txn
+
+let get_maxnodes tree =
+ match tree.db with
+ None -> raise (Invalid_argument
+ "Attempt to invoke DB operation without DB")
+ | Some db -> db.maxnodes
+
+(******************************************************************)
+
+let rec get_node_rec ~sef t node zzs ~depth ~goal_depth =
+ if depth < goal_depth
+ then (
+ match node.children with
+ Children children ->
+ let cindex = string_index t depth zzs in
+ let cnode =
+ (if sef then load_child_sef else load_child)
+ t children cindex in
+ get_node_rec ~sef t cnode zzs ~depth:(depth+1) ~goal_depth
+ | Leaf _ ->
+ raise Not_found
+ )
+ else if depth = goal_depth then node
+ else failwith "Goal depth exceeded"
+
+let get_node_str ?(sef=false) t zzs depth =
+ let rval = get_node_rec ~sef t t.root zzs ~depth:0 ~goal_depth:depth in
+ (** shrink the tree if required, creating transaction as needed *)
+ begin
+ match t.db with
+ None -> ()
+ | Some db ->
+ let txn = db.create_txn () in
+ try
+ shrink_tree_if_necessary t txn;
+ db.commit_txn txn
+ with
+ e -> db.abort_txn txn; raise e
+ end;
+ rval
+
+
+let get_node ?(sef=false) t zz depth =
+ let zzs = ZZp.to_bytes zz in
+ get_node_str ~sef t zzs depth
+
+let get_node_key ?(sef=false) t key =
+ if (Bitstring.num_bits key) mod t.bitquantum <> 0
+ then raise (Invalid_argument "Prefix given of wrong length")
+ else
+ let depth = (Bitstring.num_bits key) / t.bitquantum in
+ get_node_str ~sef t (Bitstring.to_bytes key) depth
+
+(******************************************************************)
+
+let root t = t.root
+
+let children node = match node.children with
+ | Leaf _ -> None
+ | Children children -> Some children
+
+let svalues node = node.svalues
+let size node = node.num_elements
+let is_leaf node =
+ match node.children with Leaf _ -> true | _ -> false
+
+let points tree = tree.points
+
+let elements tree node =
+ let pset = get_elements tree node in
+ Set.fold ~f:(fun zzs set -> ZSet.add (ZZp.of_bytes zzs) set)
+ ~init:ZSet.empty pset
+
+
+(******************************************************************)
+
+let node_size tree nodedisk =
+ let node = match nodedisk with
+ InMem node -> node
+ | OnDisk key -> load_node tree (dbkey_of_key key)
+ in
+ node.num_elements
+
+let nonempty_children tree children =
+ let sizes = Array.map ~f:(node_size tree) children in
+ let nonempty = Array.mapi ~f:(fun i s -> (i,s > 0) ) sizes in
+ Array.fold_left ~f:(fun list (i,nonempty) ->
+ if nonempty then i::list else list)
+ ~init:[] nonempty
+
+let random_element list =
+ let i = Random.int (List.length list) in
+ List.nth list i
+
+let rec get_random tree node =
+ match node.children with
+ Leaf children ->
+ if Set.is_empty children then raise Not_found
+ else
+ let elements = Set.elements children in
+ let i = Random.int (Set.cardinal children) in
+ List.nth elements i
+ | Children children ->
+ let nonempty = nonempty_children tree children in
+ if List.length nonempty = 0
+ then raise (Bug "Internal node with no nonempty children");
+ let randchild =
+ match children.(random_element nonempty) with
+ InMem node -> node
+ | OnDisk key -> load_node tree (dbkey_of_key key)
+ in
+ get_random tree randchild
+
+
+let set_synctime tree synctime = tree.synctime <- synctime
+let get_synctime tree = tree.synctime
+
+let depth tree node = Bitstring.num_bits node.key / tree.bitquantum
+let num_elements tree node = node.num_elements
+
+
+(******************************************************************)
+(******************************************************************)
+(******************************************************************)
+
Added: sks/branches/upstream/sks/current/prefix_test.ml
===================================================================
--- sks/branches/upstream/sks/current/prefix_test.ml (rev 0)
+++ sks/branches/upstream/sks/current/prefix_test.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,192 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+module Unix=UnixLabels
+
+module Set = PSet.Set
+open Printf
+(*module ZZp = RMisc.ZZp *)
+module PTree = PrefixTree
+
+let debug = !Settings.debug
+
+let base = 1000
+let bitquantum = !Settings.bitquantum
+let num_samples = !Settings.mbar + 1
+
+let (tree: unit option PTree.tree ) =
+ PTree.create ~txn:None ~num_samples ~bitquantum ~thresh:!Settings.mbar ()
+let timer = MTimer.create ()
+
+let keymatch ~key string =
+ let bitlength = Bitstring.num_bits key in
+ let bstring = Bitstring.of_bytes_all_nocopy string in
+ let keystr = Bitstring.create bitlength in
+ Bitstring.blit ~src:bstring ~dst:keystr ~len:bitlength;
+ (Bitstring.to_bytes_nocopy keystr) = (Bitstring.to_bytes_nocopy key)
+
+let one = ZZp.of_int 1
+
+let compute_svalue point elements =
+ Set.fold
+ ~f:(fun el prod -> ZZp.mult prod (ZZp.sub point el))
+ ~init:ZZp.one
+ elements
+
+let compute_svalues points elements =
+ let array =
+ Array.map ~f:(fun point -> compute_svalue point elements) points
+ in
+ ZZp.mut_array_of_array array
+
+let print_vec vec =
+ let list = Array.to_list (ZZp.mut_array_to_array vec) in
+ MList.print2 ~f:ZZp.print list
+
+(*******************************************************)
+
+let rec add_or_delete setref tree p =
+ if Random.float 1. < p
+ then (* add element *)
+ let zz = ZZp.of_bytes (RMisc.random_string Random.bits !Settings.bytes) in
+ PTree.insert tree None zz;
+ setref := Set.add zz !setref;
+ (*printf "num_elements: counted %d, recorded %d\n"
+ (PTree.count_inmem_tree tree) (PTree.get_node_count tree) *)
+ else (* remove element *)
+ match (try Some (Set.choose !setref) with Not_found -> None) with
+ None ->
+ printf "*** nothing to delete!\n";
+ flush stdout;
+ add_or_delete setref tree p
+ | Some zz ->
+ PTree.delete tree None zz;
+ setref := Set.remove zz !setref
+
+
+(*******************************************************)
+
+exception Notequal
+
+let zza_equal zza1 zza2 =
+ let zza1 = ZZp.mut_array_to_array zza1
+ and zza2 = ZZp.mut_array_to_array zza2
+ in
+ if Array.length zza1 != Array.length zza2 then false
+ else
+ try
+ for i = 0 to Array.length zza1 - 1 do
+ if ZZp.neq zza1.(i) zza2.(i)
+ then raise Notequal
+ done;
+ true
+ with
+ Notequal -> false
+
+let () =
+
+ let set = ref Set.empty in
+
+ for i = 0 to 100000 do
+ add_or_delete set tree 0.52
+ done;
+
+ let pt_set = PTree.elements tree (PTree.root tree) in
+ if Set.equal !set pt_set
+ then
+ print_string "Set and PTree report identical elements\n"
+ else (
+ print_string "Failure: Set and PTree report different elements\n";
+ printf "Set: \t%d, %s\n" (Set.cardinal !set) (ZZp.to_string (Set.min_elt !set));
+ printf "Tree: \t%d, %s\n" (Set.cardinal pt_set) (ZZp.to_string (Set.min_elt pt_set));
+ if Set.subset !set pt_set then
+ printf "set is subset of tree\n"
+ else if Set.subset pt_set !set then
+ printf "tree is susbet of set\n"
+ else
+ printf "No subset relationship\n"
+
+ );
+
+ if PTree.is_leaf (PTree.root tree)
+ then print_string "Root is leaf\n";
+
+ let points = PTree.points tree in
+
+ let rec verify key =
+ let node = PTree.get_node_key tree key in
+ let elements = PTree.elements tree node in
+ let svalues_computed = compute_svalues points elements in
+ let svalues = PTree.svalues node in
+ if not (zza_equal svalues_computed svalues)
+ then (
+ print_vec svalues; print_newline ();
+ print_vec svalues_computed; print_newline ();
+ failwith "svalues do not match";
+ );
+ let len = Set.cardinal elements
+ and reported_len = PTree.size node in
+ if not (len = reported_len)
+ then ( failwith
+ (sprintf "element size %d does not match reported size %d"
+ len reported_len ));
+ if debug
+ then printf "Key: %s,\t num elements: %d\n"
+ (Bitstring.to_string key) (Set.cardinal elements);
+ Set.iter ~f:(fun el ->
+ if not (keymatch ~key (ZZp.to_bytes el))
+ then failwith "Elements don't match key!") elements;
+ let keys = PTree.child_keys tree key in
+ if not (PTree.is_leaf node) then
+ List.iter ~f:verify keys
+ in
+ try
+ verify (Bitstring.create 0);
+ print_string "Verification successful\n";
+ with
+ Failure s ->
+ print_string (sprintf "Verification failed: %s\n" s);
+
+
+
+
+ (*
+ MTimer.start timer;
+ Array.iteri ~f:(fun i zz -> PTree.insert_str tree zz sa.(i)) zza;
+ MTimer.stop timer;
+
+ Printf.printf "Insert time: %f ms, Depth: %d\n"
+ (MTimer.read_ms timer) (PTree.depth tree);
+ flush stdout;
+
+ MTimer.start timer;
+ let tree = PTree.deepcopy tree in
+ MTimer.stop timer;
+ Printf.printf "Copy time: %f ms\n" (MTimer.read_ms timer);
+ flush stdout;
+
+ let set = ref Set.empty in
+ MTimer.start timer;
+ Array.iter ~f:(fun zz -> set := Set.add zz !set) zza;
+ MTimer.stop timer;
+
+ Printf.printf "Set Insert time: %f ms\n" (MTimer.read_ms timer);
+ flush stdout;
+ *)
+
Added: sks/branches/upstream/sks/current/prime.ml
===================================================================
--- sks/branches/upstream/sks/current/prime.ml (rev 0)
+++ sks/branches/upstream/sks/current/prime.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,113 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+module Unix=UnixLabels
+open Number.Infix
+
+(** Generate prime using miller-rabin primality test *)
+
+(** returns random string with exactly <bits> bits. Highest order bit is
+ always 1 *)
+let randbits rfunc nbits =
+ let rval =
+ let nbytes = nbits / 8 + (if nbits mod 8 = 0 then 0 else 1) in
+ let rstring = Utils.random_string rfunc nbytes in
+ let rand = Number.of_bytes rstring in
+ let high = two **! (nbits - 1) in
+ high +! (rand %! high)
+ in
+ assert (Number.nbits rval = nbits);
+ rval
+
+(** chooses random int between 0 and high-1 *)
+let rec randint rfunc high =
+ let nbits = Number.nbits high in
+ let nbytes = nbits / 8 + (if nbits mod 8 = 0 then 0 else 1) in
+ let rstring = Utils.random_string rfunc nbytes in
+ let rand = Number.of_bytes rstring in
+ rand %! high
+
+(** chooses random int between low and high-1 *)
+let randrange rfunc low high =
+ low +! (randint rfunc (high -! low))
+
+let zerobits n =
+ let nbits = Number.nbits n in
+ let rec loop count =
+ if count >= nbits
+ then failwith ("Prime.zerobits: unexpected condition. " ^
+ "Argument may have been zero");
+ if Number.nth_bit n count
+ then count
+ else loop (count + 1)
+ in
+ loop 0
+
+let decompose n =
+ let s = zerobits n in
+ let r = n /! two **! s in
+ assert ((two **! s) *! r =! n);
+ assert(Number.nth_bit r 0);
+ (s,r)
+
+type result = Prime | Composite
+
+let rec test_loop test m =
+ if m = 0 then true
+ else
+ match test () with
+ Prime -> test_loop test (m - 1)
+ | Composite -> false
+
+
+(** miller-rabin primality test *)
+let miller_rabin rfunc n t =
+ let (s,r) = decompose (n -! one) in
+ let neg_one = n -! one in
+
+ let test () =
+ let a = randrange rfunc two (n -! one) in
+ let y = Number.powmod a r n in
+ if y =! one or y =! neg_one then Prime
+ else
+ let rec loop y j =
+ if y =! neg_one then Prime
+ else if j = s then Composite
+ else
+ let y = Number.squaremod y n in
+ if y =! one then Composite
+ else loop y (j + 1)
+ in
+ loop y 1
+
+ in
+ test_loop test t
+
+
+let rec randprime rfunc ~bits ~error:t =
+ let guess = randbits rfunc bits in
+ let guess = (* force oddness *)
+ if guess %! two =! zero
+ then guess +! one else guess
+ in
+ if miller_rabin rfunc guess t
+ then guess
+ else randprime rfunc ~bits ~error:t
+
+
Added: sks/branches/upstream/sks/current/pstyle.ml
===================================================================
--- sks/branches/upstream/sks/current/pstyle.ml (rev 0)
+++ sks/branches/upstream/sks/current/pstyle.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,53 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Allows for some python-like tricks, at the expense of some performance
+ and indirection *)
+open StdLabels
+open MoreLabels
+
+module Array =
+struct
+ include Array
+ let normalize ar i = if i < 0 then length ar + i else i
+ let get ar i = get ar (normalize ar i)
+ let slice start stop ar =
+ let stop = if stop = 0 then length ar else stop in
+ let pos = normalize ar start in
+ let len = (normalize ar stop) - pos in
+ sub ar ~pos ~len
+end
+
+module String =
+struct
+ include String
+ let normalize str i = if i < 0 then length str + i else i
+ let get str i = get str (normalize str i)
+ let slice start stop str =
+ let stop = if stop = 0 then length str else stop in
+ let pos = normalize str start in
+ let len = (normalize str stop) - pos in
+ sub str ~pos ~len
+end
+
+let rec range ?(stride=1) ?(start=0) stop =
+ if start >= stop then []
+ else start::(range ~stride ~start:(start+stride) stop)
+
+
+let ( </> ) string (start,stop) = String.slice start stop string
+let ( <|> ) ar (start,stop) = Array.slice start stop ar
Added: sks/branches/upstream/sks/current/ptest.ml
===================================================================
--- sks/branches/upstream/sks/current/ptest.ml (rev 0)
+++ sks/branches/upstream/sks/current/ptest.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,161 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+open Printf
+open Common
+open Packet
+open Bdb
+
+module Set = PSet.Set
+
+module Keydb =
+ Keydb.Make(struct
+ let withtxn = !Settings.transactions
+ and cache_bytes = !Settings.cache_bytes
+ and pagesize = !Settings.pagesize
+ and dbdir = !Settings.dbdir
+ and dumpdir = !Settings.dumpdir
+ end)
+
+module PTreeDB =
+ PTreeDB.Make(struct
+ let mbar = !Settings.mbar
+ and bitquantum = !Settings.bitquantum
+ and treetype = `ondisk
+ and max_nodes = !Settings.max_ptree_nodes
+ and dbdir = !Settings.ptree_dbdir
+ and cache_bytes = !Settings.ptree_cache_bytes
+ and pagesize = !Settings.ptree_pagesize
+ end)
+open PTreeDB
+
+module PTree = PrefixTree
+
+let () = PTreeDB.init ()
+let () = Keydb.open_dbs ()
+let ptree = PrefixTree.create ?db:(get_db ()) ~txn:None
+ ~num_samples ~bitquantum
+ ~thresh:(mbar * !Settings.ptree_thresh_mult) ()
+
+let trunc s = String.sub ~pos:0 ~len:16 s
+
+
+let i = ref 0
+let get_ptree_hashes () =
+ PTree.summarize_tree
+ ~lagg:(fun set -> Array.map ~f:trunc
+ (Array.of_list (Set.elements set)))
+ ~cagg:(fun alist -> Array.concat (Array.to_list alist))
+ ptree
+
+
+let sstream_array_get size stream =
+ match SStream.peek stream with
+ None -> [| |]
+ | Some first ->
+ let array = Array.make size first in
+ let ctr = ref 0 in
+ let emptystream = ref false in
+ while (!ctr < Array.length array &&
+ not !emptystream )
+ do
+ match SStream.next stream with
+ Some hash ->
+ array.(!ctr) <- hash;
+ incr ctr
+ | None ->
+ emptystream := true
+ done;
+ if !ctr <> Array.length array then
+ Array.sub ~pos:0 ~len:!ctr array
+ else
+ array
+
+let get_kdb_hashes () =
+ let chunksize = 5000 in
+ let (stream,close) = Keydb.create_hashstream () in
+ let rec loop alist =
+ let newarray = sstream_array_get chunksize stream in
+ if newarray = [| |] then
+ List.rev alist
+ else
+ loop (newarray::alist)
+ in
+ let alist = loop [] in
+ let array = Array.concat alist in
+ array
+
+
+let is_sorted ~cmp array =
+ let rec loop i =
+ if i >= Array.length array - 1 then
+ true
+ else (
+ if cmp array.(i+1) array.(i) > 0 then loop (i+1)
+ else false
+ )
+ in
+ loop 0
+
+(** compute the symmetric difference between two arrays
+ sorted in increasing order
+*)
+let array_diff a1 a2 =
+ let c1 = ref 0 and c2 = ref 0 in
+ let diff1 = ref [] and diff2 = ref [] in
+
+ let add1 () =
+ diff1 := a1.(!c1)::!diff1;
+ incr c1
+ and add2 () =
+ diff2 := a2.(!c2)::!diff2;
+ incr c2
+ in
+
+ while !c1 < Array.length a1 || !c2 < Array.length a2 do
+ if !c1 >= Array.length a1 then add2 ()
+ else if !c2 >= Array.length a2 then add1 ()
+ else if a1.(!c1) = a2.(!c2) then ( incr c1; incr c2; )
+ else if a1.(!c1) < a2.(!c2) then add1 ()
+ else add2 ()
+ done;
+ (List.rev !diff1,List.rev !diff2)
+
+
+let () =
+ if not !Sys.interactive then
+ perror "Getting Keydb hashes";
+ let khashes = get_kdb_hashes () in
+ perror "Getting PTree hashes";
+ let phashes = get_ptree_hashes () in
+ perror "Comparing hashes";
+ let (diff1,diff2) = array_diff phashes khashes in
+ let (diff1,diff2) = (List.map ~f:KeyHash.hexify diff1,
+ List.map ~f:KeyHash.hexify diff2)
+ in
+ printf "Prefix side:\n";
+ MList.print2 ~f:(printf "%s") diff1;
+ printf "\n\nKeydb side:\n";
+ MList.print2 ~f:(printf "%s") diff2;
+ printf "\n"
+
+let () =
+ perror "Closing DBs";
+ Keydb.close_dbs ();
+ PTreeDB.closedb ()
Added: sks/branches/upstream/sks/current/ptree_consistency_test.ml
===================================================================
--- sks/branches/upstream/sks/current/ptree_consistency_test.ml (rev 0)
+++ sks/branches/upstream/sks/current/ptree_consistency_test.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,81 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Test for verifying consistency of prefix tree data structure *)
+open Common
+open StdLabels
+open MoreLabels
+module Set = PSet.Set
+
+open ReconPTreeDb
+
+let ident x = x
+
+let node_to_svalues node = node.PTree.svalues
+
+let check_svalues parent children =
+ let parent = ZZp.zzarray_to_array parent in
+ let children = List.map ~f:ZZp.zzarray_to_array children in
+ match children with
+ [] -> failwith "check_svalues: no children to check"
+ | hd::tl ->
+ parent = List.fold_left ~f:ZZp.array_mult ~init:hd tl
+
+let check_node ptree parent children =
+ check_svalues parent.PTree.svalues
+ (List.map ~f:node_to_svalues children)
+
+let check_leaf ptree node =
+ let points = ptree.PTree.points in
+ let svalues = PTree.create_svalues points in
+ match node.PTree.children with
+ | PTree.Children _ -> failwith "check_leaf called on non-leaf node"
+ | PTree.Leaf children ->
+ Set.iter children ~f:(fun zzs ->
+ let zz = ZZp.of_bytes zzs in
+ ZZp.add_el ~svalues ~points zz
+ );
+ (ZZp.zzarray_to_array node.PTree.svalues =
+ ZZp.zzarray_to_array svalues)
+
+let rec check_tree ptree node =
+ let key = node.PTree.key in
+ let keyrep = Bitstring.to_string key in
+ if PTree.is_leaf node then
+ let rval = check_leaf ptree node in
+ if rval
+ then perror "leaf passed: %s" keyrep
+ else perror "leaf failed: %s" keyrep;
+ rval
+ else
+ let childkeys = PTree.child_keys ptree key in
+ let children =
+ List.map ~f:(fun key -> PTree.get_node_key ptree key) childkeys
+ in
+ let node_passed = check_node ptree node children in
+ if node_passed
+ then perror "internal node passed: %s" keyrep
+ else perror "internal node failed: %s" keyrep;
+ let child_status = List.map ~f:(check_tree ptree) children in
+ node_passed &
+ List.for_all ~f:ident child_status
+
+let () =
+ perror "Starting recursive check";
+ if check_tree !ptree (!ptree).PTree.root
+ then perror "tree passed"
+ else perror "tree FAILED"
Added: sks/branches/upstream/sks/current/ptree_db_test.ml
===================================================================
--- sks/branches/upstream/sks/current/ptree_db_test.ml (rev 0)
+++ sks/branches/upstream/sks/current/ptree_db_test.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,52 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Checks whether the memory-bounds on a ptree are in force *)
+
+(** Test for verifying consistency of prefix tree data structure *)
+(* #directory "/home/yminsky/Work/projects/keyserver/sks";;
+let () = Sys.chdir "/usr/share/keyfiles/sks_the";;
+#load "reconPTreeDb.cmo";;
+*)
+
+open Printf
+open StdLabels
+open MoreLabels
+module Set = PSet.Set
+
+open Common
+
+open ReconPTreeDb
+open ReconPTreeDb.PDb
+
+let root = (!ptree).PTree.root
+
+let random_probe () =
+ let zzs = PTree.get_random !ptree root in
+ let depth = ref 0 in
+ while
+ let node = PTree.get_node_str !ptree zzs !depth in
+ if PTree.is_leaf node then false
+ else true
+ do incr depth done
+
+
+
+let inmem_count () =
+ match !ptree.PTree.db with
+ None -> failwith "DB expected"
+ | Some db -> db.PTree.inmem_count
Added: sks/branches/upstream/sks/current/ptree_replay.ml
===================================================================
--- sks/branches/upstream/sks/current/ptree_replay.ml (rev 0)
+++ sks/branches/upstream/sks/current/ptree_replay.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,87 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Test for verifying consistency of prefix tree data structure *)
+open Common
+open StdLabels
+open MoreLabels
+module Set = PSet.Set
+
+open Pstyle
+open ReconPTreeDb
+open ReconPTreeDb.PDb
+
+(******************************************************************)
+
+let rec get_piece_ch ch s pos =
+ if pos >= String.length s then None
+ else if s.[pos] = ch then get_piece_ch ch s (pos + 1)
+ else
+ try
+ let nextpos = String.index_from s pos ch in
+ Some ((String.sub ~pos ~len:(nextpos - pos) s),nextpos)
+ with
+ Not_found ->
+ Some ((String.sub ~pos ~len:(String.length s - pos) s),
+ String.length s)
+
+let rec chsplit ch s pos =
+ match get_piece_ch ch s pos with
+ None -> []
+ | Some (piece,nextpos) -> piece::chsplit ch s nextpos
+
+let chsplit ch s = Array.of_list (chsplit ch s 0)
+
+(******************************************************************)
+
+let hashfile = "log.real"
+
+let rec hashiter ~f file =
+ match (try Some (input_line file) with End_of_file -> None)
+ with
+ | None -> ()
+ | Some line ->
+ let pieces = chsplit ' ' line in
+ let hash = KeyHash.dehexify pieces.(-1) in
+ let action = match pieces.(-2) with
+ | "Add" -> Add hash
+ | "Del" -> Delete hash
+ | _ -> failwith "Unexpected action"
+ in
+ f action;
+ hashiter ~f file
+
+let hashiter ~f file =
+ ignore (input_line file);
+ hashiter ~f file
+
+let apply_action txn action =
+ match action with
+ | Add hash -> PTree.insert_str !ptree txn hash
+ | Delete hash -> PTree.delete_str !ptree txn hash
+
+
+let () =
+ let file = open_in hashfile in
+ let txn = new_txnopt () in
+ try
+ hashiter ~f:(apply_action txn) file;
+ commit_txnopt txn;
+ with
+ e ->
+ abort_txnopt txn;
+ raise e
Added: sks/branches/upstream/sks/current/ptscript.ml
===================================================================
--- sks/branches/upstream/sks/current/ptscript.ml (rev 0)
+++ sks/branches/upstream/sks/current/ptscript.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,26 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open PdiskTest
+open PTree
+
+let () =
+ Settings.prob := 0.0
+
+let () =
+ runtest 100
+
Added: sks/branches/upstream/sks/current/query.ml
===================================================================
--- sks/branches/upstream/sks/current/query.ml (rev 0)
+++ sks/branches/upstream/sks/current/query.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,73 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Executable Simple tool for direct querying key db. Should not be used
+ while dbserver is running *)
+open StdLabels
+open MoreLabels
+open Printf
+open Arg
+open Packet
+
+module Keydb = Keydb.Make(struct
+ let withtxn = false
+ and cache_bytes = !Settings.cache_bytes
+ and pagesize = !Settings.pagesize
+ and dbdir = !Settings.dbdir
+ and dumpdir = !Settings.dumpdir
+ end)
+
+
+let dbdir = !Settings.dbdir
+
+let _ =
+ Keydb.open_dbs ()
+
+let _ =
+ try
+ while true do
+ let line = try read_line () with End_of_file -> raise Exit in
+ try
+ let words = Keydb.extract_words line in
+
+ print_string " Query words: ";
+ MList.print ~f:(fun s -> printf "\"%s\"" s) words;
+ print_newline ();
+
+ let keylist = Keydb.get_by_words ~max:200 words in
+ List.iter ~f:(fun key ->
+ try
+ let keyid = Fingerprint.keyid_from_key key in
+ let keyidstr = Fingerprint.keyid_to_string
+ ~short:true keyid in
+ printf "0x%s: %s\n"
+ keyidstr (List.hd (Key.get_ids key))
+ with
+ Not_found ->
+ printf "Failure to extract key\n";
+ )
+ keylist;
+ with
+ e -> raise e
+ done
+
+ with
+ | Exit -> Keydb.close_dbs (); print_string "Exiting.\n"
+ | e -> Keydb.close_dbs ();
+ print_string "Exiting by exception.\n";
+ raise e
+
Added: sks/branches/upstream/sks/current/rMisc.ml
===================================================================
--- sks/branches/upstream/sks/current/rMisc.ml (rev 0)
+++ sks/branches/upstream/sks/current/rMisc.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,169 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Miscellaneous utilities associated with reconciliation, and in particular
+ those that require access to the size of the prime modulus. *)
+open StdLabels
+open MoreLabels
+module Unix=UnixLabels
+
+(** deterministic RNG *)
+let det_rng = Random.State.make [|104|]
+module Set = PSet.Set (* was: Polyset.Set *)
+module Map = PMap.Map
+
+let stringset_to_string stringset =
+ let list = List.sort ~cmp:compare (Set.elements stringset) in
+ let cout = Channel.new_buffer_outc 1024 in
+ List.iter ~f:(fun string ->
+ cout#write_int (String.length string);
+ cout#write_string string)
+ list;
+ cout#contents
+
+let digest_stringset strings =
+ let string = stringset_to_string strings in
+ Digest.string string
+
+let print_lengths list =
+ let list = List.sort ~cmp:compare list in
+ MList.print ~f:(fun s -> Printf.printf "%d" (String.length s))
+ list
+
+let rec fill_random_string rfunc string ~pos ~len =
+ if pos < len then
+ let steps =
+ if len - pos > 3 then 3 else len - pos in
+ (* CR yminsky: I think this has the same bug as the function with the same name in Utils *)
+ let _bits = rfunc () in
+ for i = 0 to steps - 1 do
+ string.[pos + i] <-
+ char_of_int (0xFF land ((rfunc ()) lsr (8 * i)))
+ done;
+ fill_random_string rfunc string ~pos:(pos + steps) ~len
+ else
+ ()
+
+let random_string rfunc len =
+ let string = String.create len in
+ fill_random_string rfunc string ~pos:0 ~len;
+ string
+
+let conv_chans (cin, cout) =
+ (new MeteredChannel.metered_in_channel (new Channel.sys_in_channel cin),
+ new MeteredChannel.metered_out_channel (new Channel.sys_out_channel cout))
+(* new Bufchan.buf_out_channel cout (1024 * 100)) *)
+(************************************************************)
+(* String Sets ********************************************)
+(************************************************************)
+
+let add_random rfunc bytelength set =
+ Set.add (random_string rfunc bytelength) set
+
+let add_n_random rfunc bytelength ~n set =
+ Utils.apply n (add_random rfunc bytelength) set
+
+let det_string_set ~bytes ~size =
+ add_n_random
+ (fun () -> Random.State.bits det_rng)
+ bytes ~n:size Set.empty
+
+let rand_string_set ~bytes ~size =
+ add_n_random Random.bits bytes ~n:size Set.empty
+
+let localize_string_set ~bytes ~diff set =
+ add_n_random Random.bits bytes ~n:diff set
+
+(*
+let local_string_set ~bytes ~base_size ~diff =
+ let base_set = det_string_set ~bytes ~size:base_size in
+ let local_set = add_n_random Random.bits bytes ~n:diff base_set in
+ local_set
+*)
+
+(*
+let string_sets ~bytes ~base_size ~diff =
+ let base_set = det_string_set ~bytes ~size:base_size in
+ let diff_set = add_n_random Random.bits bytes ~n:diff Set.empty in
+ (base_set,diff_set)
+*)
+
+(*
+let print_string_set set =
+ let list = Set.elements set in
+ let list= List.sort ~cmp:compare list in
+ List.iter ~f:(fun string -> print_string string; print_newline ())
+*)
+
+let add_sarray ~data sarray =
+ Array.fold_right ~f:(fun string set -> Set.add string set)
+ sarray ~init:data
+
+(*****************************************************************)
+(*****************************************************************)
+
+let pad string bytes =
+ let len = String.length string in
+ if bytes > len then
+ let nstr = String.create bytes in
+ String.fill nstr ~pos:len ~len:(bytes - len) '\000';
+ String.blit ~src:string ~dst:nstr ~src_pos:0 ~dst_pos:0 ~len;
+ nstr
+ else
+ string
+
+
+let padset stringset bytes =
+ Set.fold ~f:(fun el set -> Set.add (pad el bytes) set)
+ ~init:Set.empty stringset
+
+let truncate string bytes =
+ let len = String.length string in
+ if bytes < len then
+ let nstr = String.create bytes in
+ String.blit ~src:string ~dst:nstr ~src_pos:0 ~dst_pos:0 ~len:bytes;
+ nstr
+ else
+ string
+
+let truncset stringset bytes =
+ Set.fold ~f:(fun el set -> Set.add (truncate el bytes) set)
+ ~init:Set.empty stringset
+
+
+
+(*****************************************************************)
+(* PRIMENESS-RELATED THINGS ***********************************)
+(*****************************************************************)
+
+let order_string = "530512889551602322505127520352579437339"
+
+(** Printing Functions *)
+
+let print_ZZp_list list =
+ let list = Sort.list (fun x y -> compare x y < 0) list in
+ MList.print2 ~f:ZZp.print list
+
+let print_ZZp_set set = print_ZZp_list (Set.elements set)
+
+
+(************* Initialization code ****************************)
+
+let _ =
+ Settings.setup_RNG ();
+ ZZp.set_order (ZZp.of_string order_string)
+
Added: sks/branches/upstream/sks/current/recode.ml
===================================================================
--- sks/branches/upstream/sks/current/recode.ml (rev 0)
+++ sks/branches/upstream/sks/current/recode.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,37 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open Printf
+open StdLabels
+open MoreLabels
+
+open Packet
+
+let limit = try int_of_string Sys.argv.(1) with _ -> 10
+let cin = new Channel.sys_in_channel stdin
+let cout = new Channel.sys_out_channel stdout
+let getkey = Key.get_of_channel cin
+
+let _ =
+ let count = ref 0 in
+ ( try
+ while !count < limit do
+ Key.write (getkey ()) cout;
+ incr count
+ done
+ with
+ Not_found -> () )
Added: sks/branches/upstream/sks/current/reconCS.ml
===================================================================
--- sks/branches/upstream/sks/current/reconCS.ml (rev 0)
+++ sks/branches/upstream/sks/current/reconCS.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,169 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Reconciliation logic that is shared between the client and server *)
+open StdLabels
+open MoreLabels
+open Common
+open CMarshal
+open ReconMessages
+open Printf
+module Set = PSet.Set
+
+(** Configuration related functions *)
+
+(** Build map containing configuration information *)
+let build_configdata filters =
+ let map = Map.empty in
+ let map = (map |< "version") version in
+ let map = (map |< "http port") (int_to_string http_port) in
+ let map = (map |< "bitquantum") (int_to_string !Settings.bitquantum) in
+ let map = (map |< "mbar") (int_to_string !Settings.mbar) in
+ let map = (map |< "filters") (String.concat ~sep:"," filters) in
+ map
+
+let comma_rxp = Str.regexp ","
+let config_get_filters cd = Str.split comma_rxp (cd |= "filters")
+
+(** Returns `passed if there are no problems with the configdata,
+ `failed s if there is a problem, where s is a string describing the
+ problem.
+*)
+let test_configdata local remote =
+ try
+ let remote_version_string = remote |= "version" in
+ let remote_version = parse_version_string remote_version_string in
+ if remote_version < compatible_version_tuple
+ then `failed (sprintf "Requires version at least %s. %s provided "
+ version remote_version_string)
+ else if not (Set.equal
+ (Set.of_list (config_get_filters local))
+ (Set.of_list (config_get_filters remote)))
+ then `failed (sprintf "filters do not match.\n\tlocal filters: %s\n\tremote filters: %s"
+ (MList.to_string ~f:(sprintf "%s")
+ (config_get_filters local))
+ (MList.to_string ~f:(sprintf "%s")
+ (config_get_filters remote))
+ )
+ else
+ let bitquantum = int_of_string (remote |= "bitquantum") in
+ let mbar = int_of_string (remote |= "mbar") in
+ if bitquantum <> !Settings.bitquantum then
+ `failed "bitquantum values do not match"
+ else if mbar <> !Settings.mbar then
+ `failed "mbar values do not match"
+ else
+ `passed
+ with
+ Not_found -> `failed "Missing entry in configdata"
+ | e ->
+ Eventloop.reraise e;
+ `failed (sprintf "Error parsing configdata: %s"
+ (Printexc.to_string e) )
+
+(** Exchanges config data with other host, and tests
+ whether provided config data allows for reconciliation
+ to proceed.
+
+ @param cin input channel @param cout output channel
+ @param filters list of strings representing filters that have been applied
+ to data.
+ @param peer sockaddr of gossip partner
+*)
+let handle_config cin cout filters peer =
+ let configdata = build_configdata filters in
+ marshal cout (Config configdata); (* channel is flushed here *)
+ let remote_configdata =
+ match (unmarshal cin).msg with
+ | Config x -> x
+ | _ -> failwith "No configdata provided"
+ in
+ (match test_configdata configdata remote_configdata with
+ | `passed ->
+ marshal_string cout "passed";
+ cout#flush
+ | `failed reason ->
+ marshal_string cout "failed";
+ marshal_string cout reason;
+ cout#flush;
+ failwith (sprintf "configuration of remote host (%s) rejected: %s"
+ (sockaddr_to_string peer) reason)
+ );
+ (match unmarshal_string cin with
+ "passed" -> ()
+ | "failed" ->
+ let reason = unmarshal_string cin in
+ failwith (sprintf "Local configuration rejected by remote host (%s): %s"
+ (sockaddr_to_string peer) reason)
+ | _ -> failwith "Unexpected configuration confirmation response"
+ );
+ remote_configdata
+
+
+let config_get_http_port cd =
+ int_of_string (cd |= "http port")
+
+let change_port sockaddr newport = match sockaddr with
+ | Unix.ADDR_UNIX _ -> raise (Invalid_argument
+ "Can't change port of UNIX address")
+ | Unix.ADDR_INET (ipaddr,port) -> Unix.ADDR_INET (ipaddr,newport)
+
+let print_config config =
+ perror "Printing config";
+ Map.iter ~f:(fun ~key ~data -> perror " %s: %s" key data) config
+
+
+
+(** function to connect to remote host to initate reconciliation *)
+let connect tree ~filters ~partner =
+ (* TODO: change the following to depend on the address type *)
+ let s = Unix.socket
+ ~domain:partner.Unix.ai_family
+ ~kind:partner.Unix.ai_socktype
+ ~protocol:partner.Unix.ai_protocol
+ in
+ let run () =
+ Unix.bind s ~addr:(match_client_recon_addr partner.Unix.ai_addr);
+ Unix.connect s ~addr:partner.Unix.ai_addr;
+ let cin = Channel.sys_in_from_fd s
+ and cout = Channel.sys_out_from_fd s in
+ plerror 4 "Initiating reconciliation";
+ let remote_config = handle_config cin cout filters partner.Unix.ai_addr in
+ ignore (Unix.alarm !Settings.reconciliation_timeout);
+
+ let http_port = config_get_http_port remote_config in
+ let remote_http_address = change_port partner.Unix.ai_addr http_port in
+
+ let data = Server.handle tree cin cout in
+ (data,remote_http_address)
+ in
+ protect ~f:run ~finally:(fun () -> Unix.close s)
+
+
+(** *)
+let handle_connection tree ~filters ~partner cin cout =
+
+ plerror 4 "Joining reconciliation";
+ let remote_config = handle_config cin cout filters partner in
+ ignore (Unix.alarm !Settings.reconciliation_timeout);
+
+ let http_port = config_get_http_port remote_config in
+ let remote_http_address = change_port partner http_port in
+
+ let data = Client.handle tree cin cout in
+
+ (data,remote_http_address)
Added: sks/branches/upstream/sks/current/reconComm.ml
===================================================================
--- sks/branches/upstream/sks/current/reconComm.ml (rev 0)
+++ sks/branches/upstream/sks/current/reconComm.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,109 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+open Printf
+open Common
+open Packet
+
+module Unix = UnixLabels
+open DbMessages
+
+(***************************************************************)
+(** Message Sending Primitives *)
+(***************************************************************)
+
+(** send DbMessages message and wait for response *)
+let send_dbmsg msg =
+ let s = Unix.socket
+ ~domain:(Unix.domain_of_sockaddr db_command_addr)
+ ~kind:Unix.SOCK_STREAM
+ ~protocol:0 in
+ protect ~f:(fun () ->
+ Unix.connect s ~addr:db_command_addr;
+ let cin = Channel.sys_in_from_fd s in
+ let cout = Channel.sys_out_from_fd s in
+ marshal cout msg;
+ let reply = (unmarshal cin).msg in
+ reply
+ )
+ ~finally:(fun () -> Unix.close s)
+
+
+(** send DbMessages message, don't wait for response *)
+let send_dbmsg_noreply msg =
+ let s = Unix.socket
+ ~domain:(Unix.domain_of_sockaddr db_command_addr)
+ ~kind:Unix.SOCK_STREAM
+ ~protocol:0 in
+ protect ~f:(fun () ->
+ Unix.connect s ~addr:db_command_addr;
+ let cout = Channel.sys_out_from_fd s in
+ marshal cout msg )
+ ~finally:(fun () -> Unix.close s)
+
+let is_content_type line =
+ try
+ let colonpos = String.index line ':' in
+ let prefix = String.sub ~pos:0 ~len:colonpos line in
+ String.lowercase prefix = "content-type"
+ with
+ Not_found -> false
+
+let http_status_ok_regexp = Str.regexp "^HTTP/[0-9]+\\.[0-9]+ 2"
+
+let get_keystrings_via_http addr hashes =
+ let s = Unix.socket
+ ~domain:(Unix.domain_of_sockaddr addr)
+ ~kind:Unix.SOCK_STREAM
+ ~protocol:0 in
+ protect ~f:(fun () ->
+ Unix.bind s ~addr:(match_client_recon_addr addr);
+ Unix.connect s ~addr;
+ let cin = Channel.sys_in_from_fd s
+ and cout = Channel.sys_out_from_fd s in
+
+ let sout = Channel.new_buffer_outc 0 in
+ CMarshal.marshal_list ~f:CMarshal.marshal_string sout hashes;
+ let msg = sout#contents in
+ cout#write_string "POST /pks/hashquery HTTP/1.0\r\n";
+ cout#write_string (sprintf "content-length: %d\r\n\r\n"
+ (String.length msg));
+ cout#write_string msg;
+ cout#flush;
+ (* read "HTTP" line and make sure the status is 2xx *)
+ let status = input_line cin#inchan in
+ if not (Str.string_match http_status_ok_regexp status 0) then
+ failwith status;
+ let _headers = Wserver.parse_headers Map.empty cin#inchan in
+ let keystrings =
+ CMarshal.unmarshal_list ~f:CMarshal.unmarshal_string cin
+ in
+ keystrings
+ )
+ ~finally:(fun () -> Unix.close s)
+
+
+
+let fetch_filters () =
+ let reply = send_dbmsg (Config ("filters",`none)) in
+ match reply with
+ | Filters filters -> filters
+ | _ -> failwith "ReconComm.fetch_filters: unexpected reply"
+
+
Added: sks/branches/upstream/sks/current/reconMessages.ml
===================================================================
--- sks/branches/upstream/sks/current/reconMessages.ml (rev 0)
+++ sks/branches/upstream/sks/current/reconMessages.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,256 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+open Printf
+include CMarshal
+open Common
+module Unix=UnixLabels
+module Map = PMap.Map
+
+(***********************************)
+(* ZZ-specific marshallers ********)
+(***********************************)
+
+let marshal_ZZp cout zz =
+ let str = ZZp.to_bytes zz in
+ marshal_lstring cout str
+
+let unmarshal_ZZp cin =
+ ZZp.of_bytes (unmarshal_lstring !ZZp.nbytes cin)
+
+(*****)
+
+let marshal_zzarray cout zzarray =
+ marshal_array ~f:marshal_ZZp cout
+ (ZZp.mut_array_to_array zzarray)
+
+let unmarshal_zzarray cin =
+ let array = unmarshal_array ~f:unmarshal_ZZp cin in
+ ZZp.mut_array_of_array array
+
+(*****)
+
+let marshal_zset cout set =
+ let array = Array.of_list (ZSet.elements set) in
+ marshal_array ~f:marshal_ZZp cout array
+
+
+let unmarshal_zset cin =
+ let array = unmarshal_array ~f:unmarshal_ZZp cin in
+ ZZp.zset_of_list (Array.to_list array)
+
+(***********************************)
+(* Data Types ********************)
+(***********************************)
+
+(* recon request where polynomial checksum is sent *)
+type recon_rqst_poly =
+ { rp_prefix: Bitstring.t;
+ rp_size: int;
+ rp_samples: ZZp.mut_array;
+ }
+
+
+let marshal_recon_rqst_poly cout rp =
+ marshal_bitstring cout rp.rp_prefix;
+ cout#write_int rp.rp_size;
+ marshal_zzarray cout rp.rp_samples
+
+let unmarshal_recon_rqst_poly cin =
+ let prefix = unmarshal_bitstring cin in
+ let size = cin#read_int in
+ let samples = unmarshal_zzarray cin in
+ { rp_prefix = prefix;
+ rp_size = size;
+ rp_samples = samples;
+ }
+
+(***********************************)
+(***********************************)
+(***********************************)
+
+(* recon request where full data is sent *)
+type recon_rqst_full =
+ { rf_prefix: Bitstring.t;
+ rf_elements: ZSet.t;
+ }
+
+let marshal_recon_rqst_full cout rf =
+ marshal_bitstring cout rf.rf_prefix;
+ marshal_zset cout rf.rf_elements
+
+let unmarshal_recon_rqst_full cin =
+ let prefix = unmarshal_bitstring cin in
+ let elements = unmarshal_zset cin in
+ { rf_prefix = prefix;
+ rf_elements = elements; }
+
+(***********************************)
+(***********************************)
+(***********************************)
+
+(* recon request where full data is sent *)
+type configdata = (string,string) Map.t
+(* type metadata = { md_recon_addr: Unix.sockaddr; } *)
+
+let marshal_stringpair cout (s1,s2) =
+ marshal_string cout s1; marshal_string cout s2
+
+let unmarshal_stringpair cin =
+ let s1 = unmarshal_string cin in
+ let s2 = unmarshal_string cin in
+ (s1,s2)
+
+let marshal_stringpair_list cout list =
+ marshal_list ~f:marshal_stringpair cout list
+
+let unmarshal_stringpair_list cin =
+ unmarshal_list ~f:unmarshal_stringpair cin
+
+let marshal_configdata cout configdata =
+ marshal_stringpair_list cout (Map.to_alist configdata)
+
+let unmarshal_configdata cin =
+ Map.of_alist (unmarshal_stringpair_list cin)
+
+let sockaddr_to_string sockaddr = match sockaddr with
+ Unix.ADDR_UNIX s -> sprintf "<ADDR_UNIX %s>" s
+ | Unix.ADDR_INET (addr,p) -> sprintf "<ADDR_INET [%s]:%d>"
+ (Unix.string_of_inet_addr addr) p
+
+
+(***********************************)
+(***********************************)
+(***********************************)
+
+
+let marshal_allreply cout (prefix,set) =
+ marshal_bitstring cout prefix;
+ marshal_zset cout set
+
+let unmarshal_allreply cin =
+ let prefix = unmarshal_bitstring cin in
+ let set = unmarshal_zset cin in
+ (prefix,set)
+
+(*************)
+
+type msg = | ReconRqst_Poly of recon_rqst_poly
+ | ReconRqst_Full of recon_rqst_full
+ | Elements of ZSet.t
+ | FullElements of ZSet.t
+ | SyncFail
+ | Done
+ | Flush
+ | Error of string
+ | DbRqst of string
+ | DbRepl of string
+ | Config of configdata
+
+let rec msg_to_string msg =
+ (match msg with
+ | ReconRqst_Poly rp ->
+ sprintf "ReconRqst_Poly(%s)" (Bitstring.to_string rp.rp_prefix)
+ | ReconRqst_Full rf ->
+ sprintf "ReconRqst_Full(%d,%s)"
+ (ZSet.cardinal rf.rf_elements)
+ (Bitstring.to_string rf.rf_prefix)
+ | Elements s -> sprintf "Elements(len:%d)" (ZSet.cardinal s)
+ | FullElements s -> sprintf "FullElements(len:%d)" (ZSet.cardinal s)
+ | SyncFail -> "SyncFail"
+ | Done -> "Done"
+ | Flush -> "Flush"
+ | Error s -> sprintf "Error(%s)" s
+ | DbRqst s -> "DbRqst"
+ | DbRepl s -> "DbRepl"
+ | Config s -> "Config"
+ )
+
+let print_msg msg = print_string (msg_to_string msg)
+
+let marshal_samplevalues cout (size,sarray) =
+ cout#write_int size;
+ marshal_fixed_sarray cout sarray
+
+let unmarshal_samplevalues cin =
+ let size = cin#read_int in
+ let sarray = unmarshal_fixed_sarray cin in
+ (size,sarray)
+
+let marshal_time = ref 0.0
+let unmarshal_time = ref 0.0
+let timer = MTimer.create ()
+
+let rec marshal_msg cout msg = match msg with
+ | ReconRqst_Poly rp -> cout#write_byte 0; marshal_recon_rqst_poly cout rp
+ | ReconRqst_Full rf -> cout#write_byte 1; marshal_recon_rqst_full cout rf
+ | Elements set -> cout#write_byte 2; marshal_zset cout set
+ | FullElements set -> cout#write_byte 3; marshal_zset cout set
+ | SyncFail -> cout#write_byte 4
+ | Done -> cout#write_byte 5;
+ | Flush -> cout#write_byte 6;
+ | Error s -> cout#write_byte 7; marshal_string cout s
+ | DbRqst s -> cout#write_byte 8; marshal_string cout s
+ | DbRepl s -> cout#write_byte 9; marshal_string cout s
+ | Config md -> cout#write_byte 10; marshal_configdata cout md
+
+
+let rec unmarshal_msg cin =
+ let msg_type = cin#read_byte in
+ match msg_type with
+ | 0 -> ReconRqst_Poly (unmarshal_recon_rqst_poly cin)
+ | 1 -> ReconRqst_Full (unmarshal_recon_rqst_full cin)
+ | 2 -> Elements (unmarshal_zset cin)
+ | 3 -> FullElements (unmarshal_zset cin)
+ | 4 -> SyncFail
+ | 5 -> Done
+ | 6 -> Flush
+ | 7 -> Error (unmarshal_string cin)
+ | 8 -> DbRqst (unmarshal_string cin)
+ | 9 -> DbRepl (unmarshal_string cin)
+ | 10 -> Config (unmarshal_configdata cin)
+ | x -> failwith (sprintf "Unexpected message code: %d" x)
+
+module M =
+ NbMsgContainer.Container(
+ struct
+ type msg_t = msg
+ let marshal = marshal_msg
+ let unmarshal = unmarshal_msg
+ let to_string = msg_to_string
+ let print = (fun s -> plerror 6 "%s" s)
+ end)
+
+include M
+
+
+
+(* type init_flag = Recon | DbRequest
+
+let init_flag_to_byte flag = match flag with
+ Recon -> 0
+ | DbRequest -> 1
+
+let init_flag_of_byte byte = match byte with
+ 0 -> Recon
+ | 1 -> DbRequest
+ | _ -> failwith "Unexpected DB flag"
+*)
+
+
Added: sks/branches/upstream/sks/current/reconPTreeDb.ml
===================================================================
--- sks/branches/upstream/sks/current/reconPTreeDb.ml (rev 0)
+++ sks/branches/upstream/sks/current/reconPTreeDb.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,22 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+open Common
+module PTree = PrefixTree
+
Added: sks/branches/upstream/sks/current/reconserver.ml
===================================================================
--- sks/branches/upstream/sks/current/reconserver.ml (rev 0)
+++ sks/branches/upstream/sks/current/reconserver.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,389 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Executable: server process that handles reconciliation. *)
+
+module F(M:sig end) =
+struct
+ open StdLabels
+ open MoreLabels
+ open Printf
+ open Common
+ open Packet
+ open DbMessages
+ module Unix = UnixLabels
+ module PTree = PrefixTree
+ module Map = PMap.Map
+ module ZSet = ZZp.Set
+
+ open RecoverList
+ open PTreeDB
+ open Catchup
+
+ let settings = {
+ mbar = !Settings.mbar;
+ bitquantum = !Settings.bitquantum;
+ treetype = (if !Settings.transactions
+ then `transactional
+ else if !Settings.disk_ptree
+ then `ondisk else `inmem);
+ max_nodes = !Settings.max_ptree_nodes;
+ dbdir = Lazy.force Settings.ptree_dbdir;
+ cache_bytes = !Settings.ptree_cache_bytes;
+ pagesize = !Settings.ptree_pagesize;
+ }
+
+ (******************************************************************)
+
+ let reconsocks =
+ List.map ~f:Eventloop.create_sock (make_addr_list recon_address recon_port)
+
+ let () =
+ if Sys.file_exists recon_command_name
+ then Unix.unlink recon_command_name
+ let comsock = Eventloop.create_sock recon_command_addr
+
+ let filters = ref None
+ let get_filters () = match !filters with
+ None -> failwith "No filters retrieved"
+ | Some filters -> filters
+
+
+ (***************************************************************)
+ (* Handlers *************************************************)
+ (***************************************************************)
+
+ let eventify_handler handle =
+ (fun addr cin cout ->
+ let cin = (new Channel.sys_in_channel cin)
+ and cout = (new Channel.sys_out_channel cout) in
+ handle addr cin cout
+ )
+
+ let choose_partner () =
+ try
+ let addrlist = Membership.choose () in
+ (* Only return usable addresses *)
+ let is_compatible addr =
+ try
+ ignore (match_client_recon_addr addr.Unix.ai_addr);
+ true
+ with Not_found -> false
+ in
+ let addrlist = List.filter ~f:is_compatible addrlist in
+ List.nth addrlist (Random.int (List.length addrlist))
+ with
+ Not_found | Invalid_argument _ ->
+ failwith "No gossip partners available"
+
+ let missing_keys_timeout = !Settings.missing_keys_timeout
+
+ (******************************************************************)
+
+ let rec get_missing_keys () =
+ let name = "get missing keys" in
+ let timeout = missing_keys_timeout in
+ try
+
+ ( try
+ let (hashes,httpaddr) = Queue.pop recover_list in
+ plerror 3
+ "Requesting %d missing keys from %s, starting with %s"
+ (List.length hashes) (sockaddr_to_string httpaddr)
+ (match hashes with
+ [] -> "<nohash>"
+ | hash::tl -> KeyHash.hexify hash
+ );
+
+ let keystrings = ReconComm.get_keystrings_via_http httpaddr hashes in
+ plerror 3 "%d keys received" (List.length keystrings);
+ let ack = ReconComm.send_dbmsg (KeyStrings keystrings) in
+ if ack <> Ack 0
+ then failwith ("Reconserver.get_missing_keys: " ^
+ "Unexpected reply to KeyStrings message");
+ let now = Unix.gettimeofday () in
+ [
+ Eventloop.Event
+ (now,
+ Eventloop.make_tc
+ ~name:"get_missing_keys.catchup"
+ ~timeout:max_int
+ ~cb:Catchup.catchup);
+
+ Eventloop.Event
+ (Ehandlers.float_incr now,
+ Eventloop.make_tc ~name ~timeout
+ ~cb:get_missing_keys; );
+ ]
+ with
+ | Queue.Empty -> enable_gossip (); []
+ | Eventloop.SigAlarm as e -> raise e
+ | e ->
+ Eventloop.reraise e;
+ eperror e "Error getting missing keys";
+ [Eventloop.Event (Unix.gettimeofday (),
+ Eventloop.make_tc ~cb:get_missing_keys
+ ~timeout ~name)
+ ]
+
+ )
+ with
+ | Eventloop.SigAlarm ->
+ plerror 2 "get_missing_keys terminated by timeout";
+ (* If we time out, just schedule the next one *)
+ [Eventloop.Event (Unix.gettimeofday (),
+ Eventloop.make_tc ~cb:get_missing_keys ~timeout ~name; ) ]
+
+ (******************************************************************)
+
+ (** convert a sockaddr to a string suitable for including in a file name *)
+ let sockaddr_to_name sockaddr = match sockaddr with
+ Unix.ADDR_UNIX s -> sprintf "UNIX_%s" s
+ | Unix.ADDR_INET (addr,p) -> sprintf "%s_%d" (Unix.string_of_inet_addr addr) p
+
+ (******************************************************************)
+
+ (** Handles incoming reconciliation *)
+ let recon_handler addr cin cout =
+ if gossip_disabled () then
+ begin
+ plerror 3
+ "Reconciliation attempt from %s while gossip disabled. %s"
+ (sockaddr_to_string addr) "Ignoring.";
+ []
+ end
+ else if not (Membership.test addr) then
+ begin
+ plerror 1
+ "Reconciliation attempt from unauthorized host %s. Ignoring"
+ (sockaddr_to_string addr) ;
+ []
+ end
+ else
+ begin
+ plerror 4 "Beginning recon as server, client: %s"
+ (sockaddr_to_string addr);
+ let cin = (new Channel.sys_in_channel cin)
+ and cout = (new Channel.sys_out_channel cout) in
+ let filters = get_filters () in
+ let (results,http_addr) =
+ ReconCS.handle_connection (get_ptree ()) ~filters
+ ~partner:addr cin cout
+ in
+ plerror 4 "Reconciliation complete";
+ let elements = ZSet.elements results in
+ let hashes = hashconvert elements in
+ print_hashes (sockaddr_to_string http_addr) hashes;
+ log_diffs (sprintf "diff-%s.txt" (sockaddr_to_name http_addr)) hashes;
+ if List.length elements > 0
+ then
+ begin
+ update_recover_list elements http_addr;
+ [Eventloop.Event (Unix.gettimeofday () +. 10.0,
+ Eventloop.make_tc ~cb:get_missing_keys
+ ~timeout:missing_keys_timeout
+ ~name:"get missing keys"
+ )]
+ end
+ else
+ []
+ end
+
+
+ (******************************************************************)
+
+ (** Initiates reconciliation as client *)
+ let initiate_recon () =
+ if gossip_disabled () then
+ begin
+ plerror 5 "Not gossiping because gossip is disabled";
+ []
+ end
+ else
+ begin
+ let partner = choose_partner () in
+ plerror 4 "Recon partner: %s" (sockaddr_to_string partner.Unix.ai_addr);
+ let filters = get_filters () in
+ let (results,http_addr) =
+ ReconCS.connect (get_ptree ()) ~filters ~partner
+ in
+ let results = ZSet.elements results in
+ plerror 4 "Reconciliation complete";
+ let hashes = hashconvert results in
+ print_hashes (sockaddr_to_string http_addr) hashes;
+ log_diffs (sprintf "diff-%s.txt" (sockaddr_to_name http_addr)) hashes;
+ match results with
+ [] -> []
+ | _ ->
+ update_recover_list results http_addr;
+ [Eventloop.Event (Unix.gettimeofday (),
+ Eventloop.make_tc ~cb:get_missing_keys
+ ~timeout:missing_keys_timeout
+ ~name:"get missing keys"
+ )]
+ end
+
+
+ (******************************************************************)
+
+ let command_handler addr cin cout =
+ match (unmarshal cin).msg with
+
+ | Synchronize ->
+ marshal cout (Ack 0);
+ plerror 2 "Initiating recon due to explicit request";
+ initiate_recon ()
+
+ | RandomDrop n ->
+ marshal cout (Ack 0);
+ for i = 1 to n do
+ try
+ let hash = PTree.get_random (get_ptree ())
+ (PTree.root (get_ptree ())) in
+ let hash = RMisc.truncate hash KeyHash.hash_bytes in
+ plerror 3 "Requesting deletion %s" (Utils.hexstring hash);
+ ignore (ReconComm.send_dbmsg (DeleteKey hash))
+ with
+ Not_found ->
+ failwith "Attempted to delete element from empty prefix tree"
+ | e ->
+ Eventloop.reraise e;
+ eplerror 3 e "Attempt to delete key failed"
+ done;
+ []
+
+ | HashRequest hashes ->
+ let keyresp = (ReconComm.send_dbmsg (HashRequest hashes)) in
+ assert (match keyresp with Keys _ -> true | _ -> false);
+ marshal cout keyresp;
+ []
+
+ | Config (s,cvar) ->
+ plerror 4 "Received config message";
+ (match (s,cvar) with
+ ("maxnodes",`int x) ->
+ plerror 3 "Setting maxnodes to %d" x;
+ let txn = new_txnopt () in
+ (try
+ PTree.set_maxnodes (get_ptree ()) txn x;
+ PTree.clean txn (get_ptree ());
+ commit_txnopt txn
+ with
+ e ->
+ eplerror 1 e "set_maxnodes Transaction aborting";
+ abort_txnopt txn)
+ | _ ->
+ failwith "Unexpected config request"
+ );
+ []
+
+ | m ->
+ marshal cout ProtocolError;
+ perror "Unexpected message: %s" (msg_to_string m);
+ []
+
+ (***************************************************************)
+
+ let sync_interval = !Settings.recon_sync_interval
+ let sync_tree () =
+ perror "Syncing prefix tree";
+ let txn = new_txnopt () in
+ try
+ PTree.clean txn (get_ptree ());
+ commit_txnopt txn
+ with
+ e ->
+ eplerror 1 e "sync_tree transaction aborting";
+ abort_txnopt txn;
+ raise e
+
+
+ let checkpoint_interval = !Settings.recon_checkpoint_interval
+
+ (***************************************************************)
+
+ let () = Sys.set_signal Sys.sigusr1 Sys.Signal_ignore
+ let () = Sys.set_signal Sys.sigusr2 Sys.Signal_ignore
+
+ (***********************************************************************)
+
+ let prepare () =
+ set_logfile "recon";
+ plerror 1 "sks_recon, SKS version %s" version;
+ plerror 1 "Copyright Yaron Minsky 2002-2003";
+ plerror 1 "Licensed under GPL. See COPYING file for details";
+ plerror 5 "recon port: %d" recon_port;
+
+ init_db settings;
+ init_ptree settings
+
+
+ let run () =
+ prepare ();
+ plerror 4 "Initiating catchup";
+ uninterruptable_catchup ();
+ (* do initial catchup to ensure reconciliation data
+ is synchronized with key database *)
+ plerror 4 "Fetching filters";
+ filters := Some (ReconComm.fetch_filters ());
+ plerror 4 "Starting event loop";
+ Eventloop.evloop
+ ( [ Eventloop.Event (0.0, Eventloop.Callback catchup) ]
+ @ (Ehandlers.repeat_forever_simple catchup_interval catchup)
+ @ (if !Settings.gossip
+ then Ehandlers.repeat_forever
+ ~jitter:0.1 (* 10% randomness in delay interval *)
+ !Settings.gossip_interval
+ (Eventloop.make_tc
+ ~cb:initiate_recon
+ ~name:"recon as client"
+ ~timeout:!Settings.reconciliation_config_timeout
+ )
+ else [] )
+ @ (match settings.treetype with
+ | `transactional ->
+ Ehandlers.repeat_forever_simple checkpoint_interval checkpoint
+ | `ondisk -> Ehandlers.repeat_forever_simple
+ sync_interval sync_tree
+ | `inmem -> []
+ )
+ )
+
+ ( (comsock, Eventloop.make_th
+ ~name:"command handler"
+ ~cb:(eventify_handler command_handler)
+ ~timeout:!Settings.command_timeout
+ )
+ ::
+ (List.map ~f:(fun sock ->
+ (sock, Eventloop.make_th
+ ~name:"reconciliation handler"
+ ~cb:recon_handler
+ ~timeout:!Settings.reconciliation_config_timeout))
+ reconsocks))
+
+
+ (******************************************************************)
+
+ let run () =
+ protect ~f:run
+ ~finally:(fun () ->
+ closedb ();
+ plerror 2 "DB closed"
+ )
+
+end
Added: sks/branches/upstream/sks/current/recoverList.ml
===================================================================
--- sks/branches/upstream/sks/current/recoverList.ml (rev 0)
+++ sks/branches/upstream/sks/current/recoverList.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,98 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Code for managing reconserver's recover list, i.e., the list of keys that
+ need to be recovered from other hosts. *)
+open StdLabels
+open MoreLabels
+open Printf
+open Common
+
+(** Queue of bundles of hashes to be recovered*)
+type recover_element = string list * Unix.sockaddr
+
+let hash_bundle_size = !Settings.http_fetch_size
+let recover_list = (Queue.create () : recover_element Queue.t)
+
+let gossip_disabled_var = ref false
+
+let gossip_disabled () =
+ not (Queue.is_empty recover_list) || !gossip_disabled_var
+let disable_gossip () =
+ plerror 5 "Disabling gossip";
+ gossip_disabled_var := true
+let enable_gossip () =
+ plerror 5 "Enabling gossip";
+ gossip_disabled_var := false
+
+
+(******************************************************)
+
+let rec n_split list n = match (n,list) with
+ (0,_) | (_,[]) -> ([],list)
+ | (_,hd::tl) ->
+ let (first,rest) = n_split tl (n - 1) in
+ (hd::first,rest)
+
+let size_split list size =
+ let rec loop list accum =
+ match n_split list size with
+ | ([],[]) -> List.rev accum
+ | (first,rest) -> loop rest (first::accum)
+ in
+ loop list []
+
+let print_hashes source hashes =
+ if List.length hashes = 0
+ then plerror 4 "No hashes recovered from %s" source
+
+ else if List.length hashes <= 10 then (
+ plerror 3 "%d hashes recovered from %s" (List.length hashes) source;
+ List.iter hashes
+ ~f:(fun hash -> plerror 3 "\t%s" (KeyHash.hexify hash));
+ ) else
+ plerror 3 "%d hashes recovered from %s" (List.length hashes) source
+
+(** converts a list of elements of ZZp to a sorted list of hashes *)
+let hashconvert elements =
+ let hashes = List.rev_map ~f:ZZp.to_bytes elements in
+ let hashes = List.rev_map ~f:(fun hash -> RMisc.truncate hash
+ KeyHash.hash_bytes) hashes in
+ let hashes = List.sort ~cmp:compare hashes in
+ hashes
+
+(** Dumps the hashes associated with the difference set to the named file *)
+let log_diffs log_fname hashes =
+ if !Settings.log_diffs then
+ begin
+ let log_fname = Filename.concat !Settings.basedir log_fname in
+ let file = open_out log_fname in
+ protect ~f:(fun () -> List.iter hashes
+ ~f:(fun h -> fprintf file "%s\n" (KeyHash.hexify h)))
+ ~finally:(fun () -> close_out file)
+ end
+
+let update_recover_list results partner_http_addr =
+ let hashes = hashconvert results in
+ let bundles = size_split hashes hash_bundle_size in
+ List.iter bundles ~f:(fun bundle ->
+ Queue.add (bundle,partner_http_addr)
+ recover_list);
+ if not (Queue.is_empty recover_list) then disable_gossip ()
+
+
+
Added: sks/branches/upstream/sks/current/recvmail.ml
===================================================================
--- sks/branches/upstream/sks/current/recvmail.ml (rev 0)
+++ sks/branches/upstream/sks/current/recvmail.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,93 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Simple (and likely incomplete) interface for receiving mail *)
+
+open Common
+open StdLabels
+open MoreLabels
+open Printf
+module Unix = UnixLabels
+
+let whitespace = Str.regexp "[ \t\n\r]+"
+let eol = Str.regexp "\r?\n"
+
+let parse_header_line hline =
+ if String.length hline = 0
+ then None (* done parsing header *)
+ else
+ if hline.[0] = '\t'
+ then (* this is a continuation, not a new pair *)
+ Some ("",String.sub ~pos:1 ~len:(String.length hline - 1) hline)
+ else
+
+ try
+ let colonpos =
+ try String.index hline ':'
+ with Not_found -> failwith "No colon found"
+ in
+ let key = String.sub hline ~pos:0 ~len:colonpos
+ and data = String.sub hline ~pos:(colonpos+1)
+ ~len:(String.length hline - colonpos - 1)
+ in
+ if String.contains data ' ' then
+ (* then the colon in question wasn't a real line *)
+ Some ("",Wserver.strip hline)
+ else
+ Some (Wserver.strip key, Wserver.strip data)
+
+ with
+ Failure "No colon found" -> Some ("",Wserver.strip hline)
+
+
+
+let rec parse_header lines header = match lines with
+ [] ->
+ (* headers done, no body left *)
+ (List.rev header,[])
+ | hline::tl -> match parse_header_line hline with
+ None -> (List.rev header,tl)
+ | Some pair -> parse_header tl (pair::header)
+
+
+(** Given a list of headers where some entries have no keys listed, returns a
+ list of headers where those keyless entries have been joined into previous
+ entries.
+*)
+let rec simplify_headers headers newheaders =
+ match headers with
+ [] -> List.rev newheaders
+ | ("",data)::header_tl ->
+ (match newheaders with
+ [] -> failwith "simplify_headers: initial header line lacks field"
+ | (key,prevdata)::newheader_tl ->
+ simplify_headers
+ header_tl ((key,prevdata ^ "\n" ^ data)::newheader_tl)
+ )
+ | (key,data)::header_tl ->
+ simplify_headers header_tl ((key,data)::newheaders)
+
+let simplify_headers headers = simplify_headers headers []
+
+let parse msgtext =
+ let lines = Str.split eol msgtext in
+ let (headers,bodylines) = parse_header lines [] in
+ (*let headers = simplify_headers headers in *)
+ { Sendmail.headers = headers;
+ Sendmail.body = String.concat ~sep:"\n" bodylines;
+ }
+
Added: sks/branches/upstream/sks/current/request.ml
===================================================================
--- sks/branches/upstream/sks/current/request.ml (rev 0)
+++ sks/branches/upstream/sks/current/request.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,94 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+open Printf
+open Common
+
+let amp = Str.regexp "&"
+
+let chsplit c s =
+ let eqpos = String.index s c in
+ let first = Str.string_before s eqpos
+ and second = Str.string_after s (eqpos + 1) in
+ (first, second)
+
+let eqsplit s = chsplit '=' s
+
+type request_kind = VIndex | Index | Get | HGet | Stats
+
+type request = { kind: request_kind;
+ search: string list;
+ fingerprint: bool;
+ hash: bool;
+ exact: bool;
+ machine_readable: bool;
+ clean: bool;
+ limit: int;
+ }
+
+let default_request = { kind = Index;
+ search = [];
+ fingerprint = false;
+ hash = false;
+ exact = false;
+ machine_readable = false;
+ clean = true;
+ limit = 0;
+ }
+
+let comma_rxp = Str.regexp ","
+
+let rec request_of_oplist ?(request=default_request) oplist =
+ match oplist with
+ [] -> request
+ | hd::tl ->
+ let new_request =
+ match hd with
+ | ("options",options) ->
+ let options = Str.split comma_rxp options in
+ if List.mem "mr" options
+ then { request with machine_readable = true }
+ else request
+ | ("op","stats") -> {request with kind = Stats };
+ | ("op","x-stats") -> {request with kind = Stats };
+ | ("op","index") -> {request with kind = Index };
+ | ("op","vindex") -> {request with kind = VIndex };
+ | ("op","get") -> {request with kind = Get};
+ | ("op","hget") -> {request with kind = HGet};
+ | ("op","x-hget") -> {request with kind = HGet};
+ | ("limit",c) -> {request with limit = (int_of_string c)};
+ | ("search",s) ->
+ {request with search =
+ List.rev (Utils.extract_words (String.lowercase s))
+ };
+ | ("fingerprint","on") -> {request with fingerprint = true};
+ | ("fingerprint","off") -> {request with fingerprint = false};
+ | ("hash","on") -> {request with hash = true};
+ | ("hash","off") -> {request with hash = false};
+ | ("x-hash","on") -> {request with hash = true};
+ | ("x-hash","off") -> {request with hash = false};
+ | ("exact","on") -> {request with exact = true};
+ | ("exact","off") -> {request with exact = false};
+ | ("clean","on") -> {request with clean = true;}
+ | ("clean","off") -> {request with clean = false;}
+ | ("x-clean","on") -> {request with clean = true;}
+ | ("x-clean","off") -> {request with clean = false;}
+ | _ -> request
+ in
+ request_of_oplist tl ~request:new_request
Added: sks/branches/upstream/sks/current/sStream.ml
===================================================================
--- sks/branches/upstream/sks/current/sStream.ml (rev 0)
+++ sks/branches/upstream/sks/current/sStream.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,46 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** simple stream with 1-step lookahead. *)
+
+type 'b sstream = { mutable first: 'b option;
+ next: unit -> 'b option;
+ }
+
+let make ?first next = { first = first;
+ next = next;
+ }
+
+let next s =
+ match s.first with
+ None -> s.next ()
+ | v ->
+ s.first <- None;
+ v
+
+let peek s =
+ if s.first = None
+ then s.first <- s.next ();
+ s.first
+
+let junk s =
+ if s.first = None
+ then ignore (s.next ())
+ else s.first <- None
+
+
+
Added: sks/branches/upstream/sks/current/sampleConfig/DB_CONFIG
===================================================================
--- sks/branches/upstream/sks/current/sampleConfig/DB_CONFIG (rev 0)
+++ sks/branches/upstream/sks/current/sampleConfig/DB_CONFIG 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,11 @@
+set_mp_mmapsize 268435456
+set_cachesize 0 134217728 1
+set_flags DB_LOG_AUTOREMOVE
+set_lg_regionmax 1048576
+set_lg_max 104857600
+set_lg_bsize 2097152
+set_lk_detect DB_LOCK_DEFAULT
+set_tmp_dir /tmp
+set_lock_timeout 1000
+set_txn_timeout 1000
+mutex_set_max 65536
Added: sks/branches/upstream/sks/current/sampleConfig/aliases.sample
===================================================================
--- sks/branches/upstream/sks/current/sampleConfig/aliases.sample (rev 0)
+++ sks/branches/upstream/sks/current/sampleConfig/aliases.sample 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,7 @@
+# handle incoming keyserver mail. Use one or the oyher of these but NOT both
+# If you define pgp-public-keys to a user, that user must have an appropriate
+# .procmailrc or other forwarding directive in its $HOME, preferrably the same
+# directory as SKS's base_dir
+#
+#pgp-public-keys: "|/usr/bin/sks_add_mail /var/sks/messages"
+#pgp-public-keys: sks
Added: sks/branches/upstream/sks/current/sampleConfig/crontab.sample
===================================================================
--- sks/branches/upstream/sks/current/sampleConfig/crontab.sample (rev 0)
+++ sks/branches/upstream/sks/current/sampleConfig/crontab.sample 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,5 @@
+# SKS stats for sks-keyservers.net @~{10,20}:50 CET
+45 3,13 * * * pkill -USR2 sks || exit 1
+# SKS stats on the hour
+0 * * * * pkill -USR2 sks || exit 1
+
Added: sks/branches/upstream/sks/current/sampleConfig/debian/README
===================================================================
--- sks/branches/upstream/sks/current/sampleConfig/debian/README (rev 0)
+++ sks/branches/upstream/sks/current/sampleConfig/debian/README 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,2 @@
+These are the example configuration files that ship with the debian
+SKS package.
Added: sks/branches/upstream/sks/current/sampleConfig/debian/forward.exim
===================================================================
--- sks/branches/upstream/sks/current/sampleConfig/debian/forward.exim (rev 0)
+++ sks/branches/upstream/sks/current/sampleConfig/debian/forward.exim 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1 @@
+|/usr/bin/procmail
Added: sks/branches/upstream/sks/current/sampleConfig/debian/forward.postfix
===================================================================
--- sks/branches/upstream/sks/current/sampleConfig/debian/forward.postfix (rev 0)
+++ sks/branches/upstream/sks/current/sampleConfig/debian/forward.postfix 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1 @@
+"|exec /usr/bin/procmail"
Added: sks/branches/upstream/sks/current/sampleConfig/debian/mailsync
===================================================================
--- sks/branches/upstream/sks/current/sampleConfig/debian/mailsync (rev 0)
+++ sks/branches/upstream/sks/current/sampleConfig/debian/mailsync 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,16 @@
+# /etc/sks/mailsync
+#
+# The mailsync should contains a list of email addresses of PKS
+# keyservers, one per line. This file is important, because it ensures
+# that keys submitted directly to an SKS keyserver are also forwarded
+# to PKS keyservers.
+#
+# Empty lines and whitespace-only lines are ignored, as are lines
+# whose first non-whitespace character is a `#'.
+#
+# IMPORTANT: don't add someone to your mailsync file without getting
+# their permission first!
+#
+# Jason Harris says that having his keyserver's address in the Debian package
+# is fine.
+#pgp-public-keys at keyserver.kjsl.com
Added: sks/branches/upstream/sks/current/sampleConfig/debian/membership
===================================================================
--- sks/branches/upstream/sks/current/sampleConfig/debian/membership (rev 0)
+++ sks/branches/upstream/sks/current/sampleConfig/debian/membership 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,13 @@
+# /etc/sks/membership
+#
+# With SKS, two hosts can efficiently compare their databases then
+# repair whatever differences are found. In order to set up
+# reconciliation, you first need to find other SKS servers that will
+# agree to gossip with you. The hostname and port of the server that
+# has agreed to do so should be added to this file.
+#
+# Empty lines and whitespace-only lines are ignored, as are lines
+# whose first non-whitespace character is a `#'.
+#
+# Example:
+# keyserver.linux.it 11370
Added: sks/branches/upstream/sks/current/sampleConfig/debian/procmail
===================================================================
--- sks/branches/upstream/sks/current/sampleConfig/debian/procmail (rev 0)
+++ sks/branches/upstream/sks/current/sampleConfig/debian/procmail 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,3 @@
+:0
+* ^Subject: *(incremental|add)
+| /usr/lib/sks/sks_add_mail /var/spool/sks
Added: sks/branches/upstream/sks/current/sampleConfig/debian/sksconf
===================================================================
--- sks/branches/upstream/sks/current/sampleConfig/debian/sksconf (rev 0)
+++ sks/branches/upstream/sks/current/sampleConfig/debian/sksconf 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,32 @@
+# /etc/sks/sksconf
+#
+# The configuration file for your SKS server.
+# You can find more options in sks(8) manpage.
+
+# Set server hostname
+#hostname: this.server.fdqn
+
+# Set recon binding address
+#recon_address: 0.0.0.0
+
+# Set recon port number
+#recon_port: 11370
+
+# Set hkp binding address
+#hkp_address: 0.0.0.0
+
+# Set hkp port number
+#hkp_port: 11371
+
+# Have the HKP interface listen on port 80, as well as the hkp_port
+#use_port_80:
+
+# From address used in synchronization emails used to communicate with PKS
+#from_addr: "PGP Key Server Administrator <pgp-public-keys at this.server.fdqn>"
+
+# Command used for sending mail (you can use -f option to specify the
+# envelope sender address, if your MTA trusts the sks user)
+#sendmail_cmd: /usr/lib/sendmail -t -oi
+
+# Runs database statistics calculation on boot (time and cpu expensive)
+#initial_stat:
Added: sks/branches/upstream/sks/current/sampleConfig/mailsync
===================================================================
--- sks/branches/upstream/sks/current/sampleConfig/mailsync (rev 0)
+++ sks/branches/upstream/sks/current/sampleConfig/mailsync 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,21 @@
+# mailsync
+#
+# The mailsync should contains a list of email addresses of PKS
+# keyservers, one per line. This file is important, because it ensures
+# that keys submitted directly to an SKS keyserver are also forwarded
+# to PKS keyservers.
+#
+# Empty lines and whitespace-only lines are ignored, as are lines
+# whose first non-whitespace character is a `#'.
+#
+# IMPORTANT: don't add someone to your mailsync file without getting
+# their permission first!
+#
+# Hironobu Suzuki operates the OpenPKSD server <suzuki.hironobu at gmail.com>
+#pgp-public-keys at pgp.nic.ad.jp
+#
+# Jonathon McDowell openrates the ONAK server <noodles at earth.li>
+# http://www.earth.li/projectpurple/progs/onak.html
+#pgp-public-keys at the.earth.li
+#
+# V. Alex Brennen operates the CKS (CrytptNet) servers <vab at cryptnet.net>
Added: sks/branches/upstream/sks/current/sampleConfig/membership
===================================================================
--- sks/branches/upstream/sks/current/sampleConfig/membership (rev 0)
+++ sks/branches/upstream/sks/current/sampleConfig/membership 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,25 @@
+# membership
+#
+# With SKS, two hosts can efficiently compare their databases then
+# repair whatever differences are found. In order to set up
+# reconciliation, you first need to find other SKS servers that will
+# agree to gossip with you. The hostname and port of the server that
+# has agreed to do so should be added to this file.
+#
+# Empty lines and whitespace-only lines are ignored, as are lines
+# whose first non-whitespace character is a `#'. Comments preceded by '#'
+# are allowed at the ends of lines
+#
+# Example:
+# keyserver.linux.it 11370
+#
+# The following operators have agreed to have their peering info included in this sample file.
+# NOTE: This does NOT mean you may uncomment the lines and have peers. First you must contact the
+# server owner and ask permission. You should include a line styled like these for your own server.
+# Until two SKS membership files contain eact others peering info, they will not gossip.
+#
+#yourserver.example.net 11370 # Your full name <emailaddress for admin purposes> 0xPreferrefPGPkey
+#keyserver.gingerbear.net 11370 # John P. Clizbe <John at Gingerbear.net> 0xD6569825
+#sks.keyservers.net 11370 # John P. Clizbe <John at Gingerbear.net> 0xD6569825
+#keyserver.rainydayz.org 11370 # Andy Ruddock <andy.ruddock at rainydayz.org> 0xEEC3AFB3
+#keyserver.computer42.org 11370 # H.-Dirk Schmitt <dirk at computer42.org> 0x6A017B17
Added: sks/branches/upstream/sks/current/sampleConfig/procmailrc
===================================================================
--- sks/branches/upstream/sks/current/sampleConfig/procmailrc (rev 0)
+++ sks/branches/upstream/sks/current/sampleConfig/procmailrc 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,27 @@
+#!/usr/bin/procmail
+#
+# <user> - .procmailrc
+
+# Environment
+SHELL=/bin/bash
+UMASK=0177
+LINEBUF=4096
+LOGFILE=/var/log/procmail.log
+VERBOSE=off
+DEFAULT=/dev/null
+PATH=/usr/bin
+
+# Bounce and loop detection
+:0
+* ^FROM_DAEMON
+* ^X-Loop:.*pgp-public-keys at gingerbear.net
+$DEFAULT
+
+# Handle your keysync mails (optional)
+:0
+* ^Subject.*incremental
+| /usr/bin/sks_add_mail /var/sks/
+
+# Anything leftover
+:0
+$DEFAULT
Added: sks/branches/upstream/sks/current/sampleConfig/rc.sks
===================================================================
--- sks/branches/upstream/sks/current/sampleConfig/rc.sks (rev 0)
+++ sks/branches/upstream/sks/current/sampleConfig/rc.sks 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,39 @@
+#! /bin/sh
+#
+CLIENT=/usr/bin/sks
+DIR=/var/sks
+STARTOPTS=
+#STARTOPTS will need to be in quotes if it has white space in it
+
+test -e $CLIENT || exit 0
+
+test -d $DIR || exit 0
+
+case "$1" in
+ start)
+ cd $DIR
+ echo -n "Starting SKS:"
+ echo -n \ sks_db
+ $CLIENT db &
+ echo -n \ sks_recon
+ $CLIENT recon &
+ echo "."
+ ;;
+ stop)
+ echo -n "Stopping SKS:"
+ killall sks
+ while [ "`pidof sks`" ]; do sleep 1; done # wait until SKS processes have exited
+ echo "."
+ ;;
+ restart|force-reload)
+ $0 stop
+ sleep 1
+ $0 start
+ ;;
+ *)
+ echo "Usage: $0 {start|stop|reload|restart|force-reload}"
+ exit 1
+ ;;
+esac
+
+exit 0
Property changes on: sks/branches/upstream/sks/current/sampleConfig/rc.sks
___________________________________________________________________
Added: svn:executable
+ *
Added: sks/branches/upstream/sks/current/sampleConfig/sksconf.minimal
===================================================================
--- sks/branches/upstream/sks/current/sampleConfig/sksconf.minimal (rev 0)
+++ sks/branches/upstream/sks/current/sampleConfig/sksconf.minimal 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,12 @@
+# sksconf sample for keyserver.foo.bar
+# ------------------------------------
+# Set the logfile to $basedir/log[.db|.recon]
+logfile: log
+
+# debuglevel 4 is default (max. debuglevel is 10)
+debuglevel: 4
+
+# set the hostname of your server
+hostname: keyserver.foo.bar
+
+# EOF
Added: sks/branches/upstream/sks/current/sampleConfig/sksconf.typical
===================================================================
--- sks/branches/upstream/sks/current/sampleConfig/sksconf.typical (rev 0)
+++ sks/branches/upstream/sks/current/sampleConfig/sksconf.typical 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,17 @@
+# sksconf -- SKS main configuration
+#
+basedir: /var/sks
+
+# debuglevel 4 is default (max. debuglevel is 10)
+debuglevel: 5
+
+hostname: keyserver.example.tld
+hkp_port: 11371
+recon_port: 11370
+#
+from_addr: pgp-public-keys at example.tld
+sendmail_cmd: /usr/sbin/sendmail -t -oi
+#
+initial_stat:
+membership_reload_interval: 1
+stat_hour: 17
Added: sks/branches/upstream/sks/current/sampleWeb/HTML5/README
===================================================================
--- sks/branches/upstream/sks/current/sampleWeb/HTML5/README (rev 0)
+++ sks/branches/upstream/sks/current/sampleWeb/HTML5/README 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,12 @@
+This is just a prettified index.html in HTML5.
+
+It uses elements of HTML5 boilerplate 1.0
+
+The link to SKS points to the code.google.com
+
+The submission links are relative to minimize having to search and replace
+on installation.
+
+Comments welcome.
+
+Submitted by samir at samirnassar.com.
Added: sks/branches/upstream/sks/current/sampleWeb/HTML5/index.html
===================================================================
--- sks/branches/upstream/sks/current/sampleWeb/HTML5/index.html (rev 0)
+++ sks/branches/upstream/sks/current/sampleWeb/HTML5/index.html 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,161 @@
+<!DOCTYPE html>
+<html lang="en">
+ <head>
+ <meta http-equiv="content-type" content="text/html; charset=UTF-8">
+ <meta http-equiv="X-UA-Compatible" content="IE=edge,chrome=1">
+ <title>SKS key server at YOURDOMAIN</title>
+ <meta name="description" content="">
+ <meta name="author" content="">
+ <!-- Mobile viewport optimized: j.mp/bplateviewport -->
+ <meta name="viewport" content="width=device-width, initial-scale=1.0">
+ <style type="text/css">
+ h1,
+ h2,
+ p {
+ margin: 0; /* Let's zero those margins */
+ }
+
+ #container {
+ border: 1px solid #555; /* Nice transition from white background */
+ width: 600px; /* Should be narrow enough for small screens */
+ margin: 0 auto; /* Centering */
+ font-size: 1.1em; /* Font big enough not to need to squint */
+ line-height: 1.3em;
+ }
+
+ #title {
+ background-color:#e2e5e2;
+ padding: 10px;
+ }
+
+ #title h1, #title h2 {
+ margin-top: 0.3em;
+ }
+
+ #info {
+ background-color:#e2e5e2;
+ padding: 5px 10px;
+ }
+
+ #main {
+ background : #FAFBEA;
+ padding: 0 10px 10px 10px;
+ }
+
+ #main header {
+ padding-top: 1em;
+ }
+
+ #main p {
+ margin: 0.5em 0;
+ }
+
+ #keytext {
+ width: 100%;
+ height: 150px;
+ border: 1px solid #555;
+ background : #fff;
+ max-width: 100%;
+ display: block;
+ }
+
+ ul {
+ width: 100%;
+ list-style-type: none;
+ padding-left: 0;
+ }
+
+ li {
+ width: 99%;
+ }
+
+ li label {
+ width: 57%;
+ display: inline-block;
+ }
+
+ button {
+ border-radius: 3px;
+ -moz-border-radius: 3px;
+ background: -webkit-gradient(linear, left top, left bottom, from(#fff), to(#ddd));
+ background: -moz-linear-gradient(top, #fff, #ddd);
+ border: 1px solid #bbb;
+ }
+
+ #info p {line-height: 1.1em; margin-bottom: 0.3em;}
+ </style>
+ </head>
+ <body>
+ <div id="container">
+ <header id="title">
+ <hgroup>
+ <h1>SKS OpenPGP Key server</h1>
+ <h2>YOURDOMAIN</h2>
+ </hgroup>
+ </header>
+ <div id="main" role="main">
+ <header>
+ <h2>Extract a key</h2>
+ </header>
+ <p>You can find a key by typing in some words that appear in the
+ userid (name, email, etc.) of the key you're looking for, or
+ by typing in the keyid in hex format ("0x…")</p>
+ <form id="lookup" action="/pks/lookup" method="get">
+ <fieldset checked="true"> <legend>Search for a public key</legend>
+ <ul>
+ <li> <label for="search">String</label> <input id="search"
+ name="search" placeholder="0xDEADBEEF" required="" autofocus=""
+ type="text"> </li>
+ <li> <label for="fingerprint">Show PGP Fingerprints</label>
+ <input id="fingerprint" name="fingerprint" type="checkbox">
+ </li>
+ <li> <label for="hash">Show SKS full-key hashes</label> <input
+ id="hash" name="hash" type="checkbox"> </li>
+ <li> <label for="matching">Get regular index of matching
+ keys</label> <input id="matching" name="op" value="index"
+ type="radio"> </li>
+ <li> <label for="verbose">Get verbose index of matching
+ keys</label> <input id="verbose" name="op" value="vindex"
+ checked="checked" type="radio"> </li>
+ <li> <label for="asciiarmored">Retrieve ascii-armored
+ keys</label> <input id="asciiarmored" name="op" value="get"
+ type="radio"> </li>
+ <li> <label for="fullkey">Retrieve keys by full-key hash</label>
+ <input id="fullkey" name="op" value="hget" type="radio">
+ </li>
+ </ul>
+ <button type="reset">Reset</button> <button type="submit">Search
+
+
+
+
+
+
+ for a key</button> </fieldset>
+ </form>
+ <header>
+ <h2>Submit a key</h2>
+ </header>
+ <p>You can submit a key by simply pasting in the ASCII-armored
+ version of your key and clicking on submit.</p>
+ <form id="add" action="/pks/add" method="post">
+ <fieldset> <textarea id="keytext" name="keytext" rows="5" cols="30"></textarea>
+ <button type="reset">Reset</button> <button checked="true"
+ type="submit">Submit this key</button></fieldset>
+ </form>
+ </div>
+ <!-- end of #main -->
+ <footer id="info">
+ <p><a href="https://code.google.com/p/sks-keyserver/">SKS</a> is
+ a new <a href="http://www.openpgp.org/">OpenPGP</a>
+ keyserver. The main innovation of SKS is that it includes a
+ highly-efficient reconciliation algorithm for keeping the
+ keyservers synchronized.</p>
+ <p style="text-align: center;"><a href="/pks/lookup?op=stats">SKS
+
+ statistics</a></p>
+ </footer>
+ </div>
+ <!--! end of #container -->
+ </body>
+</html>
Added: sks/branches/upstream/sks/current/sampleWeb/HTML5/robots.txt
===================================================================
--- sks/branches/upstream/sks/current/sampleWeb/HTML5/robots.txt (rev 0)
+++ sks/branches/upstream/sks/current/sampleWeb/HTML5/robots.txt 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,2 @@
+User-agent: *
+Disallow: /
Added: sks/branches/upstream/sks/current/sampleWeb/OpenPKG/README
===================================================================
--- sks/branches/upstream/sks/current/sampleWeb/OpenPKG/README (rev 0)
+++ sks/branches/upstream/sks/current/sampleWeb/OpenPKG/README 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,4 @@
+I found this one day surfing. It from the OpenPKG RPM Package Specification
+Copyright (c) 2000-2008 OpenPKG Foundation e.V. <http://openpkg.net/>
+
+It is considerably barebones
Added: sks/branches/upstream/sks/current/sampleWeb/OpenPKG/index.html
===================================================================
--- sks/branches/upstream/sks/current/sampleWeb/OpenPKG/index.html (rev 0)
+++ sks/branches/upstream/sks/current/sampleWeb/OpenPKG/index.html 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,52 @@
+<?xml version="1.0"?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+ <head>
+ <title>SKS OpenPGP Public Key Server</title>
+ </head>
+ <body>
+ <h1>SKS OpenPGP Public Key Server</h1>
+ <hr />
+ <h2>
+ <a id="extract" name="extract">Extracting a OpenPGP Key</a>
+ </h2>
+ <form action="/pks/lookup" method="get">
+ <p>Index:
+ <input type="radio" name="op" value="index" />
+ Verbose Index:
+ <input type="radio" name="op" value="vindex" checked="checked" />
+ </p>
+ <p>Search String:
+ <input name="search" size="40" value="openpkg" />
+ </p>
+ <p>
+ <input type="checkbox" name="fingerprint" checked="checked" />
+ Show OpenPGP "fingerprints" for keys</p>
+ <p>
+ <input type="checkbox" name="exact" />
+ Only return exact matches</p>
+ <p>
+ <input type="reset" value="Reset" />
+
+ <input type="submit" value="Search!" />
+ </p>
+ </form>
+ <hr />
+ <h2>
+ <a id="submit" name="submit">Submitting a new OpenPGP Key</a>
+ </h2>
+ <form action="/pks/add" method="post">
+ <p>Enter ASCII-armored OpenPGP key here:</p>
+ <p>
+ <textarea name="keytext" rows="20" cols="66"></textarea>
+ </p>
+ <p>
+ <input type="reset" value="Reset" />
+
+ <input type="submit" value="Submit!" />
+ </p>
+ </form>
+ <hr />
+ </body>
+</html>
Added: sks/branches/upstream/sks/current/sampleWeb/OpenPKG/robots.txt
===================================================================
--- sks/branches/upstream/sks/current/sampleWeb/OpenPKG/robots.txt (rev 0)
+++ sks/branches/upstream/sks/current/sampleWeb/OpenPKG/robots.txt 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,2 @@
+User-agent: *
+Disallow: /
Added: sks/branches/upstream/sks/current/sampleWeb/XHTML+ES/README
===================================================================
--- sks/branches/upstream/sks/current/sampleWeb/XHTML+ES/README (rev 0)
+++ sks/branches/upstream/sks/current/sampleWeb/XHTML+ES/README 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,37 @@
+Christoph Anton Mitterer <mail at christoph.anton.mitterer.name>
+XHTML w/ ECMAscript/Javascript
+This was issue #9 on the GoogleCode page.
+
+Notes from submission
+
+Reported by calestyo, Oct 25, 2010
+
+As far as I can see the source tar-ball does currently not ship a default index website, which would make some sense IMHO, so that fresh installations have one and in order that people have a starting point on how to create their own (if they want).
+
+The attached index.xhtml would be one with the following "features":
+- valid XHTML 1.1, CSS 2.1
+ therefore depending on issue #6 (http://code.google.com/p/sks-keyserver/issues/detail?id=6)
+- tries to use clean and structured HTML as it's indented, no fancy graphics etc.
+- seems to be quite viewable in both graphical and textual browsers
+- uses little CMS and simple JavaScript for better "look and feel", both are however not necessary (e.g. if not implemented by the user agent).
+- scripts are in a seperate files, to allow user agents not supporting them to not load them at all
+
+Todos:
+- scripts.txt should be named scripts.es (once issue #6 is resolved)
+- the commented part is indented to be adapted by the sysadmin to their respectvie site... a note on this should be perhaps added to the readme or so.
+- are there further Options/etc. that sks would understand?!
+
+
+Change and/or drop the license notes as you like.
+
+Hope you like,
+Chris.
+
+Comment 2 by calestyo, Oct 31, 2010
+
+New versions of the files, adding support for "options=mr", which is however disabled for "op=get" as it's not yet implemented there (see issue #12).
+
+"exact=on" is not in the website, as it seems to be ignored in sks. The same with "options=nm".
+
+"clean=on" is not yet in, as I don't understand what it does.
+
Added: sks/branches/upstream/sks/current/sampleWeb/XHTML+ES/index.xhtml
===================================================================
--- sks/branches/upstream/sks/current/sampleWeb/XHTML+ES/index.xhtml (rev 0)
+++ sks/branches/upstream/sks/current/sampleWeb/XHTML+ES/index.xhtml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,138 @@
+<?xml version="1.1" encoding="UTF-8"?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en">
+
+
+
+
+<head>
+ <title>scientia.net OpenPGP Keyserver</title>
+
+ <meta http-equiv="Content-Style-Type" content="text/css"/>
+ <meta http-equiv="Content-Script-Type" content="application/ecmascript"/>
+
+ <script src="script.es" type="application/ecmascript" defer="defer"/></script>
+</head>
+
+
+
+
+<body>
+ <h1>scientia.net OpenPGP Keyserver</h1>
+ <p>
+ Welcome to <a href="http://scientia.net/" title="scientia.net">scientia.net</a>'s OpenPGP Keyserver service at "<a href="/" title="scientia.net OpenPGP Keyserver">keyserver.pki.scientia.net</a>".
+ </p>
+ <p>
+ In case of questions or problems please contact "<a href="mailto:root at keyserver.pki.scientia.net" title="scientia.net OpenPGP Keyserver Administrator">root at keyserver.pki.scientia.net</a>".
+ </p>
+
+
+ <h2><a id="search">Search</a></h2>
+ <form action="/pks/lookup" method="get">
+ <p>
+ Search for keys:<br/>
+ <span>
+ <input type="text" name="search" size="80" style="width: 100%; font-family: monospace;"/><br/>
+ <input type="submit" value="Search"/><input type="reset" value="Clear Form" style="float: right;"/>
+ </span>
+ </p>
+ <p>
+ Options:<br/>
+ <span>
+ <input type="radio" name="op" value="index" checked="checked" onchange="search_options_change();"/> generate normal key listing<br/>
+ <input type="radio" name="op" value="vindex" onchange="search_options_change();"/> generate verbose key listing<br/>
+ <input type="radio" name="op" value="get" onchange="search_options_change();"/> generate an "<a href="http://tools.ietf.org/html/rfc4880" title="RFC 4880 ("OpenPGP Message Format")">OpenPGP Message</a>" in the <a href="http://tools.ietf.org/html/rfc4880#section-6" title="RFC 4880 ("OpenPGP Message Format") - 6. Radix-64 Conversions">"Radix-64" (also known as "ASCII armor") format</a> containing the keys (<a id="radio-button_hget"><input type="radio" name="op" value="hget" onchange="search_options_change();"/></a> by searching for "SKS full key hashes")<br/>
+ <span id="modifier_fingerprint"><input type="checkbox" name="fingerprint" value="on" checked="checked" style="margin-top: 1em;"/> display <a href="http://tools.ietf.org/html/rfc4880#section-12.2" title="RFC 4880 ("OpenPGP Message Format") - 12.2. Key IDs and Fingerprints">Key Fingerprints</a><br/></span>
+ <span id="modifier_hash"><input type="checkbox" name="hash" value="on"/> display "SKS full key hashes"<br/></span>
+ <span id="modifier_options_mr"><input type="checkbox" name="options" value="mr"/> use <a href="http://tools.ietf.org/html/draft-shaw-openpgp-hkp-00#section-5.1" title="Internet-Draft ("The OpenPGP HTTP Keyserver Protocol (HKP)") - 5.1. Machine Readable Output">machine readable format</a></span>
+ </span>
+ </p>
+ <p>
+ Examples:<br/>
+ </p>
+ <ul>
+ <li>User IDs<br/>
+ Searching the keys' <a href="http://tools.ietf.org/html/rfc4880#section-5.11" title="RFC 4880 ("OpenPGP Message Format") - 5.11. User ID Packet (Tag 13)">User IDs</a> for any string, usually <a href="http://en.wikipedia.org/wiki/Personal_name" title="Wikipedia - Personal name">personal names</a> like "<samp>Pierre de Fermat</samp>", <a href="http://en.wikipedia.org/wiki/Email_address" title="Wikipedia - Email address">email addresses</a> "<samp>pierre at de-fermat.example</samp>" or so called "<a href="http://tools.ietf.org/html/rfc5322#section-3.4" title="RFC 5322 ("Internet Message Format") - 3.4. Address Specification">name-addrs</a>" like "<samp>Pierre de Fermat <pierre at de-fermat.example></samp>".
+ </li>
+ <li>Key Fingerprints and Key IDs<br/>
+ Searching for <a href="http://tools.ietf.org/html/rfc4880#section-12.2" title="RFC 4880 ("OpenPGP Message Format") - 12.2. Key IDs and Fingerprints">Key Fingerprints</a> like "<samp>0x0123456789ABCDEF0123456789ABCDEF01234567</samp>" (version 4) or "<samp>0x89ABCDEF0123456789ABCDEF01234567</samp>" (version 3) and <a href="http://tools.ietf.org/html/rfc4880#section-3.3" title="RFC 4880 ("OpenPGP Message Format") - 3.3. Key IDs">Key IDs</a> like "<samp>0x89ABCDEF01234567</samp>" (so called "short Key IDs" like "<samp>0x01234567</samp>" can be used, too).
+ </li>
+ <li>"SKS full key hashes"<br/>
+ Searching for "SKS full key hashes" like "<samp>0123456789ABCDEF0123456789ABCDEF</samp>".<br/>
+ For this the respective option must be selected <a href="#radio-button_hget">above</a>.
+ </li>
+ </ul>
+ </form>
+
+
+ <h2><a id="submission">Submission</a> And <a id="publication">Publication</a></h2>
+ <form action="/pks/add" method="post">
+ <p>
+ Notes:
+ </p>
+ <ul>
+ <li>The keys must be presented as an "<a href="http://tools.ietf.org/html/rfc4880" title="RFC 4880 ("OpenPGP Message Format")">OpenPGP Message</a>" in the <a href="http://tools.ietf.org/html/rfc4880#section-6" title="RFC 4880 ("OpenPGP Message Format") - 6. Radix-64 Conversions">"Radix-64" (also known as "ASCII armor") format</a>.</li>
+ <li>This keyserver is part of the "<a href="http://sks-keyservers.net/" title="Unofficial "SKS Keyserver Network" Website">SKS Keyserver Network</a>" and therefore ultimately <em>fully synchronised with all of its other keyservers</em>.</li>
+ <li>Submitted keys are going to be <em>published immediately</em>, which means that all their data (including the cryptographic material, <a href="http://tools.ietf.org/html/rfc4880#section-5.11" title="RFC 4880 ("OpenPGP Message Format") - 5.11. User ID Packet (Tag 13)">User IDs</a>, <a href="http://tools.ietf.org/html/rfc4880#section-5.12" title="RFC 4880 ("OpenPGP Message Format") - 5.12. User Attribute Packet (Tag 17)">User Attributes</a>, <a href="http://tools.ietf.org/html/rfc4880#section-5.2.1" title="RFC 4880 ("OpenPGP Message Format") - 5.2.1. Signature Types">certification signatures</a>, et cetera) becomes publicly available and that personal information and even social connections may be revealed.</li>
+ <li><strong>Published keys cannot be removed</strong> for security and technical reasons, neither from this keyserver nor from the "<a href="http://sks-keyservers.net/" title="Unofficial "SKS Keyserver Network" Website">SKS Keyserver Network</a>".</li>
+ </ul>
+ <p>
+ Submit and publish keys:<br/>
+ <span>
+ <textarea name="keytext" cols="80" rows="10" style="width: 100%; height: 10em; font-family: monospace;"/></textarea><br/>
+ <input type="submit" value="Submit / Publish"/><input type="reset" value="Clear Form" style="float: right;"/>
+ </span>
+ </p>
+ </form>
+
+
+ <h2><a id="status">Status</a></h2>
+ <p>
+ The <a href="/pks/lookup?op=stats">status page</a> contains miscellaneous information about the keyserver, including its general settings, its peers and statistics.
+ </p>
+
+
+ <hr/>
+ <p>
+ <a href="http://validator.w3.org/check?uri=referer"><object data="http://www.w3.org/Icons/valid-xml11-v.svg" type="image/svg+xml" style="width:5em; height:100%;"><p>Valid XML 1.1</p></object></a>
+ <a href="http://validator.w3.org/check?uri=referer"><object data="http://www.w3.org/Icons/valid-xhtml11-v.svg" type="image/svg+xml" style="width:5em; height:100%;"><p>Valid XHTML 1.1</p></object></a>
+ <a href="http://jigsaw.w3.org/css-validator/check/referer"><object data="http://www.w3.org/Icons/valid-css-v.svg" type="image/svg+xml" style="width:5em; height:100%;"><p>Valid CSS</p></object></a>
+ </p>
+</body>
+
+
+
+
+</html>
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+<!--
+Copyright © 2010, Christoph Anton Mitterer <mail at christoph.anton.mitterer.name>.
+All rights reserved.
+
+
+This work is licensed under the Creative Commons Attribution-ShareAlike 3.0
+Unported License. To view a copy of this license, visit
+http://creativecommons.org/licenses/by-sa/3.0/ or send a letter to Creative
+Commons, 171 Second Street, Suite 300, San Francisco, California, 94105, USA.
+
+Permission is granted to copy, distribute and/or modify this document under the
+terms of the GNU Free Documentation License, Version 1.3 or any later version
+published by the Free Software Foundation; with no Invariant Sections, no Front-
+Cover Texts, and no Back-Cover Texts. A copy of the license is included in the
+section entitled "GNU Free Documentation License".
+-->
Added: sks/branches/upstream/sks/current/sampleWeb/XHTML+ES/robots.txt
===================================================================
--- sks/branches/upstream/sks/current/sampleWeb/XHTML+ES/robots.txt (rev 0)
+++ sks/branches/upstream/sks/current/sampleWeb/XHTML+ES/robots.txt 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,2 @@
+User-agent: *
+Disallow: /
Added: sks/branches/upstream/sks/current/sampleWeb/XHTML+ES/script.es
===================================================================
--- sks/branches/upstream/sks/current/sampleWeb/XHTML+ES/script.es (rev 0)
+++ sks/branches/upstream/sks/current/sampleWeb/XHTML+ES/script.es 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,88 @@
+function search_options_change()
+{
+ var op = "";
+ for (var i = 0; i < document.getElementsByName("op").length; ++i)
+ if (document.getElementsByName("op")[i].checked)
+ {
+ op = document.getElementsByName("op")[i].value;
+ break;
+ }
+
+
+ switch (op)
+ {
+ case "index":
+ document.getElementById("modifier_fingerprint").style.visibility = "visible";
+ document.getElementById("modifier_hash").style.visibility = "visible";
+ document.getElementById("modifier_options_mr").style.visibility = "visible";
+ document.getElementById("modifier_fingerprint").disabled = false;
+ document.getElementById("modifier_hash").disabled = false;
+ document.getElementById("modifier_options_mr").disabled = false;
+ break;
+
+ case "vindex":
+ document.getElementById("modifier_fingerprint").style.visibility = "visible";
+ document.getElementById("modifier_hash").style.visibility = "visible";
+ document.getElementById("modifier_options_mr").style.visibility = "hidden";
+ document.getElementById("modifier_fingerprint").disabled = false;
+ document.getElementById("modifier_hash").disabled = false;
+ document.getElementById("modifier_options_mr").disabled = true;
+ break;
+
+ case "get":
+ document.getElementById("modifier_fingerprint").style.visibility = "hidden";
+ document.getElementById("modifier_hash").style.visibility = "hidden";
+ document.getElementById("modifier_options_mr").style.visibility = "hidden";
+ document.getElementById("modifier_fingerprint").disabled = true;
+ document.getElementById("modifier_hash").disabled = true;
+ document.getElementById("modifier_options_mr").disabled = true;
+ break;
+
+ case "hget":
+ document.getElementById("modifier_fingerprint").style.visibility = "hidden";
+ document.getElementById("modifier_hash").style.visibility = "hidden";
+ document.getElementById("modifier_options_mr").style.visibility = "hidden";
+ document.getElementById("modifier_fingerprint").disabled = true;
+ document.getElementById("modifier_hash").disabled = true;
+ document.getElementById("modifier_options_mr").disabled = true;
+ break;
+ }
+}
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+//Copyright © 2010, Christoph Anton Mitterer <mail at christoph.anton.mitterer.name>.
+//All rights reserved.
+//
+//
+//This work is licensed under the Creative Commons Attribution-ShareAlike 3.0
+//Unported License. To view a copy of this license, visit
+//http://creativecommons.org/licenses/by-sa/3.0/ or send a letter to Creative
+//Commons, 171 Second Street, Suite 300, San Francisco, California, 94105, USA.
+//
+//
+//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 3 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, see <http://www.gnu.org/licenses/>.
Added: sks/branches/upstream/sks/current/script.ml
===================================================================
--- sks/branches/upstream/sks/current/script.ml (rev 0)
+++ sks/branches/upstream/sks/current/script.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,382 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+#directory "bdb";;
+
+open Common
+open StdLabels
+open MoreLabels
+open Printf
+open Bdb
+open DbMessages
+open Tester
+open UnixLabels
+
+module Map = PMap.Map
+module Set = PSet.Set
+
+let rec last list = match list with
+ [x] -> x
+ | hd::tl -> last tl
+ | [] -> raise Not_found
+
+let d1 = ADDR_UNIX "/usr/share/keyfiles/sks_wan/db_com_sock"
+let r1 = ADDR_UNIX "/usr/share/keyfiles/sks_wan/recon_com_sock"
+let h1 = ADDR_INET (inet_addr_any, 11371)
+let h2 = ADDR_INET (inet_addr_of_string "128.84.154.32", 11371)
+
+let get_hashes n =
+ let logresp = send_msg r1 (LogQuery (n,0.)) in
+ match logresp.msg with
+ | LogResp loglist ->
+ List.map loglist
+ ~f:(function (t, Add hash) -> hash
+ | (t,Delete hash) -> hash)
+ | _ -> failwith "Expected LogResp"
+
+
+let is_content_type line =
+ try
+ let colonpos = String.index line ':' in
+ let prefix = String.sub ~pos:0 ~len:colonpos line in
+ String.lowercase prefix = "content-type"
+ with
+ Not_found -> false
+
+let get_keystrings_via_http addr hashes =
+ let s = Unix.socket
+ ~domain:(Unix.domain_of_sockaddr addr)
+ ~kind:Unix.SOCK_STREAM
+ ~protocol:0 in
+ let () = Unix.connect s ~addr in
+ let cin = Channel.sys_in_from_fd s
+ and cout = Channel.sys_out_from_fd s in
+
+ let sout = Channel.new_buffer_outc 0 in
+ CMarshal.marshal_list ~f:CMarshal.marshal_string sout hashes;
+ let msg = sout#contents in
+ cout#write_string "POST /pks/hashquery HTTP/1.0\r\n";
+ cout#write_string (sprintf "content-length: %d\r\n\r\n"
+ (String.length msg));
+ cout#write_string msg;
+ cout#flush;
+ while
+ not (is_content_type (input_line cin#inchan))
+ do () done;
+ ignore (input_line cin#inchan);
+ CMarshal.unmarshal_list ~f:CMarshal.unmarshal_string cin
+
+let get_keys addr hashes =
+ List.map ~f:Key.of_string
+ (get_keystrings_via_http addr (List.map ~f:KeyHash.dehexify hashes))
+
+
+let test addr hashes =
+ let s = Unix.socket
+ ~domain:(Unix.domain_of_sockaddr addr)
+ ~kind:Unix.SOCK_STREAM
+ ~protocol:0 in
+ let () = Unix.connect s ~addr in
+ let cin = Channel.sys_in_from_fd s
+ and cout = Channel.sys_out_from_fd s in
+
+ let sout = Channel.new_buffer_outc 0 in
+ CMarshal.marshal_list ~f:CMarshal.marshal_string sout hashes;
+ let msg = sout#contents in
+ cout#write_string "POST /pks/hashquery HTTP/1.0\r\n";
+ cout#write_string (sprintf "content-length: %d\r\n\r\n"
+ (String.length msg));
+ cout#write_string msg;
+ cout#flush;
+ cin
+
+
+
+let hset1 = ["073AF736308A85A347C63EFFC9A99482";
+ "09B4D190A6B30F86E5EFC38F0FBA2DAE";
+ "0F83854955688FF6415A624B830B4DA4";
+ "102D133A801CC5B52B17AEF4D566AD93";
+ "109E9FFE31DD96BF8160CAB75594142D";
+ "113E1742AAB522E92C2DB2491D1019D3";
+ "1523B10A2C837F485CA4B9DF5321273A";
+ "1ABD8F55A164E1E88B3C1F80F515F8E0";
+ "1F034745CEF1BCB330274C950000F765";
+ "21FCA6558FE593756B7E3F0673278CEB";
+ "2223F2D7C102D79EFA575C5747A8A931";
+ "254FC421BEAA8B380F833FC28D1BE2A1";
+ "27B64D0F9CE17F608895F46AACD5BFF4";
+ "299177B9E6B46802C14FD789F9A0C294";
+ "2A521C6C82DE9FCD177B7EF9BBDCF100";
+ "2ADE12449A0F2836ED6BD545EE75F2B8";
+ "2AFF1B924E0397DCEE2E6ED5374219AB";
+ "2BC734A43386B963F209F92B02DAA842";
+ "2D6502F1D540C41D42CB4CB354C2773B";
+ "2DB0521237286FEDAF6E239B7C0F6BA1";
+ "2E192990A82C5055141882EE37B4B74E";
+ "2F41DCA64AF8D4173CE509AFF122E1A2";
+ "310F6C06F8E4A592F6B1D8F9E3E0495F";
+ "31B7839521CFCFA827942A2C5C9568CA";
+ "32A598E5642AFA291CE303F54F99C4D0";
+ "3449CBD013A76F479F81E923685E76A8";
+ "35DDA793A7E22F7EF0600BCC1F497501";
+ "38D24B7A67CE0488B4243AAE8153230A";
+ "3E1511FACCEF446DBA98C442D18CA0E2";
+ "3E70E17FFA4E8D4D57D1FBA59364FF8B";
+ "429D252EA09C27D6CE258C0EE6C98CA3";
+ "4358759B254D5ACFC7D9ABAB762D0123";
+ "440B43DD8FB2A3137D7D1BC67EC8F25E";
+ "44F7468732F6EF97EDA177E9DFCF9848";
+ "45C1E69BB78DA17F7EB31F434DD0EFA4";
+ "461AA6DDE0DC9413F6F65B1868578FE1";
+ "4B1EAD0ACB70AA46A6C358724051BF40";
+ "4E29E8BF5F871F41295C134CAE542AE6";
+ "4F4C299F3BD9584DFE59615DC088ACAF";
+ "4FB4E9601A82602D4F5273E4C2C1877E";
+ "50FCFA5BCEBC7AA08F3E44651E0D1877";
+ "523BCB763533C5F51BB4B00EFAB97C15";
+ "53F1D20CBCF7431268430BDEEB527354";
+ "555761C2DF8C7877BC151CC04EF6435F";
+ "56022C9F1E7493D3A11BBACD4D9DB5FA";
+ "570D51EE662B2D04FEFCF79405241092";
+ "5CCF177B58DC4266E4EBF8CD4780B57F";
+ "5CD1C06A64DE7FF82920FA95661C1D4A";
+ "5DDDC038CBABF9F492F577012FE67898";
+ "61A344AE8A81C47D1EFD2139E6456F83";
+ "68B1D93B7A98F3445C26A17A48CDDD9F";
+ "69E80386CF505EC995D8B40C9FFEF4E5";
+ "6A6B6137B0102DA560CC8A0A734E1482";
+ "71735C1E66D87FC3ECAAF26B486EB313";
+ "7224F58D708BFCDC69BA6AA6B5F91745";
+ "72B984C808E84A2FDC5EE7E221030678";
+ "73FAD4CA69D4E70D4B140956E1ADA616";
+ "773382A28C6C352AC53AA27978BF11CE";
+ "77E3824C7F2E466EF908209A55C6E66A";
+ "7A515D5882E25F0A765D54EDFFFF5AE7";
+ "7B49CF957028767419E7EAFA46B2A83B";
+ "7C802BBF4618A3944DFF10AA5F861562";
+ "7DAE77E172B360FC1D172B76E2669AA4";
+ "7EB9074255D26AC2B72D3061297E55AD";
+ "7EDE5DD999ECF3E1EA438535B0D3779D";
+ "7F968E88FAFED784DCC28660BBED7478";
+ "813445CB4FC4E7E4164FCF7C0CD15D36";
+ "84CEB8563C8CC140C2499813327483C8";
+ "8715BE02905CEF666462B8B424CA13AB";
+ "8A55903F9EFC65A3C6C17E7E47ACC0EB";
+ "8B63E9749AF64062AD38AF4B61FCE514";
+ "8B7B36B347DED51D3296A9D47EC5516C";
+ "9215976B65D0A0C85ECF5E3E946627A9";
+ "92E5B775B25A058E1F548ADD168C1EBA";
+ "93514EA9D63D51CC997A3FE9E1C1F499";
+ "94B9EFACDBF0DA9B60688D7CB682DA06";
+ "997AF31C7BD9936779057B7C55986C3D";
+ "9A90D6A9205C20D7908F2B954513CDD7";
+ "9B87E1E2B7A9036EABCCF5CAD305AA64";
+ "9DF8C8D33B7532696FB3585CCF3C18E3";
+ "9F6ADAB6E4A0AD1565BBE91772DAB754";
+ "A0A2F674DEA97FDF3738EC48B8873D91";
+ "A25A9B16B8453EF40BF02635CC4AC1C1";
+ "A59EB873346D2546F2E7F20C3B724D90";
+ "A6C976319512CD7A1BEFCFC0BB298AB4";
+ "AB551FDB2B20C67204AFFD2536AF58D2";
+ "AC153BA05F29E2CEDDAE3E24EDEDD92B";
+ "ACE143E606EEC27A1D34DD76B99C788D";
+ "AEA5DE1B43730A2D427ADF5D02FC4EBA";
+ "AEC7BB1CB38C29644100F05FA71D8C14";
+ "B0E1B61B479EC1AD104DF67C71E3D7D3";
+ "B470D04516203E887F878496E32D5F52";
+ "B6618F62F2996339DDAF98F5A551F1EC";
+ "B8C4BC448D1A2A79F3D6DFE67B39A6B5";
+ "B98E83A30E26E72150B90D969AC79A31";
+ "BF6FB42F6907DF4DFCCBB62B3A16ACEC";
+ "C0D39BC0952064F01B55BD4F7A30FC8F";
+ "C139B3B14E0C6181BD6FD78EEEF0E544";
+ "C3F3EBD524D1E1C379BA39F54283D4DE";
+ "C479F034F4A275190D096EF34EC4C9F9";
+ "C4BEA20F1231F32CC4BEEF3C09F9659D";
+ "C86212FD84F29B976FA8607F3A39AA18";
+ "D05A0FAFC9A407F7475DE09840C366FC";
+ "D1A71BE0FDD780C8A4B6F7C852D59618";
+ "D667409C8B8496C02CB8D6BA3D519E6A";
+ "D7520F9ABE07F8677AF173341630A3B0";
+ "D76F6D86235C359B06B0A142C4165267";
+ "D9FAC58A9BD13BCE0F416C29C959691C";
+ "DABF1800598B36CDD62CDEFEF269D6D9";
+ "DDBDDC4B11607EAD595475700FA26BEE";
+ "E291DC25E84D8FBB502159D36714B51D";
+ "E351B972CE16A145D715A5139F14BEB4";
+ "E4E889925A2E4670FDAE895441162462";
+ "E6757E5572707ECE172B459CAE40C0D1";
+ "E6E76D19638C68F93F328355D255DDC6";
+ "EA49A27E0AE92A5DD202241004DEB27B";
+ "EFB4EC84A1D808225028879C21868598";
+ "F616BF83E695F4803EACFD522DD0FC18";
+ "F65CDB83DCAA0DD5132BA175D38CB9A8";
+ "F7B7186CD472AB3B2C349D1E8590A319";
+ "F996B2D14287E2F48DCFE4299FA366E9";
+ "FAE8908F933D8BBD76AA48E2D5D87FF5";
+ "FB8822D7C59D5FDF3EE51D97B321CDA2";
+ "FC4B96441E9731957BF42F9605F0CE8E";
+ "FCFAB7D527718FF7DA859362FCCCCBCD"
+ ]
+
+let hset2 = [ "00B296304509111AD3FBADF5D0EB4174";
+ "0380F59D0EFC08D91D92EA2DA21AA63B";
+ "041F0FC43345B40966F7F719B9516BD5";
+ "0AE2D4B775F1F96B69F847C41A647E7C";
+ "0EC7C7B2063906583C0FB1FAF226C1F5";
+ "120A8399CC40D8E77F45D0E48E24D1C3";
+ "13816751FCDAD3A0C435891173F4B2B3";
+ "1508AF0754BAE36164A273CE23F6F92C";
+ "152C6329676F13AB7DA26920C7EE2B26";
+ "17A77CD4D4C199584055F20C5BAE7E42";
+ "19DFBC8796B3C601F42CBE956A21450A";
+ "1AFE2D66788ACCA74623C0ABEFC76A23";
+ "1B9D36DF0E1DF06C26E2CFF09EB8E8F6";
+ "1DCD73D52AA4107FB10C443C7FE15D82";
+ "1EFE5A704FB95F34E7681F17709CF48B";
+ "21F53DA73435722B4A33AD8E592D7AD8";
+ "22DEB68B528B8BFF63C67AB8E0647F5D";
+ "242290617D2C2EAF3C315DBDA003FB0E";
+ "25BA96D2491C28413933FF9CA65F98D1";
+ "2AD37228644CBDE5B90A314BFA5F5F12";
+ "2E210DBEBBA8650440087FFE78ED12E4";
+ "3092D250C98AE7BD9A4E645B13047019";
+ "315707A359E1335CD9A7F1B91D223304";
+ "315C318F9E0D2F0808C5C2FAEDA1B9B4";
+ "3469AA6260EB8016B7DE3875A540CFE3";
+ "36CFC24ECE2B01AA03DB484C1606C30B";
+ "3C270BDE18BA4BB6A81B65FF36DCE9DD";
+ "3C753A6EF3D1147DAD75BBBAAFA78959";
+ "3DD36C3D63D877766BAFF701386AE28D";
+ "3FE4EE03A72DA348729D8BA178120B1A";
+ "41EDD431F77E932FBE128628C387AD4C";
+ "48BCFE282FC7975BBB304ACBE6491E9F";
+ "49A7419829CFE787E0DAFF9972E98BBF";
+ "4A4FC66FB85C5B437DB35E452AC14FA4";
+ "4B763E5A0A455D7E351B4458AC37CEE3";
+ "4DAA527A37447D42464337C143C59221";
+ "4DDF9FC4263177FDCE3612E28619B781";
+ "4F3C5D59683AA58D1E02CBD323CEEBBB";
+ "4FF3987B0E59BCEA3FBB5FF691394F39";
+ "51A3482B1C5E507BF977046A39B1F397";
+ "537E4BC2A6459505183F9FE7D3D3C4BB";
+ "59A8392563EC43A9E0BE0C4633C2383F";
+ "5B91C853430935981E1222F4A3EEF3DE";
+ "5D54BA1012D4C39E1642119400B26D1E";
+ "5D5A87DB43E8D10507B46719F327813F";
+ "5E153871907884437F90D2EA8C2AD59E";
+ "5E1BFB9C0CE18CE68A11AA8BF924298C";
+ "5E74618321F5DA421C185D136BD15F13";
+ "65CBF754725E33FC6BBA72A12ECBA7E1";
+ "6923CF692886CFAC086FFC69FFF7FD41";
+ "6924AB2BC66A21ECD83AAEEF0D1B9F5D";
+ "6B6F903A61AE0E06DAE159EFCCB87AB3";
+ "6BA548156E1BC0BED7F1CFFB269DCEC5";
+ "6D0B688753F261110D4FB1D4671157E9";
+ "6EB09315AF03C56C09B0986F25919B2B";
+ "6F0BDA642E5A24DDE1A1818D2DA0B802";
+ "6FCF4602F565B71BF7191DE166065545";
+ "70CAA0977099552575988814B67F21B2";
+ "731AE161BDD59C8D1136B62AC1010042";
+ "74E631C656D0AFAE7564CD33E7DE9C5F";
+ "78BD52DD9FEF9CDCEC9E94F5638D1E0D";
+ "792E5F84D84B2E61ED4557D914502651";
+ "793ACE2504302EE88900CBCA2C0587E7";
+ "7989D52BD12918F2682FDD7D094D1821";
+ "7A342B342675CC29731D9F41F2E1FF88";
+ "7A6208B321D39E9343F708529A195204";
+ "807A560003EB5A12FA33649B2EB01EFA";
+ "80E1124D15F4600AC5067F38471D4553";
+ "8265D8BE769C403B894470D4218C40AF";
+ "832D03E697579945398B337DCF953AD4";
+ "8554C494D66FD2678D8D3E4B9392651E";
+ "86A2ABC4B5B71B1AEA9AAE50F8785353";
+ "892ECD9F60DB49366F6655456ED6DBE4";
+ "8ABD3D82A932EC7C2460BD1F888E2D0B";
+ "8D551EBFEC2992841345020BB2486D62";
+ "909FB7B6F92BE1C16C98370D5541E67D";
+ "91B9D87FE486EC18937D150317505790";
+ "91F9C9C94C4722D37942614D4925965D";
+ "970F3ED74A779CEC3970FC0D2796619C";
+ "97C613AB7F49D29A98D072519F58B662";
+ "9859F5F034E707F61AC61F3746506EC5";
+ "99BE9C6210F952F66816CADA4659FC57";
+ "9B141D0078BBF564DBE600C4D9DDB6E3";
+ "A12AA1F81B55BA7E860F104F70B28CE5";
+ "A30051E27A50A4A2B08C5B0297308B29";
+ "A78EBF9942E2BB2A19BFF54264C1DF92";
+ "A8A9C12ABABFFC0BEA23096027224813";
+ "A91B09ECED33D833BB96E4A94102B666";
+ "AB5528D81E3D5A57CB6267CD178F2EDB";
+ "AC73E0342A0391349AA054FA4A1A8FA9";
+ "AD4ADBCFFF4554F8998A6173DAAEEF85";
+ "ADD59B5ABBFD060E37A432E341BE3F0C";
+ "AF7B930A794E2B0D5F08EEE4D3D39C10";
+ "B13F9377018068081D44A16446EFFCF2";
+ "B37A6AF07852F39A863677F22EDF8E12";
+ "B9FA82C1DB741A85D8E519A7CDE7ACCC";
+ "C577251814B145B6B5B59D8F42D0DF26";
+ "C88871174AFDB0C46873D75C614CDE10";
+ "CBADA8F7FBD2DEB89129EC3BB36328CD";
+ "CCA68A5581EA50E3D72E39726C7CCA8B";
+ "CD46C59E67F9A2165DA7030E11C72D5C";
+ "D338A6A91057EDADF8A1AD3BFA116D13";
+ "D34DB4C12B869BC3590219F2C584B60E";
+ "D4F9A8AC603954243E7E23843352C2C9";
+ "D5DECE3E600DA5211D1C49DCA4327B17";
+ "D7809C3C317CED042341D980C4579284";
+ "DA13BC09EBFBB6CF83E41027FB3A14A1";
+ "DBE411983E0C37A11CF0F90592A7491F";
+ "DF288C042F30691D52204F8A57A8E746";
+ "E06ED99CC839B8680E465A96042C185C";
+ "E0DE6722AB921D1CB3E17CA59E1A6A9E";
+ "E1A3585BD925180FD594C6E75CC15DE8";
+ "E1BA428E3CF44E78600E4EC9DA19D14C";
+ "E2BB667A2B4A35BAA683CCF1457914E0";
+ "E360F4EBAB65F8906E6BE774D982B13C";
+ "E4C48C99B4FF0CE7584E23C2198E4556";
+ "E540ADE2CE01D310C72BD8222F1EB17E";
+ "E6D7221D91D4EAE9BC1D7EBAD253C059";
+ "EE0B194B94A807D85139A121D0D7582F";
+ "F3E9BA4BB990F09022B4A20D567AC376";
+ "F5FA58C9C0A4CB9ED534342C8DDAB355";
+ "F6DF7D2DBA71E52B600032C7A22767C5";
+ "F7961C3436DB73A9BDDEEC0A5205F5F1";
+ "FA7DD2C088E88B0CCEBE8BD232DBD935";
+ "FAD188976DB9B5C8CA0704B30A108747";
+ "FC6D9BE059D84DBAFDF38D38326BB0E2"]
+
+let (|=) map key = Map.find key map
+let (|<) map key = (fun data -> Map.add ~key ~data map)
+
+let keys1 = get_keys h1 hset2
+let keys2 = get_keys h2 hset1
+
+let kmap1 = Map.of_alist
+ (List.map keys1
+ ~f:(fun key -> (Fingerprint.keyid_from_key key, key)))
+
+let kmap2 = Map.of_alist
+ (List.map keys2
+ ~f:(fun key -> (Fingerprint.keyid_from_key key, key)))
+
+let unwrap x = match x with None -> failwith "unwrap failed" | Some x -> x
+
+let subset k1 k2 = Set.subset (Set.of_list k1) (Set.of_list k2)
+let equal k1 k2 = Set.equal (Set.of_list k1) (Set.of_list k2)
+
+
Added: sks/branches/upstream/sks/current/sendmail.ml
===================================================================
--- sks/branches/upstream/sks/current/sendmail.ml (rev 0)
+++ sks/branches/upstream/sks/current/sendmail.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,103 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Simple (and likely incomplete) interface for sending mail *)
+open StdLabels
+open MoreLabels
+open Common
+open Printf
+
+module Map = PMap.Map
+module Set = PSet.Set
+
+type msg = { headers: (string * string) list;
+ body: string;
+ }
+
+let process_status_to_string ps =
+ let (name,code) = match ps with
+ Unix.WEXITED n -> ("Exited",n)
+ | Unix.WSIGNALED n -> ("Signaled",n)
+ | Unix.WSTOPPED n -> ("Stopped",n)
+ in
+ sprintf "%s(%d)" name code
+
+exception Unwrap_failure
+let unwrap x = match x with
+ None -> raise Unwrap_failure
+ | Some x -> x
+
+
+(** Invokes sendmail and sends the argument to sendmail via stdin *)
+let send_text text =
+ let cout = Unix.open_process_out !Settings.sendmail_cmd in
+ let status = ref None in
+ protect ~f:(fun () -> output_string cout text)
+ ~finally:(fun () -> status := Some (Unix.close_process_out cout));
+ if unwrap !status <> Unix.WEXITED 0 then
+ failwith (sprintf "Sendmail.send_text failed: %s"
+ (process_status_to_string (unwrap !status)))
+ else ()
+
+(** converts message to string ready for sending via you favoriate
+ MTA *)
+let msg_to_string msg =
+ let header_lines =
+ List.map ~f:(fun (field,entry) ->
+ if field = "" then sprintf "\t%s\n" entry
+ else sprintf "%s: %s\n" field entry)
+ msg.headers
+ in
+ let header = String.concat ~sep:"" header_lines in
+ header ^ "\n" ^ msg.body
+
+
+(** Sends the given message *)
+let send msg = send_text (msg_to_string msg)
+
+(** removes the continuation of the headers, where a continuation is defined
+ to be an initial sequence of headers with empty field names
+*)
+let rec remove_continuation headers = match headers with
+ [] -> []
+ | ("",entry)::tl ->
+ remove_continuation tl
+ | headers -> headers
+
+
+let rec filter_headers_from_headers headers fields = match headers with
+ | [] -> []
+ | (("",contents) as hd)::tl ->
+ hd::(filter_headers_from_headers tl fields)
+ | ((field,contents) as hd)::tl ->
+ if Set.mem (String.lowercase field) fields then
+ hd::(filter_headers_from_headers tl fields)
+ else
+ filter_headers_from_headers (remove_continuation tl)
+ fields
+
+let filter_headers msg fields =
+ let fields = Set.of_list (List.map ~f:String.lowercase fields) in
+ { msg with
+ headers = filter_headers_from_headers msg.headers fields
+ }
+
+let add_headers msg headers =
+ { msg with headers = headers @ msg.headers }
+
+let get_body msg = msg.body
+let get_headers msg = msg.headers
Added: sks/branches/upstream/sks/current/server.ml
===================================================================
--- sks/branches/upstream/sks/current/server.ml (rev 0)
+++ sks/branches/upstream/sks/current/server.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,170 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Server side of set-reconciliation algorithm *)
+open StdLabels
+open MoreLabels
+module Unix=UnixLabels
+open Printf
+
+open Common
+open ReconMessages
+
+module ZSet = ZZp.Set
+module PTree = PrefixTree
+(* module ZZp = RMisc.ZZp *)
+
+exception Bug of string
+
+(***************************************************************)
+(* Diagnostic Timers *****************************************)
+(***************************************************************)
+
+let solving = ref 0.0
+let lookup = ref 0.0
+let flushtime = ref 0.0
+let unmarsh_time = ref 0.0
+
+(***************************************************************)
+(* Wrapper for core reconciliation code *********************)
+(***************************************************************)
+
+let solve ~remote_size ~local_size ~remote_samples ~local_samples ~points =
+ let values = ZZp.mut_array_div remote_samples local_samples in
+ try
+ let (remote_diff,local_diff) =
+ Decode.reconcile ~values ~points ~d:(remote_size - local_size)
+ in
+ Some (remote_diff,local_diff)
+ with
+ Decode.Low_mbar -> None
+
+(************************************************)
+
+
+(* returns true if the connection should be left open, false otherwise *)
+let handle_one tree cin cout =
+ let request = unmarshal cin in
+ match request.msg with
+
+ | Elements s ->
+ (true, s)
+
+ | ReconRqst_Poly rp -> (
+ (* NOTE: Add case analysis to deal with where set size = 0 *)
+ let remote_size = rp.rp_size
+ and points = PTree.points tree
+ and remote_samples = rp.rp_samples in
+ ( match (try Some (PTree.get_node_key tree rp.rp_prefix)
+ with Not_found -> None)
+ with
+ None ->
+ marshal cout
+ (Error("server should never receive request " ^
+ "for non-existant node (ReconRqst_Poly)"));
+ plerror 2 "%s" ("Server received ReconRqst_Poly " ^
+ "for non-existant node");
+ (false,ZSet.empty)
+ | Some node ->
+ let local_samples = PTree.svalues node
+ and local_size = PTree.size node in
+ let results =
+ solve ~remote_samples ~local_samples ~remote_size
+ ~local_size ~points in
+ match results with
+ | Some (remote_set,local_set) ->
+ marshal_noflush cout (Elements local_set);
+ (true,remote_set)
+ | None ->
+ if PTree.is_leaf node ||
+ PTree.num_elements tree node <
+ !Settings.recon_thresh_mult * !Settings.mbar
+ then (
+ let elements = PTree.elements tree node in
+ marshal_noflush cout (FullElements elements);
+ (true,ZSet.empty)
+ (* NOTE: server still doesn't know its share here.
+ Client will send that later *)
+ ) else (
+ marshal_noflush cout SyncFail;
+ (true, ZSet.empty)
+ )
+
+ ))
+
+ | ReconRqst_Full rf -> (
+ match
+ ( try
+ let node = PTree.get_node_key tree rf.rf_prefix in
+ let localset = PTree.elements tree node in
+ Some (ZSet.diff localset rf.rf_elements,
+ ZSet.diff rf.rf_elements localset)
+ with
+ Not_found -> None )
+ with
+ Some (localdiff,remotediff) ->
+ marshal_noflush cout (Elements localdiff);
+ (true, remotediff)
+ | None ->
+ marshal cout (Error ("server should never received request " ^
+ "for non-existant node (ReconRqst_Full)"));
+ plerror 2 "%s" ("Server recieved RconRqst_Full " ^
+ "for non-existant node");
+ (false,ZSet.empty)
+ )
+
+ | Done ->
+ plerror 5 "Done received";
+ (false,ZSet.empty)
+
+ | Flush ->
+ plerror 5 "Flush occured";
+ cout#flush;
+ (true,ZSet.empty)
+
+ | _ ->
+ failwith ("Unexpected message: " ^
+ msg_to_string request.msg)
+
+(***************************************************************)
+
+
+let recover_timeout = 10
+
+let handle tree cin cout =
+ let set_ref = ref ZSet.empty in
+ let continue_ref = ref true in
+ try
+ while !continue_ref do
+ let (continue, elements) = handle_one tree cin cout in
+ set_ref := ZSet.union !set_ref elements;
+ continue_ref := continue;
+ done;
+ !set_ref
+ with
+ | Eventloop.SigAlarm ->
+ ignore (Unix.alarm recover_timeout);
+ plerror 2 "%s" ("Reconciliation failed due to timeout. " ^
+ "Returning elements returned so far");
+ !set_ref
+ | End_of_file | Sys_error _ as e ->
+ ignore (Unix.alarm recover_timeout);
+ eplerror 2 e "%s" ("Reconciliation failed. " ^
+ "Returning elements returned so far");
+ !set_ref
+
+
Added: sks/branches/upstream/sks/current/settings.ml
===================================================================
--- sks/branches/upstream/sks/current/settings.ml (rev 0)
+++ sks/branches/upstream/sks/current/settings.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,329 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+module Unix=UnixLabels
+open Printf
+
+(** Various and sundry settings with their defaults,
+ plus functions for assigning new values. This is used by the
+ getopt routines to set preferences *)
+
+let n = ref 0
+let set_n value = n := value
+
+let debug = ref true
+let set_debug value = debug := value
+
+let debuglevel = ref 3
+let set_debuglevel value = debuglevel := value
+
+let mbar = ref 5
+let set_mbar value = mbar := value
+
+let bitquantum = ref 2
+let set_bitquantum value = bitquantum := value
+
+let drop = ref 10
+let set_drop value = drop := value
+
+let bytes = ref 16
+let set_bytes value = bytes := value
+
+(** maximum number of differences to recover in one go *)
+let max_recover = ref 2000
+let set_max_recover value = max_recover := value
+
+let seed = ref 0
+let self_seed = ref true
+let set_seed value =
+ self_seed := false;
+ seed := value
+
+let recon_port = ref 11370
+let recon_address = ref "0.0.0.0"
+let set_recon_address value = recon_address := value
+
+let hkp_port = ref 11371
+let hkp_address = ref "0.0.0.0"
+let set_hkp_address value = hkp_address := value
+
+let use_port_80 = ref false
+
+let set_base_port value =
+ recon_port := value;
+ hkp_port := value + 1
+
+let set_recon_port value = recon_port := value
+let set_hkp_port value = hkp_port := value
+
+let setup_RNG () =
+ if !self_seed
+ then Random.self_init ()
+ else Random.init !seed
+
+let max_internal_matches = ref 20000
+let set_max_internal_matches value = max_internal_matches := value
+
+let max_matches = ref 500
+let set_max_matches value = max_matches := value
+
+let max_outstanding_recon_requests = ref 100
+let set_max_outstanding_recon_requests value =
+ max_outstanding_recon_requests := value
+
+let max_uid_fetches = ref 1000
+let set_max_uid_fetches value = max_uid_fetches := value
+
+let dump_new = ref false
+
+(* whether or not to use a disk-based prefix-tree implementation *)
+let disk_ptree = ref true
+
+let max_ptree_nodes = ref 1000
+let set_max_ptree_nodes value = max_ptree_nodes := value
+
+let http_fetch_size = ref 100
+let set_http_fetch_size value = http_fetch_size := value
+
+let prob = ref 0.1
+let set_prob value = prob := value
+
+let db_sync_interval = ref (5. *. 60.)
+let set_db_sync_interval value = db_sync_interval := value
+
+let recon_sync_interval = ref (5. *. 60.)
+let set_recon_sync_interval value = recon_sync_interval := value
+
+let gossip_interval = ref 60. (* time between gossips in seconds*)
+let set_gossip_interval value = gossip_interval := value *. 60.
+
+let gossip = ref true (* whether or not to initiate gossips *)
+
+let anonlist = ref ([] : string list)
+
+let cache_bytes = ref (Some (20 * 1024 * 1024))
+let set_cache_bytes value = cache_bytes := Some (value * 1024 * 1024)
+
+let pagesize = ref (Some 2048)
+let set_pagesize value = pagesize := Some (value * 512)
+
+let ptree_cache_bytes = ref (Some (5 * 1024 * 1024))
+let set_ptree_cache_bytes value =
+ ptree_cache_bytes := Some (value * 1024 * 1024)
+
+let ptree_pagesize = ref (Some 512)
+let set_ptree_pagesize value = ptree_pagesize := Some (value * 512)
+
+let hostname = ref (Unix.gethostname ())
+let set_hostname value = hostname := value
+
+let filelog = ref true
+
+let transactions = ref true
+
+let checkpoint_interval = ref (60. *. 60.)
+let set_checkpoint_interval value = checkpoint_interval := value
+
+let recon_checkpoint_interval = ref (60. *. 60.)
+let set_recon_checkpoint_interval value = recon_checkpoint_interval := value
+
+let ptree_thresh_mult = ref 10
+let set_ptree_thresh_mult value = ptree_thresh_mult := value
+
+let recon_thresh_mult = ref 30
+let set_recon_thresh_mult value = recon_thresh_mult := value
+
+let wserver_timeout = ref 180
+let set_wserver_timeout value = wserver_timeout := value
+
+let reconciliation_config_timeout = ref 45
+let set_reconciliation_config_timeout value =
+ reconciliation_config_timeout := value
+
+let reconciliation_timeout = ref (60 * 60)
+let set_reconciliation_timeout value = reconciliation_timeout := (value * 60)
+
+let initial_stat = ref false (* whether to calculate stats page on boot *)
+
+let stat_calc_hour = ref 3 (* hour of the day to do stats calculation *)
+let set_stat_calc_hour value = stat_calc_hour := value
+
+(*let XXX = ref
+let set_XXX value = XXX := value *)
+
+let missing_keys_timeout = ref 180
+let set_missing_keys_timeout value = missing_keys_timeout := value
+
+let command_timeout = ref 60
+let set_command_timeout value = command_timeout := value
+
+let sendmail_cmd = ref "sendmail -t -oi"
+let set_sendmail_cmd value = sendmail_cmd := value
+
+let membership_reload_time = ref (60. *. 60. *. 6.)
+let set_membership_reload_time value =
+ membership_reload_time := value *. 60. *. 60.
+
+(** whether to send out PKS-style mailsync messages *)
+let send_mailsyncs = ref true
+(** WHether to log hashes of most-recently-found diff *)
+let log_diffs = ref true
+
+let from_addr = ref None
+let set_from_addr value = from_addr := Some value
+let get_from_addr () =
+ match !from_addr with
+ | Some addr -> addr
+ | None ->
+ let addr = ((Unix.getpwuid (Unix.getuid ())).Unix.pw_name
+ ^ "@" ^ !hostname)
+ in
+ from_addr := Some addr;
+ addr
+
+let basedir = ref "."
+
+let base_dbdir = "KDB"
+let base_ptree_dbdir = "PTree"
+let base_membership_file = "membership"
+let base_mailsync_file = "mailsync"
+let base_dumpdir = "dump"
+let base_msgdir = "messages"
+let base_failed_msgdir = "failed_messages"
+
+let dbdir = lazy (Filename.concat !basedir base_dbdir)
+let ptree_dbdir = lazy (Filename.concat !basedir base_ptree_dbdir)
+let membership_file = lazy (Filename.concat !basedir base_membership_file)
+let mailsync_file = lazy (Filename.concat !basedir base_mailsync_file)
+let dumpdir = lazy (Filename.concat !basedir base_dumpdir)
+let msgdir = lazy (Filename.concat !basedir base_msgdir)
+let failed_msgdir = lazy (Filename.concat !basedir base_failed_msgdir)
+
+(*****************************************************************)
+
+(** Specifies the options along with the corresponding actions.
+ These are used both for command-line options and the config file *)
+let parse_spec =
+ [ ("-debug", Arg.Set debug, " debugging mode");
+ ("-debuglevel", Arg.Int set_debuglevel,
+ " Debugging level -- sets verbosity of logging");
+ ("-q", Arg.Int set_bitquantum, " number of bits defining a bin");
+ ("-mbar", Arg.Int set_mbar, " number of errors that can be corrected " ^
+ "in one shot");
+ ("-seed", Arg.Int set_seed, " Seed used by RNG");
+ ("-hostname", Arg.String set_hostname, " current hostname");
+ ("-d", Arg.Int set_drop, " Number of keys to drop at random " ^
+ "when synchronizing");
+ ("-n", Arg.Int set_n, " Number of key dump files to load at once " ^
+ "when used with build, multiple of 15000 keys when used with " ^
+ "fastbuild.");
+ ("-max_internal_matches", Arg.Int set_max_internal_matches,
+ " Maximum number of matches for most specific word in a " ^
+ "multi-word search");
+ ("-max_matches", Arg.Int set_max_internal_matches,
+ " Maximum number of matches that will be returned from a query");
+ ("-max_uid_fetches", Arg.Int set_max_uid_fetches,
+ " Maximum number of uid fetches performed in a verbose index query");
+ ("-pagesize", Arg.Int set_pagesize, " Pagesize in bytes for key db");
+ ("-cache", Arg.Int set_cache_bytes, " Cache size in megs for key db");
+ ("-ptree_pagesize", Arg.Int set_ptree_pagesize,
+ " Pagesize in bytes for prefix tree db");
+ ("-ptree_cache", Arg.Int set_ptree_cache_bytes,
+ " Cache size in megs for prefix tree db");
+ ("-baseport",Arg.Int set_base_port, " Set base port number");
+ ("-logfile",Arg.String (fun _ -> ()), " DEPRECATED. Now ignored.");
+ ("-recon_port",Arg.Int set_recon_port, " Set recon port number");
+ ("-recon_address",Arg.String set_recon_address, " Set recon binding address");
+ ("-hkp_port",Arg.Int set_hkp_port, " Set hkp port number");
+ ("-hkp_address",Arg.String set_hkp_address, " Set hkp binding address");
+ ("-use_port_80",Arg.Set use_port_80,
+ " Have the HKP interface listen on port 80, as well as the hkp_port");
+ ("-basedir", Arg.Set_string basedir, " Base directory");
+ ("-stdoutlog", Arg.Clear filelog,
+ " Send log messages to stdout instead of log file");
+ ("-diskptree", Arg.Set disk_ptree,
+ " Use a disk-based ptree implementation. Slower, but requires far less memory");
+ ("-nodiskptree", Arg.Clear disk_ptree, " Use in-mem ptree");
+ ("-max_ptree_nodes", Arg.Int set_max_ptree_nodes,
+ " Maximum number of allowed ptree nodes. Only meaningful if -diskptree is set");
+ ("-prob", Arg.Float set_prob, " Set probability. Used for testing code only");
+ ("-recon_sync_interval", Arg.Float set_recon_sync_interval,
+ " Set sync interval for reconserver.");
+ ("-gossip_interval", Arg.Float set_gossip_interval, " Set time between " ^
+ "gossips in minutes.");
+ ("-dontgossip", Arg.Clear gossip, " Don't gossip automatically. " ^
+ "Host will still respond to requests from other hosts");
+ ("-db_sync_interval", Arg.Float set_db_sync_interval,
+ " Set sync interval for dbserver.");
+ ("-checkpoint_interval", Arg.Float set_checkpoint_interval,
+ " Time period between checkpoints");
+ ("-recon_checkpoint_interval", Arg.Float set_recon_checkpoint_interval,
+ " Time period between checkpoints for reconserver");
+ ("-ptree_thresh_mult", Arg.Int set_ptree_thresh_mult,
+ " Multiple of thresh which specifies minimum node size in prefix tree");
+ ("-recon_thresh_mult", Arg.Int set_recon_thresh_mult,
+ " Multiple of thresh which specifies minimum node size that is " ^
+ "included in reconciliation");
+ ("-max_recover", Arg.Int set_max_recover,
+ " Maximum number of differences to recover in one round");
+ ("-http_fetch_size", Arg.Int set_http_fetch_size,
+ " Number of keys for reconserver to fetch from dbserver in one go.");
+ ("-wserver_timeout", Arg.Int set_wserver_timeout,
+ " Timeout in seconds for webserver requests");
+ ("-reconciliation_timeout", Arg.Int set_reconciliation_timeout,
+ " Timeout for reconciliation runs in minutes");
+ ("-stat_hour", Arg.Int set_stat_calc_hour,
+ " Hour at which to run database statistics");
+ ("-initial_stat", Arg.Set initial_stat,
+ " Runs database statistics calculation on boot");
+ ("-reconciliation_config_timeout", Arg.Int set_reconciliation_config_timeout,
+ " Set timeout in seconds for initial exchange of config info " ^
+ "in reconciliation");
+ ("-missing_keys_timeout", Arg.Int set_missing_keys_timeout,
+ " Timeout in seconds for get_missing_keys");
+ ("-command_timeout", Arg.Int set_command_timeout,
+ " Timeout in seconds for commands set over command socket");
+ ("-sendmail_cmd", Arg.String set_sendmail_cmd,
+ " Command used for sending mail");
+ ("-from_addr", Arg.String set_from_addr,
+ " From address used in synchronization emails used to communicate " ^
+ "with PKS");
+ ("-dump_new_only", Arg.Set dump_new,
+ " When doing a database dump, only dump new keys, not keys" ^
+ " already contained in a keydump file");
+ ("-max_outstanding_recon_requests", Arg.Int set_max_outstanding_recon_requests,
+ " maximum number of outstanding requests in reconciliation");
+ ("-membership_reload_interval", Arg.Float set_membership_reload_time,
+ " maximum interval (in hours) at which membership file is reloaded");
+ ("-disable_mailsync", Arg.Clear send_mailsyncs,
+ " Disable sending of PKS mailsync messages. ONLY FOR STANDALONE SERVERS!");
+ ("-disable_log_diffs", Arg.Clear log_diffs,
+ " Disable logging of recent hashset diffs.");
+ ]
+
+let parse_spec = Arg.align parse_spec
+
+let anon_options option_string =
+ anonlist := option_string::!anonlist
+
+let usage_string =
+ "sks command [-mbar mbar] [-q bitquantum] -debug (type \"sks help\" for a list of commands)"
+
+
+
Added: sks/branches/upstream/sks/current/sks.ml
===================================================================
--- sks/branches/upstream/sks/current/sks.ml (rev 0)
+++ sks/branches/upstream/sks/current/sks.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,188 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+open Printf
+open Scanf
+open Common
+(** Executable: Uber-executable replacing all others *)
+
+type command =
+ { name: string;
+ usage: string;
+ desc: string;
+ func: unit -> unit
+ }
+
+let usage command =
+ sprintf "Usage: sks %s %s" command.name command.usage
+
+let space = Str.regexp " ";;
+
+let rec commands = [
+ { name = "db";
+ usage = "";
+ desc = "Initiates database server";
+ func = (fun () ->
+ let module M = Dbserver.F(struct end) in
+ M.run ()
+ )
+ };
+ { name = "recon";
+ usage = "";
+ desc = "Initiates reconciliation server";
+ func = (fun () ->
+ let module M = Reconserver.F(struct end) in
+ M.run ()
+ )
+ };
+ { name = "cleandb";
+ usage = "";
+ desc = "Apply filters to all keys in database, fixing some common problems";
+ func = (fun () ->
+ let module M = Clean_keydb.F(struct end) in
+ M.run ()
+ )
+ };
+ { name = "build";
+ usage = "";
+ desc = "Build key database, including body of keys directly in database";
+ func = (fun () ->
+ let module M = Build.F(struct end) in
+ M.run ()
+ )
+ };
+ { name = "fastbuild";
+ usage = "-n [size] -cache [mbytes]";
+ desc = "Build key database, doesn't include keys directly in database, " ^
+ "faster than build . -n specifies the number of keydump files to " ^
+ "read per pass when used with build and the multiple of 15,000 " ^
+ "keys to be read per pass when used with fastbuild. " ^
+ " -cache specifies the database cache to use in megabytes.";
+ func = (fun () ->
+ let module M = Fastbuild.F(struct end) in
+ M.run ()
+ )
+ };
+ { name = "pbuild";
+ usage = "-cache [mbytes] -ptree_cache [mbytes]";
+ desc = "Build prefix-tree database, used by reconciliation server, " ^
+ "from key database. Allows for specification of cache for " ^
+ "key database and for ptree database.";
+ func = (fun () ->
+ let module M = Pbuild.F(struct end) in
+ M.run ()
+ )
+ };
+ { name = "dump";
+ usage = "#keys dumpdir";
+ desc = "Create a raw dump of the keys in the database";
+ func = (fun () ->
+ let module M = Sksdump.F(struct end) in
+ M.run ()
+ )
+ };
+ { name = "merge";
+ usage = "";
+ desc = "Adds key from key files to existing database";
+ func = (fun () ->
+ let module M = Merge_keyfiles.F(struct end) in
+ M.run ()
+ )
+ };
+ { name = "drop";
+ usage = "";
+ desc = "Drops key from database. Requires running sks db.";
+ func = Sks_do.drop;
+ };
+ { name = "update_subkeys";
+ usage = "[-n # of updates / 1000]";
+ desc = "Updates subkey keyid index to include all current keys. " ^
+ "Only useful when upgrading versions 1.0.4 or before of sks.";
+ func = Update_subkeys.run;
+ };
+ { name = "incdump";
+ usage = "timestamp(seconds since 1970) [dumpname]";
+ desc = "Create a raw dump of the keys in the database that got" ^
+ "updated after timestamp";
+ func = Incdump.run;
+ };
+ { name = "unit_test";
+ usage = "";
+ desc = "Runs basic unit tests and reporst results";
+ func = Unit_tests.run;
+ };
+ { name = "help";
+ usage = "";
+ desc = "Prints this message";
+ func = help;
+ };
+]
+
+and help () =
+ printf "This is a list of the available commands\n\n";
+ List.iter commands
+ ~f:(fun c ->
+ Format.open_box 3;
+ Format.print_string "sks ";
+ Format.print_string c.name;
+ if c.usage <> "" then (
+ Format.print_string " ";
+ Format.print_string c.usage);
+ Format.print_string ": ";
+ List.iter (fun s ->
+ Format.print_string s;
+ Format.print_space ();)
+ (Str.split space c.desc);
+ Format.close_box ();
+ Format.print_newline ();
+ );
+printf "\n"
+
+
+(****************************************************)
+
+let rec find name commands = match commands with
+ | [] -> raise Not_found
+ | hd::tl ->
+ if hd.name = name
+ then hd else find name tl
+
+
+let () =
+ match !Settings.anonlist with
+ | [] ->
+ eprintf "No command specified\n";
+ exit (-1)
+ | name::tl ->
+ let command =
+ try find name commands
+ with Not_found ->
+ eprintf "Unknown command %s\n" name;
+ exit (-1)
+ in
+ Settings.anonlist := tl;
+ try command.func ()
+ with
+ Argument_error s ->
+ eprintf "Argument error: %s\n" s;
+ eprintf "Usage: sks %s %s\n%!" command.name command.usage;
+ exit (-1)
+
+
+
Added: sks/branches/upstream/sks/current/sks.pod
===================================================================
--- sks/branches/upstream/sks/current/sks.pod (rev 0)
+++ sks/branches/upstream/sks/current/sks.pod 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,363 @@
+=head1 NAME
+
+SKS - Synchronizing Key Server
+
+=head1 SYNOPSIS
+
+sks [options] -debug
+
+=head1 DESCRIPTION
+
+SKS is a OpenPGP keyserver whose goal is to provide easy to deploy, decentralized, and highly reliable synchronization. That means that a key submitted to one SKS server will quickly be distributed to all key servers, and even wildly out-of-date servers, or servers that experience spotty connectivity, can fully synchronize with rest of the system.
+
+The design of SKS is deliberately simple. The server consists of two single-threaded processes. The first, "sks db", fulfills the normal jobs associated with a public key server, such as answering web requests. The only special functionality of "sks db" is that it keeps a log summarizing the changes to the key database. "sks recon" does all the work with respect to reconciling hosts databases. "sks recon" keeps track of specialized summary information about the database, and can use that information to efficiently determine the differences between its database and that of another host.
+
+=head1 FEATURES
+
+Highly efficient and reliable reconciliation algorithm
+
+Follows RFC2440 and RFC2440bis carefully - unlike PKS, SKS supports new and old style packets, photoID packets, multiple subkeys, and pretty much everything allowed by the RFCs.
+
+Fully compatible with PKS system - can both send and receive syncs from PKS servers, ensuring seamless connectivity.
+
+Simple configuration: each host just needs a (partial) list of the other participating key servers. Gossip is used to distribute information without putting a heavy load an any one host.
+
+Supports HKP/web-based querying, and soon-to-be-standard machine readable indices
+
+=head1 OPTIONS
+
+SKS binary command options are as follows:
+
+=over
+
+=item db
+
+ Initiates database server.
+
+=item recon
+
+Initiates reconciliation server.
+
+=item cleandb
+
+Apply filters to all keys in database, fixing some common problems.
+
+=item build
+
+Build key database, including body of keys directly in database.
+
+=item fastbuild -n [size] -cache [mbytes]
+
+Build key database, doesn't include keys directly in database, faster than build. -n specifies the number of keydump files to read per pass when used with build and the multiple of 15,000 keys to be read per pass when used with fastbuild. -cache specifies the database cache to use in megabytes.
+
+=item pbuild -cache [mbytes] -ptree_cache [mbytes]
+
+Build prefix-tree database, used by reconciliation server, from key database. Allows for specification of cache for key database and for ptree database.
+
+=item dump #keys dumpdir
+
+Create a raw dump of the keys in the database.
+
+=item merge
+
+Adds key from key files to existing database.
+
+=item drop
+
+Drops key from database.
+
+=item update_subkeys [-n # of updates / 1000]
+
+Updates subkey keyid index to include all current keys. Only useful when upgrading versions 1.0.4 or before of SKS.
+
+=item help
+
+Prints the help message.
+
+=back
+
+=head1 ADDITIONAL OPTIONS
+
+You won't need most of the options below for normal operation. These options can be given in basedir/sksconf or as command line option for the sks binary.
+
+=over
+
+=item -debug
+
+Debugging mode.
+
+=item -debuglevel
+
+Debugging level -- sets verbosity of logging.
+
+=item -q
+
+ Number of bits defining a bin.
+
+=item -mbar
+
+Number of errors that can be corrected in one shot.
+
+=item -seed
+
+Seed used by RNG.
+
+=item -hostname
+
+Current hostname.
+
+=item -d
+
+ Number of keys to drop at random when synchronizing.
+
+=item -n
+
+ Number of keydump files to load at once.
+
+=item -max_internal_matches
+
+Maximum number of matches for most specific word in a multi-word search.
+
+=item -max_matches
+
+Maximum number of matches that will be returned from a query.
+
+=item -max_uid_fetches
+
+Maximum number of uid fetches performed in a verbose index query.
+
+=item -pagesize
+
+Pagesize in bytes for key db.
+
+=item -cache
+
+Cache size in megs for key db.
+
+=item -ptree_pagesize
+
+Pagesize in bytes for prefix tree db.
+
+=item -ptree_cache
+
+Cache size in megs for prefix tree db.
+
+=item -baseport
+
+Set base port number.
+
+=item -recon_port
+
+Set recon port number.
+
+=item -recon_address
+
+Set recon binding addresses. Can be a list of whitespace separated IP addresses or domain names.
+
+=item -hkp_port
+
+Set hkp port number.
+
+=item -hkp_address
+
+Set hkp binding addresses. Can be a list of whitespace separated IP addresses or domain names.
+
+=item -use_port_80
+
+Have the HKP interface listen on port 80, as well as the hkp_port.
+
+=item -basedir
+
+Set base directory.
+
+=item -stdoutlog
+
+Send log messages to stdout instead of log file.
+
+=item -diskptree
+
+Use a disk-based ptree implementation. Slower, but requires far less memory.
+
+=item -nodiskptree
+
+Use in-mem ptree.
+
+=item -max_ptree_nodes
+
+Maximum number of allowed ptree nodes. Only meaningful if -diskptree is set.
+
+=item -prob
+
+Set probability. Used for testing code only.
+
+=item -recon_sync_interval
+
+Set sync interval for reconserver.
+
+=item -gossip_interval
+
+Set time between gossips in minutes.
+
+=item -dontgossip
+
+Don't gossip automatically. Host will still respond to requests from other hosts.
+
+=item -db_sync_interval
+
+Set sync interval for dbserver.
+
+=item -checkpoint_interval
+
+Time period between checkpoints.
+
+=item -recon_checkpoint_interval
+
+Time period between checkpoints for reconserver.
+
+=item -ptree_thresh_mult
+
+Multiple of thresh which specifies minimum node size in prefix tree.
+
+=item -recon_thresh_mult
+
+Multiple of thresh which specifies minimum node size that is included in reconciliation.
+
+=item -max_recover
+
+Maximum number of differences to recover in one round.
+
+=item -http_fetch_size
+
+Number of keys for reconserver to fetch from dbserver in one go.
+
+=item -wserver_timeout
+
+Timeout in seconds for webserver requests.
+
+=item -reconciliation_timeout
+
+Timeout for reconciliation runs in minutes.
+
+=item -stat_hour
+
+Hour at which to run database statistics.
+
+=item -initial_stat
+
+Runs database statistics calculation on boot.
+
+=item -reconciliation_config_timeout
+
+Set timeout in seconds for initial exchange of config info in reconciliation.
+
+=item -missing_keys_timeout
+
+Timeout in seconds for get_missing_keys.
+
+=item -command_timeout
+
+Timeout in seconds for commands set over command socket.
+
+=item -sendmail_cmd
+
+Command used for sending mail.
+
+=item -from_addr
+
+From address used in synchronization emails used to communicate with PKS.
+
+=item -dump_new_only
+
+When doing a database dump, only dump new keys, not keys already contained in a keydump file.
+
+=item -max_outstanding_recon_requests
+
+Maximum number of outstanding requests in reconciliation.
+
+=item -membership_reload_interval
+
+Maximum interval (in hours) at which membership file is reloaded.
+
+=item -disable_mailsync
+
+Disable sending of PKS mailsync messages. ONLY FOR STANDALONE SERVERS!
+THIS IS THE MECHANIASM FOR SENDING UPDATES TO NON-SKS SERVERS.
+
+=item -disable_log_diffs
+
+Disable logging of recent hashset diffs.
+
+=item --help, -help
+
+Displays list of options.
+
+=back
+
+=head1 FILES
+
+Information about important files located in your SKS basedir.
+
+=over
+
+=item bin/sks
+
+The main SKS executable.
+
+=item bin/sks_add_mail
+
+The executable responsible for parsing incoming mails from PKS key servers.
+
+=item bin/sks_build.sh
+
+Script to generate an initial database.
+
+=item mailsync
+
+The mailsync should contains a list of email addresses of PKS keyservers. This file is important, because it ensures that keys submitted directly to an SKS keyserver are also forwarded to PKS keyservers. IMPORTANT : don't add someone to your mailsync file without getting their permission first!
+
+=item membership
+
+With SKS, two hosts can efficiently compare their databases then repair whatever differences are found. In order to set up reconciliation, you first need to find other SKS servers that will agree to gossip with you. The hostname and port of the server that has agreed to do so should be added to this file.
+
+=item sksconf
+
+The configuration file for your SKS server.
+
+=back
+
+=head1 EXAMPLES
+
+=over
+
+=item membership
+
+ keyserver.ahost.org 11370 # Comments are allowed
+ keyserver.foo.org 11370 # Another host with default ports
+
+=item sksconf
+
+ membership_reload_interval: 1
+ initial_stat:
+ hostname: keyserver.example.com
+ from_addr: pgp-public-keys at keyserver.example.com
+
+=item Procmail
+
+ PATH=/path/of/sks/exectuables
+ :0
+ * ^Subject: incremental
+ | /path/of/sks_add_mail /path/to/sks/directory
+
+=item /etc/aliases
+
+ pgp-public-keys: "|/path/of/sks_add_mail /path/to/sks/directory"
+
+=back
+
+=head1 SEE ALSO
+
+ The SKS website is located at http://minskyprimus.net/sks/.
+
+=head1 AUTHOR
+
+The first draft was written by Thomas Sjogren <thomas at northernsecurity.net>.
Added: sks/branches/upstream/sks/current/sks_build.bc.sh
===================================================================
--- sks/branches/upstream/sks/current/sks_build.bc.sh (rev 0)
+++ sks/branches/upstream/sks/current/sks_build.bc.sh 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,17 @@
+#!/bin/bash
+
+# SKS build script.
+# cd to directory with "dump" subdirectory, and run
+# You might want to edit this file to reduce or increase memory usage
+# depending on your system
+
+fail() { echo Command failed unexpectedly. Bailing out; exit -1; }
+SKS=sks.bc
+
+echo === Running fastbuild... ===
+if ! $SKS fastbuild -n 10 -cache 100; then fail; fi
+echo === Cleaning key database... ===
+if ! $SKS cleandb; then fail; fi
+echo === Building ptree database... ===
+if ! $SKS pbuild -cache 20 -ptree_cache 70; then fail; fi
+echo === Done! ===
Added: sks/branches/upstream/sks/current/sks_build.sh
===================================================================
--- sks/branches/upstream/sks/current/sks_build.sh (rev 0)
+++ sks/branches/upstream/sks/current/sks_build.sh 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,48 @@
+#!/bin/bash
+
+# SKS build script.
+# cd to directory with "dump" subdirectory, and run
+# You might want to edit this file to reduce or increase memory usage
+# depending on your system
+
+ask_mode() {
+ echo "Please select the mode in which you want to import the keydump:"
+ echo ""
+ echo "1 - fastbuild"
+ echo " only an index of the keydump is created and the keydump cannot be"
+ echo " removed."
+ echo ""
+ echo "2 - normalbuild"
+ echo ""
+ echo " all the keydump will be imported in a new database. It takes longer"
+ echo " time and more disk space, but the server will run faster (depending"
+ echo " from the source/age of the keydump)."
+ echo " The keydump can be removed after the import."
+ echo ""
+ echo -n "Enter enter the mode (1/2): "
+ read
+ case "$REPLY" in
+ 1)
+ mode="fastbuild"
+ ;;
+ 2)
+ mode="build /var/lib/sks/dump/*.pgp"
+ ;;
+ *)
+ echo "Option unknown. bye!"
+ exit 1
+ ;;
+ esac
+}
+
+fail() { echo Command failed unexpectedly. Bailing out; exit -1; }
+
+ask_mode
+
+echo "=== Running (fast)build... ==="
+if ! /usr/sbin/sks $mode -n 10 -cache 100; then fail; fi
+echo === Cleaning key database... ===
+if ! /usr/sbin/sks cleandb; then fail; fi
+echo === Building ptree database... ===
+if ! /usr/sbin/sks pbuild -cache 20 -ptree_cache 70; then fail; fi
+echo === Done! ===
Property changes on: sks/branches/upstream/sks/current/sks_build.sh
___________________________________________________________________
Added: svn:executable
+ *
Added: sks/branches/upstream/sks/current/sks_do.ml
===================================================================
--- sks/branches/upstream/sks/current/sks_do.ml (rev 0)
+++ sks/branches/upstream/sks/current/sks_do.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,61 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** simple command-line tool for sending actions directly to
+ sks_db and sks_recon processes
+*)
+
+open StdLabels
+open MoreLabels
+open Printf
+open Common
+open Packet
+open DbMessages
+module Unix = UnixLabels
+module PTree = PrefixTree
+module Map = PMap.Map
+
+let fail reason =
+ printf "%s\n" reason;
+ flush stdout;
+ exit (-1)
+
+let send_dbmsg msg =
+ let s = Unix.socket
+ ~domain:(Unix.domain_of_sockaddr db_command_addr)
+ ~kind:Unix.SOCK_STREAM
+ ~protocol:0 in
+ protect ~f:(fun () ->
+ Unix.connect s ~addr:db_command_addr;
+ let cin = Channel.sys_in_from_fd s in
+ let cout = Channel.sys_out_from_fd s in
+ marshal cout msg;
+ let reply = (unmarshal cin).msg in
+ reply
+ )
+ ~finally:(fun () -> Unix.close s)
+
+
+let drop () =
+ match !Settings.anonlist with
+ | [hash_string] ->
+ if String.length hash_string <> 32 then
+ fail "hash should be exactly 32 characters long";
+ let hash = KeyHash.dehexify hash_string in
+ ignore (send_dbmsg (DeleteKey hash))
+ | _ -> fail "Wrong number of arguments: must specify exactly 1 hash"
+
Added: sks/branches/upstream/sks/current/sksdump.ml
===================================================================
--- sks/branches/upstream/sks/current/sksdump.ml (rev 0)
+++ sks/branches/upstream/sks/current/sksdump.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,119 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** takes content of SKS keyserver and creates key dump files from that *)
+
+module F(M:sig end) =
+struct
+ open StdLabels
+ open MoreLabels
+ open Printf
+ open Common
+ open Packet
+
+ let settings = {
+ Keydb.withtxn = !Settings.transactions;
+ Keydb.cache_bytes = !Settings.cache_bytes;
+ Keydb.pagesize = !Settings.pagesize;
+ Keydb.dbdir = Lazy.force Settings.dbdir;
+ Keydb.dumpdir = Lazy.force Settings.dumpdir;
+ }
+
+ module Keydb = Keydb.Unsafe
+
+ let should_dump skey = match skey with
+ | Keydb.KeyString _ | Keydb.Key _ -> true
+ | Keydb.Offset _ | Keydb.LargeOffset _ ->
+ if !Settings.dump_new then false else true
+
+ let rec write_to_file size stream cout =
+ if size <= 0 then ()
+ else
+ match SStream.next stream with
+ | None -> ()
+ | Some (hash,string) ->
+ let remain =
+ try
+ let skey = Keydb.skey_of_string string in
+ if should_dump skey then
+ let keystring = Keydb.keystring_of_skey skey in
+ output_string cout keystring;
+ size - 1
+ else
+ size
+ with
+ e ->
+ eplerror 1 e "Failed attempt to extract key %s"
+ (KeyHash.hexify hash);
+ size
+ in
+ write_to_file remain stream cout
+
+
+ let write_to_fname size stream fname =
+ printf "Dumping keys to file %s\n" fname;
+ flush stdout;
+ let file = open_out fname in
+ protect ~f:(fun () -> write_to_file size stream file)
+ ~finally:(fun () -> close_out file)
+
+ let dump_database dumpdir size name =
+ let (stream,close) = Keydb.create_hash_skey_stream () in
+ let run () =
+ let ctr = ref 0 in
+ while SStream.peek stream <> None do
+ let fname =
+ Filename.concat dumpdir (sprintf "%s-%04d.pgp" name !ctr)
+ in
+ write_to_fname size stream fname;
+ incr ctr
+ done
+ in
+ protect ~f:run ~finally:close
+
+
+
+ exception Argument_error
+
+ (***************************************************************)
+
+ let () = Sys.set_signal Sys.sigusr1 Sys.Signal_ignore
+ let () = Sys.set_signal Sys.sigusr2 Sys.Signal_ignore
+
+ (***************************************************************)
+
+ let run () =
+ try (
+ match !Settings.anonlist with
+ | size::dumpdir::tl ->
+ let name = match tl with
+ | [] -> "sks-dump"
+ | [name] -> name
+ | _ -> raise Argument_error
+ in
+ set_logfile "dump";
+ Keydb.open_dbs settings;
+ let size = int_of_string size in
+ dump_database dumpdir size name
+ | _ ->
+ raise Argument_error
+ ) with Argument_error ->
+ eprintf "wrong number of arguments\n";
+ eprintf "usage: sks dump numkeys dumpdir [dumpname]\n";
+ flush stderr;
+ exit (-1)
+end
Added: sks/branches/upstream/sks/current/smtp_script.py
===================================================================
--- sks/branches/upstream/sks/current/smtp_script.py (rev 0)
+++ sks/branches/upstream/sks/current/smtp_script.py 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,33 @@
+#!/usr/bin/env python2
+
+# Simple script for sending out messages via smtp.
+# This is an alternative to using sendmail
+
+import smtplib
+import os
+import sys
+import string
+
+msg = [ line for line in sys.stdin ]
+msgtext = string.join([line[:-1] for line in msg],sep="\n")
+
+def get_headers(msg):
+ i = 0
+ headers = {}
+ while i < len(msg):
+ line = msg[i]
+ line = line[:-1]
+ if line == "": break
+ (field,data) = line.split(":",1)
+ field = field.lower().strip()
+ data = data.strip()
+ if field == "from":
+ headers["from"] = data
+ elif field == "to":
+ headers["to"] = [ addr.strip() for addr in data.split(",") ]
+ i = i + 1
+ return headers
+
+headers = get_headers(msg)
+smtp = smtplib.SMTP("smtp.earthlink.net")
+smtp.sendmail(headers["from"],headers["to"],msgtext)
Property changes on: sks/branches/upstream/sks/current/smtp_script.py
___________________________________________________________________
Added: svn:executable
+ *
Added: sks/branches/upstream/sks/current/spider.ml
===================================================================
--- sks/branches/upstream/sks/current/spider.ml (rev 0)
+++ sks/branches/upstream/sks/current/spider.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,128 @@
+open StdLabels
+open MoreLabels
+open Printf
+open Pstyle
+open Common
+module Set = PSet.Set
+module Unix = UnixLabels
+
+let stats_timeout = 10
+
+(** Argument parsing *)
+let root =
+ if Array.length Sys.argv = 2 then
+ (Sys.argv.(1),11370)
+ else
+ ("stinkfoot.org",11370)
+
+let input_lines cin =
+ let rec loop lines =
+ match (try Some (input_line cin)
+ with End_of_file -> None)
+ with
+ None -> List.rev lines
+ | Some l -> loop (l::lines)
+ in
+ loop []
+
+let get_ip_opt hostname =
+ if hostname = "localhost" then None
+ else
+ try
+ let he = Unix.gethostbyname hostname in
+ Some he.Unix.h_addr_list
+ with
+ Invalid_argument _ | Not_found -> None
+
+let fetch_url url =
+ let cin = Unix.open_process_in (sprintf "curl -s -m %d \"%s\"" stats_timeout url) in
+ let lines = input_lines cin in
+ match Unix.close_process_in cin with
+ | Unix.WEXITED 0 -> Some lines
+ | _ -> None
+
+let start_line = Str.regexp ".*Gossip Peers.*"
+let whitespace = Str.regexp "[ \t]+"
+
+let get_peer line =
+ if line </> (0,8) = "<tr><td>" then
+ match Str.split whitespace (line </> (8,0)) with
+ | host::port::_ ->
+ let port = int_of_string port in
+ Some (host,port)
+ | _ -> None
+ else
+ None
+
+let build_url (host,port) =
+ sprintf "http://%s:%d/pks/lookup?op=stats" host port
+
+let lines_to_peers lines =
+ let rec skip_to_start = function
+ | line::((_::rest) as tl) ->
+ if Str.string_match start_line line 0 then
+ rest
+ else skip_to_start tl
+ | _ -> []
+ in
+ let lines = skip_to_start lines in
+ let rec get_peers = function
+ | [] -> []
+ | hd::tl -> match get_peer hd with
+ | Some peer -> peer :: get_peers tl
+ | None -> []
+ in
+ get_peers lines
+
+let multi_fetch (host,port) =
+ let ports = [port+1] in
+ (*let ports = if port <> 11370 then 11371::ports else ports in
+ let ports = List.rev (80::ports) in *)
+ let get_peers (host,port) =
+ match fetch_url (build_url (host,port)) with
+ | None -> None
+ | Some x ->
+ let peers = lines_to_peers x in
+ if peers = [] then None
+ else Some peers
+ in
+ let rec loop ports = match ports with
+ [] -> None
+ | port::tl ->
+ match get_peers (host,port) with
+ | Some x -> Some x
+ | None -> loop tl
+ in
+ loop ports
+
+let find_all peer =
+ let visited = ref (Set.singleton None) in
+ let rec dfs peer =
+ let ip = get_ip_opt (fst peer) in
+ if Set.mem ip !visited then
+ []
+ else
+ begin
+ visited := Set.add ip !visited;
+ match multi_fetch peer with
+ | None -> (* retrieval failed *)
+ eprintf "(%s,%d) FAILED\n%!" (fst peer) (snd peer);
+ []
+ | Some peers ->
+ try
+ eprintf "(%s,%d)\n%!" (fst peer) (snd peer);
+ let others = List.concat (List.map ~f:dfs peers) in
+ peer :: others
+ with e ->
+ eprintf "(%s,%d) FAILED with %s\n%!" (fst peer) (snd peer)
+ (Printexc.to_string e);
+ []
+ end
+ in
+ dfs peer
+
+
+let () = if not !Sys.interactive then
+ let servers = find_all root in
+ printf "%d servers found\n" (List.length servers);
+ List.iter ~f:(fun (host,port) -> printf "%s %d\n" host port) servers
Added: sks/branches/upstream/sks/current/stats.ml
===================================================================
--- sks/branches/upstream/sks/current/stats.ml (rev 0)
+++ sks/branches/upstream/sks/current/stats.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,214 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** functions for formatting raw DB stats *)
+open StdLabels
+open MoreLabels
+open Printf
+open Common
+open Packet
+module Unix = UnixLabels
+
+
+let rec last list = match list with
+ [x] -> x | hd::tl -> last tl | _ -> raise Not_found
+
+type histogram_entry =
+ {
+ upper: float;
+ lower: float;
+ mutable num_adds: int;
+ mutable num_dels: int;
+ }
+
+(************************************************************)
+
+external get_tzname : unit -> (string * string) = "caml_get_tzname"
+
+let time_to_tz_string time =
+ let tm = Unix.localtime time in
+ sprintf "%04d-%02d-%02d %02d:%02d:%02d %s"
+ (1900 + tm.Unix.tm_year) (1 + tm.Unix.tm_mon) tm.Unix.tm_mday
+ tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
+ (fst (get_tzname ()))
+
+let time_to_string time =
+ let tm = Unix.localtime time in
+ sprintf "%04d-%02d-%02d %02d:%02d:%02d"
+ (1900 + tm.Unix.tm_year) (1 + tm.Unix.tm_mon) tm.Unix.tm_mday
+ tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec
+
+let time_to_date time =
+ let tm = Unix.localtime time in
+ sprintf "%04d-%02d-%02d"
+ (1900 + tm.Unix.tm_year) (1 + tm.Unix.tm_mon) tm.Unix.tm_mday
+
+let time_to_hour time =
+ let tm = Unix.localtime time in
+ sprintf "%04d-%02d-%02d %02d"
+ (1900 + tm.Unix.tm_year) (1 + tm.Unix.tm_mon) tm.Unix.tm_mday tm.Unix.tm_hour
+
+(************************************************************)
+
+let round_up_to_day time =
+ let tm = Unix.localtime time in
+ let tm = {tm with
+ Unix.tm_hour = 24;
+ Unix.tm_min = 0;
+ Unix.tm_sec = 0;}
+ in
+ let (time,tm) = Unix.mktime tm in
+ time
+
+let round_up_to_hour time =
+ let tm = Unix.localtime time in
+ let tm = {tm with
+ Unix.tm_min = 60;
+ Unix.tm_sec = 0;}
+ in
+ let (time,tm) = Unix.mktime tm in
+ time
+
+
+(************************************************************)
+
+let histogram_log ~now binsize log =
+ let oldtime = fst log.(0) in
+ let newtime = now in
+
+ let nbins = truncate (ceil ((newtime -. oldtime) /. binsize)) in
+ let bins = Array.init nbins
+ ~f:(fun i -> {
+ upper = newtime -. binsize *. float i;
+ lower = newtime -. binsize *. float (i + 1);
+ num_adds = 0; num_dels = 0; } )
+ in
+ Array.iter log
+ ~f:(fun (time,op) ->
+ let bin_idx = truncate ((newtime -. time) /. binsize) in
+ let bin = bins.(bin_idx) in
+ if time < bin.lower || time > bin.upper
+ then failwith "bad bin placement";
+ match op with
+ Add _ -> bin.num_adds <- bin.num_adds + 1
+ | Delete _ -> bin.num_dels <- bin.num_dels + 1
+ );
+ bins
+
+(************************************************************)
+
+let histogram_to_table time_to_string histogram =
+ let hist_entry_to_table_entry entry =
+ sprintf "<tr><td>%s</td><td>%d</td><td>%d</td></tr>"
+ (time_to_string entry.lower)
+ (entry.num_adds - entry.num_dels) entry.num_dels
+ in
+ let table_entries =
+ List.map ~f:hist_entry_to_table_entry (Array.to_list histogram)
+ in
+ "<table summary=\"Statistics\" border=\"1\">\n" ^
+ "<tr><td>Time</td><td>New Keys</td><td>Updated Keys</td></tr>\n" ^
+ String.concat "\n" table_entries ^
+ "\n</table>\n"
+
+
+(************************************************************)
+
+let info_tables () =
+ let settings =
+ sprintf
+ "<h2>Settings</h2>
+ <table summary=\"Keyserver Settings\">
+ <tr><td>Hostname:</td><td>%s</td></tr>
+ <tr><td>Version:</td><td>%s</td></tr>
+ <tr><td>HTTP port:</td><td>%d</td></tr>
+ <tr><td>Recon port:</td><td>%d</td></tr>
+ <tr><td>Debug level:</td><td>%d</td></tr>
+</table>\r\n"
+ !Settings.hostname Common.version
+ http_port recon_port !Settings.debuglevel
+ in
+ let gossip_peers =
+ let peers = Array.to_list (Membership.get_names ()) in
+ let peers = List.map ~f:(fun peer -> sprintf "<tr><td>%s</td></tr>\n" peer) peers in
+ sprintf "<h2>Gossip Peers</h2>\n<table summary=\"Gossip Peers\">\n%s</table>"
+ (String.concat ~sep:"" peers)
+ in
+ let mail_peers =
+ let peers =
+ try Membership.get_mailsync_partners ()
+ with Failure "No partners specified" -> []
+ in
+ let peers = List.map ~f:(fun s -> sprintf "<tr><td>%s</td></tr>\n" s) peers in
+ sprintf "<h2>Outgoing Mailsync Peers</h2>\n<table summary=\"Mailsync Peers\">\n%s</table>"
+ (String.concat ~sep:"" peers)
+ in
+ sprintf "%s\n\n<table summary=\"Keyserver Peers\" width=\"100%%\">
+<tr valign=\"top\"><td>
+%s
+</td><td>
+%s
+</td></tr></table>\r\n"
+ settings gossip_peers mail_peers
+
+
+(************************************************************)
+
+let generate_html_stats_page log size =
+ let log = Array.of_list log in
+ let now = Unix.gettimeofday () in
+ let num_keys = sprintf "<p>Total number of keys: %d</p>\n" size in
+ let title =
+ sprintf
+ "SKS OpenPGP Keyserver statistics<br />Taken at %s"
+ (time_to_tz_string now)
+ in
+ if Array.length log = 0 then
+ HtmlTemplates.page
+ ~title
+ ~body:(info_tables () ^ num_keys ^ "\n<p>No recent transactions</p>")
+ else
+ let last_time = fst log.(Array.length log - 1) in
+ let daily_histogram = histogram_log (60. *. 60. *. 24.) log
+ ~now:(round_up_to_day last_time)
+ and hourly_histogram = histogram_log (60. *. 60.) log
+ ~now:(round_up_to_hour last_time)
+ in
+ let daily_table = histogram_to_table time_to_date daily_histogram
+ and hourly_table = histogram_to_table time_to_hour hourly_histogram
+ in
+ let body =
+ info_tables () ^
+ "<h2>Statistics</h2>" ^
+ num_keys ^
+ "<h3>Daily Histogram</h3>\n" ^
+ daily_table ^
+ "<h3>Hourly Histogram</h3>\n" ^
+ hourly_table
+ in
+ HtmlTemplates.page ~title ~body
+
+
+let generate_html_stats_page_nostats () =
+ let body = info_tables () ^
+ "<br /> Database statistics are time-consuming and so are " ^
+ "only calculated once per day"
+ in
+ let title = "Stats not calculated yet" in
+ HtmlTemplates.page ~title ~body
+
+
Added: sks/branches/upstream/sks/current/tester.ml
===================================================================
--- sks/branches/upstream/sks/current/tester.ml (rev 0)
+++ sks/branches/upstream/sks/current/tester.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,110 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+open Printf
+open Common
+open Packet
+open DbMessages
+module Unix = UnixLabels
+
+let settings = {
+ Keydb.withtxn = !Settings.transactions;
+ Keydb.cache_bytes = !Settings.cache_bytes;
+ Keydb.pagesize = !Settings.pagesize;
+ Keydb.dbdir = Lazy.force Settings.dbdir;
+ Keydb.dumpdir = Lazy.force Settings.dumpdir;
+}
+
+module Keydb = Keydb.Safe
+
+
+let send_msg addr msg =
+ let s = Unix.socket
+ ~domain:(Unix.domain_of_sockaddr addr)
+ ~kind:Unix.SOCK_STREAM
+ ~protocol:0 in
+ protect ~f:( fun () ->
+ Unix.connect s ~addr:addr;
+ let cin = Channel.sys_in_from_fd s
+ and cout = Channel.sys_out_from_fd s in
+ marshal cout msg;
+ let reply = unmarshal cin in
+ printf "Reply received: %s\n" (msg_to_string reply.msg);
+ reply
+ )
+ ~finally:(fun () -> Unix.close s)
+
+let send_msg_noreply addr msg =
+ let s = Unix.socket
+ ~domain:(Unix.domain_of_sockaddr addr)
+ ~kind:Unix.SOCK_STREAM
+ ~protocol:0 in
+ protect ~f:(fun () ->
+ Unix.connect s ~addr:addr;
+ let cout = Channel.sys_out_from_fd s in
+ marshal cout msg
+ )
+ ~finally:(fun () -> Unix.close s)
+
+
+let print_key key =
+ let ids = Key.get_ids key in
+ List.iter ~f:(printf "%s | ") ids;
+ print_newline ()
+
+let word_query addr string =
+ let words = Utils.extract_words string in
+ let reply = send_msg addr (WordQuery words) in
+ match reply.msg with
+ | Keys keys ->
+ List.iter ~f:print_key keys;
+ printf "\n-------------------\n"
+ | _ ->
+ printf "Unexpected response\n"; flush stdout
+
+let rec is_sorted list = match list with
+ [] -> true
+ | hd::[] -> true
+ | hd1::hd2::tl -> hd2 > hd1 && is_sorted (hd2::tl)
+
+let rec last list = match list with
+ [] -> raise Not_found
+ | hd::[] -> hd
+ | hd::tl -> last tl
+
+let get_log addr ts =
+ let resp = send_msg addr (LogQuery ts) in
+ match resp.msg with
+ LogResp log -> log
+ | _ -> failwith "Unexpected response"
+
+let ts pair = fst pair
+
+let first log = List.hd log
+let first_ts log = ts (first log)
+
+let last_ts log =
+ let (ts,hash) = last log in
+ ts
+
+(*
+let rec get_all ts accum =
+ let hashes = send_msg (LogQuery ts)
+
+*)
Added: sks/branches/upstream/sks/current/tz.c
===================================================================
--- sks/branches/upstream/sks/current/tz.c (rev 0)
+++ sks/branches/upstream/sks/current/tz.c 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,29 @@
+/*
+ This file is part of SKS. SKS 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
+*/
+
+#include <stdlib.h>
+#include <time.h>
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/custom.h>
+#include <caml/fail.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+#define CRC24_INIT 0xb704ceL
+
+// Simple timezone calculations
+
Added: sks/branches/upstream/sks/current/unit_tests.ml
===================================================================
--- sks/branches/upstream/sks/current/unit_tests.ml (rev 0)
+++ sks/branches/upstream/sks/current/unit_tests.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,28 @@
+open Printf
+open Common
+
+let run () =
+ printf "Running Decode unit tests:%!";
+ begin
+ try Decode_test.run ()
+ with Unit_test_failure s ->
+ printf "\nUnit test failure: %s\n%!" s
+ end;
+ printf "Done\n%!";
+
+ printf "Running Number unit tests:%!";
+ begin
+ try Number_test.run ()
+ with Unit_test_failure s ->
+ printf "\nUnit test failure: %s\n%!" s
+ end;
+ printf "Done\n%!";
+
+ printf "Running Poly unit tests:%!";
+ begin
+ try Poly_test.run ()
+ with Unit_test_failure s ->
+ printf "\nUnit test failure: %s\n%!" s
+ end;
+ printf "Done\n%!";
+
Added: sks/branches/upstream/sks/current/update_subkeys.ml
===================================================================
--- sks/branches/upstream/sks/current/update_subkeys.ml (rev 0)
+++ sks/branches/upstream/sks/current/update_subkeys.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,131 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+open StdLabels
+open MoreLabels
+open Printf
+open Arg
+open Common
+module Set = PSet.Set
+module Map = PMap.Map
+module Unix = UnixLabels
+open Packet
+open Bdb
+
+let settings = {
+ Keydb.withtxn = !Settings.transactions;
+ Keydb.cache_bytes = !Settings.cache_bytes;
+ Keydb.pagesize = !Settings.pagesize;
+ Keydb.dbdir = Lazy.force Settings.dbdir;
+ Keydb.dumpdir = Lazy.force Settings.dumpdir;
+}
+
+(** we need full keydb access because we're playing directly with
+ databases and cursors and such
+*)
+module Keydb = Keydb.Unsafe
+
+type update = { keyid: string;
+ hash: string;
+ }
+
+let ( |= ) map key = Map.find key map
+let ( |< ) map (key,data) = Map.add ~key ~data map
+
+let at_once = match !Settings.n with
+ 0 -> 10000
+ | n -> n * 1000
+
+let subkeyids_from_key key =
+ let (keyid,subkey_keyids) = Fingerprint.keyids_from_key ~short:true key in
+ subkey_keyids
+
+(** returns a copy of the list without duplicates in sorted order *)
+let sort_dedup list =
+ let list = List.sort ~cmp:(fun x y -> compare y x) list in
+ let rec dedup list partial = match list with
+ | [] -> partial
+ | hd::[] -> dedup [] (hd::partial)
+ | hd1::hd2::tl ->
+ if hd1 = hd2 then dedup (hd2::tl) partial
+ else dedup (hd2::tl) (hd1::partial)
+ in
+ dedup list []
+
+
+(** takes a list of updates and applies them to the database *)
+let apply_updates updates =
+ let dbs = Keydb.get_dbs () in
+ perror "%d updates found. Applying to database" (List.length updates);
+ let updates = sort_dedup updates in
+ let txn = Keydb.txn_begin () in
+ try
+ List.iter ~f:(fun update ->
+ try Db.put ?txn dbs.Keydb.subkey_keyid ~key:update.keyid
+ ~data:update.hash [Db.NODUPDATA]
+ with
+ Key_exists -> ()
+ )
+ updates;
+ Keydb.txn_commit txn;
+ perror "Application of updates complete."
+ with
+ | Bdb.DBError s as e ->
+ eplerror 0 e "Fatal database error";
+ raise Sys.Break
+ | e ->
+ eplerror 1 e "apply_md_updates failed -- aborting txn";
+ Keydb.txn_abort txn;
+ raise e
+
+(** iterate through the database, extracting updates that need to be
+ applied and applies them *)
+let fix_keyids () =
+ perror "Beginning subkeyid update process";
+ let updates = ref [] in
+ let ctr = ref 0 in
+
+ let process_key ~hash ~key =
+ let subkeyids = subkeyids_from_key key in
+ let new_updates =
+ List.map subkeyids
+ ~f:(fun subkeyid -> { keyid = subkeyid; hash = hash })
+ in
+ updates := List.rev_append new_updates !updates;
+ ctr := !ctr + List.length new_updates;
+ if !ctr >= at_once then (
+ apply_updates !updates;
+ ctr := 0;
+ updates := []
+ )
+ in
+ Keydb.iter process_key;
+ (* need one more call to apply_updates to add the final batch *)
+ apply_updates !updates
+
+let run () =
+ set_logfile "update_subkeys";
+ Keydb.open_dbs settings;
+ perror "Keydb opened";
+
+ fix_keyids ();
+ perror "Subkey update complete. Checkpointing database.";
+ Keydb.checkpoint ();
+ perror "Checkpoint complete. Closing.";
+ Keydb.close_dbs ();
+ perror "Database closed.";
+
Added: sks/branches/upstream/sks/current/utils.ml
===================================================================
--- sks/branches/upstream/sks/current/utils.ml (rev 0)
+++ sks/branches/upstream/sks/current/utils.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,330 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** A variety of simple utilities *)
+open StdLabels
+open MoreLabels
+module Unix=UnixLabels
+module Set = PSet.Set
+module Map = PMap.Map
+
+open Printf
+
+let compose f g x = f (g x)
+let iceil x = int_of_float (ceil x)
+let ifloor x = int_of_float (floor x)
+
+(** Binary search.
+
+ (f i) returns -1, 0 or 1, and should be monotonic.
+ f should have values for all i in [low,high], inclusive.
+
+ if \E i \in [low,high] such that (f i) = 0,
+ then such an i is returned.
+ Otherwise, i is returned such that
+ (f i = 1) and (f (i-1)=-1).
+ Unless it's all 1's or all -1s. If it's all 1s, the first 1 is returned.
+ If it's all -1's, then raise Not_found
+*)
+let bsearch ~f ~low ~high =
+ let rec bsearch ~f ~low ~high =
+ if low = high then
+ match f low with
+ 0 -> low
+ | 1 -> low
+ | _ -> raise Not_found
+ else let mid = (low + high)/2 in
+ match f mid with
+ 0 -> mid
+ | 1 -> bsearch ~f ~low ~high:mid
+ | (-1) -> bsearch ~f ~low:(mid+1) ~high
+ | _ -> raise (Failure ("bsearch: " ^
+ "Search returned value other than -1,0,1"))
+ in
+ if high < low
+ then raise Not_found
+ else bsearch ~f ~low ~high
+
+(** similar to bsearch, but returns (index,value) pair.
+ f is expected to return a (test,value) pair,
+ where test is like the output of f above, and value is some
+ related value. *)
+let bsearch_val ~f ~low ~high =
+ let rec bsearch_val ~f ~low ~high =
+ (* print_string "."; flush stdout; *)
+ if low = high then
+ let (test,value) = f low in
+ match test with
+ 0 -> (low,value)
+ | 1 -> (low,value)
+ | _ -> raise Not_found
+ else
+ let mid = (low + high)/2 in
+ let (test,value) = f mid in
+ match test with
+ 0 -> (mid,value)
+ | 1 -> bsearch_val ~f ~low ~high:mid
+ | (-1) -> bsearch_val ~f ~low:(mid+1) ~high
+ | _ -> raise (Failure ("bsearch: " ^
+ "Search returned value other than -1,0,1"))
+ in
+ if high < low
+ then raise Not_found
+ else bsearch_val ~f ~low ~high
+
+
+(*******************************************************************)
+(*******************************************************************)
+(*******************************************************************)
+
+let is_alnum char =
+ let num = int_of_char char in
+ (num >= int_of_char 'A' && num <= int_of_char 'Z') ||
+ (num >= int_of_char 'a' && num <= int_of_char 'z') ||
+ (num >= int_of_char '0' && num <= int_of_char '9') ||
+ (num >= 192 && num <= 255)
+
+
+let rec extract_words_rec s ~start ~len partial =
+ let one () = Set.add (String.lowercase (String.sub s start len)) partial in
+ if start + len = String.length s
+ then ( if len = 0 then partial
+ else one ())
+ else (
+ if is_alnum s.[start + len]
+ then extract_words_rec s ~start ~len:(len + 1) partial
+ else ( if len = 0
+ then extract_words_rec s ~start:(start + 1) ~len partial
+ else extract_words_rec s ~start:(start + len) ~len:0
+ (one ())
+ )
+ )
+
+(** returns the set of words found in string s *)
+let extract_word_set s =
+ extract_words_rec s ~start:0 ~len:0 Set.empty
+
+(** returns a list of words found in string s *)
+let extract_words s =
+ Set.elements (extract_word_set s)
+
+
+(*******************************************************************)
+(* START: Miscellaneous *****************************************)
+(*******************************************************************)
+
+(** print results of a test *)
+let ptest str bool = match bool with
+ true -> printf " Test %s passed\n" str; flush stdout
+| false -> printf "*** Test %s FAILED ***" str; flush stdout
+
+(** For all values i between first (incl) and last (excl) , evaluate func
+ on i and partial *)
+let rec for_loop first last partial func =
+ if first = last
+ then partial
+ else for_loop (first+1) last (func first partial) func
+
+
+(** For all pairs (i,j) of elements in list where i!=j and i < j, evaluate
+ func (i,j) partial, building up partial as you go. *)
+let rec pair_loop func partial list = match list with
+ [] -> partial
+| i::tl ->
+ let rec i_loop list partial = match list with
+ [] -> partial
+ | j::tl -> i_loop tl (func (i,j) partial) in
+ pair_loop func (i_loop tl partial) tl
+
+(** Note: does not terminate upon finding a false instance *)
+let for_all_pairs test list =
+ let test_join (i,j) partial = (test i j) && partial in
+ pair_loop test_join true list
+
+let neq_test (x,y) partial =
+ (x != y) && partial
+
+let time func =
+ let s_time = Unix.gettimeofday () in
+ func ();
+ (Unix.gettimeofday ()) -. s_time
+
+let random_int low high =
+ (Random.int (high-low)) + low
+
+let char_width = 8
+
+let hexstring digest =
+ let result = String.create (String.length digest * 2) in
+ let hex = "0123456789ABCDEF" in
+ for i = 0 to String.length digest - 1 do
+ let c = Char.code digest.[i] in
+ result.[2*i] <- hex.[c lsr 4];
+ result.[2*i+1] <- hex.[c land 0xF]
+ done;
+ result
+
+let rec int_from_bstring_rec string ~pos ~len partial =
+ if len = 0 then partial
+ else
+ int_from_bstring_rec string ~pos:(pos + 1) ~len:(len-1)
+ ((partial lsl char_width) + (int_of_char string.[pos]))
+
+let int_from_bstring string ~pos ~len =
+ int_from_bstring_rec string ~pos ~len 0
+
+let bstring_of_int i =
+ let s = String.create 4 in
+ s.[3] <- char_of_int (i land 0xFF);
+ s.[2] <- char_of_int ((i lsr 8) land 0xFF);
+ s.[1] <- char_of_int ((i lsr 16) land 0xFF);
+ s.[0] <- char_of_int ((i lsr 24) land 0xFF);
+ s
+
+(* tail recursive *)
+let rec apply count func start = match count with
+ 0 -> start
+| _ -> apply (count-1) func (func start)
+
+let get_bit ~pos i = (i lsr pos) land 1
+
+let create_rand_bits () =
+ let bits = ref (Random.bits ())
+ and pos = ref 0 in
+ let bitfunc () =
+ if !pos > 30 then
+ (pos := 0; bits := Random.bits ());
+ let rval = get_bit ~pos:!pos !bits in
+ pos := !pos + 1;
+ rval
+ in
+ bitfunc
+
+let rbit = create_rand_bits ()
+
+(* FIX: this depends on the interals of the sort mechanism.
+ A rather cheap trick, really. It does work at present, though *)
+let permute list =
+ let cmp i j = (rbit ()) * 2 - 1 in
+ List.sort ~cmp list
+
+(* Exception Handling *)
+
+exception FinalDouble of exn * exn
+exception Final of exn
+
+let try_finally ~f ~finally =
+ let finally_called = ref false in
+ try
+ let rval = f () in
+ finally_called := true;
+ finally ();
+ rval
+ with x ->
+ if not !finally_called
+ then
+ begin
+ (try finally () with
+ y -> raise (FinalDouble (x,y)));
+ raise x
+ end
+
+ else raise (Final x)
+
+
+let rec rfold ~f low high ~init =
+ if low >= high then init
+ else (
+ rfold ~f (low + 1) high ~init:(f init low)
+ )
+
+let rec fill_random_string rfunc string ~pos ~len =
+ if pos < len then
+ let steps =
+ if len - pos > 3 then 3 else len - pos in
+ (* CR yminsky: this is basically a bug. We double-call rfunc for no reason.
+ I'm worried about changing this because there is probably some assumptions about
+ the random generation being deterministic *)
+ let _bits = rfunc () in
+ for i = 0 to steps - 1 do
+ string.[pos + i] <-
+ char_of_int (0xFF land ((rfunc ()) lsr (8 * i)))
+ done;
+ fill_random_string rfunc string ~pos:(pos + steps) ~len
+ else
+ ()
+
+let random_string rfunc len =
+ let string = String.create len in
+ fill_random_string rfunc string ~pos:0 ~len;
+ string
+
+let dedup list = Set.elements (Set.of_list list)
+
+(** returns memoized version of any fucntion with argument unit *)
+let unit_memoize f =
+ let store = ref None in
+ (fun () ->
+ match !store with
+ | Some x -> x
+ | None ->
+ let rval = f () in
+ store := Some rval;
+ rval
+ )
+
+(** returns memoized version of any function with a single argument *)
+let memoize f =
+ let store = Hashtbl.create 10 in
+ (fun x ->
+ try Hashtbl.find store x
+ with Not_found ->
+ let rval = f x in
+ Hashtbl.add store ~key:x ~data:rval;
+ rval
+ )
+
+(** object-based memoizer. Main advantage here is that you can
+ clear the cache. *)
+class ['a] memo (f:'a) =
+object (self)
+ val store = Hashtbl.create 10
+
+ method apply x =
+ try Hashtbl.find store x
+ with Not_found ->
+ let rval = f x in
+ Hashtbl.add store ~key:x ~data:rval;
+ rval
+
+ method clear = Hashtbl.clear store
+
+end
+
+
+let filter_map ~f list =
+ let rec loop list accum = match list with
+ [] -> List.rev accum
+ | hd :: tl ->
+ match f hd with
+ None -> loop tl accum
+ | Some x -> loop tl (x :: accum)
+ in
+ loop list []
+
+
+
Added: sks/branches/upstream/sks/current/wserver.ml
===================================================================
--- sks/branches/upstream/sks/current/wserver.ml (rev 0)
+++ sks/branches/upstream/sks/current/wserver.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,326 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** simple web server code *)
+
+open StdLabels
+open MoreLabels
+open Printf
+open Common
+module Unix = UnixLabels
+open Unix
+
+module Map = PMap.Map
+module Set = PSet.Set
+
+exception Not_implemented of string
+exception Misc_error of string
+exception Page_not_found of string
+
+let ( |= ) map key = Map.find key map
+let ( |< ) map (key,data) = Map.add ~key ~data map
+
+let hexa_digit x =
+ if x >= 10 then Char.chr (Char.code 'A' + x - 10)
+ else Char.chr (Char.code '0' + x)
+
+let hexa_val conf =
+ match conf with
+ '0'..'9' -> Char.code conf - Char.code '0'
+ | 'a'..'f' -> Char.code conf - Char.code 'a' + 10
+ | 'A'..'F' -> Char.code conf - Char.code 'A' + 10
+ | _ -> 0
+
+let decode s =
+ let rec need_decode i =
+ if i < String.length s then
+ match s.[i] with
+ '%' | '+' -> true
+ | _ -> need_decode (succ i)
+ else false
+ in
+ let rec compute_len i i1 =
+ if i < String.length s then
+ let i =
+ match s.[i] with
+ '%' when i + 2 < String.length s -> i + 3
+ | _ -> succ i
+ in
+ compute_len i (succ i1)
+ else i1
+ in
+ let rec copy_decode_in s1 i i1 =
+ if i < String.length s then
+ let i =
+ match s.[i] with
+ '%' when i + 2 < String.length s ->
+ let v = hexa_val s.[i + 1] * 16 + hexa_val s.[i + 2] in
+ s1.[i1] <- Char.chr v; i + 3
+ | '+' -> s1.[i1] <- ' '; succ i
+ | x -> s1.[i1] <- x; succ i
+ in
+ copy_decode_in s1 i (succ i1)
+ else s1
+ in
+ let rec strip_heading_and_trailing_spaces s =
+ if String.length s > 0 then
+ if s.[0] == ' ' then
+ strip_heading_and_trailing_spaces
+ (String.sub s 1 (String.length s - 1))
+ else if s.[String.length s - 1] == ' ' then
+ strip_heading_and_trailing_spaces
+ (String.sub s 0 (String.length s - 1))
+ else s
+ else s
+ in
+ if need_decode 0 then
+ let len = compute_len 0 0 in
+ let s1 = String.create len in
+ strip_heading_and_trailing_spaces (copy_decode_in s1 0 0)
+ else s
+
+
+let special x = List.mem x ['='; '&'; '"'; '\r'; '\n'; '+']
+
+let encode s =
+ let rec need_code i =
+ if i < String.length s then
+ match s.[i] with
+ ' ' -> true
+ | x -> if special x then true else need_code (succ i)
+ else false
+ in
+ let rec compute_len i i1 =
+ if i < String.length s then
+ let i1 = if special s.[i] then i1 + 3 else succ i1 in
+ compute_len (succ i) i1
+ else i1
+ in
+ let rec copy_code_in s1 i i1 =
+ if i < String.length s then
+ let i1 =
+ match s.[i] with
+ ' ' -> s1.[i1] <- '+'; succ i1
+ | c ->
+ if special c then
+ begin
+ s1.[i1] <- '%';
+ s1.[i1 + 1] <- hexa_digit (Char.code c / 16);
+ s1.[i1 + 2] <- hexa_digit (Char.code c mod 16);
+ i1 + 3
+ end
+ else begin s1.[i1] <- c; succ i1 end
+ in
+ copy_code_in s1 (succ i) i1
+ else s1
+ in
+ if need_code 0 then
+ let len = compute_len 0 0 in copy_code_in (String.create len) 0 0
+ else s
+
+let stripchars = Set.of_list [ ' '; '\t'; '\n'; '\r' ]
+
+let strip s =
+ let start = ref 0 in
+ while (!start < String.length s
+ && Set.mem s.[!start] stripchars) do
+ incr start
+ done;
+ let stop = ref (String.length s - 1) in
+ while (!stop >= 0 && Set.mem s.[!stop] stripchars) do
+ decr stop
+ done;
+ if !stop >= !start then
+ String.sub s ~pos:!start ~len:(!stop - !start + 1)
+ else
+ ""
+
+
+type 'a request = | GET of (string * (string,string) Map.t)
+ | POST of (string * (string,string) Map.t * 'a)
+
+let whitespace = Str.regexp "[ \t\n\r]+"
+let eol = Str.regexp "\r?\n"
+
+let get_all cin =
+ let buf = Buffer.create 0 in
+ (try Buffer.add_channel buf cin 10000
+ with End_of_file -> ());
+ Buffer.contents buf
+
+let get_lines cin =
+ Str.split eol (get_all cin)
+
+let max_post_length = 5 * 1024 * 1024 (* posts restricted to 5 Megs or less *)
+
+let parse_post headers cin =
+ try
+ let lengthstr = headers |= "content-length" in
+ let len = int_of_string lengthstr in
+ if len > max_post_length
+ then raise (Misc_error (sprintf "POST data too long: %f megs"
+ (float len /. 1024. /. 1024.)));
+ let rest = String.create len in
+ really_input cin rest 0 len;
+ rest
+ with
+ Not_found ->
+ failwith "parse_post failed for lack of a content-length header"
+
+let is_blank line =
+ String.length line = 0 || line.[0] = '\r'
+
+let rec parse_headers map cin =
+ let line = input_line cin in (* DOS attack: input_line is unsafe on sockets *)
+ if is_blank line then map
+ else
+ let colonpos = try String.index line ':' with
+ Not_found -> failwith "Error parsing headers: no colon found"
+ in
+ let key = String.sub line ~pos:0 ~len:colonpos
+ and data = String.sub line ~pos:(colonpos + 1)
+ ~len:(String.length line - colonpos - 1)
+ in
+ parse_headers (map |< (String.lowercase key, strip data)) cin
+
+let parse_request cin =
+ let line = input_line cin in (* DOS attack: input_line is unsafe on sockets *)
+ let pieces = Str.split whitespace line in
+ let headers = parse_headers Map.empty cin in
+ match List.hd pieces with
+ "GET" -> GET (List.nth pieces 1,headers)
+ | "POST" -> POST (List.nth pieces 1,headers,
+ parse_post headers cin)
+ | _ -> failwith "Malformed header"
+
+let headers_to_string map =
+ let pieces = List.map ~f:(fun (x,y) -> sprintf "%s:%s" x y)
+ (Map.to_alist map)
+ in
+ "\n" ^ (String.concat "\n" pieces)
+
+let request_to_string request =
+ let (kind,req,headers) =
+ match request with
+ | GET (req,header_map) ->
+ ("GET",req,headers_to_string header_map)
+ | POST (req,header_map,_) ->
+ ("POST",req,headers_to_string header_map)
+ in
+ sprintf "(%s,%s,[%s])" kind req headers
+
+let request_to_string_short request =
+ let (kind,request) =
+ match request with
+ | GET (req,header_map) ->
+ ("GET",req)
+ | POST (req,header_map,_) ->
+ ("POST",req)
+ in
+ sprintf "(%s %s)" kind request
+
+
+
+
+let send_result cout ?(error_code = 200) ?(content_type = "text/html; charset=UTF-8") ?(count = -1) body =
+ fprintf cout "HTTP/1.0 %03d OK\r\n" error_code;
+ fprintf cout "Server: sks_www/%s\r\n" version;
+ fprintf cout "Content-length: %u\r\n" (String.length body + 2);
+ if count >= 0 then
+ fprintf cout "X-HKP-Results-Count: %d\r\n" count;
+ fprintf cout "Content-type: %s\r\n\r\n" content_type;
+ fprintf cout "%s\r\n" body;
+ flush cout
+
+
+let accept_connection f ~recover_timeout addr cin cout =
+ begin
+ try
+ let request = parse_request cin in
+ let output_chan = Channel.new_buffer_outc 0 in
+ try
+ let (content_type, count) = f addr request output_chan#upcast in
+ let output = output_chan#contents in
+ send_result cout ~content_type ~count output
+ with
+ | Eventloop.SigAlarm ->
+ ignore (Unix.alarm recover_timeout);
+ plerror 2 "request %s timed out" (request_to_string request);
+ let output =
+ HtmlTemplates.page ~title:"Time Out"
+ ~body:(sprintf "Error handling request %s: Timed out after %d seconds"
+ (request_to_string_short request) !Settings.wserver_timeout)
+ in
+ send_result cout ~error_code:408 output
+
+ | Sys.Break as e ->
+ plerror 1 "Break occured while processing HKP request %s"
+ (request_to_string request);
+ raise e
+
+ | Not_implemented s ->
+ ignore (Unix.alarm recover_timeout);
+ plerror 2 "Error handling request %s: %s"
+ (request_to_string request) ("Not implemented: " ^ s);
+ let output =
+ HtmlTemplates.page ~title:"Not implemented"
+ ~body:(sprintf "Error handling request %s: %s not implemented."
+ (request_to_string request) s)
+ in
+ send_result cout ~error_code:501 output
+
+ | Page_not_found s ->
+ ignore (Unix.alarm recover_timeout);
+ plerror 2 "Page not found: %s" s;
+ let output = HtmlTemplates.page ~title:"Page not found"
+ ~body:(sprintf "Page not found: %s" s)
+ in
+ send_result cout ~error_code:404 output
+
+ | Misc_error s ->
+ ignore (Unix.alarm recover_timeout);
+ plerror 2 "Error handling request %s: %s"
+ (request_to_string request) s;
+ let output = HtmlTemplates.page ~title:"Error handling request"
+ ~body:(sprintf "Error handling request: %s" s)
+ in
+ send_result cout ~error_code:500 output
+
+ | e ->
+ ignore (Unix.alarm recover_timeout);
+ plerror 2 "Error handling request %s: %s"
+ (request_to_string request) (Common.err_to_string e);
+ let output =
+ (HtmlTemplates.page ~title:"Error handling request"
+ ~body:(sprintf "Error handling request. Exception raised: %s"
+ (Common.err_to_string e)))
+ in
+ send_result cout ~error_code:500 output
+ with
+ | Sys.Break as e -> raise e
+ | Eventloop.SigAlarm ->
+ ignore (Unix.alarm recover_timeout);
+ let output =
+ HtmlTemplates.page ~title:"Timeout"
+ ~body:(sprintf "Request timed during request parsing after %d seconds"
+ !Settings.wserver_timeout)
+ in
+ send_result cout ~error_code:408 output
+ | e ->
+ eplerror 5 e "Miscellaneous error"
+ end;
+ []
Added: sks/branches/upstream/sks/current/zZp.ml
===================================================================
--- sks/branches/upstream/sks/current/zZp.ml (rev 0)
+++ sks/branches/upstream/sks/current/zZp.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,211 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Field of integers mod p (for a settable prime p) *)
+open StdLabels
+open MoreLabels
+module Unix=UnixLabels
+open Printf
+
+module N = Number
+open Number.Infix
+(* open Big_int *)
+
+type zz = Number.z
+type zzref = Number.z ref
+type mut_array = zz array
+
+let order = ref two
+let nbits = ref 0
+let nbytes = ref 0
+
+let two = two
+let zero = zero
+let one = one
+
+let set_order value =
+ order := value;
+ nbits := N.nbits !order;
+ nbytes := !nbits / 8 + (if !nbits mod 8 = 0 then 0 else 1)
+
+let num_bytes () = !nbytes
+let of_bytes bytes = N.of_bytes bytes
+let to_bytes n = N.to_bytes ~nbytes:!nbytes (n %! !order)
+let of_int i = (Number.of_int i) %! !order
+let to_N x = x
+let of_N x = x %! !order
+
+let add x y = (x +! y) %! !order
+let sub x y = (x -! y) %! !order
+let mul x y = (x *! y) %! !order
+let mult x y = (x *! y) %! !order
+let imult x y = (Number.int_mult y x) %! !order
+
+
+
+let add_fast x y = (x +! y)
+let mul_fast x y = (x *! y)
+let mult_fast x y = (x *! y)
+let canonicalize x = x %! !order
+
+let shl x i =
+ x *! Number.int_posint_power 2 i
+
+let square x = (x *! x) %! !order
+let square_fast x = x *! x
+
+let imul x y = (y *! x) %! !order
+let neg x = !order -! x
+
+let inv x =
+ if x =! zero then raise (Invalid_argument "ZZp.inv: Attempt to invert 0");
+ let (u,_,_) = N.gcd_ex x !order in u %! !order
+
+
+let div x y = (x *! (inv y)) %! !order
+let sub_fast x y = x -! y
+
+let lt = ( <! )
+let gt = ( >! )
+let eq = ( =! )
+let neq x y = not (x =! y)
+
+let to_string = Number.to_string
+let of_string = Number.of_string
+let print x = print_string (to_string x)
+
+let points n = Array.init n
+ ~f:(fun i ->
+ let ival = ((i + 1) / 2) * (if i mod 2 = 0 then 1 else (-1)) in
+ Number.of_int ival)
+
+let svalues n =
+ Array.init n ~f:(fun i -> one)
+
+(* In-place operations. Since we're using Big_int, there are no in-place operations,
+ so we just fake it. *)
+
+let mult_in v x y =
+ v := mult x y
+
+let mult_fast_in v x y =
+ v := mult_fast x y
+
+let add_in v x y =
+ v := add x y
+
+let add_fast_in v x y =
+ v := add_fast x y
+
+let sub_in v x y =
+ v := sub x y
+
+let sub_fast_in v x y =
+ v := x -! y
+
+let copy_in v x = v := x
+let copy_out v = !v
+let make_ref x = ref x
+let look = copy_out
+
+let canonicalize_in v = v := !v %! !order
+
+(* Array-wise functions for adding elements to svalues *)
+
+let add_el_array ~points el =
+ Array.init (Array.length points)
+ ~f:( fun i ->
+ let rval = (points.(i) -! el) %! !order in
+ if eq rval zero
+ then failwith "Sample point added to set"
+ else rval )
+
+let del_el_array ~points el =
+ Array.map ~f:inv (add_el_array ~points el)
+
+let mult_array ~svalues array =
+ if Array.length svalues <> Array.length array
+ then raise (Invalid_argument "ZZp.mult_array: array lengths don't match");
+ for i = 0 to Array.length array - 1 do
+ svalues.(i) <- mult svalues.(i) array.(i)
+ done
+
+(** Element-based functions for adding elements to svalues *)
+
+let add_el ~svalues ~points el =
+ if Array.length svalues <> Array.length points
+ then raise (Invalid_argument "ZZp.add_el: array lengths don't match");
+ for i = 0 to Array.length points - 1 do
+ svalues.(i) <- mult svalues.(i) (points.(i) -! el)
+ done
+
+(* needs checking *)
+let del_el ~svalues ~points el =
+ if Array.length svalues <> Array.length points
+ then raise (Invalid_argument "ZZp.del_el: array lengths don't match");
+ for i = 0 to Array.length points - 1 do
+ svalues.(i) <- div svalues.(i) (points.(i) -! el)
+ done
+
+let array_mult x y =
+ let len = Array.length x in
+ Array.init len ~f:(fun i -> mult x.(i) y.(i))
+
+let mut_array_div x y =
+ Array.init (Array.length x) ~f:(fun i -> div x.(i) y.(i))
+
+let mut_array_copy ar = Array.copy ar
+
+let cmp = Number.compare
+
+let length array = Array.length array
+
+let mut_array_to_array array = Array.copy array
+let mut_array_of_array array = Array.copy array
+
+let to_string_array x =
+ Array.init 1 ~f:(fun i -> to_bytes x)
+
+module Set = Set.Make(struct
+ type t = zz
+ let compare = Number.compare
+ end)
+
+let zset_of_list list =
+ List.fold_left ~init:Set.empty
+ ~f:(fun x y -> Set.add y x) list
+
+
+let of_number x = x
+let canonical_of_number x =
+ x %! !order
+
+let to_number x = x
+
+let rand bits =
+ let n = Prime.randint bits !order in
+ n %! !order
+
+module Infix =
+struct
+ let ( +: ) = add
+ let ( -: ) = sub
+ let ( *: ) = mul
+ let ( /: ) = div
+ let ( =: ) = ( =! )
+ let ( <>: ) = ( <>! )
+end
Added: sks/branches/upstream/sks/current/zZp.mli
===================================================================
--- sks/branches/upstream/sks/current/zZp.mli (rev 0)
+++ sks/branches/upstream/sks/current/zZp.mli 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,110 @@
+type zz
+type zzref
+type mut_array
+val order : Number.z ref
+val nbits : int ref
+val nbytes : int ref
+val two : zz
+val zero : zz
+val one : zz
+val set_order : zz -> unit
+val num_bytes : unit -> int
+val of_bytes : string -> zz
+val to_bytes : zz -> string
+val of_int : int -> zz
+val to_N : 'a -> 'a
+val of_N : zz -> zz
+val add : zz -> zz -> zz
+val sub : zz -> zz -> zz
+val mul : zz -> zz -> zz
+val mult : zz -> zz -> zz
+val imult : zz -> int -> zz
+val add_fast : zz -> zz -> zz
+val mul_fast : zz -> zz -> zz
+val mult_fast : zz -> zz -> zz
+val canonicalize : zz -> zz
+val square : zz -> zz
+val square_fast : zz -> zz
+val imul : zz -> zz -> zz
+val neg : zz -> zz
+val inv : zz -> zz
+val div : zz -> zz -> zz
+(* val sub_fast : zz -> zz -> zz *)
+val lt : zz -> zz -> bool
+val gt : zz -> zz -> bool
+val eq : zz -> zz -> bool
+val neq : zz -> zz -> bool
+val to_string : zz -> string
+val of_string : string -> zz
+val print : zz -> unit
+val points : int -> zz array
+val svalues : int -> mut_array
+val mult_in : zzref -> zz -> zz -> unit
+(* val mult_fast_in : zzref -> zz -> zz -> unit *)
+val add_in : zzref -> zz -> zz -> unit
+(* val add_fast_in : zzref -> zz -> zz -> unit *)
+val sub_in : zzref -> zz -> zz -> unit
+(* val sub_fast_in : zzref -> zz -> zz -> unit *)
+val copy_in : zzref -> zz -> unit
+val copy_out : zzref -> zz
+val make_ref : zz -> zzref
+val look : zzref -> zz
+val canonicalize_in : zzref -> unit
+val add_el_array : points: zz array -> zz -> zz array
+val del_el_array : points: zz array -> zz -> zz array
+val mult_array : svalues:mut_array -> zz array -> unit
+val add_el : svalues:mut_array -> points:zz array -> zz -> unit
+val del_el : svalues:mut_array -> points:zz array -> zz -> unit
+val array_mult : zz array -> zz array -> zz array
+val mut_array_div : mut_array -> mut_array -> zz array
+val mut_array_copy : mut_array -> mut_array
+val cmp : zz -> zz -> int
+val length : mut_array -> int
+val mut_array_to_array : mut_array -> zz array
+val mut_array_of_array : zz array -> mut_array
+val to_string_array : zz -> string array
+val rand : (unit -> int) -> zz
+
+(** Set specialized to ZZp.zz *)
+module Set :
+ sig
+ type elt = zz
+ type t
+ val empty : t
+ val is_empty : t -> bool
+ val mem : elt -> t -> bool
+ val add : elt -> t -> t
+ val singleton : elt -> t
+ val remove : elt -> t -> t
+ val union : t -> t -> t
+ val inter : t -> t -> t
+ val diff : t -> t -> t
+ val compare : t -> t -> int
+ val equal : t -> t -> bool
+ val subset : t -> t -> bool
+ val iter : f:(elt -> unit) -> t -> unit
+ val fold : f:(elt -> 'a -> 'a) -> t -> init:'a -> 'a
+ val for_all : f:(elt -> bool) -> t -> bool
+ val exists : f:(elt -> bool) -> t -> bool
+ val filter : f:(elt -> bool) -> t -> t
+ val partition : f:(elt -> bool) -> t -> t * t
+ val cardinal : t -> int
+ val elements : t -> elt list
+ val min_elt : t -> elt
+ val max_elt : t -> elt
+ val choose : t -> elt
+ val split : elt -> t -> t * bool * t
+ end
+val zset_of_list : zz list -> Set.t
+val canonical_of_number : Number.z -> zz
+val of_number : Number.z -> zz
+val to_number : zz -> Number.z
+module Infix :
+ sig
+ val ( +: ) : zz -> zz -> zz
+ val ( -: ) : zz -> zz -> zz
+ val ( *: ) : zz -> zz -> zz
+ val ( /: ) : zz -> zz -> zz
+ val ( =: ) : zz -> zz -> bool
+ val ( <>: ) : zz -> zz -> bool
+ end
Added: sks/branches/upstream/sks/current/zZp2.ml
===================================================================
--- sks/branches/upstream/sks/current/zZp2.ml (rev 0)
+++ sks/branches/upstream/sks/current/zZp2.ml 2012-05-30 15:11:05 UTC (rev 236)
@@ -0,0 +1,181 @@
+(************************************************************************)
+(* This file is part of SKS. SKS 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 *)
+(***********************************************************************)
+
+(** Field of integers mod p (for a settable prime p) *)
+open StdLabels
+open MoreLabels
+module Unix=UnixLabels
+open Printf
+
+open Number2
+open Big_int
+
+type t = big_int
+type tref = big_int ref
+type zzarray = big_int array
+
+let order = ref two
+let nbits = ref 0
+let nbytes = ref 0
+
+let rec num_bits x =
+ if x =! zero then 0
+ else 1 + num_bits (x /! two)
+
+let set_order value =
+ order := value;
+ nbits := num_bits !order;
+ nbytes := !nbits / 8 + (if !nbits mod 8 = 0 then 0 else 1)
+
+
+
+let modulo = mod_big_int
+
+let num_bytes () = !nbytes
+let of_bytes bytes = bigint_of_bytes bytes
+let to_bytes n = bigint_to_bytes ~nbytes:!nbytes (modulo n !order)
+let of_int i = modulo (big_int_of_int i) !order
+let to_N x = x
+let of_N x = modulo x !order
+
+let add x y = modulo (x +! y) !order
+let mul x y = modulo (x *! y) !order
+let mult x y = modulo (x *! y) !order
+let imult x y = modulo (mult_int_big_int x y) !order
+
+let add_fast x y = (x +! y)
+let mul_fast x y = (x *! y)
+let mult_fast x y = (x *! y)
+let canonicalize x = modulo x !order
+
+let shl x i =
+ x *! power_int_positive_int 2 i
+
+let square x = modulo (x *! x) !order
+let square_fast x = x *! x
+
+let imul x y = modulo (mult_big_int y x) !order
+let neg x = !order -! x
+let inv x =
+ if x = zero then raise (Invalid_argument "ZZp.inv: Attempt to invert 0");
+ let u = gcd_big_int x !order in
+ modulo u !order
+
+let div x y = modulo (x *! (inv y)) !order
+let sub_fast x y = x -! y
+let sub x y = modulo (x -! y) !order
+
+let lt = lt_big_int
+let gt = gt_big_int
+let eq = eq_big_int
+let neq x y = not (eq_big_int x y)
+
+let to_string x = string_of_big_int x
+let print x = print_string (to_string x)
+
+let points n =
+ Array.init n
+ ~f:(fun i ->
+ let ival = ((i + 1) / 2) * (if i mod 2 = 0 then 1 else (-1)) in
+ big_int_of_int ival)
+
+let svalues n =
+ Array.init n ~f:(fun i -> one)
+
+(* In-place operations. Since we're using Big_int, there are no in-place operations,
+ so we just fake it. *)
+
+let mult_in v x y =
+ v := mult x y
+
+let mult_fast_in v x y =
+ v := mult_fast x y
+
+let add_in v x y =
+ v := add x y
+
+let add_fast_in v x y =
+ v := add_fast x y
+
+let sub_in v x y =
+ v := sub x y
+
+let sub_fast_in v x y =
+ v := x -! y
+
+let copy_in v x = v := x
+let copy_out v = !v
+let make_ref x = ref x
+let look = copy_out
+
+let canonicalize_in v = v := modulo !v !order
+
+(* Array-wise functions for adding elements to svalues *)
+
+let add_el_array ~points el =
+ Array.init (Array.length points)
+ ~f:( fun i ->
+ let rval = modulo (points.(i) -! el) !order in
+ if eq rval zero
+ then failwith "Sample point added to set"
+ else rval )
+
+let del_el_array ~points el =
+ Array.map ~f:inv (add_el_array ~points el)
+
+let mult_array ~svalues array =
+ if Array.length svalues <> Array.length array
+ then raise (Invalid_argument "ZZp.add_el: array lengths don't match");
+ for i = 0 to Array.length array - 1 do
+ svalues.(i) <- mult svalues.(i) array.(i)
+ done
+
+(** Element-based functions for adding elements to svalues *)
+
+let add_el ~svalues ~points el =
+ if Array.length svalues <> Array.length points
+ then raise (Invalid_argument "ZZp.add_el: array lengths don't match");
+ for i = 0 to Array.length points - 1 do
+ svalues.(i) <- mult svalues.(i) (points.(i) -! el)
+ done
+
+(* needs checking *)
+let del_el ~svalues ~points el =
+ if Array.length svalues <> Array.length points
+ then raise (Invalid_argument "ZZp.del_el: array lengths don't match");
+ for i = 0 to Array.length points - 1 do
+ svalues.(i) <- div svalues.(i) (points.(i) -! el)
+ done
+
+let array_mult x y =
+ let len = Array.length x in
+ Array.init len ~f:(fun i -> mult x.(i) y.(i))
+
+let zzarray_div x y =
+ Array.init (Array.length x) ~f:(fun i -> x.(i) /! y.(i))
+
+let zzarray_copy ar = Array.copy ar
+
+let cmp = compare_big_int
+
+let length array = Array.length array
+
+let zzarray_to_array array = Array.copy array
+let zzarray_of_array array = Array.copy array
+
+let to_string_array x =
+ Array.init 1 ~f:(fun i -> to_bytes x)
More information about the Pkg-sks-commit
mailing list