From fc3b090ac8dceefd315e6ca16f12d32dca11f580 Mon Sep 17 00:00:00 2001 From: Sam Truzjan Date: Thu, 28 Nov 2013 14:57:08 +0400 Subject: Add QueryLike and Convertible instances to Magnet --- src/Data/Torrent/Magnet.hs | 289 ++++++++++++++++++++++----------------------- 1 file changed, 140 insertions(+), 149 deletions(-) (limited to 'src/Data/Torrent') diff --git a/src/Data/Torrent/Magnet.hs b/src/Data/Torrent/Magnet.hs index 791537b1..1a675be4 100644 --- a/src/Data/Torrent/Magnet.hs +++ b/src/Data/Torrent/Magnet.hs @@ -13,7 +13,11 @@ -- Bittorrent specific info: -- -- -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} module Data.Torrent.Magnet ( -- * Magnet Magnet(..) @@ -26,85 +30,32 @@ module Data.Torrent.Magnet -- * Conversion , parseMagnet , renderMagnet - - -- ** Extra - , fromURI - , toURI ) where import Control.Applicative import Control.Monad +import Data.ByteString.Char8 as BC +import Data.Convertible +import Data.Default 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 Data.Text.Read +import Data.Typeable +import Network.HTTP.Types.QueryLike +import Network.HTTP.Types.URI 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 +import Data.Torrent.URN -{----------------------------------------------------------------------- --- 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 @@ -113,14 +64,17 @@ infoHashToURN = URN btih . T.pack . show 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 + , manifest :: Maybe Text + -- | Search string. - , keywordTopic :: Maybe String + , keywordTopic :: Maybe Text , acceptableSource :: Maybe URI , exactSource :: Maybe URI @@ -128,32 +82,98 @@ data Magnet = Magnet , tracker :: Maybe URI , supplement :: Map Text Text - } deriving (Eq, Ord) + } deriving (Eq, Ord, Typeable) + + +instance QueryValueLike Integer where + toQueryValue = toQueryValue . show + +instance QueryValueLike URI where + toQueryValue = toQueryValue . show + +instance QueryLike Magnet where + toQuery Magnet {..} = + [ ("xt", toQueryValue $ infohashURN exactTopic) + , ("dn", toQueryValue displayName) + , ("xl", toQueryValue exactLength) + , ("mt", toQueryValue manifest) + , ("kt", toQueryValue keywordTopic) + , ("as", toQueryValue acceptableSource) + , ("xs", toQueryValue exactSource) + , ("tr", toQueryValue tracker) + ] + +instance QueryValueLike Magnet where + toQueryValue = toQueryValue . renderMagnet + +instance Convertible QueryText Magnet where + safeConvert xs = do + urnStr <- getTextMsg "xt" "exact topic not defined" xs + infoHash <- convertVia (error "safeConvert" :: URN) urnStr + return Magnet + { exactTopic = infoHash + , displayName = getText "dn" xs + , exactLength = getText "xl" xs >>= getInt + , manifest = getText "mt" xs + , keywordTopic = getText "kt" xs + , acceptableSource = getText "as" xs >>= getURI + , exactSource = getText "xs" xs >>= getURI + , tracker = getText "tr" xs >>= getURI + , supplement = M.empty + } + where + getInt = either (const Nothing) (Just . fst) . signed decimal + getURI = parseURI . T.unpack + getText p = join . L.lookup p + getTextMsg p msg ps = maybe (convError msg xs) pure $ getText p ps -instance Show Magnet where - show = renderMagnet - {-# INLINE show #-} +magnetScheme :: URI +magnetScheme = URI + { uriScheme = "magnet:" + , uriAuthority = Nothing + , uriPath = "" + , uriQuery = "" + , uriFragment = "" + } -instance Read Magnet where - readsPrec _ xs - | Just m <- parseMagnet mstr = [(m, rest)] - | otherwise = [] - where - (mstr, rest) = L.break (== ' ') xs +isMagnetURI :: URI -> Bool +isMagnetURI u = u { uriQuery = "" } == magnetScheme -instance IsString Magnet where - fromString = fromMaybe def . parseMagnet - where - def = error "unable to parse magnet" +-- | Can be used instead of 'parseMagnet'. +instance Convertible URI Magnet where + safeConvert u @ URI {..} + | not (isMagnetURI u) = convError "this is not a magnet link" u + | otherwise = safeConvert $ parseQueryText $ BC.pack uriQuery -instance URLEncode Magnet where - urlEncode = toQuery - {-# INLINE urlEncode #-} +-- | Can be used instead of 'renderMagnet'. +instance Convertible Magnet URI where + safeConvert m = pure $ magnetScheme + { uriQuery = BC.unpack $ renderQuery True $ toQuery m } -instance Pretty Magnet where - pretty = PP.text . renderMagnet +instance Convertible String Magnet where + safeConvert str + | Just uri <- parseURI str = safeConvert uri + | otherwise = convError "unable to parse uri" str + +{----------------------------------------------------------------------- +-- Construction +-----------------------------------------------------------------------} --- | Set exact topic only, other params are empty. +-- | Meaningless placeholder value. +instance Default Magnet where + def = Magnet + { exactTopic = def + , displayName = Nothing + , exactLength = Nothing + , manifest = Nothing + , keywordTopic = Nothing + , acceptableSource = Nothing + , exactSource = Nothing + , tracker = Nothing + , supplement = M.empty + } + +-- | Set 'exactTopic' ('xt' param) only, other params are empty. nullMagnet :: InfoHash -> Magnet nullMagnet u = Magnet { exactTopic = u @@ -167,17 +187,16 @@ nullMagnet u = Magnet , supplement = M.empty } --- | A simple magnet link including infohash ('xt' param) and display --- name ('dn' param). --- +-- | Like 'nullMagnet' but also include 'displayName' ('dn' param). simpleMagnet :: Torrent -> Magnet simpleMagnet Torrent {tInfoDict = InfoDict {..}} = (nullMagnet idInfoHash) { displayName = Just $ T.decodeUtf8 $ suggestedName idLayoutInfo } --- | Like 'simpleMagnet' but also include exactLength ('xl' param) and --- tracker ('tr' param). +-- | Like 'simpleMagnet' but also include 'exactLength' ('xl' param) and +-- 'tracker' ('tr' param). +-- detailedMagnet :: Torrent -> Magnet detailedMagnet t @ Torrent {tInfoDict = InfoDict {..}, tAnnounce} = (simpleMagnet t) @@ -185,71 +204,43 @@ detailedMagnet t @ Torrent {tInfoDict = InfoDict {..}, tAnnounce} , 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 +{----------------------------------------------------------------------- +-- Conversion +-----------------------------------------------------------------------} -magnetScheme :: URI -magnetScheme = URI - { uriScheme = "magnet:" - , uriAuthority = Nothing - , uriPath = "" - , uriQuery = "" - , uriFragment = "" - } +parseMagnetStr :: String -> Maybe Magnet +parseMagnetStr = either (const Nothing) Just . safeConvert -isMagnetURI :: URI -> Bool -isMagnetURI u = u { uriQuery = "" } == magnetScheme +renderMagnetStr :: Magnet -> String +renderMagnetStr = show . (convert :: Magnet -> URI) + +instance Pretty Magnet where + pretty = PP.text . renderMagnetStr --- | 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 +instance Show Magnet where + show = renderMagnetStr + {-# INLINE show #-} --- | The same as 'renderMagnet' but useful if you need an uri. -toURI :: Magnet -> URI -toURI m = magnetScheme %? urlEncode m +instance Read Magnet where + readsPrec _ xs + | Just m <- parseMagnetStr mstr = [(m, rest)] + | otherwise = [] + where + (mstr, rest) = L.break (== ' ') xs -etom :: Either a b -> Maybe b -etom = either (const Nothing) Just +instance IsString Magnet where + fromString str = fromMaybe (error msg) $ parseMagnetStr str + where + msg = "unable to parse magnet: " ++ str --- | Try to parse magnet link from urlencoded string. -parseMagnet :: String -> Maybe Magnet -parseMagnet = parseURI >=> etom . fromURI +-- | Try to parse magnet link from urlencoded string. Use +-- 'safeConvert' to find out error location. +-- +parseMagnet :: Text -> Maybe Magnet +parseMagnet = parseMagnetStr . T.unpack +{-# INLINE parseMagnet #-} -- | Render magnet link to urlencoded string -renderMagnet :: Magnet -> String -renderMagnet = show . toURI +renderMagnet :: Magnet -> Text +renderMagnet = T.pack . renderMagnetStr +{-# INLINE renderMagnet #-} -- cgit v1.2.3