module Network.MPD.Commands (
Artist, Album, Title, PlaylistName, Path,
Meta(..), Match(..), Query,
module Network.MPD.Types,
disableOutput, enableOutput, kill, outputs, update,
find, list, listAll, listAllInfo, lsInfo, search, count,
add, add_, addId, clear, currentSong, delete, load, move,
playlistInfo, listPlaylist, listPlaylistInfo, playlist, plChanges,
plChangesPosId, playlistFind, playlistSearch, rm, rename, save, shuffle,
swap,
crossfade, next, pause, play, previous, random, repeat, seek, setVolume,
volume, stop,
clearError, close, commands, notCommands, password, ping, reconnect, stats,
status, tagTypes, urlHandlers,
addMany, deleteMany, complete, crop, prune, lsDirs, lsFiles, lsPlaylists,
findArtist, findAlbum, findTitle, listArtists, listAlbums, listAlbum,
searchArtist, searchAlbum, searchTitle, getPlaylist, toggle, updateId
) where
import Network.MPD.Core
import Network.MPD.Utils
import Network.MPD.Parse
import Network.MPD.Types
import Control.Monad (liftM, unless)
import Control.Monad.Error (throwError)
import Prelude hiding (repeat)
import Data.List (findIndex, intersperse, isPrefixOf)
import Data.Maybe
import System.FilePath (dropFileName)
newtype Args = Args [String]
deriving Show
class Show a => MPDArg a where
prep :: a -> Args
prep = Args . return . show
infixl 3 <++>
(<++>) :: (MPDArg a, MPDArg b) => a -> b -> Args
x <++> y = Args $ xs ++ ys
where Args xs = prep x
Args ys = prep y
infix 2 <$>
(<$>) :: (MPDArg a) => String -> a -> String
x <$> y = x ++ " " ++ unwords (filter (not . null) y')
where Args y' = prep y
instance MPDArg Args where prep = id
instance MPDArg String where
prep x = Args ['"' : x ++ "\""]
instance (MPDArg a) => MPDArg (Maybe a) where
prep Nothing = Args []
prep (Just x) = prep x
instance MPDArg Int
instance MPDArg Integer
instance MPDArg Bool where prep = Args . return . showBool
type Artist = String
type Album = String
type Title = String
type PlaylistName = String
type Path = String
data Meta = Artist | Album | Title | Track | Name | Genre | Date
| Composer | Performer | Disc | Any | Filename
deriving Show
instance MPDArg Meta
data Match = Match Meta String
instance Show Match where
show (Match meta query) = show meta ++ " \"" ++ query ++ "\""
showList xs _ = unwords $ map show xs
type Query = [Match]
instance MPDArg Query where
prep = foldl (<++>) (Args []) . f
where f = map (\(Match m q) -> Args [show m] <++> q)
disableOutput :: Int -> MPD ()
disableOutput = getResponse_ . ("disableoutput" <$>)
enableOutput :: Int -> MPD ()
enableOutput = getResponse_ . ("enableoutput" <$>)
outputs :: MPD [Device]
outputs = getResponse "outputs" >>= runParser parseOutputs
update :: [Path] -> MPD ()
update [] = getResponse_ "update"
update [x] = getResponse_ ("update" <$> x)
update xs = getResponses (map ("update" <$>) xs) >> return ()
list :: Meta
-> Query -> MPD [String]
list mtype query = liftM takeValues $ getResponse ("list" <$> mtype <++> query)
lsInfo :: Path -> MPD [Either Path Song]
lsInfo = lsInfo' "lsinfo"
listAll :: Path -> MPD [Path]
listAll path = liftM (map snd . filter ((== "file") . fst) . toAssoc)
(getResponse $ "listall" <$> path)
listAllInfo :: Path -> MPD [Either Path Song]
listAllInfo = lsInfo' "listallinfo"
lsInfo' :: String -> Path -> MPD [Either Path Song]
lsInfo' cmd path = do
liftM (extractEntries (Just . Right, const Nothing, Just . Left)) $
takeEntries =<< getResponse (cmd <$> path)
find :: Query -> MPD [Song]
find query = getResponse ("find" <$> query) >>= takeSongs
search :: Query -> MPD [Song]
search query = getResponse ("search" <$> query) >>= takeSongs
count :: Query -> MPD Count
count query = getResponse ("count" <$> query) >>= runParser parseCount
addId :: Path -> MPD Integer
addId p = getResponse1 ("addid" <$> p) >>=
parse parseNum id . snd . head . toAssoc
add :: PlaylistName -> Path -> MPD [Path]
add plname x = add_ plname x >> listAll x
add_ :: PlaylistName -> Path -> MPD ()
add_ "" path = getResponse_ ("add" <$> path)
add_ plname path = getResponse_ ("playlistadd" <$> plname <++> path)
clear :: PlaylistName -> MPD ()
clear "" = getResponse_ "clear"
clear pl = getResponse_ ("playlistclear" <$> pl)
delete :: PlaylistName -> PLIndex -> MPD ()
delete "" (Pos x) = getResponse_ ("delete" <$> x)
delete "" (ID x) = getResponse_ ("deleteid" <$> x)
delete plname (Pos x) = getResponse_ ("playlistdelete" <$> plname <++> x)
delete _ _ = fail "'delete' within a playlist doesn't accept a playlist ID"
load :: PlaylistName -> MPD ()
load plname = getResponse_ ("load" <$> plname)
move :: PlaylistName -> PLIndex -> Integer -> MPD ()
move "" (Pos from) to = getResponse_ ("move" <$> from <++> to)
move "" (ID from) to = getResponse_ ("moveid" <$> from <++> to)
move plname (Pos from) to =
getResponse_ ("playlistmove" <$> plname <++> from <++> to)
move _ _ _ = fail "'move' within a playlist doesn't accept a playlist ID"
rm :: PlaylistName -> MPD ()
rm plname = getResponse_ ("rm" <$> plname)
rename :: PlaylistName
-> PlaylistName
-> MPD ()
rename plname new = getResponse_ ("rename" <$> plname <++> new)
save :: PlaylistName -> MPD ()
save plname = getResponse_ ("save" <$> plname)
swap :: PLIndex -> PLIndex -> MPD ()
swap (Pos x) (Pos y) = getResponse_ ("swap" <$> x <++> y)
swap (ID x) (ID y) = getResponse_ ("swapid" <$> x <++> y)
swap _ _ = fail "'swap' cannot mix position and ID arguments"
shuffle :: MPD ()
shuffle = getResponse_ "shuffle"
playlistInfo :: Maybe PLIndex -> MPD [Song]
playlistInfo x = getResponse cmd >>= takeSongs
where cmd = case x of
Just (Pos x') -> "playlistinfo" <$> x'
Just (ID x') -> "playlistid" <$> x'
Nothing -> "playlistinfo"
listPlaylistInfo :: PlaylistName -> MPD [Song]
listPlaylistInfo plname =
takeSongs =<< getResponse ("listplaylistinfo" <$> plname)
listPlaylist :: PlaylistName -> MPD [Path]
listPlaylist plname =
liftM takeValues $ getResponse ("listplaylist" <$> plname)
playlist :: MPD [(PLIndex, Path)]
playlist = mapM f =<< getResponse "playlist"
where f s | (pos, name) <- breakChar ':' s
, Just pos' <- parseNum pos
= return (Pos pos', name)
| otherwise = throwError . Unexpected $ show s
plChanges :: Integer -> MPD [Song]
plChanges version = takeSongs =<< getResponse ("plchanges" <$> version)
plChangesPosId :: Integer -> MPD [(PLIndex, PLIndex)]
plChangesPosId plver =
getResponse ("plchangesposid" <$> plver) >>=
mapM f . splitGroups [("cpos",id)] . toAssoc
where f xs | [("cpos", x), ("Id", y)] <- xs
, Just (x', y') <- pair parseNum (x, y)
= return (Pos x', ID y')
| otherwise = throwError . Unexpected $ show xs
playlistFind :: Query -> MPD [Song]
playlistFind q = takeSongs =<< getResponse ("playlistfind" <$> q)
playlistSearch :: Query -> MPD [Song]
playlistSearch q = takeSongs =<< getResponse ("playlistsearch" <$> q)
currentSong :: MPD (Maybe Song)
currentSong = do
cs <- status
if stState cs == Stopped
then return Nothing
else getResponse1 "currentsong" >>=
fmap Just . runParser parseSong . toAssoc
crossfade :: Seconds -> MPD ()
crossfade secs = getResponse_ ("crossfade" <$> secs)
play :: Maybe PLIndex -> MPD ()
play Nothing = getResponse_ "play"
play (Just (Pos x)) = getResponse_ ("play" <$> x)
play (Just (ID x)) = getResponse_ ("playid" <$> x)
pause :: Bool -> MPD ()
pause = getResponse_ . ("pause" <$>)
stop :: MPD ()
stop = getResponse_ "stop"
next :: MPD ()
next = getResponse_ "next"
previous :: MPD ()
previous = getResponse_ "previous"
seek :: Maybe PLIndex -> Seconds -> MPD ()
seek (Just (Pos x)) time = getResponse_ ("seek" <$> x <++> time)
seek (Just (ID x)) time = getResponse_ ("seekid" <$> x <++> time)
seek Nothing time = do
st <- status
unless (stState st == Stopped) (seek (stSongID st) time)
random :: Bool -> MPD ()
random = getResponse_ . ("random" <$>)
repeat :: Bool -> MPD ()
repeat = getResponse_ . ("repeat" <$>)
setVolume :: Int -> MPD ()
setVolume = getResponse_ . ("setvol" <$>)
volume :: Int -> MPD ()
volume = getResponse_ . ("volume" <$>)
clearError :: MPD ()
clearError = getResponse_ "clearerror"
commands :: MPD [String]
commands = liftM takeValues (getResponse "commands")
notCommands :: MPD [String]
notCommands = liftM takeValues (getResponse "notcommands")
tagTypes :: MPD [String]
tagTypes = liftM takeValues (getResponse "tagtypes")
urlHandlers :: MPD [String]
urlHandlers = liftM takeValues (getResponse "urlhandlers")
password :: String -> MPD ()
password = getResponse_ . ("password " ++)
ping :: MPD ()
ping = getResponse_ "ping"
stats :: MPD Stats
stats = getResponse "stats" >>= runParser parseStats
status :: MPD Status
status = getResponse "status" >>= runParser parseStatus
updateId :: [Path] -> MPD Integer
updateId paths = liftM (read . head . takeValues) cmd
where cmd = case paths of
[] -> getResponse "update"
[x] -> getResponse ("update" <$> x)
xs -> getResponses $ map ("update" <$>) xs
toggle :: MPD ()
toggle = status >>= \st -> case stState st of Playing -> pause True
_ -> play Nothing
addMany :: PlaylistName -> [Path] -> MPD ()
addMany _ [] = return ()
addMany plname [x] = add_ plname x
addMany plname xs = getResponses (map cmd xs) >> return ()
where cmd x = case plname of
"" -> "add" <$> x
pl -> "playlistadd" <$> pl <++> x
deleteMany :: PlaylistName -> [PLIndex] -> MPD ()
deleteMany _ [] = return ()
deleteMany plname [x] = delete plname x
deleteMany "" xs = getResponses (map cmd xs) >> return ()
where cmd (Pos x) = "delete" <$> x
cmd (ID x) = "deleteid" <$> x
deleteMany plname xs = getResponses (map cmd xs) >> return ()
where cmd (Pos x) = "playlistdelete" <$> plname <++> x
cmd _ = ""
complete :: String -> MPD [Either Path Song]
complete path = do
xs <- liftM matches . lsInfo $ dropFileName path
case xs of
[Left dir] -> complete $ dir ++ "/"
_ -> return xs
where
matches = filter (isPrefixOf path . takePath)
takePath = either id sgFilePath
crop :: Maybe PLIndex -> Maybe PLIndex -> MPD ()
crop x y = do
pl <- playlistInfo Nothing
let x' = case x of Just (Pos p) -> fromInteger p
Just (ID i) -> fromMaybe 0 (findByID i pl)
Nothing -> 0
ys = case y of Just (Pos p) -> drop (max (fromInteger p) x') pl
Just (ID i) -> maybe [] (flip drop pl . max x' . (+1))
(findByID i pl)
Nothing -> []
deleteMany "" . mapMaybe sgIndex $ take x' pl ++ ys
where findByID i = findIndex ((==) i . (\(ID j) -> j) . fromJust . sgIndex)
prune :: MPD ()
prune = findDuplicates >>= deleteMany ""
findDuplicates :: MPD [PLIndex]
findDuplicates =
liftM (map ((\(ID x) -> ID x) . fromJust . sgIndex) . flip dups ([],[])) $
playlistInfo Nothing
where dups [] (_, dup) = dup
dups (x:xs) (ys, dup)
| x `mSong` xs && not (x `mSong` ys) = dups xs (ys, x:dup)
| otherwise = dups xs (x:ys, dup)
mSong x = let m = sgFilePath x in any ((==) m . sgFilePath)
lsDirs :: Path -> MPD [Path]
lsDirs path =
liftM (extractEntries (const Nothing,const Nothing, Just)) $
takeEntries =<< getResponse ("lsinfo" <$> path)
lsFiles :: Path -> MPD [Path]
lsFiles path =
liftM (extractEntries (Just . sgFilePath, const Nothing, const Nothing)) $
takeEntries =<< getResponse ("lsinfo" <$> path)
lsPlaylists :: MPD [PlaylistName]
lsPlaylists = liftM (extractEntries (const Nothing, Just, const Nothing)) $
takeEntries =<< getResponse "lsinfo"
findArtist :: Artist -> MPD [Song]
findArtist x = find [Match Artist x]
findAlbum :: Album -> MPD [Song]
findAlbum x = find [Match Album x]
findTitle :: Title -> MPD [Song]
findTitle x = find [Match Title x]
listArtists :: MPD [Artist]
listArtists = liftM takeValues (getResponse "list artist")
listAlbums :: Maybe Artist -> MPD [Album]
listAlbums artist = liftM takeValues $
getResponse ("list album" <$> fmap ("artist" <++>) artist)
listAlbum :: Artist -> Album -> MPD [Song]
listAlbum artist album = find [Match Artist artist, Match Album album]
searchArtist :: Artist -> MPD [Song]
searchArtist x = search [Match Artist x]
searchAlbum :: Album -> MPD [Song]
searchAlbum x = search [Match Album x]
searchTitle :: Title -> MPD [Song]
searchTitle x = search [Match Title x]
getPlaylist :: MPD [Song]
getPlaylist = playlistInfo Nothing
getResponse_ :: String -> MPD ()
getResponse_ x = getResponse x >> return ()
getResponses :: [String] -> MPD [String]
getResponses cmds = getResponse . concat $ intersperse "\n" cmds'
where cmds' = "command_list_begin" : cmds ++ ["command_list_end"]
failOnEmpty :: [String] -> MPD [String]
failOnEmpty [] = throwError $ Unexpected "Non-empty response expected."
failOnEmpty xs = return xs
getResponse1 :: String -> MPD [String]
getResponse1 x = getResponse x >>= failOnEmpty
takeValues :: [String] -> [String]
takeValues = snd . unzip . toAssoc
data EntryType
= SongEntry Song
| PLEntry String
| DirEntry String
deriving Show
takeEntries :: [String] -> MPD [EntryType]
takeEntries = mapM toEntry . splitGroups wrappers . toAssoc . reverse
where
toEntry xs@(("file",_):_) = liftM SongEntry $ runParser parseSong xs
toEntry (("directory",d):_) = return $ DirEntry d
toEntry (("playlist",pl):_) = return $ PLEntry pl
toEntry _ = error "takeEntries: splitGroups is broken"
wrappers = [("file",id), ("directory",id), ("playlist",id)]
extractEntries :: (Song -> Maybe a, String -> Maybe a, String -> Maybe a)
-> [EntryType] -> [a]
extractEntries (fSong,fPlayList,fDir) = catMaybes . map f
where
f (SongEntry s) = fSong s
f (PLEntry pl) = fPlayList pl
f (DirEntry d) = fDir d
takeSongs :: [String] -> MPD [Song]
takeSongs = mapM (runParser parseSong) . splitGroups [("file",id)] . toAssoc