diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Sam Truzjan + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Sam Truzjan nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT +OWNER 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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,36 @@ +### Synopsis + +A library for making Haskell applications which use bittorrent +protocol easy. This package aims to be a fast thin layer and at the +same time provide both: + +* Concise high level API for typical usage scenarious. +* More straightforward API if you need more fine grained control. + +Currently it provides serialization and deserealization of core +datatypes, some widely used routines and core types. + +### Status + +See list of implemented [BEPs](BEP.md). + +### Documentation + +For documentation see haddock generated documentation. + +### Build Status + +[![Build Status][1]][2] + +[1]: https://travis-ci.org/cobit/bittorrent.png +[2]: https://travis-ci.org/cobit/bittorrent + + +### Maintainer + +This library is written and maintained by Sam T. + +Feel free to report bugs and suggestions via +[github issue tracker][issues] or the mail. + +[issues]: https://github.com/cobit/bittorrent/issues/new diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bittorrent.cabal b/bittorrent.cabal new file mode 100644 --- /dev/null +++ b/bittorrent.cabal @@ -0,0 +1,174 @@ +name: bittorrent +version: 0.0.0.1 +license: BSD3 +license-file: LICENSE +author: Sam Truzjan +maintainer: Sam Truzjan +copyright: (c) 2013, Sam Truzjan +category: Network +build-type: Simple +cabal-version: >= 1.10 +tested-with: GHC == 7.4.1 + , GHC == 7.6.3 +homepage: https://github.com/cobit/bittorrent +bug-reports: https://github.com/cobit/bittorrent/issues +synopsis: Bittorrent protocol implementation. +description: + + A library for making Haskell bittorrent applications easy. + . + For more information see: + + +extra-source-files: res/dapper-dvd-amd64.iso.torrent + res/pkg.torrent + , README.md + , changelog + +source-repository head + type: git + location: git://github.com/cobit/bittorrent.git + +source-repository this + type: git + location: git://github.com/cobit/bittorrent.git + branch: master + tag: v0.0.0.1 + +library + default-language: Haskell2010 + default-extensions: PatternGuards + , OverloadedStrings + , RecordWildCards + hs-source-dirs: src + exposed-modules: Data.Torrent +-- , Data.Torrent.Bitfield + , Data.Torrent.Block + , Data.Torrent.InfoHash + , Data.Torrent.Layout + , Data.Torrent.Magnet + , Data.Torrent.Piece + , Data.Torrent.Tree + +-- , System.IO.MMap.Fixed +-- , System.Torrent.Storage + +-- Network.BitTorrent +-- , Network.BitTorrent.Extension +-- , Network.BitTorrent.Peer +-- , Network.BitTorrent.Tracker +-- , Network.BitTorrent.Tracker.Protocol +-- , Network.BitTorrent.Tracker.HTTP +-- , Network.BitTorrent.Tracker.UDP +-- , Network.BitTorrent.Exchange +-- , Network.BitTorrent.Exchange.Protocol +-- , Network.BitTorrent.DHT +-- , Network.BitTorrent.DHT.Protocol +-- , Network.BitTorrent.Sessions +-- other-modules: Network.BitTorrent.Sessions.Types + build-depends: base == 4.* + , bits-extras + , pretty + + -- Control + , deepseq + , lens + , mtl + , resourcet + , transformers + + -- Concurrency + , SafeSemaphore + , BoundedChan >= 1.0.1.0 + , stm >= 2.4 + + -- Streaming + , conduit >= 1.0 + , network-conduit >= 1.0 + , cereal-conduit >= 0.5 + , binary-conduit + + -- Data & Data structures + , bytestring >= 0.10.0.0 + , containers >= 0.4 + , data-default + , IntervalMap + , intset + , text >= 0.11.0 + , unordered-containers + , vector + + -- Hashing + , cryptohash + , hashable + + -- Codecs & Serialization + , aeson + , base16-bytestring + , base32-bytestring + , base64-bytestring + , bencoding >= 0.4 + , binary + , cereal >= 0.3 + , urlencoded >= 0.4 + + -- Time + , old-locale >= 1.0 + , time >= 0.1 + + -- Network + , network >= 2.4 + , HTTP >= 4000.2 + , krpc >= 0.3 + + -- System + , directory >= 1 + , entropy + , filepath >= 1 + , mmap + + ghc-options: -Wall + ghc-prof-options: + + +test-suite spec + default-language: Haskell2010 + default-extensions: OverloadedStrings + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Spec.hs + build-depends: base == 4.* + , bytestring + , directory + , filepath + + , aeson + , cereal + , network + , text + + , hspec + , QuickCheck + , quickcheck-instances + + , bencoding + , bittorrent + ghc-options: -Wall -fno-warn-orphans + + +--benchmark bench +-- default-language: Haskell2010 +-- default-extensions: +-- type: exitcode-stdio-1.0 +-- hs-source-dirs: bench +-- main-is: Main.hs +-- build-depends: base +-- , bytestring +-- , cereal +-- , network +-- +-- , criterion +-- , deepseq +-- +-- , bittorrent +-- ghc-options: -O2 -Wall -fno-warn-orphans diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,1 @@ +* 0.0.0.1: Initial version. diff --git a/res/dapper-dvd-amd64.iso.torrent b/res/dapper-dvd-amd64.iso.torrent new file mode 100644 Binary files /dev/null and b/res/dapper-dvd-amd64.iso.torrent differ diff --git a/res/pkg.torrent b/res/pkg.torrent new file mode 100644 Binary files /dev/null and b/res/pkg.torrent differ diff --git a/src/Data/Torrent.hs b/src/Data/Torrent.hs new file mode 100644 --- /dev/null +++ b/src/Data/Torrent.hs @@ -0,0 +1,289 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Torrent file contains metadata about files and folders but not +-- content itself. The files are bencoded dictionaries. There is +-- also other info which is used to help join the swarm. +-- +-- This module provides torrent metainfo serialization and info hash +-- extraction. +-- +-- For more info see: +-- , +-- +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS -fno-warn-orphans #-} +module Data.Torrent + ( -- * Info dictionary + InfoDict (..) + + -- ** Lenses + , infohash + , layoutInfo + , pieceInfo + , isPrivate + + -- * Torrent file + , Torrent(..) + + -- ** Lenses + , announce + , announceList + , comment + , createdBy + , creationDate + , encoding + , infoDict + , publisher + , publisherURL + , signature + + -- * Construction + , nullTorrent + + -- * File paths + , torrentExt + , isTorrentPath + + -- * IO + , fromFile + , toFile + ) where + +import Prelude hiding (sum) + +import Control.Applicative +import Control.DeepSeq +import Control.Exception +import Control.Lens + +import Data.Aeson.Types (ToJSON(..), FromJSON(..), Value(..), withText) +import Data.Aeson.TH +import Data.BEncode as BE +import Data.BEncode.Types as BE +import Data.ByteString as BS +import qualified Data.ByteString.Char8 as BC (pack, unpack) +import qualified Data.ByteString.Lazy as BL +import Data.Char as Char +import Data.Hashable as Hashable +import qualified Data.List as L +import Data.Text as T +import Data.Time +import Data.Time.Clock.POSIX +import Data.Typeable +import Network.URI +import System.FilePath + +import Data.Torrent.InfoHash as IH +import Data.Torrent.Layout +import Data.Torrent.Piece + + +{----------------------------------------------------------------------- +-- Info dictionary +-----------------------------------------------------------------------} + +{- note that info hash is actually reduntant field + but it's better to keep it here to avoid heavy recomputations +-} + +-- | Info part of the .torrent file contain info about each content file. +data InfoDict = InfoDict + { idInfoHash :: !InfoHash + -- ^ SHA1 hash of the (other) 'DictInfo' fields. + , idLayoutInfo :: !LayoutInfo + , idPieceInfo :: !PieceInfo + , idPrivate :: !Bool + -- ^ If set the client MUST publish its presence to get other + -- peers ONLY via the trackers explicity described in the + -- metainfo file. + -- + -- BEP 27: + } deriving (Show, Read, Eq, Typeable) + +$(deriveJSON (L.map Char.toLower . L.dropWhile isLower) ''InfoDict) + +makeLensesFor + [ ("idInfoHash" , "infohash" ) + , ("idLayoutInfo", "layoutInfo") + , ("idPieceInfo" , "pieceInfo" ) + , ("idPrivate" , "isPrivate" ) + ] + ''InfoDict + +instance NFData InfoDict where + rnf InfoDict {..} = rnf idLayoutInfo + +instance Hashable InfoDict where + hash = Hashable.hash . idInfoHash + {-# INLINE hash #-} + +getPrivate :: Get Bool +getPrivate = (Just True ==) <$>? "private" + +putPrivate :: Bool -> BDict -> BDict +putPrivate False = id +putPrivate True = \ cont -> "private" .=! True .: cont + +instance BEncode InfoDict where + toBEncode InfoDict {..} = toDict $ + putLayoutInfo idLayoutInfo $ + putPieceInfo idPieceInfo $ + putPrivate idPrivate $ + endDict + + fromBEncode dict = (`fromDict` dict) $ do + InfoDict ih <$> getLayoutInfo + <*> getPieceInfo + <*> getPrivate + where + ih = IH.hashlazy (encode dict) + +{----------------------------------------------------------------------- +-- Torrent info +-----------------------------------------------------------------------} + +-- | Metainfo about particular torrent. +data Torrent = Torrent + { tAnnounce :: !URI + -- ^ The URL of the tracker. + + , tAnnounceList :: !(Maybe [[URI]]) + -- ^ Announce list add multiple tracker support. + -- + -- BEP 12: + + , tComment :: !(Maybe Text) + -- ^ Free-form comments of the author. + + , tCreatedBy :: !(Maybe Text) + -- ^ Name and version of the program used to create the .torrent. + + , tCreationDate :: !(Maybe POSIXTime) + -- ^ Creation time of the torrent, in standard UNIX epoch. + + , tEncoding :: !(Maybe Text) + -- ^ String encoding format used to generate the pieces part of + -- the info dictionary in the .torrent metafile. + + , tInfoDict :: !InfoDict + -- ^ Info about each content file. + + , tPublisher :: !(Maybe URI) + -- ^ Containing the RSA public key of the publisher of the + -- torrent. Private counterpart of this key that has the + -- authority to allow new peers onto the swarm. + + , tPublisherURL :: !(Maybe URI) + , tSignature :: !(Maybe ByteString) + -- ^ The RSA signature of the info dictionary (specifically, the + -- encrypted SHA-1 hash of the info dictionary). + } deriving (Show, Eq, Typeable) + +instance FromJSON URI where + parseJSON = withText "URI" $ + maybe (fail "could not parse URI") pure . parseURI . T.unpack + +instance ToJSON URI where + toJSON = String . T.pack . show + +instance ToJSON NominalDiffTime where + toJSON = toJSON . posixSecondsToUTCTime + +instance FromJSON NominalDiffTime where + parseJSON v = utcTimeToPOSIXSeconds <$> parseJSON v + +$(deriveJSON (L.map Char.toLower . L.dropWhile isLower) ''Torrent) + +makeLensesFor + [ ("tAnnounce" , "announce" ) + , ("tAnnounceList", "announceList") + , ("tComment" , "comment" ) + , ("tCreatedBy" , "createdBy" ) + , ("tCreationDate", "creationDate") + , ("tEncoding" , "encoding" ) + , ("tInfoDict" , "infoDict" ) + , ("tPublisher" , "publisher" ) + , ("tPublisherURL", "publisherURL") + , ("tSignature" , "signature" ) + ] + ''Torrent + +instance NFData Torrent where + rnf Torrent {..} = rnf tInfoDict + +-- TODO move to bencoding +instance BEncode URI where + toBEncode uri = toBEncode (BC.pack (uriToString id uri "")) + {-# INLINE toBEncode #-} + + fromBEncode (BString s) | Just url <- parseURI (BC.unpack s) = return url + fromBEncode b = decodingError $ "url <" ++ show b ++ ">" + {-# INLINE fromBEncode #-} + +-- TODO move to bencoding +instance BEncode POSIXTime where + toBEncode pt = toBEncode (floor pt :: Integer) + fromBEncode (BInteger i) = return $ fromIntegral i + fromBEncode _ = decodingError $ "POSIXTime" + +instance BEncode Torrent where + toBEncode Torrent {..} = toDict $ + "announce" .=! tAnnounce + .: "announce-list" .=? tAnnounceList + .: "comment" .=? tComment + .: "created by" .=? tCreatedBy + .: "creation date" .=? tCreationDate + .: "encoding" .=? tEncoding + .: "info" .=! tInfoDict + .: "publisher" .=? tPublisher + .: "publisher-url" .=? tPublisherURL + .: "signature" .=? tSignature + .: endDict + + fromBEncode = fromDict $ do + Torrent <$>! "announce" + <*>? "announce-list" + <*>? "comment" + <*>? "created by" + <*>? "creation date" + <*>? "encoding" + <*>! "info" + <*>? "publisher" + <*>? "publisher-url" + <*>? "signature" + +-- | A simple torrent contains only required fields. +nullTorrent :: URI -> InfoDict -> Torrent +nullTorrent ann info = Torrent + ann Nothing Nothing Nothing Nothing Nothing + info Nothing Nothing Nothing + +-- | Extension usually used for torrent metafiles. +torrentExt :: String +torrentExt = "torrent" + +-- | Test if this path has proper extension. +isTorrentPath :: FilePath -> Bool +isTorrentPath filepath = takeExtension filepath == extSeparator : torrentExt + +-- | Read and decode a .torrent file. +fromFile :: FilePath -> IO Torrent +fromFile filepath = do + contents <- BS.readFile filepath + case decode contents of + Right !t -> return t + Left msg -> throwIO $ userError $ msg ++ " while reading torrent file" + +toFile :: FilePath -> Torrent -> IO () +toFile filepath = BL.writeFile filepath . encode diff --git a/src/Data/Torrent/Block.hs b/src/Data/Torrent/Block.hs new file mode 100644 --- /dev/null +++ b/src/Data/Torrent/Block.hs @@ -0,0 +1,198 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Blocks are used to transfer pieces. +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +module Data.Torrent.Block + ( -- * Piece attributes + PieceIx + , PieceSize + + -- * Block attributes + , BlockOffset + , BlockCount + , BlockSize + , defaultTransferSize + + -- * Block index + , BlockIx(..) + , ppBlockIx + , blockIxRange + + -- * Block data + , Block(..) + , ppBlock + , blockIx + , blockSize + , blockRange + ) where + +import Control.Applicative + +import Data.Aeson.TH +import qualified Data.ByteString.Lazy as Lazy +import Data.Char +import Data.List as L + +import Data.Binary as B +import Data.Binary.Get as B +import Data.Binary.Put as B +import Data.Serialize as S + +import Text.PrettyPrint + + +{----------------------------------------------------------------------- +-- Piece attributes +-----------------------------------------------------------------------} + +-- | Zero-based index of piece in torrent content. +type PieceIx = Int + +-- | Size of piece in bytes. Should be a power of 2. +-- +-- NOTE: Have max and min size constrained to wide used +-- semi-standard values. This bounds should be used to make decision +-- about piece size for new torrents. +-- +type PieceSize = Int + +{----------------------------------------------------------------------- +-- Block attributes +-----------------------------------------------------------------------} + +-- | Offset of a block in a piece in bytes. Should be multiple of +-- the choosen block size. +type BlockOffset = Int + +-- | Size of a block in bytes. Should be power of 2. +-- +-- Normally block size is equal to 'defaultTransferSize'. +-- +type BlockSize = Int + +-- | Number of block in a piece of a torrent. Used to distinguish +-- block count from piece count. +type BlockCount = Int + +-- | Widely used semi-official block size. Some clients can ignore if +-- block size of BlockIx in Request message is not equal to this +-- value. +-- +defaultTransferSize :: BlockSize +defaultTransferSize = 16 * 1024 + +{----------------------------------------------------------------------- + Block Index +-----------------------------------------------------------------------} + +-- | BlockIx correspond. +data BlockIx = BlockIx { + -- | Zero-based piece index. + ixPiece :: {-# UNPACK #-} !PieceIx + + -- | Zero-based byte offset within the piece. + , ixOffset :: {-# UNPACK #-} !BlockOffset + + -- | Block size starting from offset. + , ixLength :: {-# UNPACK #-} !BlockSize + } deriving (Show, Eq) + +$(deriveJSON (L.map toLower . L.dropWhile isLower) ''BlockIx) + +getInt :: S.Get Int +getInt = fromIntegral <$> S.getWord32be +{-# INLINE getInt #-} + +putInt :: S.Putter Int +putInt = S.putWord32be . fromIntegral +{-# INLINE putInt #-} + +getIntB :: B.Get Int +getIntB = fromIntegral <$> B.getWord32be +{-# INLINE getIntB #-} + +putIntB :: Int -> B.Put +putIntB = B.putWord32be . fromIntegral +{-# INLINE putIntB #-} + +instance Serialize BlockIx where + {-# SPECIALIZE instance Serialize BlockIx #-} + get = BlockIx <$> getInt + <*> getInt + <*> getInt + {-# INLINE get #-} + + put BlockIx {..} = do + putInt ixPiece + putInt ixOffset + putInt ixLength + {-# INLINE put #-} + +instance Binary BlockIx where + {-# SPECIALIZE instance Binary BlockIx #-} + get = BlockIx <$> getIntB + <*> getIntB + <*> getIntB + {-# INLINE get #-} + + put BlockIx {..} = do + putIntB ixPiece + putIntB ixOffset + putIntB ixLength + +-- | Format block index in human readable form. +ppBlockIx :: BlockIx -> Doc +ppBlockIx BlockIx {..} = + "piece = " <> int ixPiece <> "," <+> + "offset = " <> int ixOffset <> "," <+> + "length = " <> int ixLength + +-- | Get location of payload bytes in the torrent content. +blockIxRange :: (Num a, Integral a) => PieceSize -> BlockIx -> (a, a) +blockIxRange pieceSize BlockIx {..} = (offset, offset + len) + where + offset = fromIntegral pieceSize * fromIntegral ixPiece + + fromIntegral ixOffset + len = fromIntegral ixLength +{-# INLINE blockIxRange #-} + +{----------------------------------------------------------------------- + Block +-----------------------------------------------------------------------} + +data Block payload = Block { + -- | Zero-based piece index. + blkPiece :: {-# UNPACK #-} !PieceIx + + -- | Zero-based byte offset within the piece. + , blkOffset :: {-# UNPACK #-} !BlockOffset + + -- | Payload bytes. + , blkData :: !payload + } deriving (Show, Eq) + +-- | Format block in human readable form. Payload is ommitted. +ppBlock :: Block Lazy.ByteString -> Doc +ppBlock = ppBlockIx . blockIx +{-# INLINE ppBlock #-} + +-- | Get size of block /payload/ in bytes. +blockSize :: Block Lazy.ByteString -> BlockSize +blockSize blk = fromIntegral (Lazy.length (blkData blk)) +{-# INLINE blockSize #-} + +-- | Get block index of a block. +blockIx :: Block Lazy.ByteString -> BlockIx +blockIx = BlockIx <$> blkPiece <*> blkOffset <*> blockSize + +-- | Get location of payload bytes in the torrent content. +blockRange :: (Num a, Integral a) => PieceSize -> Block Lazy.ByteString -> (a, a) +blockRange pieceSize = blockIxRange pieceSize . blockIx +{-# INLINE blockRange #-} diff --git a/src/Data/Torrent/InfoHash.hs b/src/Data/Torrent/InfoHash.hs new file mode 100644 --- /dev/null +++ b/src/Data/Torrent/InfoHash.hs @@ -0,0 +1,149 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Infohash is a unique identifier of torrent. +-- +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Data.Torrent.InfoHash + ( -- * Info hash + InfoHash(..) + , textToInfoHash + , addHashToURI + , ppInfoHash + + , Data.Torrent.InfoHash.hash + , Data.Torrent.InfoHash.hashlazy + ) where + +import Control.Applicative +import Control.Monad +import qualified Crypto.Hash.SHA1 as C +import Data.Aeson +import Data.BEncode +import Data.ByteString as BS +import Data.ByteString.Char8 as BC +import Data.ByteString.Lazy as BL +import Data.ByteString.Base16 as Base16 +import Data.ByteString.Base32 as Base32 +import qualified Data.ByteString.Lazy.Builder as B +import qualified Data.ByteString.Lazy.Builder.ASCII as B +import Data.Char +import Data.List as L +import Data.Hashable as Hashable +import Data.URLEncoded as URL +import Data.Serialize +import Data.String +import Data.Text +import Data.Text.Encoding as T +import Network.URI +import Numeric +import Text.ParserCombinators.ReadP as P +import Text.PrettyPrint + + +-- | Exactly 20 bytes long SHA1 hash of the info part of torrent file. +newtype InfoHash = InfoHash { getInfoHash :: BS.ByteString } + deriving (Eq, Ord) + +-- | for hex encoded strings +instance Show InfoHash where + show = render . ppInfoHash + +-- | for hex encoded strings +instance Read InfoHash where + readsPrec _ = readP_to_S $ do + str <- replicateM 40 (satisfy isHexDigit) + return $ InfoHash $ decodeIH str + where + decodeIH = BS.pack . L.map fromHex . pair + fromHex (a, b) = read $ '0' : 'x' : a : b : [] + + pair (a : b : xs) = (a, b) : pair xs + pair _ = [] + +-- | for base16 (hex) encoded strings +instance IsString InfoHash where + fromString str + | L.length str == 40 + , (ihStr, inv) <- Base16.decode $ BC.pack str + = if BS.length inv == 0 then InfoHash ihStr + else error "fromString: invalid infohash string" + | otherwise = error "fromString: invalid infohash string length" + +instance Hashable InfoHash where + hash = Hashable.hash . getInfoHash + +instance BEncode InfoHash where + toBEncode = toBEncode . getInfoHash + fromBEncode be = InfoHash <$> fromBEncode be + +instance Serialize InfoHash where + put = putByteString . getInfoHash + get = InfoHash <$> getBytes 20 + +-- | Represented as base16 encoded string. +instance ToJSON InfoHash where + toJSON (InfoHash ih) = String $ T.decodeUtf8 $ Base16.encode ih + +-- | Can be base16 or base32 encoded string. +instance FromJSON InfoHash where + parseJSON = withText "JSON" $ + maybe (fail "could not parse InfoHash") pure . textToInfoHash + +instance URLShow InfoHash where + urlShow = show + +-- | Tries both base16 and base32 while decoding info hash. +textToInfoHash :: Text -> Maybe InfoHash +textToInfoHash text + | hashLen == 32 = Just $ InfoHash $ Base32.decode hashStr + | hashLen == 40 = let (ihStr, inv) = Base16.decode hashStr + in if BS.length inv == 0 + then Just $ InfoHash ihStr + else Nothing + | otherwise = Nothing + where + hashLen = BS.length hashStr + hashStr = T.encodeUtf8 text + +-- | Hash strict bytestring using SHA1 algorithm. +hash :: BS.ByteString -> InfoHash +hash = InfoHash . C.hash + +-- | Hash lazy bytestring using SHA1 algorithm. +hashlazy :: BL.ByteString -> InfoHash +hashlazy = InfoHash . C.hashlazy + +-- | Pretty print info hash in hexadecimal format. +ppInfoHash :: InfoHash -> Doc +ppInfoHash = text . BC.unpack . ppHex . getInfoHash + +ppHex :: BS.ByteString -> BS.ByteString +ppHex = BL.toStrict . B.toLazyByteString . B.byteStringHexFixed + +-- | Add query info hash parameter to uri. +-- +-- > info_hash= +-- +addHashToURI :: URI -> InfoHash -> URI +addHashToURI uri s = uri { + uriQuery = uriQuery uri ++ mkPref (uriQuery uri) ++ + "info_hash=" ++ rfc1738Encode (BC.unpack (getInfoHash s)) + } + where + mkPref [] = "?" + mkPref ('?' : _) = "&" + mkPref _ = error "addHashToURI" + + rfc1738Encode = L.concatMap (\c -> if unreservedS c then [c] else encodeHex c) + where + unreservedS = (`L.elem` chars) + chars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_./" + encodeHex c = '%' : pHex c + pHex c = let p = (showHex . ord $ c) "" + in if L.length p == 1 then '0' : p else p diff --git a/src/Data/Torrent/Layout.hs b/src/Data/Torrent/Layout.hs new file mode 100644 --- /dev/null +++ b/src/Data/Torrent/Layout.hs @@ -0,0 +1,292 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Layout of files in torrent. +-- +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS -fno-warn-orphans #-} +module Data.Torrent.Layout + ( -- * File attributes + FileOffset + , FileSize + + -- * Single file info + , FileInfo (..) + + -- ** Lens + , fileLength + , filePath + , fileMD5Sum + + -- * File layout + , LayoutInfo (..) + + -- ** Lens + , singleFile + , multiFile + , rootDirName + + -- ** Predicates + , isSingleFile + , isMultiFile + + -- ** Folds + , contentLength + , fileCount + , blockCount + + -- * Flat file layout + , Layout + , flatLayout + , accumOffsets + , fileOffset + + -- * Internal + , getLayoutInfo + , putLayoutInfo + ) where + +import Control.Applicative +import Control.DeepSeq +import Control.Lens +import Data.Aeson.TH +import Data.Aeson.Types (FromJSON, ToJSON) +import Data.BEncode +import Data.BEncode.Types +import Data.ByteString as BS +import Data.ByteString.Char8 as BC +import Data.Char +import Data.List as L +import Data.Typeable +import System.FilePath +import System.Posix.Types + +import Data.Torrent.Block + + +{----------------------------------------------------------------------- +-- File attribytes +-----------------------------------------------------------------------} + +-- | Size of a file in bytes. +type FileSize = FileOffset + +deriving instance FromJSON FileOffset +deriving instance ToJSON FileOffset +deriving instance BEncode FileOffset + +{----------------------------------------------------------------------- +-- File info both either from info dict or file list +-----------------------------------------------------------------------} + +-- | Contain metainfo about one single file. +data FileInfo a = FileInfo { + fiLength :: {-# UNPACK #-} !FileSize + -- ^ Length of the file in bytes. + + -- TODO unpacked MD5 sum + , fiMD5Sum :: !(Maybe ByteString) + -- ^ 32 character long MD5 sum of the file. Used by third-party + -- tools, not by bittorrent protocol itself. + + , fiName :: !a + -- ^ One or more string elements that together represent the + -- path and filename. Each element in the list corresponds to + -- either a directory name or (in the case of the last element) + -- the filename. For example, the file: + -- + -- > "dir1/dir2/file.ext" + -- + -- would consist of three string elements: + -- + -- > ["dir1", "dir2", "file.ext"] + -- + } deriving (Show, Read, Eq, Typeable) + +$(deriveJSON (L.map toLower . L.dropWhile isLower) ''FileInfo) + +makeLensesFor + [ ("fiLength", "fileLength") + , ("fiMD5Sum", "fileMD5Sum") + , ("fiName" , "filePath" ) + ] + ''FileInfo + +instance NFData a => NFData (FileInfo a) where + rnf FileInfo {..} = rnf fiName + {-# INLINE rnf #-} + +instance BEncode (FileInfo [ByteString]) where + toBEncode FileInfo {..} = toDict $ + "length" .=! fiLength + .: "md5sum" .=? fiMD5Sum + .: "path" .=! fiName + .: endDict + {-# INLINE toBEncode #-} + + fromBEncode = fromDict $ do + FileInfo <$>! "length" + <*>? "md5sum" + <*>! "path" + {-# INLINE fromBEncode #-} + +type Put a = a -> BDict -> BDict + +putFileInfoSingle :: Put (FileInfo ByteString) +putFileInfoSingle FileInfo {..} cont = + "length" .=! fiLength + .: "md5sum" .=? fiMD5Sum + .: "name" .=! fiName + .: cont + +getFileInfoSingle :: Get (FileInfo ByteString) +getFileInfoSingle = do + FileInfo <$>! "length" + <*>? "md5sum" + <*>! "name" + +instance BEncode (FileInfo ByteString) where + toBEncode = toDict . (`putFileInfoSingle` endDict) + {-# INLINE toBEncode #-} + + fromBEncode = fromDict getFileInfoSingle + {-# INLINE fromBEncode #-} + +{----------------------------------------------------------------------- +-- Original torrent file layout info +-----------------------------------------------------------------------} + +-- | Original (found in torrent file) layout info is either: +-- +-- * Single file with its /name/. +-- +-- * Multiple files with its relative file /paths/. +-- +data LayoutInfo + = SingleFile + { -- | Single file info. + liFile :: !(FileInfo ByteString) + } + | MultiFile + { -- | List of the all files that torrent contains. + liFiles :: ![FileInfo [ByteString]] + + -- | The /suggested/ name of the root directory in which to + -- store all the files. + , liDirName :: !ByteString + } deriving (Show, Read, Eq, Typeable) + +$(deriveJSON (L.map toLower . L.dropWhile isLower) ''LayoutInfo) + +makeLensesFor + [ ("liFile" , "singleFile" ) + , ("liFiles" , "multiFile" ) + , ("liDirName", "rootDirName") + ] + ''LayoutInfo + +instance NFData LayoutInfo where + rnf SingleFile {..} = () + rnf MultiFile {..} = rnf liFiles + +getLayoutInfo :: Get LayoutInfo +getLayoutInfo = single <|> multi + where + single = SingleFile <$> getFileInfoSingle + multi = MultiFile <$>! "files" <*>! "name" + +putLayoutInfo :: Put LayoutInfo +putLayoutInfo SingleFile {..} = putFileInfoSingle liFile +putLayoutInfo MultiFile {..} = \ cont -> + "files" .=! liFiles + .: "name" .=! liDirName + .: cont + +instance BEncode LayoutInfo where + toBEncode = toDict . (`putLayoutInfo` endDict) + fromBEncode = fromDict getLayoutInfo + +-- | Test if this is single file torrent. +isSingleFile :: LayoutInfo -> Bool +isSingleFile SingleFile {} = True +isSingleFile _ = False +{-# INLINE isSingleFile #-} + +-- | Test if this is multifile torrent. +isMultiFile :: LayoutInfo -> Bool +isMultiFile MultiFile {} = True +isMultiFile _ = False +{-# INLINE isMultiFile #-} + +-- | Find sum of sizes of the all torrent files. +contentLength :: LayoutInfo -> FileSize +contentLength SingleFile { liFile = FileInfo {..} } = fiLength +contentLength MultiFile { liFiles = tfs } = sum (L.map fiLength tfs) + +-- | Get number of all files in torrent. +fileCount :: LayoutInfo -> Int +fileCount SingleFile {..} = 1 +fileCount MultiFile {..} = L.length liFiles + +-- | Find number of blocks of the specified size. If torrent size is +-- not a multiple of block size then the count is rounded up. +blockCount :: BlockSize -> LayoutInfo -> Int +blockCount blkSize ci = contentLength ci `sizeInBase` blkSize + +{----------------------------------------------------------------------- +-- Flat layout +-----------------------------------------------------------------------} + +-- | File layout specifies the order and the size of each file in the +-- storage. Note that order of files is highly important since we +-- coalesce all the files in the given order to get the linear block +-- address space. +-- +type Layout a = [(FilePath, a)] + +-- | Extract files layout from torrent info with the given root path. +flatLayout + :: FilePath -- ^ Root path for the all torrent files. + -> LayoutInfo -- ^ Torrent content information. + -> Layout FileSize -- ^ The all file paths prefixed with the given root. +flatLayout prefixPath SingleFile { liFile = FileInfo {..} } + = [(prefixPath BC.unpack fiName, fiLength)] +flatLayout prefixPath MultiFile {..} = L.map mkPath liFiles + where -- TODO use utf8 encoding in name + mkPath FileInfo {..} = (path, fiLength) + where + path = prefixPath BC.unpack liDirName + joinPath (L.map BC.unpack fiName) + +-- | Calculate offset of each file based on its length, incrementally. +accumOffsets :: Layout FileSize -> Layout FileOffset +accumOffsets = go 0 + where + go !_ [] = [] + go !offset ((n, s) : xs) = (n, offset) : go (offset + s) xs + +-- | Gives global offset of a content file for a given full path. +fileOffset :: FilePath -> Layout FileOffset -> Maybe FileOffset +fileOffset = lookup +{-# INLINE fileOffset #-} + +{----------------------------------------------------------------------- +-- Internal utilities +-----------------------------------------------------------------------} + +-- | Divide and round up. +sizeInBase :: Integral a => a -> Int -> Int +sizeInBase n b = fromIntegral (n `div` fromIntegral b) + align + where + align = if n `mod` fromIntegral b == 0 then 0 else 1 +{-# SPECIALIZE sizeInBase :: Int -> Int -> Int #-} +{-# SPECIALIZE sizeInBase :: Integer -> Int -> Int #-} diff --git a/src/Data/Torrent/Magnet.hs b/src/Data/Torrent/Magnet.hs new file mode 100644 --- /dev/null +++ b/src/Data/Torrent/Magnet.hs @@ -0,0 +1,223 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Parsing and rendering of magnet URIs. +-- +-- For more info see: +-- +-- +-- Bittorrent specific info: +-- +-- +module Data.Torrent.Magnet + ( -- * Magnet + Magnet(..) + , nullMagnet + , parseMagnet + , renderMagnet + + -- ** Extra + , fromURI + , toURI + ) where + +import Control.Applicative +import Control.Monad +import Data.Map as M +import Data.Maybe +import Data.List as L +import Data.URLEncoded as URL +import Data.String +import Data.Text as T +import Network.URI +import Text.Read + +import Data.Torrent.InfoHash + + +{----------------------------------------------------------------------- +-- URN +-----------------------------------------------------------------------} + +type NamespaceId = [Text] + +btih :: NamespaceId +btih = ["btih"] + +-- | Uniform Resource Name - location-independent, resource +-- identifier. +data URN = URN + { urnNamespace :: NamespaceId + , urnString :: Text + } deriving (Eq, Ord) + +instance Show URN where + showsPrec n = showsPrec n . T.unpack . renderURN + +instance IsString URN where + fromString = fromMaybe def . parseURN . T.pack + where + def = error "unable to parse URN" + +instance URLShow URN where + urlShow = T.unpack . renderURN + +parseURN :: Text -> Maybe URN +parseURN str = case T.split (== ':') str of + uriScheme : body + | T.toLower uriScheme == "urn" -> mkURN body + | otherwise -> Nothing + [] -> Nothing + where + mkURN [] = Nothing + mkURN xs = Just $ URN + { urnNamespace = L.init xs + , urnString = L.last xs + } + +renderURN :: URN -> Text +renderURN URN {..} + = T.intercalate ":" $ "urn" : urnNamespace ++ [urnString] + +urnToInfoHash :: URN -> Maybe InfoHash +urnToInfoHash (URN {..}) + | urnNamespace /= btih = Nothing + | otherwise = textToInfoHash urnString + +infoHashToURN :: InfoHash -> URN +infoHashToURN = URN btih . T.pack . show + +{----------------------------------------------------------------------- +-- Magnet +-----------------------------------------------------------------------} + +-- TODO multiple exact topics +-- TODO supplement + +-- | An URI used to identify torrent. +data Magnet = Magnet + { -- | Resource hash. + exactTopic :: !InfoHash + -- | Might be used to display name while waiting for metadata. + , displayName :: Maybe Text + -- | Size of the resource in bytes. + , exactLength :: Maybe Integer + + , manifest :: Maybe String + -- | Search string. + , keywordTopic :: Maybe String + + , acceptableSource :: Maybe URI + , exactSource :: Maybe URI + + , tracker :: Maybe URI + + , supplement :: Map Text Text + } deriving (Eq, Ord) + +instance Show Magnet where + show = renderMagnet + {-# INLINE show #-} + +instance Read Magnet where + readsPrec _ xs + | Just m <- parseMagnet mstr = [(m, rest)] + | otherwise = [] + where + (mstr, rest) = L.break (== ' ') xs + +instance IsString Magnet where + fromString = fromMaybe def . parseMagnet + where + def = error "unable to parse magnet" + +instance URLEncode Magnet where + urlEncode = toQuery + {-# INLINE urlEncode #-} + +-- | Set exact topic only, other params are empty. +nullMagnet :: InfoHash -> Magnet +nullMagnet u = Magnet + { exactTopic = u + , displayName = Nothing + , exactLength = Nothing + , manifest = Nothing + , keywordTopic = Nothing + , acceptableSource = Nothing + , exactSource = Nothing + , tracker = Nothing + , supplement = M.empty + } + +fromQuery :: URLEncoded -> Either String Magnet +fromQuery q + | Just urnStr <- URL.lookup ("xt" :: String) q + , Just urn <- parseURN $ T.pack urnStr + , Just infoHash <- urnToInfoHash urn + = return $ Magnet + { exactTopic = infoHash + , displayName = T.pack <$> URL.lookup ("dn" :: String) q + , exactLength = readMaybe =<< URL.lookup ("xl" :: String) q + + , manifest = URL.lookup ("mt" :: String) q + , keywordTopic = URL.lookup ("kt" :: String) q + + , acceptableSource = parseURI =<< URL.lookup ("as" :: String) q + , exactSource = parseURI =<< URL.lookup ("xs" :: String) q + + , tracker = parseURI =<< URL.lookup ("tr" :: String) q + , supplement = M.empty + } + + | otherwise = Left "exact topic not defined" + +toQuery :: Magnet -> URLEncoded +toQuery Magnet {..} + = s "xt" %= infoHashToURN exactTopic + %& s "dn" %=? (T.unpack <$> displayName) + %& s "xl" %=? exactLength + %& s "mt" %=? manifest + %& s "kt" %=? keywordTopic + %& s "as" %=? acceptableSource + %& s "xs" %=? exactSource + %& s "tr" %=? tracker + where + s :: String -> String; s = id + +magnetScheme :: URI +magnetScheme = URI + { uriScheme = "magnet:" + , uriAuthority = Nothing + , uriPath = "" + , uriQuery = "" + , uriFragment = "" + } + +isMagnetURI :: URI -> Bool +isMagnetURI u = u { uriQuery = "" } == magnetScheme + +-- | The same as 'parseMagnet' but useful if you alread have a parsed +-- uri. +fromURI :: URI -> Either String Magnet +fromURI u @ URI {..} + | not (isMagnetURI u) = Left "this is not a magnet link" + | otherwise = importURI u >>= fromQuery + +-- | The same as 'renderMagnet' but useful if you need an uri. +toURI :: Magnet -> URI +toURI m = magnetScheme %? urlEncode m + +etom :: Either a b -> Maybe b +etom = either (const Nothing) Just + +-- | Try to parse magnet link from urlencoded string. +parseMagnet :: String -> Maybe Magnet +parseMagnet = parseURI >=> etom . fromURI + +-- | Render magnet link to urlencoded string +renderMagnet :: Magnet -> String +renderMagnet = show . toURI diff --git a/src/Data/Torrent/Piece.hs b/src/Data/Torrent/Piece.hs new file mode 100644 --- /dev/null +++ b/src/Data/Torrent/Piece.hs @@ -0,0 +1,226 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Pieces are used to validate torrent content. +-- +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Data.Torrent.Piece + ( -- * Piece attributes + PieceIx + , PieceCount + , PieceSize + , minPieceSize + , maxPieceSize + , defaultPieceSize + + -- * Piece data + , Piece (..) + , ppPiece + , pieceSize + , isPiece + + -- * Piece control + , PieceInfo (..) + , ppPieceInfo + , pieceCount + + -- * Lens + , pieceLength + , pieceHashes + + -- * Validation + , pieceHash + , checkPieceLazy + + -- * Internal + , getPieceInfo + , putPieceInfo + ) where + +import Control.DeepSeq +import Control.Lens +import qualified Crypto.Hash.SHA1 as SHA1 +import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), withText) +import Data.Aeson.TH +import Data.BEncode +import Data.BEncode.Types +import Data.Bits +import Data.Bits.Extras +import Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Base64 as Base64 +import Data.Char +import Data.Int +import Data.List as L +import Data.Text.Encoding as T +import Data.Typeable +import Text.PrettyPrint + +import Data.Torrent.Block + + +class Lint a where + lint :: a -> Either String a + +--class Validation a where +-- validate :: PieceInfo -> Piece a -> Bool + +{----------------------------------------------------------------------- +-- Piece attributes +-----------------------------------------------------------------------} + +-- | Number of pieces in torrent or a part of torrent. +type PieceCount = Int + +-- | Optimal number of pieces in torrent. +optimalPieceCount :: PieceCount +optimalPieceCount = 1000 +{-# INLINE optimalPieceCount #-} + +-- | Piece size should not be less than this value. +minPieceSize :: Int +minPieceSize = defaultTransferSize * 4 +{-# INLINE minPieceSize #-} + +-- | To prevent transfer degradation piece size should not exceed this +-- value. +maxPieceSize :: Int +maxPieceSize = 4 * 1024 * 1024 +{-# INLINE maxPieceSize #-} + +toPow2 :: Int -> Int +toPow2 x = bit $ fromIntegral (leadingZeros (0 :: Int) - leadingZeros x) + +-- | Find the optimal piece size for a given torrent size. +defaultPieceSize :: Int64 -> Int +defaultPieceSize x = max minPieceSize $ min maxPieceSize $ toPow2 pc + where + pc = fromIntegral (x `div` fromIntegral optimalPieceCount) + +{----------------------------------------------------------------------- +-- Piece data +-----------------------------------------------------------------------} + +-- TODO check if pieceLength is power of 2 +-- | Piece payload should be strict or lazy bytestring. +data Piece a = Piece + { -- | Zero-based piece index in torrent. + pieceIndex :: {-# UNPACK #-} !PieceIx + + -- | Payload. + , pieceData :: !a + } deriving (Show, Read, Eq, Typeable) + +$(deriveJSON (L.map toLower . L.dropWhile isLower) ''Piece) + +instance NFData (Piece a) + +-- | Format piece in human readable form. Payload bytes are omitted. +ppPiece :: Piece a -> Doc +ppPiece Piece {..} + = "Piece" <+> braces ("index" <+> "=" <+> int pieceIndex) + +-- | Get size of piece in bytes. +pieceSize :: Piece BL.ByteString -> PieceSize +pieceSize Piece {..} = fromIntegral (BL.length pieceData) + +-- | Test if a block can be safely turned into a piece. +isPiece :: PieceSize -> Block BL.ByteString -> Bool +isPiece pieceLen blk @ (Block i offset _) = + offset == 0 && blockSize blk == pieceLen && i >= 0 +{-# INLINE isPiece #-} + +{----------------------------------------------------------------------- +-- Piece control +-----------------------------------------------------------------------} + +newtype HashArray = HashArray { unHashArray :: ByteString } + deriving (Show, Read, Eq, BEncode) + +-- | Represented as base64 encoded JSON string. +instance ToJSON HashArray where + toJSON (HashArray bs) = String $ T.decodeUtf8 $ Base64.encode bs + +instance FromJSON HashArray where + parseJSON = withText "HashArray" $ + either fail (return . HashArray) . Base64.decode . T.encodeUtf8 + +-- | Part of torrent file used for torrent content validation. +data PieceInfo = PieceInfo + { piPieceLength :: {-# UNPACK #-} !PieceSize + -- ^ Number of bytes in each piece. + + , piPieceHashes :: !HashArray + -- ^ Concatenation of all 20-byte SHA1 hash values. + } deriving (Show, Read, Eq, Typeable) + +$(deriveJSON (L.map toLower . L.dropWhile isLower) ''PieceInfo) + +-- | Number of bytes in each piece. +makeLensesFor [("piPieceLength", "pieceLength")] ''PieceInfo + +-- | Concatenation of all 20-byte SHA1 hash values. +makeLensesFor [("piPieceHashes", "pieceHashes")] ''PieceInfo + +instance NFData PieceInfo + +instance Lint PieceInfo where + lint pinfo @ PieceInfo {..} + | BS.length (unHashArray piPieceHashes) `rem` hashsize == 0 + , piPieceLength >= 0 = return pinfo + | otherwise = Left undefined + + +putPieceInfo :: PieceInfo -> BDict -> BDict +putPieceInfo PieceInfo {..} cont = + "piece length" .=! piPieceLength + .: "pieces" .=! piPieceHashes + .: cont + +getPieceInfo :: Get PieceInfo +getPieceInfo = do + PieceInfo <$>! "piece length" + <*>! "pieces" + +instance BEncode PieceInfo where + toBEncode = toDict . (`putPieceInfo` endDict) + fromBEncode = fromDict getPieceInfo + +-- | Format piece info in human readable form. Hashes are omitted. +ppPieceInfo :: PieceInfo -> Doc +ppPieceInfo PieceInfo { piPieceLength = len } = + "PieceInfo" <+> braces ("length" <+> "=" <+> int len) + +hashsize :: Int +hashsize = 20 +{-# INLINE hashsize #-} + +slice :: Int -> Int -> ByteString -> ByteString +slice start len = BS.take len . BS.drop start +{-# INLINE slice #-} + +-- | Extract validation hash by specified piece index. +pieceHash :: PieceInfo -> PieceIx -> ByteString +pieceHash PieceInfo {..} i = slice (hashsize * i) hashsize (unHashArray piPieceHashes) + +-- | Find count of pieces in the torrent. If torrent size is not a +-- multiple of piece size then the count is rounded up. +pieceCount :: PieceInfo -> PieceCount +pieceCount PieceInfo {..} = BS.length (unHashArray piPieceHashes) `quot` hashsize + +-- | Test if this is last piece in torrent content. +isLastPiece :: PieceInfo -> PieceIx -> Bool +isLastPiece ci i = pieceCount ci == succ i + +-- | Validate piece with metainfo hash. +checkPieceLazy :: PieceInfo -> Piece BL.ByteString -> Bool +checkPieceLazy pinfo @ PieceInfo {..} Piece {..} + = (fromIntegral (BL.length pieceData) == piPieceLength + || isLastPiece pinfo pieceIndex) + && SHA1.hashlazy pieceData == pieceHash pinfo pieceIndex diff --git a/src/Data/Torrent/Tree.hs b/src/Data/Torrent/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Data/Torrent/Tree.hs @@ -0,0 +1,81 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Directory tree can be used to easily manipulate file layout info. +-- +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Data.Torrent.Tree + ( -- * Directory tree + DirTree (..) + + -- * Construction + , build + + -- * Query + , Data.Torrent.Tree.lookup + , lookupDir + , fileNumber + , dirNumber + ) where + +import Data.ByteString as BS +import Data.ByteString.Char8 as BC +import Data.Foldable +import Data.List as L +import Data.Map as M +import Data.Monoid + +import Data.Torrent.Layout + + +-- | 'DirTree' is more convenient form of 'LayoutInfo'. +data DirTree a = Dir { children :: Map ByteString (DirTree a) } + | File { node :: FileInfo a } + deriving Show + +-- | Build directory tree from a list of files. +build :: LayoutInfo -> DirTree () +build SingleFile {liFile = FileInfo {..}} = Dir + { children = M.singleton fiName (File fi) } + where + fi = FileInfo fiLength fiMD5Sum () +build MultiFile {..} = Dir $ M.singleton liDirName files + where + files = Dir $ M.fromList $ L.map mkFileEntry liFiles + mkFileEntry FileInfo {..} = (L.head fiName, ent) -- TODO FIXME + where + ent = File $ FileInfo fiLength fiMD5Sum () + +--decompress :: DirTree () -> [FileInfo ()] +--decompress = undefined + +-- | Lookup file by path. +lookup :: [FilePath] -> DirTree a -> Maybe (DirTree a) +lookup [] t = Just t +lookup (p : ps) (Dir m) | Just subTree <- M.lookup (BC.pack p) m + = Data.Torrent.Tree.lookup ps subTree +lookup _ _ = Nothing + +-- | Lookup directory by path. +lookupDir :: [FilePath] -> DirTree a -> Maybe [(ByteString, DirTree a)] +lookupDir ps d = do + subTree <- Data.Torrent.Tree.lookup ps d + case subTree of + File _ -> Nothing + Dir es -> Just $ M.toList es + +-- | Get total count of files in directory and subdirectories. +fileNumber :: DirTree a -> Sum Int +fileNumber File {..} = Sum 1 +fileNumber Dir {..} = foldMap fileNumber children + +-- | Get total count of directories in the directory and subdirectories. +dirNumber :: DirTree a -> Sum Int +dirNumber File {..} = Sum 0 +dirNumber Dir {..} = Sum 1 <> foldMap dirNumber children diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}