Add QueryLike and Convertible instances to Magnet

1 files changed, 140 insertions, 149 deletions

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:
 --   <http://www.bittorrent.org/beps/bep_0009.html>
 --
-{-# 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 #-}