module Data.Torrent
(
InfoDict (..)
, infoDictionary
, infohash
, layoutInfo
, pieceInfo
, isPrivate
, Torrent(..)
, announce
, announceList
, comment
, createdBy
, creationDate
, encoding
, infoDict
, publisher
, publisherURL
, signature
, nullTorrent
, typeTorrent
, torrentExt
, isTorrentPath
, 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 Text.PrettyPrint as PP
import Text.PrettyPrint.Class
import System.FilePath
import Data.Torrent.InfoHash as IH
import Data.Torrent.Layout
import Data.Torrent.Piece
data InfoDict = InfoDict
{ idInfoHash :: !InfoHash
, idLayoutInfo :: !LayoutInfo
, idPieceInfo :: !PieceInfo
, idPrivate :: !Bool
} 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
infoDictionary :: LayoutInfo -> PieceInfo -> Bool -> InfoDict
infoDictionary li pinfo private = InfoDict ih li pinfo private
where
ih = IH.hashlazy $ encode $ InfoDict fake_ih li pinfo private
fake_ih = InfoHash ""
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)
ppPrivacy :: Bool -> Doc
ppPrivacy privacy = "Privacy: " <> if privacy then "private" else "public"
instance Pretty InfoDict where
pretty InfoDict {..} =
pretty idLayoutInfo $$
pretty idPieceInfo $$
ppPrivacy idPrivate
data Torrent = Torrent
{ tAnnounce :: !URI
, tAnnounceList :: !(Maybe [[URI]])
, tComment :: !(Maybe Text)
, tCreatedBy :: !(Maybe Text)
, tCreationDate :: !(Maybe POSIXTime)
, tEncoding :: !(Maybe Text)
, tInfoDict :: !InfoDict
, tPublisher :: !(Maybe URI)
, tPublisherURL :: !(Maybe URI)
, tSignature :: !(Maybe ByteString)
} 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
instance BEncode URI where
toBEncode uri = toBEncode (BC.pack (uriToString id uri ""))
fromBEncode (BString s) | Just url <- parseURI (BC.unpack s) = return url
fromBEncode b = decodingError $ "url <" ++ show b ++ ">"
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"
(<:>) :: Doc -> Doc -> Doc
name <:> v = name <> ":" <+> v
(<:>?) :: Doc -> Maybe Doc -> Doc
_ <:>? Nothing = PP.empty
name <:>? (Just d) = name <:> d
instance Pretty Torrent where
pretty Torrent {..} =
"InfoHash: " <> pretty (idInfoHash tInfoDict)
$$ hang "General" 4 generalInfo
$$ hang "Tracker" 4 trackers
$$ pretty tInfoDict
where
trackers = case tAnnounceList of
Nothing -> text (show tAnnounce)
Just xxs -> vcat $ L.map ppTier $ L.zip [1..] xxs
where
ppTier (n, xs) = "Tier #" <> int n <:> vcat (L.map (text . show) xs)
generalInfo =
"Comment" <:>? ((text . T.unpack) <$> tComment) $$
"Created by" <:>? ((text . T.unpack) <$> tCreatedBy) $$
"Created on" <:>? ((text . show . posixSecondsToUTCTime)
<$> tCreationDate) $$
"Encoding" <:>? ((text . T.unpack) <$> tEncoding) $$
"Publisher" <:>? ((text . show) <$> tPublisher) $$
"Publisher URL" <:>? ((text . show) <$> tPublisherURL) $$
"Signature" <:>? ((text . show) <$> tSignature)
nullTorrent :: URI -> InfoDict -> Torrent
nullTorrent ann info = Torrent
ann Nothing Nothing Nothing Nothing Nothing
info Nothing Nothing Nothing
typeTorrent :: BS.ByteString
typeTorrent = "application/x-bittorrent"
torrentExt :: String
torrentExt = "torrent"
isTorrentPath :: FilePath -> Bool
isTorrentPath filepath = takeExtension filepath == extSeparator : torrentExt
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