conjure (empty) → 0.1

raw patch · 49 files changed

+4848/−0 lines, 49 filesdep +HTTPdep +arraydep +basesetup-changed

Dependencies added: HTTP, array, base, bytestring, containers, filepath, html, mtl, network, old-time, parsec, pretty, random, stm, unix

Files

• AUTHORS +68/−0
• DEVELOPING +47/−0
• INSTALL +26/−0
• LICENSE +18/−0
• MILESTONES +29/−0
• READTHEM +40/−0
• STYLE +286/−0
• Setup.hs +5/−0
• TODO +114/−0
• cbits/sha1.c +166/−0
• cbits/sha1.h +75/−0
• conjure.cabal +47/−0
• conjure.glade +231/−0
• pjlester-1.11.tar.Z.torrent +3/−0
• src/BEncode/BEncode.hs +189/−0
• src/BEncode/BEncodePP.hs +56/−0
• src/BEncode/BLexer.hs +41/−0
• src/BEncode/BParser.hs +120/−0
• src/Conjure.hs +86/−0
• src/Conjure/Constants.hs +8/−0
• src/Conjure/Debug.hs +84/−0
• src/Conjure/FileSystem/Interface.hs +28/−0
• src/Conjure/FileSystem/InterfaceMMap.hsc +187/−0
• src/Conjure/FileSystem/InterfaceNaive.hs +138/−0
• src/Conjure/Logic/BlockManagement.hs +213/−0
• src/Conjure/Logic/PeerManager.hs +280/−0
• src/Conjure/Logic/QueueManager.hs +49/−0
• src/Conjure/Network/Client.hs +150/−0
• src/Conjure/Network/Peer.hs +326/−0
• src/Conjure/Network/Server.hs +25/−0
• src/Conjure/OptionParser.hs +67/−0
• src/Conjure/Piecemap.hs +259/−0
• src/Conjure/Protocol/PWP.hs +24/−0
• src/Conjure/Protocol/PWP/Parser.hs +107/−0
• src/Conjure/Protocol/PWP/Printer.hs +72/−0
• src/Conjure/Protocol/PWP/Types.hs +55/−0
• src/Conjure/Protocol/THP.hs +86/−0
• src/Conjure/Protocol/THP/Parser.hs +42/−0
• src/Conjure/Protocol/THP/Types.hs +20/−0
• src/Conjure/STM/PeerCtrl.hs +207/−0
• src/Conjure/Torrent.hs +175/−0
• src/Conjure/Types.hs +163/−0
• src/Conjure/UI/Http.hs +122/−0
• src/Conjure/Utils.hs +28/−0
• src/Conjure/Utils/Logger.hsc +99/−0
• src/Conjure/Utils/SHA1.hs +35/−0
• src/Conjure/Utils/Shuffle.hs +43/−0
• src/Conjure/Utils/Transaction.hs +39/−0
• src/Conjure/Version.hs +70/−0

@@ -0,0 +1,68 @@+This file is a complete list of who have worked on parts of Conjure at+some point in time. All people listed here have in some part+contributed source code, documentation or helpful discussions+regarding the development.++The list is alphabetical on last name.++Name: Jesper Louis Andersen+Contact: jlouis <at> mongers.org -- jlouis on #haskell@freenode:+Repo: http://j.mongers.org/pub/haskell/darcs/conjure/+  Was insane enough to start this project.+  Project Leader.+  Did the initial layout of the darcs repository and+    wrote most files herein.+  Architectural design of the software.+  Interest Thread.+  Hacked too much code.+  Did all the bugs.+  Codes on a mixture of Carrots, Oranges and Apples+    (I really do. I code badly on chocolate, candy, and+     make numerous typos on coffee)+  File System code and FSThread work.++Name: Dmitry Astapov+Contact: dastapov <at> gmail.com -- adept on #haskell@freenode+Repo: http://adept.homeunix.net/conjure+  Wrote the Logging framework, based on MissingH+  Various diagrams+  Some work on a SpikeSolution to PeerThread+  NaivePiecePicker -- (Not so naive again!)+  A lot of work on the PeerThread.+  WireMessage protocol work.+  A lot of helpful discussions.+  Clear head, when jlouis gets high on abstractions.+  [Lots of other things -- add!]++Name: Samuel Bronson+Contact: naesten <at> gmail.com -- SamB on #haskell@freenode:+Repo: http://naesten.dyndns.org:8080/repos/conjure-SamB # Warning: 56k dialup!+  Haddock framework. +  Haddock docstring fixes.+  Helpful discussions.+  WireProtocol.+  Tracker Client.+  Forcing the project to actually do something.+  Fixes jlouis bugs for him (jlouis is grateful for this)++Name: Shae Erisson+Contact: shae <at> ScannedInAvian.com -- shapr on #haskell@freenode:+  Provided the idea of READTHEM. +  Encouraged jlouis to go on.+  Provided most of the B-coding parser, which jlouis+    took as an initial starting point. It turns out he had stolen it from+    sylvan, also on #haskell@freenode.++Name: Lennart Kolmodin+Contact: kolmodin <at> dtek.chalmers.se -- kolmodin on #haskell@freenode:+  Wrote the initial QuickCheck framework for BEncoded strings, and+    further shaped up stuff in the BEncode folder.++Name: Paolo Martini+Contact: p.martini <at> neuralnoise.com -- xerox on #haskell@freenode:+  Documentation fixes when jlouis was too sleepy and attempted+    a documentation write.++Name: Taral+Contact: taral <at> taral.net --+  Provided a neat patch to MiniHTTP making its urlEncoder much nicer.

@@ -0,0 +1,47 @@+++``Walking the plane of innocence can be dangerous, berk. You might+end up finding yourself face to face with danger when you least+expect it. You look over your shoulder and find your fellow+planewalkers gone, consumed by the odd reality of the plane. A succubi+will come walking in a sexy, seductive walk. While it seduces you, it+will keep telling you through telepathy ``Provide Conjure+Patches''. You can do nothing but do its bidding, as its luring powers+are unequalled. Then it will kiss you and pull you down; down to the+lower planes.'' -- Confessions of a Conjurer.++If you are reading this document, you might want to provide patches to+the Conjure project. This document is intended to give you a quick+overview of the project, so you are able to begin being productive+faster.++Conjure is a Bittorrent client written in the functional, pure, lazy+language of Haskell. The primary point of Conjure is to show the+feasibility of Haskell with respect to heavy network applications. In+particular, we are using the STM (Software Transactional Memory)+framework to provide us with concurrency.++CURRENT STATE: ++The current state of the code is that of immature development. Some of+us are building modules in a bottom-up fashion, so much of the code is+not yet linked into the main project.++SUGGESTED READING:++I suggest you go read some of the documents in the READTHEM file. The+file is a pile of documents relating to Haskell, Programming and+Bittorrent. They give the general overview.++The file TODO lists things people have found needing addition to the+project. Feel free to fill stuff into it, if you find anything. The+TODO list also lists who is working, or have worked, on what. You can+contact them and gain deeper knowledge about a certain part of the+code.++The document INSTALL should contain information about installing+Conjure. Currently the document is in a sad state, missing a lot of+stuff.++The docs/ directory contains some in-depth documentation on parts of+the code.

@@ -0,0 +1,26 @@+-----------------------------------------------------------------------------+Formulae for installing conjure:+-----------------------------------------------------------------------------++PRIMARY INGREDIENTS:++You will need GHC 6.6 or later.++You'll also need FilePath, HTTP and cabal-setup.+FilePath:    http://www-users.cs.york.ac.uk/~ndm/projects/libraries.php+cabal-setup: http://haskell.org/cabal/+HTTP:        http://haskell.org/http/++Global installation:++  1. cabal-setup configure+  2. cabal-setup build+  3. sudo cabal-setup install++Local installation:++  1. cabal-setup configure --prefix=~/usr # or some place else+  2. cabal-setup build+  3. cabal-setup install --user++LICENSING: Read COPYING

@@ -0,0 +1,18 @@++ Copyright (c) 2005 Jesper Louis Andersen <jlouis@mongers.org>+ Copyright (c) 2005 Samuel Bronson <naesten@gmail.com>+ Copyright (c) 2005 Dmitry Astapov <dastapov@gmail.com>+ Copyright (c) 2005 Lemmih <lemmih@gmail.com>++ Permission to use, copy, modify, and distribute this software for any+ purpose with or without fee is hereby granted, provided that the above+ copyright notice and this permission notice appear in all copies.++ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.+

@@ -0,0 +1,29 @@+This document lists certain milestones of the project.++Why Milestones?+===============++Milestones are important to keep focus on getting something done. We+don't strictly adhere to these, but they are there to have a target to+work towards. Milestones can be added by anyone. If we can agree on+the importance of a Milestone, it is listed here and given a priority.++Thus Milestones serves as the more abstract version of the TODO list:+The TODO list is the pool of stuff to do, while the Milestone list is+concerned with the larger goals.++Milestones are subject to change, but lays out the general position+we are at regarding a working Bittorent Client in Haskell.++CURRENT MILESTONE: 1+++Milestone 1: Seeding client+===========================++We are going for having a simple seeding client.++Milestone 2: Yet to be defined.+===============================++

@@ -0,0 +1,40 @@+The purpose of the READTHEM document is to provide newcomers with some+information and documentation. I, jlouis, encourage all wanting to+work on parts of the protocol to read the documents here. It is much+easier to do stuff on the project, when you know the intrisics. Bram+Cohen did a tremendous job and the torrent specification is quite+succint.++The initial developer guide is the file+  DEVELOPING+in this very directory++The Bittorrent protocol specification is at +  http://www.bittorrent.com/protocol.html++The Bittorrent economics paper is at+  http://www.bittorrent.com/bittorrentecon.pdf++Another, nicer-looking page documenting the protocol is at+  http://wiki.theory.org/BitTorrentSpecification++A student project aimed to produce RFC for BitTorrent protocol is at+  http://www.nitro.dk/~jonas/bittorrent/bittorrent-rfc.html++Interesting paper about BitTorrent performance+  http://research.microsoft.com/~padmanab/papers/msr-tr-2005-03.pdf++``Composeable Memory Transactions'' -- Tim Harris, Simon Marlow, Simon+Peyton Jones and Maurice Herlihy.+  http://research.microsoft.com/Users/simonpj/papers/stm/stm.pdf+This document describes the base behind the Control.Concurrent.STM+library in Haskell. Conjure will make heavy use of these primitives,+so reading about them might be a good idea if you want to hack on+the project.++All the project documentation resides in the repository under+  ./docs++Typing ``runhaskell Setup.lhs haddock'' will build the source code haddock+documentation in the following directory (if you haven't told cabal otherwise):+  ./dist/doc/html/conjure

@@ -0,0 +1,286 @@+Certain STYLE rules governing the conjure project:++OPTIMIZE FOR FUN!+=================++ABOVE ANYTHING ELSE: This project is about having fun coding a haskell+implementation of the bittorrent protocol. The reason for this is to+test Haskell in the environment of heavily threaded network+applications and prove it to be a feasible thing. We might learn a bit+about Haskell in the process and find it to be a cool programming+language. If we are lucky, we might even gather some new cool tricks+for programming client/server applications.++We are also doing this as a defensive measure. Without this project,+we might be lured into Alcohol, Amphetamine, Hashish, Cocaine, C, C++,+Java, PHP and other designer drugs. We are hacking code to avoid this+though some of the projects members have admitted to the+before-mentioned drug abuse. For example, 2 authors are currently+sedated by the use of Perl.++Targets are to have well-documented code under 10k lines providing the+bare bones of a bittorrent client. We are going to throw the beast at+a 100 Megabit line and test the sustain rate as well as the CPU load.++Under these assumptions, there are 100 100-line blocks to be written.+I have begun by providing the first 4.5 blocks, so you can still join+in, we still have 95.5 blocks to do ;)++[2005-12-18 Update:]+  Sam and ADEpT went insane. 34% code, and we are extremely close to+  seeding!++  Not going to write more, because I have to code to keep up with our+  speed demons.++[2005-12-08 Update:]+  Beginning taking courses at the university really hurts your+  productivity when the course puts out exercises to do. Combined with+  a bit of problems in my work-life made me be very unproductive on+  Conjure for the last 14 days or so. On the other hand, we have had+  SamB and Adept working on the code so much they have their own+  repositories now.++  I am hopefully able to get a lot of code done around the holidays,+  since I can use most of my time coding on this.++  My last count of the code was 29%, which means we are nearly 1/3+  through hitting the number of code lines that the original+  bittorrent had when this project was started.++  Do you want to join in? Get in contact with one of us!++[2005-11-20 Update:]+  Code generation has fallen a bit the last 10 days. This is due to the+  fact I have been researching on building thread primitives. But my ideas+  were in vain and did not really gain the code anything but needless+  abstraction. We have 24% of the code now!++  SamB keeps writing patches and kolmodin is a cool newcomer to the+  project writing QuickCheck tests. I am planning on using his QC framework+  as the base for a more general QC framework.++[2005-11-10 Update:]+  We are /still/ writing code like mad! I am shocked at the amount of+  patches I can produce myself, and people are really helping me out+  here. SamB is doing a tremendous piece of work, attacking the project+  from one side, while I am working on primitives behind the curtains.+  +  We are up to 19% of the code now. We have the first idea of a Thread+  primitive based on STM.TChans, Communication with the Tracker client+  begins to fall into place. We have a complete Type checker for the+  B-code, we can keep track of which pieces to download.++  But most importantly: I've not had that much fun in a long time hacking+  on a project. Join us! Read code! Find my bugs! Give us hints on papers+  or articles to read!++[2005-11-08 Update:]+  SamB is currently providing code like mad! I am hacking away on+  BType and making the HoldTimer actually work. 14.8% of the code+  done. Expectations at this speed is a working client before X-mas.++[2005-11-06 Update:]+  Sudden coding frenzy on the project! 11.0% And I do not even know+  how much other people have worked on the project. Rather cool!++[2005-11-04 Update:]+  Code goes on: 8.2 blocks of code. Join in while you can! There are+  numerous odd things you can attack in the TODO list.++[2005-11-03 Update:]+  We now have 6.7 blocks of code. If I sustain this writing rate, we+  have the whole client in 50 days. Join hackers! Join! Let us poke+  fun at the ICFP contestants for being lazy slackers not able to+  code fast!++Get people to join!+===================++Instead of working 10 people on one-man-army projects, it is much+better to join up, team together and kick some serious butt. Patches+are encouraged. I accept the most outrageous nitpicks. Especially+because I currently work in ``Ram-mode'' on the project: I ram the way+for others by spewing out code faster than good is. Like all good+warfare, you need to have a leap-frog team coming in and covering your+back while you press on.++BSD Licensing preferred over GPL+================================++If you wish to provide code, please provide it on BSD licensing+terms. We may adopt GPL code, but it will reside in the GNU+subdirectory of the project. However, the project must not be bogged+down by mere licensing. If you goddammit want to supply code in GPL,+talk to jlouis.  We might be able to figure something out.++Simple things+=============++We strive for complete documentation. All functions and everything+must be documented. If you read through the source code and find you+can document a non-documented function, you are officially a hero and+god if you provide me with a patch.++I will personally announce ``<person> is an extremely cool Haskell+hacker'' to #haskell whenever one provides documentation for the+project (However, there might be a timer in between announcements as+to not spam #haskell completely by eager programmers).++We strive for haddock(1) style documentation before each function+call. Provide documentation, please!++Iterative development+=====================++If you have anything to provide, do so! The quality of the provided+is not that important as we can always rewrite code that does not+click anymore. Therefore, heed ``Perfect is the enemy of done''. We+will rather have 8k lines of source code with opportunity for polishing+than 500 lines of perfect code.++The development model is strictly iterative. To keep flexibility, it+is important to think modular when writing code. Either build modularity+by ``pipelining'' one module after another or by ``layering'' where+modules stack on top of each other to provide successively more+functionality. If you have this in mind, modularity will prevail and+we can exchange stuff in a later iteration.++Repository layout+=================++If you take a look at the repository layout, you will see it attempts to+mimick the hierachy of the Haskell libraries. Things are placed in Control/*,+Data/*, etc. However, there are some special directories for Conjure:++* GNU -- GNU licensed software in the project.++* FS  -- Filesystem modules++* Conjure -- Everything related to Conjure++* BEncode -- Modules related to the B-coding++Coding style+============++The aim is absolute hackery. Absolute hackery is achieved when the+speed-of-change in the code goes below that of all other languages. To+achieve this goal, we will need to have clean code above anything+else. If you provide performance-patches, please bear in mind that+others should be able to read them as well. Documentation of performance+hacks are needed when they are nontrivial to figure out.++Aim for code readability. If the code is more readable and easier to+understand, we get more hackers than if it is totally+incomprehensible. We also get fewer bugs, maintainability etc.++Performance should always be governed by profiling. I'd rather have+the cost-centre optimized to Hades than have all the code being a+complete mess. Premature optimizers will be served one pint of+Styx-wash!++Commit policy+=============++We use Darcs as a Configuration Management system. This encourages+highly decentralized development. jlouis does his best to incoporate+patches from everyone into the source code tree. If you want to be+sure to get your patch into the tree, send the patch to+jlouis@mongers.org. I might take a bit to answer though, as I do not+currently have an internet connection at my home. Rest assured+however, that in a few days, I will commit your patch to the+repository.++I try to answer everyone who sends me patches. As long as I can manage+it, I prefer to thank people for their work on the project. Your+attempts at curing my insanity are greatly appreciated.++When writing commit messages, try to think about what you write. What+you should keep in mind is, that we might want to locate exactly that+patch in 4 months of time and then it helps tremendously with a good+commit log. jlouis is not always good at this - so please gently tell+him when his commit messages are non-understandable.++A good commit message contains a title describing the change in+general and possibly an elaboration if the change isn't of the simple+kind. This is especially important when fixing bugs, changing+semantics, APIs etc. We should strive for a commit log verbosity where+the interested reader can figure out what is going on in the source by+reading commit messages alone.++Code reviews+============++Try to get source code patches to be read by at least 2 people. I,+jlouis, currently look at all source code patches, but I would love to+have volunteers to hand off source code to if the pressure at some+point gets too big.++The reason is to make cool patches even cooler. Each source code+contribution is very valuable and I hope to highen the standards of+the source code by encouraging people to read other peoples source+code. You might even learn a trick or 2 by doing this.++Remember that execution of code on a computer is a by-product. The+important part is having the code read by another human and+understood (paraphrasing from SICP, I believe).++Attempt to provide signatures first+===================================++This is one thing I suddenly realised when discussing with Dmitry Astapov:+If you intend to build something bigger which the rest of the code should+interact with, start by defining a signature (*) -- a rough skeleton --+defining the API of your parts of the code. That way you have a framework+to build on and others are able to see what they can use the finished+product for. ++(*) The word signature is something I've stolen from SML. In SML a signature+is a collection of identifiers accompanied by types which a module must adhere+to. You then constrain your module (called a structure in SML) to a given+signature, encapsulating everything in the module, but the definitions in+the signature.++Compiler options+================++Code should pass a ghc -Wall at all times.++Helper functions+================++Helper functions should be put in a where clause or let..in block whenever+possible. Of course, if more than one function uses them, they should be+lifted.++Function naming+===============++lowerThenUpperCase.++Variable naming+===============++all_lowercase_seperated_by_underscores.++Imports+=======++jlouis Tends to use qualified imports for most of what he does to+separate name spaces as much as possible. However, there is no+restriction on the imports at all. You may import directly into a+name-space, but try to limit the amount of things you import to make+it easier to change the code later, do new imports etc without having+naming collisions.++I attempt to put local imports first, then foreign library imports and+at last system library imports. Each section is ordered+alphabetically. Spotting one miss makes you an extremely cool code+scout!++SamB, on the other hand, likes to have a section for things from this+project, followed by a section for things from the library, ordered+approximately Text -> Data -> Control -> System -> Network. The idea+is high-level things first, then lower level stuff, and then finally+things external to the Haskell system.

@@ -0,0 +1,5 @@+#!/usr/bin/runhaskell++import Distribution.Simple++main = defaultMainWithHooks simpleUserHooks

