diff --git a/AUTHORS b/AUTHORS new file mode 100644 --- /dev/null +++ b/AUTHORS @@ -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 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 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 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 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 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 neuralnoise.com -- xerox on #haskell@freenode: + Documentation fixes when jlouis was too sleepy and attempted + a documentation write. + +Name: Taral +Contact: taral taral.net -- + Provided a neat patch to MiniHTTP making its urlEncoder much nicer. diff --git a/DEVELOPING b/DEVELOPING new file mode 100644 --- /dev/null +++ b/DEVELOPING @@ -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. diff --git a/INSTALL b/INSTALL new file mode 100644 --- /dev/null +++ b/INSTALL @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,18 @@ + + Copyright (c) 2005 Jesper Louis Andersen + Copyright (c) 2005 Samuel Bronson + Copyright (c) 2005 Dmitry Astapov + Copyright (c) 2005 Lemmih + + 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. + diff --git a/MILESTONES b/MILESTONES new file mode 100644 --- /dev/null +++ b/MILESTONES @@ -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. +=============================== + + diff --git a/READTHEM b/READTHEM new file mode 100644 --- /dev/null +++ b/READTHEM @@ -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 diff --git a/STYLE b/STYLE new file mode 100644 --- /dev/null +++ b/STYLE @@ -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 `` 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,5 @@ +#!/usr/bin/runhaskell + +import Distribution.Simple + +main = defaultMainWithHooks simpleUserHooks diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -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 ] + +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 ] + +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 + diff --git a/cbits/sha1.c b/cbits/sha1.c new file mode 100644 --- /dev/null +++ b/cbits/sha1.c @@ -0,0 +1,166 @@ +/* + * sha1.c + * + * Originally witten by Steve Reid + * + * Modified by Aaron D. Gifford + * + * 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 + +#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); +} + diff --git a/cbits/sha1.h b/cbits/sha1.h new file mode 100644 --- /dev/null +++ b/cbits/sha1.h @@ -0,0 +1,75 @@ +/* + * sha.h + * + * Originally taken from the public domain SHA1 implementation + * written by by Steve Reid + * + * Modified by Aaron D. Gifford + * + * 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 + diff --git a/conjure.cabal b/conjure.cabal new file mode 100644 --- /dev/null +++ b/conjure.cabal @@ -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 diff --git a/conjure.glade b/conjure.glade new file mode 100644 --- /dev/null +++ b/conjure.glade @@ -0,0 +1,231 @@ + + + + + + + True + $file - Conjurer $version + GTK_WINDOW_TOPLEVEL + GTK_WIN_POS_NONE + False + True + False + True + False + False + GDK_WINDOW_TYPE_HINT_NORMAL + GDK_GRAVITY_NORTH_WEST + True + + + + 4 + True + False + 8 + + + + True + False + 4 + + + + True + False + 0 + + + + True + filename + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + False + + + + + + True + filesize + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + False + + + + + 0 + True + True + + + + + + + + + + True + white.ico + 0.5 + 0.5 + 0 + 0 + + + 0 + False + True + + + + + 0 + False + False + + + + + + 4 + True + False + 4 + + + + True + GTK_PROGRESS_LEFT_TO_RIGHT + 0.300000011921 + 0.10000000149 + PANGO_ELLIPSIZE_NONE + + + 0 + False + False + + + + + + True + time elapsed / estimated : $elapsed / $estimated + False + False + GTK_JUSTIFY_LEFT + False + False + 0.5 + 0.5 + 0 + 0 + PANGO_ELLIPSIZE_NONE + -1 + False + 0 + + + 0 + False + False + + + + + + + + + 0 + True + True + + + + + + 4 + True + True + 4 + + + + True + True + Pause + True + GTK_RELIEF_NORMAL + True + + + 0 + True + False + + + + + + True + True + Cancel + True + GTK_RELIEF_NORMAL + True + + + 0 + True + False + + + + + 0 + False + True + + + + + + + diff --git a/pjlester-1.11.tar.Z.torrent b/pjlester-1.11.tar.Z.torrent new file mode 100644 --- /dev/null +++ b/pjlester-1.11.tar.Z.torrent @@ -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 diff --git a/src/BEncode/BEncode.hs b/src/BEncode/BEncode.hs new file mode 100644 --- /dev/null +++ b/src/BEncode/BEncode.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE CPP #-} +{- + Copyright (c) 2005 Jesper Louis Andersen + Lemmih + + 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 diff --git a/src/BEncode/BEncodePP.hs b/src/BEncode/BEncodePP.hs new file mode 100644 --- /dev/null +++ b/src/BEncode/BEncodePP.hs @@ -0,0 +1,56 @@ +{- + + Copyright (c) 2005 Jesper Louis Andersen + + 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 diff --git a/src/BEncode/BLexer.hs b/src/BEncode/BLexer.hs new file mode 100644 --- /dev/null +++ b/src/BEncode/BLexer.hs @@ -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 + diff --git a/src/BEncode/BParser.hs b/src/BEncode/BParser.hs new file mode 100644 --- /dev/null +++ b/src/BEncode/BParser.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE PatternGuards #-} +{- + Copyright (c) 2005 Lemmih + + 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 + diff --git a/src/Conjure.hs b/src/Conjure.hs new file mode 100644 --- /dev/null +++ b/src/Conjure.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE CPP #-} +{- + Copyright (c) 2005-2006 Lemmih + + 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 diff --git a/src/Conjure/Constants.hs b/src/Conjure/Constants.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Constants.hs @@ -0,0 +1,8 @@ +module Conjure.Constants where + +-- FIXME: this should be configurable. +blockSize :: Int +blockSize = 2^(14::Int) + + + diff --git a/src/Conjure/Debug.hs b/src/Conjure/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Debug.hs @@ -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) + diff --git a/src/Conjure/FileSystem/Interface.hs b/src/Conjure/FileSystem/Interface.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/FileSystem/Interface.hs @@ -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) ] + diff --git a/src/Conjure/FileSystem/InterfaceMMap.hsc b/src/Conjure/FileSystem/InterfaceMMap.hsc new file mode 100644 --- /dev/null +++ b/src/Conjure/FileSystem/InterfaceMMap.hsc @@ -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 +#ifndef _POSIX_MAPPED_FILES + +open :: Torrent -> IO Backend +open = error "Conjure.FileSystem.InterfaceMMap.open: mmap backend not available" + +#else + +#include + +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 diff --git a/src/Conjure/FileSystem/InterfaceNaive.hs b/src/Conjure/FileSystem/InterfaceNaive.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/FileSystem/InterfaceNaive.hs @@ -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 ] diff --git a/src/Conjure/Logic/BlockManagement.hs b/src/Conjure/Logic/BlockManagement.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Logic/BlockManagement.hs @@ -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 diff --git a/src/Conjure/Logic/PeerManager.hs b/src/Conjure/Logic/PeerManager.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Logic/PeerManager.hs @@ -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 () diff --git a/src/Conjure/Logic/QueueManager.hs b/src/Conjure/Logic/QueueManager.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Logic/QueueManager.hs @@ -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 + diff --git a/src/Conjure/Network/Client.hs b/src/Conjure/Network/Client.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Network/Client.hs @@ -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 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 () diff --git a/src/Conjure/Network/Peer.hs b/src/Conjure/Network/Peer.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Network/Peer.hs @@ -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 + diff --git a/src/Conjure/Network/Server.hs b/src/Conjure/Network/Server.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Network/Server.hs @@ -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 diff --git a/src/Conjure/OptionParser.hs b/src/Conjure/OptionParser.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/OptionParser.hs @@ -0,0 +1,67 @@ +{- + + Copyright (c) 2005 Jesper Louis Andersen + + 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 diff --git a/src/Conjure/Piecemap.hs b/src/Conjure/Piecemap.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Piecemap.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE CPP, TypeOperators, OverlappingInstances, RankNTypes #-} +{- + Copyright (c) 2005-2006 Lemmih + + 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 diff --git a/src/Conjure/Protocol/PWP.hs b/src/Conjure/Protocol/PWP.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Protocol/PWP.hs @@ -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 diff --git a/src/Conjure/Protocol/PWP/Parser.hs b/src/Conjure/Protocol/PWP/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Protocol/PWP/Parser.hs @@ -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 + diff --git a/src/Conjure/Protocol/PWP/Printer.hs b/src/Conjure/Protocol/PWP/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Protocol/PWP/Printer.hs @@ -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" + diff --git a/src/Conjure/Protocol/PWP/Types.hs b/src/Conjure/Protocol/PWP/Types.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Protocol/PWP/Types.hs @@ -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) + + diff --git a/src/Conjure/Protocol/THP.hs b/src/Conjure/Protocol/THP.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Protocol/THP.hs @@ -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 + diff --git a/src/Conjure/Protocol/THP/Parser.hs b/src/Conjure/Protocol/THP/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Protocol/THP/Parser.hs @@ -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 + +{- +-} diff --git a/src/Conjure/Protocol/THP/Types.hs b/src/Conjure/Protocol/THP/Types.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Protocol/THP/Types.hs @@ -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 diff --git a/src/Conjure/STM/PeerCtrl.hs b/src/Conjure/STM/PeerCtrl.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/STM/PeerCtrl.hs @@ -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 diff --git a/src/Conjure/Torrent.hs b/src/Conjure/Torrent.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Torrent.hs @@ -0,0 +1,175 @@ +{- + + Copyright (c) 2005 Jesper Louis Andersen + + 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 + + diff --git a/src/Conjure/Types.hs b/src/Conjure/Types.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Types.hs @@ -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) + diff --git a/src/Conjure/UI/Http.hs b/src/Conjure/UI/Http.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/UI/Http.hs @@ -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) ++ "%") diff --git a/src/Conjure/Utils.hs b/src/Conjure/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Utils.hs @@ -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 diff --git a/src/Conjure/Utils/Logger.hsc b/src/Conjure/Utils/Logger.hsc new file mode 100644 --- /dev/null +++ b/src/Conjure/Utils/Logger.hsc @@ -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 +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 + diff --git a/src/Conjure/Utils/SHA1.hs b/src/Conjure/Utils/SHA1.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Utils/SHA1.hs @@ -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 diff --git a/src/Conjure/Utils/Shuffle.hs b/src/Conjure/Utils/Shuffle.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Utils/Shuffle.hs @@ -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) + diff --git a/src/Conjure/Utils/Transaction.hs b/src/Conjure/Utils/Transaction.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Utils/Transaction.hs @@ -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 diff --git a/src/Conjure/Version.hs b/src/Conjure/Version.hs new file mode 100644 --- /dev/null +++ b/src/Conjure/Version.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE CPP #-} +{- + Copyright (c) 2005 Jesper Louis Andersen + + 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 +#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."]