add track metadata

Database.hs

@@ -8,10 +8,12 @@ import qualified Unsafe.Coerce as C
 import qualified Data.Text as TIO
 import Data.Text.Encoding
 import System.Process
-import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString as B
 import Data.String.Utils
+import Data.Maybe
+import Control.Applicative
 
-toPath :: String -> MP.Path
 {-
  - unsafeCoerce is needed because the "Path"
  - type is a newtype that represents a ByteString type.
@@ -20,8 +22,28 @@ toPath :: String -> MP.Path
  - Therefore we just coerce to that type, which
  - is the exact same type anyway
  -}
-toPath = C.unsafeCoerce . B.pack . strip . head . split "\n"
+toPath :: String -> MP.Path
+toPath = C.unsafeCoerce . BC.pack . strip . head . split "\n"
+
+toValue :: B.ByteString -> MP.Value
+toValue = C.unsafeCoerce
+
+changeTitle :: TIO.Text -> Maybe MP.Song -> IO (MP.Response ())
+changeTitle _ Nothing = error "empty playlist"
+
+changeTitle title' (Just song) = do
+  let title = encodeUtf8 title'
+  case (MP.sgId song) of
+    Nothing -> error "tried to modify a non-existent track"
+    (Just sid) -> do
+      MP.withMPD $
+        MP.addTagId sid MP.Title (toValue title)
 
-addSingle url = do
-  fullUrl <- readProcess "youtube-dl" ["-g", "-f", "bestaudio", (TIO.unpack url)] ""
+addSingle :: SearchResult -> IO (MP.Response ())
+addSingle track = do
+  let trackUrl = url track
+  let trackTitle = title track
+  fullUrl <- readProcess "youtube-dl" ["-g", "-f", "bestaudio", (TIO.unpack trackUrl)] ""
   MP.withMPD $ MP.add $ toPath fullUrl
+  (Right pl) <- (MP.withMPD $ MP.playlistInfo Nothing)
+  changeTitle trackTitle (listToMaybe $ reverse pl)

Internal.hs

@@ -0,0 +1,100 @@
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
+
+{- |
+Module      : Network.MPD.Applicative.Internal
+Copyright   : (c) Simon Hengel 2012
+License     : MIT
+
+Maintainer  : joachifm@fastmail.fm
+Stability   : stable
+Portability : unportable
+
+Applicative MPD command interface.
+
+This allows us to combine commands into command lists, as in
+
+> (,,) <$> currentSong <*> stats <*> status
+
+where the requests are automatically combined into a command list and
+the result of each command passed to the consumer.
+-}
+
+module Internal
+    ( Parser(..)
+    , liftParser
+    , getResponse
+    , emptyResponse
+    , unexpected
+    , Command(..)
+    , runCommand
+    ) where
+
+import           Control.Applicative
+import           Control.Monad
+import           Data.ByteString.Char8 (ByteString)
+
+import           Network.MPD.Core hiding (getResponse)
+import qualified Network.MPD.Core as Core
+import           Control.Monad.Error
+
+-- | A line-oriented parser that returns a value along with any remaining input.
+newtype Parser a
+    = Parser { runParser :: [ByteString] -> Either String (a, [ByteString]) }
+      deriving Functor
+
+instance Monad Parser where
+    fail      = Parser . const . Left
+    return a  = Parser $ \input -> Right (a, input)
+    p1 >>= p2 = Parser $ \input -> runParser p1 input >>= uncurry (runParser . p2)
+
+instance Applicative Parser where
+    pure  = return
+    (<*>) = ap
+
+-- | Convert a regular parser.
+liftParser :: ([ByteString] -> Either String a) -> Parser a
+liftParser p = Parser $ \input -> case break (== "list_OK") input of
+    (xs, ys) -> fmap (, drop 1 ys) (p xs)
+
+-- | Return everything until the next "list_OK".
+getResponse :: Parser [ByteString]
+getResponse = Parser $ \input -> case break (== "list_OK") input of
+    (xs, ys) -> Right (xs, drop 1 ys)
+
+-- | For commands returning an empty response.
+emptyResponse :: Parser ()
+emptyResponse = do
+    r <- getResponse
+    unless (null r) $
+        unexpected r
+
+-- | Fail with unexpected response.
+unexpected :: [ByteString] -> Parser a
+unexpected = fail . ("unexpected Response: " ++) . show
+
+-- | A compound command, comprising a parser for the responses and a
+-- combined request of an arbitrary number of commands.
+data Command a = Command {
+     commandParser  :: Parser a
+   , commandRequest :: [String]
+   } deriving Functor
+
+instance Applicative Command where
+    pure a = Command (pure a) []
+    (Command p1 c1) <*> (Command p2 c2) = Command (p1 <*> p2) (c1 ++ c2)
+
+-- | Execute a 'Command'.
+runCommand :: MonadMPD m => Command a -> m a
+runCommand (Command p c) = do
+    r <- Core.getResponse command
+    case runParser p r of
+        Left err      -> throwError (Unexpected err)
+        Right (a, []) -> return a
+        Right (_, xs) -> throwError (Unexpected $ "superfluous input: " ++ show xs)
+    where
+        command = case c of
+            [x] -> x
+            xs  -> unlines ("command_list_ok_begin" : xs)
+                   ++ "command_list_end"

Main.hs

@@ -1,6 +1,7 @@
 module Main where
 
 import Search
+import Network.MPD.Applicative.CurrentPlaylist
 import Types
 import Database
 import Data.List

Search.hs

@@ -71,8 +71,7 @@ search term = do
   accessTok <- fmap (accessToken . read) (readFile file)
   findTracks client accessTok $ urlEncode term
 
-firstResult = url . head $. search
-allResults = map url $. search
+firstResult = head $. search
 withDescriptions = map ((T.drop 3) . liftM2 (T.append `on` (T.append " : ")) url description) $. search
 withTitles = map ((T.drop 3) . liftM2 (T.append `on` (T.append " : ")) url title) $. search
 withDescriptionsStr = T.intercalate "\n" $. withDescriptions