module Network.MPD.Commands (
module Network.MPD.Commands.Types,
module Network.MPD.Commands.Query,
clearError, currentSong, idle, noidle, status, stats,
consume, crossfade, random, repeat, setVolume, single, replayGainMode,
replayGainStatus,
next, pause, play, previous, seek, stop,
add, add_, addId, clear, delete, move, playlist, playlistFind,
playlistInfo, playlistSearch, plChanges, plChangesPosId, shuffle, swap,
listPlaylist, listPlaylistInfo, listPlaylists, load, playlistAdd,
playlistAdd_, playlistClear, playlistDelete, playlistMove, rename, rm,
save,
count, find, findAdd, list, listAll, listAllInfo, lsInfo, search, update,
rescan,
stickerGet, stickerSet, stickerDelete, stickerList, stickerFind,
close, kill, password, ping,
disableOutput, enableOutput, outputs,
commands, notCommands, tagTypes, urlHandlers, decoders,
addMany, deleteMany, complete, crop, prune, lsDirs, lsFiles, lsPlaylists,
listArtists, listAlbums, listAlbum, getPlaylist, toggle, updateId, volume
) where
import Network.MPD.Commands.Arg
import Network.MPD.Commands.Parse
import Network.MPD.Commands.Query
import Network.MPD.Commands.Types
import Network.MPD.Core
import Network.MPD.Utils
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)
clearError :: MonadMPD m => m ()
clearError = getResponse_ "clearerror"
currentSong :: (Functor m, MonadMPD m) => m (Maybe Song)
currentSong = do
cs <- status
if stState cs == Stopped
then return Nothing
else getResponse1 "currentsong" >>=
fmap Just . runParser parseSong . toAssocList
idle :: MonadMPD m => m [Subsystem]
idle =
mapM (\("changed", system) -> case system of "database" -> return Database
"update" -> return Update
"stored_playlist" -> return StoredPlaylist
"playlist" -> return Playlist
"player" -> return Player
"mixer" -> return Mixer
"output" -> return Output
"options" -> return Options
k -> fail ("Unknown subsystem: " ++ k))
=<< toAssocList `liftM` getResponse "idle"
noidle :: MonadMPD m => m ()
noidle = getResponse_ "noidle"
stats :: MonadMPD m => m Stats
stats = getResponse "stats" >>= runParser parseStats
status :: MonadMPD m => m Status
status = getResponse "status" >>= runParser parseStatus
consume :: MonadMPD m => Bool -> m ()
consume = getResponse_ . ("consume" <$>)
crossfade :: MonadMPD m => Seconds -> m ()
crossfade secs = getResponse_ ("crossfade" <$> secs)
random :: MonadMPD m => Bool -> m ()
random = getResponse_ . ("random" <$>)
repeat :: MonadMPD m => Bool -> m ()
repeat = getResponse_ . ("repeat" <$>)
setVolume :: MonadMPD m => Int -> m ()
setVolume = getResponse_ . ("setvol" <$>)
single :: MonadMPD m => Bool -> m ()
single = getResponse_ . ("single" <$>)
replayGainMode :: MonadMPD m => ReplayGainMode -> m ()
replayGainMode = getResponse_ . ("replay_gain_mode" <$>)
replayGainStatus :: MonadMPD m => m [String]
replayGainStatus = getResponse "replay_gain_status"
next :: MonadMPD m => m ()
next = getResponse_ "next"
pause :: MonadMPD m => Bool -> m ()
pause = getResponse_ . ("pause" <$>)
play :: MonadMPD m => Maybe PLIndex -> m ()
play Nothing = getResponse_ "play"
play (Just (Pos x)) = getResponse_ ("play" <$> x)
play (Just (ID x)) = getResponse_ ("playid" <$> x)
previous :: MonadMPD m => m ()
previous = getResponse_ "previous"
seek :: MonadMPD m => Maybe PLIndex -> Seconds -> m ()
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)
stop :: MonadMPD m => m ()
stop = getResponse_ "stop"
addId :: MonadMPD m => Path -> Maybe Integer
-> m Integer
addId p pos = liftM (parse parseNum id 0 . snd . head . toAssocList)
$ getResponse1 ("addid" <$> p <++> pos)
add :: MonadMPD m => Path -> m [Path]
add x = add_ x >> listAll x
add_ :: MonadMPD m => Path -> m ()
add_ path = getResponse_ ("add" <$> path)
clear :: MonadMPD m => m ()
clear = getResponse_ "clear"
delete :: MonadMPD m => PLIndex -> m ()
delete (Pos x) = getResponse_ ("delete" <$> x)
delete (ID x) = getResponse_ ("deleteid" <$> x)
move :: MonadMPD m => PLIndex -> Integer -> m ()
move (Pos from) to = getResponse_ ("move" <$> from <++> to)
move (ID from) to = getResponse_ ("moveid" <$> from <++> to)
playlist :: MonadMPD m => m [(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
playlistFind :: MonadMPD m => Query -> m [Song]
playlistFind q = takeSongs =<< getResponse ("playlistfind" <$> q)
playlistInfo :: MonadMPD m => Maybe (Either PLIndex (Int, Int)) -> m [Song]
playlistInfo x = getResponse cmd >>= takeSongs
where cmd = case x of
Nothing -> "playlistinfo"
Just (Left (Pos x')) -> "playlistinfo" <$> x'
Just (Left (ID x')) -> "playlistid" <$> x'
Just (Right range) -> "playlistinfo" <$> range
playlistSearch :: MonadMPD m => Query -> m [Song]
playlistSearch q = takeSongs =<< getResponse ("playlistsearch" <$> q)
plChanges :: MonadMPD m => Integer -> m [Song]
plChanges version = takeSongs =<< getResponse ("plchanges" <$> version)
plChangesPosId :: MonadMPD m => Integer -> m [(PLIndex, PLIndex)]
plChangesPosId plver =
getResponse ("plchangesposid" <$> plver) >>=
mapM f . splitGroups [("cpos",id)] . toAssocList
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
shuffle :: MonadMPD m => Maybe (Int, Int)
-> m ()
shuffle range = getResponse_ ("shuffle" <$> range)
swap :: MonadMPD m => PLIndex -> PLIndex -> m ()
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"
listPlaylist :: MonadMPD m => PlaylistName -> m [Path]
listPlaylist plname =
liftM takeValues $ getResponse ("listplaylist" <$> plname)
listPlaylistInfo :: MonadMPD m => PlaylistName -> m [Song]
listPlaylistInfo plname =
takeSongs =<< getResponse ("listplaylistinfo" <$> plname)
listPlaylists :: MonadMPD m => m [PlaylistName]
listPlaylists = (go [] . toAssocList) `liftM` getResponse "listplaylists"
where
go acc [] = acc
go acc ((_, b):_:xs) = go (b : acc) xs
go _ _ = error "listPlaylists: bug"
load :: MonadMPD m => PlaylistName -> m ()
load plname = getResponse_ ("load" <$> plname)
playlistAdd :: MonadMPD m => PlaylistName -> Path -> m [Path]
playlistAdd plname path = playlistAdd_ plname path >> listAll path
playlistAdd_ :: MonadMPD m => PlaylistName -> Path -> m ()
playlistAdd_ plname path = getResponse_ ("playlistadd" <$> plname <++> path)
playlistClear :: MonadMPD m => PlaylistName -> m ()
playlistClear = getResponse_ . ("playlistclear" <$>)
playlistDelete :: MonadMPD m => PlaylistName
-> Integer
-> m ()
playlistDelete name pos = getResponse_ ("playlistdelete" <$> name <++> pos)
playlistMove :: MonadMPD m => PlaylistName -> Integer -> Integer -> m ()
playlistMove name from to =
getResponse_ ("playlistmove" <$> name <++> from <++> to)
rename :: MonadMPD m
=> PlaylistName
-> PlaylistName
-> m ()
rename plname new = getResponse_ ("rename" <$> plname <++> new)
rm :: MonadMPD m => PlaylistName -> m ()
rm plname = getResponse_ ("rm" <$> plname)
save :: MonadMPD m => PlaylistName -> m ()
save plname = getResponse_ ("save" <$> plname)
count :: MonadMPD m => Query -> m Count
count query = getResponse ("count" <$> query) >>= runParser parseCount
find :: MonadMPD m => Query -> m [Song]
find query = getResponse ("find" <$> query) >>= takeSongs
findAdd :: MonadMPD m => Query -> m ()
findAdd q = getResponse_ ("findadd" <$> q)
list :: MonadMPD m
=> Meta
-> Query -> m [String]
list mtype query = liftM takeValues $ getResponse ("list" <$> mtype <++> query)
listAll :: MonadMPD m => Path -> m [Path]
listAll path = liftM (map snd . filter ((== "file") . fst) . toAssocList)
(getResponse $ "listall" <$> path)
lsInfo' :: MonadMPD m => String -> Path -> m [Either Path Song]
lsInfo' cmd path =
liftM (extractEntries (Just . Right, const Nothing, Just . Left)) $
takeEntries =<< getResponse (cmd <$> path)
listAllInfo :: MonadMPD m => Path -> m [Either Path Song]
listAllInfo = lsInfo' "listallinfo"
lsInfo :: MonadMPD m => Path -> m [Either Path Song]
lsInfo = lsInfo' "lsinfo"
search :: MonadMPD m => Query -> m [Song]
search query = getResponse ("search" <$> query) >>= takeSongs
update :: MonadMPD m => [Path] -> m ()
update [] = getResponse_ "update"
update [x] = getResponse_ ("update" <$> x)
update xs = getResponses (map ("update" <$>) xs) >> return ()
rescan :: MonadMPD m => [Path] -> m ()
rescan [] = getResponse_ "rescan"
rescan [x] = getResponse_ ("rescan" <$> x)
rescan xs = getResponses (map ("rescan" <$>) xs) >> return ()
stickerGet :: MonadMPD m => ObjectType
-> String
-> String
-> m [String]
stickerGet typ uri name = takeValues `liftM` getResponse ("sticker get" <$> typ <++> uri <++> name)
stickerSet :: MonadMPD m => ObjectType
-> String
-> String
-> String
-> m ()
stickerSet typ uri name value =
getResponse_ ("sticker set" <$> typ <++> uri <++> name <++> value)
stickerDelete :: MonadMPD m => ObjectType
-> String
-> String
-> m ()
stickerDelete typ uri name =
getResponse_ ("sticker delete" <$> typ <++> uri <++> name)
stickerList :: MonadMPD m => ObjectType
-> String
-> m [(String, String)]
stickerList typ uri =
toAssocList `liftM` getResponse ("sticker list" <$> typ <++> uri)
stickerFind :: MonadMPD m => ObjectType
-> String
-> String
-> m [(String, String)]
stickerFind typ uri name =
toAssocList `liftM`
getResponse ("sticker find" <$> typ <++> uri <++> name)
password :: MonadMPD m => String -> m ()
password = getResponse_ . ("password " ++)
ping :: MonadMPD m => m ()
ping = getResponse_ "ping"
disableOutput :: MonadMPD m => Int -> m ()
disableOutput = getResponse_ . ("disableoutput" <$>)
enableOutput :: MonadMPD m => Int -> m ()
enableOutput = getResponse_ . ("enableoutput" <$>)
outputs :: MonadMPD m => m [Device]
outputs = getResponse "outputs" >>= runParser parseOutputs
commands :: MonadMPD m => m [String]
commands = liftM takeValues (getResponse "commands")
notCommands :: MonadMPD m => m [String]
notCommands = liftM takeValues (getResponse "notcommands")
tagTypes :: MonadMPD m => m [String]
tagTypes = liftM takeValues (getResponse "tagtypes")
urlHandlers :: MonadMPD m => m [String]
urlHandlers = liftM takeValues (getResponse "urlhandlers")
decoders :: MonadMPD m => m [(String, [(String, String)])]
decoders = (takeDecoders . toAssocList) `liftM` getResponse "decoders"
where
takeDecoders [] = []
takeDecoders ((_, p):xs) =
let (info, rest) = break ((==) "plugin" . fst) xs
in (p, info) : takeDecoders rest
updateId :: MonadMPD m => [Path] -> m 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 :: MonadMPD m => m ()
toggle = status >>= \st -> case stState st of Playing -> pause True
_ -> play Nothing
addMany :: MonadMPD m => PlaylistName -> [Path] -> m ()
addMany _ [] = return ()
addMany "" [x] = add_ x
addMany plname [x] = playlistAdd_ plname x
addMany plname xs = getResponses (map cmd xs) >> return ()
where cmd x = case plname of
"" -> "add" <$> x
pl -> "playlistadd" <$> pl <++> x
deleteMany :: MonadMPD m => PlaylistName -> [PLIndex] -> m ()
deleteMany _ [] = return ()
deleteMany plname [(Pos x)] = playlistDelete 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 :: MonadMPD m => String -> m [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 :: MonadMPD m => Maybe PLIndex -> Maybe PLIndex -> m ()
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 :: MonadMPD m => m ()
prune = findDuplicates >>= deleteMany ""
findDuplicates :: MonadMPD m => m [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 :: MonadMPD m => Path -> m [Path]
lsDirs path =
liftM (extractEntries (const Nothing,const Nothing, Just)) $
takeEntries =<< getResponse ("lsinfo" <$> path)
lsFiles :: MonadMPD m => Path -> m [Path]
lsFiles path =
liftM (extractEntries (Just . sgFilePath, const Nothing, const Nothing)) $
takeEntries =<< getResponse ("lsinfo" <$> path)
lsPlaylists :: MonadMPD m => m [PlaylistName]
lsPlaylists = liftM (extractEntries (const Nothing, Just, const Nothing)) $
takeEntries =<< getResponse "lsinfo"
listArtists :: MonadMPD m => m [Artist]
listArtists = liftM takeValues (getResponse "list artist")
listAlbums :: MonadMPD m => Maybe Artist -> m [Album]
listAlbums artist = liftM takeValues $
getResponse ("list album" <$> fmap ("artist" <++>) artist)
listAlbum :: MonadMPD m => Artist -> Album -> m [Song]
listAlbum artist album = find (Artist =? artist <&> Album =? album)
getPlaylist :: MonadMPD m => m [Song]
getPlaylist = playlistInfo Nothing
volume :: MonadMPD m => Int -> m ()
volume n = do
current <- (fromIntegral . stVolume) `liftM` status
setVolume . round $ (fromIntegral n / 100) * current + current
getResponse_ :: MonadMPD m => String -> m ()
getResponse_ x = getResponse x >> return ()
getResponses :: MonadMPD m => [String] -> m [String]
getResponses cmds = getResponse . concat $ intersperse "\n" cmds'
where cmds' = "command_list_begin" : cmds ++ ["command_list_end"]
failOnEmpty :: MonadMPD m => [String] -> m [String]
failOnEmpty [] = throwError $ Unexpected "Non-empty response expected."
failOnEmpty xs = return xs
getResponse1 :: MonadMPD m => String -> m [String]
getResponse1 x = getResponse x >>= failOnEmpty
takeValues :: [String] -> [String]
takeValues = snd . unzip . toAssocList
data EntryType
= SongEntry Song
| PLEntry String
| DirEntry String
deriving (Eq, Show)
takeEntries :: MonadMPD m => [String] -> m [EntryType]
takeEntries = mapM toEntry . splitGroups wrappers . toAssocList
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) = mapMaybe f
where
f (SongEntry s) = fSong s
f (PLEntry pl) = fPlayList pl
f (DirEntry d) = fDir d
takeSongs :: MonadMPD m => [String] -> m [Song]
takeSongs = mapM (runParser parseSong)
. splitGroups [("file",id)]
. toAssocList