@@ -0,0 +1,114 @@+This list constitutes work which have to be done. We are trying+to list the level of -Ofun! a given task will have. There is a+strong correlation between the -Ofun! level and how much risk+a risk analysis would tie to a given part of the project. This is+totally coincidential ;). The fun parts are those we do not know+how to solve yet in detail.++If you want to add something to the list, do so. If you want to work+on something on the list, coordinate via conjure@lists.urchin.earth.li.++Grep for FIXME/TODO in the code.+================================++Faster sha1 hash check.+=======================++We should save our piecemap (with an option for ignoring it) and only+recheck downloaded pieces.++Optimize HTTP library.+======================++The tracker in bittorrent communicates by HTTP. Thus, we need a fast+HTTP library to be able to fetch files from the tracker. Fix this by+using FPS in HTTP.hs. -Ofun! level is low.++[Is this really important? We don't need to contact the tracker all+*that* often, do we? --SamB]++[No, but it's an easy task that'll make Conjure use fewer resources.+--Lemmih]++Construct an implementation of khashmir+=======================================++khashmir is a distributed hash table (DHT). We need an implementation of this+to support trackerless torrents.++Build the Option Parser+=======================++[Contact: Jesper Louis Andersen <jlouis@mongers.org>]++STATUS: I was bored and built a preliminary option parser.+        The config file parser stuff still needs doing. Any volunteers?++Are you new to Haskell? Want a simple task? Begin building the Option+parser for Conjure. You'll learn a bit about module structure and how+the getOpt framework in Haskell works. This is simple, but I'll+gladly volunteer to help you out if/when you get stuck.++If you want really bloody hands, you can begin building a simple+configuration file parser. The path you take is up to you: You can+rely upon the MissingH package and use its config parser. If you want+a bit more fun, you can define your own little config language and+Parsec away on it.++You can also take a look into Reader monads for the configuration+environment.++Research into effective storage management+==========================================++[Workers: Jesper Louis Andersen <jlouis@mongers.org>]++I have a hunch: The original bittorrent client is ineffective when it+comes to the FileSystem. I think it is wasting a lot of processing+power moving stuff around and that there are evil evil race condition+and atomicity problems in it as well.++Currently I am researching how to do this more effectively. Sending+files on FreeBSD with high speed is easy: We use sendfile(2) and then+we can forget entirely and completely about the file until it+completes. We have to compute the transfer rate though for the choker+can work its magic, but I think it is possible.++However, Linux doesn't have sendfile(2), so we need to use its corking+features. If somebody is able to provide me with information about+this, I would be grateful.++(As a side note: It is sendfile(2) that makes things like kernelbased+HTTPd servers irrelavant. It is extremely fast and uses zero-copy).++We also need to see if using stuff like kqueue() can benefit the+client. Of course we will need to play along with the FFI, but for+speed, nothing can beat it.++I propose we go for a simpler thing in the beginning, but we need to+design the code such that we can utilize sendfile() later on.++The simpler designs are to prefill the data on the disk with NULLs+before getting the file. It has the advantage of ensuring we can get+the whole file too and ensures we do not have to move around files+later.++We can also opt for sparse files. MLdonkey does this. Problem is that+the kernels are normally not optimized for manipulating them.++We can even simpler just let lseek(2) do its stuff on 0-byte sized+files. This is what the original bittorrent client seems to+do. Anyway, there is more to do in this world.++Proper (un)choke algorithm+==========================+Paper by INRIA +(http://hal.inria.fr/docs/00/05/86/99/PDF/bt_experiments_techRepINRIA-00001111_VERSION1_13FEBRUARY2006.pdf)+contains a very detailed descriptions of what we ought to have+++Decode client name from peer ids+================================++http://wiki.theory.org/BitTorrentSpecification#peer_id+

@@ -0,0 +1,166 @@+/*+ * sha1.c+ *+ * Originally witten by Steve Reid <steve@edmweb.com>+ * + * Modified by Aaron D. Gifford <agifford@infowest.com>+ *+ * NO COPYRIGHT - THIS IS 100% IN THE PUBLIC DOMAIN+ *+ * The original unmodified version is available at:+ *    ftp://ftp.funet.fi/pub/crypt/hash/sha/sha1.c+ *+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR(S) AND CONTRIBUTORS ``AS IS'' AND+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ * ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR(S) OR CONTRIBUTORS BE LIABLE+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+ * SUCH DAMAGE.+ */++#include "sha1.h"+#include <string.h>++#define rol(value, bits) (((value) << (bits)) | ((value) >> (32 - (bits))))++/* blk0() and blk() perform the initial expand. */+/* I got the idea of expanding during the round function from SSLeay */++#ifdef LITTLE_ENDIAN+#define blk0(i) (block->l[i] = (rol(block->l[i],24)&(sha1_quadbyte)0xFF00FF00) \+	|(rol(block->l[i],8)&(sha1_quadbyte)0x00FF00FF))+#else+#define blk0(i) block->l[i]+#endif++#define blk(i) (block->l[i&15] = rol(block->l[(i+13)&15]^block->l[(i+8)&15] \+	^block->l[(i+2)&15]^block->l[i&15],1))++/* (R0+R1), R2, R3, R4 are the different operations used in SHA1 */+#define R0(v,w,x,y,z,i) z+=((w&(x^y))^y)+blk0(i)+0x5A827999+rol(v,5);w=rol(w,30);+#define R1(v,w,x,y,z,i) z+=((w&(x^y))^y)+blk(i)+0x5A827999+rol(v,5);w=rol(w,30);+#define R2(v,w,x,y,z,i) z+=(w^x^y)+blk(i)+0x6ED9EBA1+rol(v,5);w=rol(w,30);+#define R3(v,w,x,y,z,i) z+=(((w|x)&y)|(w&x))+blk(i)+0x8F1BBCDC+rol(v,5);w=rol(w,30);+#define R4(v,w,x,y,z,i) z+=(w^x^y)+blk(i)+0xCA62C1D6+rol(v,5);w=rol(w,30);++typedef union _BYTE64QUAD16 {+	sha1_byte c[64];+	sha1_quadbyte l[16];+} BYTE64QUAD16;++/* Utility function for easy use in Haskell */+void SHA1(sha1_byte *data, unsigned int len, sha1_byte digest[SHA1_DIGEST_LENGTH])+{+  SHA_CTX context;+  SHA1_Init(&context);+  SHA1_Update(&context,data,len);+  SHA1_Final(digest,&context);+}++/* Hash a single 512-bit block. This is the core of the algorithm. */+void SHA1_Transform(sha1_quadbyte state[5], sha1_byte buffer[64]) {+	sha1_quadbyte	a, b, c, d, e;+	BYTE64QUAD16	*block;++	block = (BYTE64QUAD16*)buffer;+	/* Copy context->state[] to working vars */+	a = state[0];+	b = state[1];+	c = state[2];+	d = state[3];+	e = state[4];+	/* 4 rounds of 20 operations each. Loop unrolled. */+	R0(a,b,c,d,e, 0); R0(e,a,b,c,d, 1); R0(d,e,a,b,c, 2); R0(c,d,e,a,b, 3);+	R0(b,c,d,e,a, 4); R0(a,b,c,d,e, 5); R0(e,a,b,c,d, 6); R0(d,e,a,b,c, 7);+	R0(c,d,e,a,b, 8); R0(b,c,d,e,a, 9); R0(a,b,c,d,e,10); R0(e,a,b,c,d,11);+	R0(d,e,a,b,c,12); R0(c,d,e,a,b,13); R0(b,c,d,e,a,14); R0(a,b,c,d,e,15);+	R1(e,a,b,c,d,16); R1(d,e,a,b,c,17); R1(c,d,e,a,b,18); R1(b,c,d,e,a,19);+	R2(a,b,c,d,e,20); R2(e,a,b,c,d,21); R2(d,e,a,b,c,22); R2(c,d,e,a,b,23);+	R2(b,c,d,e,a,24); R2(a,b,c,d,e,25); R2(e,a,b,c,d,26); R2(d,e,a,b,c,27);+	R2(c,d,e,a,b,28); R2(b,c,d,e,a,29); R2(a,b,c,d,e,30); R2(e,a,b,c,d,31);+	R2(d,e,a,b,c,32); R2(c,d,e,a,b,33); R2(b,c,d,e,a,34); R2(a,b,c,d,e,35);+	R2(e,a,b,c,d,36); R2(d,e,a,b,c,37); R2(c,d,e,a,b,38); R2(b,c,d,e,a,39);+	R3(a,b,c,d,e,40); R3(e,a,b,c,d,41); R3(d,e,a,b,c,42); R3(c,d,e,a,b,43);+	R3(b,c,d,e,a,44); R3(a,b,c,d,e,45); R3(e,a,b,c,d,46); R3(d,e,a,b,c,47);+	R3(c,d,e,a,b,48); R3(b,c,d,e,a,49); R3(a,b,c,d,e,50); R3(e,a,b,c,d,51);+	R3(d,e,a,b,c,52); R3(c,d,e,a,b,53); R3(b,c,d,e,a,54); R3(a,b,c,d,e,55);+	R3(e,a,b,c,d,56); R3(d,e,a,b,c,57); R3(c,d,e,a,b,58); R3(b,c,d,e,a,59);+	R4(a,b,c,d,e,60); R4(e,a,b,c,d,61); R4(d,e,a,b,c,62); R4(c,d,e,a,b,63);+	R4(b,c,d,e,a,64); R4(a,b,c,d,e,65); R4(e,a,b,c,d,66); R4(d,e,a,b,c,67);+	R4(c,d,e,a,b,68); R4(b,c,d,e,a,69); R4(a,b,c,d,e,70); R4(e,a,b,c,d,71);+	R4(d,e,a,b,c,72); R4(c,d,e,a,b,73); R4(b,c,d,e,a,74); R4(a,b,c,d,e,75);+	R4(e,a,b,c,d,76); R4(d,e,a,b,c,77); R4(c,d,e,a,b,78); R4(b,c,d,e,a,79);+	/* Add the working vars back into context.state[] */+	state[0] += a;+	state[1] += b;+	state[2] += c;+	state[3] += d;+	state[4] += e;+	/* Wipe variables */+	a = b = c = d = e = 0;+}+++/* SHA1_Init - Initialize new context */+void SHA1_Init(SHA_CTX* context) {+	/* SHA1 initialization constants */+	context->state[0] = 0x67452301;+	context->state[1] = 0xEFCDAB89;+	context->state[2] = 0x98BADCFE;+	context->state[3] = 0x10325476;+	context->state[4] = 0xC3D2E1F0;+	context->count[0] = context->count[1] = 0;+}++/* Run your data through this. */+void SHA1_Update(SHA_CTX *context, sha1_byte *data, unsigned int len) {+	unsigned int	i, j;++	j = (context->count[0] >> 3) & 63;+	if ((context->count[0] += len << 3) < (len << 3)) context->count[1]++;+	context->count[1] += (len >> 29);+	if ((j + len) > 63) {+	    memcpy(&context->buffer[j], data, (i = 64-j));+	    SHA1_Transform(context->state, context->buffer);+	    for ( ; i + 63 < len; i += 64) {+	        SHA1_Transform(context->state, &data[i]);+	    }+	    j = 0;+	}+	else i = 0;+	memcpy(&context->buffer[j], &data[i], len - i);+}+++/* Add padding and return the message digest. */+void SHA1_Final(sha1_byte digest[SHA1_DIGEST_LENGTH], SHA_CTX *context) {+	sha1_quadbyte	i, j;+	sha1_byte	finalcount[8];++	for (i = 0; i < 8; i++) {+	    finalcount[i] = (sha1_byte)((context->count[(i >= 4 ? 0 : 1)]+	     >> ((3-(i & 3)) * 8) ) & 255);  /* Endian independent */+	}+	SHA1_Update(context, (sha1_byte *)"\200", 1);+	while ((context->count[0] & 504) != 448) {+	    SHA1_Update(context, (sha1_byte *)"\0", 1);+	}+	/* Should cause a SHA1_Transform() */+	SHA1_Update(context, finalcount, 8);+	for (i = 0; i < SHA1_DIGEST_LENGTH; i++) {+	    digest[i] = (sha1_byte)+	     ((context->state[i>>2] >> ((3-(i & 3)) * 8) ) & 255);+	}+	/* Wipe variables */+	i = j = 0;+	memset(context->buffer, 0, SHA1_BLOCK_LENGTH);+	memset(context->state, 0, SHA1_DIGEST_LENGTH);+	memset(context->count, 0, 8);+	memset(&finalcount, 0, 8);+}+

@@ -0,0 +1,75 @@+/*+ * sha.h+ *+ * Originally taken from the public domain SHA1 implementation+ * written by by Steve Reid <steve@edmweb.com>+ * + * Modified by Aaron D. Gifford <agifford@infowest.com>+ *+ * NO COPYRIGHT - THIS IS 100% IN THE PUBLIC DOMAIN+ *+ * The original unmodified version is available at:+ *    ftp://ftp.funet.fi/pub/crypt/hash/sha/sha1.c+ *+ * THIS SOFTWARE IS PROVIDED BY THE AUTHOR(S) AND CONTRIBUTORS ``AS IS'' AND+ * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ * ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR(S) OR CONTRIBUTORS BE LIABLE+ * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+ * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+ * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+ * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+ * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+ * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+ * SUCH DAMAGE.+ */++#ifndef __SHA1_H__+#define __SHA1_H__++#ifdef __cplusplus+extern "C" {+#endif++/* Define this if your machine is LITTLE_ENDIAN, otherwise #undef it: */+#define LITTLE_ENDIAN++/* Make sure you define these types for your architecture: */+typedef unsigned int sha1_quadbyte;	/* 4 byte type */+typedef unsigned char sha1_byte;	/* single byte type */++/*+ * Be sure to get the above definitions right.  For instance, on my+ * x86 based FreeBSD box, I define LITTLE_ENDIAN and use the type+ * "unsigned long" for the quadbyte.  On FreeBSD on the Alpha, however,+ * while I still use LITTLE_ENDIAN, I must define the quadbyte type+ * as "unsigned int" instead.+ */++#define SHA1_BLOCK_LENGTH	64+#define SHA1_DIGEST_LENGTH	20++/* The SHA1 structure: */+typedef struct _SHA_CTX {+	sha1_quadbyte	state[5];+	sha1_quadbyte	count[2];+	sha1_byte	buffer[SHA1_BLOCK_LENGTH];+} SHA_CTX;++#ifndef NOPROTO+void SHA1(sha1_byte *data, unsigned int len, sha1_byte digest[SHA1_DIGEST_LENGTH]);+void SHA1_Init(SHA_CTX *context);+void SHA1_Update(SHA_CTX *context, sha1_byte *data, unsigned int len);+void SHA1_Final(sha1_byte digest[SHA1_DIGEST_LENGTH], SHA_CTX* context);+#else+void SHA1_Init();+void SHA1_Update();+void SHA1_Final();+#endif++#ifdef	__cplusplus+}+#endif++#endif+

@@ -0,0 +1,47 @@+Name:             conjure+Version:          0.1+License:          BSD3+License-file:     LICENSE+Author:           See AUTHORS+Stability:        Alpha+Category:         Network+Synopsis:         A BitTorrent client+Description:      Conjure is a Bittorrent client written in the functional, pure, lazy+                  language of Haskell. The primary point of Conjure is to show the+                  feasibility of Haskell with respect to heavy network applications. In+                  particular, we are using the STM (Software Transactional Memory)+                  framework to provide us with concurrency.++Build-depends:    base>3, network, mtl, parsec, stm, filepath, unix, html,+                  HTTP, containers, bytestring, array, random, old-time+Cabal-Version:    >= 1.2+Build-Type:       Simple++data-files:         conjure.glade, AUTHORS, DEVELOPING, INSTALL, READTHEM, MILESTONES, pjlester-1.11.tar.Z.torrent, STYLE, TODO+extra-source-files: ./cbits/sha1.h++Library+        Hs-Source-Dirs:   src+        GHC-Options:      -Wall+        Extensions:       NoMonomorphismRestriction, CPP, GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses, ForeignFunctionInterface, TypeOperators, PatternGuards+        C-Sources:        cbits/sha1.c++        Build-depends:    base>3, network, mtl, parsec, stm, filepath, unix, html,+                  HTTP, containers, bytestring, array, random, old-time, pretty+-- QuickCheck<2++        exposed-modules: BEncode.BEncode, BEncode.BEncodePP, BEncode.BLexer, BEncode.BParser,+                         Conjure.Constants, Conjure.Debug, Conjure.FileSystem.Interface, Conjure.FileSystem.InterfaceMMap,+                         Conjure.FileSystem.InterfaceNaive, Conjure.Logic.BlockManagement, Conjure.Logic.PeerManager, Conjure.Logic.QueueManager,+                         Conjure.Network.Client, Conjure.Network.Peer, Conjure.Network.Server, Conjure.OptionParser, Conjure.Piecemap,+                         Conjure.Protocol.PWP, Conjure.Protocol.PWP.Parser, Conjure.Protocol.PWP.Printer,+                         Conjure.Protocol.PWP.Types, Conjure.Protocol.THP, Conjure.Protocol.THP.Parser, Conjure.Protocol.THP.Types, Conjure.STM.PeerCtrl,+                         Conjure.Torrent, Conjure.Types, Conjure.UI.Http, Conjure.Utils, Conjure.Utils.Logger,+                         Conjure.Utils.SHA1, Conjure.Utils.Shuffle, Conjure.Utils.Transaction, Conjure.Version++Executable conjure+       Hs-Source-Dirs:   src+       Main-is:          Conjure.hs+       Other-modules:    Conjure.Utils.Logger, Conjure.FileSystem.InterfaceMMap+       Extensions:       NoMonomorphismRestriction, CPP, GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses, ForeignFunctionInterface, TypeOperators+       C-Sources:        cbits/sha1.c

@@ -0,0 +1,231 @@+<?xml version="1.0" standalone="no"?> <!--*- mode: xml -*-->+<!DOCTYPE glade-interface SYSTEM "http://glade.gnome.org/glade-2.0.dtd">++<glade-interface>++<widget class="GtkWindow" id="download_info">+  <property name="visible">True</property>+  <property name="title" translatable="yes">$file - Conjurer $version</property>+  <property name="type">GTK_WINDOW_TOPLEVEL</property>+  <property name="window_position">GTK_WIN_POS_NONE</property>+  <property name="modal">False</property>+  <property name="resizable">True</property>+  <property name="destroy_with_parent">False</property>+  <property name="decorated">True</property>+  <property name="skip_taskbar_hint">False</property>+  <property name="skip_pager_hint">False</property>+  <property name="type_hint">GDK_WINDOW_TYPE_HINT_NORMAL</property>+  <property name="gravity">GDK_GRAVITY_NORTH_WEST</property>+  <property name="focus_on_map">True</property>++  <child>+    <widget class="GtkVBox" id="vbox1">+      <property name="border_width">4</property>+      <property name="visible">True</property>+      <property name="homogeneous">False</property>+      <property name="spacing">8</property>++      <child>+	<widget class="GtkHBox" id="hbox2">+	  <property name="visible">True</property>+	  <property name="homogeneous">False</property>+	  <property name="spacing">4</property>++	  <child>+	    <widget class="GtkVBox" id="vbox2">+	      <property name="visible">True</property>+	      <property name="homogeneous">False</property>+	      <property name="spacing">0</property>++	      <child>+		<widget class="GtkLabel" id="filename">+		  <property name="visible">True</property>+		  <property name="label" translatable="yes">filename</property>+		  <property name="use_underline">False</property>+		  <property name="use_markup">False</property>+		  <property name="justify">GTK_JUSTIFY_LEFT</property>+		  <property name="wrap">False</property>+		  <property name="selectable">False</property>+		  <property name="xalign">0.5</property>+		  <property name="yalign">0.5</property>+		  <property name="xpad">0</property>+		  <property name="ypad">0</property>+		  <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>+		  <property name="width_chars">-1</property>+		  <property name="single_line_mode">False</property>+		  <property name="angle">0</property>+		</widget>+		<packing>+		  <property name="padding">0</property>+		  <property name="expand">False</property>+		  <property name="fill">False</property>+		</packing>+	      </child>++	      <child>+		<widget class="GtkLabel" id="filesize">+		  <property name="visible">True</property>+		  <property name="label" translatable="yes">filesize</property>+		  <property name="use_underline">False</property>+		  <property name="use_markup">False</property>+		  <property name="justify">GTK_JUSTIFY_LEFT</property>+		  <property name="wrap">False</property>+		  <property name="selectable">False</property>+		  <property name="xalign">0.5</property>+		  <property name="yalign">0.5</property>+		  <property name="xpad">0</property>+		  <property name="ypad">0</property>+		  <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>+		  <property name="width_chars">-1</property>+		  <property name="single_line_mode">False</property>+		  <property name="angle">0</property>+		</widget>+		<packing>+		  <property name="padding">0</property>+		  <property name="expand">False</property>+		  <property name="fill">False</property>+		</packing>+	      </child>+	    </widget>+	    <packing>+	      <property name="padding">0</property>+	      <property name="expand">True</property>+	      <property name="fill">True</property>+	    </packing>+	  </child>++	  <child>+	    <placeholder/>+	  </child>++	  <child>+	    <widget class="GtkImage" id="image1">+	      <property name="visible">True</property>+	      <property name="pixbuf">white.ico</property>+	      <property name="xalign">0.5</property>+	      <property name="yalign">0.5</property>+	      <property name="xpad">0</property>+	      <property name="ypad">0</property>+	    </widget>+	    <packing>+	      <property name="padding">0</property>+	      <property name="expand">False</property>+	      <property name="fill">True</property>+	    </packing>+	  </child>+	</widget>+	<packing>+	  <property name="padding">0</property>+	  <property name="expand">False</property>+	  <property name="fill">False</property>+	</packing>+      </child>++      <child>+	<widget class="GtkVBox" id="vbox3">+	  <property name="border_width">4</property>+	  <property name="visible">True</property>+	  <property name="homogeneous">False</property>+	  <property name="spacing">4</property>++	  <child>+	    <widget class="GtkProgressBar" id="progressbar1">+	      <property name="visible">True</property>+	      <property name="orientation">GTK_PROGRESS_LEFT_TO_RIGHT</property>+	      <property name="fraction">0.300000011921</property>+	      <property name="pulse_step">0.10000000149</property>+	      <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>+	    </widget>+	    <packing>+	      <property name="padding">0</property>+	      <property name="expand">False</property>+	      <property name="fill">False</property>+	    </packing>+	  </child>++	  <child>+	    <widget class="GtkLabel" id="time">+	      <property name="visible">True</property>+	      <property name="label" translatable="yes">time elapsed / estimated : $elapsed / $estimated</property>+	      <property name="use_underline">False</property>+	      <property name="use_markup">False</property>+	      <property name="justify">GTK_JUSTIFY_LEFT</property>+	      <property name="wrap">False</property>+	      <property name="selectable">False</property>+	      <property name="xalign">0.5</property>+	      <property name="yalign">0.5</property>+	      <property name="xpad">0</property>+	      <property name="ypad">0</property>+	      <property name="ellipsize">PANGO_ELLIPSIZE_NONE</property>+	      <property name="width_chars">-1</property>+	      <property name="single_line_mode">False</property>+	      <property name="angle">0</property>+	    </widget>+	    <packing>+	      <property name="padding">0</property>+	      <property name="expand">False</property>+	      <property name="fill">False</property>+	    </packing>+	  </child>++	  <child>+	    <placeholder/>+	  </child>+	</widget>+	<packing>+	  <property name="padding">0</property>+	  <property name="expand">True</property>+	  <property name="fill">True</property>+	</packing>+      </child>++      <child>+	<widget class="GtkHBox" id="hbox1">+	  <property name="border_width">4</property>+	  <property name="visible">True</property>+	  <property name="homogeneous">True</property>+	  <property name="spacing">4</property>++	  <child>+	    <widget class="GtkButton" id="pause">+	      <property name="visible">True</property>+	      <property name="can_focus">True</property>+	      <property name="label" translatable="yes">Pause</property>+	      <property name="use_underline">True</property>+	      <property name="relief">GTK_RELIEF_NORMAL</property>+	      <property name="focus_on_click">True</property>+	    </widget>+	    <packing>+	      <property name="padding">0</property>+	      <property name="expand">True</property>+	      <property name="fill">False</property>+	    </packing>+	  </child>++	  <child>+	    <widget class="GtkButton" id="cancel">+	      <property name="visible">True</property>+	      <property name="can_focus">True</property>+	      <property name="label" translatable="yes">Cancel</property>+	      <property name="use_underline">True</property>+	      <property name="relief">GTK_RELIEF_NORMAL</property>+	      <property name="focus_on_click">True</property>+	    </widget>+	    <packing>+	      <property name="padding">0</property>+	      <property name="expand">True</property>+	      <property name="fill">False</property>+	    </packing>+	  </child>+	</widget>+	<packing>+	  <property name="padding">0</property>+	  <property name="expand">False</property>+	  <property name="fill">True</property>+	</packing>+      </child>+    </widget>+  </child>+</widget>++</glade-interface>

@@ -0,0 +1,3 @@+d8:announce30:http://localhost:8080/announce13:creation datei1131382864e4:infod6:lengthi377415e4:name19:pjlester-1.11.tar.Z12:piece lengthi32768e6:pieces240:¤ýl7)«+‰+eí¾¬¸Yäü€{ºR$Ç>KRÚËv­dÒñän…mt9›]ƒÓi†MŽ‚t#,øT7ÌMH­µ8®Áo<šwÌ+l@õ֊ÞønH¶ÝÅ É||8Œz£ò÷±Úϸ±P)«4b…Î܏eU5©
IÀ=ç£*ü#įFldâ|ö^®ß9Qԛլ -OXf44Šcо÷ë4±¥Ë±lañÊÀRÄhïå+!VTËn]¿`7ÙǍÍFB‘l¥ôF´Jvÿ­pgùSTøŠìèÈãm_7ÅQ*Éò2ð}pee

@@ -0,0 +1,189 @@+{-# LANGUAGE CPP #-}+{-+ Copyright (c) 2005 Jesper Louis Andersen <jlouis@mongers.org>+                    Lemmih <lemmih@gmail.com>++ Permission to use, copy, modify, and distribute this software for any+ purpose with or without fee is hereby granted, provided that the above+ copyright notice and this permission notice appear in all copies.++ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.+-}+-----------------------------------------------------------------------------+-- |+-- Module      :  BEncode.BEncode+-- Copyright   :  (c) Jesper Louis Andersen, 2005. (c) Lemmih, 2005-2006+-- License     :  BSD-style+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  believed to be stable+-- Portability :  portable+--+-- Provides a BEncode data type is well as functions for converting this+-- data type to and from a String.+--+-- Also supplies a number of properties which the module must satisfy.+-----------------------------------------------------------------------------+module BEncode.BEncode+  (+   -- * Data types+   BEncode(..),+   -- * Functions+   bRead,+   bShow,+  )+where++import qualified Data.Map as Map+import Data.Map (Map)+import Text.ParserCombinators.Parsec+import qualified Data.ByteString.Char8 as BS++import Data.ByteString (ByteString)++import BEncode.BLexer ( Token (..), lexer )++#ifdef __CABAL_TEST__+import Test.QuickCheck+import Control.Monad+#endif+++type BParser a = GenParser Token () a++{- | The B-coding defines an abstract syntax tree given as a simple+     data type here+-}+data BEncode = BInt Int+             | BString ByteString+             | BList [BEncode]+             | BDict (Map String BEncode)+               deriving (Eq, Ord, Show)++-- Source position is pretty useless in BEncoded data.+updatePos :: t -> t1 -> t2 -> t+updatePos pos _ _ = pos++bToken :: Token -> BParser ()+bToken t = tokenPrim show updatePos fn+    where fn t' | t' == t = Just ()+          fn _ = Nothing++token' :: (Token -> Maybe a) -> BParser a+token' = tokenPrim show updatePos++tnumber :: BParser Int+tnumber = token' fn+    where fn (TNumber i) = Just i+          fn _ = Nothing++tstring :: BParser ByteString+tstring = token' fn+    where fn (TString str) = Just str+          fn _ = Nothing++withToken :: Token -> BParser a -> BParser a+withToken tok+    = between (bToken tok) (bToken TEnd)++--------------------------------------------------------------+--------------------------------------------------------------++bInt :: BParser BEncode+bInt = withToken TInt $ fmap BInt tnumber++bString :: BParser BEncode+bString = fmap BString tstring++bList :: BParser BEncode+bList = withToken TList $ fmap BList (many bParse)++bDict :: BParser BEncode+bDict = withToken TDict $ fmap (BDict . Map.fromAscList) (many1 bAssocList)+    where bAssocList+              = do str <- tstring+                   value <- bParse+                   return (BS.unpack str,value)++bParse :: BParser BEncode+bParse = bDict <|> bList <|> bString <|> bInt++-- | bRead is a conversion routine. It assumes a B-coded string as input+--   and attempts a parse of it into a BEncode data type+bRead :: ByteString -> Maybe BEncode+bRead str = case parse bParse "" (lexer str) of+             Left _err -> Nothing+             Right b   -> Just b++-- | Render a BEncode structure to a B-coded string+bShow :: BEncode -> ShowS+bShow be = bShow' be+  where+    sc = showChar+    ss = showString+    sKV (k,v) = sString k (length k) . bShow' v+    sDict dict = foldr (.) id (map sKV (Map.toAscList dict))+    sList list = foldr (.) id (map bShow' list)+    sString str len = shows len . sc ':' . ss str+    bShow' b =+      case b of+        BInt i    -> sc 'i' . shows i . sc 'e'+        BString s -> sString (BS.unpack s) (BS.length s)+        BList bl  -> sc 'l' . sList bl . sc 'e'+        BDict bd  -> sc 'd' . sDict bd . sc 'e'++++++++++++--------------------------------------------------------------+-- Tests+--------------------------------------------------------------+#ifdef __CABAL_TEST__++arbitraryBStr :: Int -> Gen ByteString+arbitraryBStr len+    = fmap BS.pack (replicateM len (elements ['\0' .. '\255']))++instance Arbitrary BS.ByteString where+    arbitrary = sized $ \n -> arbitraryBStr =<< choose (1,n)+    coarbitrary = undefined++instance Arbitrary Char where+  arbitrary = elements "abcdefghijklmopqstuvwzyx"+  coarbitrary = undefined++instance (Arbitrary k, Ord k+         ,Arbitrary a ) => Arbitrary (Map.Map k a) where+    arbitrary = sized $ \n ->+                do x <- arbitrary+                   xs <- resize (n `div` 2) arbitrary+                   return (Map.fromList (x:xs))+    coarbitrary = undefined++instance Arbitrary BEncode where+    coarbitrary = undefined+    arbitrary = sized $ \n ->+                oneof+                [ liftM BInt arbitrary+                , liftM BString arbitrary+                , liftM BList (resize (n `div` 2) arbitrary)+                , liftM BDict arbitrary ]++_prop_identity :: BEncode -> Bool+_prop_identity bencode+    = maybe False (== bencode) $ bRead (BS.pack (bShow bencode ""))++#endif

@@ -0,0 +1,56 @@+{-++ Copyright (c) 2005 Jesper Louis Andersen <jlouis@mongers.org>++ Permission to use, copy, modify, and distribute this software for any+ purpose with or without fee is hereby granted, provided that the above+ copyright notice and this permission notice appear in all copies.++ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.++-}+-----------------------------------------------------------------------------+-- |+-- Module      :  BEncode.BEncodePP+-- Copyright   :  (c) Jesper Louis Andersen, 2005+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  jlouis@mongers.org+-- Stability   :  believed to be stable+-- Portability :  portable+-- +-- This module provides Pretty-printing of BEncoded strings+-----------------------------------------------------------------------------+module BEncode.BEncodePP +  (+   pp+  ) +where++import BEncode.BEncode++import qualified Data.Map+import Text.PrettyPrint++-- | Convert a BEncoded AST into a Document of the type we can +--   pretty-print+ppBEncode :: BEncode -> Doc+ppBEncode benc = +  case benc of+    BInt i -> parens $ (text "INT") <> (brackets $ text $ show i)+    BString str -> parens $ (text "STRING") <> (brackets $ text $ show str)+    BList blst -> brackets . hsep $ map ppBEncode blst+    BDict mp -> +     braces $ vcat $ +       map (\ (k, v) -> parens $ text k <> comma <+> ppBEncode v)+	   (Data.Map.toList mp)++-- | Render a BEncoded AST into a (humanly readable) String.+pp :: BEncode -> String+pp = render . ppBEncode

@@ -0,0 +1,41 @@+module BEncode.BLexer where++import Data.Char++import qualified Data.ByteString.Char8 as BS+import Data.ByteString (ByteString)++data Token+    = TDict+    | TList+    | TInt+    | TString ByteString+    | TNumber Int+    | TEnd+      deriving (Show,Eq)+++lexer :: ByteString -> [Token]+lexer ps | BS.null ps = []+lexer ps+    = case ch of+        'd' -> TDict : lexer rest+        'l' -> TList : lexer rest+        'i' -> TInt  : lexer rest+        'e' -> TEnd  : lexer rest+        '-' -> let (digits,rest') = BS.span isDigit rest+                   number = read (BS.unpack digits)+               in TNumber (-number) : lexer rest'+        _ | isDigit ch+              -> let (digits,rest') = BS.span isDigit ps+                     number = read (BS.unpack digits)+                 in if BS.null rest'+                       then [TNumber number]+                       else case BS.head rest' of+                              ':' -> let (str, rest'') = BS.splitAt number (BS.tail rest')+                                     in TString str : lexer rest''+                              _ -> TNumber number : lexer rest'+          | otherwise -> error $ "Lexer error: " ++ show (BS.unpack ps)+    where ch = BS.head ps+          rest = BS.tail ps+

@@ -0,0 +1,120 @@+{-# LANGUAGE PatternGuards #-}+{-+ Copyright (c) 2005 Lemmih <lemmih@gmail.com>++ Permission to use, copy, modify, and distribute this software for any+ purpose with or without fee is hereby granted, provided that the above+ copyright notice and this permission notice appear in all copies.++ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.+-}+-----------------------------------------------------------------------------+-- |+-- Module      :  BEncode.BParser+-- Copyright   :  (c) Lemmih, 2005+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  stable+-- Portability :  portable+--+-- A parsec style parser for BEncoded data+-----------------------------------------------------------------------------+module BEncode.BParser+    ( BParser+    , runParser+    , token+    , dict+    , list+    , optional+    , bstring+    , bfaststring+    , bint+    , setInput+    , (<|>)+    ) where++import BEncode.BEncode+import qualified Data.Map as Map+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import Control.Monad++data BParser a+    = BParser (BEncode -> Reply a)++runB :: BParser a -> BEncode -> Reply a+runB (BParser b) = b++data Reply a+    = Ok a BEncode+    | Error String++instance Monad BParser where+    (BParser p) >>= f = BParser $ \b -> case p b of+                                          Ok a b' -> runB (f a) b'+                                          Error str -> Error str+    return val = BParser $ Ok val+    fail str = BParser $ \_ -> Error str++(<|>) :: BParser a -> BParser a -> BParser a+(BParser b1) <|> (BParser b2)+        = BParser $ \b -> case b1 b of+                            Ok a b' -> Ok a b'+                            _ -> b2 b++runParser :: BParser a -> BEncode -> Either String a+runParser parser b = case runB parser b of+                       Ok a _ -> Right a+                       Error str -> Left str++token :: BParser BEncode+token = BParser $ \b -> Ok b b++dict :: String -> BParser BEncode+dict name = BParser $ \b -> case b of+                              BDict bmap | Just code <- Map.lookup name bmap+                                   -> Ok code b+                              BDict _ -> Error $ "Name not found in dictionary: " ++ name+                              _ -> Error $ "Not a dictionary: " ++ name++list :: String -> BParser a -> BParser [a]+list name p+    = dict name >>= \lst ->+      BParser $ \b -> case lst of+                      BList bs -> foldr cat (Ok [] b) (map (runB p) bs)+                      _ -> Error $ "Not a list: " ++ name+    where cat (Ok v _) (Ok vs b) = Ok (v:vs) b+          cat (Ok _ _) (Error str) = Error str+          cat (Error str) _ = Error str++optional :: BParser a -> BParser (Maybe a)+optional p = liftM Just p <|> return Nothing++bstring :: BParser BEncode -> BParser String+bstring p = do b <- p+               case b of+                 BString str -> return (BS.unpack str)+                 _ -> fail $ "Expected BString, found: " ++ show b++bfaststring :: BParser BEncode -> BParser ByteString+bfaststring p = do b <- p+                   case b of+                     BString str -> return str+                     _ -> fail $ "Expected BString, found: " ++ show b++bint :: BParser BEncode -> BParser Int+bint p = do b <- p+            case b of+              BInt int -> return int+              _ -> fail $ "Expected BInt, found: " ++ show b++setInput :: BEncode -> BParser ()+setInput b = BParser $ \_ -> Ok () b+

@@ -0,0 +1,86 @@+{-# LANGUAGE CPP #-}+{-+ Copyright (c) 2005-2006 Lemmih <lemmih@gmail.com>++ Permission to use, copy, modify, and distribute this software for any+ purpose with or without fee is hereby granted, provided that the above+ copyright notice and this permission notice appear in all copies.++ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.+-}+-----------------------------------------------------------------------------+-- C O N J U R E+--+-- How small a Bittorrent implementation can you actually do?+--+-- The current Bittorrent implementation is about 10.000 lines. Let us+-- beat that by lengths.+-----------------------------------------------------------------------------+module Main (main,run) where++import Conjure.Torrent+import Conjure.Network.Client+import Conjure.FileSystem.Interface as Interface+import Conjure.Logic.PeerManager+import Conjure.Network.Server+import Conjure.UI.Http+import Conjure.OptionParser+import Conjure.Utils.Logger+import Conjure.Debug++import Control.Concurrent+import Control.Concurrent.STM+import System.Environment (getArgs)+import Control.Monad (when)+import Control.Exception (finally)+#ifndef mingw32_HOST_OS+import System.Posix+#endif++import qualified Data.Map as Map+-- import Data.Map (Map)++-- FIXME: Logger options and log mask should be configurable.+main = do putStrLn "Conjure!"+#ifndef mingw32_HOST_OS+          installHandler sigPIPE Ignore Nothing+#endif+          openlog [PError] "conjure"+          initSTMLogger+          (args, files) <- (getArgs >>= getOpts)+          when (not $ null files) (run $ head files)+          closelog+          return ()++-- FIXME: This is only a temporary function.+--        We only need a single connPeer list, server, wantedDownload, wantedUploads and torrentMap+--        for all torrents.+run torrentPath+    = do mbTorrent <- readTorrentFile torrentPath+         case mbTorrent of+           Left err -> putStrLn err+           Right torrent+               -> do connectedPeers <- atomically $ newTVar []+                     seedingPeers <- atomically $ newTVar []+                     torrentMap <- atomically $ newTVar (Map.empty)+                     nSecs      <- atomically $ newTVar 10+                     -- Options:   Max peers, max downloads, max uploads, min optimistic+                     opts       <- atomically $ newTVar (50, 20, 10, 2)+                     forkIO (runMainChoker nSecs connectedPeers opts)+                     forkIO (httpServer connectedPeers torrentMap uiPort)+                     tid <- forkIO $ runServer connectedPeers torrentMap port+                     backend <- Interface.defaultOpen torrent+                     runClient port connectedPeers torrentMap torrent backend+                     atomically retry+                       `finally` do putStrLn "Shutting down."+                                    killThread tid+                                    shutdownAll torrentMap+                                    putStrLn "Done."+    where port = 3000+          uiPort = 3080

@@ -0,0 +1,8 @@+module Conjure.Constants where++-- FIXME: this should be configurable.+blockSize :: Int+blockSize = 2^(14::Int)+++

@@ -0,0 +1,84 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.Debug+-- Copyright   :  (c) ADEpt 2005+-- License     :  BSD-like+--+-- Maintainer  :  adept@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-----------------------------------------------------------------------------+-- TODO: make it not THAT trivial+module Conjure.Debug+    ( debug+    , initSTMLogger+    , stmTransactionName+    , stmDebug+    ) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception+import Control.Monad+import System.IO.Unsafe+import GHC.Conc                   ( unsafeIOToSTM )++import qualified Data.Map as Map+import Data.Map ( Map )++import Conjure.Utils.Logger()++debug :: String -> IO ()+debug = putStrLn -- syslog Debug+++--------------------------------------------------------------+-- Non-portable STM debugger+--------------------------------------------------------------++{-# NOINLINE stmLog #-}+stmLog :: TVar (Map ThreadId (String, [String]))+stmLog = unsafePerformIO (newTVarIO Map.empty)++initSTMLogger :: IO ()+initSTMLogger+    = do evaluate stmLog+         forkIO $ loop $+           do msgs <- atomically $+                      do msgs <- readTVar stmLog+                         when (Map.null msgs) retry+                         writeTVar stmLog Map.empty+                         return (Map.elems msgs)+              mapM_ printMsg msgs+         debug "STMLogger initialized"+    where loop fn = fn >> loop fn+          printMsg (name,strs)+              | null strs+                  = return ()+              | null name+                  = mapM_ putStrLn (reverse strs)+              | otherwise+                  = do putStrLn (name++":")+                       mapM_ (\str -> putStr "  " >> putStrLn str) (reverse strs)++stmTransactionName :: String -> STM ()+stmTransactionName name+    = do tid <- unsafeIOToSTM myThreadId+         msgs <- readTVar stmLog+         case Map.lookup tid msgs of+           Nothing -> writeTVar stmLog (Map.singleton tid (name,[]))+           Just (name',strs)+               | null name'+                   -> writeTVar stmLog (Map.singleton tid (name,strs))+               | otherwise+                   -> retry++stmDebug :: String -> STM ()+stmDebug str+    = do tid <- unsafeIOToSTM myThreadId+         msgs <- readTVar stmLog+         writeTVar stmLog (Map.insertWith joinInfo tid ("",[str]) msgs)+    where joinInfo ("",[string]) (name,strings) = (name,string:strings)+          joinInfo (name,strings) ("",[string]) = (name,string:strings)+

@@ -0,0 +1,28 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.FileSystem.Interface+-- Copyright   :  (c) Lemmih 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-----------------------------------------------------------------------------+module Conjure.FileSystem.Interface+    ( defaultOpen+    , backends+    ) where++import Conjure.Types++import Conjure.FileSystem.InterfaceNaive as Naive+import Conjure.FileSystem.InterfaceMMap as MMap++defaultOpen :: Torrent -> IO Backend+defaultOpen = Naive.open++backends :: [ (String, Torrent -> IO Backend) ]+backends = [ ("Naive", Naive.open)+           , ("MMap",  MMap.open) ]+

@@ -0,0 +1,187 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.FileSystem.InterfaceMMap+-- Copyright   :  (c) Lemmih 2006+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable (requires posix)+--+-- Fast mmap based backend.+-----------------------------------------------------------------------------+module Conjure.FileSystem.InterfaceMMap where+{-    ( open+    ) where -}++#include <unistd.h>+#ifndef _POSIX_MAPPED_FILES++open :: Torrent -> IO Backend+open = error "Conjure.FileSystem.InterfaceMMap.open: mmap backend not available"++#else++#include <sys/mman.h>++import Conjure.Torrent+import Conjure.Types++import System.IO+import Data.List+import Data.Maybe+import Control.Monad+import Control.Exception+import Foreign+import Foreign.C++import System.FilePath++import System.Posix++import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BS+import qualified Data.ByteString.Unsafe as BS (unsafeUseAsCStringLen)+import Data.ByteString (ByteString)++open :: Torrent -> IO Backend+open torrent+    = do mmapped <- mapM (uncurry mmap) files+         return $ Backend+                    { close       = mapM_ (munmap . mmapBS) mmapped+                    , readPiece   = mmapReadPiece torrent mmapped+                    , readPiece'  = mmapReadPiece' torrent mmapped+                    , writeBlock  = mmapWriteBlock torrent mmapped+                    , readBlock   = mmapReadBlock torrent mmapped+                    , commitPiece = mmapCommitPiece torrent mmapped+                    }+  where files = case tInfo torrent of+                  SingleFile {tName=name,tLength=len} -> [(name,len)]+                  MultiFile {tName=name,tFiles=files} -> map (\f -> (name </> filePath f,fileLength f)) files+++mmapReadPiece :: Torrent -> [MMapped] -> Int -> IO ByteString+mmapReadPiece torrent mmapped pieceNum+    = fmap (fromMaybe $ error msg) (mmapReadPiece' torrent mmapped pieceNum)+    where msg = "Failed to read piece."++mmapReadPiece' :: Torrent -> [MMapped] -> Int -> IO (Maybe ByteString)+mmapReadPiece' torrent mmapped pieceNum+    = readFromTorrent' mmapped entities+      where entities = getPieceFilePaths torrent pieceNum++mmapWriteBlock :: Torrent -> [MMapped] -> Int -> Int -> ByteString -> IO ()+mmapWriteBlock torrent mmapped pieceNum offset block+    = worker block entries+    where entries = getBlockFilePaths torrent pieceNum offset (BS.length block)+          worker str [] = assert (BS.null str) $ return ()+          worker str ((path, start, size):xs)+              = do let block = getMMapped mmapped path+                   assureSize block (start+size)+                   writeData (BS.drop start $ mmapBS block) (BS.take size str)+                   worker (BS.drop size str) xs++mmapReadBlock :: Torrent -> [MMapped] -> Int -> Int -> Int -> IO ByteString+mmapReadBlock torrent mmapped pieceNum offset len+    = readFromTorrent mmapped entities+    where entities = getBlockFilePaths torrent pieceNum offset len++mmapCommitPiece :: Torrent -> [MMapped] -> Int -> IO ()+mmapCommitPiece torrent mmapped pieceNum+    = forM_ entities $ \(path, _, _) ->+      do let block = getMMapped mmapped path+         msync (mmapBS block)+    where entities = getPieceFilePaths torrent pieceNum++--------------------------------------------------------------+-- Utilities+--------------------------------------------------------------++getMMapped :: [MMapped] -> FilePath -> MMapped+getMMapped mmapped path = fromMaybe err $ find (\m -> mmapPath m == path) mmapped+    where err = error $ "Failed to locate mmapped file: " ++ path+++readFromTorrent :: [MMapped]+                -> [(FilePath, Int, Int)]+                -> IO ByteString+readFromTorrent mmapped entities+    = do mbBlock <- readFromTorrent' mmapped entities+         case mbBlock of+           Just block -> return block+           Nothing    -> error "Failed to read data block."++readFromTorrent' :: [MMapped]-> [(FilePath, Int, Int)] -> IO (Maybe ByteString)+readFromTorrent' mmapped entities+    = reader entities []+    where reader [] acc = return (Just (BS.concat (reverse acc)))+          reader ((path, start, size):xs) acc+              = do let block = getMMapped mmapped path+                   fSize <- liftM (fromIntegral.fileSize) $ getFdStatus (mmapFd block)+                   if (fSize < start+size)+                      then return Nothing+                      else reader xs (BS.take size (BS.drop start (mmapBS block)):acc)++++--------------------------------------------------------------+-- MMap functions+--------------------------------------------------------------++prot_read, prot_write, map_shared :: (Num t) => t+prot_read = #{const PROT_READ}+prot_write = #{const PROT_WRITE}++map_shared = #{const MAP_SHARED}++foreign import ccall unsafe "mmap" c_mmap :: Ptr a -> CSize -> CInt -> CInt -> CInt -> COff -> IO (Ptr b)+foreign import ccall unsafe "munmap" c_munmap :: Ptr a -> CSize -> IO CInt+foreign import ccall unsafe "msync" c_msync :: Ptr a -> CSize -> CInt -> IO CInt++data MMapped =+    MMapped { mmapFd   :: Fd+            , mmapPath :: FilePath+            , mmapBS   :: ByteString+            }++assureSize :: MMapped -> Int -> IO ()+assureSize block minsize+    = do status <- getFdStatus (mmapFd block)+         let size = fromIntegral $ fileSize status+         when (minsize > size)+            $ setFdSize (mmapFd block) (fromIntegral minsize)+++writeData :: ByteString -> ByteString -> IO ()+writeData desc src+    = BS.unsafeUseAsCStringLen desc $ \(descAddr,descLen) ->+      BS.unsafeUseAsCStringLen src $ \(srcAddr,srcLen) ->+      do BS.memcpy (castPtr descAddr) (castPtr srcAddr) (fromIntegral $ min descLen srcLen)+         return ()++mmap :: FilePath -> Int -> IO MMapped+mmap path length+    = do Fd fd <- openFd path ReadWrite Nothing defaultFileFlags{append = True}+         addr <- c_mmap nullPtr (fromIntegral length) (prot_read .|. prot_write) map_shared fd 0+         return =<< (liftM $ MMapped (Fd fd) path) (BS.packCStringLen (addr, length))+++munmap :: ByteString -> IO ()+munmap bs+    = BS.unsafeUseAsCStringLen bs $ \(addr,len) ->+      do c_munmap addr (fromIntegral len)+         return ()++ms_sync, ms_async, ms_invalidate :: (Num t) => t+ms_sync = #{const MS_SYNC}+ms_async = #{const MS_ASYNC}+ms_invalidate = #{const MS_INVALIDATE}++msync :: ByteString -> IO ()+msync bs+    = BS.unsafeUseAsCStringLen bs $ \(addr,len) ->+      do c_msync (castPtr addr) (fromIntegral len) ms_sync+         return ()++#endif

@@ -0,0 +1,138 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.FileSystem.InterfaceNaive+-- Copyright   :  (c) Lemmih 2005-2006+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Naive filesystem interface. This backend tries to be as+-- portable as possible.+-----------------------------------------------------------------------------+module Conjure.FileSystem.InterfaceNaive+    ( open+    ) where++import Conjure.Torrent              ( getPieceFilePaths+                                    , getBlockFilePaths )+import Conjure.Types++import System.IO+import Data.Map (Map)+import Data.Maybe+import Control.Monad                ( liftM, when, join )+import qualified Data.Map as Map+import Control.Concurrent+import Control.Exception+import Foreign                      ( mallocForeignPtrArray+                                    , withForeignPtr, advancePtr )+++import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BS+import Data.ByteString (ByteString)++type Handles = MVar (Map FilePath Handle)++open :: Torrent -> IO Backend+open torrent+    = do handles <- newMVar Map.empty+         return $ Backend+                    { close       = naiveClose handles+--                    , sendPiece = naiveSendPiece torrent handles+                    , readPiece   = naiveReadPiece torrent handles+                    , readPiece'  = naiveReadPiece' torrent handles+                    , writeBlock  = naiveWriteBlock torrent handles+                    , readBlock   = naiveReadBlock torrent handles+                    , commitPiece = const (return ())+                    }++naiveClose :: Handles -> IO ()+naiveClose mvar+    = modifyMVar_ mvar $ \handleMap ->+        do mapM_ hClose (Map.elems handleMap)+           return (Map.empty)++naiveSendPiece :: Torrent -> Handles -> Int -> Handle -> IO ()+naiveSendPiece torrent handles pieceNum peer+    = do piece <- naiveReadPiece torrent handles pieceNum+         BS.hPut peer piece+         -- force finalization of the piece?++naiveReadPiece :: Torrent -> Handles -> Int -> IO ByteString+naiveReadPiece torrent handles pieceNum+    = fmap (fromMaybe $ error msg) (naiveReadPiece' torrent handles pieceNum)+    where msg = "Failed to read piece."++naiveReadPiece' :: Torrent -> Handles -> Int -> IO (Maybe ByteString)+naiveReadPiece' torrent handles pieceNum+    = readFromTorrent' handles entities+      where entities = getPieceFilePaths torrent pieceNum++naiveWriteBlock :: Torrent -> Handles -> Int -> Int -> ByteString -> IO ()+naiveWriteBlock torrent handles pieceNum offset block+    = worker block entries+    where entries = getBlockFilePaths torrent pieceNum offset (BS.length block)+          worker str [] = assert (BS.null str) $ return ()+          worker str ((path, start, size):xs)+              = do withFileHandle handles path $ \handle ->+                       do prepareHandle handle start size+                          BS.hPut handle (BS.take size str)+                   worker (BS.drop size str) xs++naiveReadBlock :: Torrent -> Handles -> Int -> Int -> Int -> IO ByteString+naiveReadBlock torrent handles pieceNum offset len+    = readFromTorrent handles entities+    where entities = getBlockFilePaths torrent pieceNum offset len+++--------------------------------------------------------------+-- Utilities+--------------------------------------------------------------++withFileHandle :: Handles -> FilePath -> (Handle -> IO a) -> IO a+withFileHandle mvar path action+    = modifyMVar mvar $ \handleMap ->+        case Map.lookup path handleMap of+          Just handle -> do a <- action handle+                            return (handleMap, a)+          Nothing -> do handle <- openFile path ReadWriteMode+                        a <- action handle+                        return (Map.insert path handle handleMap, a)++prepareHandle :: Handle -> Int -> Int -> IO ()+prepareHandle handle pos len+    = do size <- liftM fromIntegral $ hFileSize handle+         when (size < pos+len)+            $ hSetFileSize handle (fromIntegral $ pos+len)+         hSeek handle AbsoluteSeek (fromIntegral pos)+++readFromTorrent :: Handles+                -> [(FilePath, Int, Int)]+                -> IO ByteString+readFromTorrent handles entities+    = do mbBlock <- readFromTorrent' handles entities+         case mbBlock of+           Just block -> return block+           Nothing    -> error "Failed to read data block."++readFromTorrent' :: Handles+                 -> [(FilePath, Int, Int)] -- ^ Block information.+                 -> IO (Maybe ByteString)+readFromTorrent' handles entities+    = do fp <- mallocForeignPtrArray len+         let reader [] _ = return (Just (BS.fromForeignPtr fp 0 len))+             reader ((path, start, size):xs) ptr+              = join $+                withFileHandle handles path $ \handle ->+                       do fSize <- liftM fromIntegral $ hFileSize handle+                          if (fSize < start+size)+                             then return (return Nothing)+                             else do hSeek handle AbsoluteSeek (fromIntegral start)+                                     hGetBuf handle ptr size+                                     return (reader xs (ptr `advancePtr` size))+         withForeignPtr fp (reader entities)+    where len = sum [ pSize | (_,_,pSize) <- entities ]

@@ -0,0 +1,213 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.Logic.BlockManagement+-- Copyright   :  (c) Lemmih 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable (requires STM)+--+-- The module serves as an intermedium between the backend (harddisk)+-- and the frontend (network), providing relevant blocks and+-- validating completed pieces.+-- A block can either be 'Active' or 'Downloaded'.+-- When a peer finishes a block, the blockmanager sends out a cancel signal+-- to the other peers downloading the same block. And once a piece is fully+-- downloaded, the blockmanager spawns a validator thread. If the piece is+-- successfully validated then the local piecemap is updated. If the+-- validation fails then all the blocks are reset to (Active []).+-- The piece picker works by overlapping the pieces we want with the pieces+-- the remote peer got, sorting that list by rarest first and then picking+-- the block with the lowest score. Score is the number of peers engaged in+-- active download of the block.+-----------------------------------------------------------------------------+module Conjure.Logic.BlockManagement+    ( findInterestingPieces -- :: ActiveTorrent -> ConnectedPeer -> STM [Int]+    , registerNewBlock      -- :: ConnectedPeer -> Torrent -> Piece -> Int -> STM (Int,Int)+    , requestNewBlock       -- :: ActiveTorrent -> ConnectedPeer -> STM (Maybe Block)+    , abandonBlock          -- :: ActiveTorrent -> ConnectedPeer -> Block -> STM ()+    , registerBlock         -- :: ActiveTorrent -> ConnectedPeer -> Block -> ByteString -> IO (Maybe Block)+    ) where++import Conjure.Types+import Conjure.Utils.Transaction+import Conjure.Utils+import Conjure.Protocol.PWP.Types+import Conjure.Debug+import Conjure.STM.PeerCtrl+import Conjure.Torrent                     ( pieceLength, pieceCheckSum )+import Conjure.Constants                   ( blockSize )+import Conjure.Piecemap                    ( findNewPieces, setPiecemapBit+                                           , orderPieces )+import Conjure.Utils.SHA1                  ( sha1 )++import Control.Concurrent                  ( forkIO )+import Control.Concurrent.STM+import Control.Exception                   ( assert )+import Control.Monad                       ( when )+import System.Random                       ( mkStdGen )+import Data.List+import Data.Ord                            ( comparing )+import Data.Array.IArray                   ( (!) )+import qualified Data.IntMap as IntMap++import qualified Data.ByteString as BS+import Data.ByteString (ByteString)++import qualified Data.Map as Map         ( delete, lookup )++--------------------------------------------------------------+--------------------------------------------------------------+++-- FIXME: We never update the usecount.+findInterestingPieces :: ActiveTorrent -> ConnectedPeer -> STM [Int]+findInterestingPieces at (ConnectedPeer {cpPiecemap = remotePiecemap})+    = do started   <- readTVar (atPieces at)+         usecount  <- readTVar (atUsecount at)+         ourpieces <- readTVar (atPiecemap at)+         remote  <- readTVar remotePiecemap+         -- FIXME: constant stdGen.+         return (filter (remote!) (IntMap.keys started) -- prefer already started pieces+                 ++ orderPieces (mkStdGen 42) usecount (findNewPieces ourpieces remote))++registerNewBlock :: ConnectedPeer -> Torrent -> Piece -> Int -> STM (Int,Int)+registerNewBlock connPeer torrent piece blockIdx+    = do modifyTVar_ (pStatus piece) (worker blockIdx)+         let offset = blockIdx * blockSize+         return (offset,min blockSize (pieceLength torrent (pIndex piece) - offset))+    where worker _ [] = error "Block index overflow"+          worker 0 (Downloaded:_)+              = error "Tried to start download at an already downloaded block"+          worker 0 (Active peers:xs)+              = Active (connPeer:peers):xs+          worker n (x:xs)+              = x:worker (n-1) xs++withPieceStatus :: ([BlockStatus] -> a) -> Piece -> STM a+withPieceStatus ac piece+    = do status <- readTVar (pStatus piece)+         return (ac status)++getPieceScore :: ConnectedPeer -> Piece -> STM (Int,Int)+getPieceScore peer = withPieceStatus (minimumBy (comparing snd) . zip [0..] . map getScore)+    where getScore Downloaded = maxBound+          getScore (Active lst)+                   | peer `elem` lst = maxBound+                   | otherwise = length lst++isCompletedPiece :: Piece -> STM Bool+isCompletedPiece = withPieceStatus (all isDownloaded)+    where isDownloaded Downloaded = True+          isDownloaded _ = False++requestNewBlock :: ActiveTorrent -> ConnectedPeer -> STM (Maybe Block)+requestNewBlock at connPeer+    = do pieces    <- readTVar (atPieces at)+         let mkNewPiece idx+                 = do status <- newTVar (emptyStatus idx)+                      let piece = Piece idx status+                      writeTVar (atPieces at) (IntMap.insert idx piece pieces)+                      return piece+             findGoodPiece [] (prevPiece, prevScore, prevBlockIdx)+                 | prevScore == maxBound = return Nothing+                 | otherwise = fmap Just (registerFromPiece prevPiece prevBlockIdx)+             findGoodPiece (x:xs) (prevPiece, prevScore, prevBlockIdx)+                 = case IntMap.lookup x pieces of+                     Nothing ->+                         do piece <- mkNewPiece x+                            fmap Just (registerFromPiece piece 0)+                     Just piece ->+                         do (blockIdx,score) <- getPieceScore connPeer piece+                            case score of+                              0 -> fmap Just (registerFromPiece piece blockIdx)+                              _ | score < prevScore+                                    -> findGoodPiece xs (piece, score, blockIdx)+                                | otherwise+                                    -> findGoodPiece xs (prevPiece, prevScore, prevBlockIdx)+         pieceLst <- findInterestingPieces at connPeer+         findGoodPiece pieceLst (undefined, maxBound, undefined)+    where emptyStatus idx = let intDiv a b = (a+b-1) `div` b+                                nBlocks = pieceLength (atTorrent at) idx `intDiv` blockSize+                            in replicate nBlocks (Active [])+          registerFromPiece piece blockidx+              = do (blockidx, blockLen) <- registerNewBlock connPeer (atTorrent at) piece blockidx+                   return (piece, blockidx, blockLen)++--------------------------------------------------------------+--------------------------------------------------------------++-- | Claim the completed block for your own and tell the other+-- downloaders to cancel their download.+claimCompletedBlock :: ConnectedPeer -> Block -> STM Bool+claimCompletedBlock connPeer block@(piece, offset, _)+    = do status <- readTVar (pStatus piece)+         let (status', peers, first) = mkNewStatus 0 [] status+         writeTVar (pStatus piece) status'+         flip mapM_ (filter (/=connPeer) peers) $ \peer ->+             do sendCancel peer block+                modifyTVar_ (cpPendingBlocks peer) (Map.delete (pIndex piece, offset))+         return first+    where mkNewStatus _ _ [] = error "Walked through piece status without hitting the wanted offset: mkNewStatus"+          mkNewStatus n ac (x:xs)+              | n == offset+                  = case x of+                      Active peers -> (reverse ac ++ Downloaded:xs,peers,True)+                      _ -> (reverse ac ++ Downloaded:xs,[], False)+              | otherwise+                  = mkNewStatus (n+blockSize) (x:ac) xs++abandonBlock :: ConnectedPeer -> Block -> STM ()+abandonBlock connPeer (piece, offset, _)+    = modifyTVar_ (pStatus piece) $ abandonPeer 0+    where abandonPeer _ [] = error "Walked through piece status without hitting the wanted offset: abandonBlock"+          abandonPeer n (x:xs)+              | n == offset = case x of+                                Active peers+                                    -> assert (connPeer `elem` peers) $+                                       Active (filter (/=connPeer) peers):xs+                                _ -> error "Tried to abort download of a block which wasn't being downloaded"+              | otherwise = x:abandonPeer (n+blockSize) xs++--------------------------------------------------------------+--------------------------------------------------------------+++-- | Register a block as downloaded and, if possible, validate the+-- complete piece.++registerBlock :: ActiveTorrent -> ConnectedPeer -> (Int,Int,Int) -> ByteString -> Transaction ()+registerBlock at connPeer (idx, offset, _) blockData+    = do blocks <- stm $ readTVar (cpPendingBlocks connPeer)+         case Map.lookup (idx,offset) blocks of+           Nothing -> onCommit (debug "Received unexpected block, ignored.")+           Just block+               -> do first <- stm $ claimCompletedBlock connPeer block+                     stm $ writeTVar (cpPendingBlocks connPeer) (Map.delete (idx,offset) blocks)+                     when first+                       $ do let (piece,_,_) = block+                            isComplete <- stm $ isCompletedPiece piece+                            onCommit $ do writeBlock (atBackend at) idx offset blockData+                                          forkIO $ when isComplete $ validatePiece at idx offset++validatePiece :: ActiveTorrent -> Int -> Int -> IO ()+validatePiece at idx _+    = do pieceData <- readPiece (atBackend at) idx+         let pieceLen = fromIntegral (BS.length pieceData)+         if sha1 pieceData == pieceCheckSum torrent idx+            then commitPiece (atBackend at) idx >>+                 atomically (+                 do setPiecemapBit (atPiecemap at) idx True+                    modifyTVar_ (atPieces at) (IntMap.delete idx)+                    modifyTVar_ (atDownloaded at) (+ pieceLen)+                    modifyTVar_ (atLeft at) (subtract pieceLen)+                    peers <- readTVar (atPeers at)+                    flip mapM_ peers $ \peer ->+                        do sendMessage peer (Have idx)+                           recalculateInterest True idx at peer)+            else do atomically $+                      do pieces <- readTVar (atPieces at)+                         writeTVar (atPieces at) (IntMap.delete idx pieces)+                    debug $ "Piece failed validation: " ++ show idx+    where torrent = atTorrent at

@@ -0,0 +1,280 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.Logic.PeerManager+-- Copyright   :  (c) Lemmih 2005, 2006+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable (requires STM)+--+{-++The described algorihm is NOT yet implemented.++-}+{-++Ideology overview:++  This bittorrent implementation builds on a few assumptions:+    * High download rates are paramount.+    * We can only download from as many leechers as we upload to.+    * Seeding is a luxury. We will only do it when we can afford it.++  There are three types of uploads:+    * Regular uploads. For peers that we're downloading from.+    * Optimistic uploads. For peers that we aren't downloading from.+    * Seed uploads. For torrents that we're seeding.++  Controversial ideas:+    * Limit upload speeds. Many medium uploads are "better" than a few+      fast ones.+    * Put peers using conjure first in the seed list.++-}+{-+WARNING: THIS TEXT IS OUT DATED AND MAY BE INACCUATE.++Choke algorithm:++Factors:+  N(10) = seconds between regular (non-optimistic and non-seeding) unchokes.+  X(11) = max number of uploads.+  Z(10) = max number of uploads - K.+  G = number of intersted peers that we're downloading from.+  J = number of uploads. (including regular, optimistic and seed uploads)+  Y = number of seed uploads.+  M(30) = seconds between optimistic unchokes.+  K(1) = min number of optimistic uploads.+  L(60) = seconds to seed before selecting a new peer.+  I(30) = seconds to (optimistically) upload before choking.++Every N seconds we:+  * sort peer list by their download speed.+  * remove uninterested peers.+  * Make sure the fastes (min G Z) are unchoked (and unchoke them if they aren't).+  * Choke slower peers.+  * J is updated.+  * if J > Z -- if total uploads > max uploads+       then stop surplus seed uploads.+       else initiate (Z - J) new seed uploads.+            J is updated.+            when Z < J+                 initiate (Z - J) new optimistic uploads.++Seed uploads continues for L seconds. After that it appends its peer+to the end of the seed list and starts uploading to the first in the+seed list. If the new peer is the same as before, no choke/unchoke+action is needed.++Every M seconds we:+  * Initiate K new optimistic uploads at random.++Optimistic uploads continues for I seconds. After that they choke the+connection unless the peer has started uploaded to us.++We're intested in a peer if:+  he got a piece we want.+  the current number of downloads < the max number of downloads.++-}+-----------------------------------------------------------------------------+module Conjure.Logic.PeerManager+    ( runMainChoker )+    where++import Conjure.Types+import Conjure.Utils+import Conjure.Protocol.PWP.Types+import Conjure.STM.PeerCtrl+import Conjure.Debug()++import GHC.Conc++import Control.Monad.State+import Text.Printf()+import Data.List++import qualified Data.Set as Set+import Data.Set (Set)++data Classification+    = Idle Integer Integer     -- download age, upload age+    | Optimistic Int           -- bps+    | Upload Int               -- bps+    | DownloadUpload (Int,Int) -- (down bps, up bps)+    | Download Int Bool        -- bps, remote interest+      deriving (Eq, Show, Ord)++type ClassifiedPeer = (Classification, ConnectedPeer)+++getDownloadBps :: Classification -> Int+getDownloadBps (DownloadUpload bps) = fst bps+getDownloadBps (Download bps _) = bps+getDownloadBps _ = 0++isDownload :: Classification -> Bool+isDownload (Download _ _) = True+isDownload (DownloadUpload _) = True+isDownload _ = False++isUpload :: Classification -> Bool+isUpload (Upload _) = True+isUpload (DownloadUpload _) = True+isUpload _ = False++isIdle :: Classification -> Bool+isIdle (Idle _ _) = True+isIdle _ = False++isOptimistic :: Classification -> Bool+isOptimistic (Optimistic _) = True+isOptimistic _ = False++onFst :: (a -> a -> t1) -> t -> (a, b) -> t1+onFst f _ b = f (fst b) (fst b)++orderByUploadAge :: Classification -> Classification -> Ordering+orderByUploadAge (Idle _ age1) (Idle _ age2) = compare age1 age2+orderByUploadAge    _ _                      = EQ++orderByImportance :: Classification -> Classification -> Ordering+orderByImportance = w+    where w (Idle age1 _) (Idle age2 _) = compare age2 age1 -- Old idles are worth more.+          w (Idle _ _) _ = LT+          w _ (Idle _ _) = GT+          w (Upload bps1) (Upload bps2) = compare bps1 bps2+          w (Upload _) _ = LT+          w _ (Upload _) = GT+          w (Optimistic bps1) (Optimistic bps2) = compare bps1 bps2+          w (Optimistic _) _ = LT+          w _ (Optimistic _) = GT+          w x y = compare (getDownloadBps x) (getDownloadBps y)++classifyPeer :: Integer -> ConnectedPeer -> STM (Classification, ConnectedPeer)+classifyPeer now peer+    = do c <- classifyPeer' now peer+         return (c,peer)+classifyPeer' :: Integer -> ConnectedPeer -> STM Classification+classifyPeer' now peer+    = do lChoke <- getLocalChoke peer+         rChoke <- getRemoteChoke peer+         lInterest <- getLocalInterest peer+         rInterest <- getRemoteInterest peer+         lastDownload <- getTimingAge now (cpDownloadTimings peer)+         lastUpload <- getTimingAge now (cpUploadTimings peer)+         downBps <- getTiming now 20000 (cpDownloadTimings peer)+         upBps <- getTiming now 20000 (cpUploadTimings peer)+         return $ case (lChoke, rChoke, lInterest, rInterest) of+                    (False,False,True,True)    -> DownloadUpload (downBps, upBps)+                    (_, False, True, _)        -> Download downBps rInterest+                    (False, _, _, True)+                        | lastDownload < 30000 -> Optimistic upBps+                        | otherwise            -> Upload upBps+                    _                          -> Idle lastDownload lastUpload++++choke :: ConnectedPeer -> STM ()+choke connPeer+    = do sendMessage connPeer Choke+         setLocalChoke connPeer True++unchoke :: ConnectedPeer -> STM ()+unchoke connPeer+    = do sendMessage connPeer Unchoke+         setLocalChoke connPeer False+++data CState =+    CState { toChoke :: Set ConnectedPeer+           , toUnchoke :: Set ConnectedPeer }++type Unchoker a = StateT CState STM a++markForChoke :: ConnectedPeer -> Unchoker ()+markForChoke peer = modify (\s -> s{toChoke = Set.insert peer (toChoke s)+                                   ,toUnchoke = Set.delete peer (toUnchoke s)})++markForUnchoke :: ConnectedPeer -> Unchoker ()+markForUnchoke peer = modify (\s -> s{toChoke = Set.delete peer (toChoke s)+                                     ,toUnchoke = Set.insert peer (toUnchoke s)})++runMainChoker :: TVar Int -- 'N'. Use an MVar?+              -> TVar [ConnectedPeer]+              -> TVar (Int, Int, Int, Int)+              -> IO ()+runMainChoker nSecs connPeersVar opts+    = forever $+      do atomically $ do st <- execStateT (mainUnchoker connPeersVar opts) (CState Set.empty Set.empty)+                         mapM_ choke (Set.toList $ toChoke st)+                         mapM_ unchoke (Set.toList $ toUnchoke st)+         secs <- atomically (readTVar nSecs)+         threadDelay $ secs * 10^(6::Int)++mainUnchoker :: TVar [ConnectedPeer]+             -> TVar (Int,Int,Int,Int)+             -> Unchoker ()+mainUnchoker peerListVar opts+    = do (maxPeers, maxDownloads, maxUploads, minOptimistic) <- lift $ readTVar opts+         peerList <- lift $ readTVar peerListVar+         now <- lift $ unsafeIOToSTM getCurrentTime+         -- Classify peers+         classified <- lift $ mapM (classifyPeer now) peerList+         maintained <- maintainDownloads classified+         trimmed    <- trimPeers maintained maxPeers maxDownloads maxUploads+         launchOptimistic trimmed now maxUploads minOptimistic+         return ()+++{-+  Keep downloads running by unchoking interested peers.+-}+maintainDownloads :: [ClassifiedPeer] -> Unchoker [ClassifiedPeer]+maintainDownloads = mapM worker+    where worker (Download bps True, peer)+              = do markForUnchoke peer+                   return (DownloadUpload (bps, 0), peer)+          worker x = return x++{-+  Trim the total number of peers, the number of downloads and the number of uploads.+-}+trimPeers :: [ClassifiedPeer] -> Int -> Int -> Int -> Unchoker [ClassifiedPeer]+trimPeers classified maxPeers maxDownloads maxUploads+    = do let byImportance = reverse (sortBy (onFst orderByImportance) classified)+             (okPeers, excessPeers) = splitAt maxPeers byImportance+         -- disconnect from the excess peers+         lift $ mapM_ (disconnectPeer.snd) excessPeers+         -- Take the downloads and sort them by speed.+         let byDownload = reverse $ sort $ filter (isDownload.fst) okPeers+             (_, excessDownloads) = splitAt maxDownloads byDownload+         -- stop downloads from excess downloads+         lift $ mapM_ (disconnectPeer.snd) excessDownloads+         let okPeers' = filter (`notElem` excessDownloads) okPeers+             byUpload = reverse $ sort $ filter (isUpload.fst) okPeers'+             (_, excessUploads) = splitAt maxUploads byUpload+         -- stop uploads to excess uploads+         mapM_ (markForChoke.snd) excessUploads+         return $ filter (`notElem` excessUploads) okPeers'++{-+  Launch new optimistic uploads+-}+launchOptimistic :: [(Classification, ConnectedPeer)] -> Integer -> Int -> Int -> Unchoker ()+launchOptimistic classified now maxUploads minOptimistic+    = do -- Start new optimistic uploads if we can.+         -- We start more than 'minOptimistic' uploads if we're low on+         -- normal uploads. This is hugely beneficial when starting a new download.+         let uploads = length (filter (isUpload.fst) classified)+         idles <- lift $ fmap (sortBy (onFst orderByUploadAge)) $+                  filterM (getRemoteInterest.snd) (filter (isIdle.fst) classified)+         let initUploads = abs (maxUploads - uploads)+             currentOptimistic = length (filter (isOptimistic.fst) classified)+             newOptimistic = abs (minOptimistic - currentOptimistic)+         forM_ (take (initUploads+newOptimistic) idles) $ \(_, peer) ->+             do lift $ recordTiming (cpDownloadTimings peer) now 0 -- Mark now as start of optimistic upload.+                markForUnchoke peer+         return ()

@@ -0,0 +1,49 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.Logic.BlockSelector+-- Copyright   :  (c) Lemmih 2006+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable (requires STM)+--+-- The queue manager runs in a thread for each connected peer. It's job it to+-- keep block queue full with the right blocks for every peer.+-----------------------------------------------------------------------------+module Conjure.Logic.QueueManager+    ( queueManager+    ) where++import Conjure.Types+import Conjure.Utils+import Conjure.Logic.BlockManagement+import Conjure.STM.PeerCtrl+import Conjure.Debug++import Control.Concurrent.STM+import Control.Monad                   (forever, when)++import qualified Data.Map as Map++queueManager :: ActiveTorrent -> ConnectedPeer -> IO ()+queueManager at peer+    = forever $ atomically $+      do stmTransactionName "QueueManager"+         rc <- getRemoteChoke peer+         si <- getLocalInterest peer+         when (rc || not si) retry+         limit <- readTVar (cpQueueLength peer)+         blocks <- readTVar pendingBlocks+         when (Map.size blocks >= limit) retry+         mbBlock <- requestNewBlock at peer+         case mbBlock of+           Nothing -> do stmDebug "Out of blocks."+                         retry+           Just block@(piece,offset,_)+               -> let newBlocks = Map.insert (pIndex piece,offset) block blocks+                  in do --stmDebug $ "I want this block: " ++ show (pIndex piece, offset)+                        writeTVar pendingBlocks newBlocks+                        sendRequest peer block+    where pendingBlocks = cpPendingBlocks peer+

@@ -0,0 +1,150 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.Network.Client+-- Copyright   :  (c) Lemmih 2005-2006+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable (requires STM)+--+-----------------------------------------------------------------------------+module Conjure.Network.Client+    ( runClient+    , shutdownClient+    , shutdownAll+    , shutdownClient'+    ) where+++import Conjure.Types+import Conjure.Utils+import Conjure.Torrent+import Conjure.STM.PeerCtrl+import Conjure.Piecemap              ( scanTorrent, drawPiecemap, emptyUsecount )+import Conjure.Network.Peer+import qualified Data.ByteString.Char8 as BS+import Data.ByteString (ByteString)++import Conjure.Protocol.THP++import Control.Concurrent+import Control.Exception+import Control.Concurrent.STM+import Control.Monad+import System.Random                 ( randomRIO )+import Network+import Text.Printf                   ( printf )++import qualified Data.IntMap as IntMap+import qualified Data.Map as Map+import Data.Map                      ( Map )+import Data.Array.Diff               ( assocs )+import Data.List                     ( nubBy )++import Prelude hiding (catch)++newActiveTorrent :: Torrent -> Backend -> PeerId -> ThreadId -> Int -> IO ActiveTorrent+newActiveTorrent torrent backend myPeerId tid nPieces =+  do piecemap <- scanTorrent torrent backend+     putStrLn ("Piecemap: " ++ drawPiecemap piecemap "")+     let incomplete_pieces = [ i | (i,False) <- assocs piecemap ]+     atomically $+      do usecount    <- newTVar (emptyUsecount nPieces)+         piecemapVar <- newTVar piecemap+         pieces      <- newTVar (IntMap.empty)+         peers       <- newTVar []+         downloaded  <- newTVar 0+         uploaded    <- newTVar 0+         left        <- newTVar $ fromIntegral $ sum $ map (pieceLength torrent) incomplete_pieces+         return (ActiveTorrent+                 { atTorrent = torrent, atClient = tid, atBackend = backend+                 , atPeerId = myPeerId, atUsecount =  usecount+                 , atPiecemap = piecemapVar, atPieces = pieces, atPeers = peers+                 , atDownloaded = downloaded, atUploaded = uploaded, atLeft = left})++sendTrackerRequest :: PortNumber -> Maybe Event -> ActiveTorrent -> IO Response+sendTrackerRequest portNum event at+    = do up   <- atomically $ readTVar (atUploaded at)+         down <- atomically $ readTVar (atDownloaded at)+         left <- atomically $ readTVar (atLeft at)+         queryTracker torrent myPeerId Nothing portNum up down left event+             `catch` \e -> return $ Error $ show e+    where torrent = atTorrent at+          myPeerId = atPeerId at++-- FIXME: we need some kind of mechanism to implement "try to maintain N peers, but no more than M, N<M"+runClient :: PortNumber+          -> TVar [ConnectedPeer] -- Use a Set?+          -> TVar (Map ByteString ActiveTorrent)+          -> Torrent+          -> Backend+          -> IO ()+runClient portNum connectedPeers torrentMap torrent backend+    = do myPeerIdStr <- liftM BS.pack $ replicateM 20 (randomRIO ('a','z')) -- ('\0','\255'))+         let myPeerId = PeerId myPeerIdStr+         tid <- myThreadId+         at <- newActiveTorrent torrent backend myPeerId tid nPieces+         atomically $ modifyTVar_ torrentMap $ Map.insert (tInfoHash torrent) at+         let loop event+                 = do putStrLn "Sending request to tracker"+                      resp <- sendTrackerRequest portNum event at+                      case resp of+                        Error str -> do putStrLn $ "Error: " ++ str+                                        threadDelay (60 * 10^(6::Int))+                        Info { rspInterval = interval+                             , rspPeers = peers}+                            -> do flip mapM_ (distinct peers) $ \peer ->+                                      forkIO $+                                      do peerHandle <- connectTo (iPeerIp peer) (PortNumber (fromIntegral (iPeerPort peer)))+                                         printf "  %s:%d\t %s\n" (iPeerIp peer) (iPeerPort peer) (show peerHandle)+                                         connectionToPeer at+                                                          connectedPeers+                                                          peerHandle+                                       `catch` \e -> print e >> return ()+                                  putStrLn $ "Delaying " ++ show interval ++ "secs"+                                  replicateM_ 10 (threadDelay (interval * 10^(5::Int)))+                      loop Nothing+         loop (Just Started) `catch` clientExceptionHandler connectedPeers torrentMap torrent at+             where nPieces = infoNumPieces torrent+                   distinct peers = nubBy equalHostAndPort peers+                   equalHostAndPort peer1 peer2 = (iPeerIp peer1, iPeerPort peer1) == (iPeerIp peer2, iPeerPort peer2)+++shutdownClient :: Torrent -> TVar (Map ByteString ActiveTorrent) -> IO ()+shutdownClient torrent torrentMap+    = do mbAt <- atomically $+                   fmap (Map.lookup (tInfoHash torrent)) (readTVar torrentMap)+         case mbAt of+           Nothing -> error "Conjure.Network.Client.shutdownClient: torrent not found."+           Just at -> do shutdownClient' at+                         atomically $+                           do m <- readTVar torrentMap+                              when (Map.member (tInfoHash torrent) m) retry++shutdownAll :: TVar (Map ByteString ActiveTorrent) -> IO ()+shutdownAll torrentMap+    = do ats <- atomically $ readTVar torrentMap+         mapM_ shutdownClient' (Map.elems ats)+         atomically $+           do ats' <- readTVar torrentMap+              unless (Map.null ats') retry++shutdownClient' :: ActiveTorrent -> IO ()+shutdownClient' at+    = throwTo (atClient at) (ErrorCall "shutdown")++++clientExceptionHandler :: TVar [ConnectedPeer]+                       -> TVar (Map ByteString ActiveTorrent)+                       -> Torrent+                       -> ActiveTorrent+                       -> Exception+                       -> IO ()+clientExceptionHandler peers torrentMap torrent at _+    = do sendTrackerRequest 0 (Just Stopped) at+         atomically $+           do mapM_ disconnectPeer =<< readTVar peers+              modifyTVar_ torrentMap $ Map.delete (tInfoHash torrent)+         return ()

@@ -0,0 +1,326 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.Network.Peer+-- Copyright   :  (c) Lemmih 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable (requires STM)+--+-----------------------------------------------------------------------------+-- FIXME: refactor+module Conjure.Network.Peer+    ( connectionFromPeer+    , connectionToPeer+    ) where++import Conjure.Utils.Transaction++import Conjure.Types+import Conjure.Utils+import Conjure.Torrent               ( infoNumPieces )+import Conjure.Piecemap              ( mkPiecemap, setPiecemapBit+                                     , emptyPiecemap, fromPiecemap+                                     , addPiecemap, addPiece, delPiecemap )+import Conjure.Logic.BlockManagement+import Conjure.Logic.QueueManager+import Conjure.Protocol.PWP.Types as PWP+import Conjure.Protocol.PWP.Printer+import Conjure.Protocol.PWP.Parser+import Conjure.Debug++import Conjure.STM.PeerCtrl++import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception             ( Exception (..), catch, throw, finally, assert+                                     , bracket )+import Control.Monad                 ( when, mplus, forever )+import System.IO                     ( Handle, hClose  )+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Set as Set+import Data.List                     ( delete )++import qualified Data.ByteString as BS+import Data.ByteString (ByteString)++import Prelude hiding (catch)++--------------------------------------------------------------+-- Interface+--------------------------------------------------------------++connectionFromPeer :: TVar [ConnectedPeer]+                   -> TVar (Map ByteString ActiveTorrent)+                   -> Handle+                   -> IO ()+connectionFromPeer connectedPeers torrentMap handle+    = do Handshake infohash peerid <- hGetHandshake handle+         torrents <- atomically $ readTVar torrentMap+         at <- case Map.lookup infohash torrents of+                 Nothing -> disconnect+                 Just at -> return at+         hPutHandshake handle (Handshake infohash (atPeerId at))+         doConnection peerid at connectedPeers handle+      `catchDisconnect` handle++connectionToPeer :: ActiveTorrent+                 -> TVar [ConnectedPeer]+                 -> Handle+                 -> IO ()+connectionToPeer at connectedPeers handle+    = do left <- atomically $ readTVar (atLeft at)+         when (left == 0) disconnect+         hPutHandshake handle (Handshake myInfohash myPeerId)+         Handshake infohash peerid <- hGetHandshake handle+         when (infohash /= myInfohash) disconnect+         doConnection peerid at connectedPeers handle+    `catchDisconnect` handle+    where myInfohash = tInfoHash torrent+          myPeerId = atPeerId at+          torrent = atTorrent at+++withConnectedPeer :: PeerId -> ActiveTorrent -> TVar [ConnectedPeer] -> (ConnectedPeer -> IO a) -> IO a+withConnectedPeer remotePeerId at connectedPeers+    = bracket createPeer destroyPeer+    where createPeer = atomically $+                       do connPeer <- registerConnectedPeer connectedPeers remotePeerId (atTorrent at)+                          modifyTVar_ (atPeers at) (connPeer:)+                          return connPeer+          destroyPeer peer+              = do atomically $+                     do piecemap <- readTVar (cpPiecemap peer)+                        modifyTVar_ (atUsecount at) (delPiecemap piecemap)+                        removePeer connectedPeers remotePeerId+                        removePeer (atPeers at) remotePeerId+                   tids <- atomically (readTVar (cpThreads peer))+                   mapM_ killThread (Set.toList tids)++doConnection :: PeerId+             -> ActiveTorrent+             -> TVar [ConnectedPeer]+             -> Handle+             -> IO ()+doConnection remotePeerId at connectedPeers handle+    = withConnectedPeer remotePeerId at connectedPeers $ \connPeer ->+      do piecemap <- atomically (readTVar (atPiecemap at))+         hPutMessage handle (BitField (fromPiecemap piecemap))+         handlePeer handle at connPeer++--------------------------------------------------------------+-- Network utility functions+--------------------------------------------------------------++-- FIXME: refactor+handleNewInput :: Handle -> ActiveTorrent -> ConnectedPeer -> Message -> Transaction ()+handleNewInput _ at connPeer (RequestedPiece idx offset blockData)+    = registerBlock at connPeer (idx, offset, BS.length blockData) blockData+handleNewInput _ at connPeer msg+    = stm $+      case msg of+        Choke         -> do setRemoteChoke connPeer True+                            abandonBlocks connPeer+        Unchoke       -> setRemoteChoke connPeer False+        Interested    -> setRemoteInterest connPeer True+        NotInterested -> setRemoteInterest connPeer False+        BitField fs   -> do let piecemap = mkPiecemap nPieces fs+                            writeTVar (cpPiecemap connPeer) piecemap+                            modifyTVar_ (atUsecount at) (addPiecemap piecemap)+                            rescanInterest at connPeer+        Have num      -> do setPiecemapBit (cpPiecemap connPeer) num True+                            modifyTVar_ (atUsecount at) (addPiece num)+                            recalculateInterest False num at connPeer+        Request idx offset len+            -> do status <- queryUploadLegality connPeer+                  case status of+                    UploadIllegal -> stmDebug "Illegal download request." >> disconnect+                    UploadIgnore  -> stmDebug "Ignoring download request." >> return ()+                    UploadGrant   -> sendPiece connPeer idx offset len+                       -- ^ Tell the upload handler to add this piece to the upload queue.+        Cancel idx offset len+            -> cancelUpload connPeer idx offset len+        KeepAlive     -> return ()+        _ -> stmDebug $ "Unhandled message: " ++ show msg+    where nPieces = infoNumPieces (cpTorrent connPeer)++keepAliveThread :: Handle -> ConnectedPeer -> IO ()+keepAliveThread _ peer+    = loop+    where loop = do threadDelay (30 * 10^(6::Int))+                    atomically $+                      do lChoke <- getLocalChoke peer+                         rChoke <- getRemoteChoke peer+                         lInterest <- getLocalInterest peer+                         rInterest <- getRemoteInterest peer+                         let download = not rChoke && lInterest+                             upload = not lChoke && rInterest+                         if not download && not upload+                            then sendMessage peer KeepAlive+                            else retry+                    loop++forkThread :: String -> ConnectedPeer -> IO () -> IO ()+forkThread _ connPeer action+    = do --debug $ "Forking thread: " ++ name+         block <- newEmptyMVar+         tid <- forkIO (do tid <- readMVar block+                           action+                             `finally`+                             do atomically $ unregisterThread connPeer tid+                       )+         atomically $ registerThread connPeer tid+         putMVar block tid++-- FIXME: refactor+handlePeer :: Handle -> ActiveTorrent -> ConnectedPeer -> IO ()+handlePeer handle at connPeer+    = do forkThread "outputThread" connPeer (vital outputThread)+         forkThread "inputThread" connPeer (vital inputThread)+         forkThread "keepAliveThread" connPeer (keepAliveThread handle connPeer)+         forkThread "queueManager" connPeer (queueManager at connPeer)+         let loop = forever $ runT $+                    do stm $ stmTransactionName "handlePeer"+                       action <- stm $ readTChan (cpMsgChan connPeer)+                       case action of+                         NewInput msg    -> handleNewInput handle at connPeer msg+                         Disconnect      -> disconnect+                         SockError e     -> do stm $ stmDebug $ "SockError: " ++ show e+                                               disconnect+         loop `finally` atomically (abandonBlocks connPeer)+    where vital action = action `catch` \e -> atomically $ writeTChan (cpMsgChan connPeer) (SockError e)+          outputThread+              = do msgList <- atomically $ newTVar []+                   forever $ runT $+                     do action <- stm $ readTChan (cpOutChan connPeer)+                        case action of+                          SendMessage msg+                              -> onCommit (hPutMessage handle msg)+                          SendPiece idx offset len+                              -> stm $ modifyTVar_ msgList ((idx,offset,len):)+                          ClearPiece idx offset len+                              -> stm $+                                 do pieces <- readTVar msgList+                                    assert ((idx,offset,len) `elem` pieces) $ return ()+                                    writeTVar msgList (delete (idx,offset,len) pieces)+                          ClearPieces+                              -> stm (writeTVar msgList [])+                     `mplus`+                     do msg <- stm $ readTVar msgList+                        case msg of+                          []  -> stm $ retry+                          ((idx,offset,len):xs)+                              -> do onCommit $+                                      do payload <- readBlock (atBackend at) idx offset len+                                         assert (BS.length payload == len)+                                           $ hPutMessage handle (RequestedPiece idx offset payload)+                                         now <- getCurrentTime+                                         atomically $+                                           do recordTiming (cpUploadTimings connPeer) now len+                                              modifyTVar_ (atUploaded at) (+ (fromIntegral len))+                                    stm $ writeTVar msgList xs+          reporter now bps+              = atomically $ recordTiming (cpDownloadTimings connPeer) now bps+          inputThread = do msg <- hGetMessage reporter handle+                           atomically $ writeTChan (cpMsgChan connPeer) (NewInput msg)+                           inputThread++abandonBlocks :: ConnectedPeer -> STM ()+abandonBlocks connPeer+    = do blocks <- readTVar (cpPendingBlocks connPeer)+         mapM_ (abandonBlock connPeer) (Map.elems blocks)+         writeTVar (cpPendingBlocks connPeer) Map.empty++--------------------------------------------------------------+-- ConnectedPeer utility functions+--------------------------------------------------------------++newConnectedPeer :: PeerId -> Torrent -> STM ConnectedPeer+newConnectedPeer peerid torrent =+    do threads         <- newTVar Set.empty+       ctrlChan        <- newTChan+       outChan         <- newTChan+       piecemap        <- newTVar (emptyPiecemap (infoNumPieces torrent))+       localChoke      <- newTVar True+       remoteChoke     <- newTVar True+       localInterest   <- newTVar False+       remoteInterest  <- newTVar False+       uploadTimings   <- newTVar (Timing 0 [])+       downloadTimings <- newTVar (Timing 0 [])+       pBlocks         <- newTVar Map.empty+       qLength         <- newTVar 2+--       isDownloading   <- newTVar False+--       isUploading     <- newTVar False+       return $ ConnectedPeer+                  { cpThreads         = threads+                  , cpMsgChan         = ctrlChan+                  , cpOutChan         = outChan+                  , cpPeerId          = peerid+                  , cpTorrent         = torrent+                  , cpPiecemap        = piecemap+                  , cpLocalChoke      = localChoke+                  , cpRemoteChoke     = remoteChoke+                  , cpLocalInterest   = localInterest+                  , cpRemoteInterest  = remoteInterest+                  , cpUploadTimings   = uploadTimings+                  , cpDownloadTimings = downloadTimings+                  , cpPendingBlocks   = pBlocks+                  , cpQueueLength     = qLength+                  }++registerConnectedPeer :: TVar [ConnectedPeer]+                      -> PeerId+                      -> Torrent+                      -> STM ConnectedPeer+registerConnectedPeer connectedPeers peerid torrent+    = do when (BS.null $ unPeerId peerid) disconnect -- Null PeerID means that this is handshake from+                                                     -- tracker which tries to check whether we are+                                                     -- behind the NAT. We should disconnect, because+                                                     -- tracker closes connection immediately after this+                                                     -- handshake+         peers <- readTVar connectedPeers+         -- FIXME: use Sets+         let torrentPeers = [ cpPeerId peer | peer <- peers+                            , tInfoHash (cpTorrent peer) == tInfoHash torrent]+         when (peerid `elem` torrentPeers) disconnect+         connPeer <- newConnectedPeer peerid torrent+         writeTVar connectedPeers (connPeer:peers)+         return connPeer++-- FIXME: move this+data UploadLegality+    = UploadIllegal+    | UploadIgnore+    | UploadGrant++queryUploadLegality :: ConnectedPeer -> STM UploadLegality+queryUploadLegality connPeer+    = do sc <- getLocalChoke connPeer+         ri <- getRemoteInterest connPeer+         case (sc,ri) of+           (_,False) -> return UploadIllegal+           (True,_)  -> return UploadIgnore+           _         -> return UploadGrant++removePeer :: TVar [ConnectedPeer] -> PeerId -> STM ()+removePeer peerLst peerid+    = modifyTVar_ peerLst $ \lst ->+      assert (length (filter (\p -> cpPeerId p == peerid) lst) == 1) $+      filter (\p -> cpPeerId p /= peerid) lst++--------------------------------------------------------------+-- Other utility functions+--------------------------------------------------------------++disconnect :: Monad m => m a+disconnect = error "disconnect"++catchDisconnect :: IO () -> Handle -> IO ()+catchDisconnect action h+    = action `catch` \e -> hClose h >> handle e+    where handle (ErrorCall "disconnect") = putStrLn $ "Disconnecting from: " ++ show h+          handle (ErrorCall errMsg) = throw (ErrorCall ("Error: " ++ errMsg))+          handle e = throw e+

@@ -0,0 +1,25 @@+module Conjure.Network.Server where++import Conjure.Types+import Conjure.Network.Peer   ( connectionFromPeer )+import Conjure.Debug++import Control.Concurrent+import Control.Concurrent.STM++import Data.Map (Map)+import Data.ByteString+import Network                ( PortID(..), PortNumber, listenOn, accept )++runServer :: TVar [ConnectedPeer]+          -> TVar (Map ByteString ActiveTorrent)+          -> PortNumber+          -> IO ()+runServer connectedPeers torrentMap port+    = do sock <- listenOn (PortNumber port)+         debug $ "Server is awaiting connections. Socket: " ++ show (sock, port)+         let loop = do (handle, _, _) <- accept sock+                       -- debug $ "(server) got connect from: " ++ show hostname ++ ":" ++ show port ++ " (handle: " ++ show handle ++ ")"+                       forkIO (connectionFromPeer connectedPeers torrentMap handle)+                       loop+         loop

@@ -0,0 +1,67 @@+{-++ Copyright (c) 2005 Jesper Louis Andersen <jlouis@mongers.org>++ Permission to use, copy, modify, and distribute this software for any+ purpose with or without fee is hereby granted, provided that the above+ copyright notice and this permission notice appear in all copies.++ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.++-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.OptionParser+-- Copyright   :  (c) Jesper Louis Andersen, 2005+-- License     :  BSD-style (see the file libraries/base/LICENSE)+-- +-- Maintainer  :  jlouis@mongers.org+-- Stability   :  believed to be stable+-- Portability :  portable+-- +-- Utilize 'System.Console.GetOpt' to parse command line options of+-- Conjure.+-----------------------------------------------------------------------------+module Conjure.OptionParser+  (+   Flag(..),+   getOpts+  )+where+    +import System.Exit+import System.Console.GetOpt+import Data.Maybe ( fromMaybe )+import Control.Monad (when)++data Flag +     = Verbose  | Version | RarestCutoff String | Help+       deriving (Eq,Show)++options :: [OptDescr Flag]+options =+  [ Option ['v']        ["verbose"] (NoArg Verbose) "Provide verbose output",+    Option ['V','?']    ["version"] (NoArg Version) "Show version number",+    Option ['R']        ["rarest-cutoff"] +                        (OptArg rarest_cut_point "INTEGER")+                        "Cutoff point for rarest first piece retrieval",+    Option []           ["help"]    (NoArg Help)    "Show this help" ]++rarest_cut_point :: Maybe String -> Flag+rarest_cut_point = RarestCutoff . fromMaybe "10"++getOpts :: [String] -> IO ([Flag], [String])+getOpts argv =+  case getOpt Permute options argv of+       (o, files, []  ) -> do when (Help `elem` o) (do putStrLn usage +                                                       exitWith ExitSuccess)+                              return (o, files)+       (_, _, errs)      -> ioError (userError (concat errs ++ usage))+ where header = "Usage: conjure [OPTION...] file"+       usage  = usageInfo header options

@@ -0,0 +1,259 @@+{-# LANGUAGE CPP, TypeOperators, OverlappingInstances, RankNTypes #-}+{-+ Copyright (c) 2005-2006 Lemmih <lemmih@gmail.com>++ Permission to use, copy, modify, and distribute this software for any+ purpose with or without fee is hereby granted, provided that the above+ copyright notice and this permission notice appear in all copies.++ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.+-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.InterestTable+-- Copyright   :  (c) Lemmih, 2005+-- License     :  BSD-style+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable (requires DiffArrays)+--+--+-- The InterestTable keeps track of what pieces are+-- interesting. Interesting pieces are those pieces which few peers have+-- downloaded. If a piece is rare, it is a prime candidate for sharing+-- with others and most of the Bittorrent protocol relies on this fact+-- for fast piece retrieval.+--+-- This module provides a Table of interests. Every time we learn+-- something about the distribution of pieces, we update this table to+-- track the new information. Thus, we keep a table of things we should+-- be interested in. Of course, it is also possible to query a table to+-- find the next piece we should download.+-----------------------------------------------------------------------------+module Conjure.Piecemap+    ( drawPiecemap  -- :: Piecemap -> ShowS+    , emptyUsecount -- :: Int -> Usecount+    , emptyPiecemap -- :: Int -> Piecemap+    , mkPiecemap    -- :: Int -> ByteString -> Piecemap+    , fromPiecemap  -- :: Piecemap -> ByteString+    , findNewPieces -- :: Piecemap -- ^ Our pieces. @findNewPiece@ may not return (Just i) if this!i == True.+                    -- -> Piecemap -- ^ Remote pieces. @findNewPieces@ may not return (Just i) if this!i == False.+                    -- -> [Int]    -- ^ Lazy list of pieces we can get from the remote peer.+    , orderPieces+    , setPiecemapBit -- TVar Piecemap -> Int -> Bool -> STM ()+    , addPiecemap   -- :: Piecemap -> Usecount -> Usecount+    , addPiece      -- :: Int -> Usecount -> Usecount+    , delPiecemap   -- :: Piecemap -> Usecount -> Usecount+    , scanTorrent   -- :: Torrent -> TorrentHandle -> IO Piecemap+    ) where++import Data.List                ( groupBy, sortBy, group )+import Data.Ord                 ( comparing )+import Data.Word                ( Word8 )+import Data.Bits                ( Bits (..) )+import Data.Array.Base+import Data.Array.Diff+import Control.Monad.ST+import Control.Exception+import Control.Concurrent.STM+import System.Random            ( StdGen )++import Conjure.Types+import Conjure.Utils.Shuffle+import Conjure.Utils.SHA1 (sha1)+import Conjure.Torrent++import qualified Data.ByteString as BS+import Data.ByteString (ByteString)++#ifdef __CABAL_TEST__+import Test.QuickCheck hiding (evaluate)+#endif++import Control.Monad+import GHC.Exts+{-+-- import Data.Array.IO            ( IOUArray )+-- import System.IO.Unsafe         (unsafePerformIO)+-- Stolen from Data.Array.Diff:+-- If the array contains unboxed elements, then the elements of the+-- diff list may also recursively reference the array from inside+-- replaceDiffArray, so we must seq them too.+replaceDiffArray2 :: (MArray a e IO, Ix i)+                => IOToDiffArray a i e+                -> [(Int, e)]+                -> IO (IOToDiffArray a i e)+a `replaceDiffArray2` ies = do+    mapM_ (\(a,b) -> do evaluate a; evaluate b) ies+    a `replaceDiffArray` ies+++instance IArray (IOToDiffArray IOUArray) Bool where+    bounds        a      = bounds (unsafeCoerce# a :: IOToDiffArray IOUArray i Int)+    unsafeArray   lu ies = unsafePerformIO $ newDiffArray lu ies+    unsafeAt      a i    = unsafePerformIO $ a `readDiffArray` i+    unsafeReplace a ies  = unsafePerformIO $ a `replaceDiffArray2` ies++instance (Ix ix, Show ix) => Show (DiffUArray ix Bool) where+  showsPrec = showsIArray+-}++drawPiecemap :: Piecemap -> ShowS+drawPiecemap piecemap+    = foldr (\e r -> draw e . r) id $ group $ elems piecemap+    where draw [True]        = showChar '#'+          draw lst@(True:_)  = shows (length lst) . showChar '#'+          draw [False]       = showChar '_'+          draw lst@(False:_) = shows (length lst) . showChar '_'+++-- It's important that the sha1 check is strict.+-- Otherwise we can't garbage collect the pieces and+-- we'll end up with the entire file in memory.+-- FIXME: Skip all the pieces in a file when 'readPiece'' returns Nothing.+scanTorrent :: Torrent -> Backend -> IO Piecemap+scanTorrent torrent backend+    = fmap (listArray (0, nPieces-1)) (mapM checker [0 .. nPieces - 1])+    where nPieces = infoNumPieces torrent+          checker pNum+              = do pieceMb <- readPiece' backend pNum+                   case pieceMb of+                     Nothing -> return False+                     Just piece+                       -> return $! pieceCheckSum torrent pNum == sha1 piece++emptyUsecount :: Int -> Usecount+emptyUsecount l+    = listArray (0,l-1) (replicate l 0)++emptyPiecemap :: Int -> Piecemap+emptyPiecemap l+    = listArray (0,l-1) (replicate l False)++mkPiecemap :: Int -> ByteString -> Piecemap+mkPiecemap l bitmap+    = listArray (0,l-1) (take l (bsToBitmap (BS.unpack bitmap)))++bsToBitmap :: [Word8] -> [Bool]+bsToBitmap [] = []+bsToBitmap (x:xs)+    = foldl (\s n l -> s (testBit x n:l)) id [7, 6 .. 0] (bsToBitmap xs)++fromPiecemap :: Piecemap -> ByteString+fromPiecemap arr = BS.pack (bitmapToBS (elems arr))++bitmapToBS :: [Bool] -> [Word8]+bitmapToBS [] = []+bitmapToBS xs+    = foldl (\b a -> (b `shiftL` 1) .|. fromBool a) 0 (take 8 (byte ++ repeat False)):bitmapToBS bytes+    where (byte,bytes) = splitAt 8 xs++fromBool :: (Num t) => Bool -> t+fromBool False = 0+fromBool True = 1++findNewPieces :: Piecemap -- ^ Our pieces. @findNewPiece@ may not return (Just i) if this!i == True.+              -> Piecemap -- ^ Remote pieces. @findNewPieces@ may not return (Just i) if this!i == False.+              -> [Int]    -- ^ Lazy list of pieces we can get from the remote peer.+findNewPieces ourPieces remotePieces+    = assert (bounds ourPieces == bounds remotePieces) $+      loop 0+    where len = rangeSize $ bounds ourPieces+          loop n+              | n < len = let gotPiece = ourPieces `unsafeAt` n+                              isAvailable = remotePieces `unsafeAt` n+                          in if not gotPiece && isAvailable+                             then n:loop (n+1)+                             else loop (n+1)+              | otherwise = []++-- Arrange pieces in rarest first where equally rare pieces are shuffled.+orderPieces :: StdGen -> Usecount -> [Int] -> [Int]+orderPieces gen usecount wantedPieces+    = concatMap (shuffle gen)+      $ map (map snd) $ groupBy (\a b -> fst a == fst b)+      $ sortBy (comparing fst)+            [ (unsafeAt usecount idx,idx) | idx <- wantedPieces ]++runSTDiffU :: (Ix i) => (forall s. ST s (STUArray s i Int)) -> DiffUArray i Int+runSTDiffU st = runST (st >>= unsafeFreeze)++setPiecemapBit :: TVar Piecemap -> Int -> Bool -> STM ()+setPiecemapBit piecemapVar pieceNum status+    = do piecemap <- readTVar piecemapVar+         writeTVar piecemapVar (piecemap // [(pieceNum,status)])++addPiecemap :: Piecemap -> Usecount -> Usecount+addPiecemap = modPiecemap (+)++addPiece :: Int -> Usecount -> Usecount+addPiece idx usecount+    = let n = unsafeAt usecount idx+      in usecount // [(idx, n+1)]++delPiecemap :: Piecemap -> Usecount -> Usecount+delPiecemap = modPiecemap (-)++modPiecemap :: (Int -> Int -> Int) -> Piecemap -> Usecount -> Usecount+modPiecemap ac pieceArr countArr+    = assert (bounds pieceArr == bounds countArr) $+      runSTDiffU mkArray+    where len = rangeSize $ bounds countArr+          mkArray = do arr <- newArray_ (bounds countArr)+                       let loop n+                               | n < len = let newVal = unsafeAt countArr n `ac` if unsafeAt pieceArr n then 1 else 0+                                           in unsafeWrite arr n newVal >> loop (n+1)+                               | otherwise = return ()+                       loop 0+                       return arr+++--------------------------------------------------------------+-- Tests.+--------------------------------------------------------------+#ifdef __CABAL_TEST__++instance Arbitrary Word8 where+    arbitrary = fmap fromIntegral (choose (0, 255) :: Gen Int)+instance Arbitrary (DiffArray Int Bool) where+    arbitrary = sized $ \n ->+                liftM (listArray (0,n-1)) (vector n)+    coarbitrary = undefined++instance Arbitrary (DiffUArray Int Int) where+    arbitrary = sized $ \n ->+                liftM (listArray (0,n-1)) (vector n)+    coarbitrary = undefined++{-+findNewPieces :: Piecemap -- ^ Our pieces. @findNewPiece@ may not return (Just i) if this!i == True.+              -> Piecemap -- ^ Remote pieces. @findNewPieces@ may not return (Just i) if this!i == False.+              -> [Int]    -- ^ Lazy list of pieces we can get from the remote peer.+-}++_prop_add_del piecemap usecount+    = assocs usecount == assocs (delPiecemap piecemap (addPiecemap piecemap usecount))++_prop_newPieces our remote+    = let newPieces = findNewPieces our remote+      in assocs our /= assocs remote ==> and [ not (our!p) && remote!p | p <- newPieces ]++_prop_identity piecemap+    = trivial (len==0) $ assocs piecemap == assocs (mkPiecemap len bs)+    where (l,u) = bounds piecemap+          len = u-l+1+          bs = fromPiecemap piecemap++_prop_bs_to_bitmap bs = trivial (null bs) $ bs == bitmapToBS (bsToBitmap bs)+_prop_bitmap_to_bs bitmap = trivial (null bitmap) $+                            bitmap == take (length bitmap) (bsToBitmap (bitmapToBS bitmap))+++#endif

@@ -0,0 +1,24 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.Protocol.PWP+-- Copyright   :  (c) Lemmih 2005-2006+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-----------------------------------------------------------------------------+module Conjure.Protocol.PWP+    ( PeerId (..)+    , Handshake (..)+    , Message (..)+    , hGetHandshake+    , hGetMessage+    , hPutHandshake+    , hPutMessage+    ) where++import Conjure.Protocol.PWP.Types+import Conjure.Protocol.PWP.Parser+import Conjure.Protocol.PWP.Printer

@@ -0,0 +1,107 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.Protocol.PWP.Parser+-- Copyright   :  (c) Lemmih 2005-2006+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable (requires Foreign.*)+--+-- Input handler for the Peer Wire Protocol.+-----------------------------------------------------------------------------+module Conjure.Protocol.PWP.Parser+    ( hGetHandshake+    , hGetMessage+    -- For tests+    , parseMessage+    ) where++import Control.Monad ( liftM )+import System.IO+import System.IO.Unsafe+import Foreign++import qualified Data.ByteString.Char8 as Char8+import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BS+import Data.ByteString (ByteString)++import Conjure.Protocol.PWP.Types+import Conjure.Utils++-- | Read a 4-byte big-endian @Int@ off the wire+hGetInt :: Handle -> IO Int+hGetInt h = do [a,b,c,d] <- mapM (liftM fromEnum) (replicate 4 (hGetChar h))+               return (a `shiftL` 24 + b `shiftL` 16 + c `shiftL` 8 + d)++-- | Parse a 4-byte big-endian @Int@+parseInt :: ByteString -> (Int, ByteString)+parseInt str+    = let [a,b,c,d] = map (fromIntegral . BS.index str) [0,1,2,3]+      in (a `shiftL` 24 .|. b `shiftL` 16 .|. c `shiftL` 8 .|. d, BS.drop 4 str)+++hGetHandshake :: Handle -> IO Handshake+hGetHandshake h = do c <- hGetChar h+                     let len = fromEnum c+                     if len /= 19 then error "Unknown protocol in handshake" else do+                     msg <- BS.hGet h len+                     if msg /= Char8.pack "BitTorrent protocol" then error "Unknown protocol in handshake" else do+                     BS.hGet h 8 -- Those 8 reserved bytes ...+                     infohash <- BS.hGet h 20+                     client <- unsafeInterleaveIO $ BS.hGet h 20+                     -- 'unsafeInterleaveIO' is required because+                     -- handshake could be without client id. This+                     -- happens when tracker wants to check whether+                     -- we are alive and not behind the NAT. This+                     -- way we could postpone reading client id for+                     -- later, after we have sent our own handshake+                     return $ Handshake infohash (PeerId client)++-- This a bit ugly.+-- | Read a @Message@ from a @Handle@ and report when chunks are downloaded.+hGetMessage :: (Integer -- ^ Current time in milliseconds.+                -> Int  -- ^ Bytes per second.+                -> IO ())+            -> Handle -> IO Message+hGetMessage report h+    = do len <- hGetInt h+         if len == 0 then return KeepAlive else do+         let loop l ptr+                 = do hWaitForInput h (-1)+                      realLen <- hGetBufNonBlocking h ptr l+                      now <- getCurrentTime+                      report now realLen+                      if realLen == l+                         then return ()+                         else loop (l-realLen) (advancePtr ptr realLen)+         msgID <- fmap BS.head $ BS.hGet h 1+         msg <- if msgID == 7+                then do fp <- mallocForeignPtrBytes (len-1)+                        withForeignPtr fp (loop (len-1))+                        return $ BS.fromForeignPtr fp 0 (len-1)+                else BS.hGet h (len - 1)+         return $! parseMessage msgID msg++-- FIXME: error handling.+parseMessage :: Word8 -> ByteString -> Message+parseMessage msgID payload+    = case msgID of+        0 -> Choke+        1 -> Unchoke+        2 -> Interested+        3 -> NotInterested+        4 -> Have (fst $ parseInt payload)+        5 -> BitField payload+        6 -> let [idx, offset, len] = take 3 (combine parseInt)+             in Request idx offset len+        7 -> let (idx,str') = parseInt payload+                 (offset,str'') = parseInt str'+             in RequestedPiece idx offset str''+        8 -> let [idx, offset, len] = take 3 (combine parseInt)+             in Cancel idx offset len+        _ -> Unknown msgID+    where combine f = let loop str = let (val,str') = f str in val : loop str'+                      in loop payload+

@@ -0,0 +1,72 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.Protocol.PWP.Printer+-- Copyright   :  (c) Lemmih 2005-2006+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Output handler for the Peer Wire Protocol.+-----------------------------------------------------------------------------+module Conjure.Protocol.PWP.Printer+    ( hPutHandshake+    , hPutMessage+    , serializeMessage+    ) where++import Data.Word+import System.IO+import Data.Bits++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS++import Conjure.Protocol.PWP.Types++-- | Write a 4-byte big-endian @Int@ to the wire+hPutInt :: Handle -> Int -> IO ()+hPutInt h x = BS.hPut h (BS.pack (serializeInt x))++-- | Convert an @Int@ to 4-byte big-endian format+serializeInt :: Int -> [Word8]+serializeInt x+    = [ fromIntegral $ x `shiftR` shft .&. 255 | shft <- [24,16,8,0]]++++hPutHandshake :: Handle -> Handshake -> IO ()+hPutHandshake h (Handshake i (PeerId c))+    = do hPutStr h $ "\19BitTorrent protocol" ++ replicate 8 '\0'+         BS.hPut h i+         BS.hPut h c+         hFlush h+++-- | Write a @Message@ to a @Handle@+hPutMessage :: Handle -> Message -> IO ()+hPutMessage h msg = do let str = serializeMessage msg+                       hPutInt h (myLength str)+                       LBS.hPut h str+                       hFlush h+  where myLength = sum . map BS.length . LBS.toChunks++-- | Return a message\'s body in wire form+serializeMessage :: Message -> LBS.ByteString+serializeMessage KeepAlive = LBS.empty+serializeMessage msg       = LBS.singleton tag `LBS.append` rest +    where+    (tag, rest) = case msg of +                  Choke         -> (0, LBS.empty)+                  Unchoke       -> (1, LBS.empty)+                  Interested    -> (2, LBS.empty)+                  NotInterested -> (3, LBS.empty)+                  Have n        -> (4, LBS.pack (serializeInt n))+                  BitField pieces  -> (5, LBS.fromChunks [pieces])+                  Request p off size -> (6, LBS.pack (concatMap serializeInt [p,off,size]))+                  RequestedPiece p off str +                                     -> (7, LBS.fromChunks $ BS.pack (concatMap serializeInt [p,off]):[str])+                  Cancel  p off size -> (8, LBS.pack (concatMap serializeInt [p,off,size]))+                  _ -> error "Conjure.Protocol.PWP.Printer.serializeMessage: can't happen"+

@@ -0,0 +1,55 @@+module Conjure.Protocol.PWP.Types where++import qualified Data.ByteString as BS+import Data.ByteString (ByteString)++import Data.Word++newtype PeerId = PeerId {unPeerId :: ByteString} deriving (Eq,Ord)++instance Show PeerId where+    showsPrec n (PeerId peerId) = showsPrec n peerId++data Handshake+    = Handshake+    { hsInfoHash :: ByteString+    , hsPeerId   :: PeerId+    }++-- | Message datatype. Should be revamped to use packed strings.+data Message +    = KeepAlive+    | Choke     +    | Unchoke    +    | Interested +    | NotInterested+    | Have !Int     -- ^ Note: this is not trustworthy (could claim pieces+                    -- it doesn't have that we will never want, could leave+                    -- out pieces we don't want that it has)+    | BitField ByteString -- ^ which Pieces this peer boasts to have++      -- | Request for a block of data. A bit complicated. See spec for detals.+    | Request { msgIndex    :: !Int, -- ^ Piece index+                msgBegin    :: !Int,      -- ^ Byte offset within piece+                msgLength   :: !Int       -- ^ Length in bytes, normally 2^14+              }+      +      -- | Such a block of data.+    | RequestedPiece+      { msgIndex    :: !Int        -- ^ Piece index+      , msgBegin    :: !Int        -- ^ Byte offset within piece+      , msgBlock    :: ByteString+      }+ +      -- | Cancel a request.+    | Cancel { msgIndex    :: !Int, -- ^ Piece index+               msgBegin    :: !Int,      -- ^ Byte offset within piece+               msgLength   :: !Int       -- ^ Length in bytes, normally 2^14+             }++      -- | Not a real message type, holds the id of an+      -- unknown message type+    | Unknown !Word8+      deriving (Eq,Show)++

@@ -0,0 +1,86 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.Protocol.THP+-- Copyright   :  (c) Lemmih 2005-2006+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable+--+--+-----------------------------------------------------------------------------+module Conjure.Protocol.THP+    ( queryTracker+    , Response (..)+    , PeerInfo (..)+    , Event (..)+    ) where++import Conjure.Types+import Conjure.Protocol.THP.Types+import Conjure.Protocol.THP.Parser+import Network.HTTP                 ( urlEncode, simpleHTTP+                                    , Request(..), RequestMethod(..)+                                    , rspBody, rspCode )+import BEncode.BEncode              ( bRead )+import BEncode.BParser              ( runParser )+import qualified Data.ByteString.Char8 as BS+-- import Data.ByteString (ByteString)++import Data.List                    ( intersperse )+import Network.URI                  ( uriQuery )+import Network                      ( PortNumber )++showEvent :: Event -> String+showEvent Started = "started"+showEvent Stopped = "stopped"+showEvent Completed = "completed"++-- | Encode a query in the way that webapps are so fond of+makeQuery :: [(String, String)]  -- ^ @parameter@-@value@ pairs+          -> String              -- ^ Resulting @URL@+makeQuery params = '?':concat (intersperse "&" $ map f params)+    where f (name, val) = name ++ "=" ++ urlEncode val+++-- | Query the tracker (TODO: factor some of these together when the+-- appropriate abstractions are ready+queryTracker :: Torrent      -- ^ The 'Torrent' we are asking about+             -> PeerId       -- ^ Peerid+             -> Maybe String -- ^ Optional @ip@ parameter+             -> PortNumber   -- ^ The listening @port@+             -> Integer      -- ^ Amount @uploaded@ sinse Starter event.+             -> Integer      -- ^ Amount @downloaded@ since Starter event.+             -> Integer      -- ^ Amount @left@ (not filesize minus @downloaded@!)+             -> Maybe Event+             -> IO Response+             -- ^ The response from the tracker++queryTracker torrent peerId ip port uploaded downloaded' left event+    = do Right rsp <- simpleHTTP (Request { rqMethod  = GET,+                                            rqURI     = newURI,+                                            rqHeaders = [],+                                            rqBody    = "" })++         let body = rspBody rsp+         if (case rspCode rsp of (2,_,_) -> False; _ -> True) then return $ Error $ head $ lines $ show rsp else do+         case bRead (BS.pack body) of+           Nothing -> return $ Error $ "Response not BEncoded. " ++ show body+           Just be -> case runParser parseResponse be of+                        Left err -> return $ Error $ err ++ "\n" ++ show be+                        Right rs -> return rs+    where baseURI = tAnnounce torrent+          newURI = baseURI { uriQuery = query }+          query = makeQuery $+                    optParam "ip" id ip $+                    optParam "event" showEvent event $+                    [("info_hash",  BS.unpack $ tInfoHash torrent),+                     ("peer_id",    BS.unpack $ unPeerId peerId),+                     ("port",       show port),+                     ("uploaded",   show uploaded),+                     ("downloaded", show downloaded'),+                     ("left",       show left)]+          optParam name ppVal mbVal+              = maybe id (\param lst -> (name, ppVal param):lst) mbVal+

@@ -0,0 +1,42 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.Protocol.THP.Parser+-- Copyright   :  (c) Lemmih 2005-2006+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Parser for the Tracker HTTP Protocol.+-----------------------------------------------------------------------------+module Conjure.Protocol.THP.Parser+    ( parseResponse+    ) where++import BEncode.BParser++import Conjure.Protocol.THP.Types++parseResponse :: BParser Response+parseResponse =+    errorResponse <|> okResponse++errorResponse :: BParser Response+errorResponse =+    do reason <- bstring $ dict "failure reason"+       return $ Error reason++okResponse :: BParser Response+okResponse =+    do interval <- bint $ dict "interval"+       complete <- optional $ bint $ dict "complete"+       incomplete <- optional $ bint $ dict "incomplete"+       peers <- list "peers" $ do peerID <- bfaststring $ dict "peer id"+                                  peerIP <- bstring $ dict "ip"+                                  peerPort  <- bint $ dict "port"+                                  return $ PeerInfo peerID peerIP peerPort+       return $ Info interval complete incomplete peers++{-+-}

@@ -0,0 +1,20 @@+module Conjure.Protocol.THP.Types where++import Data.ByteString (ByteString)++data Response+    = Error String+    | Info { rspInterval   :: Int+           , rspComplete   :: Maybe Int+           , rspIncomplete :: Maybe Int+           , rspPeers      ::[PeerInfo] +           } deriving (Show)++data PeerInfo = PeerInfo+    { iPeerId   :: ByteString+    , iPeerIp   :: String+    , iPeerPort :: Int+    } deriving (Show)++data Event = Started | Stopped | Completed+             deriving Show

@@ -0,0 +1,207 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.STM.PeerCtrl+-- Copyright   :  (c) Lemmih 2006+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable (requires STM)+--+-----------------------------------------------------------------------------+module Conjure.STM.PeerCtrl+    ( -- Peer actions+      disconnectPeer+    , sendMessage+    , sendPiece+    , cancelUpload+    , cancelUploads+    , sendCancel+    , sendRequest+      -- Network timings+    , recordTiming+    , getTimingAge+    , getTiming+      -- Utilities for peer helper threads+    , registerThread+    , unregisterThread+      -- Peer state+    , getLocalChoke+    , setLocalChoke+    , getRemoteChoke+    , setRemoteChoke+    , getLocalInterest+    , getRemoteInterest+    , setRemoteInterest+      -- Peer interest calculations+    , rescanInterest+    , recalculateInterest+    ) where++import Data.List+import Data.Array.Base++import Conjure.Types+import Conjure.Piecemap+import Conjure.Protocol.PWP.Types++import Control.Concurrent.STM+import Control.Exception+import Control.Monad+import GHC.Conc++import qualified Data.Set as Set+++disconnectPeer :: ConnectedPeer -> STM ()+disconnectPeer peer+    = writeTChan (cpMsgChan peer) Disconnect++sendMessage :: ConnectedPeer -> Message -> STM ()+sendMessage connPeer msg+    = writeTChan (cpOutChan connPeer) (SendMessage msg)++sendPiece :: ConnectedPeer -> Int -> Int -> Int -> STM ()+sendPiece connPeer idx offset len+    = writeTChan (cpOutChan connPeer) (SendPiece idx offset len)++cancelUpload :: ConnectedPeer -> Int -> Int -> Int -> STM ()+cancelUpload connPeer idx offset len+    = writeTChan (cpOutChan connPeer) (ClearPiece idx offset len)++cancelUploads :: ConnectedPeer -> STM ()+cancelUploads connPeer+    = writeTChan (cpOutChan connPeer) ClearPieces++sendCancel :: ConnectedPeer -> Block -> STM ()+sendCancel connPeer (piece, offset, len)+    = sendMessage connPeer (Cancel (pIndex piece) offset len)++sendRequest :: ConnectedPeer -> Block -> STM ()+sendRequest connPeer (piece, offset, len)+    = sendMessage connPeer (Request (pIndex piece) offset len)+++recordTiming :: TVar Timing -> Integer -> Int -> STM ()+recordTiming tvar date size+    = do Timing _ tmings <- readTVar tvar+         writeTVar tvar (Timing date $ take 40 $ (date,size):tmings) -- We only want to keep 40 timings.+         --bps <- getTiming date 20000 tvar+         --stmDebug $ "  b/s: " ++ show bps ++ ", kb/s: " ++ show (bps `div` 1024)++getTimingAge :: Integer -> TVar Timing -> STM Integer+getTimingAge now tvar+    = do Timing lastRecording _ <- readTVar tvar+         return (now - lastRecording)++getTiming :: Integer     -- ^ Current date in milliseconds.+          -> Integer     -- ^ Age limit in milliseconds.+                         -- 20000 => only consider timings from the last 20 seconds.+          -> TVar Timing -- TVar containing the timings.+          -> STM Int     -- bps+getTiming now limit tvar+    = do Timing _ tmings <- readTVar tvar+         let t' = filter ((>now-limit) . fst) tmings+             timeSpan = fromIntegral (now - fst (last t'))+             bps = (fromIntegral (sum (map snd t')) / (timeSpan / 1000) ::Double)+         if null t'+            then return 0+            else return (round bps)++++registerThread :: ConnectedPeer -> ThreadId -> STM ()+registerThread peer tid+    = do threads <- readTVar (cpThreads peer)+         writeTVar (cpThreads peer) (Set.insert tid threads)++unregisterThread :: ConnectedPeer -> ThreadId -> STM ()+unregisterThread peer tid+    = do threads <- readTVar (cpThreads peer)+         assert (Set.member tid threads) $ writeTVar (cpThreads peer) (Set.delete tid threads)+++++getLocalChoke :: ConnectedPeer -> STM Bool+getLocalChoke = readTVar . cpLocalChoke++setLocalChoke :: ConnectedPeer -> Bool -> STM ()+setLocalChoke connPeer val+    = writeTVar (cpLocalChoke connPeer) val++getRemoteChoke :: ConnectedPeer -> STM Bool+getRemoteChoke = readTVar . cpRemoteChoke++setRemoteChoke :: ConnectedPeer -> Bool -> STM ()+setRemoteChoke connPeer val+    = writeTVar (cpRemoteChoke connPeer) val++++getLocalInterest :: ConnectedPeer -> STM Bool+getLocalInterest = readTVar . cpLocalInterest++setLocalInterest :: ConnectedPeer -> Bool -> STM ()+setLocalInterest connPeer val+    = writeTVar (cpLocalInterest connPeer) val++getRemoteInterest :: ConnectedPeer -> STM Bool+getRemoteInterest = readTVar . cpRemoteInterest++setRemoteInterest :: ConnectedPeer -> Bool -> STM ()+setRemoteInterest connPeer val+    = writeTVar (cpRemoteInterest connPeer) val++{-++ Local interest \ piece origins.++                |  Local  |  Remote  |+ Interested     |  True   |  False   |+ Not interested |  False  |  True    |+-}+possibleStateChange :: Bool {- local piece -} -> Bool {- local interest -} -> Bool+possibleStateChange True lInterest = lInterest+possibleStateChange False lInterest = not lInterest++{-+  Perform a complete interest rescan. This is necessary after we+  receive bitfields.+-}+rescanInterest :: ActiveTorrent -> ConnectedPeer -> STM ()+rescanInterest at connPeer+    = do lInterest <- getLocalInterest connPeer+         when (possibleStateChange False lInterest) $+           rescanInterest' lInterest at connPeer++{-+  Perform a minimal interest re-calculation. Only a single bit has changed+  so we may be able to tell our interest without costly calculations.+-}+recalculateInterest :: Bool -> Int -> ActiveTorrent -> ConnectedPeer -> STM ()+recalculateInterest local idx at connPeer+    = do lInterest <- getLocalInterest connPeer+         when (possibleStateChange local lInterest) $+              do piecemap <- readTVar $ if local then cpPiecemap connPeer else atPiecemap at+                 case (unsafeAt piecemap idx, local) of+                   -- We received a new piece and he has it too. Are we still interested?+                   (True, True)   -> rescanInterest' lInterest at connPeer+                   -- He received a new piece which we don't have. Assert our interest.+                   (False, False) -> do setLocalInterest connPeer True+                                        sendMessage connPeer Interested+                   -- Either he received a piece that we have or we received a piece that he hasn't.+                   -- No interest change possible.+                   _ -> return ()++rescanInterest' :: Bool -> ActiveTorrent -> ConnectedPeer -> STM ()+rescanInterest' lInterest at connPeer+    = do rPiecemap <- readTVar (cpPiecemap connPeer)+         lPiecemap <- readTVar (atPiecemap at)+         case findNewPieces lPiecemap rPiecemap of+           [] -> when lInterest $+                 do setLocalInterest connPeer False+                    sendMessage connPeer NotInterested+           _  -> unless lInterest $+                 do setLocalInterest connPeer True+                    sendMessage connPeer Interested

@@ -0,0 +1,175 @@+{-++ Copyright (c) 2005 Jesper Louis Andersen <jlouis@mongers.org>++ Permission to use, copy, modify, and distribute this software for any+ purpose with or without fee is hereby granted, provided that the above+ copyright notice and this permission notice appear in all copies.++ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.++-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.Torrent+-- Copyright   :  (c) Jesper Louis Andersen, 2005+--                (c) Lemmih, 2005-2006+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  believed to be stable+-- Portability :  portable+--+-- This module provides the basic one abstraction of Conjure. A Torrent+-- type is the basic type of torrents, which the rest of the software+-- uses to identify and manipulate torrent files. They are actually+-- nothing more than simple BEncoded strings, built into ASTs and kept+-- inside the Torrent type.+--+-- Several logical operations are available on Torrent types. These+-- allow the programmer to work on Torrents and retrieve information+-- about them, without having to dig around inside the structure+-- manually.+-----------------------------------------------------------------------------+module Conjure.Torrent+    ( getPieceFilePaths -- :: Torrent -> Int -> [(FilePath,Int,Int)]+    , getBlockFilePaths -- :: Torrent -> Int -> Int -> Int -> [(FilePath,Int,Int)]+    , pieceLength       -- :: Torrent -> Int -> Int+    , pieceCheckSum     -- :: Torrent -> Int -> ByteString+    , infoNumPieces     -- :: Torrent -> Int+    , infoTotalBytes    -- :: Torrent -> Integer+    , readTorrentFile   -- :: FilePath -> IO (Either String Torrent)+    ) where++import BEncode.BEncode as BE+import BEncode.BParser+import qualified Data.ByteString.Char8 as BS+import Data.ByteString (ByteString)+import Conjure.Utils.SHA1 (sha1)++import Control.Monad++import Data.List++import System.FilePath+import Network.URI++import Conjure.Types++buri :: BParser BEncode -> BParser URI+buri p = do str <- bstring p+            case parseURI str of+              Nothing -> fail $ "Expected URI: " ++ str+              Just uri -> return uri++parseTorrent :: BParser Torrent+parseTorrent =+    do announce <- buri $ dict "announce"+       creator  <- optional $ bstring $ dict "created by"+       info     <- dict "info"+       setInput info+       name     <- bstring $ dict "name"+       pLen     <- bint $ dict "piece length"+       pieces   <- bfaststring $ dict "pieces"+       torrentInfo      <- parseTorrentInfo name pLen pieces+       let infoHash = sha1 (BS.pack $ BE.bShow info "")+       return $ Torrent announce [] "" creator torrentInfo infoHash++parseTorrentInfo :: String -> Int -> ByteString -> BParser TorrentInfo+parseTorrentInfo name pLen pieces+    = do len <- bint $ dict "length"+         return $ SingleFile len name pLen pieces+      <|>+      do files <- list "files" $ do len <- bint $ dict "length"+                                    filePaths <- list "path" $ bstring token+                                    return $ TorrentFile len (joinPath filePaths)+         return $ MultiFile files name pLen pieces+++-- | The size of a SHA1 Sum. It should probably be defined elsewhere+sizeSHA :: Int+sizeSHA = 20++-- | Assume that the given String is a Torrent file and attempt to read+--   it in. The function return Left err if it was impossible to validate+--   the String as a torrent file and Right Torrent in the case where the+--   torrent file could be parsed.+readTorrent :: ByteString -> Either String Torrent+readTorrent str+    = case BE.bRead str of+        Just be -> runParser parseTorrent be+        Nothing -> Left "String is not BEncoded."++-- | Assume the file pointed to by the FilePath is a torrent file+--   and attempt to read it.+readTorrentFile :: FilePath -> IO (Either String Torrent)+readTorrentFile = (liftM readTorrent) . BS.readFile++-- | Length of particular piece (all except the last one are the same)+pieceLength :: Torrent -> Int -> Int+pieceLength t p | p < (infoNumPieces t)-1 = tPieceLength (tInfo t)+pieceLength t _ | otherwise               = fromIntegral $ infoTotalBytes t `mod` fromIntegral (tPieceLength (tInfo t))++infoTotalBytes :: Torrent -> Integer+infoTotalBytes t = sum $ map (fromIntegral.snd) $ fileInfo t++infoPieces :: Torrent -> ByteString+infoPieces = tPieces . tInfo++pieceCheckSum :: Torrent -> Int -> ByteString+pieceCheckSum t n = BS.take 20 (BS.drop (n*20) (infoPieces t))++-- | Calculate the number of Pieces of a given Torrent file+infoNumPieces :: Torrent -> Int+infoNumPieces t = (BS.length . infoPieces) t `div` sizeSHA++-- | Find wanted blocks from a greater whole.+-- Used for picking pieces out of files and blocks out of pieces.+findBlocks :: Int -> Int -> [(FilePath, Int, Int)] -> [(FilePath, Int, Int)]+findBlocks blockStart blockLen units+    = worker 0 units+    where worker unitStart []+              | unitStart < blockLen = error "Conjure.Torrent.findBlocks: Block exceeded unit space"+              | otherwise = []+          worker unitStart ((pth,unitOffset,unitLen):xs)+              | blockEnd <= unitStart = []+              | blockStart < unitEnd+                  = let startPos = max 0 (blockStart-unitStart)+                        unitLen' = min blockEnd unitEnd - startPos - unitStart+                    in (pth, startPos+unitOffset, unitLen'):worker unitEnd xs+              | otherwise = worker unitEnd xs+              where unitEnd = unitStart + unitLen+          blockEnd = blockStart + blockLen++getPieceFilePaths :: Torrent -> Int -> [(FilePath,Int,Int)]+getPieceFilePaths torrent pieceNum+    = case tInfo torrent of+        SingleFile {tName = name} -> [(name,pieceStart,pieceLength torrent pieceNum)]+        MultiFile {tName = name+                  ,tFiles = files}+            -> let entries = map (\file -> (name </> filePath file, 0, fileLength file)) files+               in findBlocks pieceStart (pieceLength torrent pieceNum) entries+    where pLen = tPieceLength (tInfo torrent)+          pieceStart = pieceNum*pLen++getBlockFilePaths :: Torrent -> Int -> Int -> Int -> [(FilePath,Int,Int)]+getBlockFilePaths torrent pieceNum blockStart blockLength+    = findBlocks blockStart blockLength pieceEntries+    where pieceEntries = getPieceFilePaths torrent pieceNum++-- | Unpack the list of files in the torrent+fileInfo :: Torrent -> [(FilePath, Int)]+fileInfo t+    = case tInfo t of+        SingleFile { tLength = len, tName = name }+            -> [(name,len)]+        MultiFile { tFiles = files}+            -> map (\f -> (filePath f, fileLength f)) files++

@@ -0,0 +1,163 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.Types+-- Copyright   :  (c) Lemmih 2005-2006+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable (requires STM)+--+-----------------------------------------------------------------------------+module Conjure.Types+    ( module Conjure.Types+    , PeerId (..)+    ) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception+import Data.Array.Diff+import Network.URI+import Data.IntMap (IntMap)+import Data.Map (Map)+import Data.Set (Set)+import System.IO+import Data.ByteString (ByteString)+import Conjure.Protocol.PWP.Types++type Piecemap = DiffArray Int Bool++type Usecount = DiffUArray Int Int++data Torrent+    = Torrent+    { tAnnounce     :: URI+    , tAnnounceList :: [URI]+    , tComment      :: String+    , tCreatedBy    :: Maybe String+--    , tCreationData :: ? -- FIXME+    , tInfo         :: TorrentInfo+    , tInfoHash     :: ByteString+    } deriving Show++data TorrentInfo+    = SingleFile+    { tLength      :: Int+    , tName        :: String+    , tPieceLength :: Int+    , tPieces      :: ByteString }+    | MultiFile+    { tFiles       :: [TorrentFile]+    , tName        :: String+    , tPieceLength :: Int+    , tPieces      :: ByteString+    } deriving Show++data TorrentFile+    = TorrentFile+    { fileLength :: Int+    , filePath   :: FilePath+    } deriving Show++data Backend+    = Backend+    { close       :: IO ()+--    , sendPiece   :: Int -> Handle -> IO ()+    , readPiece   :: Int -> IO ByteString+    , readPiece'  :: Int -> IO (Maybe ByteString)+    , writeBlock  :: Int -> Int -> ByteString -> IO ()+    , readBlock   :: Int -> Int -> Int -> IO ByteString+    , commitPiece :: Int -> IO ()+    }++data PeerCtrl+    = NewInput Message     -- Received a new message.+    | Disconnect+    | SockError Exception  -- Error occurred while waiting for input.+--      deriving Show++data OutputCtrl+    = SendMessage Message+    | SendPiece !Int !Int !Int -- idx, offset, len+    | ClearPiece !Int !Int !Int -- idx, offset, len+    | ClearPieces++{-+data UploadStatus+    = Inactive+    | Regular+    | Seeding ClockTime+    | Optimistic ClockTime+-}++data ConnectedPeer+    = ConnectedPeer+    { cpThreads         :: TVar (Set ThreadId)+    , cpMsgChan         :: TChan PeerCtrl+    , cpOutChan         :: TChan OutputCtrl+    , cpPeerId          :: PeerId+    , cpTorrent         :: Torrent+    , cpPiecemap        :: TVar Piecemap+    , cpLocalChoke      :: TVar Bool+    , cpRemoteChoke     :: TVar Bool+    , cpLocalInterest   :: TVar Bool+    , cpRemoteInterest  :: TVar Bool+    , cpUploadTimings   :: TVar Timing+    , cpDownloadTimings :: TVar Timing+    , cpPendingBlocks   :: TVar (Map (Int,Int) Block)+    , cpQueueLength     :: TVar Int+      -- ^ How many pending blocks we want. FIXME: Should this be global?+--    , cpUploadStatus    :: TVar UploadStatus+    }++instance Eq ConnectedPeer where+    cp1 == cp2 = cpPeerId cp1 == cpPeerId cp2++instance Ord ConnectedPeer where+    cp1 `compare` cp2 = cpPeerId cp1 `compare` cpPeerId cp2++data Timing+    = Timing { lastTiming :: Integer       -- Last recorded measurement in millieseconds.+             , timings :: [(Integer, Int)] -- time of measurement in millieseconds, bytes transferred.+             } ++data ActiveTorrent+    = ActiveTorrent+    { atTorrent    :: Torrent+    , atClient     :: ThreadId+    , atBackend    :: Backend+    , atPeerId     :: PeerId               -- Local peerid for this torrent.+                                           -- We keep a distinct peerid for each torrent.+    , atUsecount   :: TVar Usecount+    , atPiecemap   :: TVar Piecemap+    , atPieces     :: TVar (IntMap Piece)+    , atPeers      :: TVar [ConnectedPeer] -- Use a Set or Sequence?+    , atDownloaded :: TVar Integer+    , atUploaded   :: TVar Integer+    , atLeft       :: TVar Integer+    }++-- FIXME: Use a Set?+data BlockStatus+    = Active [ConnectedPeer]+    | Downloaded++instance Show BlockStatus where+    show (Active lst) = "(Active " ++ show (length lst) ++ ")"+    show Downloaded = "Downloaded"++data Piece+    = Piece+    { pIndex  :: Int+    , pStatus :: TVar [BlockStatus]+    }++instance Eq Piece where+    p1 == p2 = pIndex p1 == pIndex p2++instance Show Piece where+    showsPrec n p = showString "Piece " . showsPrec n (pIndex p)++type Block = (Piece,Int,Int) -- (Piece, offset, length)+

@@ -0,0 +1,122 @@+module Conjure.UI.Http (httpServer) where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception++import Conjure.Types+import Conjure.Utils+import Conjure.Piecemap+import Conjure.Network.Peer ()+import Conjure.STM.PeerCtrl+import Conjure.Debug++import System.IO+import GHC.Conc (unsafeIOToSTM)+import Data.Map (Map)+import Data.List+import Data.Array.Diff hiding ((!))+import qualified Data.ByteString as BS+import Network                ( PortID(..), PortNumber, listenOn, accept )++import qualified Data.Map as Map+import qualified Data.IntMap as IntMap+import Text.Html++httpServer :: TVar [ConnectedPeer]+          -> TVar (Map BS.ByteString ActiveTorrent)+          -> PortNumber+          -> IO ()+httpServer connectedPeers torrentMap port+    = do sock <- listenOn (PortNumber port)+         debug $ "HTTP UI Server is awaiting connections. Socket: " ++ show sock+         let loop = do (hndle, hostname, prt) <- accept sock+                       debug $ "HTTP UI server got connect from: " +++                               show hostname ++ ":" ++ show prt +++                               " (handle: " ++ show hndle ++ ")"+                       forkIO (handleUIrequest connectedPeers torrentMap hndle `finally` hClose hndle)+                       loop+         loop++handleUIrequest :: TVar [ConnectedPeer] -> TVar (Map k ActiveTorrent)+                                               -> Handle+                                               -> IO ()+handleUIrequest connectedPeers torrentMap hndle =+  do request <- hGetLine hndle+     page <- atomically $+             do peers <- readTVar connectedPeers+                torrents <- readTVar torrentMap+                at_rows <- mapM dumpActiveTorrent (zip ones (Map.elems torrents))+                peer_rows <- mapM dumpConnectedPeer (zip ones peers)+                return $ body <<+                         h1 << "Request:" +++ request ++++                         table![border 1] <<+                           ( ( th << "Torrent map:" <-> th << "Connected peers:" )+                             </>+                             ( td![valign "top"] << ( table![border 1] << at_rows ) <->+                               td![valign "top"] << ( table![border 1] <<+                                                      ( (th << "#"                <->+                                                         th << "Choke"            <-> th << "Interest"       <->+                                                         th << "Pending" <->+                                                         th << "Download kb/s"    <-> th << "Upload kb/s"    <->+                                                         th << "Complete"+                                                        )+                                                        </>+                                                        (tr << peer_rows)+                                                      )+                                                    )+                             )+                           )+     hPutStr hndle $ renderHtml page+  where+  ones :: [Int]+  ones = [1..]+  dumpActiveTorrent (n,at) =+    do up <- readTVar $ atUploaded at+       down <- readTVar $ atDownloaded at+       piece_map <- readTVar $ atPiecemap at+       pieces <- do pmap <- readTVar $ atPieces at+                    mapM (\(idx,q) -> do s<-readTVar (pStatus q); return (idx,s)) (IntMap.toList pmap)+       let files = tFiles' (tInfo $ atTorrent at)+       return $ td << ("Torrent number " +++ show n) <->+                  ( ( td << "Our Peer ID:" <-> td << (show $ atPeerId at) <->+                      td << "Uploaded:" <->  td << (show up) <->+                      td << "Downloaded:" <-> td << (show down)+                    )+                    </>+                    ( td <<"Piecemap:"  <-> td << drawPiecemap piece_map "")+                    </>+                    ( td << "Pieces:" <-> td << (foldr (\x y -> x +++ br +++ y) noHtml $ map show pieces))+                    </>+                    ( td << "Files:" <-> files )+                  )++  tFiles' (SingleFile len nme plen _) =+    td << nme <-> td << (show len +++ " bytes") <-> td << (show plen ++ " bytes per piece)")+  tFiles' (MultiFile files nme plen _) =+    (td << nme <-> td << (show plen ++ " bytes per piece)"))+    </>+    (aboves $ map tFile' files)+  tFile' (TorrentFile len path) =+    td << path <-> td << (show len +++ " bytes")++  dumpConnectedPeer (n,cp) =+    do lChoke <- getLocalChoke cp+       rChoke <- getRemoteChoke cp+       lInterest <- getLocalInterest cp+       rInterest <- getRemoteInterest cp+       pending <- readTVar (cpPendingBlocks cp)+       now <- unsafeIOToSTM $ getCurrentTime+       downBps <- if lInterest && not rChoke+                  then fmap (Just .flip div 1024) $ getTiming  now 20000 (cpDownloadTimings cp)+                  else return Nothing+       upBps <- if rInterest && not lChoke+                then fmap (Just .flip div 1024) $ getTiming  now 20000 (cpUploadTimings cp)+                else return Nothing+       piecemap <- readTVar (cpPiecemap cp)+       let complete = fromIntegral (length $ filter id $ elems piecemap) / (fromIntegral (rangeSize $ bounds piecemap) :: Double)+       return $ td << (show n) <->+                td << (show (lChoke,rChoke)) <-> td<< (show (lInterest,rInterest)) <->+                td << (show (Map.size pending)) <->+                td << (show downBps) <->td<<(show upBps)<->+                td << (show (complete * 100) ++ "%")

@@ -0,0 +1,28 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.Utils+-- Copyright   :  (c) Lemmih 2006+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-----------------------------------------------------------------------------+module Conjure.Utils where++import System.Time+import Control.Monad+import Control.Concurrent.STM++-- Get current time in milliseconds.+getCurrentTime :: IO Integer+getCurrentTime =+    do TOD secs pico <- getClockTime+       return $ secs*1000 + (pico `div` 10^(10::Int))+++modifyTVar_ :: TVar a -> (a -> a) -> STM ()+modifyTVar_ tvar fn+    = do var <- readTVar tvar+         writeTVar tvar $! fn var

@@ -0,0 +1,99 @@+{-# LANGUAGE ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.Utils.Logger+-- Copyright   :  (c) Lemmih 2006+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable (POSIX)+--+-----------------------------------------------------------------------------+-- FIXME: What do we do on Windows?+#include <syslog.h>+module Conjure.Utils.Logger+    ( Mask+    , Option (..)+    , Priority (..)+    , setlogmask+    , openlog+    , syslog+    , closelog+    ) where++import Foreign+import Foreign.C+import Data.Bits++foreign import ccall unsafe "openlog" c_openlog :: CString -> Int -> Int -> IO ()+foreign import ccall unsafe "syslog" c_syslog :: Int -> CString -> CString -> IO ()+foreign import ccall unsafe "closelog" closelog :: IO ()+foreign import ccall unsafe "setlogmask" c_setlogmask :: Int -> IO Int++data Mask+    = Bitmask [Priority]+    | Upto Priority++logMask, logUpTo :: (Bits t) => Priority -> t+logMask p = 1 `shiftL` fromPriority p+logUpTo p = 1 `shiftL` fromPriority p+++fromMask :: (Bits a) => Mask -> a+fromMask (Bitmask ps) = foldr (.|.) 0 (map logMask ps)+fromMask (Upto p)     = logUpTo p++setlogmask :: Mask -> IO ()+setlogmask mask+    = do c_setlogmask (fromMask mask)+         return ()++data Option+    = Console+    | NoDelay+    | NoWait+    | Delay+    | PError+    | PID++fromOption :: (Num t) => Option -> t+fromOption Console = #{const LOG_CONS}+fromOption NoDelay = #{const LOG_NDELAY}+fromOption NoWait = #{const LOG_NOWAIT}+fromOption Delay = #{const LOG_ODELAY}+fromOption PError = #{const LOG_PERROR}+fromOption PID = #{const LOG_PID}++openlog :: [Option] -> String -> IO ()+openlog options ident+    = withCString ident $ \cstr ->+      c_openlog cstr (foldr (.|.) 0 (map fromOption options))+                #{const LOG_USER}++data Priority+    = Emergency+    | Alert+    | Critical+    | Error+    | Warning+    | Notice+    | Info+    | Debug++fromPriority :: Priority -> Int+fromPriority Emergency = #{const LOG_EMERG }+fromPriority Alert = #{const LOG_ALERT }+fromPriority Critical = #{const LOG_CRIT }+fromPriority Error = #{const LOG_ERR }+fromPriority Warning = #{const LOG_WARNING }+fromPriority Notice = #{const LOG_NOTICE }+fromPriority Info = #{const LOG_INFO }+fromPriority Debug= #{const LOG_DEBUG }++syslog :: Priority -> String -> IO ()+syslog priority msg+    = withCString "%s" $ \format ->+      withCString msg $ \cstr ->+      c_syslog (fromPriority priority) format cstr+

@@ -0,0 +1,35 @@+{-# LANGUAGE ForeignFunctionInterface #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.Utils.SHA1+-- Copyright   :  (c) Lemmih 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-----------------------------------------------------------------------------+-- FIXME: Move this to Conjure.SHA1?+module Conjure.Utils.SHA1 (sha1) where++import Foreign+import Foreign.C+import System.IO.Unsafe++import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Internal as ByteString+import qualified Data.ByteString.Unsafe as ByteString (unsafeUseAsCString)+import Data.ByteString.Char8 (ByteString)++--void SHA1(sha1_byte *data, unsigned int len, sha1_byte digest[SHA1_DIGEST_LENGTH]);+foreign import ccall unsafe "SHA1" c_sha1 :: CString -> Int -> CString -> IO ()++sha1 :: ByteString -> ByteString+sha1 fs = unsafePerformIO $+          ByteString.unsafeUseAsCString fs $ \cstr ->+              do ret <- mallocBytes 20+                 c_sha1 cstr (BS.length fs) ret+                 fp <- newForeignPtr finalizerFree (castPtr ret)+                 return $ ByteString.fromForeignPtr fp 0 20

@@ -0,0 +1,43 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.Utils.Shuffle+-- Copyright   :  (c) Lemmih 2005-2006+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-----------------------------------------------------------------------------+module Conjure.Utils.Shuffle+    ( shuffle+    ) where++import Data.Array.IO+import Data.Array.MArray (MArray(..))+import Data.Array.Base (unsafeRead,unsafeWrite)++import System.IO.Unsafe++import System.Random++shuffle :: StdGen -> [e] -> [e]+shuffle _ []  = []+shuffle gen lst = unsafePerformIO $+                  do arr <- newListArray (0,length lst - 1) lst+                     shuffleArr gen arr++shuffleArr :: (RandomGen g) => g -> IOArray Int e -> IO [e]+shuffleArr gen arr+    = do b <- getBounds arr+         let loop _ 0 = return []+             loop gen' top+                 = unsafeInterleaveIO $+                   do let (n, gen'') = randomR (0, top-1) gen'+                      aObj <- unsafeRead arr n+                      bObj <- unsafeRead arr (top-1)+                      unsafeWrite arr n bObj+                      rest <- loop gen'' (top-1)+                      return (aObj:rest)+         loop gen (rangeSize b)+

@@ -0,0 +1,39 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, MultiParamTypeClasses #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.Utils.Transaction+-- Copyright   :  (c) Lemmih 2006+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  experimental+-- Portability :  non-portable (requires STM)+--+-----------------------------------------------------------------------------+module Conjure.Utils.Transaction where++import Control.Concurrent.STM+import Control.Monad.State++newtype Transaction a = Transaction (StateT [IO ()] STM a) deriving (Monad,MonadPlus)++instance MonadState [IO ()] Transaction where+    get = Transaction get+    put a = Transaction (put a)++-- | Run a STM action.+stm :: STM a -> Transaction a+stm action = Transaction (lift action)++-- | Execute an IO action when the transaction commits.+onCommit :: IO a -> Transaction ()+onCommit action+    = do lst <- get+         put ((action>>return()):lst)++-- | Execute an atomic transaction.+runT :: Transaction a -> IO a+runT (Transaction trans)+    = do (a,lst) <- atomically $ runStateT trans []+         sequence_ (reverse lst)+         return a

@@ -0,0 +1,70 @@+{-# LANGUAGE CPP #-}+{-+ Copyright (c) 2005 Jesper Louis Andersen <jlouis@mongers.org>++ Permission to use, copy, modify, and distribute this software for any+ purpose with or without fee is hereby granted, provided that the above+ copyright notice and this permission notice appear in all copies.++ THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES+ WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF+ MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR+ ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES+ WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN+ ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF+ OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.+-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Conjure.Version+-- Copyright   :  (c) Jesper Louis Andersen, 2005+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  jlouis@mongers.org+-- Stability   :  believed to be stable+-- Portability :  portable+--+-- The Conjure.Version module is responsible for Conjure Version+-- control.+-----------------------------------------------------------------------------+#ifndef __HADDOCK__+#include <ghcconfig.h>+#endif+module Conjure.Version+  (+    conjure_version,+    showVersionHeader+  )+where++import Data.Version as Version++-- | List the conjure version. Our version numbers are listed by+--   Date, like all versions of software should be. To make it easier+--   to refer to a given version, they are given a tag which is a+--   pronounceable string with a certain magical feel to it.+conjure_version :: Version.Version+conjure_version =+  Version.Version { Version.versionBranch = [2005, 12, 15],+                    Version.versionTags = ["WASTING"]}++-- Other names for different versionTags:+-- SORCERY, MAGIC, RITUAL, RITE, CAULDRON, ILLUSION, DEMONOLOGY,+-- NECROMANCY, DRAGONOLOGY, ASTRAL, PLANEWALKER, FIREBALL,+-- LIGHTNING_STRIKE, PENTAGRAM, SOULTAP, BARRIER, SUMMON, HEX,+-- WIZARDRY, CONJURATON, INFLUENCE, DISINTEGRATE, ELEMENTALIST,+-- EXORCISM, TELEKINESIS, TELEPATHY, TREMOR, TRANQUILITY, ALAKAZAM!+-- MANDRAKE, NIGHTSHADE, FOCI, BANISHMENT, WANING, WAXING.+-- etc... (jlouis)++-- Old names: BREWING STEWING++-- | Convert the Version into a header+-- FIXME+showVersionHeader :: Version.Version -> String+showVersionHeader version =+  concat ["This is Conjure built for ", "PLATFORM",+          "\n  GHC version: ", "GHC_VERSION",+          "\n  Version: ", Version.showVersion version,+          "\n  Internal patch count: ", "PATCH_COUNT",+          "\nI am ready to summon the files you need."]