module Data.Torrent.Magnet
(
Magnet(..)
, nullMagnet
, simpleMagnet
, detailedMagnet
, parseMagnet
, renderMagnet
, 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 Data.Text.Encoding as T
import Network.URI
import Text.Read
import Text.PrettyPrint as PP
import Text.PrettyPrint.Class
import Data.Torrent
import Data.Torrent.InfoHash
import Data.Torrent.Layout
type NamespaceId = [Text]
btih :: NamespaceId
btih = ["btih"]
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
data Magnet = Magnet
{
exactTopic :: !InfoHash
, displayName :: Maybe Text
, exactLength :: Maybe Integer
, manifest :: Maybe 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
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
instance Pretty Magnet where
pretty = PP.text . renderMagnet
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
}
simpleMagnet :: Torrent -> Magnet
simpleMagnet Torrent {tInfoDict = InfoDict {..}}
= (nullMagnet idInfoHash)
{ displayName = Just $ T.decodeUtf8 $ suggestedName idLayoutInfo
}
detailedMagnet :: Torrent -> Magnet
detailedMagnet t @ Torrent {tInfoDict = InfoDict {..}, tAnnounce}
= (simpleMagnet t)
{ exactLength = Just $ fromIntegral $ contentLength idLayoutInfo
, tracker = Just tAnnounce
}
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
fromURI :: URI -> Either String Magnet
fromURI u @ URI {..}
| not (isMagnetURI u) = Left "this is not a magnet link"
| otherwise = importURI u >>= fromQuery
toURI :: Magnet -> URI
toURI m = magnetScheme %? urlEncode m
etom :: Either a b -> Maybe b
etom = either (const Nothing) Just
parseMagnet :: String -> Maybe Magnet
parseMagnet = parseURI >=> etom . fromURI
renderMagnet :: Magnet -> String
renderMagnet = show . toURI