sks-1.1.5/ANNOUNCEMENT0000644000175000017500000001132612331743744014714 0ustar kristianfkristianfWe are pleased to announce the availability of a new stable SKS release: Version 1.1.5. SKS is an 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. What's New in 1.1.5 ==================== - Fixes for machine-readable indices. Key expiration times are now read from self-signatures on the key's UIDs. In addition, instead of 8-digit key IDs, index entries now return the most specific key ID possible: 16-digit key ID for V3 keys, and the full fingerprint for V4 keys. - Add metadata information (number of keys, number of files, checksums, etc) to key dump. This allows for information on the key dump ahead of download/import, and direct verification of checksums using md5sum -c . - Replaced occurrances of the deprecated operator 'or' with '||' (BB issue #2) - Upgraded to cryptlib-1.7 and own changes are now packaged as separate patches that is installed during 'make'. Added the SHA-3 algorithm, Keccak - Option max_matches was setting max_internal_matches. Fixed (BB issue #4) - op=hget now supports option=mr for completeness (BB issue #17) - Add CORS header to web server responses. Allows JavaScript code to interact with keyservers, for example the OpenPGP.js project. - Change the default hkp_address and recon_address to making the default configuration support IPv6. (Requires OCaml 3.11.0 or newer) - Only use '-warn-error A' if the source is marked as development as per the version suffix (+) (part of BB Issue #2) - Reduce logging verbosity for debug level lower than 6 for (i) bad requests, and (ii) no results found (removal of HTTP headers in log) (BB Issue #13) - Add additional OIDs for ECC RFC6637 style implementations (brainpool and secp256k1) (BB Issue #25) and fix issue for 32 bit arches. - Fix a non-persistent cross-site scripting possibility resulting from improper input sanitation before writing to client. (BB Issue #26 | CVE-2014-3207) Note when upgrading from earlier versions of SKS ==================== The default values for pagesize settings changed in SKS 1.1.4. To continue using an existing DB from earlier versions without rebuilding, explicit settings have to be added to the sksconf file. pagesize: 4 ptree_pagesize: 1 Getting the Software ==================== SKS can be downloaded from https://bitbucket.org/skskeyserver/sks-keyserver Prerequisites ==================== There are a few prerequisites to building this code. You need: * ocaml-3.11.0 or later (ocaml-3.12.x is recommended). Get it from * Berkeley DB version 4.6.* or later, whereby 4.8 or later is recommended. You can find the appropriate versions at * GNU Make and a C compiler (e.g gcc) Verifying the integrity of the download ==================== Releases of SKS are signed using the SKS Keyserver Signing Key available on public keyservers with the KeyID 0x41259773973A612A and has a fingerprint of C90E F143 0B3A C0DF D00E 6EA5 4125 9773 973A 612A. Using GnuPG, verification can be accomplished by, first, retrieving the signing key using gpg --keyserver pool.sks-keyservers.net --recv-key 0x41259773973A612A followed by verifying that you have the correct key gpg --keyid-format long --fingerprint 0x41259773973A612A should produce: pub 4096R/41259773973A612A 2012-06-27 Key fingerprint = C90E F143 0B3A C0DF D00E 6EA5 4125 9773 973A 612A A check should also be made that the key is signed by trustworthy other keys; gpg --list-sigs 0x41259773973A612A and the fingerprint should be verified through other trustworthy sources. Once you are certain that you have the correct key downloaded, you can create a local signature, in order to remember that you have verified the key. gpg --lsign-key 0x41259773973A612A Finally; verifying the downloaded file can be done using gpg --keyid-format long --verify sks-x.y.z.tgz.asc The resulting output should be similar to gpg: Signature made Wed Jun 27 12:52:39 2012 CEST gpg: using RSA key 41259773973A612A gpg: Good signature from "SKS Keyserver Signing Key" Thanks ==================== We have to thank all the people who helped with this release, by discussions on the mailing list, submitting patches, or opening issues for items that needed our attention. Happy Hacking, The SKS Team (Yaron, John, Kristian, Phil, and the other contributors) sks-1.1.5/BUGS0000644000175000017500000000360012273431766013561 0ustar kristianfkristianf* 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 ---------FIXED----------------- * Possible DDOS on input socket. Issue is being worked on. Workaround: use reverse proxy in Apache or nginx to feed traffic to localhost:11371 sksconf hkp_address: 127.0.0.1 Apache Example from Peter Kornherr: ServerName ServerAdmin Order deny,allow Allow from all ProxyPass / http://127.0.0.1:11371/ ProxyPassReverse / http://127.0.0.1:11371/ SetEnv proxy-nokeepalive 1 nginx example from Daniel Kahn Gillmor ------------------- server { listen 209.234.253.170:11371; listen 80; server_name keys.mayfirst.org; access_log off; location / { proxy_pass http://localhost:11371/; } } server { listen 443; server_name zimmermann.mayfirst.org; ssl on; ssl_certificate /etc/ssl/keys-m.o.crt; ssl_certificate_key /etc/ssl/private/keys.m.o-key.pem; ssl_ciphers HIGH:MEDIUM:!ADH; access_log off; location / { proxy_pass http://localhost:11371/; } } ------------------- sks-1.1.5/CHANGELOG0000644000175000017500000002231512331743744014311 0ustar kristianfkristianf1.1.5 - Fixes for machine-readable indices. Key expiration times are now read from self-signatures on the key's UIDs. In addition, instead of 8-digit key IDs, index entries now return the most specific key ID possible: 16-digit key ID for V3 keys, and the full fingerprint for V4 keys. - Add metadata information (number of keys, number of files, checksums, etc) to key dump. This allows for information on the key dump ahead of download/import, and direct verification of checksums using md5sum -c . - Replaced occurrances of the deprecated operator 'or' with '||' (BB issue #2) - Upgraded to cryptlib-1.7 and own changes are now packaged as separate patches that is installed during 'make'. Added the SHA-3 algorithm, Keccak - Option max_matches was setting max_internal_matches. Fixed (BB issue #4) - op=hget now supports option=mr for completeness (BB issue #17) - Add CORS header to web server responses. Allows JavaScript code to interact with keyservers, for example the OpenPGP.js project. - Change the default hkp_address and recon_address to making the default configuration support IPv6. (Requires OCaml 3.11.0 or newer) - Only use '-warn-error A' if the source is marked as development as per the version suffix (+) (part of BB Issue #2) - Reduce logging verbosity for debug level lower than 6 for (i) bad requests, and (ii) no results found (removal of HTTP headers in log) (BB Issue #13) - Add additional OIDs for ECC RFC6637 style implementations (brainpool and secp256k1) (BB Issue #25) and fix issue for 32 bit arches. - Fix a non-persistent cross-site scripting possibility resulting from improper input sanitation before writing to client. (BB Issue #26 | CVE-2014-3207) 1.1.4 - Fix X-HKP-Results-Count so that limit=0 returns no results, but include the header, to let a client poll for how many results exist, without retrieving any. Submitted by Phil Pennock. See: http://lists.nongnu.org/archive/html/sks-devel/2010-11/msg00015.html - Add UPGRADING document to explain upgrading Berkeley DB without rebuilding. System bdb versions often change with new SKS releases for .deb and .rpm distros. - Cleanup build errors for bdb/bdb_stubs.c. Patch from Mike Doty - Update cryptokit from version 1.0 to 1.5 without requiring OASIS build system or other additional dependencies - build, fastbuild, & pbuild fixed to ignore signals USR1 and USR2 - common.ml and reconSC.ml were using different values for minumimum compatible version. This has been fixed. - Added new server mime-types, and trying another default document (Issue 6) In addition to the new MIME types added in 1.1.[23], the server now looks over a list and and serves the first index file that it finds Current list: index.html, index.htm, index.xhtml, index.xhtm, index.xml. - options=mr now works on get as well as (v)index operations. This is described in http://tools.ietf.org/html/draft-shaw-openpgp-hkp-00 sections 3.2.1.1. and 5.1. - Updated copyright notices in source files - Added sksclient tool, similar to old pksclient - Add no-cache instructions to HTTP response (in order for reverse proxies not to cache the output from SKS) - Use unique timestamps for keydb to reduce occurrances of Ptree corruption. - Added Interface specifications (.mli files) for modules that were missing them - Yaron pruned some no longer needed source files from the tree. - Improved the HTTP status and HTTP error codes returned for various situations and added checks for more error conditions. - Add a suffix to version (+) indicating non-release or development builds - Add an option to specify the contact details of the server administrator that shows in the status page of the server. The information is in the form of an OpenPGP KeyID and set by server_contact: in sksconf - Add a `sks version` command to provide information on the setup. - Added configuration settings for the remaining database table files. If no pagesize settings are in sksconf, SKS will use 2048 bytes for key and 512 for ptree. The remainining files' pagesize will be set by BDB based on the filesystem settings, typically this is 4096 bytes. See sampleConfig/sksconf.typical for settings recommended by db_tuner. - Makefile: Added distclean target. Dropped autogenerated file from VCS. - Allow tuning BDB environment before creation in [fast]build and pbuild. If DB_CONFIG exists in basedir, copy it to DB dir before DB creation. Preference is given to DB_CONFIG.KDB and DB_CONFIG.PTree over DB_CONFIG. - Add support for Elliptic Curve Public keys (ECDSA, ECDH) - Add check if an upload is a revocation certificate, and if it is, produce an error message tailored for this. 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@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 sks-1.1.5/LICENSE0000644000175000017500000004325412273431766014114 0ustar kristianfkristianf GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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 Lesser General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. sks-1.1.5/FILES0000644000175000017500000000037612273431766013672 0ustar kristianfkristianfANNOUNCEMENT BUGS CHANGELOG LICENSE FILES README.md TODO UPGRADING VERSION Makefile Makefile.local.unused cryptokit-1.7.tar.gz sks_build.sh bdb/*.ml bdb/*.mli bdb/Makefile bdb/*.c bdb/*.h .depend *.ml *.mli *.c *.patch sampleConfig/* sampleWeb/* sks.pod sks-1.1.5/README.md0000644000175000017500000002055712331743744014364 0ustar kristianfkristianfSKS Keyserver ============= The following is an incomplete guide to compiling, setting up and using SKS. Hopefully this is enough to get you started, in addition there is a wiki available, where in particular should help getting a working installation. Prerequisites ------------- There are a few prerequisites to building this code. You need: * OCaml-3.11.0 or later. Get it from * Berkeley DB version 4.6.* or later. You can find the appropriate versions at * GNU Make and a C compiler (e.g gcc) Verifying the integrity of the download ---------------------------- Releases of SKS are signed using the SKS Keyserver Signing Key available on public keyservers with the KeyID 0x41259773973A612A and has a fingerprint of C90E F143 0B3A C0DF D00E 6EA5 4125 9773 973A 612A. Using GnuPG, verification can be accomplished by, first, retrieving the signing key using gpg --keyserver pool.sks-keyservers.net --recv-key 0x41259773973A612A followed by verifying that you have the correct key gpg --keyid-format long --fingerprint 0x41259773973A612A should produce: pub 4096R/41259773973A612A 2012-06-27 Key fingerprint = C90E F143 0B3A C0DF D00E 6EA5 4125 9773 973A 612A A check should also be made that the key is signed by trustworthy other keys; gpg --list-sigs 0x41259773973A612A and the fingerprint should be verified through other trustworthy sources. Once you are certain that you have the correct key downloaded, you can create a local signature, in order to remember that you have verified the key. gpg --lsign-key 0x41259773973A612A Finally; verifying the downloaded file can be done using gpg --keyid-format long --verify sks-x.y.z.tgz.asc The resulting output should be similar to gpg: Signature made Wed Jun 27 12:52:39 2012 CEST gpg: using RSA key 41259773973A612A gpg: Good signature from "SKS Keyserver Signing Key" 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 to get other SKS administrators to add you to their membership lists. **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. ### 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 - 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. sks-1.1.5/TODO0000644000175000017500000001210212273431766013563 0ustar kristianfkristianf--- 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 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@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@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 sks-1.1.5/UPGRADING0000644000175000017500000000252012273431766014341 0ustar kristianfkristianfIn general, it is possible to upgrade a database to a new version of Berkeley DB without rebuilding as most upgrades of bdb only require a change to the log file. For example, if one wishes to upgrade sks and bdb from db51 to db53: cd /var/sks # default location for DB in KDB PTree do db51_recover -eh $DB # feels extra, some Oracle docs recommend db51_recover -h $DB # run again, this time removing DB env db51_checkpoint -1h $DB # checkpoint with old version done # # for DB in KDB PTree do db53_checkpoint -1h $DB # checkpoint and convert the log db53_recover -eh $DB # run db_recover and recreate env db53_archive -dh $DB # remove old log files done # see http://docs.oracle.com/cd/E17275_01/html/programmer_reference/upgrade_process.html as well as the release notes for the new version of bdb being installed Help is, as usual, available from the Sks-devel mailing list, Sks-devel@nongnu.org. https://lists.nongnu.org/mailman/listinfo/sks-devel sks-1.1.5/VERSION0000644000175000017500000000000612331743744014140 0ustar kristianfkristianf1.1.5 sks-1.1.5/Makefile0000644000175000017500000002647112273431766014551 0ustar kristianfkristianf# # 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 SKSVS=$(shell grep 'version_suffix = "+"' common.ml) ifeq ($(strip $(SKSVS)),) WARNERR= else WARNERR=-warn-error A endif CAMLP4=-pp $(CAMLP4O) CAMLINCLUDE= -I lib -I bdb COMMONCAMLFLAGS=$(CAMLINCLUDE) $(OCAMLLIB) -ccopt -Lbdb -dtypes $(WARNERR) 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 \ Unique_time.cmo version.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: @if [ ! -e Makefile.local ]; then echo "Makefile.local has to be defined before building. See Makefile.local.unused"; exit 1; fi; 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 sksclient: $(LIBS) $(ALLOBJS) sksclient.cmx $(OCAMLOPT) -o sksclient $(OCAMLOPTFLAGS) $(ALLOBJS) sksclient.cmx sksclient.bc: $(LIBS.bc) $(ALLOBJS.bc) sksclient.cmo $(OCAMLC) -o sksclient.bc $(OCAMLFLAGS) $(ALLOBJS.bc) sksclient.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 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 *.mli *.ml 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 *.mli *.ml ################################## # 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 CKVER=cryptokit-1.7 CKDIR=$(CKVER)/src $(CKVER)/README.txt: tar xmvfz $(CKVER).tar.gz patch -p 0 < $(CKVER)-sks.patch patch -p 0 < $(CKVER)-sks-custom_compare.patch $(CKDIR)/cryptokit.cma: $(CKVER)/README.txt cd $(CKDIR) && $(MAKE) all $(CKDIR)/cryptokit.cmxa: $(CKVER)/README.txt 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: .mli .ml .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 -rf spider sksclient 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 $(CKVER) distclean: cleanall rm -rf Makefile.local rm -rf .depend tmp lib # Dependencies dep: $(OCAMLDEP) $(INCLUDES) *.mli *.ml > .depend -include .depend # DO NOT DELETE sks-1.1.5/Makefile.local.unused0000644000175000017500000000025412273431766017133 0ustar kristianfkristianfBDBLIB=-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 sks-1.1.5/cryptokit-1.7.tar.gz0000644000175000017500000042216012273431766016566 0ustar kristianfkristianfvQ]{w6S{O*9"z8v=4>94H"U>|NS`00Aû4Uvo(Eݎ&85UAwL89xuSӃS:ӶF){[/2BЙ6CSL\.b?vMTX؞ΨMfә|j?pgnjL=3}C½;{NW_[ŚomOu. cSHMyӯ`ꚡTkz׻̽b&Qj2U#s{"_$d3w+~?qBi(cW6?@2_ V10ل^_m{7P~/-!uMyYYؗM88:9‰k24!&Ӟ;Iv H [HFH !s>p I- tFg%3[ƖgB 1r,/`08Џ>l9t0ʇ`m plk8l˹ g2@8xRR/kP;0!;BOņTVSm?ܲMkR[G4fؾk2d-Ч}![$6uAAu! 1:4Ul@.@/N,VFN38q̳b Y5uc͒,]bh>Xߙ;.-p;y (CwjΕ,!eXMI1zt~h3G.%5Fظ &<}u0-sF(h~ôĿF5Hll)Hj!=}pvd֬n+uŋ5vJ2G' F\^k3 Fr=ܚ,t9 =FxQK|-xsS@Dgkx1 CĨ8:\փ+c;p8i98$j71B0HA$ }\oHS)q9GG;nC#4PHxoUPpHb*d5&ӝE?{WgH7gG~xrvpx??锱ZkU @lUM`)o3t0ܡl4}Jk  &'E>|[֒DM轀3཭~!V&r( pQNZ*#V7"ܪ nf Y:wx{cV;d D ](ctȈ/bğ㛃ӷٯh/]+qSjqQJ\1 mʄ$C;96K9<vfw[[n(wg喱{~aGcuc8:>gP7s`i*F[zaH53NG7b k؏jb].'6>Qj-c 9ӵLpuѠM߄[<:G Jf(+Fkh%%x{xoyOaLQog~ʷ*w**y`mʲvR+_S(?cYs.vߣL+-1ۻ? d^#$wr]2`³ $xnr#8@poop *^,6ȻY[m94iA6椚إ1ǾtR&$dzaG}$Owvs>fX+Jϸ鷳ߝ'xs.a ;\wFa&.8Dn^>vak ? G|$dYrG@`BOC%ub^D!) &,TkYg-屢 z GvJJMgS#Ye*G&5$Ny)ԌO~̈́J\*XWYl47A_RY+ւn? ˂ v@Y(a#-9ϧۻ~9pMq:in_Tv/I~6,gdBS 2%.EϏiыt:':uORiӯ&2brj^1p9x"dHQBTG`3{$aJ\B/EK6Q \( ZIYIM)_ifq|l[[7?~de,W?NXȴ+ђ?>6~ Uj%'אp/~ fy0,^K"N83NaX\R:N啝*dUe*c~n\y˩>w_ٷ?S7`jqG_GL-8ubwGg5';ؠǧm(hR屹vțroCm0$fL[U Z2whdžӧ: lو6& ?B!OhGػL]wo23lhƿLLkh| ^T72d(KR`YUӊL׷Usk; ]u#}dAnM/-hEXGƺe/Ĕ1Gjˇ}qfywݩ(..dbJ*xпGgоnw8M$k>Og%HnD!1N>?N%[H"cZDzd*5"BO|9nܖrգEJE +#<o8Q/-5<U-tz/'eZׇGowA@ӱN5UMJSw$TL6r]Uy P3ˣ[EjTouf^äf#+ IHDAs^4Xʕ̧Wj&]5bE?)87*v%'7;􌾩t؋qw{=E7j1^[E8WGWƢ(ozQLV 02we>4S,|Of~sr?Yv)QOID\Bʴ2ϙ̍ѠIek0#=I?투xP.Ws[QӯsT箄 w'/%/JvQ)N5ɋ#?l8'oP'+;?'ԗjKUsteZ rk|Yt lwvW b!/tgTؾ"|[\o~yPh _8dvtZgX"U['z"uK>&Wo6hi%ƶ{œr`l4&̏8C] ;e1>CHQґ4DcjBMΏYQG7,(G2 i%cG%Ej2{mtsqmg-[<lˈwxm'ަ- RxW^@1F/9?cA_=zGïI!".ek%Lv7v);YP95Q=&\PMy-EyP .cz*+f 5*&dI1_zFknOі.ϓ;i?r"=`ۢ>1Z.ue9;7TmB}slM1HrBlMLyF*E.O-Q0r_lgsAɈCtDT2ΰy| ]*?oo,Yi{}A)E= G15{5ryM5o15>qUkЍa/~&]ѿp,pKD94 (\h‘VAAv4xe!|H_ꖭU m+)bP09JqP' *FjG17aaL4֩El*H #:\1@_k8fHnc7UH4ocέA<:^KeFDp+6R5(Eu#7>KߔIΈx̔uq`ZeꈶqS+}KFSUu:E"s7iyF\䘚;[+*zz7^0cByvL\0`w |i+$Kځ@j;>Oo9yFz)I!ՠN6&>ǍyS7NYGϝyz!z~筲^I$Њyα',f( B^ϛY4E1 qD*qQ Ue͵JfJ'*Mŕ٫]JϬM&+?{g)ES4#O*MQ4 'Mఫ|la=rpo*,EU= ϶2|DEȔ"A)BS!1q=Z ȤDQ<7 J1A g@#ѭ҂ -Wi9<&)i/U竧1aS:ʀk U+/ vA_1gY2Cf9h(Ee!Nq CR6mt8-*wO1Os7;*2&ՊhBqP!Fp~M*萿h}Nx4AKBro = e4|Hw34|1-%;&;m#zBIJz.zQO K&HL9K܌ɍ(ʹv}^ J(k~q'W <33+#3ڬKU?Y^$MW4EJl"ѐǗ$&PF1RJD~Iz CAjQkd*UUh#qyZac4+`ƝI13B 耽س#lrI0 h*Ey#]©$#]L KC e9~1ga7dz _%0=pb3hD+hud[\$R&WZxrqH3qQ?.'c8sk}b"@GW[o$ghy3kP:s!Y9m3ӗzkhc >ra_{*NσI**8yFMj|!n?-x]rx; ?0޽wG2Y:04,GvU6$HkEu"uJ/Zm6b ;p avXr*W|$6E@_o7t=猎E)Pmz`֔,l(4$4g)US6-d!!ψqa,6+_[t >2Y;DKIu|֛!8;AH(gS~Ʃh'0RˈAqx##_r֗79_uMUFJR`Fzra Fϛju|J,!2vHSve.@̿I&`qFg}nظN=ͰŦ9ae C?rW}_/.凗=ohf L>ԌU4uIeZՎnYz:ب/?\/ce4gq3`*W(/IUiغ/zuDnp"UဌiOi/}<-'vcHƸS4wf#gɶGcM{-)K2eqdmA< 3ro2r387rGS#^?8_6j%=+W7p HvoUM38ܵГ5mw٪e)ݸVMk3q4)SQ}+-gtv7M_na}lXW #%3#d(mʢQtIa7ŎGoweqW_Zw/NwJ~ g>pjzvߑ:+ ]z, J"Z:2rzѧ-[9J_8n)((paC20Vb@ʤ*ifuq0Ϻ9̴_/M_nrW UgR>f]ΦCcI"}(9M@ TUuq*pF>;e3H=.cmK(?Դ?|A7=祽ꍸȊ}nu6Z 궡6wg螩 ė_=C+/;|fŪ//ϘΏ8u_,S(ibXO;_:$G#HD#ǷWD_-/ONp9hPWnW,n]7;4x'Ͻs9TRxeē\yz!8}ž.a}u :DWR䍖/\^i=*DvMzćcG[9kd.\Wb]ͨ5`?3=5ٽ-Vtqt{~7c]tCzgరOҐc(o(nmcNx[48™k9VOdsŤm㔖>΍w!vgR=Ht젝dg`w^uGw;`KA\l?e;ݽ(0Б/Rd7YFg5Ӕ5skVkV"z;:;1;[ -G߭ ^W%X&]x7Df nNY_\m _ins5.ݶkiǛaԯ5]T,C}k{k]cC]6o֯'gU6} ?t~TgݍᘎerG_ͺQwjGe7c2:R+u"̙TcM?y{iy_Ҹ},S #ۘmMJ:jxҕ[<͒,~GSB;ىC b[#4>#E";co'VJVuNvuڍU}m$hY(0sѯg*9+Cv;#e{H1\[nnt  X߂cJRRZgk ?1Fhv;N[8 {NX }SUg:C50]ڸȽ;5ۃ=Clck4w{gĆV{-'D3'5yE{s]:9SpMbY͑8.ͻxM &Ɲѽo`bX!; z]k88wX'T9竾en[{4_S+8<? " 9b#gIrGgЭYmagJ^ ~F)3g݇3v)U1z/]H3ُڈ(:~]>˘B -Wdͱ325qJ|LJ=l/ⳝ Avluèa0i%݁I+NrjMh ˮU&ި)ogw/*˝߽Pl qUHK{0縟$NT3LP to_Ҙi>irTLWKurۻ#5NY;dZKւJ3ORb^+%1 +Ӌ6j[opiԡ0y޴ǔXbzrL |EOe6ګ9QEpXE彐ӕ3vi1sįLO"ߵ꾡M{HK54-&l;~N'=귟e\j$'ړFIŷEkFgO<,BkUG%K@A}pU)\ڗ,xO֕Yz]&MD OGe?^"j|8K6D5qd\ =a;\4cb.4iJhM5+3jQ#2}mMQ~(K}ʕ-OW'tD7,gٶ_EyÔM)99v).YqT/˛ќ_SiO/Y8 )jɅW|yޱ yPPw)5 5wpO[puy~O>s9RorbP%}D?Wgq,Őҟ)Tڑ0ڷ\ \jOZnɛ̪.8w6N@ǔ4%}(Go#CSzVكTS^?xsDg6es=agoj m4QWШFKh}}#Od5UgޓN̛3G;YBM*jz+禦Jz&`m*yX9L`/"aD~OjI=Ȥ=é}q5&+Ig2ai_[m39ndcyS#I:P> ^vk:J17x0y춘t 3q@7WN UvݟUU_%=AjCF8q//Fgaf8;%nӴ^_^B^=Ͻ1fVYj/Vg?bJ'5_+("DY2Kɼ niut0%S0V)+> 8!őXV],_hDw-3Qѝkklq2:{ ղ5grsafcm+~3Y0= J`ё[ . J,Rղ):Ga9_8Ec+|q(.#C*l }^t//5[͵dg wH0z#_:iE7D7=;s )3;ee|筏.#VN]^n)=_ gPnE\1wtFt4|46ؚӨU^uzot^WZvuU @5,]]$F`2KdFir;UGEj #%敬%?/ZO N[0Zm#xAsӖAÂ޴3vKjy ).x6/͗tSrxeacefL~{?S<~i/<*D+-w60pAzBsLE)eM}!/MZѩ՜%?<{Rjuh`V*]tSR4:56A^]Zwǿ~\_v+_J}C@(jݒ)\%q>\],DMo%d(@⳰DK\5{#*8iQw,vu87Kn%aW |wi!L.ky2 ^%S>Jz:CN*K#;ن"O3P>}_F}YsF3]Fw'g,}aS 2f,Y5h\+IQ T*;d: 뺖n=w}z߻ 98I4!EvR-e_º}ǖ_>7:'d/umRϬ:vIkE{gC!VVPeliml6)l4:hꙋVܭgݻ-7M)z!K1€1&x-~PNG6*Y?[GfSBLt0ߋU+gʼnr yacuK1)%чJ@V+$.Pgj}8ggRG}v>Ip~z7X^(iotk/ *%CN- X" ysNVۿo]o8Ht+,Mt?2i}o_].x+p(lwz]V?hͰ5 _9xfR9 ę-[krzU]^!ʭVީfysm{aj.z, z1>9-4N `Syj ڻvrQd|=}n^zزb" ҕ)/b쉯:sd7|31.ύ/ޞ~zsBmO۳}9;8)}Lq>gæb@0/2f=Q=UF4/.E yEN.d]>IU 7wEN/& 6B&D2Ba$c|} a:ydD9%E.)J*/#!4`ة!'ȣĬHsHVHDsYɍEry,TՓR<.LYr- Γ|_d?O˪V.VP.KZX@X@ \}&^4.>swMv.VHw.Na IdXJs}.rZU.c TXc9J:bVD"ݹhvb.z=&&A!(GK.L.vL.ҝBT^9(eL:\$:MRw&FFŮŮj'剴p"OȢT>ڛP(xǒZMS~+D"E(oTTDXi!L!+MHw!VK!VK!}!+KESm!8 .Db"EuU!J![/ $ZыD [.b/DR Z-DS" &T^}Rer ؃g%ݝ9Z$5/M ]sir( u_*{LIMU6nTSV5nUrMܘr|אuE >T:Ax݋sq;I6/[7z e ^|UuvNr'S!'}KM^ҝ|\>7Ǥi\eDq%JZx(/}и<ʩA{Fw;ge9QV{`"A5b*eGoԡo_XbKߎLzGX=Q/@$~7e_h"]ӶZէ8p3ONѧBNU{k!}sXee(xK[Gj47xۍy']}:FUR^3iڥ!xK;\ MژsX2us}ټmt,3Xbܑ`K5 FܠKI%$"i&HoV* f?;BT8:xOl!>#Ş6cc!pE1nktNnR1sTS-_8ݗ)Zs(ȡa.gk =ou6ԊN^ĥkLj]\4iPpcJnv(1e~NKǦwM=?5Yux _85nP leHլzv3*Q/n]&ݵ7ửR3--иN]g*~Oҷہx~6A߱(iW< #ȧagR/}tɗ v:&7P߫KEr| O{=y~z-Ӫ?+-EcEOeLDKNwC-HS9858p4⥃U0k+DUV^wT/!ބ#;I y\/9{<|7_~<}ӿ?iݴ_~>;_,/^֛W߼k ;V 6TtYP/..7Mzf $Klz9<~Vf^MNyx>t$1u@9ιzyvy./r]rUGϹ$9jU9DœeT -H'r){|5/L6W@&Hp x.EU7o..%ϒ]Qszv=[Px@=d&,HK{,.+.,/,RK%JXJGJKJ|\Xyra$ N~Yf"h}ePËc]p;K^7{7j"8ke܍yv/f>^7Km8hƘѴ-W{yt[{%Pwv^癝]O,QQa'|j$DVwFH7n_mQb{/ZխMvljJ-y2Wmqbx|l"Rljic=yCr߾ނTGE_ѷtglYjg:ϾlT'dWոÑҶ[umW:F%ܼg[JooضӼ^md)M.(:bL+ݭ EjpѦENk:Aj ?Ypt|a\Ӕg7X?I&B KKJHwS\at,0KS½Jޙ.f4x8~wכӎq|wj80GcLo:U&/x䚵' g%KC䤓}5k>.s5L{syCѸ6Ŵt=ZWOxs6Q@XhM\s2Ōsޞ/)1Fx`7d[Tg{qc-L#Qw°7LC蝌Q?2;9v%G=sLgGW5ϿT.}9P|A3˼9V'OM ޫ wrBws;7ļb\ILGĪ_<FG- #OoTd/$ !$/(YD,,HrY07gjvFR3~Ͱ׀tɪZ}~-MV-->/d_I?y|7x_^js}4_^Wq48xXoM̓I[+? lx1[KvؒR=: gg͑Uq'ׄXykPӜ߰cK?K7|] U'gӳyMvnnKl?ݚm鿳gDYD@˫}~5qC&=n%?< $ vNgruX5|2*oFrlS: ۣӯ{v^.fs?B7բ.?sݽ8k1NV)I&GQ|ʹ@Kt!UjyWf_rWA|tf^M~$&@OjGŞA~?=Pѯf?Q357}~Y닷{IJѹ_l2yq*FܔU7Ju=)e=Y+y'*c} /_p?OA?/w-e!Y'ʃ^֦=4ւ!&bBRx梒TpvJK0;_>nTބV`7w@!zmGUݑ6o&U oO7Ǡ"SGE1T釤E HDjĕMO^s7un"wTwX [UśWh)/YS0O$?~IqǓ=>N8 8K8Ƀa(mh 䖛XVwFljipiY&I(jZI;8wV2;둿#l6`-}2p V}&ܼyoRu"ZerF"Qx BiITg^W#2۰'>n8Z88ERW/'m ꨒw?N0wH) r8⚗YyGz'MU\_n[UCFf=OƱʈ $q8Oe>\:)tsK3O&+Ow+O=p({ZjU^ZEX;V#cgeFn%%Vgp#gYiB*E`XnawnOCU$Fj؝XjINF_Ւ̨˝3'k?˝n_t#i~UϵU#(r6cRr]!ti4XYXu_~#Wf0{Hl3?#L$)dDwZom4K%Ć}z-}>_~~v6~: $_~Ao^DO?=~g7> '䠞_aܜR/jJ룕\v]m~_.6Krn*^[GSsB~Gx%{ <oժ0GWx AumpqV؏_`Y}}iGtÀ~}޿Çݟ}Óg}J?Xӧ'~1erOy?=x6wQg?H*bs?< {7tyo?wgS#n#M'?=nƃO{wDU<ׇ?cofQIٓD _ߓB}|޷Q'?_IDݷ?Cj'~@r1TӇO~wkjlӓ1?>|SOOP%r\ {?=},{O?||ß3ă0Ĥ;̐>8^!=zlev<%d Ϝ?_?C%2?pAz>㧜1*]'ntц 1ܫGWI>VrCt}[nTErw֛C螳;w̑eOy =0$A':$H L"I'Uxh*HA! ?"O0&$S'ω$A'Ruj!f^bY97u'yRe?Q7Lm L&xbZ6?|,a#O<өhY>Fr1βÄP5\m^E<vFx:͚)X.ҦV65O*U]h_4+2rR_ Jfؔo6fU|8dv|mZE20|iT5&mҼ@fU\3TfTt 3!iRU:C>_MuXȨ_hY3k"T4dT-X՝M,i/RT e1+#z$-hX'unRiUVe|1hљ5UR%3\ LUyV%D+&ͤb!8I Hd3?$cui%!ZՌ+ rKId4="4T"iDOgMĹ2iԞ:R|RGgBHulhB&Ť,S(1nIN35%dUQ3E[%.*ih&J+UdMBn4!-!6X}VI}҉kYJ¶/%4cΔf ))B}퇲&2'Ɛ#$ B2J#+gP; 2<T5ʹv5ӖTvjhLќ)喒V)RAY}6IJ2V(.A8 |VV>'3RqTfCjMШ[H.q&ҙLJGYͤM4AgbIiRPi]y͖zR&y,*yUH\Mjt-o҆2sҙvY>S,YΚlt3RdNĚ((eۂ( }. K̷FٟaQ$NGS_*-bOQά E34A礠Ճ%]+;$jSImIf]:QR,&9J G$MaS`CBҁg wIPo!̕hAMv8gVNBGQk&mҬNyNJduGI %L6aR(@gB$\ S>26Vz"+%IlGȆ4xR*LVHIF@9tBF͛JVd4 ,O\Hh|H3֊kLQEV臨|Y,$Z$!A>I-ЧA}q޹}Q V QI 2-@D("jm$QM-T'JJ1z@D+@D9DTs" 2D"i"} /DTdQMV!ԀDT "J1DT:D瀈QJ]"*T ѤOf6_ &@Dat8 "" Ic@D4)Dē*QMJ"BX3@D[䀈) "4Q_@DKBfVΦx"*Dt% "Z"BZ@D.䀈QzAt ( @D5}"QMȀ U 5 "m'x2DV ) 2h" "ehAhm&@Dr~6 Q[ڊAEԺZ"Bx*@D"| "DD?W"ZDD5 "*/At ha*"@DYIJ!@D5]"QϖP""_ !ѳ3@D#@DD׀(dhg~ƀ`a &5 "zDiS@DK, i  O[@D4v @D("*%K h) "(mO1tr@DDT ,!"K@D$mt&倈J@Ds@DpDԶ@D": 4h_ N") CŀDD! c0""YD5 ":DF,7D+}J@DDD} 5l@DЙ"[@D=DR"9 "Q +@DgQE NvWW"2@D\v׀"DXhY"/ "*O!3@D+/S@DT"bLqQ"ZG8Z@D"r@D[_ )"I h!DD} ":DD@D+/9 "" "$DtAZ % " -@D,lQH hW"B>'vܶ`E*A YhDEo~h @DP"bŀ{OAgfKS@Dp,D!#b(q1Ft"0"9F #:Ҏv/H1F;BFD?)0"́NA`D!#`Dp1#:t3F Ax#DBF5 0"+F?s`D!#B̀QHj`D!#  FD!0G EbMJ$Ft"0"X#Bl̝ EAM  A Fљ0QEBj`DPR#:CFVA`#Ah}:ghA D`DT#| DHS "`D4v D`DHZ`D| D`D U(q D`DbWhAFi 0"#:NO2 AF#Ax#hx:gBFD 0"*/т AS#B"`D!#0".`D#:,1`Dl D`DF_R`DR#:,e-0"#:"# 0" I^A |nWhlK`D!#k-0":F)0Ѿ2FS`D!#k10".*`DR#:OBF5 0":FFf`R #:ڧFD `D#Q0"̀-0"#:ρ1R`D]#:QE NBFD#Ft"0"ȁ!g)0"8#:|iQy #:U4S`D\TBFD($FDBFהՌ~ȁFt"0"ˀљ0"*#:\#:HZ#A 0"X#A(FD9Ft"0"X#BJ`DP2Ft`DY&A&F%0 0"lQ Ah_ #c90(BL[ @4> )Dc1M1|) )DTuB )ǔ1eh|L z> iSGgbj&%Ó@4> i?<l!DczLo!ǔ1eh|L z> )DcDo!ǔ1eh|Lw h}?ЩTZǔⰏ)D4cc-Dy2@4>"৪t69>e35=-DaR@t? ST L μ-D\I9ZTM+z :54=-D|p DcBzƟ)Dc Qzǔ1eh|L z> )Dc2@|L0>J'-D/@4>j[CDcڪ:NDcf?9ş"PR@>Khl?P  SIz j1UBOi]S}bc~Wh5z2@4>J\"J*n! >@>jF?(O{Wo!O)DcxmDc&?>@4>jzpbkDc[|*B=h|L3h)TJ l!Dc3?D}@P@4>F[cJ>bӋRE3p(43e#*U% uY;q\^lҤ:%\ճ*+`K- č&3[5A[%eYׅ>';8S)\RWT8O4U4*q FY&8VTa4kͬ9͜3b>ғֳP&'>@8qЄmH.ʌf Ot[Eӓ^;"4m*NS+e҄,E66"u"p&""Dލq"DD+r@DP1A3@D;*@DDDZ@D CDDh YjDgR@DT""i:[@DkgU" "(I6@DTQ"bmq1DkQEiDtNt'` W"}S@D4)D9 m_Z@DDD3@Dwc@DH *!- "K юq"q !CD QF@D-AS@DT""i $մ䀈jDtVP1지H"|@D5DTٙDB7 "Lm}3@Dէj"I@D`DEʠDT 7DTcQI3 "D *@D\Ԁ(Dt% R̀J"j%DD- ".B@D| hD@DDT ]"bQ܎\ f=@Dg%fDD1 5 "Z &ŀК1 G) "򵀈6DV@Dg% R"S@D`k@D<"Bga! "ӌ0"#:3+0#*QF`D(TVc`Dāt[`D#I3`D#I!jRFT10m cF_2`D<#:0,`D; `DY#90"."`Dkg(5FD?L RFD W#~h1p `D4F 0"zF?`D*,F#m LY1Fi 0".b`D%FfH#B^b`DtJ,#bTO%0"#:&0"#}50me0"#g'Z`D0FD f 0"љ50"#Z$(FDW zh Q_49F6`}Jv.Qj 0"(h!90"2Fē9FD 0"ZP#Z=# 0"HK櫁AZ!PL(-%0"V!0":3F6F C`DHƦ )0"DFD̀Qy !`D3F S`DT#ZlѾUW#:Ag Jj`D_ `D"#c0 MJQH `DgEF̀)0o`DT#| m} 0"3FD 0"5FX'K J"`D'R`Dˁ50". `Qt"s@DgE" "("~h/Dss@De"y,D_B@DЙ"}@D5 "H QHLm&xZ" "2@DTQ" "$DP""_ 1DēYD5% ""B@D\d g5 "DD?Ԁ| ,|"I@DfV^2@D AIhn" " mR@Db.q": 5&+ݭ9]""" UTȗ"=D_*@Dtu ' qQ"b>": ) ",DēٹDD"@DA B@D@D"DDrV"b@DT""_ N)x/D4/DtAg ~H܀ՀW"i !"bd怈v"D׀(D(5^ /ds6@ω6[-7g{or?'n@8yrISA>|b ᳟xbU|||T?$Atf.hmʹ'EAۑ܎Xns˼ɋmd2u\ϗe/_}u*V3]=K3z/ƍ[~#O?~ o8TQtKr7}|·΍OM{~AR *\V=mߑ`AXR%HFD1'ς=Ena~ݹO jß'{yOB$pzaSNj5dMujsӮLX@کIdIBsOr,Cݿ<臺)ynn?B]F˘ (Vu" sE(뎢c(QaaM((8Q'QQ?GQ_((*>(*?(\(JEIEEI|(I%$뎢EI~()>(*?(o| R;z "Pw|qf~,u2q65kyv.Mq襙[ 4w빾!;v04xCrҭev뺾El_&!:qfIYڭkl4xّ5nJ}DRoHqL.j`aZ΍Ӓc75I4,MDÒIHg, N Bs_*hK4w]hK}I95@s Q2@s _I37u g{)qj٧ov3fg훫Eyq10м˸\=.vͻ|]qѵhe\ X42.6W =eg7ljјWwww[; !.uT){c]2UAJSҺb^l.9h;57FQ D~cxϚ~uĝe `c^cJ-WwjLo67GIIb}/ںe\=eu<3g IwSZ{)EC1`ҌfA۽ZMh5cZ̀kSjƀc3WmWX5`Ռf X5&=α]v:@3_ZwѦE[h8fum]4Nӌg4;,n 4c&u"h}xj_(EQo%Hh\(.:ʏ0]4siEE:GQ_(.AE:GvѸQ]4s-.:ʏ0&?GQ3ʏ1GvѸQ?h\(JEEZGQFѯrѸ6q-lEZFڀƵwpѸa7q-CoEZ߀Ƶ q=qEz䰋Ƶ kq-CtEZ鈋Ƶ k.v_1"PDxi4ylhvڍnv1"4_ KKcd |nt7hv4mK{`F;@.b^.^#ͻa{i4xi42.v 4uE~|Ǒwp_&cM|k$m\x~:])w@6Jgݼo=}ڼ+mzصyWŽiߎ@)x]~Ůͻ G7/6Pwg1V Uǜ[l3TcKkQekAEVFhv2Lʝ4; &鈸\bw:4ډ tz0&6qtF7k'bY&LI ƲtѰ)%n/:ϩYR9N ]˛l;/OS^;Oip-NT}b5?@ I1/+%ܿݧl~>^Kq{ _l[ݲ-*;]6FԥtΞ!@% C\'[GAO_I9.}syIjUG{D"Vgi}(8*2ɧAH$kZWY˲ktw#|~އ_7Zg{Y짟=u^.>}y}_b9o=FT\Wo4fYMyt2M&R2tOTW`6C틨8{2&)_TꭾBUUKAlR?Gi/i'PJ}GFw𓗷ң79'EW_A;Y]^[VwYUB^$k%FVz B\g꫷>_,74f?ufvWe콑;Y|Ixײ3gxVe$oZ~&A?D?j_{ [6l_[[/&`^eaֱ<~>w}hojew_Oݾh K.^d{@5•W-_uk򉹋w˒Yi~x ZS閖gϘ!W(a1>CSWV;ɼrt|}pw֢c.n^Y:f,gف:ӿPQfA:8|*UiU Ѻ[^KFs^;ٜJT#&Լ`~6tTlnw>$+]~]b v _E Bɠs/cM1sj+&_5xapp8YU4m-DMңɒ;=YvCmH_5!A#ن9a{s-7.yoA o\~Uć|'Xl 5 ].[#*_QƟW*פڦDĉRIoIzjR=WaNܥM%cGV^Oכb,B0UՏ`z 4PWH eUtXjQqMkhIeDzD׃w&ʸL&?}Pfm&>,}}+gtZ7qI̚=8$>ؘ()7("LYY6MzT|aU\NxOUМ)gX_aM1Şm>= r7*|\Hq Q 1"y#J2cdN2Cud馔qɶ ^L .xVͬqjrArsq72qcCw3d&`+&V^)8sd\FʭV9Qh|ȅ%[-0yrGj€+^^_mx= -0İ! ;f߶*d7D `<=O3(O#5qjȶiƍl+ͮ>Jsd24Gh9ӌx;ͱ3Zr{Dk}xp\B#څ.c46.xٵhv(K]FXώ=|  #gbXd2#4{hf}f\eo9Яk|l&iN>٠bEǰc=tت%=#1x<_-8f.5Gir2hv1(c+4'~94OrƇgA>>L/ݎ/g5ttM/pVUG!CNdVgGVMS)ib~IޥiľӑBJʷw4"<;Sx8m'<4HDE L"*q}Z݃7n"HrsD72=IepNEzp.DSR6N6o"$~I+'1O{w8(L,-'ѣ>^\ѵ'7q@ܽ}P2[r<6w6čcn.뵑Ndq٣*6B7PuZ f9:PQyr:AT/px& ^Wk"ЛU7F)k/'z՗Tm348< 6s=L=uf|P?>~nulT [:jP4a,I;a#.顼z>\:);oc!}R5iy.G.uj)\Y"DWyUi./7q†ݜfI5jQyg, I _o%N3j7JQI(b NW)mW=T-܁XkZ8ߝ5 u 0H܆KŒIr>cRr])ti4拎~ ydA 3H^.2-'Q΄/˳eZ1"{5R΁1?pZY_q'J(>?C?hu{H>E=s;xǧ Dexs<}>FYȉuV`١wE*S%ot c%:ww'DΞPK'_w7JE>c;J8|/reN>+'[&*I7W[elQss>78 t; IV͚_`FYMU<|!J4D{lZw;fʹ$G2:Φ$̢(IIʸJw5mT BQ\&4qDe6m,NmRV64Iɴü*wMH6LI-嶳ieοku5rM;\ZVEZ'aEY#9l*䘔IEY,-,FxZ7ebVQmNg ?iDu'P$*G\L*3qHiC63*KbJxgaU$Y z*7eT$"RGOgmYEhGT%+98T.:*UGQAe4vIR, $uLRnM"{&TZ(툉EJ;tN멑*mRtRU*qfZJҒ$eůXTeZEAzc=Nl&ViFJJfr+ }?p` ׼f`A@yAs w8O0 &ԲO<|s+T2(NyU2Qwɔ*!/ >7. y u+rB j JE5XuF73yEש9Q:{z-g9v_6Y=S0Yʵ}0Q֔;hGxf/ 1^Ao7(#=HyGqzP4`J]vDmsji1%<=oFcN&ߌ(&LǺF`~3u[`~3s4s}7pW0Fƍ+:;e_vްenwG-M{旽L:ws{ҹ[Sƭ$ݧtwbgہbO0B&_ɷ& H[|:ͽі֞Clw_oΦ^OI?WKb`|ɃO͎>i_p7X6tphz ZDm<`ݮ5jB}h[} =mGɜ&rӮysrQ4UlBlEͲ}+Hۍ^(6hW痈ql27y~|=?;[ )_zbO[R]4=jW'%KRR1W(vͨxC'W%œmmuyH#.ϗ # vD< }MB+ƶ.mp;g ?~J A/W4/Iz{p[~PkLuTG{}sxȡJxc]\׫E}*qfT,;^ 8 > k&@!}Ma>]B!+/>OBj|//gRp a62='̝d E?oXfqk0[3SL$eN˘s>ðmf>?Wdd)OwA`ABA pyJ3bzWy,J_;rf=bAZg>g0//p-??@+s "RP{l|%MjJL@/ͨj^~gs悮 ˛"}iw\F+Ɛt$ fJg&yH wP!2}0243.\ã//^0o_/e&M`T`_T)gOU: NzS ҄wzCKご0 T ? ?a*xX Y-sHj&['a(i0 RF"Iyf/) 3 MeRtJZ+8(P TL§H *. k:ϕӖw vm@DuIk!rL#ﵚ%$Ǚ8 Vunr;-L)-rJKeniyig֔̚^c1jusĂ6Arv۱mVJJJJ ]IǧȸѐHftQj^DRXrNڋbL`<TM}UjtNMȩ)R\#>EC&!ϣ<diSBEO^.;5߹,0v{~(}mzP A#de#sȩI>ȽLe7]_6mm%j5yL=z|z]{.Aui٣(rGyZZ-ND eyBfz!#~gx,yi`΍ 萷.ݑw +.~n߮6g82 6^ŝ@Nlz{r΍OnH'epEȥv2>53ؚ[[ğ|wL=tC6yGr[0}fٵ`iJF%= N[][ver].[׷+Q5, |^U^+> IQ?!7 e;6LD,]ŚGp '߾ףen,YdL7Mtp)܍|7nmBݤM7A3`ui #+FG{A#Ɲr=Ccӑݝh>:݂ t1?YRBwԹyټAu=TGh`kY5CN/cQiA9Aݴ3~#'~^a)!zAYWY4I(,/`6u0&ePY$q,j*yOl[KOHEeAU -j볥wz}4M5~(CEI"+J_?,?ha$n" avG_%#c$՜mJ⾵|Tq.N|3bvlNMPW`Vfb:ݬͲ^q ɼn|pM'Ņ>˜5jm)O$J!% Z>|z'>?QQ? >}='ϗ|XICQooO%ׇשl6oiΉ-:Y]7wW`Rww7:y#9P#>݃LSEɜ'ç'tpijyVTXf<;WBq{[I[ik;%ӏʑ@KsB,v%CY! jtݥ>Ji^hxn1/4W6:ٙS5m.5C3Tp|>=pt"2٤WK2 L 5+"+̯A{trTMbdgD֓jN󇫕krq" K2u,/ݹQNvc( (b'MfKC)DYW=[nwd.%1e  p=?{ѧU59S*g^Z-2at=K!'Ϝ'κ!9.]!w!C3G//04d5PgH7[L%;H$poG%Ċ߮B絴+~cBdb]܌<8a90]FRd P<{˂H]'`wiq6j{rp?Zu\Ndy9kW=#\Qa(ySrv#bG"vۍ ֊`[[El锰Vd`cKAvV|zبθJl͈6HT٪5C|Bk;|,e^&}x \ƪa,+>ծ| kg0!|q#6xG< cCޞ3/8>}A\76d7ꀢOJsX:-A]l:eHcg4H ݮ 5?cVSڽ7-9KSi A4gHM=iU{NU e_fYcx9;8AJ*f-1&pCWx:BycZclmOY8U=~/Cs6m16 $Jk_ɚ!v=sBdnLUV6TpJyL# R*`2[%+c>oec.5"mJymDA/Zʦ~i0{YB3a{gȍ MLk.?>?ak#A]aPU7QVv,<'5uzIEza+^ayKw".9''æ\_wFfzmlth}Y庭I2xI JH󲴠f7Q0<+cD}1/XkU1_#D&f82kfMhYz /׌3U%˫fSt hx#&adeâi^8cW "kGk8hX+D's/ڶYu!ޕJA>Bܩx&-Qj5PvܸZ4,!_9@7[ []jEW!]=߼}NTy\)nv݌rdmOh97X8S,m =jM$p,G|ĊTC51kFi?fY3|xѐ[UI]iZal+#D RN.yKNom}S-W_Uqciߵ=f;z^K [5ځj+%ε 'OىCC"SsUuJ#Kyt`FjJoIdDMHIʒ8ۭ@~=4Н̴󳷇"aRdxN}Bdߴܵ͡ޒax[_J^6[ (a{]{J4~8OŤ^dSawIZƒGN$mb)xIH.{}[tgvbۄ܁g-obcUL9N2 8YfykTqN!'sZbe]'"Fqo[P)viȖ,C\:u]V<)|ep0nQ0QtIHi#I`?zumHG._ح"-M4 Ѷȸ8!4v v|ܠfnA3OHӆibl76Hvi3?aٮoS3}Uj/"u{,WC.mK}˹uFn<z|H֙Pw_N"SD(]vssiv 2KwqjښZhWYmƚ#(q(mIkGg*wQ>[tkQ&@ky&q,_[Xo*^oh=^) w픇//+?oǚw@۪9,/Vj[ ͆|췽Y-/VK_;AnOUX5"#ʜk<մnCBZL[_^XYKҗID{{TayDn6ojOrU;i ̀} a5ڜSgboLv` rR2;!iȠrJp(ͤWr!s~w6_?8~y'=ut8zOq E67b<{qGۻnj{CyI@{5X?g+00^ brA31E!@S%4 Qk>wm@#)CWoܴvyI=xyЌZ1A +G8]o Z֎G&]12|m63dW싵~yZppXCƊLzKz_3-j-{=ɉ?y=DpSE.HDtvfԋ݁}Ҩ6> rS.tJݸTwܦڵa|*ZFWJqoW5%C9 Cݬy~h[݇a[yb്ˍV(u3 ; Ut-lSD;f$y6<,ę!s8{,/fYwa yw!yI;tAeQ%GN'+yݗ)3O 굊 h>%tTsH>9Ǹe>Y+lYW6o|냝۳y s6dlĺ7>V`R3jΘ:nVg1hdZq;r<$lvpl*A~)L^wY ԝbnan)WfN НKLQi}WMe3 MK6YV J[\{Em2$Ug^Έ̱/Δ(vH* ɰx Z .d>tuPɷ=*wWyb,k"6jN8ޑGGGRaeD^M]6!g41%{`_X7@@XUUOrw~#߭S=AgTe(wQS Z$ZQG=d/O;"ꉦq굷qeX r<4ٺQ D2\{mD-^8loq g_3E\rEli"G4ɻ;w&|ֱěS2ȑ'!Xj Bqt߇K+a^Ȃс(N_.;->vZ_ኞ`͒ޚa7*,"b9Oh6_֧ tgVŇj^Rnol>kVg(#kO[Yղj.V'vSn}֬;23Tט0qx-!VLmo`>z[!C Oe-CXUx%K}#mzmCDc^c"@ 8=nԍ{cCϫ v0.ZY:@R4 \?#}MXUq4I9 Neͦ#e֧Ծ3+`wuei0q;_)Lٽg)MK Jn~b%ΙV0wil"ƅ3󛃅3 .\YQe-zb!K gpn`JrFEM3kȊ5p{@cmAQ)J6k61e! g34Ll 7PpS-՜ѷվ%losqLwģw.SB#RMk6TG۾mbCq*nӳhԪȎ#$!}yU-N3~^,_/Xmd'4PWʀR@Df~WBfçGcJƵ?q|b:lh|[ZPr,hU)Rqpdl÷Z Goٍ`_ޮm'>W"ͪUo;P/.Ȓ^ԧE^(l[Mˑ,=s=Em/x5tyxj]ӞW1[9{*gNErenNڹ[>*72,骥yjR*bɔ9mg-(a,0WOqg#JMތ)ѻJm 艇QL8%[LP/(wVNZ.U9<;tഀzB- H./Z9s2,/׮̴Ո `nct;[nw+g$C"ߢ: &oĬjzs-znaAwAVʚEZWjZw-mU;Zka꽣额s#Lҝz+ I?5 U*5f /'prVNњ!b8FtF99F,61?˭);iLc}XF d{f?Y6zUX{=|]{226ݜ*fv/fΠ2fsQPa}sΛggs{(E8үNʐ*P-◈bאG ~hyR}ݍ]a^pc&gUxBs- 2v:ܮX?7"ۍNKls*W*Nȥaq:)%ݳ%UrzN UϬfDYtbb| բ'oDUULVQY9@-2n7oDHGiSthz%&1dž{$PrZ"rWԧDQ@ ~I) Y+8"t?OzVRZ0h`xgO,!z&`GzyC1]vAlM6R")H>>gѪZxEqUcg)jjS*>n|H#Y\TBZGV69,C3 K^( %hC1#K6^uvEn@<PSBF嘊Hx">LCaUnd` ˲tr]`>u3K2Zs|eW%g9察9^xVMƸ39_.cgQehrqbs:~#@$[mۗplwwjAOpr^m벞,T"zh!5Ϥ5Z+w^k`y,=jK1~C~ OÓ4S #bt7=' ~(u#AZ!3u-6ݣ7um~KR:%, ՝s.0ՏmEX^CmrsGkwt*/ZgF͔y]rD:l E:  (|f^Aٍ(ntk(Wt-=vW4[ Ejrgۙ4_;[I%&6 hT:STËggj;ZXѢ$XG~MӻCk2>q1:C0y]eV+͜,v 5Kʲn%; w5x3e +zK8s@46ΫU퓷Ë Y`acQuZu-ҋ(] XJS`dK~7NE+Yhyg_kU-wm,_/l{B)I1u&d·aH>3 ęNTdPr(h=럅ZpZ?VO_)rk9޺Τ .^^b筓'W<'PzVَx噑 /~ƫԅlj?o$nafxrxe%2-uzF}%]~=4J-ժ_n1e3@߅rD@JB7^v|(ʱQ'-y on+Ǜ[ˍIݝ{< KjLKj'4&Zn69-p}i81ݻ-Msa;dXu[Ԣ}(aT\ 6GFs~YXp):nD$:qm&i[YiM"﹈8F6 ;4z`'yBUSڋ Kv["bTbv;mp!tfe!C|ɮ xSs~mEb `ŷ,K*&埭0s=8N~Nmm}2v˘UcsH,crؐCwvەcёTX ʘvbwNǖ£㫿ŷV윤BNZy{C\\-7zy-vĴ$("w.+; 聫˞Gȯ4% sC<7D1g¹;_MnQWC\mf[ic, \Vײ&(8caC KąT\MK#S^~qT"L_gvʏeѾrQJ9<7͙y/GR74U'ĈZapOU_m.VqOРhAddŕ4v:s'ZUf )aS*,;8gzFcnPuO;?䣍C:lpYwwۍL y$*۬;E>|8u)Q<= >!K:ɱƒfX {QiIgv rj36 Kf2׍UN˯d=t~ Bjo~Xծ??_~vDQBއ5|kj,lY ?n]hL{Ud5lZҕRjWyf` ʧkXra}L]ľ;_-ʼ #𽊡oλg0f )s z=qsy 5OKܪc'nv_  =jY9$ 8 +g(8|#w⳴ԡUoFn/S;zw"÷ +ha08PB+|t{k}u]iPkҝӼs7vܵ޳?{q 7lmk6>B /B/,i@T:72:o`˯U;ɞ kRwق Mdm64Yb͍}-Arhr̀znkle)f,9kHwdf^J;bǗ>1^Aq''uv*;OP5'#,6چ#0g#i2QBqNu;uy%famX6r!¼Mj/8p.v&rGV$n^^`>@WfEK LP7߯nDX}ͫ1U +?B py"l Mzhڔ R ˷l3;cP=N̗Z)?`-l6vڣnj91S; ُLN֤0cbU bgB0sM;zU5$Omo ;{@/wvf^w7$0M BM'.9JZ|=j ^獭^gd^>?ڠhQV8GZͫ3CDkv%O/bol) mާ䍔_T~ ܼ폆,ZKH,swEIHVعܕ aX;݊==ޱܨڵ>wv`[]Ɓ;}u|JԵE!/64i&し3Tk봢;A?;2Fe;zݿ.^%V:ߝ}v 3{= ,Ҏ*9$;Re0)izK:WH7wm>9%}6;%+TsZEQCz83CCc=]w v س,&o9+zldf|sc(>qP3f`3Ѿ/L ;C|r+ɸwbjq5W9 ;p8*gWXnyqHm#}+tpwb 9y£b=2 a~ fms!nӌ&g&}m;Mwχ6HMo49/Og9ֵ)@ŮgYMUznSM!c?frx{>"pe3H@ffٱlY1&fJs;{ {W5_vT=> _Oճ(S+}Ϋ?& gb28"ꈻ /Ug }vxҁ}iҎ)T^ 7p>vPf9V tl{⿹'=&"h^ŝCN ŰC߇l캙cBtNTy_0dV3]3Uoi3;4w>[( m[̾`lļmwd['z3*BgdĩϩAh7#׻Uv4 ϶ -XG#V\FG,ixIGGsn =j_"/#˾ Yd c9wDq@Y9(u]`C 2/!Hyg4/RvIԨbgB2ܢ*\l:_`r!8V<.g8S9{11Ce{X5 ;Nonٯa%wXЏeT՚$1D0FItk)ܺ&S!orA[VBrlwb@]]Zo9R}SHmxY}Elta1Nݖ|wiZig!XZ?؀h2$YurFѣ"ֵ(IR6]ӶLRz`>M=Mb>: 2WFԚVGϙ`!9 < 7O⾒@Ry42;MRN9Aom4P!#$ye$$=i6bTG`5μ8!̘ڴ Mdxu蒓1S WEKEȕ䶒śv̦rdK^ `m /X 4/>l|)`'Y*J(uhW IС(6U>"9``wm膌Q, W몛YYTVT(K%mW|gQg2\ds.() a%h=90*ʞ8Vx=[L%Z(u2McVo׆ӱrwf4#t>/aLh㉔[t~zqgH PdŭۼPg'R۞ uNw3$Qd2^9yKw}(jYȕ>$ PJBǟQdRl{[a:/F-V /p2SY>䠒:[\+5B#]L7Sc9z>} 뚽}e&ĐBa(}cNS`4m ! w]x\Vk/#I!lcO#Hc~lB C7hl1^؏D;2P2"JyM'Ebk4oΌBڌjᠼp)ж)CDRo[t8z~8xVf6.'8O;8yP)wxP g{Oxx $id^R 6=*yiPSxf udZP@2?P$9.L&E|E=5,4>9ΎQ5?!nIdȱ)'Ú:jxSPEC<\+^"@#a0).8'{Bm/~M#L #`dy qi8CPQ,;n@l24b0^`88@Wfg<3ht՟]W% ٕ_ $*Xм}n26vz;Qm +{1<7΂_wyQFYmʲs xOdUǜ)L!Ǐrop[OAI| ^z+?C%6pbXlB׶pN>z:;?5qj(wQ?Y·)H>/~m>۹[|n+V"Ew ,AA߆KqNuVE᷻~Ct /7CZİ_ &Qv@m)!|jHU(cȉpi A^cdpbEaNz'Fgnqi+H+pM xhA;lE(_HAIѩ5ABV-{^)EoEo5[<)nEC锷ʻ[pʏk/x+]CW"$T'mvMMA^G4{&S~\|ByÌt0#lЧ|}tEWh_s&o;|PcV'o(LCcI.z) *F+|%1 aO*)C9!T,I|˹)Cl܉wE4ND"]!^nh~:8}Ӄ?[d(*j۵[SZ}|_3?q~}G.0qe Λ;VZݲ>=ߓy=& j]Qֳz~{&آB%,tvȎ) gn!8TnyŴdn&}WQNUdu*?J,[wmKkw-\iPQ 0U4QiDLv˙^]Z$E'?WM`'Z 豨sQ8p!хa@b~0 d@r…URRV#XQOJPkΎaj !8а]G]HuR >ʄt;_hOg㕓 ZYȝZ*}q.gnBQ\oI ߿_PԬNasդ_.쩯ꚯ-PIuJ;c&%p8'e(}{*[s+;v BP!kBL({h8X QO1adsY3fg`KPDw(*G ='!5͛F f XkUeR"UtBSM'찬rkvY`83 (+&aQ]GrEi BuQ4:LRSYS+ekKFgK{(] `JX7)ؓ*ͮb+Ä#Km$))󖦄]TK l/dp9`G-ͷ 2}xCj.C{1_]bVkkk1IP?i袮'taOꘇ߀:< 'O>\?)hPEO%ߩE8F0t;kJ&LSzGkK@L tJ$@U TOISU @XRtL,|7=FZ*iH%e`_>9Q&ZYMn=DΓAir65.cue"6sESa<7y̽ƕiY1# J7?pL,ٌUD ┕qWVFG?7 =t+I9f6w@y@ AVŐNɣkCF@[0 c_ŖGA F#X<QE[E(rO6ӓ8&%=|$4'Z8MXzX%fyjdS ֒aFhHhƵ>LN3 :/!ٹ {J;e!F~>c2p)v-zF^$7%P(+F&mb[Q HK[Vi`XtHŌ(N4RYaH@M,d|9LvMsI&H܆S Vml(;]O"XVpR0,]2,#P>xPRB'}IFb?Auē9,]ϟ@0.]$-'n 8p1+jG~O:]OnhZQ7z>-O^Gt C5m>}>,Ӿhw}( @LMy.n~6M>mhQ<V+NN'P~jA mhXx/vV+-]7[==^1ߚ@$Ugz.X{B9!t. 4O1"ypz?{9 {^z{N{^7ylFevvOO~]GW@Aj;m3}p4E#HV"\6VIٷ:+a?MOL{^FaՀO4XxQs8x#6zv`>hxAu8x)3S7~~Ѽ6lHmw:Ռ{)]]ϢGwWded:}SEJMZso6lAAIyQ J)U΋PfOPP`*P@5bYqXЎ-SGD_p τ;4p COD{֩7xgvf64E;MnXQJ+=dvu9EWu[_m/}^qgA c[򆼼_iC\\>7 yh߳%^Dx0[QIE4^pOD+rJ*!z f(F> &vĩ+9yaҸ~H$9S')^䨖E K<^ |5KkJJ2/:NcjZ̡W>K"L=eg!@',.z{Қ`)EN:deU{ 2 d(^PJEl0jу3F!SD˜"k)EsPVXR)qĒ !ʮ8[N#@i(wXs:a5SҖH!jvǹ\NCP rɄg |ї@<gni4*?<i_ă7inWÄքlis e=/Yn]Lt a5$cZߌ5Zq 6/XVrwTUUU5rkҴ?}˭z.=&&'?QRܫ &3c 6+{H[`vť0`\h#&PxKɀ,s "jCoɡf@0ujCâ"vt@KI8qa7$ƴ }P<E(%߱q?I3b΍5 Aa1*F g)T!Fm3c `{}]ĝ${Ѓ3ni8#oM4΁sIE g$e`_QYD_9bYn1iRI,bv gEyW˽cU hpDNzg1>]?}sGr+djnZݻzGQַ^r,Z]/j @Zǟ@Ϫ+m,NwLx[Md6 nUɾ~@7InjHwBbsRL%sI"Jm 1!HX݉\zQe0ipg3!]b\Z;~Y+cbiWTX4q62qQũnie I: mJb΍=_ƎÂo\*A$QJ"&qm:2%1/C(x іa*8<E, "tDn&m4`-ba$ҮdVAd-KwmYp9;r!&Ei[Fh(YҲ B" a:Dp9]Etiޞ\ Su)vasǚ>8d][xv^Nǜ|l$ :$?~0 FkKZ0v;D88RӶZG/I">@H7T: 1{Ok IQrF N5%DznkdwܘIӃdD+T,قRh8ޠS[*6@T@@mx1LuۣJC{r6qYHSI1]#@N4<8muhmSFH֨9e%P׮^W +ld E)!gYP 2;Aڒ!T[!#Yh ZFƲ8DF䡮Ε^gMN+QL`Xhj~& 0_d(L79ی5QCX[ƭ% 7ANB3ҦsmrC-[ARa*L:uki~*'5YI#C%S튂2>Пy.TD K aVK+"9'eI\_yrQ%k̬-PLE`SB0^ W!6_Etáa!pZC r5"G3gJԜB-dԪ nbS; 9M'e)Pᘥ1 Lœ^EgkHw[0$YB 3|C^E&d2Y`d*L K;@)!8BnxƹbD>3 $MH&RIeV4T/a4j-|S{}R [*N5#^Jf &LSH^5x0w} "LV:otЙNʈ5(Ax+"̬Yp!io1Tb|JUIgR%w%oM<ɑiK@严!{E"Y93lO HU( #|,2u,f;(T!DU1*-:4m 'XMvKF `/Bql}n^E!`^шb^x 2@s)1M"oi`@hm@ۣ@C܄7ઙܹZhD&8@f! V 4kj6iҠQV0 )-A.D$'oH>kͅVd,`F?)`5n*o ]O.W\a9J!%BmՑCۋ2s ZG9;)N])))ia"`tT|8SԠ4g1BM{8ZZ+ Jɇy,$F!F?ZrC2vGYldCBA\Kɩ6Y*m Af a01 4aԧT%^CCυ7%6JDq_*)Y90gMQeJR|9U3YUI7 D\n*"YQ !X. ߏ$Xy3*4i 76D(Wo*m""ظsS&Sc~Oh@aplf 9"6‹ANo2('^jdᦲ9P c  |pg1!X%`?ܙ DNg~W֩?)(E،QtmepM' 3BDZ!(ҩ-3Ͼk@@E3QЅC*fv"lEJUR4&2$ Z@y73r0.`B&,T7  wBS(6#f:7+,%a6mhAGg؎AR:eҰΓ j3 ẗC(r`y HA 2,6R ͊E&9s`UQ̈́23Ҋho37ɻmLYZM?rvn J 7fh%9q 6̷)F m(AἉăzǑNrJپeƥA@ )^`!ǩ"bg#tH\3YD,g{fHHGr01a@O "&sG(b'89O1ڏ-`:bSߠ8tn&U:-ʄ[U\0ŝ5@HBD7LOIWE)] :PJr@;f\B & fBJE5U"?ENDYH[h6q\wXaC%/͚ta+B!ΔuC0Аh\^Pʙ%ˑyK}o`iY?FUE M |5%G)Q InKrpAx5XPf*d<|ߓA4noFB(I U0 ldc$3l>Wz'7&Chgryդoц+vk1+ZgITjd}/I ئ|?ǻ~ "50t1d0arPK7Д<й@%3X>S,(zFSQ;ה,aN&sLӮMK0pI>2!gLBd\10Y'HlV<#1?͉'š)LLFCgFm 57@H,lTd}a ;>ˏ<з4y@3\C3FzuBXOl#y,ތ& u&k@`^Vj t(0ߒ`6.j1Tsi0YL&/rv73@hUBwp)u(}9,$&D X!^hjri`1G5 !;ہ<pUFd1sƞ$RPS$< +{a6U^=`ak'HJ@۷! Drr0ڪ+k=F|C垣R@$ bւ LD QT.u !)^ig;dN ޯ04&&Ѻ@Ѫ u'dfT*cEB,L{0e5sXT 3hCSzV1nk WM|A{3iLp^J~\;ā1|fDFxc r 0C\xz1UX"[l}`&SYGd &IlƑJ0^P 'E@)>l!#ZĠ*(,ӎEY1<9fȉ\JzTZF7FF/(DQrƈC!^O KvVZ`PQLyJ85myg#!>AJkJ2\PS'J7f{#x&Sdjє3P\uSAB\~퓢PH[0ɲk B`PH6Th*F4&+G-ҌܾJv0-Y_\LNAR Jx4%h0ʆt)=T]scȓg6K[CEFj=KJV.%d"i%*@TSFPa9 U^^(Χ^9 Q ^3 *`)h E Lj'nHȃuJ@h2C)(Fx'TMjZ6وx*2b[  w8ϼE\@A;6bQ-ֳ<۳T-¾E-0N]`аo1r7]7@de\4 7xRR'O}2p=d!>pg}mB 2*G%BNm{=KnG_. :b%MTG),?]_!\'Mh@?ni:8I}ф`Գ2I_܌6_ۛeo? Qԟ: v|~Ŷ &6glO$G(_/ ѧuOwt?7hiw,Jܽ!RqNl[=YC'cvz`Jr7G}~7j}XZ]^}Ыau:GRJqt|4YYw`gyqx|~}|gԘϛWK[8Gͅ(ެNa['y %Lr[==7/oqj_@GHo*F_?6we~{_m֒b?o>8?=wƮwk~22k_lBK"gKs-?gϋW듣)f jW -zCK:UpӮ-S,!}Ӕ:pg~]]m7ϛyzkw7]Tw:X S|9"'X=mHϕs/,?Z~;W_Gpl[JvazģŻzl f[CAo`OԷN?]W ?Z| qb}jU;}>[è/3|xn3z~t\{u=ap|sՎzgEN'WWW_\OHT=)_{V{>Qjqn#(˃o]۽vcBA-\je?W^bqϋz>x<*zp}z];iM:"nA/'@GG[!G:u}_g%1c+/on` Mۡ&`aHUaŪ|KϏ8Ƈs8PgvPu_ZC{=e=?N/ ^l|hp`uqq~qP䏏qǬ6Ϯ.Vtbw/_nTI)@NC5"۽ť|ǎmᷫ?^ =ō??_SRu0ǿds7)} ݬ0zOév==e۳K{ɫTI]~4Qh~E̮@btɨ\]rYNviA=qWDYN?Cw<>g|fώ\vǞOO.F(6`j}Sv}wKq~1_/OuH>WW&mC1;oϋoՓ}3D!逸*D%5F7ӝp<DZ 0dvud<1=|t\!N?:j7?orr8??}?',֧GO=rQ3-fM#zy}힣˫mvzS'nI= VBQ?K5 m_.-">c|F9-@k}OKn,uiD25پJfuV5!dT$n)*Q屹YL՘"$V?Ks%w+ЛIzw-u<{5ѡ-k1ٖ̓/!7(l~ 7%`f#V&dA~xo8[`R~ޘs3-,WC@ oc !gsWVwӹP5}2o_>ңжt_iރ[WBߴ(Lr] ZgPw]mxEUx~n`S7M+:h!{C{PSoPt k_܃$9LcVtѓgǏ^}wѶd-o"H_϶rGRYm/ʥZ4Am<[ )Sۖ#};ZY~|jޏ[[«b}u >9Z\Z>\<[X򕥴듓cNtI7zuۭGeܲ<_U^m gozktzZ}8)0$x_.oI(e}j-}g{0gm |zv5;:/u?opwŧm7[F~sywfo^<`\--VdY7_] zhFfԷ Ӻr}NǺQgq~vnq4ep  jXCc{ i׽'/7t|ؾC5h?bUobt_/W= RiqjenS -Ąey,[@uhˋ]4n A{5ݰS %* V9>b}nruv9v s>Ul=VPwvޝ0r7k f?+s{c,1-b_ ;.a, nu{3w/>[uxxrurr 9j@B[W>bϾ|oGh~{7%{XŴ#Wޯŝ結s|MH¨JֽVײuT.x|zR 8'%'tr=\Y^\OXqbX_^.._/$d}V̸.{TӾ ySBuF5yI,//u3Q u1M4ׇ/:9y7ٖqǫW쟬Z}8@ =q,텺MoWwnHDs#a1 B~HҐݞzD (@4=go<2 w KB!+322"2"2" 4ǰcgWpLdJ&q=iwsˤ/441ձ=Zӿ\AstyЖM0VS3:ga2lœnP-9( "&\P6RGe j-F-vz}`zW0"JhKӚz靜(D74s"lv+Wgrt1#r\MɄCBЀ-bRF)k[bTZX4+zVm់?-PHnYtC~iyk$1]^Var*\cG0MV toLY ' 5tROH(NAfJ=-UZWEnP(5 bx6Ӌ9dQ/n39u͍L?lI^B)kU+{@;0 y 5JV%XG`/ , mE(Kz\ߙd!y0XDJ;oh"@ 4 8BR$( Py( A "PMXT@-C*PJ0{xν4Ak `gݔj}4H)\(/e(46G3JHt =Ns4ݦ҃Q"*ڨEEѱ#/qF&`/mQNð^S.q5כE J~6B{e2CN@D 72jmS0TZpy'ՀI0OM nwܒeC&l +~ pJlH,ƭtq D;Ŧ-%$68}gհ@: )˛lz>=OY\  /<ūLY9(:PS"طn)e;(p*7Vm\xk *h gH}AVPU(7g8g9j8iۉT67<%eAAW^8$]^A^4.r/yo%2qQ=mz@1$^aq1ۋF :2F utT x6{`(ض;4 `+m Daw;4 śHA^6 \jQ>]T,NnHMtN[jۛ%΄M,О$bd8,){H&v>|2 ,t;#7Y2ٯYBFzS_C8^9 .l`^hME ya<Y*V A=A-z+"3׻!&$Dz4z/3MDh b QAt 4 l1|{B@hj[ f^2R mɣXrf. Xf]ciM zHT#.PҶ,ZZa5W`_x Kvz[b^h i݂"ZEDŬ#QR5Uo;vl4-`Rوnn=k% F|bꡔm5*2o[TJP~ b99VN CJC|`Ё/:1ɀK[N,__B3"q0ڝ)%5jϪD\"'6ճJu]Oow~WS̮:~W^hvuuGA+P}Օ Q+sԫ?# Sn<>a{9S\1([ʁV73~|nfGR V{=އm#ݖҌWRPIħy;|wocK"߉<6O0q8O^ŰHs?s+c? R: }ybVK1O9JKm?\?NyXgM\ 5 t~pỸAډ˪taz(&b[o+0 ˡ8q_Lʏ3:v/tH8`2!Aܒ./nB/p"ă!'B ~V gBOD3z'>~e>=B A_A(ⳂPh |HK˟ӊ_>+ GaHI]1)ez%0pXlr۫EF?rsuXy(:TZ 6^6%z.f|Aa TAϛuqpz]4%+9v=짣^~n\{/jq(ߣ]:9w?=K|Xq,? ֢F5U;vBsK@>L1b- 'oɤ.Ŀ/_5v6AOD_:7K&7fWi2 4K=o`3*rpY o v+nǗ0y.5^ݖe9+2z ? :j;_cT5M|8߭T l:RkdDb,Mg8B)e/ATb(z5 &k<*g&j=~PPsIf"bL# [Ǣl;y051#u. [ V .ZQ xcT8ڬ`c~urg^?s~Q|x^'t"`ݦW3y_O%cZ7k>ooNy|`SʶnP·5ޡW4GQ"xosZX0(A[5%;3lfzM? |"x-x+vgl =]qzΟ_rr5ǯ]Dܾv{,Z hev/R{*zZkh<᷌ =s[one@nx=VbIF21Fcקj-{z̸rYއ}&d,~>1bN.tg)f*01˘ 7byVVY1*s!\sȫ})@dh~$);^LWo(V?4|x~z6=oߍ`GPWtD?V%^=cz(fxz杦)rqYRKD\\ϳb u/] -1Lc!f`Vn[T7#3pYzJNWW*\c w g$"d9":g@h$jA*{{T7k![XK*$Vj-0B)&܁Ec-@` ,*PmRN^aj+N"+LK7)|/Y=0>9&7)oZirBxI%(ueVLl9p1gRQ0D;D, Rk+Oe-NL WX0Le?bi)h ?Qm<_ȋ%HX(/)_ws'јKIkt7E5X9p>q$|sE+ht gz %ryZLXVRe&LUl#ADFU 1g(Xw EWeUa oAj ~`Ze1-k*q٨g@2EaCd+Q9mM TiZlJqu4F+GJҳܠ:-n^ mUy1G ^QCѾ.O=4bbFUIxx * 6Rj^\-$aN&S)D2ޢfx)͠N7|PE5?z.\HG5%L^WJb=j]Fpƃaktr0)v&vݫښ8ǙaI!<@VIE%P "|LHbr #?IATf{-o9~xc d$}c^״/@y)IgM3:݀B5ܫjN*z$H_(R-J X5̈́.M3< $M8"t}IG\7MQ$kX ~pQ-i mB4:v *0aD#i6*#Xپ mϝ,x(9,t&kF( L\drޏ䰑.Bai+azv+FJ4̬֫ u3Q 0֘ CN)V8Tr. +vm@b,uH y|([YkZj8[G ;qAORJj8jl/ PvB^"pW"LJzOaإWh,b}):=[bC^Lxzc\EQIqEgԲ1GT6`nC}).͹bf03Sv~LR+g*y9hY4Ds<]ӱC(I" Ky; Mګ1S.u-n q-5fPK ? GF\sUaJ}d\FhqPe!9" y$[r/A-U_M j}ހKSmkt¢,ȏX\KSGw~ƭ*rjO ?'k9|SYĝV =J -MY,v7:O,Xro%(@hU]g'Vƾ)U9UW޸CYޢ|ȯIm$k^/{HE*RОXΤn!1e`WD%] .K&yΙ%O}x>½EՒ_Jyid$\ 1dk5H*066$qXr ?r$ԗ*8Se ){Nۥ\9V{KsS-JC粠$Y49\Ω0(B}GͰ2l/V$J"cHЩ.ZJ9(ISpp܁Y69ַLWj0UM|\ѠP9kǗ1zӜ=9r +1,6ݰZ /V\J9LZa-pM-Tw;\d֏l})bϱ'֧QV}RjNjɛ H/&V_P . nQRIEr绥\ãI<֟,5/z!(=NޠĿ+˓:৽F6to@_\2u[˶&ʘvqqK)XsThgx`2A]ЕjuUXukDԹܙCtdqyuKӿ:z5}ʹ8Ҋ{} Hkȟ<[C4RLcJ ,$xG4w}5ѵ[%_/^w̙3!y*}ڰԇ:YjbGNB(61 r-fFyNj>#;(뵸CuKxoI!jx ,#\jkgЌPJpk^Hx!>}s(2R1.s9uoZ1]6hᣢ.c@7G>.OSڪ(6B_C9( eUޱcPchYOB\["oxf<^5Kɀ7kSvlQ= r F8Q55"{É%ې͂Ի S}E4ɉRz m(VsS}g"j3+3=FP!f-͜J8+2vr)_{!7F7xZ*Om /-=z> ji۾ l5`1e}oz"wVNN W'1~)u`y}t ;8KRŢV DnہDWHRļm%}B͏mix(8dL!M٠|iᓳFlGdXVf:qGtm,{d'\o S4߬+b(| |FV* -.1`<h<^PT #Z_Z5P1h\ZkORt(mZ{So$\8\B_{{AW!Д][ 2$QH?ZF$*jBMHvv50jT Od=xf`I6R记gp7'$WCvWDt} ͨ`b9MޞŶN0|<vcZFKѺUpjBʏɘq j4<2eHI]f͖7qXӒnL@8-I,-},y'P)Z<ӛ{ӬCXP] k(dA6 m_5%%K(؛p-=@+jOҍ g&ӆ2; 9ԋ1VLF օ<ؐFoO'\6T@%+=΅|Si6ںi&pIO=:#;Dͩ]甼~3{O*iL2>B\<- yb}v}p< f-X3J+^MJt^|jM^#ː~FkuN.R5zS{%84T_ :=[c iU7uL:ʔ6gȠluI4z6%bF/muVx0# =6N0QԔM=%{DeC&+9o.*а%ͪtC֩wcxoa@݊4l^)k%ש9Vm6=8+Eet[t:tz!GtJlVKXKa1{T5v9[IsF M2Ia&*َuIK𒪨S* O pG[Z@, r@+c!L.Aܶ;b_\EQoY_/V{to؟O3LF^#&wc115Wd#Oe\cb6W58>%[![-$NeEp ́=2eVet$WOsR4? 2 VgjǝdOnҁh ӻ jΪFx )"4 \Sdjr !SxFGQuSCʊ 0 0 ]q YtoXpҳX)U\\(8t盅,$yweu7kGhͧGIK֛4w\d)KZ >{=-IP+quuݺ(MuJ"txx*9z}a{ѱֱ]xM:QknFy@RmqgHnr{yw Q!k*2@Q@p`@Kva0DmqjDU?eQeɡx_(&&T$YeٽY8lUGv@ DCK>m0ώ1XܮtRm K7vRЙ##1R4TeB ~FH*oQcu-}W o["r $rtM] x:r] t!`)j'%[bQV'0 )N nu%#>++ƿ,pW&AՐ6F( FHySJ4bP, "\cR)ED!8 R;L vO&,J"* XHvRHV:Loa\ʙBQ-Irs. p.$ƭc+*W;;.je7J2]hg^4yǵz(0wTG[m^:%8^YBZ6@_*]tܨ@Pjՙa؛q"ZO5H4&d(XJ{T{GDԅ5,֪WْEqesPePl)UiJ=hc8lfu4{AU7%ZۃW:^+%Z2(/jX7x0sJdɑCiYèڹR%nڠQ,>ח~E:xv|xv ` FT\ XDΧSf&/O|-X/*`t_.g%6I ߾·W|e<}{)~|9=oO!?=?^}Oay_^o^MTٛs^o痧 z '~<|ݥmx/gRGӿ=^ab)xz6~nB!Fި&.f,V@瀾) $fg0nȐ߽[oߝ}s1Eb:|^H뻡 }i cq7j@ "j*&t|y.a.޽ZKBЫWl:xc\PsnW8鿾t1 Zj@z֯Wo.&ˡ Z[3p<~w- 0/ 1Dٚ O_;W41#bDk\]LDtf] b4fy<ũ <,CfKowyQ5cxX,~~~`-dDzTx 3Џ^BIZ'Y ͺ_F=Zr)+ZNήқTo(n0KUebLBҗ*ᷮ0L[2*X\٫D>sGJ*:H Hօ? BƑF5Y5Rjk?,(uG2橪4*}4CN=Dn4RQi/t\ &'4% 2 8 .RuC a%QRäx'Rzv:>t@I 00-`4bێqo$F7 RhcM$yҬ)7ǂkno ;%WT0lvuLz::.9TX ɗpG〦2AH~U*t@\[XIQS2@16:ĺ(?Yu`F9 t}#^YOȆ@b ֫?{f;'l~}B ]]@?p9oi<_\BxS' m;"~7|gb']Geg"+ ׎Ez 4:*k'Z0KLuK`J^_C|Fq _D1_ W|PoX?wO+|W~q_Ю'{m_4U[F[tU=6'pq5.cٟg0COgn.QX8c_A0;aKq i\VD, 'z;} oAȺ)S IӠ4X'[ܔ+qS] ;Ɣ[N\WlrtjhvXm[Kܹ}Gɀ:FЂ/w5<+ֻ-~ %P%EPa\\?}'2%( hqZ‰O_WV'1~,Mgu}C Qtk `[/:GM/?nF&xF]H vYИ9hcȯw&,MiD\УAɱN$O"(n@@>л9ƶ}.es)~`jrX]G hL0 w%S 4O/1KD@ Ok Eh'FAnMD,(5`\8OG?u`ǝٓ7f6c{C>}t1O}`:};}=9qBﳶ't|S"8썄zfZ4nrW#H[J =oiCzQd9lګslq4ߑxg`~] y^$ccx}(8{U=1녫P ޿c?=)<8w9׽3N( ?>nq%4>N:8Ag~:ˍ_ #h?p6G?yx#/ Oos`_-S~.fAoכ>#:ݬ0[.7:xۙ U=nz;*ҟkϿ{1U|(m{ ;zE:˯D\I Wse:W+0,a,I~|qG̡GpXs6@m(JR`ii  0`0]SsZw|Iy\pBϸ4 5V~fꅚJdb< ƑGbz/^F 00 0 0 pّc*SÈY^_?,oVۿ~F7 -WB 00C $\ mj ;Z m*'ViBhP1AICOJe*MUA #*$T"΍Gi/D8|ȯp(eMEq4CvmȎ#{lO=f㺞Bq xI&8_f@~cr4r; b?JPI8aLYH^ot&&<౉Mg.Ynݒx6؏et ĎmѼIŠ Nf%S\d66vݽ= gp {Tu)r@ء(q(;<=p4D <F16:h69Cu_u-`Nj nH̞6a}7Ӡ,(,0-.|Ad;MWX[ﶵӡ9B_"|/U*oEєLb#/d[IS" /ȊIOrz_1#0 /=|YG$I3 ~UO-#02;S^t8%F?͞"Ua@Q{M9nt@TvЧT\ -OF~鳀ˢm~䫭<.T+G0>˾L? }?ui0C>p#?(T}X?FjQm2uqߩ}JwPw)&h_wa]W;=`epV=9*='e ï_u=a-K;&[.~Oᔬ{h{#~?#w"k>~4r?;Cp=;|=cp;k7;ɖkw8l{n~Ͷawu{~s]v+;bmbå)=obÝh#;OA-bÇp"֫;܇Cqx@N j 5= 0|py|ݝ݄]=yܳsJL7M)PGc8UƑ!=)R/I0ˡ y9O8yaI#Fv^p4 hNP8I@aeы{rO$W|Lh.;w< 7im@m7D< SK:IHcsځ98(C€` $ sv~;c؋p:A[n8n2 Ki@iv*}=&7YOC:MFÉyNxXi&=m2)d͞H2ii, f|^>ؒeP^f^)fQ&y;|:s -:)-rM`نNgq6h{eh#yy !s yXeQ@PN?4(,쐨^慰r`#l]*ry@7-^d|t@~q(Ng" ҉ 'ϓ؆^SG ؚaN:O$ /Ra9熙7DR/@  ! G6MD"HAq[ 3JD9R Po~L1,qn$A'((O=H/@*9)E^$>aː+?]VɧAAAH5jwWՖv~(=@J+Pʁ4CIg8h9n^I"r'uK% џq+iݤ7,D^hl9ig "ZY%v&k\q9D{y[HYŽl3ϟ! 8ž DaY @DS~&"@\Eeܙ{:/;πs.; ) B?A;"B D`(bDso D ing-W%J31*Gj)EE /'{+UTWD tʴ&lr~R[np2a"[:kYR>IXeDR@+orT##aBR@Py.#T9&p AKdM9N8& 8qPUW 9Wth~iyqnr1OgB&ف؛a i&3<-i} QZHp54l9jA%Q`a0cT<綸/禩E}&ݑ[$1EY@ppuB8*N ,y$a&LSFfDn!)pYS!:1l:UY\ƁQY ѧX&]y JiteeKd# Ӓ\93p> cC!mx$FSn _\H\?v&BH`b* G*F0fIg_L/O69Mw4(hQ)p |y 5kY3h^'(Vf"PguTmIň'녁(:U^Eք9o^ rei}ہ \o,1}]' 4A52%J^ WPmZ/xhX 74V&9ȷR=q6}r;dךуA {JD(Ʉ>.IKNDIdZr()4,3BɂA|c%8/E6).ibRg U)0p:Mnct_X $LDJց-y ݟy9|MSIH K3]Z,y:¾_aRA{u@ ,YjD"SȧMQi+$ 2ibi1~ςO$ua/)^3w3w>kF"%44W`E'őP6s%IkHiyDpq hv|IN(҆sR-*ԑR(3JLthMb biD]l7Y`rFfXKSHo" 6sm ]L8L$%'r\B,me7U0iNb40hF@Gci~:᳑WKsQ~y2CgET^`w*y\ΘiD jtS|T>Y`3L@{Shd 2bXI˃:It)Xq@ B+eb #xqx 6m%qaD>/#?J9G/#!PvLA/>lˣ?1>k>y-sa#R`Nӟ"ZIѤͺ[icz>|=&lxUfvxq$^XvѣEW/]I_/udF4]5`{g~Ghj*~]GhDŽ@+2imCvҔa`̔(xȚhAÑ?Ap>`'Ap )?peL:TH9۞֢Y뮾fo߶YY7dtXޟA=<#RꥭTW9KPgեi4h|#sQ5:kzT,O*?{b߳ӣGZ3 (WRRZ<;=:h!g~Yv٢2w53î׮(]f8*ֻ+cWzܹ dQe"˻EXzjlqLdzj[MBVUwĒ 1۫ao|Gߖ3{_KL3T^t+d-7)q*xյ..W{kпǮzk |J2AҴHcot>辛ћ QgowIR hÇl[m˒R򺪙7tO>^L ΢MK)ۆj0RͿhz bs?gH;ޢo=i3#k=}=U} ^ifo.Yյ &%f#ďί&}z U |ni-ocEꭏnoG[E4I/3|1kJ^Oz u{݇ɶ-m=ќz3njRUpUѽo|0aݬ קO2{PYQe(<ߺrPn+?O0ג<ݞ"Z(8o@70}MgK+o:^p 8ʹ-}6J(C"tgmW,CЊ>Isf]@`wgЖlN#og;- Y֔knggmc 'e a-bSsDP@,@f3CLGSMPIoLPb2~wbz j<æ\ۇ&7l h 2M;o->6&5hd_,UK޼qY_W$)ϊHR!6G4ĀA4dpE{m:z.;]uA:[yYqb lCPʌlO[Lw/U OVor:*VtŪ˶Z&*ҷ<xj8=lroMA BotHZ3LJZP%n.~xcc=TS&[l߶ 'sXd^.Yrm"ulr)::`EoE e'q6UiLcJHș뒆,I/Rոl7 ljU_"j!yh\fvӢ=Eߤs_ )  qqIh[oq0FG0{CXצ]4{zދEoH_b)gF#Q3fuAΔ6߀V́38@; އaoJu jpUZ-2/E}w~5c`+n"h4׿g;Y4#j0}mV>l3AJ[_dHZ[yʝuպ?kQ 3~BNuoz4HZIaXc;멿z-[*e]lJ_ҸxmL^0CTL}MR uw &C)=t\}+6Qfz,[$Xi:޺9#YK4ԩȡPK=>$Gr3_S8YNat9P ptt2eIj3zdj Jb։x3ZTa^"1W34{̚H2 xfoDż=8l6 @,xPvw<϶ɞ}˕ |-L)b 8_ebE80Ќ!uNT0=lZ NՀe4gW&f Rִ|1`+gݻqHhEh"Pv#3kj䗴.PNJrR(p*:Hmi܁BL=8 T~bdڜ% ZOlLUdɧ/)A.|vZT5\Z:Ȇfꇣ 횙ϭ6]P#=A&d da1_.N?廇<;G, õS ^;Gկ;|2S tۋ C70?Axa[+d?BO i>ٽfNjksVO'{w??[A/AQ51ugހr<}y>޻)>dI9,''2K Cd?OiY=-0I# I``na♸`/Vhk7]%/rۯ۱R0]Fgy9fXV }?)qpŧ/~]M t'+cX)2F`ִru+yQd@{p2-gc()Z?mbZzr;L`"cPgR>:zuog\L|}F[e]K@/ԥWfh)9뽮a1tA^3+#V~S]!OBvCW(Sa}ۡb_~Bj>]F;{&'<Ez;8W,CgŅsԵj3&D{a.W*a=ɪqޕT݈N#BEM&BD0Vf;9V(]5i9ahII4nB27xZgM4aT?˔_tZ*2_ej,ۆ#0ԫ]zj Y<#ohհ7NɊ+vQpe1Q'}ۥfojF57Ʒ㗿v>zU*w,eHC\ILS-f kˮLVSPL4kB'`UP"hv_Va4( I5a21~P*F,0Fywi[P7gek6&6YTndĶnx)@-%8WK!QiBXilzs>Bee_LMyWvC4-v_|\Aa=TPhHJAuU'aP,m5-҈[`hKd/%íV6퟊2]cڿaQfZP'1P);T͙^QĎFo[xh_[܊ؕy}ʻ~YiA/ A#Dc\T!Nxz:m]#x`grcfc^X= XkKr8K焣=Ifdž6$s(mK%$+aWsmg ~^4N;#@^h;&cg8ZW'n9tp8P|=*1j)"5luTLUT5фA]`0M#3cȯ'n}<~MR*ڔ*#z`)uMz}ID6usr65^_w5il#pS6] 3ԓ& Ǒ,C!nE=;>MwX.oU8-6*nu!I=ۆEr5˵ushƗ'/:|kԾn-uW n'_bVOgrK?iETOꦐrD?=\Hm(:&E~lOW݃ZΖ@Ye}`Ϫ\n:IU=?Oo}?.:c9Ā潺b4U`址)Ar>7#,9DGuD"J<"r^Q>Yp;0S4L=1S4/h˓x[m/B_D # /jbU40)^a_rn uMNՇSM6eb-!oa1?ٗx]XCSa*չ';QR)jQ "@GPa黭8u4Q^GCa5zk1M@MNp7jmxFI "T,W)Yp mX׵tMo}-ʩNr)xjfюa;>h:$?T mfb/-bAsKi,_, KM6:"D;ۏ֨\f`XIJHkV|optsI.>^#YC,hP+ߪi$z)a0CQptDk02SA!ym;(JB.G-F37A0`\;hğ}tch`Zu,pC8Gp| m|ofd7u0lOzrrrG{QK3P跆uԭ4! j'F R{Y;b^,G3U**Lע'2$]{2@]м+^$v;>]%^[2勛!g/M &tQ.pr&[lgPK5`e3l=c{|;tT.%PF#+TU tذmkcHE22znM&pкh\B :.O+.IO-U`h,Yd|hDSIe&ᣧP - m8q5L *q%(~EUL;+ʨ'Z:5^<02RJ; FІ|pF%q/Gj1yNj㼢x;#\X1@1l ~{Xj-6M9RfBшi_xO|ZzrC1˾St DiUC1s׾$#O:sD ,EzjC 9x9fxBuѽ (GNU`$y>%)Uv)ߙ.X¤oxH.Q5q 8/" &GS<.%h9D Gڇ足LGeڊNpfA&u:(%uK\eQ>HY5mnqRO>?QAU 萜Lzܢ5;Y5&-@ 9u#p7%6\nGQ5T&YCz]'HGse1 =aI6;jڎ9];t.ݟgf7fR`Fd-4'lA_',qc)̢Y.R3.E/}d0U@:ą+9ϸb+x-zJ#[h.GuE;5.Q05o5?MztVL+qj9|9>GYb2=]T{+ܗj$~=/M4 6iZ-0G¼U}=B (<ޅ@ yr,i w/SV5'WLe%naQvto[/eABy_# 0-S} 7bK$ÖzeG"!ZSs㊿%WaSZ!;º>'3SBՁ\$4=? I3"20ʰ9jlV8Y @Aؾ nTSɳL:(66ժ&l{niP "U!w+8v)4$ѩQ/ql_W]Ҙ́4:S9BsA2s #ՖTвd[yp߼q}J?q̡T̳ݑnYgta6zեN{~I>pEqv˛xX@ϧ8GT`5̈UB!)rRWe$$#11llmX-Dhu %ѫ#5TkwsDѱ:mR*Vw^WUWLjjDOq<|{'8cTѐ=!.\j\;ɞ>Z 3FFTF~~,~ͬJ":{lnXYEg:LFEQ1m _ku{*Vaň Rb=_J샙W]xro2-f2|muaU_VOw~bdzz#PTɀj:OwЖ p+/]'fv#Q£ȫTnE7&n=PɒCFanݴdd*5[NBOjUwaI* $n_ԘqɁ1|VC6PZ^|)(\,e#R9.eі3 b*JHx[Nh2ak\T6mH+gtaۢ ~GRE2+FFQ`=PD.=n9?NT풛Г,8j/:>"m;&a>wd"M `jb+ ~}h|UJzup&fݫ4:8Fv`y W]e XNᬛ9# X@BQ9qvAe$߿sى>8~Ǔn5Z 7L$+лCb6  a5*RUMЄu.:,|¡8nP?u6R}lh2t* v2ȨN@L)ȴFB6*΁#VYEhf"uj4 OwqƣGC(vQ>L8I ^٨1\Tl* \ɯZЎW_lh-(Nj*ͧX54hm(ҏצPZ$ 0'},]U5rު@/7D1+ŁZZ%WU3Uz-ڝlQZ,1FN b?j]^pʦcɅ^ jG 4ڴe/ivH4VTg.C;-Z$R.@n9[нXIOzSH`꼞SLhjB`3s N^E/ȴr(0 ώI|0NK%&d)Э66+%Ȭ׶GA۷8d@S/rh*┟%i[pSʤ"п2M [0ܓo祠f#?/6]ifADxc;AEatvȽnWxrΘ2XrJІ'[sPUE,x5:6ЪÝRܘW^2j򕼱.T3K=Iַ)ܱ2[I5VR uF֝31kʂqMQeiaxZW?0mSVxu -,Yp)EJh37 b'URY+DM6 ]ta$|N aS ,#SF5.˽I`8q臠 Q'½ǭ*FGK{8^U8;)3:ĀK@9ZWPf.Z*|{1Ⱦ-1ʴmthkw49qM};6A\oˉ& ^(W_g ~"K25g#Da |hi _GFPYOh9&I&*qKO{3UhJE =k֬1 Do>LZHDGgs>/FaD2f I(^Ke1ߤ&82c^'~ . M]Z&RSV"8#x&5OfaѸO}7R;fW@Xfը('F$cra+5[ 9k(JBZح,4J68^I 4e%#1| Җ70 ztB/}YæGd9+1FEm)aQ' $-fQm6sK{{Y|^ hAJY적OJ20tU3 vп=X(f#CDoOPqc@b p@f,"kدcg)h4\TKɼ-Ѯ0 .6o)d1'=,sLzR\寫i 5Uid7 E*59MXK׵XwV&mT͝ET>|p6̔kR_0\mzCUD*;i S ߻bKXЄX Mv ,<_<˖JO(}pTMjC+8,1Odh`Ì\*KN]F9=FU5Mog9jľ,&XA'*%0aȌ-_j)nhshd*+YLV>Rv (ɪuk_̶ ^gb. tjR;(RSY`"JTb@8UPӡ pg>!VtZ@}; .ʇJY v֒ c˝LϢ55S&s{W}u]'lyg".]J2^ 2'sQЕ5H?7gl'iTsh[ps' <h6uWo\B"+Gd4!Q3(X. Π2`"b #q* Q7PHniܰ$T8KR*shQd>ZܯWD824Fa0s 06W BvH:q:cgO*91*, 3kPbt0'GS]|0ի^%︑ghʦѸ;_}B 9ފPhHpQ`Q·'9vE9NRT CN&P<>-qv6> ;/s7)oU9xʏucM Nl\hЅlJ*{R fR;QW"׿<2$RKBe!q Z"-CX;!9fCq0 ,o傜S$Vi;[} !F8Fl0&pfrn _bwВҥ7CIap9^!WdZwI):? cc)R$=/A-If|Rb0 vܟ 8~,b(}")N~^fh9/s?`'_svaa4@&F=ᬸBf[Z] J >S)CAbeh _YT\WUk=uL'7 W|ïF9jBd$退AP;y 1%d)O݃82)7$Q@3wǝZP+8^0_#t*~Z˭wG <{D)kfzz_z @Cg(~ÖnDׂ5WeUϠg1 )FUnH\-(ߪsh5ަѕ4D/( ?K|dD\ZYטq88+4tS|ĀbuYժ]Gp[xnemX4sFr*ҕgP_{>Mt4:[x=!6YtիLyP2cj䘞S#QML)T0T߃#z3=J.ZfJ p֩9LO&N21KrʅD2]%z$W %6hqV uٮEZ2:Pԭg1=ZˢǞ_!5ΓHv{e8Zvvo\ ?(_FZ\4[X=9VQȞ!{ͩ;q~]Rcm܇Fv`;4KV< 6h7%;-/LI_UoI\4?BlV* -N2VD%>4t}E\ȶ~FCOOo~\Omc= U[8 DE;+ @xq 0GS 2E9}~qqqN.K_Xbzt)Gh5p2{Af/2g: ,(ܛo>a w/~RNlв>DG,=Zwޖ(|&洓[%o{} hb3;C$]<~׸z=/o]d8 y֧f*םVr4X}@>WMvHZ~.M/=4_\-%%l Zj?dYaB#j#c_~T0@* ~7˹Vt_LܾWUfZsM0f[֞jt#u(}0^È-iW` #m !ŜujmG>/'~ ?-;'j2+,끒| *(Ťh ,ZNUسw9aHB#$T@` 0\sYƒ+lv?T׿P&xGn SͦC`OkYu6jo6үG ~p~}:xY^5K8iOJ12SFRemN׳ؤtSWe @m)2֧óridڕ?7AH*؟}LĉSv+]|RTE vD,lB91LM.{n|[|B\5R<.M#Hg57u˰f!6L1$[M"u5.t&?KNjxgm&UPJ۔/|`gAxPAMR2J[1Eº\Ί򹝝\dS8_WPϪW诂d5a*GFte`VP3ЅTO>?5#–|P߭3"ӣ3Rk#EˤK= gVbg:N-3Te;.g.Q,Ǘ&/\Lt~^ kX;hR/+.F>9zٕ2:XːrKûsh4K =!% ̊y>"0ak=.mZ겨><:H$|dAۆ vvD|{T ʩe\c1[zM/sdp9_ȶ} CBHPI#bObe4.rqHb:RW>Ŋӓi+ ('*VpT cO.,Ԏ"S/l>fwTRw\Tg9ṹ54Gn>O<鋣q{du(%zr|pw+RVmf<2[q|rm/m<mdHBjxONOhЊvSSVY96+N``n+CB_zd_G 9yD#MDSn`\u]A8G:FL'ngC}zҘ;Ikں~n Qkt~AΦ$Υ[dB8Xsz5H‘zY߰oJe?^cO^gH^cïqf:%|gF, r! $ ԡz߹1K ԇrg& 6G0 S5fLGjU*wV|qj4r(NE5 z$W^AF81/[^@cSev\)5 zmVԢ11\0̷(OoI?,Eh+щyDZ-`Y鞄KLX:9; 2wX]jZ+q+cT6 RV,w&-ƒ@ڃI[0Fwu+9~&Ii1*;&l.a*nӜ>eKf3`d7͟ZpTQLĤVQW{[R[/m5l+躏#w ~CPjJ(('OzQ^8 .8GڈQ<V虣TW r8q?Bkx*t-MjM*ijc4n}z1;:yY$eNul،; Ch;< !`6JKC n(=Vs|qX$ML''ll hWZR ̒$6Xk83뙽@g1JuךXj7Xs+\jhƵ3 8m;/3-}pAAihq™1lm8+G/իVOdCIp)3BR ή@&yx4)b& ÈuiCS+w7upSCisUf)&XuKyB:lVi|p57*E2 l]_`{Ivdd)f|ktOeH+>~m^/oV9@/LtlӍ+PU^0̿-ʎ fpɺq]T`:xNQ?Ydw_COG=gܕ+eRpiΊNٵӹۜm6;Aߖ eY^?bC,\Hx]>*PFX$J7OӐEa\¾ҽYt-)i3};&JCøQ9)KpEXKKd9KMA(OI얰ZǣޯRޭs/5W"Ԡ1"xIݿwwlpU3l`;U&@wvLXO#&/(im0C 4"at6yuo51gAN,o"h: gQ?u63&?z8*n'UTO&Mlx7',i<u6]#$Dw2:| #ŨJÆĎtaɑ#'w527=f/zY]#X%?oS2du$yz"*^5æOG,dѦ)q!e򀢹՗y-vaĨ|o^R[YAcYʳ+<1|Ge ~ Z|%0x0tEwgW Hxڹ̴u,0#_@{?P~q?gF@ZP)N.1jڷmjFy$:!}z-AӚ! ]]ztz5 hgaȾ#_wݤѺHePtrFI뚬KI YoӲZ$X9 'Fэ1IDn+9+'RO$\#s#Kfi&HV0b< r+\.fkK4Avw4H.1~ٱ. i.(: >*V0.}(q'ecX9_pcVK`Ƕ-2EQD %fdA6(zXe0ւF771Y5!< 'cSb-9BK*)uQqkcT1[sjȞGY7He"6zgw_O)od-'&AZMiXKKF ӳ[gIgػuؙ }<(*})$rNQms:;z:#6(c8$2 t\L<(2PC G]\c$$mDefsJDROcȌo4H n=(0w뢳CBuVVng p0>R0qw0w~PqGh)rcSCTܮpR$~g)zfUթ. ɸb"p@D}[$4$Y?MfC>n֛>~-<0=$&LHjQC%L!Xe%޽1o܏ӏ?,@#`p61BzD|̼JQjM B[`r3> ]\AGjӁ_{h:ISdpN*vc@l AH"?3f0JD fb;zHM;t%x`"om`C+q~oW'JOĈ!g3AZZ؅)|qCJ)r!:;' *MQ'un.MVD!nĕ-ɾB+̚='JsF$ylEa5ՌNa^_fc[k+g G8d>}@7m՟ js=a1EB>+ 'ڼ_O:~c/h;Ta`_k> rΝ.4]Tk!-ٶ%ڋ54գS*c[XZ 7 Li f}J,g֣sE6:/a15 &2^vP/!DF2xYrN; g$y|5t w[(Jsv6jCgGG8%rFpp+>ufݲ:mȸ}w8>>DiUw0(sLSp 4;xTЂ+{1݋uMGP5gJH AK!YA ('߃\WX:ܣptnH_8 zqCl2‹Zbes}J<[@o]UmUЃa,[@PUG=mZ?ô_R$|0ZȯbrP쨜b,nKaÍZ7"_9jC;w^ P/꿍cp_?J0^OPrzSy|[5Be01F$ώ޼ X~z)lRW|imm1}\k0QXwɾV8?鲄G6[;$R{`YyDM@>*F)Ë5e!6RyԂ S+' kS W8%'Y1 "ݣϙTLPLbfG_ V1A 8푰7Rq>j0WS8d"=zy4vSv74AɱAcly߁~7v Zj"ev,;^;l3<,[hʪj sD2Pyk#}"b0s?LԊ0WAv'"#I?yAx)G`vTs1ăݐxV~,rJh۔D#Z ۻ6F^q^DZgoE9b22@p9[wb65emAΫB7#BۯR)GDLe,mh-[km舂 +2d'gAdnJi|U՘@P$E?2J] J?ΥHDVjN KZ;3ҳ5ߤ PMA4@X~L0b?` 8tT.zӏQbobD"E fV{cd~ 摻Gl^Isʌ]s-۹tLj $ABrh_gݡɮyv]۾ VpFDØGKUlHf@BD1Uw 4- [4>e=8"$v:  kҵa7(`ҋ j)r(Xʫ l^٭b`?|G[MȞW! Ԕ:u( ODJ`Z41dMQ(No6ر%MXuZj{?z& K+Eo2eA/MDOLԆÅxvyQ'ڞq8ҟ\1mw^Bkҗ1X ؝u#EE"8\Bi?i;Kf`U870ASY{gE[Sm4#QPu"|Owb4_=yvpZf}pme,{yS te|BJR}eŦ-[yV6z&ǫjx̙s:2=WaJػ^ewa yNn^;uWܶ4tCBq&KR$ƺ#_OS-U4o]FȞ|gXw-Si3IVR*yfxQ̱jqZ Eԓৣ!eyaL[uCqjMSjzܔآ \zsڸ|1 [G$~hTq[YKJYX?lh5Q*󉐫O;<ݴA8nD>5FTo”+m"Ubvrΐ}ݸ*'iؾ0cƦ72&f i}sm^!wQ9$xC?ye%cGemcvT|V[|F*@aQl%1Y&g Xуd, :RpNεvB$0:9=2yuZ%*sWߦ{'kE+=| ,{72U6_hŸ$q;|f:pCeE-Ty}M!R_4S؀ܙ o[>Ufˑ7bH=]ѧv.u7߯`١Y P jfWyDžۅLb#=ңK<ހE^TГ'4ght&?/Tat$;waQX'' ]ӿn+ vQͨ.:6&٦S'i 1{-L:78 0h`KH+_<ݛFI(4[)OԸzt!4Cg#d{]l$fOlu'$^ewetmlz9$e?,;EnjEK(< 1hMacx驹=%x=xZI/{,, w57׺~몘[י jȨ18ޅ/~)@$jTKBx[m YyJ; }(.93 T߽4=tj, lp0"gL2^5"8&db\yFYχRx`C|Cг0n/J#un1&SS=0HQ"tR$ %xU?c~3+}a#݂R$+s CEӅi.lՇ.B|9 ( ǓZe`ţ5%XaLŲhBN5Eh?!ϊLmFHϸx,RLK lC^E2>,x@}:<ך>34z" >r)0z{= 3|ewN9͝N+4+sՁ5hZZp7|&pTlyVD뻓Ҧr%.4_FxfY-(`|PA-VkhϾa ;&3^R55N2JV(9)pU'UI1ɞޑ]Ĝ\'}؄TagvH. 6q~׎uCJ/r Sk:npwh9fv"t9%L}c`$rN⅙ 3W=Z\w(rACTm`7 O%|F᪥sID'FqT@.]M1JJ|3PxD}h`n ♔ 4Ix+ UUSj2CmZ+9tQ~  CbX!mPG5 ƏfZLZ<7JsY~_8Tb%H7y5'ݮlg%t nˤgU؊+d,:sWgw2Iq6hX)UG? P[o]?~} _jM*44K |` KRf8W>+,@tiyGI7 5d Cx >ɃӄHR,]ƖQf*8Kl8.zD"t|=f2yZw$ZD51:f?p{q}:ҿ{ol%0 ؤb*G|cd׺b]16Y6 =GW):&4Il԰ pZҴ@g-/S+ٖ:]QDE uFp3LEi(9+wu| [YՖqPV:W1t1D_)'ea0:/Rȧza"yRv[{FeE~3E8DQ;sbsU"f][Y'W.bЪ#* kcE2*i`œ^zFbl䩖Ej\h+?`%<8lLXq8Zssĵ~E!$m05'8@'P1dVMjy~ئ5ȧ^bFˮ$$s]-U,$MQ V3X|dWmմO MWk(_/ɖD2m\Y<)fC(ք;$8{[_ٯ K@d4ƨc,tҊ#q ΃+5&)ڔe&M񑲴!AȳSj#ðL#|1 gH*OsldžxbrWoQ!COb&uC퐳nn#΂Č]5/7p3flTe_}71v+$8Z |$F!M]J .}fW }%֜ ժQu6M/ ԂF1 X)jL2:FWx4 d4~k [Χ8U h/zlk-Ri~ė\ٕH@BqD3g]fϪ G lԛsuvkJb!oxr6/2&<]D)Cb7fI?(hw%3JKZuR`\{QS*"$^r #VAhe)l֕Mȿ;DM3Ak3sg\Ķ&Y(b!wZW5[p/GP)NlFqr[V53Zx8)%Sd;P ꦠ:Aٶ!&FYOujVM` `aypn{D+} -LVUZ5V1 $_t?0:z:}XQ~󤁌_n}@i+Qiڙbb!͊f7 LDMʚ Hr5:J+zʤ1Ojl0RvbN L)jK brƤM &zMZQ::iߔnVYwqҪRwp{u&GlchbW/K(P &ٴm}+%Gm]lgePq|;e]bi8:B0[pw8^PFXE 3oc hz_v]av"B)wVlM}~e@*ȗ']}FvY!Gfd/GK<:SD:Ŧ[Vƃ]S7-uf4"xmq-!4i&}EY}OvjLP#)|O, ut$!2{(+qh(݈ Ft?"R~MԌft旋5SN|5U|xG((K T`S ]f챭~}xG> هќWkW,^rm=5,6%SlK^&1Jx&U^1kvolte\Mϲl:p~t.iUL[v:pG47:m:?-!npv -C~qgxwxQRMŠtD)y<88H8ABՈj44fkmad3#|XOQ6Eݿ@vGA>;n_,`{*h/wmf4>4poB33ƻS=B+oFvN˗=1=+HH\"gc5a5hC@0 `w\hZg hаi^ezkt~2l1Sz J]zY'j1y>7oRbʤ"om|\ qGJ#15lNQRSN T)x0oIQ& s;{Gid_9 .T)ʫ~vcۻGwW~( lVRvV^LQZZM#$:4]d5 „W5Zqf] ;I!)s]{[dH(m DnV]{;-${|ۿVYC6`"s 2a< ^"`wSkI p .iH!¡3Na6CFN 6Ͳa]Ő!oEǃ/^WxwAU Knc-n>4LT4tYy0g.GIe`F_O/v'z{`\`Kq< st,BD޼┝\c~oS߸.>Xf"'&ޝ}B!mXZKn+B c0ږm/c WZWn'8ꘈ[ͦFYF3gO6b!OqB 6B Z,•xF-P֬bIDY<?NAbmy"2fr 4&^1"_DϿ \a{;X F׽dҭjūUZ1p\34'"8{9fqz5'd} r]7JpF4tG_%Ɂc']ЭKP] *}⨼P'7FϪ%:ltu\ h0,SӕֻÆ;gE&!HsE+Qyۦm]QBBqYgoӵ-+ :ؚlpD<:rzǑ&]ؑFhL I~] /*_l[E=4/{^F?֔J[M$42VW^zʀTIl;4t02N+uKLs":H)3Eځ$Ptcr\FW f"'f4Nܦ sImJa]V>]CcFQRKFI.:rءƊ]uxGOtqwtrاhJo8Dz\R{yM*~k^S7N";۲eӲF.v\1߬YⳐI∂5e9H'hK ǿ<%*jmJ9OS.'vY/Mn$a^]\|W9$Jc8=沎"7PEGQ$9䌐5_e]71_n eaR3P `HGDs_E[7؍&f40ݭu,cH(*lFhG!ciiwM.+"ut[]R{nܠ|oX`{F (lN;@Sҕ)fo@BަHAN\~o!$8e`}2Bi8_WU5J*DS_jh#'+5B96y\Y|;]^e[b K*gxrЁJ[TySB0}9ņ娙{.CϸO/o9/}3o?㦰86T$i#I%wv{ɢB$Q9-*q>ͦrєiOAӈiYN Y7O$0G Aew\ ڊUȬ#ʠ,ӳhAA~ Nq_D'xsJ˒+跹XTK@/u6ɧO}p컇N93c04GQͳj~HRV`T]aqhW j0|]t^̶FKrQn}:ī`xD %PمF.P#' M 1HkNGYQo#0+rtV,ͼ]@g*w.LIj+tLH׸M,gPE$v,,8ڪ~cPdU2O D VKIyZۙM_Y^0 ! RTh`RfRBYI1/Wflv0 )j tFV,Dvwp[䭿 Co^7xb\9 9Z-)bX`yM?Ր<'?̖sW#bw G~kh2yʹnx)J.6P̤~#6sFW?I1{ >QQG '-u>Y$VxR̚X6D5ƜtT4o.~t샰]2R+I:֗.GT %ߴJ'"/<갤@dB `n".t]B^ݸim*$g>ԺvUҥwiw(Q32\DEhYDOBp f-uX\o"Z)j7 =uz'e|~FDJwu|P&_:l |]:r6T+щ4/*̯ʛ\?{h$+byk/y8ʡUV tϵkf[ӻ݌EWyx?g-^_ MM9r8$d J Uoh7ba]*Tz`$ZEdk߻18(k "%EO~Qºiьv =ŢlYY6vސ}4gp:BT+Hߍ5hX@5i{vH͒):Czgmt1} ۞[MzF N˶\?H yJ@>gGur-UjvКX̊rv8.ObuU,?^7}OV3ӝtǠ*q30]mɪ-\VQTPykZroA_atX8YNT:p65`5*60K8`v-D^Mu[5ңUvyXE70:K63'Gf;UdgvvxyWg>xخ*Dm&t:Q fkowD2# SiCxYzXs4w_~ >doG<_ï3v[Ί `57}?<=|ȩp?$ZW#Y}e-AFK@vUpR={+A&ˠb'Tz 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) sks-1.1.5/bdb/ocextr.ml0000777000175000017500000000116312253367673015477 0ustar kristianfkristianfopen 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 -> () sks-1.1.5/bdb/script.ml0000644000175000017500000000123012273431766015460 0ustar kristianfkristianfopen 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") sks-1.1.5/bdb/temp.ml0000644000175000017500000001516112273431766015131 0ustar kristianfkristianf(***********************************************************************) (* temp.ml *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) (* 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 sks-1.1.5/bdb/test.ml0000644000175000017500000001366012273431766015145 0ustar kristianfkristianf(***********************************************************************) (* test.ml - Module for testing out the functionality of the *) (* Berkeley DB interface *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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 () sks-1.1.5/bdb/db.mli0000644000175000017500000000466412273431766014730 0ustar kristianfkristianf(***********************************************************************) (* *) (* 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 sks-1.1.5/bdb/Makefile0000644000175000017500000000503012273431766015264 0ustar kristianfkristianf######################################################################### # # # 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 $ include ../Makefile.local 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 rm -f bdb.ml rm -f ocextr install: cp libmldb.a $(LIBDIR)/libmldb.a cd $(LIBDIR); $(RANLIB) libmldb.a cp db.cma db.cmi bdb.mli 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) *.mli *.ml > .depend #include .depend # DO NOT DELETE sks-1.1.5/bdb/bdb_stubs.c0000644000175000017500000010664112273431766015751 0ustar kristianfkristianf/***********************************************************************) (* bdb_stubs.c - Stubs appropriate for Berkeley DB 4.x and DB 5.x *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************/ #include #include #include #include #include #include #include #include #include #include #include #include #include /* O_CREAT and others are not defined in db.h */ #include #include #include "bdb_stubs.h" #ifndef DB_XA_CREATE #define DB_XA_CREATE 0 #endif #define True 1 #define False 0 void zerob(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); } //+ (* GENERATED FILE -- DO NOT EDIT -- see bdb_stubs.c *) //+ //+ (* 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(const 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, const char *msg) { raise_db(msg); } //+ external version : unit -> string = "caml_db_version" value caml_db_version() { int major, minor, patch; char version[10]; db_version(&major, &minor, &patch); sprintf(version, "%d.%d.%d", major, minor, patch); return caml_copy_string(version); } // ############################################################# // 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 char db_message[255]; void db_msgcall_fcn(const DB_ENV *dbenv, const char *msg) { if(strlen(msg) < 254) strcpy(db_message, msg); } //+ external get_dbenv_stats : t -> string = "caml_dbenv_get_stats" value caml_dbenv_get_stats(value dbenv){ CAMLparam1(dbenv); char output_message[255]; char nl[] = {"\n"}; int err; UW_dbenv(dbenv)->set_msgcall(UW_dbenv(dbenv), *db_msgcall_fcn); err = UW_dbenv(dbenv)->stat_print(UW_dbenv(dbenv), DB_STAT_ALL); if(err == 0){ if(strlen(db_message) < 253){ strcpy(output_message, db_message); strcat(output_message, nl); } UW_dbenv(dbenv)->stat_print(UW_dbenv(dbenv), DB_STAT_ALL | DB_STAT_SUBSYSTEM); if(strlen(output_message) + strlen(db_message) < 253){ strcat(output_message, db_message); strcat(output_message, nl); } } else { strcpy(output_message, "Unable to open environment"); } return caml_copy_string(output_message); } //+ 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); zerob(&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); zerob(&key,sizeof(DBT)); zerob(&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); zerob(&key,sizeof(DBT)); zerob(&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 = 0; 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); zerob(&key,sizeof(DBT)); zerob(&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); zerob(&key,sizeof(DBT)); zerob(&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); zerob(&key,sizeof(DBT)); zerob(&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; zerob(&key,sizeof(DBT)); zerob(&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); zerob(&key,sizeof(DBT)); zerob(&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; zerob(&key,sizeof(DBT)); zerob(&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; zerob(&key,sizeof(DBT)); zerob(&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 //+ sks-1.1.5/bdb/dbstubs.c0000644000175000017500000001510312273431766015440 0ustar kristianfkristianf/***********************************************************************/ /* */ /* 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 #include #include #include #include #include #include #include /* O_CREAT and others are not defined in db.h */ #include #include #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; } sks-1.1.5/bdb/templ.c0000644000175000017500000000023512273431766015113 0ustar kristianfkristianf//+ external CAMLFUNC : TYPESIG //+ = "CFUNC" value CFUNC(VALUELIST) { CAMLparamX(VALUES); CAMLlocalX(LOCAL); CODE CAMLreturn (RVAL); } sks-1.1.5/bdb/bdb_stubs.h0000644000175000017500000000433512273431766015753 0ustar kristianfkristianf/*****************************************************************/ /** 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)]) sks-1.1.5/bdb/dbstubs.h0000644000175000017500000000350212273431766015445 0ustar kristianfkristianf/***********************************************************************/ /* */ /* 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)) sks-1.1.5/.depend0000644000175000017500000004262112331743771014341 0ustar kristianfkristianfadd_mail.cmi : armor.cmi : packet.cmi bdbwrap.cmi : bitstring.cmi : build.cmi : catchup.cmi : eventloop.cmo channel.cmi : clean_keydb.cmi : client.cmi : zZp.cmi reconMessages.cmi prefixTree.cmi bitstring.cmi cMarshal.cmi : zZp.cmi channel.cmi bitstring.cmi common.cmi : pMap.cmi dbMessages.cmi : packet.cmi common.cmi channel.cmi dbserver.cmi : decode.cmi : zZp.cmi poly.cmi ehandlers.cmi : eventloop.cmo fixkey.cmi : packet.cmi pMap.cmi keyMerge.cmo fqueue.cmi : heap.cmi : htmlTemplates.cmi : packet.cmi index.cmi : request.cmi packet.cmi fingerprint.cmo keyHash.cmi : packet.cmi key.cmi : sStream.cmi packet.cmi linearAlg.cmi : zZp.cmi mArray.cmi : membership.cmi : mList.cmi : mTimer.cmi : nbMsgContainer.cmi : channel.cmi number.cmi : packet.cmi : parsePGP.cmi : packet.cmi pMap.cmi : poly.cmi : zZp.cmi pMap.cmi prefixTree.cmi : zZp.cmi bitstring.cmi prime.cmi : number.cmi pSet.cmi : pstyle.cmi : recode.cmi : packet.cmi channel.cmi reconComm.cmi : dbMessages.cmi reconCS.cmi : zZp.cmi prefixTree.cmi channel.cmi reconMessages.cmi : zZp.cmi pMap.cmi bitstring.cmi reconPTreeDb.cmi : zZp.cmi prefixTree.cmi bitstring.cmi reconserver.cmi : pTreeDB.cmo eventloop.cmo channel.cmi recoverList.cmi : zZp.cmi recvmail.cmi : sendmail.cmo request.cmi : rMisc.cmi : zZp.cmi pSet.cmi meteredChannel.cmo server.cmi : zZp.cmi prefixTree.cmi settings.cmi : sks.cmi : sStream.cmi : stats.cmi : common.cmi Unique_time.cmi : update_subkeys.cmi : sStream.cmi packet.cmi pMap.cmi keydb.cmo common.cmi utils.cmi : pSet.cmi version.cmi : wserver.cmi : pSet.cmi pMap.cmi channel.cmi zZp.cmi : number.cmi add_mail.cmo : pSet.cmi pMap.cmi add_mail.cmi add_mail.cmx : pSet.cmx pMap.cmx add_mail.cmi armor.cmo : settings.cmi key.cmi common.cmi armor.cmi armor.cmx : settings.cmx key.cmx common.cmx armor.cmi bdbwrap.cmo : common.cmi bdbwrap.cmi bdbwrap.cmx : common.cmx bdbwrap.cmi bitstring.cmo : utils.cmi bitstring.cmi bitstring.cmx : utils.cmx bitstring.cmi bugscript.cmo : zZp.cmi reconPTreeDb.cmi pSet.cmi keyHash.cmi common.cmi bugscript.cmx : zZp.cmx reconPTreeDb.cmx pSet.cmx keyHash.cmx common.cmx build.cmo : utils.cmi settings.cmi packet.cmi pSet.cmi mTimer.cmi keydb.cmo \ key.cmi fixkey.cmi common.cmi channel.cmi build.cmi build.cmx : utils.cmx settings.cmx packet.cmx pSet.cmx mTimer.cmx keydb.cmx \ key.cmx fixkey.cmx common.cmx channel.cmx build.cmi catchup.cmo : reconComm.cmi pTreeDB.cmo eventloop.cmo dbMessages.cmi \ common.cmi catchup.cmi catchup.cmx : reconComm.cmx pTreeDB.cmx eventloop.cmx dbMessages.cmx \ common.cmx catchup.cmi channel.cmo : common.cmi channel.cmi channel.cmx : common.cmx channel.cmi clean_keydb.cmo : settings.cmi packet.cmi pSet.cmi pMap.cmi mList.cmi \ keydb.cmo keyHash.cmi key.cmi fixkey.cmi fingerprint.cmo common.cmi \ channel.cmi clean_keydb.cmi clean_keydb.cmx : settings.cmx packet.cmx pSet.cmx pMap.cmx mList.cmx \ keydb.cmx keyHash.cmx key.cmx fixkey.cmx fingerprint.cmx common.cmx \ channel.cmx clean_keydb.cmi client.cmo : zZp.cmi settings.cmi reconMessages.cmi prefixTree.cmi pSet.cmi \ pMap.cmi mTimer.cmi eventloop.cmo common.cmi bitstring.cmi client.cmi client.cmx : zZp.cmx settings.cmx reconMessages.cmx prefixTree.cmx pSet.cmx \ pMap.cmx mTimer.cmx eventloop.cmx common.cmx bitstring.cmx client.cmi cMarshal.cmo : zZp.cmi channel.cmi bitstring.cmi cMarshal.cmi cMarshal.cmx : zZp.cmx channel.cmx bitstring.cmx cMarshal.cmi common.cmo : utils.cmi settings.cmi pMap.cmi common.cmi common.cmx : utils.cmx settings.cmx pMap.cmx common.cmi dbMessages.cmo : utils.cmi packet.cmi pSet.cmi msgContainer.cmo key.cmi \ common.cmi cMarshal.cmi dbMessages.cmi dbMessages.cmx : utils.cmx packet.cmx pSet.cmx msgContainer.cmx key.cmx \ common.cmx cMarshal.cmx dbMessages.cmi dbscript.cmo : settings.cmi packet.cmi keydb.cmo common.cmi dbscript.cmx : settings.cmx packet.cmx keydb.cmx common.cmx dbserver.cmo : wserver.cmi utils.cmi stats.cmi settings.cmi sendmail.cmo \ request.cmi rMisc.cmi pstyle.cmi parsePGP.cmi packet.cmi membership.cmi \ mailsync.cmo mRindex.cmo mList.cmi keydb.cmo keyMerge.cmo keyHash.cmi \ key.cmi index.cmi htmlTemplates.cmi fixkey.cmi fingerprint.cmo \ eventloop.cmo ehandlers.cmi dbMessages.cmi common.cmi channel.cmi \ cMarshal.cmi armor.cmi dbserver.cmi dbserver.cmx : wserver.cmx utils.cmx stats.cmx settings.cmx sendmail.cmx \ request.cmx rMisc.cmx pstyle.cmx parsePGP.cmx packet.cmx membership.cmx \ mailsync.cmx mRindex.cmx mList.cmx keydb.cmx keyMerge.cmx keyHash.cmx \ key.cmx index.cmx htmlTemplates.cmx fixkey.cmx fingerprint.cmx \ eventloop.cmx ehandlers.cmx dbMessages.cmx common.cmx channel.cmx \ cMarshal.cmx armor.cmx dbserver.cmi dbtest.cmo : settings.cmi packet.cmi keydb.cmo keyMerge.cmo common.cmi dbtest.cmx : settings.cmx packet.cmx keydb.cmx keyMerge.cmx common.cmx decode.cmo : zZp.cmi prime.cmi poly.cmi number.cmi linearAlg.cmi decode.cmi decode.cmx : zZp.cmx prime.cmx poly.cmx number.cmx linearAlg.cmx decode.cmi decode_test.cmo : zZp.cmi rMisc.cmi poly.cmi decode.cmi common.cmi decode_test.cmx : zZp.cmx rMisc.cmx poly.cmx decode.cmx common.cmx ehandlers.cmo : eventloop.cmo common.cmi ehandlers.cmi ehandlers.cmx : eventloop.cmx common.cmx ehandlers.cmi eventloop.cmo : packet.cmi heap.cmi common.cmi eventloop.cmx : packet.cmx heap.cmx common.cmx fastbuild.cmo : utils.cmi settings.cmi packet.cmi pSet.cmi mTimer.cmi \ keydb.cmo key.cmi fixkey.cmi common.cmi channel.cmi fastbuild.cmx : utils.cmx settings.cmx packet.cmx pSet.cmx mTimer.cmx \ keydb.cmx key.cmx fixkey.cmx common.cmx channel.cmx fingerprint.cmo : utils.cmi parsePGP.cmi packet.cmi pSet.cmi common.cmi \ channel.cmi fingerprint.cmx : utils.cmx parsePGP.cmx packet.cmx pSet.cmx common.cmx \ channel.cmx fixkey.cmo : utils.cmi parsePGP.cmi packet.cmi pMap.cmi keyMerge.cmo \ common.cmi fixkey.cmi fixkey.cmx : utils.cmx parsePGP.cmx packet.cmx pMap.cmx keyMerge.cmx \ common.cmx fixkey.cmi foo.cmo : zZp.cmi number.cmi foo.cmx : zZp.cmx number.cmx fqueue.cmo : fqueue.cmi fqueue.cmx : fqueue.cmi getfileopts.cmo : settings.cmi pstyle.cmi getfileopts.cmx : settings.cmx pstyle.cmx heap.cmo : heap.cmi heap.cmx : heap.cmi htmlTemplates.cmo : packet.cmi channel.cmi htmlTemplates.cmi htmlTemplates.cmx : packet.cmx channel.cmx htmlTemplates.cmi incdump.cmo : utils.cmi settings.cmi packet.cmi pSet.cmi keydb.cmo \ common.cmi incdump.cmx : utils.cmx settings.cmx packet.cmx pSet.cmx keydb.cmx \ common.cmx index.cmo : utils.cmi stats.cmi settings.cmi request.cmi pstyle.cmi \ parsePGP.cmi packet.cmi pMap.cmi keyMerge.cmo keyHash.cmi \ htmlTemplates.cmi fingerprint.cmo eventloop.cmo common.cmi channel.cmi \ index.cmi index.cmx : utils.cmx stats.cmx settings.cmx request.cmx pstyle.cmx \ parsePGP.cmx packet.cmx pMap.cmx keyMerge.cmx keyHash.cmx \ htmlTemplates.cmx fingerprint.cmx eventloop.cmx common.cmx channel.cmx \ index.cmi int_comparators.cmo : int_comparators.cmx : keydb.cmo : Unique_time.cmi settings.cmi sStream.cmi packet.cmi pSet.cmi \ mList.cmi keyMerge.cmo keyHash.cmi key.cmi fingerprint.cmo eventloop.cmo \ common.cmi channel.cmi keydb.cmx : Unique_time.cmx settings.cmx sStream.cmx packet.cmx pSet.cmx \ mList.cmx keyMerge.cmx keyHash.cmx key.cmx fingerprint.cmx eventloop.cmx \ common.cmx channel.cmx keyHash.cmo : utils.cmi packet.cmi channel.cmi keyHash.cmi keyHash.cmx : utils.cmx packet.cmx channel.cmx keyHash.cmi keyMerge.cmo : utils.cmi packet.cmi pSet.cmi pMap.cmi common.cmi keyMerge.cmx : utils.cmx packet.cmx pSet.cmx pMap.cmx common.cmx key.cmo : utils.cmi sStream.cmi parsePGP.cmi packet.cmi pSet.cmi channel.cmi \ key.cmi key.cmx : utils.cmx sStream.cmx parsePGP.cmx packet.cmx pSet.cmx channel.cmx \ key.cmi linearAlg.cmo : zZp.cmi linearAlg.cmi linearAlg.cmx : zZp.cmx linearAlg.cmi logdump.cmo : settings.cmi packet.cmi keydb.cmo keyHash.cmi dbMessages.cmi \ common.cmi logdump.cmx : settings.cmx packet.cmx keydb.cmx keyHash.cmx dbMessages.cmx \ common.cmx mailsync.cmo : settings.cmi keyHash.cmi fixkey.cmi eventloop.cmo common.cmi \ armor.cmi mailsync.cmx : settings.cmx keyHash.cmx fixkey.cmx eventloop.cmx common.cmx \ armor.cmx mArray.cmo : mArray.cmi mArray.cmx : mArray.cmi membership.cmo : wserver.cmi utils.cmi settings.cmi common.cmi \ membership.cmi membership.cmx : wserver.cmx utils.cmx settings.cmx common.cmx \ membership.cmi merge_keyfiles.cmo : settings.cmi packet.cmi pSet.cmi mTimer.cmi keydb.cmo \ key.cmi common.cmi channel.cmi merge_keyfiles.cmx : settings.cmx packet.cmx pSet.cmx mTimer.cmx keydb.cmx \ key.cmx common.cmx channel.cmx meteredChannel.cmo : channel.cmi meteredChannel.cmx : channel.cmx mList.cmo : mList.cmi mList.cmx : mList.cmi mRindex.cmo : utils.cmi parsePGP.cmi packet.cmi keyMerge.cmo index.cmi \ fingerprint.cmo common.cmi mRindex.cmx : utils.cmx parsePGP.cmx packet.cmx keyMerge.cmx index.cmx \ fingerprint.cmx common.cmx msgContainer.cmo : channel.cmi msgContainer.cmx : channel.cmx mTimer.cmo : mTimer.cmi mTimer.cmx : mTimer.cmi nbMsgContainer.cmo : common.cmi channel.cmi nbMsgContainer.cmi nbMsgContainer.cmx : common.cmx channel.cmx nbMsgContainer.cmi number.cmo : common.cmi number.cmi number.cmx : common.cmx number.cmi number_test.cmo : rMisc.cmi prime.cmi number.cmi common.cmi number_test.cmx : rMisc.cmx prime.cmx number.cmx common.cmx packet.cmo : packet.cmi packet.cmx : packet.cmi parsePGP.cmo : utils.cmi packet.cmi common.cmi channel.cmi parsePGP.cmi parsePGP.cmx : utils.cmx packet.cmx common.cmx channel.cmx parsePGP.cmi pbuild.cmo : settings.cmi sStream.cmi prefixTree.cmi pTreeDB.cmo keydb.cmo \ common.cmi pbuild.cmx : settings.cmx sStream.cmx prefixTree.cmx pTreeDB.cmx keydb.cmx \ common.cmx pdiskTest.cmo : zZp.cmi settings.cmi rMisc.cmi prefixTree.cmi packet.cmi \ pSet.cmi mTimer.cmi common.cmi bitstring.cmi pdiskTest.cmx : zZp.cmx settings.cmx rMisc.cmx prefixTree.cmx packet.cmx \ pSet.cmx mTimer.cmx common.cmx bitstring.cmx pMap.cmo : pMap.cmi pMap.cmx : pMap.cmi poly.cmo : zZp.cmi pMap.cmi mList.cmi poly.cmi poly.cmx : zZp.cmx pMap.cmx mList.cmx poly.cmi poly_test.cmo : zZp.cmi rMisc.cmi poly.cmi common.cmi poly_test.cmx : zZp.cmx rMisc.cmx poly.cmx common.cmx prefix_test.cmo : zZp.cmi settings.cmi rMisc.cmi prefixTree.cmi pSet.cmi \ mTimer.cmi mList.cmi bitstring.cmi prefix_test.cmx : zZp.cmx settings.cmx rMisc.cmx prefixTree.cmx pSet.cmx \ mTimer.cmx mList.cmx bitstring.cmx prefixTree.cmo : zZp.cmi pSet.cmi mArray.cmi common.cmi channel.cmi \ bitstring.cmi prefixTree.cmi prefixTree.cmx : zZp.cmx pSet.cmx mArray.cmx common.cmx channel.cmx \ bitstring.cmx prefixTree.cmi prime.cmo : utils.cmi number.cmi prime.cmi prime.cmx : utils.cmx number.cmx prime.cmi pSet.cmo : pSet.cmi pSet.cmx : pSet.cmi pstyle.cmo : pstyle.cmi pstyle.cmx : pstyle.cmi ptest.cmo : settings.cmi sStream.cmi prefixTree.cmi packet.cmi pTreeDB.cmo \ pSet.cmi mList.cmi keydb.cmo keyHash.cmi common.cmi ptest.cmx : settings.cmx sStream.cmx prefixTree.cmx packet.cmx pTreeDB.cmx \ pSet.cmx mList.cmx keydb.cmx keyHash.cmx common.cmx ptree_consistency_test.cmo : zZp.cmi reconPTreeDb.cmi pSet.cmi common.cmi \ bitstring.cmi ptree_consistency_test.cmx : zZp.cmx reconPTreeDb.cmx pSet.cmx common.cmx \ bitstring.cmx pTreeDB.cmo : utils.cmi settings.cmi prefixTree.cmi common.cmi pTreeDB.cmx : utils.cmx settings.cmx prefixTree.cmx common.cmx ptree_db_test.cmo : reconPTreeDb.cmi pSet.cmi common.cmi ptree_db_test.cmx : reconPTreeDb.cmx pSet.cmx common.cmx ptree_replay.cmo : reconPTreeDb.cmi pstyle.cmi pSet.cmi keyHash.cmi \ common.cmi ptree_replay.cmx : reconPTreeDb.cmx pstyle.cmx pSet.cmx keyHash.cmx \ common.cmx ptscript.cmo : settings.cmi pdiskTest.cmo ptscript.cmx : settings.cmx pdiskTest.cmx query.cmo : settings.cmi packet.cmi mList.cmi keydb.cmo key.cmi \ fingerprint.cmo query.cmx : settings.cmx packet.cmx mList.cmx keydb.cmx key.cmx \ fingerprint.cmx recode.cmo : packet.cmi key.cmi channel.cmi recode.cmi recode.cmx : packet.cmx key.cmx channel.cmx recode.cmi reconComm.cmo : wserver.cmi packet.cmi pMap.cmi dbMessages.cmi common.cmi \ channel.cmi cMarshal.cmi reconComm.cmi reconComm.cmx : wserver.cmx packet.cmx pMap.cmx dbMessages.cmx common.cmx \ channel.cmx cMarshal.cmx reconComm.cmi reconCS.cmo : settings.cmi server.cmi reconMessages.cmi pSet.cmi pMap.cmi \ mList.cmi eventloop.cmo common.cmi client.cmi channel.cmi cMarshal.cmi \ reconCS.cmi reconCS.cmx : settings.cmx server.cmx reconMessages.cmx pSet.cmx pMap.cmx \ mList.cmx eventloop.cmx common.cmx client.cmx channel.cmx cMarshal.cmx \ reconCS.cmi reconMessages.cmo : zZp.cmi pMap.cmi nbMsgContainer.cmi mTimer.cmi \ common.cmi cMarshal.cmi bitstring.cmi reconMessages.cmi reconMessages.cmx : zZp.cmx pMap.cmx nbMsgContainer.cmx mTimer.cmx \ common.cmx cMarshal.cmx bitstring.cmx reconMessages.cmi reconPTreeDb.cmo : prefixTree.cmi common.cmi reconPTreeDb.cmi reconPTreeDb.cmx : prefixTree.cmx common.cmx reconPTreeDb.cmi reconserver.cmo : zZp.cmi utils.cmi settings.cmi recoverList.cmi \ reconComm.cmi reconCS.cmi rMisc.cmi prefixTree.cmi packet.cmi pTreeDB.cmo \ pMap.cmi membership.cmi keyHash.cmi eventloop.cmo ehandlers.cmi \ dbMessages.cmi common.cmi channel.cmi catchup.cmi reconserver.cmi reconserver.cmx : zZp.cmx utils.cmx settings.cmx recoverList.cmx \ reconComm.cmx reconCS.cmx rMisc.cmx prefixTree.cmx packet.cmx pTreeDB.cmx \ pMap.cmx membership.cmx keyHash.cmx eventloop.cmx ehandlers.cmx \ dbMessages.cmx common.cmx channel.cmx catchup.cmx reconserver.cmi recoverList.cmo : zZp.cmi settings.cmi rMisc.cmi keyHash.cmi common.cmi \ recoverList.cmi recoverList.cmx : zZp.cmx settings.cmx rMisc.cmx keyHash.cmx common.cmx \ recoverList.cmi recvmail.cmo : wserver.cmi sendmail.cmo common.cmi recvmail.cmi recvmail.cmx : wserver.cmx sendmail.cmx common.cmx recvmail.cmi request.cmo : utils.cmi common.cmi request.cmi request.cmx : utils.cmx common.cmx request.cmi rMisc.cmo : zZp.cmi utils.cmi settings.cmi pSet.cmi pMap.cmi \ meteredChannel.cmo mList.cmi channel.cmi rMisc.cmi rMisc.cmx : zZp.cmx utils.cmx settings.cmx pSet.cmx pMap.cmx \ meteredChannel.cmx mList.cmx channel.cmx rMisc.cmi script.cmo : tester.cmo pSet.cmi pMap.cmi keyHash.cmi key.cmi \ fingerprint.cmo dbMessages.cmi common.cmi channel.cmi cMarshal.cmi script.cmx : tester.cmx pSet.cmx pMap.cmx keyHash.cmx key.cmx \ fingerprint.cmx dbMessages.cmx common.cmx channel.cmx cMarshal.cmx sendmail.cmo : settings.cmi pSet.cmi pMap.cmi common.cmi sendmail.cmx : settings.cmx pSet.cmx pMap.cmx common.cmx server.cmo : zZp.cmi settings.cmi reconMessages.cmi prefixTree.cmi \ eventloop.cmo decode.cmi common.cmi server.cmi server.cmx : zZp.cmx settings.cmx reconMessages.cmx prefixTree.cmx \ eventloop.cmx decode.cmx common.cmx server.cmi settings.cmo : settings.cmi settings.cmx : settings.cmi sksclient.cmo : settings.cmi keydb.cmo keyHash.cmi key.cmi fingerprint.cmo \ dbMessages.cmi common.cmi armor.cmi sksclient.cmx : settings.cmx keydb.cmx keyHash.cmx key.cmx fingerprint.cmx \ dbMessages.cmx common.cmx armor.cmx sks_do.cmo : settings.cmi prefixTree.cmi packet.cmi pMap.cmi keyHash.cmi \ dbMessages.cmi common.cmi channel.cmi sks_do.cmx : settings.cmx prefixTree.cmx packet.cmx pMap.cmx keyHash.cmx \ dbMessages.cmx common.cmx channel.cmx sksdump.cmo : settings.cmi sStream.cmi packet.cmi keydb.cmo keyHash.cmi \ common.cmi sksdump.cmx : settings.cmx sStream.cmx packet.cmx keydb.cmx keyHash.cmx \ common.cmx sks.cmo : version.cmi update_subkeys.cmi unit_tests.cmo sksdump.cmo \ sks_do.cmo settings.cmi reconserver.cmi pbuild.cmo merge_keyfiles.cmo \ incdump.cmo fastbuild.cmo dbserver.cmi common.cmi clean_keydb.cmi \ build.cmi sks.cmi sks.cmx : version.cmx update_subkeys.cmx unit_tests.cmx sksdump.cmx \ sks_do.cmx settings.cmx reconserver.cmx pbuild.cmx merge_keyfiles.cmx \ incdump.cmx fastbuild.cmx dbserver.cmx common.cmx clean_keydb.cmx \ build.cmx sks.cmi sksstats.cmo : settings.cmi parsePGP.cmi packet.cmi keydb.cmo keyHash.cmi \ fingerprint.cmo dbMessages.cmi common.cmi sksstats.cmx : settings.cmx parsePGP.cmx packet.cmx keydb.cmx keyHash.cmx \ fingerprint.cmx dbMessages.cmx common.cmx spider.cmo : pstyle.cmi pSet.cmi common.cmi spider.cmx : pstyle.cmx pSet.cmx common.cmx sStream.cmo : sStream.cmi sStream.cmx : sStream.cmi stats.cmo : settings.cmi packet.cmi membership.cmi htmlTemplates.cmi \ common.cmi stats.cmi stats.cmx : settings.cmx packet.cmx membership.cmx htmlTemplates.cmx \ common.cmx stats.cmi tester.cmo : utils.cmi settings.cmi packet.cmi keydb.cmo key.cmi \ dbMessages.cmi common.cmi channel.cmi tester.cmx : utils.cmx settings.cmx packet.cmx keydb.cmx key.cmx \ dbMessages.cmx common.cmx channel.cmx Unique_time.cmo : Unique_time.cmi Unique_time.cmx : Unique_time.cmi unit_tests.cmo : poly_test.cmo number_test.cmo decode_test.cmo common.cmi unit_tests.cmx : poly_test.cmx number_test.cmx decode_test.cmx common.cmx update_subkeys.cmo : settings.cmi packet.cmi pSet.cmi pMap.cmi keydb.cmo \ fingerprint.cmo common.cmi update_subkeys.cmi update_subkeys.cmx : settings.cmx packet.cmx pSet.cmx pMap.cmx keydb.cmx \ fingerprint.cmx common.cmx update_subkeys.cmi utils.cmo : pSet.cmi pMap.cmi utils.cmi utils.cmx : pSet.cmx pMap.cmx utils.cmi version.cmo : common.cmi version.cmi version.cmx : common.cmx version.cmi wserver.cmo : settings.cmi pSet.cmi pMap.cmi htmlTemplates.cmi eventloop.cmo \ common.cmi channel.cmi wserver.cmi wserver.cmx : settings.cmx pSet.cmx pMap.cmx htmlTemplates.cmx eventloop.cmx \ common.cmx channel.cmx wserver.cmi zZp.cmo : prime.cmi number.cmi zZp.cmi zZp.cmx : prime.cmx number.cmx zZp.cmi sks-1.1.5/add_mail.ml0000644000175000017500000000552512273431766015172 0ustar kristianfkristianf(***********************************************************************) (* add_mail.ml - Executable: interprets stdin as mail message and *) (* posts content to specified HTTP address *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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 () sks-1.1.5/armor.ml0000644000175000017500000001150012273431766014546 0ustar kristianfkristianf(***********************************************************************) (* armor.ml- Conversion to and from ASCII armor *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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%s" Common.version Common.version_suffix) and hostname = (sprintf "Comment: Hostname: %s" (if String.length !Settings.hostname > 53 then String.sub !Settings.hostname 0 53 else !Settings.hostname)) in let input = Key.to_string key in armor_header ^ "\n" ^ version ^ "\n" ^ hostname ^ "\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%s" Common.version Common.version_suffix) and hostname = (sprintf "Comment: Hostname: %s" (if String.length !Settings.hostname > 53 then String.sub !Settings.hostname 0 53 else !Settings.hostname)) in let input = keystr in armor_header ^ "\n" ^ version ^ "\n" ^ hostname ^ "\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 sks-1.1.5/bdbwrap.ml0000644000175000017500000001221512273431766015053 0ustar kristianfkristianf(***********************************************************************) (* bdbwrap.ml - Wrapper module for Bdb to allow for logging of *) (* database operations *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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 sks-1.1.5/bitstring.ml0000644000175000017500000002204112273431766015435 0ustar kristianfkristianf(***********************************************************************) (* bitstring.ml *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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); *) sks-1.1.5/bugscript.ml0000644000175000017500000002004412273431766015433 0ustar kristianfkristianf(***********************************************************************) (* bugscript.ml *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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 () sks-1.1.5/build.ml0000644000175000017500000001205212273431766014530 0ustar kristianfkristianf(***********************************************************************) (* build.ml - Executable: Builds up the key database from a multi-file *) (* database dump. *) (* Dump files are taken from the command-line. *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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.keyid_pagesize = !Settings.keyid_pagesize; Keydb.meta_pagesize = !Settings.meta_pagesize; Keydb.subkeyid_pagesize = !Settings.subkeyid_pagesize; Keydb.time_pagesize = !Settings.time_pagesize; Keydb.tqueue_pagesize = !Settings.tqueue_pagesize; Keydb.word_pagesize = !Settings.word_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 () = Sys.set_signal Sys.sigusr1 Sys.Signal_ignore let () = Sys.set_signal Sys.sigusr2 Sys.Signal_ignore (***************************************************************) let run () = set_logfile "build"; perror "Running SKS %s%s" Common.version Common.version_suffix; 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; Utils.initdbconf !Settings.basedir (Lazy.force Settings.dbdir); 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 sks-1.1.5/catchup.ml0000644000175000017500000001101712273431766015060 0ustar kristianfkristianf(***********************************************************************) (* catchup.ml - code used by the reconserver to catch up on whatever *) (* updates have been made to the key database *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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. sks-1.1.5/channel.ml0000644000175000017500000003114112273431766015041 0ustar kristianfkristianf(***********************************************************************) (* channel.ml *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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 *) sks-1.1.5/clean_keydb.ml0000644000175000017500000003142712273431766015700 0ustar kristianfkristianf(***********************************************************************) (* clean_keydb.ml - Executable: Cleans up various problems that occur *) (* in key databases *) (* *) (* Currently, this includes: *) (* - Merging all mergeable keys *) (* - Eliminating keys with unparseable packet sequences *) (* - 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.) *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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.keyid_pagesize = !Settings.keyid_pagesize; Keydb.meta_pagesize = !Settings.meta_pagesize; Keydb.subkeyid_pagesize = !Settings.subkeyid_pagesize; Keydb.time_pagesize = !Settings.time_pagesize; Keydb.tqueue_pagesize = !Settings.tqueue_pagesize; Keydb.word_pagesize = !Settings.word_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"; perror "Running SKS %s%s" Common.version Common.version_suffix; 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 sks-1.1.5/client.ml0000644000175000017500000001676012273431766014721 0ustar kristianfkristianf(***********************************************************************) (* client.ml - Client side of set-reconciliation algorithm *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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 := (ZZp.Set.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 = ZZp.Set.diff local elements in let remotediff = ZZp.Set.diff elements local in marshal_noflush cout (Elements localdiff); setref := ZZp.Set.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 ZZp.Set.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) sks-1.1.5/cMarshal.ml0000644000175000017500000001064412273431766015170 0ustar kristianfkristianf(***********************************************************************) (* cMarshal.ml - Marshaling into and out of channels *) (* (see [Channel] module) *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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 sks-1.1.5/common.ml0000644000175000017500000002063512331743744014724 0ustar kristianfkristianf(***********************************************************************) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) (** 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__) (* for Release versions, COMMONCAMLFLAGS in Makefile should include *) (* '-warn-error a'. Development work should use '-warn-error A' for stricter *) (* language checking. This affects the Ocaml compiler beginning with v4.01.0 *) let version_suffix = "" (* + for development branch *) 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 compatible_version_string = let (maj_version,min_version,release) = compatible_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 ()) sks-1.1.5/dbMessages.ml0000644000175000017500000002060212273431766015506 0ustar kristianfkristianf(***********************************************************************) (* dbMessages.ml- Message types for communicating with com ports on *) (* dbserver and reconserver *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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 "" s | Unix.ADDR_INET (addr,p) -> sprintf "" (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 sks-1.1.5/dbscript.ml0000644000175000017500000000435512273431766015252 0ustar kristianfkristianf(***********************************************************************) (* dbscript.ml *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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 *) sks-1.1.5/dbserver.ml0000644000175000017500000007172712273431766015263 0ustar kristianfkristianf(***********************************************************************) (* dbserver.ml - Executable: server process that handles database and *) (* database queries. *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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 open Sys let () = set_logfile "db"; plerror 0 "sks_db, SKS version %s%s" version version_suffix; plerror 0 "Using BerkelyDB version %s" (Bdb.version();); plerror 0 "Copyright Yaron Minsky 2002, 2003, 2004"; plerror 0 "Licensed under GPL. See LICENSE 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.keyid_pagesize = !Settings.keyid_pagesize; Keydb.meta_pagesize = !Settings.meta_pagesize; Keydb.subkeyid_pagesize = !Settings.subkeyid_pagesize; Keydb.time_pagesize = !Settings.time_pagesize; Keydb.tqueue_pagesize = !Settings.tqueue_pagesize; Keydb.word_pagesize = !Settings.word_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.rev_map ~f:Eventloop.maybe_create_sock ((if !Settings.use_port_80 then make_addr_list http_address 80 else []) @ make_addr_list http_address http_port) let websocks = List.fold_right ~init:[] ~f:(function | Some sock -> fun acc -> sock :: acc | None -> fun acc -> acc) websocks let () = if websocks = [] then failwith "Could not listen on any address." 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 = 90000 in let last_month = today -. (31. *. 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.No_results "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 aakeys = if keys = [] then "" else Armor.encode_pubkey_string (Key.to_string_multiple keys) in if request.machine_readable then ("application/pgp-keys; charset=UTF-8", count, aakeys) else ("text/html; charset=UTF-8", count, HtmlTemplates.page ~title:(sprintf "Public Key Server -- Get \"%s \"" (String.concat ~sep:" " request.search)) ~body:(sprintf "\r\n
\r\n%s\r\n
\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 aakey = Armor.encode_pubkey_string keystr in if request.machine_readable then ("application/pgp-keys; charset=UTF-8", 1, aakey) else ("text/html; charset=UTF-8", 1, HtmlTemplates.page ~title:(sprintf "Public Key Server -- Get ``%s ''" hash_str) ~body:(sprintf "\r\n
\r\n%s\r\n
\r\n" aakey) ) | 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 keys = clean_keys request keys in let hashes = List.map ~f:KeyHash.hash 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"; ".txt", "text/plain"; ".css", "text/css"; ".xhtml", "application/xhtml+xml"; ".xhtm", "application/xhtml+xml"; ".xml", "application/xhtml+xml"; ".es", "application/ecmascript"; ".js", "application/javascript"; ] (* Search list for web page index files *) let index_files = [ "index.html"; "index.htm"; "index.xhtml"; "index.xhtm"; "index.xml"; ] (** Returns the first element of [index_files] that exists, returning "index.html" if none of them exists. *) let index_page_filename = let found_files = List.filter index_files ~f:(fun x -> Sys.file_exists (convert_web_fname x)) in match found_files with | [] -> "index.html" | hd :: _ -> hd let index_page_mime = let period = Str.regexp_string "." in let err () = raise (Wserver.Misc_error "No mime type found for index page") in match Str.split period index_page_filename with | _ :: ext :: _ -> (try List.assoc ("." ^ ext) supported_extensions with Not_found -> err ()) | _ -> err () 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 = "" || base = "/index.xhtml" ) then let fname = convert_web_fname index_page_filename in let text = read_file fname in cout#write_string text; (index_page_mime ^ "; 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 ""; 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
"); plerror 2 "key %s %s" (KeyHash.hexify (KeyHash.hash origkey)) "could not be parsed by KeyMerge.canonicalize" | Fixkey.Standalone_revocation_certificate -> cout#write_string ("Add failed: This is a stand-alone " ^ "revocation certificate. A revocation " ^ "certificates should be imported to the " ^ "respective public key before being " ^ "published to a keyserver"); | Bdb.Key_exists as e -> cout#write_string ("Add failed: identical key already " ^ "exists in database
"); eperror e "Key add failed" | e -> Eventloop.reraise e; cout#write_string "Add failed
"; eperror e "Key add failed" ); if !ctr > 0 then ( cout#write_string ("Key block added to key server database.\n " ^ "New public keys added:
"); cout#write_string (sprintf "%d key(s) added successfully.
" !ctr) ); cout#write_string ""; ("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 sks-1.1.5/dbtest.ml0000644000175000017500000000532212273431766014720 0ustar kristianfkristianf(***********************************************************************) (* dbtest.ml *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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; ) sks-1.1.5/decode.ml0000644000175000017500000001345412273431766014663 0ustar kristianfkristianf(***********************************************************************) (* decode.ml - Handles decoding aspect of set-reconciliation *) (* algorithm. *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) open ZZp.Infix 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 sks-1.1.5/decode_test.ml0000644000175000017500000001613312273431766015717 0ustar kristianfkristianf(***********************************************************************) (* decode_test.ml - Unit tests for number.ml *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) open StdLabels open MoreLabels open Printf open Decode open Common 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 sks-1.1.5/ehandlers.ml0000644000175000017500000001020212273431766015371 0ustar kristianfkristianf(***********************************************************************) (* ehandlers.ml - functions for constructing event handlers for use *) (* with [Eventloop] module *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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)) ] sks-1.1.5/eventloop.ml0000644000175000017500000002162012273431766015445 0ustar kristianfkristianf(***********************************************************************) (* eventloop.ml - Basic eventloop for picking up timer and socket *) (* events *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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; if domain = PF_INET6 then setsockopt sock IPV6_ONLY 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 let maybe_create_sock addr = try Some (create_sock addr) with | err -> let saddr = match addr with | ADDR_UNIX path -> "\"" ^ path ^ "\"" | ADDR_INET(ip, port) -> (string_of_inet_addr ip) ^ ":" ^ (string_of_int port) in perror "Failed to listen on %s: %s" saddr (err_to_string err); None (***************************************************************) (* 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 -> () sks-1.1.5/fastbuild.ml0000644000175000017500000001675712273431766015426 0ustar kristianfkristianf(***********************************************************************) (* fastbuild.ml - 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. *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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.keyid_pagesize = !Settings.keyid_pagesize; Keydb.meta_pagesize = !Settings.meta_pagesize; Keydb.subkeyid_pagesize = !Settings.subkeyid_pagesize; Keydb.time_pagesize = !Settings.time_pagesize; Keydb.tqueue_pagesize = !Settings.tqueue_pagesize; Keydb.word_pagesize = !Settings.word_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 () = Sys.set_signal Sys.sigusr1 Sys.Signal_ignore let () = Sys.set_signal Sys.sigusr2 Sys.Signal_ignore (***************************************************************) let run () = set_logfile "fastbuild"; perror "Running SKS %s%s" Common.version Common.version_suffix; 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; Utils.initdbconf !Settings.basedir (Lazy.force Settings.dbdir); 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 sks-1.1.5/fingerprint.ml0000644000175000017500000001666312273431766015774 0ustar kristianfkristianf(***********************************************************************) (* fingerprint.ml - Computes PGP fingerprints and keyids *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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) ;; sks-1.1.5/fixkey.ml0000644000175000017500000001416112273431766014733 0ustar kristianfkristianf(***********************************************************************) (* fixkey.ml *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) open StdLabels open MoreLabels open Common open Packet module Map = PMap.Map exception Bad_key exception Standalone_revocation_certificate (** 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 is_revocation_signature pack = match pack.packet_type with | Signature_Packet -> let parsed_signature = ParsePGP.parse_signature pack in let sigtype = match parsed_signature with | V3sig s -> s.v3s_sigtype | V4sig s -> s.v4s_sigtype in let result = match (int_to_sigtype sigtype) with | Key_revocation_signature | Subkey_revocation_signature | Certification_revocation_signature -> true | _ -> false in result | _ -> false let canonicalize key = if is_revocation_signature (List.hd key) then raise Standalone_revocation_certificate; 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; }) sks-1.1.5/foo.ml0000644000175000017500000000452512273431766014222 0ustar kristianfkristianf(***********************************************************************) (* foo.ml *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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 sks-1.1.5/fqueue.ml0000644000175000017500000000767212273431766014737 0ustar kristianfkristianf(***********************************************************************) (* fqueue.ml - Simple implementation of a polymorphic functional queue *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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 sks-1.1.5/getfileopts.ml0000644000175000017500000001114512273431766015760 0ustar kristianfkristianf(***********************************************************************) (* getfileopts.ml - Loads settings from settings file. *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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 sks-1.1.5/heap.ml0000644000175000017500000001134112273431766014346 0ustar kristianfkristianf(***********************************************************************) (* heap.ml - Simple heap implementation, adapted from CLR *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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; } sks-1.1.5/htmlTemplates.ml0000644000175000017500000000765712306640647016270 0ustar kristianfkristianf(***********************************************************************) (* htmlTemplates.ml *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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 """ | '\''-> 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 "
" let page ~title ~body = sprintf "\r\n\r\n\r\n\r\n%s\r\n\r\n

%s

%s" (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/%8s %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=%s" (hash_link ~hash) hash let preformat_list elements = sprintf "
%s
" (String.concat ~sep:"\r\n" elements ^ "\r\n") sks-1.1.5/incdump.ml0000644000175000017500000000776512273431766015107 0ustar kristianfkristianf(***********************************************************************) (* incdump.ml - creates keydump consisting of recently added keys *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* Copyright (C) 2004 Peter Palfrader *) (* *) (* 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 or see . *) (***********************************************************************) 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.keyid_pagesize = !Settings.keyid_pagesize; Keydb.meta_pagesize = !Settings.meta_pagesize; Keydb.subkeyid_pagesize = !Settings.subkeyid_pagesize; Keydb.time_pagesize = !Settings.time_pagesize; Keydb.tqueue_pagesize = !Settings.tqueue_pagesize; Keydb.word_pagesize = !Settings.word_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"; perror "Running SKS %s%s" Common.version Common.version_suffix; 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") sks-1.1.5/index.ml0000644000175000017500000005413112273431766014544 0ustar kristianfkristianf(***********************************************************************) (* index.ml - code for generating pretty PGP key indices *) (* *) (* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *) (* 2011, 2012, 2013 Yaron Minsky and Contributors *) (* *) (* 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 or see . *) (***********************************************************************) 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 " exp " else " sig " | 0x11 -> if sig_expired then " exp1 " else " sig1 " | 0x12 -> if sig_expired then " exp2 " else " sig2 " | 0x13 -> if sig_expired then " exp3 " else " sig3 " | 0x20 | 0x28 | 0x30 -> "revok " | 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 "%s" 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 "%s" 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: %s" policy_url policy_url ) in let notation_data_opt = apply_opt siginfo.notation_data ~f:(fun (name,value) -> sprintf " Notation data: %s %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: %s" (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 "uid %s" (HtmlTemplates.html_quote uid.packet_body) | _ -> sprintf "uat [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 "sub" else "pub" 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 "%8s" (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 
 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.  and 
 are used to allow for an 

       inside of a pre-formatted region.  So this code only works if the
       lines are being generated to be put inside of a 
 block> *)
    ("
" ^ 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 "%s" 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
    "
"::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);
        []


sks-1.1.5/int_comparators.ml0000644000175000017500000000401612273431766016636 0ustar  kristianfkristianf(***********************************************************************)
(* int_comparators.ml -  rename the polymorphic comparators, then      *)
(*                       constraint the usual ones to ints             *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

(* 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
sks-1.1.5/keydb.ml0000644000175000017500000013231112273431766014530 0ustar  kristianfkristianf(***********************************************************************)
(* keydb.ml - Interface for dealing with underlying key database       *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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;
                    keyid_pagesize: int option;
                    meta_pagesize: int option;
                    subkeyid_pagesize: int option;
                    time_pagesize: int option;
                    tqueue_pagesize: int option;
                    word_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)
  (***********************************************************************)

  let kdbopen ?dbenv fname dbtype ?moreflags pagesize flags mode = (
    let db = Db.create ?dbenv [] in
    (match moreflags with
        None -> ()
      | Some flags -> Db.set_flags db flags );
    (match pagesize with
        None -> ()
      | Some pagesize -> Db.set_pagesize db pagesize );
    Db.dopen db fname dbtype flags mode;
    db)

  (** 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 = kdbopen ~dbenv key_db_name Db.BTREE ~moreflags:[]
             settings.pagesize openflags 0o600
          in
          let keyid = kdbopen ~dbenv keyid_db_name Db.BTREE
             ~moreflags:[Db.DUPSORT] settings.keyid_pagesize
              openflags 0o600
          in
          let meta = kdbopen  ~dbenv meta_db_name Db.BTREE
             ~moreflags:[] settings.meta_pagesize openflags 0o600
          in
          let subkey_keyid = kdbopen ~dbenv subkey_keyid_db_name Db.BTREE
             ~moreflags:[Db.DUPSORT] settings.subkeyid_pagesize
              openflags 0o600
          in
          let time = kdbopen ~dbenv time_db_name Db.BTREE
             ~moreflags:[Db.DUPSORT] settings.time_pagesize openflags 0o600
          in
          let tqueue = kdbopen  ~dbenv tqueue_db_name Db.BTREE ~moreflags:[]
             settings.tqueue_pagesize openflags 0o600
          in
          let word = kdbopen ~dbenv word_db_name Db.BTREE
             ~moreflags:[Db.DUPSORT] settings.word_pagesize 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 (Unique_time.get ()) 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 = Unique_time.get ();
      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 = Unique_time.get ();
      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 = Unique_time.get ();
      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)
sks-1.1.5/keyHash.ml0000644000175000017500000000627112273431766015033 0ustar  kristianfkristianf(***********************************************************************)
(* keyHash.ml - 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.         *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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
sks-1.1.5/keyMerge.ml0000644000175000017500000002207312273431766015205 0ustar  kristianfkristianf(***********************************************************************)
(* keyMerge.ml -  Logic for merging PGP keys with the same public key  *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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
sks-1.1.5/key.ml0000644000175000017500000001163212273431766014224 0ustar  kristianfkristianf(***********************************************************************)
(* key.ml - Basic key-related operations                               *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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)
sks-1.1.5/linearAlg.ml0000644000175000017500000002417512273431766015340 0ustar  kristianfkristianf(***********************************************************************)
(* linearAlg.ml                                                        *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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
sks-1.1.5/logdump.ml0000644000175000017500000000533112273431766015102 0ustar  kristianfkristianf(***********************************************************************)
(* logdump.ml                                                          *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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.
sks-1.1.5/mailsync.ml0000644000175000017500000001065612273431766015260 0ustar  kristianfkristianf(***********************************************************************)
(* mailsync.ml - Code for reading in and processing files received     *)
(*               from PKS-style email-based sync                       *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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 () =
  if !Settings.send_mailsyncs then
  (
  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
       );
  []
  )
  else
  []

sks-1.1.5/mArray.ml0000644000175000017500000001016212273431766014664 0ustar  kristianfkristianf(***********************************************************************)
(* mArray.ml - Various array operations                                *)
(*                                                                     *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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 || (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)))


sks-1.1.5/membership.ml0000644000175000017500000001773412273431766015600 0ustar  kristianfkristianf(***********************************************************************)
(* membership.ml - Simple module for loading membership information.   *)
(*                 Currently only loads membership from membership     *)
(*                 file.                                               *)
(*                 @author Yaron M. Minsky                             *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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 "" s
  | { Unix.ai_addr = Unix.ADDR_INET (addr,p) } -> sprintf ""
        (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 -> if !Settings.send_mailsyncs then 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
sks-1.1.5/merge_keyfiles.ml0000644000175000017500000001247012273431766016427 0ustar  kristianfkristianf(***********************************************************************)
(* merge_keyfiles.ml - Executable: Adds keys from key files to         *)
(*                     existing database.                              *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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.keyid_pagesize = !Settings.keyid_pagesize;
    Keydb.meta_pagesize = !Settings.meta_pagesize;
    Keydb.subkeyid_pagesize = !Settings.subkeyid_pagesize;
    Keydb.time_pagesize = !Settings.time_pagesize;
    Keydb.tqueue_pagesize = !Settings.tqueue_pagesize;
    Keydb.word_pagesize = !Settings.word_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";
        perror "Running SKS %s%s" Common.version Common.version_suffix;
    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
sks-1.1.5/meteredChannel.ml0000644000175000017500000000545412273431766016357 0ustar  kristianfkristianf(***********************************************************************)
(* meteredChannel.ml - Version of the [Channel] objects that keeps     *)
(*                     track of the number of bytes sent through them. *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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
sks-1.1.5/mList.ml0000644000175000017500000002252712273431766014531 0ustar  kristianfkristianf(***********************************************************************)
(* mList.ml - Various list operations                                  *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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



sks-1.1.5/mRindex.ml0000644000175000017500000001447612273431766015053 0ustar  kristianfkristianf(***********************************************************************)
(* mRindex.ml - Code for generating machine-readable index             *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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)

let get_latest_exp_time l =
   List.fold_left ~init:(None,None) ~f:(fun (cmax,emax) (cr,ex) ->
      if cr > cmax then (cr, ex) else (cmax, emax)) l

let get_key_expiration_from_uid keyid sigs =
  let sigs = get_self_sigs keyid sigs in
  let times = List.map ~f:ParsePGP.get_key_exptimes sigs in
  let (ctime,exptime) =
    get_latest_exp_time times in
  (ctime,exptime)

let key_expiration_from_uids keyid pk_ctime uids =
 let expir = List.map ~f:(fun (uid,sigs) ->
      match uid.packet_type with
          User_ID_Packet -> get_key_expiration_from_uid keyid sigs
        | _ -> (None, None)
      ) uids in
  let (ctime, exptime) =
     get_latest_exp_time expir
  in
  match exptime with
   | Some x -> Int64.add x pk_ctime
   | None -> Int64.zero

(** 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:false full_keyid in
  let fpr =  Utils.hexstring (Fingerprint.fp_from_key key) 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_expiry = key_expiration_from_uids full_keyid pki.pk_ctime uids in
  let key_expiry_string = if Int64.to_int key_expiry = 0
      then exp_string else sprintf "%Ld" key_expiry
  in
  let key_line = sprintf "pub:%s:%d:%d:%Ld:%s:%s"
  (* Since it is not possible to calculate the key ID from a V3 fingerprint, *)
  (* return the 16-digit key ID for V3 keys.                                 *)
                  (match String.length fpr with
                     | 32 -> keyid
                     |  _ -> fpr )
                   pki.pk_alg
                   pki.pk_keylen
                   pki.pk_ctime
                   key_expiry_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"
sks-1.1.5/msgContainer.ml0000644000175000017500000000443212273431766016065 0ustar  kristianfkristianf(***********************************************************************)
(* msgContainer.ml                                                     *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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


sks-1.1.5/mTimer.ml0000644000175000017500000000456512273431766014700 0ustar  kristianfkristianf(***********************************************************************)
(* mTimer.ml - Simple timer module                                     *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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)

sks-1.1.5/nbMsgContainer.ml0000644000175000017500000001012512273431766016341 0ustar  kristianfkristianf(***********************************************************************)
(* nbMsgContainer.ml - 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.                                      *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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


sks-1.1.5/number.ml0000644000175000017500000001223312273431766014722 0ustar  kristianfkristianf(***********************************************************************)
(* number.ml - Basic operations and definitions for multi-precision    *)
(*             integers                                                *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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 ( ! ) = 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


sks-1.1.5/number_test.ml0000644000175000017500000000470412273431766015765 0ustar  kristianfkristianf(***********************************************************************)
(* number_test.ml                                                      *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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;
sks-1.1.5/packet.ml0000644000175000017500000002657012273431766014712 0ustar  kristianfkristianf(***********************************************************************)
(* packet.ml -  Type definitions and simple functions related to PGP   *)
(*              packets                                                *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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"
  | 30 -> "features"
  | 31 -> "signature target"
  | 32 -> "embedded signature"
  | 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"
  | 0x19 -> "Primary Key Binding Signature"
  | 0x1F -> "Signature directly on a key"
  | 0x20 -> "Key revocation signature"
  | 0x28 -> "Subkey revocation signature"
  | 0x30 -> "Certification revocation signature"
  | 0x40 -> "Timestamp signature"
  | 0x50 -> "Third-Party Confirmation 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 -> "ECDH (ECC)" (* RFC 6637 *)
  | 19 -> "ECDSA (ECC)" (* RFC 6637 *)
  | 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 *)
  | 18 -> "e"  (* ECDH *)
  | 19 -> "E"  (* ECDSA *)
  | _  -> "?"  (* 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
sks-1.1.5/parsePGP.ml0000644000175000017500000003125612306637724015120 0ustar  kristianfkristianf(***********************************************************************)
(* parsePGP.ml                                                         *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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 []

(********************************************************)

(* RFC6637:
   The following algorithm-specific packets are added to Section 5.5.2
   of [RFC4880], "Public-Key Packet Formats", to support ECDH and ECDSA.
 *)

(* OIDs defined in 11. ECC Curve OID of RFC6637 *)
let oid_to_psize oid =
   let psize = match oid with
     | "\x2b\x81\x04\x00\x23" -> 521         		(* nistp521 *)
     | "\x2b\x81\x04\x00\x22" -> 384         		(* nistp384 *)
     | "\x2a\x86\x48\xce\x3d\x03\x01\x07" -> 256   	(* nistp256 *)
     | "\x2b\x24\x03\x03\x02\x08\x01\x01\x07" -> 256 	(* brainpoolP256r1 *)
     | "\x2b\x24\x03\x03\x02\x08\x01\x01\x0b" -> 384 	(* brainpoolP384r1 *)
     | "\x2b\x24\x03\x03\x02\x08\x01\x01\x0d" -> 512 	(* brainpoolP512r1 *)
     | "\x2b\x81\x04\x00\x0a" -> 256         		(* secp256k1 *)
     | _ -> failwith "Unknown OID"
   in
   psize


let parse_ecdh_pubkey cin =
   let length = cin#read_int_size 1 in
   let oid = cin#read_string length in
   let mpi = read_mpi cin in
   let kdf_length = cin#read_int_size 1 in
   let kdf_res = cin#read_int_size 1 in
   let kdf_hash = cin#read_int_size 1 in
   let kdf_algid = cin#read_int_size 1 in
   plerror 10 "KDF_length: %d, KDF_res %d hash %d algid %d" kdf_length kdf_res kdf_hash kdf_algid;
   let psize = oid_to_psize oid
   in
   (mpi, psize)

 let parse_ecdsa_pubkey cin =
   let length = cin#read_int_size 1 in
   let oid = cin#read_string length in
   let psize = oid_to_psize oid
   in
   psize

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,mpi,expiration, psize) =
    match version with
      | 4 ->
      let algorithm = cin#read_byte in
      let (tmpmpi, tmpsize) =  match algorithm with
        | 18 -> parse_ecdh_pubkey cin
        | 19 -> ( {mpi_bits = 0; mpi_data = ""}, (parse_ecdsa_pubkey cin))
        | _ -> ( {mpi_bits = 0; mpi_data = ""} , -1 )
      in
      let mpis = match algorithm with
       | 18 -> tmpmpi
       | _ -> let mmpis = read_mpis cin in List.hd mmpis
      in
      (algorithm,mpis,None, tmpsize)
      | 2 | 3 ->
      let expiration = cin#read_int_size 2 in
      let algorithm = cin#read_byte in
      let mpis = read_mpis cin in
      let mpi = List.hd mpis in
      (algorithm,mpi,Some expiration, -1)
      | _ -> failwith (sprintf "Unexpected pubkey version: %d" version)
  in
  { pk_version = version;
    pk_ctime = creation_time;
    pk_expiration = (match expiration with Some 0 -> None | x -> x);
    pk_alg = algorithm;
    pk_keylen = (match algorithm with |18|19 -> psize | _ -> 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 ssp_keyexptime_id = 9

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_key_exptimes 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_keyexptime_id && ssp.ssp_length = 4 then
                  (ctime,Some (int64_of_string ssp.ssp_body))
                else
                  (ctime,exptime)
             )
      in
      match exptime_delta with
        | None -> (None,None)
        | Some _ -> (ctime,exptime_delta)


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))
sks-1.1.5/pbuild.ml0000644000175000017500000001056312273431766014715 0ustar  kristianfkristianf(***********************************************************************)
(* pbuild.ml - Executable:  Builds a prefix-tree database from an      *)
(*             existing Keydb                                          *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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.keyid_pagesize = !Settings.keyid_pagesize;
    Keydb.meta_pagesize = !Settings.meta_pagesize;
    Keydb.subkeyid_pagesize = !Settings.subkeyid_pagesize;
    Keydb.time_pagesize = !Settings.time_pagesize;
    Keydb.tqueue_pagesize = !Settings.tqueue_pagesize;
    Keydb.word_pagesize = !Settings.word_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 () = Sys.set_signal Sys.sigusr1 Sys.Signal_ignore
  let () = Sys.set_signal Sys.sigusr2 Sys.Signal_ignore

  (***************************************************************)

  let run () =
    set_logfile "pbuild";
        perror "Running SKS %s%s" Common.version Common.version_suffix;

    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
sks-1.1.5/pdiskTest.ml0000644000175000017500000001125112273431766015403 0ustar  kristianfkristianf(***********************************************************************)
(* pdiskTest.ml                                                        *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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)
  )
sks-1.1.5/pMap.ml0000644000175000017500000001374312273431766014336 0ustar  kristianfkristianf(***********************************************************************)
(* pMap.ml - Association tables over ordered types.                    *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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)
sks-1.1.5/poly.ml0000644000175000017500000001430212273431766014414 0ustar  kristianfkristianf(***********************************************************************)
(* poly.ml - Simple polynomial implementation                          *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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)))


sks-1.1.5/poly_test.ml0000644000175000017500000000725312273431766015462 0ustar  kristianfkristianf(***********************************************************************)
(* poly_test.ml - unit tests for Poly module                           *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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
sks-1.1.5/prefix_test.ml0000644000175000017500000001460512273431766015773 0ustar  kristianfkristianf(***********************************************************************)
(* prefix_test.ml                                                      *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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;
  *)

sks-1.1.5/prefixTree.ml0000644000175000017500000010175212273431766015554 0ustar  kristianfkristianf(***********************************************************************)
(* prefixTree.ml                                                       *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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


(******************************************************************)
(******************************************************************)
(******************************************************************)

sks-1.1.5/prime.ml0000644000175000017500000000744012273431766014552 0ustar  kristianfkristianf(***********************************************************************)
(* prime.ml - Generate prime using miller-rabin primality test         *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

open StdLabels
open MoreLabels
module Unix=UnixLabels
open Number.Infix

(** returns random string with exactly  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 || 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


sks-1.1.5/pSet.ml0000644000175000017500000002524412273431766014353 0ustar  kristianfkristianf(***********************************************************************)
(* pSet.ml - Sets over ordered types                                   *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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)
sks-1.1.5/pstyle.ml0000644000175000017500000000501612273431766014753 0ustar  kristianfkristianf(***********************************************************************)
(* pstyle.ml - Allows for some python-like tricks, at the expense of   *)
(*             some performance and indirection                        *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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
sks-1.1.5/ptest.ml0000644000175000017500000001234112273431766014571 0ustar  kristianfkristianf(***********************************************************************)
(* ptest.ml                                                            *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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 ()
sks-1.1.5/ptree_consistency_test.ml0000644000175000017500000000703512273431766020235 0ustar  kristianfkristianf(***********************************************************************)
(* ptree_consistency_test.ml - Test for verifying consistency of       *)
(*                             prefix tree data structure              *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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"
sks-1.1.5/pTreeDB.ml0000644000175000017500000001426012273431766014721 0ustar  kristianfkristianf(***********************************************************************)
(* pTreeDB.ml                                                          *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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 0o700;
          Utils.initdbconf !Settings.basedir settings.dbdir;
          );

    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



sks-1.1.5/ptree_db_test.ml0000644000175000017500000000445512273431766016264 0ustar  kristianfkristianf(***********************************************************************)
(* ptree_db_test.ml - Checks whether the memory-bounds on a ptree are  *)
(*                    in force. Test for verifying consistency of      *)
(*                    prefix tree data structure.                      *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

(* #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
sks-1.1.5/ptree_replay.ml0000644000175000017500000000642412273431766016132 0ustar  kristianfkristianf(***********************************************************************)
(* ptree_replay.ml - Test for verifying consistency of prefix tree     *)
(*                   data structure                                    *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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
sks-1.1.5/ptscript.ml0000644000175000017500000000314712273431766015306 0ustar  kristianfkristianf(***********************************************************************)
(* ptscript.ml                                                         *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

open PdiskTest
open PTree

let () =
  Settings.prob := 0.0

let () =
  runtest 100

sks-1.1.5/query.ml0000644000175000017500000000622212273431766014600 0ustar  kristianfkristianf(***********************************************************************)
(* query.ml - Executable: Simple tool for direct querying key db.      *)
(*            Should not be used while dbserver is running             *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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

sks-1.1.5/recode.ml0000644000175000017500000000365412273431766014702 0ustar  kristianfkristianf(***********************************************************************)
(* recode.ml                                                           *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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 -> () )
sks-1.1.5/reconComm.ml0000644000175000017500000001116412273431766015356 0ustar  kristianfkristianf(***********************************************************************)
(* reconComm.ml                                                        *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

open StdLabels
open MoreLabels
open Printf
open Common
open Packet

module Unix = UnixLabels
module Map = PMap.Map

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"


sks-1.1.5/reconCS.ml0000644000175000017500000001552612273431766014776 0ustar  kristianfkristianf(***********************************************************************)
(* reconCS.ml - Reconciliation logic that is shared between the client *)
(*              and server                                             *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

open StdLabels
open MoreLabels
open Common
open CMarshal
open ReconMessages
open Printf
module Set = PSet.Set
module Map = PMap.Map
module Unix = UnixLabels

(** 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 "
                    compatible_version_string 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 partner.Unix.ai_family partner.Unix.ai_socktype partner.Unix.ai_protocol
  in
  let run () =
    Unix.bind s (match_client_recon_addr partner.Unix.ai_addr);
    Unix.connect s 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)
sks-1.1.5/reconMessages.ml0000644000175000017500000001773012273431766016237 0ustar  kristianfkristianf(***********************************************************************)
(* reconMessages.ml                                                    *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

open StdLabels
open MoreLabels
open Printf
open 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 (ZZp.Set.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: ZZp.Set.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 "" s
  | Unix.ADDR_INET (addr,p) -> sprintf ""
      (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 ZZp.Set.t
           | FullElements of ZZp.Set.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)"
         (ZZp.Set.cardinal rf.rf_elements)
         (Bitstring.to_string rf.rf_prefix)
     | Elements s -> sprintf "Elements(len:%d)" (ZZp.Set.cardinal s)
     | FullElements s -> sprintf "FullElements(len:%d)" (ZZp.Set.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"
*)


sks-1.1.5/reconPTreeDb.ml0000644000175000017500000000313112273431766015743 0ustar  kristianfkristianf(***********************************************************************)
(* reconPTreeDb.ml                                                     *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

open StdLabels
open MoreLabels
open Common
module PTree = PrefixTree

sks-1.1.5/reconserver.ml0000644000175000017500000003367512273431766016004 0ustar  kristianfkristianf(***********************************************************************)
(* reconserver.ml - Executable: server process that handles            *)
(*                  reconciliation                                     *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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.rev_map ~f:Eventloop.maybe_create_sock (make_addr_list recon_address recon_port)
  let reconsocks =
    List.fold_right ~init:[]
      ~f:(function
	   | Some sock -> fun acc -> sock :: acc
	   | None -> fun acc -> acc)
      reconsocks
  let () =
    if reconsocks = [] then
      failwith "Could not listen on any address."



  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
                 [] -> ""
               | 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%s"  version version_suffix;
    plerror 0 "Using BerkelyDB version %s" (Bdb.version(););
    plerror 1 "Copyright Yaron Minsky 2002-2013";
    plerror 1 "Licensed under GPL.  See LICENSE 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
sks-1.1.5/recoverList.ml0000644000175000017500000001013412273431766015731 0ustar  kristianfkristianf(***********************************************************************)
(* recoverList.ml - Code for managing reconserver's recover list, i.e. *)
(*                  the list of keys that need to be recovered from    *)
(*                  other hosts.                                       *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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 ()



sks-1.1.5/recvmail.ml0000644000175000017500000000746312273431766015245 0ustar  kristianfkristianf(***********************************************************************)
(* recvmail.ml - Simple (and likely incomplete) interface for          *)
(*               receiving mail                                        *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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;
  }

sks-1.1.5/request.ml0000644000175000017500000001057212273431766015126 0ustar  kristianfkristianf(***********************************************************************)
(* request.ml                                                          *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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 = (-1);
                      }

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
sks-1.1.5/rMisc.ml0000644000175000017500000001375712273431766014523 0ustar  kristianfkristianf(***********************************************************************)
(* rMisc.ml - Miscellaneous utilities associated with reconciliation,  *)
(*            and in particular those that require access to the size  *)
(*            of the prime modulus.                                    *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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)

sks-1.1.5/script.ml0000644000175000017500000004134712273431766014746 0ustar  kristianfkristianf(***********************************************************************)
(* script.ml                                                           *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

#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)


sks-1.1.5/sendmail.ml0000644000175000017500000000775412273431766015242 0ustar  kristianfkristianf(***********************************************************************)
(* sendmail.ml - Simple (& likely incomplete) interface for sending    *)
(*               mail                                                  *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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
sks-1.1.5/server.ml0000644000175000017500000001476512273431766014754 0ustar  kristianfkristianf(***********************************************************************)
(* server.ml - Server side of set-reconciliation algorithm             *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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


sks-1.1.5/settings.ml0000644000175000017500000003534512273431766015303 0ustar  kristianfkristianf(***********************************************************************)
(* settings.ml - Various and sundry settings with their defaults, plus *)
(*               functions for assigning new values.  This is used by  *)
(*               the getopt routines to set preferences                *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

open StdLabels
open MoreLabels
module Unix=UnixLabels
open Printf

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 65536)
let set_pagesize value = pagesize := Some (value * 512)

let keyid_pagesize = ref None
let set_keyid_pagesize value = keyid_pagesize := Some (value * 512)

let meta_pagesize = ref None
let set_meta_pagesize value = meta_pagesize := Some (value * 512)

let subkeyid_pagesize = ref None
let set_subkeyid_pagesize value = subkeyid_pagesize := Some (value * 512)

let time_pagesize = ref None
let set_time_pagesize value = time_pagesize := Some (value * 512)

let tqueue_pagesize = ref None
let set_tqueue_pagesize value = tqueue_pagesize := Some (value * 512)

let word_pagesize = ref None
let set_word_pagesize value = word_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 4096)
let set_ptree_pagesize value = ptree_pagesize := Some (value * 512)

let hostname = ref (Unix.gethostname ())
let set_hostname value = hostname := value

let nodename = ref (Unix.gethostname ())
let set_nodename value = nodename := value

let server_contact = ref ""
let set_server_contact value = server_contact := 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 use_stdin = ref false

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");
    ("-nodename", Arg.String set_nodename, " current nodename");
    ("-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_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 512 byte blocks for key db");
    ("-keyid_pagesize", Arg.Int set_keyid_pagesize, " Pagesize in 512 byte blocks for keyid db");
    ("-meta_pagesize", Arg.Int set_meta_pagesize, " Pagesize in 512 byte blocks for meta db");
    ("-subkeyid_pagesize", Arg.Int set_subkeyid_pagesize, " Pagesize in 512 byte blocks for subkeyid db");
    ("-time_pagesize", Arg.Int set_time_pagesize, " Pagesize in 512 byte blocks for time db");
    ("-tqueue_pagesize", Arg.Int set_tqueue_pagesize, " Pagesize in 512 byte blocks for tqueue db");
    ("-word_pagesize", Arg.Int set_word_pagesize, " Pagesize in 512 byte blocks for word db");
    ("-cache", Arg.Int set_cache_bytes, " Cache size in megs for key db");
    ("-ptree_pagesize", Arg.Int set_ptree_pagesize,
     " Pagesize in 512 byte blocks 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 by hostname or IP");
    ("-hkp_port",Arg.Int set_hkp_port, " Set hkp port number");
    ("-hkp_address",Arg.String set_hkp_address, " Set hkp binding address by hostname or IP");
    ("-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.");
    ("-stdin", Arg.Set use_stdin,
     " Read keyids from stdin (sksclient only)");
    ("-server_contact", Arg.String set_server_contact,
     " Set OpenPGP KeyID of the server contact");
  ]

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)"



sks-1.1.5/sksclient.ml0000644000175000017500000000633512273431766015437 0ustar  kristianfkristianf(************************************************************************)
(* 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 DbMessages

let settings =
  { Keydb.
    withtxn = !Settings.transactions;
    cache_bytes = !Settings.cache_bytes;
    pagesize = !Settings.pagesize;
    keyid_pagesize = !Settings.keyid_pagesize;
    meta_pagesize = !Settings.meta_pagesize;
    subkeyid_pagesize = !Settings.subkeyid_pagesize;
    time_pagesize = !Settings.time_pagesize;
    tqueue_pagesize = !Settings.tqueue_pagesize;
    word_pagesize = !Settings.word_pagesize;
    dbdir = Lazy.force Settings.dbdir;
    dumpdir = Lazy.force Settings.dumpdir;
  }

module Keydb = Keydb.Safe

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)

      | _ -> failwith "Unknown keyid type"

let dump_one_key keyid =
  let deprefixed =
    if String.length keyid <= 2 then exit 3
    else if String.sub keyid 0 2 = "0x"
    then String.sub keyid 2 (String.length keyid - 2)
    else keyid
  in
  let keys = get_keys_by_keyid (KeyHash.dehexify deprefixed) in
  let aakeys =
    if keys = [] then exit 2
    else Armor.encode_pubkey_string (Key.to_string_multiple keys)
  in
  printf "%s\n" aakeys

(** iterate over lines from stdin, printing out a final \n at the end *)
let rec stdin_iter f =
  let line = try Some (input_line stdin) with End_of_file -> None in
  match line with
  | None -> printf "\n"
  | Some line -> f line; stdin_iter f

let keysource action =
  if !Settings.use_stdin then stdin_iter action
  else
    for i = 1 to Array.length Sys.argv - 1 do
      action Sys.argv.(i)
    done

let () =
    if Array.length Sys.argv < 2 then failwith "Keys in argv unless -stdin set";
    set_logfile "sksclient";
        perror "sksclient (SKS %s%s)" Common.version Common.version_suffix;
    Keydb.open_dbs settings;
    keysource dump_one_key;
    Keydb.close_dbs ();
sks-1.1.5/sks_do.ml0000644000175000017500000000524112273431766014715 0ustar  kristianfkristianf(***********************************************************************)
(* sks_do.ml - simple command-line tool for sending actions directly   *)
(*             to sks_db and sks_recon processes                       *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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"

sks-1.1.5/sksdump.ml0000644000175000017500000001367512273431766015133 0ustar  kristianfkristianf(***********************************************************************)
(* sksdump.ml - takes content of SKS keyserver and creates key dump    *)
(*              from that                                              *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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.keyid_pagesize = !Settings.keyid_pagesize;
    Keydb.meta_pagesize = !Settings.meta_pagesize;
    Keydb.subkeyid_pagesize = !Settings.subkeyid_pagesize;
    Keydb.time_pagesize = !Settings.time_pagesize;
    Keydb.tqueue_pagesize = !Settings.tqueue_pagesize;
    Keydb.word_pagesize = !Settings.word_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 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 dump_database_create_metadata dumpdir name size ctr start_time =
   let fname = Filename.concat dumpdir (sprintf "metadata-%s.txt" name) in
   let numkey = Keydb.get_num_keys () in
   let c = ref 0  in
   let file = open_out fname in
   fprintf file "#Metadata-for: %s\n" !Settings.hostname;
   fprintf file "#Dump-started: %s\n" (time_to_string start_time);
   fprintf file "#Files-Count: %d\n" ctr;
   fprintf file "#Key-Count: %d\n" numkey;
   fprintf file "#Digest-algo: md5\n";
   while !c < ctr do 
     fprintf file "%s %s-%04d.pgp\n" (Digest.to_hex(
      Digest.file (Filename.concat dumpdir (sprintf "%s-%04d.pgp" name !c))))
      name !c;
     incr c
   done;
   fprintf file "#Dump-ended: %s\n" (time_to_string 
                                        (Unix.gettimeofday()));
   close_out file;
   ()
  
  let dump_database dumpdir size name =
   let (stream,close) = Keydb.create_hash_skey_stream () in
   let start_time = Unix.gettimeofday() in
   let () = if not (Sys.file_exists dumpdir) then
    Unix.mkdir dumpdir  0o700; 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;
    dump_database_create_metadata dumpdir name size !ctr start_time
    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";
                perror "Running SKS %s%s" Common.version Common.version_suffix;
            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
sks-1.1.5/sks.ml0000644000175000017500000001465312273431766014242 0ustar  kristianfkristianf(***********************************************************************)
(* sks.ml - Executable: Ueber-executable replacing all others          *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

open StdLabels
open MoreLabels
open Printf
open Scanf
open Common

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 = "numkeys dumpdir [prefix]";
    desc = "Create a raw dump of the keys in the database. " ^
           "The dump is split into multiple files containing numkeys " ^
           "keys per file. Optional prefix is added to each dump filename.";
    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;
  };
  { name = "version";
    usage = "";
    desc = "Show version information";
    func = Version.run;
  };
]

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)
sks-1.1.5/sksstats.ml0000777000175000017500000000460412272037451015313 0ustar  kristianfkristianf(************************************************************************)
(* 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 DbMessages
open Packet

let settings = {
    Keydb.withtxn = !Settings.transactions;
    Keydb.cache_bytes = !Settings.cache_bytes;
    Keydb.pagesize = !Settings.pagesize;
    Keydb.keyid_pagesize = !Settings.keyid_pagesize;
    Keydb.meta_pagesize = !Settings.meta_pagesize;
    Keydb.subkeyid_pagesize = !Settings.subkeyid_pagesize;
    Keydb.time_pagesize = !Settings.time_pagesize;
    Keydb.tqueue_pagesize = !Settings.tqueue_pagesize;
    Keydb.word_pagesize = !Settings.word_pagesize;
    Keydb.dbdir = Lazy.force Settings.dbdir;
    Keydb.dumpdir = Lazy.force Settings.dumpdir;
  }

module Keydb = Keydb.Unsafe

let get_algo key file =
   let fpr = Fingerprint.fp_from_key key in
   let packet = List.filter (fun x -> x.packet_type = Public_Key_Packet) key in
   if List.length packet > 0 then
   (let packet = List.hd packet in
   let pki = ParsePGP.parse_pubkey_info packet in
   fprintf file "%s;%d;%d;%d\n" (KeyHash.hexify fpr) pki.pk_version pki.pk_alg pki.pk_keylen)

let () =
    perror "sksstats (SKS %s%s)" Common.version Common.version_suffix;
    Keydb.open_dbs settings;
    let file = "sksstats.dat" in
    let out = open_out file in 

    let generate_stats =
      let genstat ~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
          get_algo key out;
      in
      Keydb.raw_iter genstat in

    generate_stats;
    close_out out;
    Keydb.close_dbs ();

sks-1.1.5/spider.ml0000644000175000017500000001153512273431766014724 0ustar  kristianfkristianf(***********************************************************************)
(* spider.ml - start with a SKS server and spider the entire network   *)
(*             by recursively crawling peers from stats pages          *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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
    ("pool.sks-keyservers.net",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 end_td = Str.regexp "$"

let get_peer line =
  if line  (0,8) = "" then
    match Str.split whitespace (Str.global_replace end_td "" 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
sks-1.1.5/sStream.ml0000644000175000017500000000376212273431766015057 0ustar  kristianfkristianf(***********************************************************************)
(* sStream.ml - simple stream with 1-step lookahead.                   *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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



sks-1.1.5/stats.ml0000644000175000017500000001705312273431766014575 0ustar  kristianfkristianf(***********************************************************************)
(* stats.ml - functions for formatting raw DB stats                    *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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 "%s%d%d"
      (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
  "\n" ^
  "\n" ^
  String.concat "\n" table_entries ^
  "\n
TimeNew KeysUpdated Keys
\n"


(************************************************************)

let info_tables () =
  let settings =
    sprintf
      "
Settings

     

     
Hostname:%s

     
Nodename:%s

     
Version:%s%s

     
Server contact:%s

     
HTTP port:%d

     
Recon port:%d

     
Debug level:%d


\r\n"
      !Settings.hostname !Settings.nodename Common.version Common.version_suffix
      !Settings.server_contact 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 "%s\n" peer) peers in
    sprintf "
Gossip Peers
\n\n%s
"
      (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 "%s\n" s) peers in
    sprintf "
Outgoing Mailsync Peers
\n\n%s
"
      (String.concat ~sep:"" peers)
  in
  sprintf "%s\n\n



%s

%s

\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 "
Total number of keys: %d
\n" size  in
  let title =
    sprintf
      "SKS OpenPGP Keyserver statistics
Taken at %s"
      (time_to_tz_string now)
  in
  if Array.length log = 0 then
    HtmlTemplates.page
      ~title
      ~body:(info_tables () ^ num_keys ^ "\n
No recent transactions
")
  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 () ^
      "
Statistics
" ^
      num_keys ^
      "
Daily Histogram
\n" ^
      daily_table ^
      "
Hourly Histogram
\n" ^
      hourly_table
    in
    HtmlTemplates.page ~title ~body


let generate_html_stats_page_nostats () =
  let body = info_tables () ^
             "
 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


sks-1.1.5/tester.ml0000644000175000017500000001014612273431766014741 0ustar  kristianfkristianf(***********************************************************************)
(* tester.ml                                                           *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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.keyid_pagesize = !Settings.keyid_pagesize;
  Keydb.meta_pagesize = !Settings.meta_pagesize;
  Keydb.subkeyid_pagesize = !Settings.subkeyid_pagesize;
  Keydb.time_pagesize = !Settings.time_pagesize;
  Keydb.tqueue_pagesize = !Settings.tqueue_pagesize;
  Keydb.word_pagesize = !Settings.word_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)

*)
sks-1.1.5/Unique_time.ml0000644000175000017500000000365412273431766015725 0ustar  kristianfkristianf(***********************************************************************)
(* Unique_time.ml - Module to return unique time                       *)
(*                 @author Yaron M. Minsky                             *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)
let most_recent_unique_time : float ref  = ref 0.

let timestamp_delta = 0.000001

let get nil =
  let candidate = Unix.gettimeofday() in
  let final =
    match candidate > !most_recent_unique_time with
      true -> candidate
    | false -> !most_recent_unique_time +. timestamp_delta
  in
  most_recent_unique_time := final;
  final
sks-1.1.5/unit_tests.ml0000644000175000017500000000412712273431766015636 0ustar  kristianfkristianf(***********************************************************************)
(* unit_tests.ml - perform simple unit tests                           *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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%!";

sks-1.1.5/update_subkeys.ml0000644000175000017500000001171612273431766016466 0ustar  kristianfkristianf(***********************************************************************)
(* update_subkeys.ml                                                   *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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.keyid_pagesize = !Settings.keyid_pagesize;
  Keydb.meta_pagesize = !Settings.meta_pagesize;
  Keydb.subkeyid_pagesize = !Settings.subkeyid_pagesize;
  Keydb.time_pagesize = !Settings.time_pagesize;
  Keydb.tqueue_pagesize = !Settings.tqueue_pagesize;
  Keydb.word_pagesize = !Settings.word_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";
  perror "Running SKS %s%s" Common.version Common.version_suffix;
  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.";

sks-1.1.5/utils.ml0000644000175000017500000002512712273431766014600 0ustar  kristianfkristianf(***********************************************************************)
(* utils.ml - A variety of simple utilities                            *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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 []

let copy_conf src dst fn =
    let command = "cp " ^ (Filename.concat src fn) ^
      " " ^ (Filename.concat dst "DB_CONFIG")  in
    let r_command = Sys.command command in
    match r_command with
        | 0 -> ()
        | _ -> failwith ("Copy of DB_CONFIG failed")

let initdbconf src dst =
  let db = Filename.basename dst in
  let lstconf = ["DB_CONFIG." ^ db; "DB_CONFIG"] in
  let conf_exists conf = Sys.file_exists
        (Filename.concat src conf) in
  let found_conf = List.filter lstconf
    ~f:(fun x -> conf_exists x)  in
  match found_conf with
      [] -> ()
      | hd :: _ -> copy_conf src dst hd;
sks-1.1.5/version.ml0000644000175000017500000000452712273431766015126 0ustar  kristianfkristianf(***********************************************************************)
(* version.ml - Executable: Show version information                   *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

open Printf

let run () =
  let bdb_version = Bdb.version () in
  let dbstats_dir =
    let split = Str.regexp_string "." in
    let major_minor_string major minor =
      sprintf "Further details about the BDB environment can be seen by \
	  executing\ndb%s.%s_stat -x in the KDB and Ptree directories\n" major minor
    in
    match Str.split split bdb_version with
    | major :: minor :: _ -> major_minor_string major minor
    | [] | _ :: []        -> major_minor_string "X"   "Y"
  in
  printf "SKS version %s%s\n"
    Common.version Common.version_suffix;
	
  printf "Compiled with Ocaml version %s and BDB version %s\n"
      Sys.ocaml_version bdb_version;

  printf "This SKS version has a minimum compatibility \
         requirement for recon of SKS %s\n"
      Common.compatible_version_string;
	
  printf "%s" dbstats_dir

sks-1.1.5/wserver.ml0000644000175000017500000003525012331743744015130 0ustar  kristianfkristianf(***********************************************************************)
(* wserver.ml - simple web server code                                 *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

open StdLabels
open MoreLabels
open Printf
open Common
module Unix = UnixLabels
open Unix

module Map = PMap.Map
module Set = PSet.Set

exception Page_not_found of string
exception No_results of string
exception Not_implemented of string
exception Bad_request of string
exception Entity_too_large of string
exception Misc_error 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 (Entity_too_large (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 request_to_string_logdepend request =
  if !Settings.debuglevel < 6 then
    request_to_string_short request
    else request_to_string request


(* Result codes and descriptions from                                               *)
(* https://support.google.com/webmasters/bin/answer.py?hl=en&answer=40132           *)
(* send_result exposes a completely open CORS policy, so use only with public data. *)

let send_result cout ?(error_code = 200) ?(content_type = "text/html; charset=UTF-8") ?(count = -1) body =
  let text_status =
    match error_code with
      | 200 -> "OK"
      | 201 -> "Created"
      | 202 -> "Accepted"
      | 203 -> "Non-Authoritative Information"
      | 204 -> "No Content"
      | 205 -> "Reset Content"
      | 206 -> "Partial Content"
      | 300 -> "Multiple Choices"
      | 301 -> "Moved Permanently"
      | 302 -> "Moved Temporarily"
      | 303 -> "See Other Location"
      | 304 -> "Not Modified"
      | 305 -> "Use Proxy"
      | 307 -> "Temporary Redirect"
      | 400 -> "Bad Request"
      | 401 -> "Not Authorized"
      | 403 -> "Forbidden"
      | 404 -> "Not found"
      | 405 -> "Method Not Allowed"
      | 406 -> "Not Acceptable"
      | 407 -> "Proxy Authentication Required"
      | 408 -> "Request Timeout"
      | 409 -> "Conflict"
      | 410 -> "Gone"
      | 411 -> "Length Required"
      | 412 -> "Precondition Failed"
      | 413 -> "Request Entity too Large"
      | 414 -> "Requested URI too Large"
      | 415 -> "Unsupported Media Type"
      | 416 -> "Requested Range not Satisfiable"
      | 417 -> "Expectation Failed"
      | 500 -> "Internal Server Error"
      | 501 -> "Not Implemented"
      | 502 -> "Bad Gateway"
      | 503 -> "Service Unavailable"
      | 504 -> "Gateway Timeout"
      | 505 -> "HTTP Version Not Supported"
      | _   -> "???"
  in
  fprintf cout "HTTP/1.0 %03d %s\r\n" error_code text_status;
  fprintf cout "Server: sks_www/%s%s\r\n" version version_suffix;
  fprintf cout "Cache-Control: no-cache\r\n";
  fprintf cout "Pragma: no-cache\r\n";
  fprintf cout "Expires: 0\r\n";
  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" content_type;
  (*
   * Hack to force content-disposition for machine readable get request.
   * This should probably be passed down in the request itself.
   *)
  if content_type = "application/pgp-keys; charset=UTF-8" then
    fprintf cout "Content-disposition: attachment; filename=gpgkey.asc\r\n";
  (*
   * Allow access from Javascript code on other sites.
   * For details, see https://en.wikipedia.org/wiki/Cross-origin_resource_sharing.
   * This is safe since all information on keyservers is public.
   *)
  fprintf cout "Access-Control-Allow-Origin: *\r\n";
  (*
   * End Headers here with a final newline
   *)
  fprintf cout "\r\n";
  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) (HtmlTemplates.html_quote 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" (HtmlTemplates.html_quote s))
            in
            send_result cout ~error_code:404 output

        | Bad_request s ->
            ignore (Unix.alarm recover_timeout);
            plerror 2 "Bad request %s: %s"
              (request_to_string_logdepend request) s;
            let output = HtmlTemplates.page ~title:"Bad request"
                 ~body:(sprintf "Bad request: %s" (HtmlTemplates.html_quote s))
            in
            send_result cout ~error_code:400 output

        | No_results s ->
            ignore (Unix.alarm recover_timeout);
            plerror 2 "No results for request %s: %s"
              (request_to_string_logdepend request) s;
            let output = HtmlTemplates.page ~title:"No results found"
             ~body:(sprintf "No results found: %s" (HtmlTemplates.html_quote s))
            in
            send_result cout ~error_code:404 output

        | Entity_too_large s ->
            ignore (Unix.alarm recover_timeout);
            plerror 2 "Error handling request %s: %s"
              (request_to_string request) s;
            let output = HtmlTemplates.page ~title:"Request Entity Too Large"
                 ~body:(sprintf "Request Entity Too Large: %s" (HtmlTemplates.html_quote s))
            in
            send_result cout ~error_code:413 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" (HtmlTemplates.html_quote 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."))
            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;
  []
sks-1.1.5/zZp.ml0000644000175000017500000001350512273431766014220 0ustar  kristianfkristianf(***********************************************************************)
(* zZp.ml - Field of integers mod p (for a settable prime p)           *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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 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
sks-1.1.5/add_mail.mli0000644000175000017500000000006112273431766015331 0ustar  kristianfkristianf(* This is the sks add_mail command-line tool *)
sks-1.1.5/armor.mli0000644000175000017500000000022312273431766014717 0ustar  kristianfkristianfval encode_pubkey_string : string -> string
val decode_pubkey : string -> Packet.packet list list
val encode_pubkey : Packet.packet list -> string
sks-1.1.5/bdbwrap.mli0000644000175000017500000000777612273431766015244 0ustar  kristianfkristianfexception Key_exists
module Dbenv :
  sig
    type t = Bdb.dbenv
    type open_flag =
      Bdb.Dbenv.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 =
      Bdb.Dbenv.verbose_flag =
        VERB_CHKPOINT
      | VERB_DEADLOCK
      | VERB_RECOVERY
      | VERB_WAITSFOR
    val create : unit -> t
    val dopen : t -> string -> open_flag list -> int -> unit
    val sopen : string -> open_flag list -> int -> t
    val close : t -> unit
    val set_verbose_internal : t -> verbose_flag list -> bool -> unit
    val set_verbose : t -> verbose_flag -> bool -> unit
    val set_cachesize : t -> gbytes:int -> bytes:int -> ncache:int -> unit
  end
module Db :
  sig
    type t = Bdb.db
    type create_flag = Bdb.Db.create_flag
    type open_flag =
      Bdb.Db.open_flag =
        CREATE
      | EXCL
      | NOMMAP
      | RDONLY
      | THREAD
      | TRUNCATE
      | AUTO_COMMIT
    type db_type = Bdb.Db.db_type = BTREE | HASH | QUEUE | RECNO | UNKNOWN
    type put_flag = Bdb.Db.put_flag = APPEND | NODUPDATA | NOOVERWRITE
    type get_flag =
      Bdb.Db.get_flag =
        CONSUME
      | CONSUME_WAIT
      | SET_RECNO
      | RMW
    type set_flag =
      Bdb.Db.set_flag =
        DUP
      | DUPSORT
      | RECNUM
      | REVSPLITOFF
      | RENUMBER
      | SNAPSHOT
    external get_size : t -> int = "caml_db_get_size"
    val create : ?dbenv:Bdb.Dbenv.t -> create_flag list -> t
    val dopen : t -> string -> db_type -> open_flag list -> int -> unit
    val close : t -> unit
    val del : t -> ?txn:Bdb.txn -> string -> unit
    val put :
      t -> ?txn:Bdb.txn -> key:string -> data:string -> put_flag list -> unit
    val get : t -> ?txn:Bdb.txn -> string -> get_flag list -> string
    val set_flags : t -> set_flag list -> unit
    val sopen :
      ?dbenv:Bdb.Dbenv.t ->
      string ->
      db_type -> ?moreflags:set_flag list -> open_flag list -> int -> t
    val set_h_ffactor : t -> int -> unit
    val set_pagesize : t -> int -> unit
    val set_cachesize : t -> gbytes:int -> bytes:int -> ncache:int -> unit
    val sync : t -> unit
  end
module Cursor :
  sig
    type t = Bdb.cursor
    type put_flag = Bdb.Cursor.put_flag = AFTER | BEFORE | CURRENT
    type kput_flag = Bdb.Cursor.kput_flag = KEYFIRST | KEYLAST | NODUPDATA
    type get_type =
      Bdb.Cursor.get_type =
        CURRENT
      | FIRST
      | LAST
      | NEXT
      | PREV
      | NEXT_DUP
      | NEXT_NODUP
      | PREV_NODUP
      | NULL
    type get_flag = Bdb.Cursor.get_flag = RMW
    val create : ?writecursor:bool -> ?txn:Bdb.txn -> Bdb.Db.t -> t
    val close : t -> unit
    val put : t -> string -> put_flag -> unit
    val kput : t -> key:string -> data:string -> kput_flag -> unit
    val init : t -> string -> get_flag list -> string
    val init_range : t -> string -> get_flag list -> string * string
    val init_both : t -> key:string -> data:string -> get_flag list -> unit
    val get : t -> get_type -> get_flag list -> string * string
    val get_keyonly : t -> get_type -> get_flag list -> string
    val del : t -> unit
    val count : t -> int
    val dup : ?keep_position:bool -> t -> t
    val ajoin :
      ?nosort:bool ->
      Bdb.db -> Bdb.cursor array -> get_flag list -> Bdb.cursor
    val join :
      ?nosort:bool ->
      Bdb.db -> Bdb.cursor list -> get_flag list -> Bdb.cursor
  end
module Txn :
  sig
    type t = Bdb.txn
    type begin_flag = Bdb.Txn.begin_flag = NOSYNC | NOWAIT | SYNC
    type checkpoint_flag = Bdb.Txn.checkpoint_flag = FORCE
    type commit_flag = Bdb.Txn.commit_flag = COM_NOSYNC | COM_SYNC
    val set_txn_max : Bdb.dbenv -> int -> unit
    val abort : t -> unit
    val txn_begin : Bdb.dbenv -> t option -> begin_flag list -> t
    val checkpoint :
      Bdb.dbenv -> kbyte:int -> min:int -> checkpoint_flag list -> unit
    val commit : t -> commit_flag list -> unit
  end
sks-1.1.5/bitstring.mli0000644000175000017500000000216712273431766015615 0ustar  kristianfkristianfexception Error of string
exception LengthError of string
val width : int
type t = { a : string; bitlength : int; }
val bytelength : int -> int
val create : int -> t
val get : t -> int -> int
val lget : t -> int -> bool
val flip : t -> int -> unit
val set : t -> int -> unit
val unset : t -> int -> unit
val setval : t -> int -> bool -> unit
val print : t -> unit
val hexprint : t -> unit
val to_bool_array : t -> bool array
val to_string : t -> string
val to_bytes : t -> string
val of_bytes : string -> int -> t
val of_byte : int -> t
val of_bytes_all : string -> t
val of_int : int -> t
val of_bytes_nocopy : string -> int -> t
val of_bytes_all_nocopy : string -> t
val to_bytes_nocopy : t -> string
val copy : t -> t
val copy_len : t -> int -> t
val shift_pair_left : char -> char -> int -> char
val shift_pair_right : char -> char -> int -> char
val shift_left_small : t -> int -> unit
val shift_right_small : t -> int -> unit
val shift_left : t -> int -> unit
val shift_right : t -> int -> unit
val num_bits : t -> int
val num_bytes : t -> int
val rmasks : int array
val blit : src:t -> dst:t -> len:int -> unit
val zero_out : t -> unit
sks-1.1.5/build.mli0000644000175000017500000000035612273431766014705 0ustar  kristianfkristianf(* A functor that builds the main function for an executable that builds up the key
   database from a multi-file database dump.  dump files are taken from the
   command-line *)

module F (M : sig end) : sig
  val run : unit -> unit
end
sks-1.1.5/catchup.mli0000644000175000017500000000017112273431766015230 0ustar  kristianfkristianfval uninterruptable_catchup : unit -> unit
val catchup : unit -> Eventloop.timed_event list
val catchup_interval : float
sks-1.1.5/channel.mli0000644000175000017500000001230712273431766015215 0ustar  kristianfkristianf(***********************************************************************)
(* channel.mli - A generic, object-based channel interface for binary  *)
(*               input/output                                          *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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
*)
sks-1.1.5/clean_keydb.mli0000644000175000017500000000007212273431766016041 0ustar  kristianfkristianfmodule F (M : sig end) : sig
  val run : unit -> unit
end
sks-1.1.5/client.mli0000644000175000017500000000174112273431766015063 0ustar  kristianfkristianfexception Bug of string
type 'a bottomQ_entry
type reconbound
exception Continue
val send_request :
  < outchan : out_channel; write_int : int -> 'a; .. > ->
  'b PrefixTree.tree ->
  bottomQ:(PrefixTree.node * Bitstring.t) bottomQ_entry Queue.t ->
  PrefixTree.node * Bitstring.t -> unit
val handle_reply :
  < outchan : out_channel; write_int : int -> 'a; .. > ->
  'b PrefixTree.tree ->
  requestQ:(PrefixTree.node * Bitstring.t) Queue.t ->
  ReconMessages.msg_container ->
  PrefixTree.node * Bitstring.t -> ZZp.Set.t ref -> unit
val connection_manager :
  < fd : UnixLabels.file_descr; read_int : int;
    read_string : int -> string; .. > ->
  < flush : 'a; outchan : out_channel; write_int : int -> 'b; .. > ->
  'c PrefixTree.tree -> PrefixTree.node * Bitstring.t -> ZZp.Set.t
val handle :
  'a PrefixTree.tree ->
  < fd : UnixLabels.file_descr; read_int : int;
    read_string : int -> string; .. > ->
  < flush : 'b; outchan : out_channel; write_int : int -> 'c; .. > ->
  ZZp.Set.t
sks-1.1.5/cMarshal.mli0000644000175000017500000000473612273431766015346 0ustar  kristianfkristianfval marshal_string :
  < upcast : #Channel.out_channel_obj; write_byte : int -> unit;
    write_char : char -> unit; write_float : float -> unit;
    write_int : int -> unit; write_int32 : int32 -> unit;
    write_int64 : int64 -> unit; write_string : string -> unit;
    write_string_pos : buf:string -> pos:int -> len:int -> unit; .. > ->
  string -> unit
val unmarshal_string : < read_int : 'a; read_string : 'a -> 'b; .. > -> 'b
val marshal_list :
  f:((< write_int : int -> 'b; .. > as 'a) -> 'c -> unit) ->
  'a -> 'c list -> unit
val unmarshal_list :
  f:((< read_int : int; .. > as 'a) -> 'b) -> 'a -> 'b list
val marshal_lstring : < write_string : 'a -> 'b; .. > -> 'a -> 'b
val unmarshal_lstring : 'a -> < read_string : 'a -> 'b; .. > -> 'b
val marshal_array :
  f:((< write_int : int -> 'b; .. > as 'a) -> 'c -> unit) ->
  'a -> 'c array -> unit
val unmarshal_array :
  f:((< read_int : int; .. > as 'a) -> 'b) -> 'a -> 'b array
val marshal_bitstring :
  < upcast : #Channel.out_channel_obj; write_byte : int -> unit;
    write_char : char -> unit; write_float : float -> unit;
    write_int : int -> unit; write_int32 : int32 -> unit;
    write_int64 : int64 -> unit; write_string : string -> unit;
    write_string_pos : buf:string -> pos:int -> len:int -> unit; .. > ->
  Bitstring.t -> unit
val unmarshal_bitstring :
  < read_int : int; read_string : int -> string; .. > -> Bitstring.t
val marshal_fixed_sarray :
  < write_int : int -> 'a; write_string : string -> unit; .. > ->
  string array -> unit
val unmarshal_fixed_sarray :
  < read_int : int; read_string : int -> 'a; .. > -> 'b -> 'a array
val marshal_set :
  f:((< write_int : int -> 'b; .. > as 'a) -> ZZp.zz -> unit) ->
  'a -> ZZp.Set.t -> unit
val unmarshal_set :
  f:((< read_int : int; .. > as 'a) -> ZZp.zz) -> 'a -> ZZp.Set.t
val marshal_sockaddr :
  < upcast : #Channel.out_channel_obj; write_byte : int -> unit;
    write_char : char -> unit; write_float : float -> unit;
    write_int : int -> unit; write_int32 : int32 -> unit;
    write_int64 : int64 -> unit; write_string : string -> unit;
    write_string_pos : buf:string -> pos:int -> len:int -> unit; .. > ->
  Unix.sockaddr -> unit
val unmarshal_sockaddr :
  < read_byte : int; read_int : int; read_string : int -> string; .. > ->
  Unix.sockaddr
val marshal_to_string :
  f:(Channel.buffer_out_channel -> 'a -> 'b) -> 'a -> string
val unmarshal_from_string :
  f:(Channel.string_in_channel -> 'a) -> string -> 'a
val int_to_string : int -> string
val int_of_string : string -> int
sks-1.1.5/common.mli0000644000175000017500000000364112273431766015076 0ustar  kristianfkristianfexception Bug of string
exception Transaction_aborted of string
exception Argument_error of string
exception Unit_test_failure of string
val ( |< ) : ('a, 'b) PMap.Map.t -> 'a -> 'b -> ('a, 'b) PMap.Map.t
val ( |= ) : ('a, 'b) PMap.Map.t -> 'a -> 'b
val ( |! ) : 'a -> ('a -> 'b) -> 'b
val enforced_filters : string list
val version_tuple : int * int * int
val version_suffix : string
val compatible_version_tuple : int * int * int
val version : string
val compatible_version_string : string
val period_regexp : Str.regexp
val parse_version_string : string -> int * int * int
val err_to_string : exn -> string
val logfile : out_channel ref
val stored_logfile_name : string option ref
val plerror : int -> ('a, unit, string, unit) format4 -> 'a
val set_logfile : string -> unit
val reopen_logfile : unit -> unit
val perror : ('a, unit, string, unit) format4 -> 'a
val eplerror : int -> exn -> ('a, unit, string, unit) format4 -> 'a
val eperror : exn -> ('a, unit, string, unit) format4 -> 'a
val catch_break : bool ref
val handle_interrupt : 'a -> unit
val set_catch_break : bool -> unit
val protect : f:(unit -> 'a) -> finally:(unit -> unit) -> 'a
val fprotect : f:(unit -> 'a) -> finally:(unit -> unit) -> unit -> 'a
val filter_opts : 'a option list -> 'a list
val decomment : string -> string
val strip_opt : 'a option list -> 'a list
val apply_opt : f:('a -> 'b) -> 'a option -> 'b option
type event = Add of string | Delete of string
type timestamp = float
val whitespace : Str.regexp
val make_addr_list : string -> int -> Unix.sockaddr list
val recon_port : int
val recon_address : string
val http_port : int
val http_address : string
val db_command_name : string
val recon_command_name : string
val db_command_addr : Unix.sockaddr
val recon_command_addr : Unix.sockaddr
val recon_addr_to_http_addr : Unix.sockaddr -> Unix.sockaddr
val get_client_recon_addr : unit -> Unix.sockaddr list
val match_client_recon_addr : Unix.sockaddr -> Unix.sockaddr
sks-1.1.5/dbMessages.mli0000644000175000017500000000264012273431766015661 0ustar  kristianfkristianftype configvar =
    [ `float of float | `int of int | `none | `string of string ]

type msg =
    WordQuery of string list
  | LogQuery of (int * Common.timestamp)
  | HashRequest of string list
  | LogResp of (Common.timestamp * Common.event) list
  | Keys of Packet.key list
  | KeyStrings of string list
  | Ack of int
  | MissingKeys of (string list * Unix.sockaddr)
  | Synchronize
  | RandomDrop of int
  | ProtocolError
  | DeleteKey of string
  | Config of (string * configvar)
  | Filters of string list

val marshal_msg :
  < upcast : #Channel.out_channel_obj; write_byte : int -> unit;
    write_char : char -> unit; write_float : Common.timestamp -> unit;
    write_int : int -> unit; write_int32 : int32 -> unit;
    write_int64 : int64 -> unit; write_string : string -> unit;
    write_string_pos : buf:string -> pos:int -> len:int -> unit; .. > ->
  msg -> unit
val unmarshal_msg :
  < read_byte : int; read_float : Common.timestamp; read_int : int;
    read_string : int -> string; .. > ->
  msg
val sockaddr_to_string : Unix.sockaddr -> string
val msg_to_string : msg -> string
module M : sig
  type msg_container = { msg : msg; }
end
type msg_container = M.msg_container = { msg : msg; }
val marshal_noflush : < upcast : Channel.out_channel_obj; .. > -> msg -> unit
val marshal :
  < flush : 'a; upcast : Channel.out_channel_obj; .. > -> msg -> 'a
val unmarshal : < upcast : Channel.in_channel_obj; .. > -> msg_container
sks-1.1.5/dbserver.mli0000644000175000017500000000007112273431766015414 0ustar  kristianfkristianfmodule F (M: sig end) : sig
  val run : unit -> unit
end
sks-1.1.5/decode.mli0000644000175000017500000000041612273431766015026 0ustar  kristianfkristianfexception Low_mbar
exception Interpolation_failure
val interpolate :
  values:ZZp.zz array -> points:ZZp.zz array -> d:int -> Poly.t * Poly.t
val factor : Poly.t -> ZZp.Set.t
val reconcile :
  values:ZZp.zz array -> points:ZZp.zz array -> d:int -> ZZp.Set.t * ZZp.Set.t
sks-1.1.5/ehandlers.mli0000644000175000017500000000135512273431766015553 0ustar  kristianfkristianfval repeat_until :
  redo_timeout:float ->
  full_timeout:float ->
  test:(unit -> bool) ->
  init:(unit -> 'a) ->
  request:(unit -> Eventloop.timed_event list) ->
  success:(unit -> Eventloop.timed_event list) ->
  failure:(unit -> Eventloop.timed_event list) -> Eventloop.timed_event list
val float_incr : float -> float
val float_decr : float -> float
val strftime : float -> string
val repeat_forever :
  ?jitter:float ->
  ?start:float -> float -> Eventloop.callback -> Eventloop.timed_event list
val repeat_forever_simple :
  float -> (unit -> 'a) -> Eventloop.timed_event list
val incr_day : float -> float
val set_hour : float -> int -> float
val repeat_at_hour :
  int -> (unit -> Eventloop.timed_event list) -> Eventloop.timed_event list
sks-1.1.5/fixkey.mli0000644000175000017500000000152512273431766015104 0ustar  kristianfkristianfexception Bad_key
exception Standalone_revocation_certificate
val filters : string list
val get_keypacket : KeyMerge.pkey -> Packet.packet
val ( |= ) : ('a, 'b) PMap.Map.t -> 'a -> 'b
val ( |< ) : ('a, 'b) PMap.Map.t -> 'a * 'b -> ('a, 'b) PMap.Map.t
val join_by_keypacket : KeyMerge.pkey list -> KeyMerge.pkey list list
val merge_pkeys : KeyMerge.pkey list -> KeyMerge.pkey
val compute_merge_replacements :
  Packet.packet list list ->
  (Packet.packet list list * Packet.packet list) list
val canonicalize : Packet.packet list -> Packet.packet list
val good_key : Packet.packet -> bool
val good_signature : Packet.packet -> bool
val drop_bad_sigs : Packet.packet list -> Packet.packet list
val sig_filter_sigpair :
  'a * Packet.packet list -> ('a * Packet.packet list) option
val presentation_filter : Packet.packet list -> Packet.packet list option
sks-1.1.5/fqueue.mli0000644000175000017500000000053212273431766015074 0ustar  kristianfkristianfexception Empty
type 'a t = { inlist : 'a list; outlist : 'a list; length : int; }
val empty : 'a t
val push : 'a -> 'a t -> 'a t
val enq : 'a -> 'a t -> 'a t
val top : 'a t -> 'a
val pop : 'a t -> 'a * 'a t
val discard : 'a t -> 'a t
val deq : 'a t -> 'a * 'a t
val to_list : 'a t -> 'a list
val length : 'a t -> int
val is_empty : 'a t -> bool
sks-1.1.5/heap.mli0000644000175000017500000000344612273431766014526 0ustar  kristianfkristianf(***********************************************************************)
(* heap.mli - Simple heap implementation, adapted from CLR             *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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
sks-1.1.5/htmlTemplates.mli0000644000175000017500000000071012273431766016423 0ustar  kristianfkristianfval html_quote : string -> string
val page : title:string -> body:string -> string
val link :
  op:string -> hash:bool -> fingerprint:bool -> keyid:string -> string
val keyinfo_header : string
val keyinfo_pks :
  Packet.pubkeyinfo ->
  bool -> keyid:string -> link:string -> userids:string list -> string
val fingerprint : fp:string -> string
val hash_link : hash:string -> string
val hash : hash:string -> string
val preformat_list : string list -> stringsks-1.1.5/index.mli0000644000175000017500000000430012273431766014706 0ustar  kristianfkristianftype siginfo
val empty_siginfo : unit -> siginfo
val keyinfo_header : Request.request -> string
val sig_to_siginfo : Packet.packet -> siginfo
val sort_siginfo_list : siginfo list -> siginfo list
val is_selfsig : keyid:string -> siginfo -> bool
val is_primary : keyid:string -> Packet.packet * siginfo list -> bool
val max_selfsig_time : keyid:string -> 'a * siginfo list -> float
val split_list : f:('a -> bool) -> 'a list -> 'a list * 'a list
val move_primary_to_front :
  keyid:string ->
  (Packet.packet * siginfo list) list -> (Packet.packet * siginfo list) list
val convert_sigpair : 'a * Packet.packet list -> 'a * siginfo list
val blank_datestr : string
val no_datestr : string
val datestr_of_int64 : int64 -> string
val siginfo_to_lines :
  get_uid:(string -> string option) ->
  ?key_creation_time:int64 ->
  Request.request -> string -> float -> siginfo -> string list
val selfsigs_to_lines :
  Request.request ->
  int64 -> string -> Packet.packet list -> float -> string list
val uid_to_lines :
  get_uid:(string -> string option) ->
  Request.request ->
  int64 -> string -> float -> Packet.packet * siginfo list -> string list
val uids_to_lines :
  get_uid:(string -> string option) ->
  Request.request ->
  int64 ->
  string -> (Packet.packet * siginfo list) list -> float -> string list
val key_packet_to_line :
  is_subkey:bool -> Packet.pubkeyinfo -> string -> string * string
val subkey_to_lines :
  Request.request -> float -> Packet.packet * siginfo list -> string list
val subkeys_to_lines :
  Request.request ->
  (Packet.packet * siginfo list) list -> float -> string list
val extract : f:('a -> bool) -> 'a list -> 'a option * 'a list
val move_to_front : f:('a -> bool) -> 'a list -> 'a list
val get_uid :
  (string -> (Packet.packet * Packet.packet list) list) ->
  string -> string option
val get_extra_lines :
  Request.request -> 'a -> string -> Fingerprint.result -> string list
val key_to_lines_verbose :
  get_uids:(string -> (Packet.packet * Packet.packet list) list) ->
  Request.request -> Packet.packet list -> string -> string list
val sig_is_revok : siginfo -> bool
val is_revoked : Packet.packet list -> bool
val key_to_lines_normal :
  Request.request -> Packet.packet list -> string -> string list
sks-1.1.5/keyHash.mli0000644000175000017500000000017512273431766015201 0ustar  kristianfkristianfval hash_bytes : int
val hash : Packet.packet list -> Digest.t
val hexify : string -> string
val dehexify : string -> string
sks-1.1.5/key.mli0000644000175000017500000000272512273431766014400 0ustar  kristianfkristianfexception Bug of string
val pos_next_rec :
  ('a * Packet.packet) SStream.sstream ->
  Packet.packet list -> Packet.packet list option
val pos_next :
  ('a * Packet.packet) SStream.sstream -> ('a * Packet.packet list) option
val pos_get : ('a * Packet.packet) SStream.sstream -> 'a * Packet.packet list
val pos_next_of_channel :
  < inchan : in_channel; read_byte : int; read_string : int -> string; .. > ->
  unit -> (int64 * Packet.packet list) option
val pos_get_of_channel :
  < inchan : in_channel; read_byte : int; read_string : int -> string; .. > ->
  unit -> int64 * Packet.packet list
val next_rec :
  Packet.packet SStream.sstream ->
  Packet.packet list -> Packet.packet list option
val next : Packet.packet SStream.sstream -> Packet.packet list option
val get : Packet.packet SStream.sstream -> Packet.packet list
val next_of_channel :
  < read_byte : int; read_string : int -> string; .. > ->
  unit -> Packet.packet list option
val get_of_channel :
  < read_byte : int; read_string : int -> string; .. > ->
  unit -> Packet.packet list
val get_ids : Packet.packet list -> string list
val write :
  Packet.packet list ->
  < write_byte : int -> 'a; write_int : int -> 'b;
    write_string : string -> unit; .. > ->
  unit
val to_string : Packet.packet list -> string
val of_string : string -> Packet.packet list
val of_string_multiple : string -> Packet.packet list list
val to_string_multiple : Packet.packet list list -> string
val to_words : Packet.packet list -> string list
sks-1.1.5/linearAlg.mli0000644000175000017500000000402412273431766015500 0ustar  kristianfkristianfexception Bug of string
exception LayoutMismatch
val riter : f:(int -> 'a) -> int -> int -> unit
val rfind : f:(int -> bool) -> int -> int -> int
module MatrixSlow :
  sig
    type t = { columns : int; rows : int; array : ZZp.zz array; }
    val columns : t -> int
    val rows : t -> int
    val dims : t -> int * int
    val copy : t -> t
    val make : columns:int -> rows:int -> ZZp.zz -> t
    val init : columns:int -> rows:int -> f:(int -> int -> ZZp.zz) -> t
    val get : t -> int -> int -> ZZp.zz
    val set : t -> int -> int -> ZZp.zz -> unit
    val scmult_ip : t -> ZZp.zz -> unit
    val scmult : t -> ZZp.zz -> t
    val scmult_row : t -> int -> ZZp.zz -> unit
    val swap_rows : t -> int -> int -> unit
    val add_ip : t -> t -> unit
    val add : t -> t -> t
    val idot_rec :
      t -> t -> i:int -> pos1:int -> pos2:int -> ZZp.zz -> ZZp.zz
    val idot : t -> t -> int -> int -> ZZp.zz
    val mult : t -> t -> t
    val transpose : t -> t
    val rowadd : t -> src:int -> dst:int -> scmult:ZZp.zz -> unit
    val rowsub : t -> src:int -> dst:int -> scmult:ZZp.zz -> unit
    val print : t -> unit
  end
module Matrix :
  sig
    type t = { columns : int; rows : int; array : ZZp.zzref array; }
    val columns : t -> int
    val rows : t -> int
    val dims : t -> int * int
    val copy : t -> t
    val init : columns:int -> rows:int -> f:(int -> int -> ZZp.zz) -> t
    val make : columns:int -> rows:int -> ZZp.zz -> t
    val lget : t -> int -> int -> ZZp.zz
    val rget : t -> int -> int -> ZZp.zzref
    val get : t -> int -> int -> ZZp.zz
    val set : t -> int -> int -> ZZp.zz -> unit
    val scmult_row : ?scol:int -> t -> int -> ZZp.zz -> unit
    val swap_rows : t -> int -> int -> unit
    val transpose : t -> t
    val rowsub :
      ?scol:int -> t -> src:int -> dst:int -> scmult:ZZp.zz -> unit
    val print : t -> unit
  end
val process_row : Matrix.t -> int -> unit
val process_row_forward : Matrix.t -> int -> unit
val backsubstitute : Matrix.t -> int -> unit
val greduce : Matrix.t -> unit
val reduce : Matrix.t -> unit
sks-1.1.5/mArray.mli0000644000175000017500000000414712273431766015043 0ustar  kristianfkristianf(***********************************************************************)
(* mArray.mli - Various array operations                               *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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
sks-1.1.5/membership.mli0000644000175000017500000000466412273431766015747 0ustar  kristianfkristianf(***********************************************************************)
(* membership.mli - Module for tracking gossip membership and mailsync *)
(*                  peers                                              *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

(** 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 -> UnixLabels.addr_info list

(** Returns true iff the address in question belongs to one of the  *)
(** hosts on the gossip membership list.                            *)
val test : UnixLabels.sockaddr -> bool

(** Returns the list of email addresses for use in PKS-style key    *)
(** distribution                                                    *)
val get_mailsync_partners : unit -> string list
sks-1.1.5/mList.mli0000644000175000017500000000622512273431766014677 0ustar  kristianfkristianf(***********************************************************************)
(* mList.mli - Various list operations                                 *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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
sks-1.1.5/mTimer.mli0000644000175000017500000000327212273431766015043 0ustar  kristianfkristianf(***********************************************************************)
(* mTimer.mli - Simple timer module                                    *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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
sks-1.1.5/nbMsgContainer.mli0000644000175000017500000000162312273431766016515 0ustar  kristianfkristianfmodule 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) ->
    sig
      val bufc : Channel.buffer_out_channel
      type msg_container = { msg : Msg.msg_t; }
      val marshal_noflush :
        < outchan : out_channel; write_int : int -> 'a; .. > ->
        Msg.msg_t -> unit
      val marshal :
        < flush : 'a; outchan : out_channel; write_int : int -> 'b; .. > ->
        Msg.msg_t -> 'a
      val last_length : int option ref
      val try_unmarshal :
        < fd : Unix.file_descr; read_int : int; read_string : int -> string;
          .. > ->
        msg_container option
      val unmarshal :
        < read_int : int; read_string : int -> string; .. > -> msg_container
    end
sks-1.1.5/number.mli0000644000175000017500000000505212273431766015074 0ustar  kristianfkristianf(***********************************************************************)
(* number.mli - Basic operations and definitions for multi-precision   *)
(*              integers                                               *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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 -> 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
sks-1.1.5/packet.mli0000644000175000017500000000521212273431766015051 0ustar  kristianfkristianftype 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; }
val ssp_type_to_string : int -> string
type key = packet list
val sigtype_to_string : int -> string
val content_tag_to_ptype : int -> ptype
val ptype_to_string : ptype -> string
type mpi = { mpi_bits : int; mpi_data : string; }
val pubkey_algorithm_string : int -> string
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
val int_to_sigtype : int -> sigtype
val content_tag_to_string : int -> string
val print_packet : packet -> unit
val write_packet_new :
  packet ->
  < write_byte : int -> 'a; write_int : int -> 'b;
    write_string : string -> 'c; .. > ->
  'c
val pk_alg_to_ident : int -> string
val write_packet_old :
  packet ->
  < write_byte : int -> 'a; write_int : int -> 'b;
    write_string : string -> 'c; .. > ->
  'c
val write_packet :
  packet ->
  < write_byte : int -> 'a; write_int : int -> 'b;
    write_string : string -> 'c; .. > ->
  'c
sks-1.1.5/parsePGP.mli0000644000175000017500000000257312273431766015272 0ustar  kristianfkristianfexception Overlong_mpi
exception Partial_body_length of int
val parse_new_packet_length : < read_byte : int; .. > -> int
val read_packet :
  < read_byte : int; read_string : int -> string; .. > -> Packet.packet
val offset_read_packet :
  < inchan : in_channel; read_byte : int; read_string : int -> string; .. > ->
  int64 * Packet.packet
val offset_length_read_packet :
  < inchan : in_channel; read_byte : int; read_string : int -> string; .. > ->
  Packet.packet * int * int
val read_mpi :
  < read_byte : int; read_string : int -> string; .. > -> Packet.mpi
val read_mpis :
  < read_byte : int; read_string : int -> string; .. > -> Packet.mpi list
val parse_pubkey_info : Packet.packet -> Packet.pubkeyinfo
val parse_sigsubpacket_length : < read_byte : int; .. > -> int
val read_sigsubpacket :
  < read_byte : int; read_string : int -> string; .. > -> Packet.sigsubpacket
val get_hashed_subpacket_string :
  < read_byte : int; read_int_size : int -> 'a; read_string : 'a -> 'b; .. > ->
  'b
val read_subpackets :
  < read_string : 'a -> string; .. > -> 'a -> Packet.sigsubpacket list
val parse_signature : Packet.packet -> Packet.signature
val ssp_ctime_id : int
val ssp_exptime_id : int
val int32_of_string : string -> int32
val int64_of_string : string -> int64
val get_times : Packet.signature -> int64 option * int64 option
val get_key_exptimes : Packet.signature -> int64 option * int64 option
sks-1.1.5/pMap.mli0000644000175000017500000001273512273431766014507 0ustar  kristianfkristianf(***********************************************************************)
(* pMap.mli - 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.                                  *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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
sks-1.1.5/poly.mli0000644000175000017500000000201712273431766014565 0ustar  kristianfkristianfval rfind : f:(int -> bool) -> int -> int -> int
type t = { a : ZZp.zz array; degree : int; }
val compute_degree : ZZp.zz array -> int
val init : int -> f:(int -> ZZp.zz) -> t
val make : int -> ZZp.zz -> t
val zero : t
val one : t
val degree : t -> int
val length : t -> int
val copy : t -> t
val to_string : t -> string
val splitter : Str.regexp
val parse_digit : string -> int * ZZp.zz
val map_keys : ('a, 'b) PMap.Map.t -> 'a list
val of_string : string -> t
val print : t -> unit
exception NotEqual
val eq : t -> t -> bool
val of_array : ZZp.zz array -> t
val term : int -> ZZp.zz -> t
val set_length : int -> t -> t
val to_array : t -> ZZp.zz array
val is_monic : t -> bool
val eval : t -> ZZp.zz -> ZZp.zz
val mult : t -> t -> t
val scmult : t -> ZZp.zz -> t
val add : t -> t -> t
val neg : t -> t
val sub : t -> t -> t
val divmod : t -> t -> t * t
val modulo : t -> t -> t
val div : t -> t -> t
val const_coeff : t -> ZZp.zz
val nth_coeff : t -> int -> ZZp.zz
val const : ZZp.zz -> t
val gcd_rec : t -> t -> t
val gcd : t -> t -> t
sks-1.1.5/prefixTree.mli0000644000175000017500000000210412273431766015714 0ustar  kristianfkristianftype 'a tree
type node
type 'a db
type 'a disk

val create :
  ?db:(string -> string) * ('a option -> key:string -> data:string -> unit) *
      ('a option -> string -> unit) *
      ((unit -> 'a option) * ('a option -> unit) * ('a option -> unit)) *
      int ->
  txn:'a option ->
  num_samples:int -> bitquantum:int -> thresh:int -> unit -> 'a tree
val child_keys : 'a tree -> Bitstring.t -> Bitstring.t list
val get_zzp_elements : 'a tree -> node -> ZZp.Set.t
val clean : 'a option -> 'a tree -> unit
val points : 'a tree -> ZZp.zz array
val get_node_key : ?sef:bool -> 'a tree -> Bitstring.t -> node
val svalues : node -> ZZp.mut_array
val size : node -> int
val is_leaf : node -> bool
val num_elements : 'a -> node -> int
val elements : 'a tree -> node -> ZZp.Set.t
val root : 'a tree -> node
val get_random : 'a tree -> node -> string

val set_synctime : 'a tree -> float -> unit
val get_synctime : 'a tree -> float

val insert_str : 'a tree -> 'a option -> string -> unit
val delete_str : 'a tree -> 'a option -> string -> unit

val set_maxnodes : 'a tree -> 'a option -> int -> unit
sks-1.1.5/prime.mli0000644000175000017500000000026312273431766014717 0ustar  kristianfkristianftype result
val randbits : (unit -> int) -> int -> Number.z
val randint : (unit -> int) -> Number.z -> Number.z
val randprime : (unit -> int) -> bits:int -> error:int -> Number.z
sks-1.1.5/pSet.mli0000644000175000017500000001475612273431766014532 0ustar  kristianfkristianf(***********************************************************************)
(* pSet.mli - 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.                                                *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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
sks-1.1.5/pstyle.mli0000644000175000017500000000022512273431766015121 0ustar  kristianfkristianfval range : ?stride:int -> ?start:int -> int -> int list
val (  ) : string -> int * int -> string
val ( <|> ) : 'a array -> int * int -> 'a array
sks-1.1.5/recode.mli0000644000175000017500000000017412273431766015045 0ustar  kristianfkristianfval limit : int
val cin : Channel.sys_in_channel
val cout : Channel.sys_out_channel
val getkey : unit -> Packet.packet list
sks-1.1.5/reconComm.mli0000644000175000017500000000033212273431766015522 0ustar  kristianfkristianfval send_dbmsg : DbMessages.msg -> DbMessages.msg
val send_dbmsg_noreply : DbMessages.msg -> unit
val fetch_filters : unit -> string list
val get_keystrings_via_http : UnixLabels.sockaddr -> string list -> string list
sks-1.1.5/reconCS.mli0000644000175000017500000000131512273431766015136 0ustar  kristianfkristianfval connect :
  'a PrefixTree.tree ->
  filters:string list ->
  partner:UnixLabels.addr_info -> ZZp.Set.t * UnixLabels.sockaddr
val handle_connection :
  'a PrefixTree.tree ->
  filters:string list ->
  partner:UnixLabels.sockaddr ->
  < fd : UnixLabels.file_descr; read_int : int;
    read_string : int -> string; .. > ->
  < flush : 'b; outchan : out_channel; upcast : #Channel.out_channel_obj;
    write_byte : int -> unit; write_char : char -> unit;
    write_float : float -> unit; write_int : int -> unit;
    write_int32 : int32 -> unit; write_int64 : int64 -> unit;
    write_string : string -> unit;
    write_string_pos : buf:string -> pos:int -> len:int -> unit; .. > ->
  ZZp.Set.t * UnixLabels.sockaddr
sks-1.1.5/reconMessages.mli0000644000175000017500000000210412273431766016375 0ustar  kristianfkristianftype recon_rqst_poly = {
  rp_prefix : Bitstring.t;
  rp_size : int;
  rp_samples : ZZp.mut_array;
}

type recon_rqst_full = { rf_prefix : Bitstring.t; rf_elements : ZZp.Set.t; }

type configdata = (string, string) PMap.Map.t

type msg =
  | ReconRqst_Poly of recon_rqst_poly
  | ReconRqst_Full of recon_rqst_full
  | Elements of ZZp.Set.t
  | FullElements of ZZp.Set.t
  | SyncFail
  | Done
  | Flush
  | Error of string
  | DbRqst of string
  | DbRepl of string
  | Config of configdata

val msg_to_string : msg -> string

module M : sig
  type msg_container = { msg : msg; }
end
type msg_container = M.msg_container = { msg : msg; }
val marshal_noflush :
  < outchan : out_channel; write_int : int -> 'a; .. > -> msg -> unit
val marshal :
  < flush : 'a; outchan : out_channel; write_int : int -> 'b; .. > ->
  msg -> 'a
val try_unmarshal :
  < fd : UnixLabels.file_descr; read_int : int;
    read_string : int -> string; .. > ->
  msg_container option
val unmarshal :
  < read_int : int; read_string : int -> string; .. > -> msg_container
val sockaddr_to_string : Unix.sockaddr -> string
sks-1.1.5/reconPTreeDb.mli0000644000175000017500000000244412273431766016122 0ustar  kristianfkristianfmodule PTree :
  sig
    type 'a tree = 'a PrefixTree.tree
    type node = PrefixTree.node
    type 'a db = 'a PrefixTree.db
    type 'a disk = 'a PrefixTree.disk
    val create :
      ?db:(string -> string) *
          ('a option -> key:string -> data:string -> unit) *
          ('a option -> string -> unit) *
          ((unit -> 'a option) * ('a option -> unit) * ('a option -> unit)) *
          int ->
      txn:'a option ->
      num_samples:int -> bitquantum:int -> thresh:int -> unit -> 'a tree
    val child_keys : 'a tree -> Bitstring.t -> Bitstring.t list
    val get_zzp_elements : 'a tree -> node -> ZZp.Set.t
    val clean : 'a option -> 'a tree -> unit
    val points : 'a tree -> ZZp.zz array
    val get_node_key : ?sef:bool -> 'a tree -> Bitstring.t -> node
    val svalues : node -> ZZp.mut_array
    val size : node -> int
    val is_leaf : node -> bool
    val num_elements : 'a -> node -> int
    val elements : 'a tree -> node -> ZZp.Set.t
    val root : 'a tree -> node
    val get_random : 'a tree -> node -> string
    val set_synctime : 'a tree -> float -> unit
    val get_synctime : 'a tree -> float
    val insert_str : 'a tree -> 'a option -> string -> unit
    val delete_str : 'a tree -> 'a option -> string -> unit
    val set_maxnodes : 'a tree -> 'a option -> int -> unit
  end
sks-1.1.5/reconserver.mli0000644000175000017500000000225612273431766016144 0ustar  kristianfkristianfmodule F :
  functor (M : sig  end) ->
    sig
      val settings : PTreeDB.ptree_settings
      val reconsocks : Eventloop.Unix.file_descr list
      val comsock : Eventloop.Unix.file_descr
      val filters : string list option ref
      val get_filters : unit -> string list
      val eventify_handler :
        ('a -> Channel.sys_in_channel -> Channel.sys_out_channel -> 'b) ->
        'a -> in_channel -> out_channel -> 'b
      val choose_partner : unit -> PTreeDB.Unix.addr_info
      val missing_keys_timeout : int
      val get_missing_keys : unit -> Eventloop.timed_event list
      val sockaddr_to_name : PTreeDB.Unix.sockaddr -> string
      val recon_handler :
        UnixLabels.sockaddr ->
        in_channel -> out_channel -> Eventloop.timed_event list
      val initiate_recon : unit -> Eventloop.timed_event list
      val command_handler :
        'a ->
        < upcast : Channel.in_channel_obj; .. > ->
        < flush : 'b; upcast : Channel.out_channel_obj; .. > ->
        Eventloop.timed_event list
      val sync_interval : float
      val sync_tree : unit -> unit
      val checkpoint_interval : float
      val prepare : unit -> unit
      val run : unit -> unit
    end
sks-1.1.5/recoverList.mli0000644000175000017500000000107312273431766016104 0ustar  kristianfkristianftype recover_element = string list * UnixLabels.sockaddr
val hash_bundle_size : int
val recover_list : recover_element Queue.t
val gossip_disabled_var : bool ref
val gossip_disabled : unit -> bool
val disable_gossip : unit -> unit
val enable_gossip : unit -> unit
val n_split : 'a list -> int -> 'a list * 'a list
val size_split : 'a list -> int -> 'a list list
val print_hashes : string -> string list -> unit
val hashconvert : ZZp.zz list -> string list
val log_diffs : string -> string list -> unit
val update_recover_list : ZZp.zz list -> UnixLabels.sockaddr -> unit
sks-1.1.5/recvmail.mli0000644000175000017500000000047412273431766015411 0ustar  kristianfkristianfval whitespace : Str.regexp
val eol : Str.regexp
val parse_header_line : string -> (string * string) option
val parse_header :
  string list ->
  (string * string) list -> (string * string) list * string list
val simplify_headers : (string * string) list -> (string * string) list
val parse : string -> Sendmail.msg
sks-1.1.5/request.mli0000644000175000017500000000073512273431766015277 0ustar  kristianfkristianfval amp : Str.regexp
val chsplit : char -> string -> string * string
val eqsplit : string -> string * string
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;
}
val default_request : request
val comma_rxp : Str.regexp
val request_of_oplist : ?request:request -> (string * string) list -> request
sks-1.1.5/rMisc.mli0000644000175000017500000000225112273431766014657 0ustar  kristianfkristianfval det_rng : Random.State.t
val stringset_to_string : string PSet.Set.t -> string
val digest_stringset : string PSet.Set.t -> Digest.t
val print_lengths : string list -> unit
val fill_random_string :
  (unit -> int) -> string -> pos:int -> len:int -> unit
val random_string : (unit -> int) -> int -> string
val conv_chans :
  in_channel * out_channel ->
  MeteredChannel.metered_in_channel * MeteredChannel.metered_out_channel
val add_random : (unit -> int) -> int -> string PSet.Set.t -> string PSet.Set.t
val add_n_random :
  (unit -> int) -> int -> n:int -> string PSet.Set.t -> string PSet.Set.t
val det_string_set : bytes:int -> size:int -> string PSet.Set.t
val rand_string_set : bytes:int -> size:int -> string PSet.Set.t
val localize_string_set :
  bytes:int -> diff:int -> string PSet.Set.t -> string PSet.Set.t
val add_sarray : data:'a PSet.Set.t -> 'a array -> 'a PSet.Set.t
val pad : string -> int -> string
val padset : string PSet.Set.t -> int -> string PSet.Set.t
val truncate : string -> int -> string
val truncset : string PSet.Set.t -> int -> string PSet.Set.t
val order_string : string
val print_ZZp_list : ZZp.zz list -> unit
val print_ZZp_set : ZZp.zz PSet.Set.t -> unit
sks-1.1.5/server.mli0000644000175000017500000000126112273431766015110 0ustar  kristianfkristianfexception Bug of string
val solving : float ref
val lookup : float ref
val flushtime : float ref
val unmarsh_time : float ref
val solve :
  remote_size:int ->
  local_size:int ->
  remote_samples:ZZp.mut_array ->
  local_samples:ZZp.mut_array ->
  points:ZZp.zz array -> (ZZp.Set.t * ZZp.Set.t) option
val handle_one :
  'a PrefixTree.tree ->
  < read_int : int; read_string : int -> string; .. > ->
  < flush : 'b; outchan : out_channel; write_int : int -> 'c; .. > ->
  bool * ZZp.Set.t
val recover_timeout : int
val handle :
  'a PrefixTree.tree ->
  < read_int : int; read_string : int -> string; .. > ->
  < flush : 'b; outchan : out_channel; write_int : int -> 'c; .. > -> ZZp.Set.t
sks-1.1.5/settings.mli0000644000175000017500000001017312273431766015444 0ustar  kristianfkristianfval n : int ref
val set_n : int -> unit
val debug : bool ref
val set_debug : bool -> unit
val debuglevel : int ref
val set_debuglevel : int -> unit
val mbar : int ref
val set_mbar : int -> unit
val bitquantum : int ref
val set_bitquantum : int -> unit
val drop : int ref
val set_drop : int -> unit
val bytes : int ref
val set_bytes : int -> unit
val max_recover : int ref
val set_max_recover : int -> unit
val seed : int ref
val self_seed : bool ref
val set_seed : int -> unit
val recon_port : int ref
val recon_address : string ref
val set_recon_address : string -> unit
val hkp_port : int ref
val hkp_address : string ref
val set_hkp_address : string -> unit
val use_port_80 : bool ref
val set_base_port : int -> unit
val set_recon_port : int -> unit
val set_hkp_port : int -> unit
val setup_RNG : unit -> unit
val max_internal_matches : int ref
val set_max_internal_matches : int -> unit
val max_matches : int ref
val set_max_matches : int -> unit
val max_outstanding_recon_requests : int ref
val set_max_outstanding_recon_requests : int -> unit
val max_uid_fetches : int ref
val set_max_uid_fetches : int -> unit
val dump_new : bool ref
val disk_ptree : bool ref
val max_ptree_nodes : int ref
val set_max_ptree_nodes : int -> unit
val http_fetch_size : int ref
val set_http_fetch_size : int -> unit
val prob : float ref
val set_prob : float -> unit
val db_sync_interval : float ref
val set_db_sync_interval : float -> unit
val recon_sync_interval : float ref
val set_recon_sync_interval : float -> unit
val gossip_interval : float ref
val set_gossip_interval : float -> unit
val gossip : bool ref
val anonlist : string list ref
val cache_bytes : int option ref
val set_cache_bytes : int -> unit
val pagesize : int option ref
val set_pagesize : int -> unit
val keyid_pagesize : int option ref
val set_keyid_pagesize : int -> unit
val meta_pagesize : int option ref
val set_meta_pagesize : int -> unit
val subkeyid_pagesize : int option ref
val set_subkeyid_pagesize : int -> unit
val time_pagesize : int option ref
val set_time_pagesize : int -> unit
val tqueue_pagesize : int option ref
val set_tqueue_pagesize : int -> unit
val word_pagesize : int option ref
val set_word_pagesize : int -> unit
val ptree_cache_bytes : int option ref
val set_ptree_cache_bytes : int -> unit
val ptree_pagesize : int option ref
val set_ptree_pagesize : int -> unit
val hostname : string ref
val nodename : string ref
val server_contact : string ref
val set_hostname : string -> unit
val filelog : bool ref
val transactions : bool ref
val checkpoint_interval : float ref
val set_checkpoint_interval : float -> unit
val recon_checkpoint_interval : float ref
val set_recon_checkpoint_interval : float -> unit
val ptree_thresh_mult : int ref
val set_ptree_thresh_mult : int -> unit
val recon_thresh_mult : int ref
val set_recon_thresh_mult : int -> unit
val wserver_timeout : int ref
val set_wserver_timeout : int -> unit
val reconciliation_config_timeout : int ref
val set_reconciliation_config_timeout : int -> unit
val reconciliation_timeout : int ref
val set_reconciliation_timeout : int -> unit
val initial_stat : bool ref
val stat_calc_hour : int ref
val set_stat_calc_hour : int -> unit
val missing_keys_timeout : int ref
val set_missing_keys_timeout : int -> unit
val command_timeout : int ref
val set_command_timeout : int -> unit
val sendmail_cmd : string ref
val set_sendmail_cmd : string -> unit
val membership_reload_time : float ref
val set_membership_reload_time : float -> unit
val send_mailsyncs : bool ref
val log_diffs : bool ref
val from_addr : string option ref
val set_from_addr : string -> unit
val get_from_addr : unit -> string
val use_stdin : bool ref
val basedir : string ref
val base_dbdir : string
val base_ptree_dbdir : string
val base_membership_file : string
val base_mailsync_file : string
val base_dumpdir : string
val base_msgdir : string
val base_failed_msgdir : string
val dbdir : string lazy_t
val ptree_dbdir : string lazy_t
val membership_file : string lazy_t
val mailsync_file : string lazy_t
val dumpdir : string lazy_t
val msgdir : string lazy_t
val failed_msgdir : string lazy_t
val parse_spec : (Arg.key * Arg.spec * Arg.doc) list
val anon_options : string -> unit
val usage_string : string
sks-1.1.5/sks.mli0000644000175000017500000000004312273431766014377 0ustar  kristianfkristianf(* This is the base sks command *)
sks-1.1.5/sStream.mli0000644000175000017500000000035112273431766015217 0ustar  kristianfkristianftype 'a sstream = { mutable first : 'a option; next : unit -> 'a option; }
val make : ?first:'a -> (unit -> 'a option) -> 'a sstream
val next : 'a sstream -> 'a option
val peek : 'a sstream -> 'a option
val junk : 'a sstream -> unit
sks-1.1.5/stats.mli0000644000175000017500000000137512273431766014746 0ustar  kristianfkristianfval last : 'a list -> 'a
type histogram_entry = {
  upper : float;
  lower : float;
  mutable num_adds : int;
  mutable num_dels : int;
}
external get_tzname : unit -> string * string = "caml_get_tzname"
val time_to_tz_string : float -> string
val time_to_string : float -> string
val time_to_date : float -> string
val time_to_hour : float -> string
val round_up_to_day : float -> float
val round_up_to_hour : float -> float
val histogram_log :
  now:float -> float -> (float * Common.event) array -> histogram_entry array
val histogram_to_table : (float -> string) -> histogram_entry array -> string
val info_tables : unit -> string
val generate_html_stats_page : (float * Common.event) list -> int -> string
val generate_html_stats_page_nostats : unit -> string
sks-1.1.5/Unique_time.mli0000644000175000017500000000473012273431766016072 0ustar  kristianfkristianf(***********************************************************************)
(* Unique_time.mli - Module to return unique time                      *)
(*                 @author Yaron M. Minsky                             *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

(* An interface to Unix.gettimeofday() which enforces that time always goes
 * up and never repeats.
 * get() returns seconds & microseconds, so minimum meaningful
 * increment is 1 microsecond; OCaml uses IEEE 754 double-precision floats,
 * which gives 53 bits of mantissa.  Assuming 32 bits for time until 32-bit
 * time_t overflows, we can knock bits off 21 bits depending upon when we want
 * the overflow/rollover to occur, and whatever's left is available for delta
 * even at the end of the lifetime of the code; as that fateful day approaches,
 * lower the granularity of this delay accordly
 * we don't use epsilon_float, as that's only guaranteed to give a different
 * result when added to 1.0, not for other numbers.
 * If wallclock time goes backwards, we won't, but time will appear to go
 * forward very very slowly until wallclock catches back up
 *)

val get : 'a -> float
sks-1.1.5/update_subkeys.mli0000644000175000017500000001473712273431766016645 0ustar  kristianfkristianfval settings : Keydb.dbsettings
module Keydb :
  sig
    type txn = Bdb.txn
    val word_db_name : string
    val key_db_name : string
    val keyid_db_name : string
    val subkey_keyid_db_name : string
    val time_db_name : string
    val tqueue_db_name : string
    val meta_db_name : string
    val max_internal_matches : int
    type action = Keydb.Unsafe.action = DeleteKey | AddKey
    type 'a offset = 'a Keydb.Unsafe.offset = { fnum : int; pos : 'a; }
    type skey =
      Keydb.Unsafe.skey =
        KeyString of string
      | Key of Packet.packet list
      | Offset of int offset
      | LargeOffset of int64 offset
    type dbdump =
      Keydb.Unsafe.dbdump = {
      directory : string;
      filearray : in_channel array;
    }
    type dbstate =
      Keydb.Unsafe.dbstate = {
      settings : Keydb.dbsettings;
      dbenv : Bdb.Dbenv.t;
      key : Bdb.Db.t;
      word : Bdb.Db.t;
      keyid : Bdb.Db.t;
      subkey_keyid : Bdb.Db.t;
      time : Bdb.Db.t;
      tqueue : Bdb.Db.t;
      meta : Bdb.Db.t;
      dump : dbdump;
    }
    val dbstate : dbstate option ref
    exception No_db
    val get_dbs : unit -> dbstate
    val get_dump_filearray : unit -> in_channel array
    val marshal_offset : < write_int : int -> 'a; .. > -> int offset -> 'a
    val unmarshal_offset : < read_int : int; .. > -> int offset
    val marshal_large_offset :
      < write_int : int -> 'a; write_int64 : 'b -> 'c; .. > ->
      'b offset -> 'c
    val unmarshal_large_offset :
      < read_int : int; read_int64 : 'a; .. > -> 'a offset
    val skey_of_string : string -> skey
    val skey_to_string : skey -> string
    val skey_is_offset : skey -> bool
    val keystring_of_offset :
      [< `large_offset of 'a offset & int64 offset
       | `offset of 'a offset & int offset ] ->
      string
    val keystring_of_skey : skey -> string
    val keystring_of_string : string -> string
    val key_of_skey : skey -> Packet.packet list
    val key_to_string : Packet.packet list -> string
    val key_of_string : string -> Packet.packet list
    val read_dir_suff : string -> string -> string list
    val open_dbs : Keydb.dbsettings -> unit
    val close_dump : dbstate -> unit
    val close_dbs : unit -> unit
    val sync : unit -> unit
    val txn_begin : ?parent:Bdb.Txn.t -> unit -> Bdb.Txn.t option
    val txn_commit : Bdb.Txn.t option -> unit
    val txn_abort : Bdb.Txn.t option -> unit
    val checkpoint : unit -> unit
    val unconditional_checkpoint : unit -> unit
    val float_to_string : float -> string
    val float_of_string : string -> float
    val event_to_string : Common.event -> string
    val event_of_string : string -> Common.event
    val flatten_array_of_lists : 'a list array -> 'a array
    val jcursor_get_all : max:int -> Bdb.Cursor.t -> string list
    val get_by_words : max:int -> string list -> Packet.packet list list
    val get_skeystring_by_hash : string -> string
    val get_keystring_by_hash : string -> string
    val get_by_hash : string -> Packet.packet list
    val has_hash : string -> bool
    val check_word_hash_pair : word:string -> hash:string -> bool
    val check_keyid_hash_pair : keyid:string -> hash:string -> bool
    val get_keystrings_by_hashes : string list -> string list
    val keyid_iter : f:(keyid:string -> hash:string -> 'a) -> unit
    val raw_iter : f:(hash:string -> keystr:string -> 'a) -> unit
    val iter : f:(hash:string -> key:Packet.packet list -> 'a) -> unit
    val keyiter : f:(string -> 'a) -> unit
    val get_hashes_by_keyid : Bdb.Db.t -> string -> string list
    val get_skeystrings_by_keyid : Bdb.Db.t -> string -> string list
    val get_by_short_keyid : string -> Packet.packet list list
    val get_by_short_subkeyid : string -> Packet.packet list 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:Bdb.txn option -> Packet.packet list -> unit
    val dequeue_key : txn:Bdb.txn option -> float * Packet.packet list
    type key_metadata =
      Keydb.Unsafe.key_metadata = {
      md_hash : string;
      md_words : string list;
      md_keyid : string;
      md_subkey_keyids : string list;
      md_time : float;
      md_skey : skey;
    }
    val shorten_offset : int64 offset -> skey
    val key_to_metadata_large_offset :
      int64 offset -> Packet.packet list -> key_metadata
    val key_to_metadata_offset :
      int offset -> Packet.packet list -> key_metadata
    val key_to_metadata :
      ?hash:Digest.t -> Packet.packet list -> key_metadata
    val add_mds : key_metadata list -> unit
    val apply_md_updates_txn :
      txn:Bdb.txn option -> (key_metadata * action) array -> unit
    val apply_md_updates : (key_metadata * action) array -> unit
    val add_md_txn : ?txn:Bdb.txn -> key_metadata -> unit
    val add_key_txn :
      ?txn:Bdb.txn -> ?hash:Digest.t -> Packet.packet list -> unit
    val add_key :
      ?parent:Bdb.Txn.t -> ?hash:Digest.t -> Packet.packet list -> unit
    val add_multi_keys : Packet.packet list list -> unit
    val add_keys : Packet.packet list list -> unit
    val key_to_merge_updates :
      Packet.packet list -> (key_metadata * action) list
    val sort_remove :
      (key_metadata * action) list -> (key_metadata * action) list
    val add_keys_merge_txn :
      txn:Bdb.txn option -> Packet.packet list list -> int
    val add_keys_merge : Packet.packet list list -> unit
    val add_key_merge : newkey:bool -> Packet.packet list -> unit
    val delete_key_txn :
      ?txn:Bdb.txn -> ?hash:Digest.t -> Packet.packet list -> unit
    val swap_keys : Packet.packet list -> Packet.packet list -> unit
    val delete_key : ?hash:'a -> Packet.packet list -> unit
    val get_meta : string -> string
    val set_meta_txn :
      txn:Bdb.txn option -> key:string -> data:string -> unit
    val set_meta : key:string -> data:string -> unit
    val replace : Packet.packet list list -> Packet.packet list -> unit
    val get_num_keys : unit -> int
  end
type update = { keyid : string; hash : string; }
val ( |= ) : ('a, 'b) PMap.Map.t -> 'a -> 'b
val ( |< ) : ('a, 'b) PMap.Map.t -> 'a * 'b -> ('a, 'b) PMap.Map.t
val at_once : int
val subkeyids_from_key : Packet.packet list -> string list
val sort_dedup : 'a list -> 'a list
val apply_updates : update list -> unit
val fix_keyids : unit -> unit
val run : unit -> unit
sks-1.1.5/utils.mli0000644000175000017500000000351412273431766014745 0ustar  kristianfkristianfval compose : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b
val iceil : float -> int
val ifloor : float -> int
val bsearch : f:(int -> int) -> low:int -> high:int -> int
val bsearch_val : f:(int -> int * 'a) -> low:int -> high:int -> int * 'a
val is_alnum : char -> bool
val extract_words_rec :
  string -> start:int -> len:int -> string PSet.Set.t -> string PSet.Set.t
val extract_word_set : string -> string PSet.Set.t
val extract_words : string -> string list
val ptest : string -> bool -> unit
val for_loop : int -> int -> 'a -> (int -> 'a -> 'a) -> 'a
val pair_loop : ('a * 'a -> 'b -> 'b) -> 'b -> 'a list -> 'b
val for_all_pairs : ('a -> 'a -> bool) -> 'a list -> bool
val neq_test : 'a * 'a -> bool -> bool
val time : (unit -> 'a) -> float
val random_int : int -> int -> int
val char_width : int
val hexstring : string -> string
val int_from_bstring_rec : string -> pos:int -> len:int -> int -> int
val int_from_bstring : string -> pos:int -> len:int -> int
val bstring_of_int : int -> string
val apply : int -> ('a -> 'a) -> 'a -> 'a
val get_bit : pos:int -> int -> int
val create_rand_bits : unit -> unit -> int
val rbit : unit -> int
val permute : 'a list -> 'a list
exception FinalDouble of exn * exn
exception Final of exn
val try_finally : f:(unit -> 'a) -> finally:(unit -> 'b) -> 'a
val rfold : f:('a -> int -> 'a) -> int -> int -> init:'a -> 'a
val fill_random_string :
  (unit -> int) -> string -> pos:int -> len:int -> unit
val random_string : (unit -> int) -> int -> string
val dedup : 'a list -> 'a list
val unit_memoize : (unit -> 'a) -> unit -> 'a
val memoize : ('a -> 'b) -> 'a -> 'b
val initdbconf : string -> string -> unit
class ['a] memo :
  'a ->
  object
    constraint 'a = 'b -> 'c
    val store : ('b, 'c) MoreLabels.Hashtbl.t
    method apply : 'b -> 'c
    method clear : unit
  end
val filter_map : f:('a -> 'b option) -> 'a list -> 'b list
sks-1.1.5/version.mli0000644000175000017500000000012212273431766015262 0ustar  kristianfkristianf(* This is a sks command for showing version information *)
val run : unit -> unitsks-1.1.5/wserver.mli0000644000175000017500000000267412273431766015310 0ustar  kristianfkristianfexception Page_not_found of string
exception No_results of string
exception Not_implemented of string
exception Bad_request of string
exception Entity_too_large of string
exception Misc_error of string
val ( |= ) : ('a, 'b) PMap.Map.t -> 'a -> 'b
val ( |< ) : ('a, 'b) PMap.Map.t -> 'a * 'b -> ('a, 'b) PMap.Map.t
val hexa_digit : int -> char
val hexa_val : char -> int
val decode : string -> string
val special : char -> bool
val encode : string -> string
val stripchars : char PSet.Set.t
val strip : string -> string
type 'a request =
  | GET of (string * (string, string) PMap.Map.t)
  | POST of (string * (string, string) PMap.Map.t * 'a)
val whitespace : Str.regexp
val eol : Str.regexp
val get_all : in_channel -> string
val get_lines : in_channel -> string list
val max_post_length : int
val parse_post : (string, string) PMap.Map.t -> in_channel -> string
val is_blank : string -> bool
val parse_headers :
  (string, string) PMap.Map.t -> in_channel -> (string, string) PMap.Map.t
val parse_request : in_channel -> string request
val headers_to_string : (string, string) PMap.Map.t -> string
val request_to_string : 'a request -> string
val request_to_string_short : 'a request -> string
val send_result :
  out_channel ->
  ?error_code:int -> ?content_type:string -> ?count:int -> string -> unit
val accept_connection :
  ('a -> string request -> Channel.out_channel_obj -> string * int) ->
  recover_timeout:int -> 'a -> in_channel -> out_channel -> 'b list
sks-1.1.5/zZp.mli0000644000175000017500000001141712273431766014371 0ustar  kristianfkristianf(***********************************************************************)
(* zZp.mli - Field of integers mod p (for a settable prime p)          *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************)

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
sks-1.1.5/crc.c0000644000175000017500000000501112273431766014007 0ustar  kristianfkristianf/***********************************************************************)
(* crc.c                                                               *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************/

#include 
#include 
#include 
#include 
#include 
#include 
#include 
#include 
#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);
}
sks-1.1.5/tz.c0000644000175000017500000000341712273431766013705 0ustar  kristianfkristianf/***********************************************************************)
(* tz.c - Simple timezone calculations                                 *)
(*                                                                     *)
(* Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, *)
(*               2011, 2012, 2013  Yaron Minsky and Contributors       *)
(*                                                                     *)
(* 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 or see .                          *)
(***********************************************************************/

#include 
#include 
#include 
#include 
#include 
#include 
#include 
#include 
#define CRC24_INIT 0xb704ceL

// Simple timezone calculations

sks-1.1.5/cryptokit-1.7-sks-custom_compare.patch0000644000175000017500000000072112273431766022267 0ustar  kristianfkristianfdiff --git a/src/stubs-sha3.c b/src/stubs-sha3.c
index df8ac30..2c48222 100644
--- cryptokit-1.7/src/stubs-sha3.c
+++ cryptokit-1.7/src/stubs-sha3.c
@@ -20,6 +20,11 @@
 #include 
 #include 
 
+// Patch is needed for ocaml < 3.12.1
+#ifndef  custom_compare_ext_default
+#define custom_compare_ext_default NULL
+#endif
+
 #define Context_val(v) (*((struct SHA3Context **) Data_custom_val(v)))
 
 static void caml_sha3_finalize(value ctx)
sks-1.1.5/cryptokit-1.7-sks.patch0000644000175000017500000001024212273431766017250 0ustar  kristianfkristianfdiff -urN cryptokit-1.7-orig/README.sks cryptokit-1.7/README.sks
--- cryptokit-1.7-orig/README.sks	1969-12-31 18:00:00.000000000 -0600
+++ cryptokit-1.7/README.sks	2013-06-19 00:30:29.097877008 -0500
@@ -0,0 +1,15 @@
+5his is the cryptokit-1.7 source with small changes to allow building without
+the OASIS build system, findlib, and their dependencies.
+
+The Makefile from cryptokit-1.3 was copied to cryptokit-1.5/src and patched to
+build the blowfish code.
+
+For 1.7, the Makefile was edited to build keccak and stubs-sha3
+
+Also fixed
+    File "cryptokit.ml", line 1930[*], characters 19-21:
+    Warning 3: deprecated feature: operator (or); you should use (||) instead
+    [*] 1900 in cryptokit-1.5
+Which may cause issues with later Ocaml compilers
+
+The main SKS Makefile was changed to support the build.
diff -urN cryptokit-1.7-orig/src/Makefile cryptokit-1.7/src/Makefile
--- cryptokit-1.7-orig/src/Makefile	1969-12-31 18:00:00.000000000 -0600
+++ cryptokit-1.7/src/Makefile	2013-06-19 00:24:06.276997446 -0500
@@ -0,0 +1,110 @@
+### Configuration section
+
+# Comment next line if the Zlib library is not available
+ZLIB=-DHAVE_ZLIB
+
+# The name of the Zlib library.  Usually -lz.  
+# Leave blank if you don't have Zlib.
+ZLIB_LIB=-lz
+
+# The directory containing the Zlib library (libz.a or libz.so)
+# Leave blank if you don't have Zlib.
+ZLIB_LIBDIR=/usr/lib
+#ZLIB_LIBDIR=/usr/lib64    # for x86-64 Linux
+
+# The directory containing the Zlib header file (zlib.h)
+ZLIB_INCLUDE=/usr/include
+
+# Where to install the library. By default: OCaml's standard library directory.
+INSTALLDIR=`$(OCAMLC) -where`
+
+# Flags for the C compiler.
+CFLAGS=-O -I$(ZLIB_INCLUDE) $(ZLIB)
+
+### End of configuration section
+
+OCAMLRUN=ocamlrun
+OCAMLC=ocamlc -g
+OCAMLOPT=ocamlopt
+OCAMLDEP=ocamldep
+MKLIB=ocamlmklib
+OCAMLDOC=ocamldoc
+
+C_OBJS=\
+  rijndael-alg-fst.o stubs-aes.o \
+  d3des.o stubs-des.o \
+  arcfour.o stubs-arcfour.o \
+  sha1.o stubs-sha1.o \
+  sha256.o stubs-sha256.o \
+  ripemd160.o stubs-ripemd160.o \
+  blowfish.o stubs-blowfish.o \
+  keccak.o stubs-sha3.o \
+  stubs-md5.o \
+  stubs-zlib.o \
+  stubs-misc.o \
+  stubs-rng.o
+
+CAML_OBJS=cryptokit.cmo
+
+all: libcryptokit.a cryptokit.cmi cryptokit.cma 
+
+allopt: libcryptokit.a cryptokit.cmi cryptokit.cmxa 
+
+libcryptokit.a: $(C_OBJS)
+	$(MKLIB) -o cryptokit $(C_OBJS) -L$(ZLIB_LIBDIR) $(ZLIB_LIB)
+
+cryptokit.cma: $(CAML_OBJS)
+	$(MKLIB) -o cryptokit $(CAML_OBJS) -L$(ZLIB_LIBDIR) $(ZLIB_LIB)
+
+cryptokit.cmxa: $(CAML_OBJS:.cmo=.cmx)
+	$(MKLIB) -o cryptokit $(CAML_OBJS:.cmo=.cmx) -L$(ZLIB_LIBDIR) $(ZLIB_LIB)
+
+test: test.byt
+	$(OCAMLRUN) -I . ./test.byt
+
+test.byt: libcryptokit.a cryptokit.cma test.ml
+	$(OCAMLC) -o test.byt unix.cma nums.cma cryptokit.cma test.ml
+
+clean::
+	rm -f test.byt
+
+speedtest: libcryptokit.a cryptokit.cmxa speedtest.ml
+	$(OCAMLOPT) -o speedtest -ccopt -L. \
+                unix.cmxa nums.cmxa cryptokit.cmxa speedtest.ml
+
+clean::
+	rm -f speedtest
+
+install:
+	cp cryptokit.cmi cryptokit.cma cryptokit.mli $(INSTALLDIR)
+	cp libcryptokit.a $(INSTALLDIR)
+	if test -f dllcryptokit.so; then cp dllcryptokit.so $(INSTALLDIR)/stublibs; fi
+	if test -f cryptokit.cmxa; then cp cryptokit.cmxa cryptokit.cmx cryptokit.a $(INSTALLDIR); fi
+
+doc: FORCE
+	cd doc; $(OCAMLDOC) -html -I .. ../cryptokit.mli
+
+FORCE:
+
+.SUFFIXES: .ml .mli .cmo .cmi .cmx
+
+.mli.cmi:
+	$(OCAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmo:
+	$(OCAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmx:
+	$(OCAMLOPT) -c $(COMPFLAGS) $<
+
+.c.o:
+	$(OCAMLC) -c -ccopt "$(CFLAGS)" $<
+
+clean::
+	rm -f *.cm* *.o *.a *.so
+
+depend:
+	gcc -MM -I `$(OCAMLC) -where` -isystem `$(OCAMLC) -where ` *.c > .depend
+	$(OCAMLDEP) *.mli *.ml >> .depend
+
+include .depend
diff -urN cryptokit-1.7-orig/src/cryptokit.ml cryptokit-1.7/src/cryptokit.ml
--- cryptokit-1.7-orig/src/cryptokit.ml	2013-04-23 12:41:40.000000000 -0500
+++ cryptokit-1.7/src/cryptokit.ml	2013-06-19 00:16:15.492252397 -0500
@@ -1927,7 +1927,7 @@
           oend <- oend + 3
       | _ -> ()
       end;
-      if multiline or padding then begin
+      if multiline || padding then begin
         let num_equals =
           match ipos with 1 -> 2 | 2 -> 1 | _ -> 0 in
         self#ensure_capacity num_equals;
sks-1.1.5/sampleConfig/aliases.sample0000644000175000017500000000054312273431766020334 0ustar  kristianfkristianf# 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
sks-1.1.5/sampleConfig/aliases.sample.orig0000777000175000017500000000054312253367673021305 0ustar  kristianfkristianf# 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
sks-1.1.5/sampleConfig/crontab.sample0000644000175000017500000000326412273431766020346 0ustar  kristianfkristianf#************************************************************************#
#* sample.crontab - Using SIGUSR2 to generate on-demand statistics      *#
#*                  USR1 checkpoints the databases                      *#
#*                  HUP reopens the log files - useful for logrotate    *#
#*                                                                      *#
#* Copyright (C) 2011, 2012, 2013  John Clizbe                         *#
#*                                                                      *#
#* 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 or see .                           *#
#************************************************************************#

# SKS stats on the hour
0  *     * * * pkill -USR2 sks || exit 1

sks-1.1.5/sampleConfig/crontab.sample.orig0000777000175000017500000000326412253367673021317 0ustar  kristianfkristianf#************************************************************************#
#* sample.crontab - Using SIGUSR2 to generate on-demand statistics      *#
#*                  USR1 checkpoints the databases                      *#
#*                  HUP reopens the log files - useful for logrotate    *#
#*                                                                      *#
#* Copyright (C) 2011, 2012, 2013  John Clizbe                         *#
#*                                                                      *#
#* 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 or see .                           *#
#************************************************************************#

# SKS stats on the hour
0  *     * * * pkill -USR2 sks || exit 1

sks-1.1.5/sampleConfig/DB_CONFIG0000644000175000017500000000335712273431766016753 0ustar  kristianfkristianf#************************************************************************#
#* DB_CONFIG - Sample Berkeley DB tunables for use with SKS             *#
#*                                                                      *#
#* Copyright (C) 2011, 2012, 2013  John Clizbe                         *#
#*                                                                      *#
#* 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 or see .                           *#
#************************************************************************#

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
sks-1.1.5/sampleConfig/DB_CONFIG.orig0000777000175000017500000000335712253367673017724 0ustar  kristianfkristianf#************************************************************************#
#* DB_CONFIG - Sample Berkeley DB tunables for use with SKS             *#
#*                                                                      *#
#* Copyright (C) 2011, 2012, 2013  John Clizbe                         *#
#*                                                                      *#
#* 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 or see .                           *#
#************************************************************************#

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
sks-1.1.5/sampleConfig/debian/0000777000175000017500000000000012273431766016734 5ustar  kristianfkristianfsks-1.1.5/sampleConfig/debian/forward.postfix.orig0000777000175000017500000000003212253367673022756 0ustar  kristianfkristianf"|exec /usr/bin/procmail"
sks-1.1.5/sampleConfig/debian/sksconf0000644000175000017500000000151712273431766020325 0ustar  kristianfkristianf# /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 "

# 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:
sks-1.1.5/sampleConfig/debian/forward.postfix0000644000175000017500000000003212273431766022005 0ustar  kristianfkristianf"|exec /usr/bin/procmail"
sks-1.1.5/sampleConfig/debian/membership0000644000175000017500000000076312273431766021014 0ustar  kristianfkristianf# /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
sks-1.1.5/sampleConfig/debian/forward.exim.orig0000777000175000017500000000002312253367673022224 0ustar  kristianfkristianf|/usr/bin/procmail
sks-1.1.5/sampleConfig/debian/mailsync.orig0000777000175000017500000000111512253367673021441 0ustar  kristianfkristianf# /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@keyserver.kjsl.com
sks-1.1.5/sampleConfig/debian/sksconf.orig0000777000175000017500000000151712253367673021276 0ustar  kristianfkristianf# /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 "

# 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:
sks-1.1.5/sampleConfig/debian/README0000644000175000017500000000012112273431766017602 0ustar  kristianfkristianfThese are the example configuration files that ship with the debian
SKS package.
sks-1.1.5/sampleConfig/debian/procmail.orig0000777000175000017500000000011512253367673021427 0ustar  kristianfkristianf:0
* ^Subject: *(incremental|add)
| /usr/lib/sks/sks_add_mail /var/spool/sks
sks-1.1.5/sampleConfig/debian/README.orig0000777000175000017500000000012112253367673020553 0ustar  kristianfkristianfThese are the example configuration files that ship with the debian
SKS package.
sks-1.1.5/sampleConfig/debian/membership.orig0000777000175000017500000000076312253367673021765 0ustar  kristianfkristianf# /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
sks-1.1.5/sampleConfig/debian/mailsync0000644000175000017500000000111512273431766020470 0ustar  kristianfkristianf# /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@keyserver.kjsl.com
sks-1.1.5/sampleConfig/debian/forward.exim0000644000175000017500000000002312273431766021253 0ustar  kristianfkristianf|/usr/bin/procmail
sks-1.1.5/sampleConfig/debian/procmail0000644000175000017500000000011512273431766020456 0ustar  kristianfkristianf:0
* ^Subject: *(incremental|add)
| /usr/lib/sks/sks_add_mail /var/spool/sks
sks-1.1.5/sampleConfig/mailsync0000644000175000017500000000434212273431766017253 0ustar  kristianfkristianf#************************************************************************#
#* mailsync - servers that should receive email updates from SKS        *#
#*                                                                      *#
#* Copyright (C) 2011, 2012, 2013  John Clizbe                         *#
#*                                                                      *#
#* 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 or see .                           *#
#************************************************************************#
#
# 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 
#pgp-public-keys@pgp.nic.ad.jp
#
# Jonathon McDowell openrates the ONAK server 
# http://www.earth.li/projectpurple/progs/onak.html
#pgp-public-keys@the.earth.li
#
# V. Alex Brennen operates the CKS (CrytptNet) servers 
sks-1.1.5/sampleConfig/mailsync.orig0000777000175000017500000000434212253367673020224 0ustar  kristianfkristianf#************************************************************************#
#* mailsync - servers that should receive email updates from SKS        *#
#*                                                                      *#
#* Copyright (C) 2011, 2012, 2013  John Clizbe                         *#
#*                                                                      *#
#* 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 or see .                           *#
#************************************************************************#
#
# 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 
#pgp-public-keys@pgp.nic.ad.jp
#
# Jonathon McDowell openrates the ONAK server 
# http://www.earth.li/projectpurple/progs/onak.html
#pgp-public-keys@the.earth.li
#
# V. Alex Brennen operates the CKS (CrytptNet) servers 
sks-1.1.5/sampleConfig/membership0000644000175000017500000000556112273431766017573 0ustar  kristianfkristianf#************************************************************************#
#* membership - list of servers to peer with along with optional        *#
#*              administrative contact information                      *#
#*                                                                      *#
#* Copyright (C) 2011, 2012, 2013  John Clizbe                         *#
#*                                                                      *#
#* 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 or see .                           *#
#************************************************************************#

#
# 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  0xPreferrefPGPkey
#keyserver.gingerbear.net	11370	# John P. Clizbe 		0xD6569825
#sks.keyservers.net		11370	# John P. Clizbe 		0xD6569825
#keyserver.rainydayz.org	11370	# Andy Ruddock 	0xEEC3AFB3
#keyserver.computer42.org	11370	# H.-Dirk Schmitt 		0x6A017B17
sks-1.1.5/sampleConfig/membership.orig0000777000175000017500000000556112253367673020544 0ustar  kristianfkristianf#************************************************************************#
#* membership - list of servers to peer with along with optional        *#
#*              administrative contact information                      *#
#*                                                                      *#
#* Copyright (C) 2011, 2012, 2013  John Clizbe                         *#
#*                                                                      *#
#* 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 or see .                           *#
#************************************************************************#

#
# 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  0xPreferrefPGPkey
#keyserver.gingerbear.net	11370	# John P. Clizbe 		0xD6569825
#sks.keyservers.net		11370	# John P. Clizbe 		0xD6569825
#keyserver.rainydayz.org	11370	# Andy Ruddock 	0xEEC3AFB3
#keyserver.computer42.org	11370	# H.-Dirk Schmitt 		0x6A017B17
sks-1.1.5/sampleConfig/procmailrc0000644000175000017500000000074712273431766017574 0ustar  kristianfkristianf#!/usr/bin/procmail
#
#  - .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@gingerbear.net
$DEFAULT

# Handle your keysync mails (optional)
:0
* ^Subject.*incremental
| /usr/bin/sks_add_mail /var/sks/

# Anything leftover
:0
$DEFAULT
sks-1.1.5/sampleConfig/procmailrc.orig0000777000175000017500000000074712253367673020545 0ustar  kristianfkristianf#!/usr/bin/procmail
#
#  - .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@gingerbear.net
$DEFAULT

# Handle your keysync mails (optional)
:0
* ^Subject.*incremental
| /usr/bin/sks_add_mail /var/sks/

# Anything leftover
:0
$DEFAULT
sks-1.1.5/sampleConfig/rc.sks0000644000175000017500000000433412273431766016640 0ustar  kristianfkristianf#************************************************************************#
#* rc.sks - sample script to start and stop the SKS processes           *#
#*                                                                      *#
#* Copyright (C) 2011, 2012, 2013  John Clizbe                         *#
#*                                                                      *#
#* 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 or see .                           *#
#************************************************************************#
#
#! /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
sks-1.1.5/sampleConfig/rc.sks.orig0000777000175000017500000000433412253367673017611 0ustar  kristianfkristianf#************************************************************************#
#* rc.sks - sample script to start and stop the SKS processes           *#
#*                                                                      *#
#* Copyright (C) 2011, 2012, 2013  John Clizbe                         *#
#*                                                                      *#
#* 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 or see .                           *#
#************************************************************************#
#
#! /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
sks-1.1.5/sampleConfig/sksconf.minimal0000644000175000017500000000341012273431766020522 0ustar  kristianfkristianf#************************************************************************#
#* sksconf.minimal - minimal settings for a SKS server                  *#
#*                                                                      *#
#* Copyright (C) 2011, 2012, 2013  John Clizbe                         *#
#*                                                                      *#
#* 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 or see .                           *#
#************************************************************************#
#
# sksconf sample for keyserver.foo.bar
# ------------------------------------
# debuglevel 3 is default (max. debuglevel is 10)
debuglevel: 3

# set the hostname of your server
hostname: keyserver.foo.bar

# set short, long, or fpr of contact's OpenPGP key
server_contact: 0xDECAFBADDEADBEEF

# EOF
sks-1.1.5/sampleConfig/sksconf.minimal.orig0000777000175000017500000000341012272011377021457 0ustar  kristianfkristianf#************************************************************************#
#* sksconf.minimal - minimal settings for a SKS server                  *#
#*                                                                      *#
#* Copyright (C) 2011, 2012, 2013  John Clizbe                         *#
#*                                                                      *#
#* 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 or see .                           *#
#************************************************************************#
#
# sksconf sample for keyserver.foo.bar
# ------------------------------------
# debuglevel 3 is default (max. debuglevel is 10)
debuglevel: 3

# set the hostname of your server
hostname: keyserver.foo.bar

# set short, long, or fpr of contact's OpenPGP key
server_contact: 0xDECAFBADDEADBEEF

# EOF
sks-1.1.5/sampleConfig/sksconf.typical0000644000175000017500000000500712273431766020545 0ustar  kristianfkristianf#************************************************************************#
#* sksconf.typical - Typical configuration settings for a SKS server    *#
#*                                                                      *#
#* Copyright (C) 2011, 2012, 2013  John Clizbe                         *#
#*                                                                      *#
#* 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 or see .                           *#
#************************************************************************#

#  sksconf -- SKS main configuration
#
basedir:			/var/sks

# debuglevel 3 is default (max. debuglevel is 10)
debuglevel:			3

hostname:			keyserver.example.tld
hkp_port:			11371
recon_port:			11370
#
server_contact:			0xDECAFBADDEADBEEF
from_addr:			pgp-public-keys@example.tld
sendmail_cmd:			/usr/sbin/sendmail -t -oi
#
initial_stat:
membership_reload_interval:	1
stat_hour:			17
#
# set DB file pagesize as recommended by db_tuner
# pagesize is (n * 512) bytes
# NOTE: These must be set _BEFORE_ [fast]build & pbuild and remain set
# for the life of the database files. To change a value requires recreating
# the database from a dump
#
# KDB/key		65536
pagesize:			128
#
# KDB/keyid		32768
keyid_pagesize			64
#
# KDB/meta		512
meta_pagesize:			1
# KDB/subkeyid		65536
subkeyid_pagesize:		128
#
# KDB/time		65536
time_pagesize:			128
#
# KDB/tqueue		512
tqueue_pagesize:		1
#
# KDB/word - db_tuner suggests 512 bytes. This locked the build process
# Better to use a default of 8 (4096 bytes) for now
#word_pagesize:			8
#
# PTree/ptree		4096
ptree_pagesize:			8
sks-1.1.5/sampleConfig/sksconf.typical.orig0000777000175000017500000000500712272011377021502 0ustar  kristianfkristianf#************************************************************************#
#* sksconf.typical - Typical configuration settings for a SKS server    *#
#*                                                                      *#
#* Copyright (C) 2011, 2012, 2013  John Clizbe                         *#
#*                                                                      *#
#* 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 or see .                           *#
#************************************************************************#

#  sksconf -- SKS main configuration
#
basedir:			/var/sks

# debuglevel 3 is default (max. debuglevel is 10)
debuglevel:			3

hostname:			keyserver.example.tld
hkp_port:			11371
recon_port:			11370
#
server_contact:			0xDECAFBADDEADBEEF
from_addr:			pgp-public-keys@example.tld
sendmail_cmd:			/usr/sbin/sendmail -t -oi
#
initial_stat:
membership_reload_interval:	1
stat_hour:			17
#
# set DB file pagesize as recommended by db_tuner
# pagesize is (n * 512) bytes
# NOTE: These must be set _BEFORE_ [fast]build & pbuild and remain set
# for the life of the database files. To change a value requires recreating
# the database from a dump
#
# KDB/key		65536
pagesize:			128
#
# KDB/keyid		32768
keyid_pagesize			64
#
# KDB/meta		512
meta_pagesize:			1
# KDB/subkeyid		65536
subkeyid_pagesize:		128
#
# KDB/time		65536
time_pagesize:			128
#
# KDB/tqueue		512
tqueue_pagesize:		1
#
# KDB/word - db_tuner suggests 512 bytes. This locked the build process
# Better to use a default of 8 (4096 bytes) for now
#word_pagesize:			8
#
# PTree/ptree		4096
ptree_pagesize:			8
sks-1.1.5/sampleWeb/HTML5/0000777000175000017500000000000012273431766015653 5ustar  kristianfkristianfsks-1.1.5/sampleWeb/HTML5/robots.txt.orig0000777000175000017500000000003212253367673020664 0ustar  kristianfkristianfUser-agent: *
Disallow: /
sks-1.1.5/sampleWeb/HTML5/robots.txt0000644000175000017500000000003212273431766017713 0ustar  kristianfkristianfUser-agent: *
Disallow: /
sks-1.1.5/sampleWeb/HTML5/index.html.orig0000777000175000017500000001166612253367673020627 0ustar  kristianfkristianf

  
    
    
    SKS key server at YOURDOMAIN
    
    
    
    
    
  
  
    

      

        

          
SKS OpenPGP Key server

          
YOURDOMAIN

        

      

      

        

          
Extract a key

        

        
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…")

        

          
 Search for a public key
            
    
              
  •    
    • 
              
  •  
                
              
    • 
              
  •    
    • 
              
  •    
    • 
              
  •    
    • 
              
  •    
    • 
              
  •  
                
              
    • 
            

              

        

        

          
Submit a key

        

        
You can submit a key by simply pasting in the ASCII-armored
          version of your key and clicking on submit.

        

          
 
             

        

      

      
      

        
SKS is
          a new OpenPGP
          keyserver. The main innovation of SKS is that it includes a
          highly-efficient reconciliation algorithm for keeping the
          keyservers synchronized.

        
SKS

            statistics

      

    

    
  

sks-1.1.5/sampleWeb/HTML5/README0000644000175000017500000000050012273431766016522 0ustar  kristianfkristianfThis is just a prettified index.html in HTML5.

It uses elements of HTML5 boilerplate 1.0

The link to SKS points to the https://bitbucket.org/skskeyserver/sks-keyserver/

The submission links are relative to minimize having to search and replace
on installation.

Comments welcome.

Submitted by samir@samirnassar.com.
sks-1.1.5/sampleWeb/HTML5/README.orig0000777000175000017500000000050012253367673017473 0ustar  kristianfkristianfThis is just a prettified index.html in HTML5.

It uses elements of HTML5 boilerplate 1.0

The link to SKS points to the https://bitbucket.org/skskeyserver/sks-keyserver/

The submission links are relative to minimize having to search and replace
on installation.

Comments welcome.

Submitted by samir@samirnassar.com.
sks-1.1.5/sampleWeb/HTML5/index.html0000644000175000017500000001166612273431766017656 0ustar  kristianfkristianf

  
    
    
    SKS key server at YOURDOMAIN
    
    
    
    
    
  
  
    

      

        

          
SKS OpenPGP Key server

          
YOURDOMAIN

        

      

      

        

          
Extract a key

        

        
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…")

        

          
 Search for a public key
            
    
              
  •    
    • 
              
  •  
                
              
    • 
              
  •    
    • 
              
  •    
    • 
              
  •    
    • 
              
  •    
    • 
              
  •  
                
              
    • 
            

              

        

        

          
Submit a key

        

        
You can submit a key by simply pasting in the ASCII-armored
          version of your key and clicking on submit.

        

          
 
             

        

      

      
      

        
SKS is
          a new OpenPGP
          keyserver. The main innovation of SKS is that it includes a
          highly-efficient reconciliation algorithm for keeping the
          keyservers synchronized.

        
SKS

            statistics

      

    

    
  

sks-1.1.5/sampleWeb/OpenPKG/0000777000175000017500000000000012273431766016265 5ustar  kristianfkristianfsks-1.1.5/sampleWeb/OpenPKG/robots.txt.orig0000777000175000017500000000003212253367673021276 0ustar  kristianfkristianfUser-agent: *
Disallow: /
sks-1.1.5/sampleWeb/OpenPKG/robots.txt0000644000175000017500000000003212273431766020325 0ustar  kristianfkristianfUser-agent: *
Disallow: /
sks-1.1.5/sampleWeb/OpenPKG/index.html.orig0000777000175000017500000000260712253367673021234 0ustar  kristianfkristianf


  
    SKS OpenPGP Public Key Server
  
  
  
SKS OpenPGP Public Key Server

  

  

  Extracting a OpenPGP Key
  

  

    
Index: 
    
     Verbose Index: 
    
    

    
Search String: 
    
    

    

    
     Show OpenPGP "fingerprints" for keys

    

    
     Only return exact matches

    

    
     
    
    

  

  

  

  Submitting a new OpenPGP Key
  

  

    
Enter ASCII-armored OpenPGP key here:

    

    
    

    

    
     
    
    

  

  

  

sks-1.1.5/sampleWeb/OpenPKG/README0000644000175000017500000000026012273431766017137 0ustar  kristianfkristianfI found this one day surfing. It from the OpenPKG RPM Package Specification
Copyright (c) 2000-2008 OpenPKG Foundation e.V. 

It is considerably barebones
sks-1.1.5/sampleWeb/OpenPKG/README.orig0000777000175000017500000000026012253367673020110 0ustar  kristianfkristianfI found this one day surfing. It from the OpenPKG RPM Package Specification
Copyright (c) 2000-2008 OpenPKG Foundation e.V. 

It is considerably barebones
sks-1.1.5/sampleWeb/OpenPKG/index.html0000644000175000017500000000260712273431766020263 0ustar  kristianfkristianf


  
    SKS OpenPGP Public Key Server
  
  
  
SKS OpenPGP Public Key Server

  

  

  Extracting a OpenPGP Key
  

  

    
Index: 
    
     Verbose Index: 
    
    

    
Search String: 
    
    

    

    
     Show OpenPGP "fingerprints" for keys

    

    
     Only return exact matches

    

    
     
    
    

  

  

  

  Submitting a new OpenPGP Key
  

  

    
Enter ASCII-armored OpenPGP key here:

    

    
    

    

    
     
    
    

  

  

  

sks-1.1.5/sampleWeb/XHTML+ES/0000777000175000017500000000000012273431766016221 5ustar  kristianfkristianfsks-1.1.5/sampleWeb/XHTML+ES/functions.es0000644000175000017500000000652512273431766020566 0ustar  kristianfkristianffunction set_modifier_status(id, active)
{
	if (active)
	{
		document.getElementById(id).style.visibility = "visible";
		document.getElementById(id + ".label").style.visibility = "visible";
		document.getElementById(id).disabled = false;
		document.getElementById(id + ".label").disabled = false;
	}
	else
	{
		document.getElementById(id).style.visibility = "hidden";
		document.getElementById(id + ".label").style.visibility = "hidden";
		document.getElementById(id).disabled = true;
		document.getElementById(id + ".label").disabled = true;
	}
}




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":
		set_modifier_status("modifier_fingerprint", true)
		set_modifier_status("modifier_hash", true)
		set_modifier_status("modifier_options-mr", true)
		
		if (  ( document.getElementById("modifier_fingerprint").checked  ||  document.getElementById("modifier_hash").checked )  &&  document.getElementById("modifier_options-mr").checked  )
		{
			document.getElementById("modifier_options-mr").checked = false;
		}
		if (document.getElementById("modifier_options-mr").checked)
		{
			set_modifier_status("modifier_fingerprint", false)
			set_modifier_status("modifier_hash", false)
		}
		else
		{
			set_modifier_status("modifier_fingerprint", true)
			set_modifier_status("modifier_hash", true)
		}
		if (document.getElementById("modifier_fingerprint").checked  ||  document.getElementById("modifier_hash").checked)
			set_modifier_status("modifier_options-mr", false)
		else
			set_modifier_status("modifier_options-mr", true)
		
		break;
	
	case "vindex":
		set_modifier_status("modifier_fingerprint", true)
		set_modifier_status("modifier_hash", true)
		set_modifier_status("modifier_options-mr", false)
		
		break;
	
	case "get":
		set_modifier_status("modifier_fingerprint", false)
		set_modifier_status("modifier_hash", false)
		set_modifier_status("modifier_options-mr", true)
		
		break;
	
	case "hget":
		set_modifier_status("modifier_fingerprint", false)
		set_modifier_status("modifier_hash", false)
		set_modifier_status("modifier_options-mr", true)
		
		break;
	}
	
	
	
	
}
















/*
Copyright © 2010–2013, Christoph Anton Mitterer .
All rights reserved.


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 .

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/.

This work is licensed under the Creative Commons Attribution-ShareAlike 3.0
Germany License.
To view a copy of this license, visit
http://creativecommons.org/licenses/by-sa/3.0/de/.
*/
sks-1.1.5/sampleWeb/XHTML+ES/robots.txt.orig0000777000175000017500000000003212253367673021232 0ustar  kristianfkristianfUser-agent: *
Disallow: /
sks-1.1.5/sampleWeb/XHTML+ES/robots.txt0000644000175000017500000000003212273431766020261 0ustar  kristianfkristianfUser-agent: *
Disallow: /
sks-1.1.5/sampleWeb/XHTML+ES/index.xhtml.orig0000777000175000017500000002614412253367673021362 0ustar  kristianfkristianf








	example.org.invalid OpenPGP Keyserver