module Network.MPD.Commands (
State(..), Status(..), Stats(..),
Device(..),
Query(..), Meta(..),
Artist, Album, Title, Seconds, PlaylistName, Path,
PLIndex(..), Song(..), Count(..),
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 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)
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
data Query = Query Meta String
| MultiQuery [Query]
instance Show Query where
show (Query meta query) = show meta ++ " " ++ show query
show (MultiQuery xs) = show xs
showList xs _ = unwords $ map show xs
disableOutput :: Int -> MPD ()
disableOutput = getResponse_ . ("disableoutput " ++) . show
enableOutput :: Int -> MPD ()
enableOutput = getResponse_ . ("enableoutput " ++) . show
outputs :: MPD [Device]
outputs = getResponse "outputs" >>= runParser parseOutputs
update :: [Path] -> MPD ()
update [] = getResponse_ "update"
update [x] = getResponse_ ("update " ++ show x)
update xs = getResponses (map (("update " ++) . show) xs) >> return ()
list :: Meta
-> Maybe Query -> MPD [String]
list mtype query = liftM takeValues (getResponse cmd)
where cmd = "list " ++ show mtype ++ maybe "" ((" "++) . show) 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 " ++ show 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 ++ " " ++ show path)
find :: Query -> MPD [Song]
find query = getResponse ("find " ++ show query) >>= takeSongs
search :: Query -> MPD [Song]
search query = getResponse ("search " ++ show query) >>= takeSongs
count :: Query -> MPD Count
count query = getResponse ("count " ++ show query) >>= runParser parseCount
addId :: Path -> MPD Integer
addId p = getResponse1 ("addid " ++ show 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_ "" = getResponse_ . ("add " ++) . show
add_ plname = getResponse_ .
(("playlistadd " ++ show plname ++ " ") ++) . show
clear :: PlaylistName -> MPD ()
clear = getResponse_ . cmd
where cmd "" = "clear"
cmd pl = "playlistclear " ++ show pl
delete :: PlaylistName -> PLIndex -> MPD ()
delete "" (Pos x) = getResponse_ ("delete " ++ show x)
delete "" (ID x) = getResponse_ ("deleteid " ++ show x)
delete plname (Pos x) =
getResponse_ ("playlistdelete " ++ show plname ++ " " ++ show x)
delete _ _ = fail "'delete' within a playlist doesn't accept a playlist ID"
load :: PlaylistName -> MPD ()
load = getResponse_ . ("load " ++) . show
move :: PlaylistName -> PLIndex -> Integer -> MPD ()
move "" (Pos from) to =
getResponse_ ("move " ++ show from ++ " " ++ show to)
move "" (ID from) to =
getResponse_ ("moveid " ++ show from ++ " " ++ show to)
move plname (Pos from) to =
getResponse_ ("playlistmove " ++ show plname ++ " " ++ show from ++
" " ++ show to)
move _ _ _ = fail "'move' within a playlist doesn't accept a playlist ID"
rm :: PlaylistName -> MPD ()
rm = getResponse_ . ("rm " ++) . show
rename :: PlaylistName
-> PlaylistName
-> MPD ()
rename plname new =
getResponse_ ("rename " ++ show plname ++ " " ++ show new)
save :: PlaylistName -> MPD ()
save = getResponse_ . ("save " ++) . show
swap :: PLIndex -> PLIndex -> MPD ()
swap (Pos x) (Pos y) = getResponse_ ("swap " ++ show x ++ " " ++ show y)
swap (ID x) (ID y) = getResponse_ ("swapid " ++ show x ++ " " ++ show 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 " ++ show x'
Just (ID x') -> "playlistid " ++ show x'
Nothing -> "playlistinfo"
listPlaylistInfo :: PlaylistName -> MPD [Song]
listPlaylistInfo plname =
takeSongs =<< (getResponse . ("listplaylistinfo " ++) $ show plname)
listPlaylist :: PlaylistName -> MPD [Path]
listPlaylist = liftM takeValues . getResponse . ("listplaylist " ++) . show
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 " ++) $ show version)
plChangesPosId :: Integer -> MPD [(PLIndex, PLIndex)]
plChangesPosId plver =
getResponse ("plchangesposid " ++ show 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 " ++) $ show q)
playlistSearch :: Query -> MPD [Song]
playlistSearch q =
takeSongs =<< (getResponse . ("playlistsearch " ++) $ show 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 = getResponse_ . ("crossfade " ++) . show
play :: Maybe PLIndex -> MPD ()
play Nothing = getResponse_ "play"
play (Just (Pos x)) = getResponse_ ("play " ++ show x)
play (Just (ID x)) = getResponse_ ("playid " ++ show x)
pause :: Bool -> MPD ()
pause = getResponse_ . ("pause " ++) . showBool
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 " ++ show x ++ " " ++ show time)
seek (Just (ID x)) time =
getResponse_ ("seekid " ++ show x ++ " " ++ show time)
seek Nothing time = do
st <- status
unless (stState st == Stopped) (seek (stSongID st) time)
random :: Bool -> MPD ()
random = getResponse_ . ("random " ++) . showBool
repeat :: Bool -> MPD ()
repeat = getResponse_ . ("repeat " ++) . showBool
setVolume :: Int -> MPD ()
setVolume = getResponse_ . ("setvol " ++) . show
volume :: Int -> MPD ()
volume = getResponse_ . ("volume " ++) . show
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 map show 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 ++) . show) xs) >> return ()
where cmd = case plname of "" -> "add "
pl -> "playlistadd " ++ show pl ++ " "
deleteMany :: PlaylistName -> [PLIndex] -> MPD ()
deleteMany _ [] = return ()
deleteMany plname [x] = delete plname x
deleteMany "" xs = getResponses (map cmd xs) >> return ()
where cmd (Pos x) = "delete " ++ show x
cmd (ID x) = "deleteid " ++ show x
deleteMany plname xs = getResponses (map cmd xs) >> return ()
where cmd (Pos x) = "playlistdelete " ++ show plname ++ " " ++ show 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 `elem` xs && x `notElem` ys = dups xs (ys, x:dup)
| otherwise = dups xs (x:ys, dup)
lsDirs :: Path -> MPD [Path]
lsDirs path =
liftM (extractEntries (const Nothing,const Nothing, Just)) $
takeEntries =<< getResponse ("lsinfo " ++ show path)
lsFiles :: Path -> MPD [Path]
lsFiles path =
liftM (extractEntries (Just . sgFilePath, const Nothing, const Nothing)) $
takeEntries =<< getResponse ("lsinfo " ++ show path)
lsPlaylists :: MPD [PlaylistName]
lsPlaylists =
liftM (extractEntries (const Nothing, Just, const Nothing)) $
takeEntries =<< getResponse "lsinfo"
findArtist :: Artist -> MPD [Song]
findArtist = find . Query Artist
findAlbum :: Album -> MPD [Song]
findAlbum = find . Query Album
findTitle :: Title -> MPD [Song]
findTitle = find . Query Title
listArtists :: MPD [Artist]
listArtists = liftM takeValues (getResponse "list artist")
listAlbums :: Maybe Artist -> MPD [Album]
listAlbums artist = liftM takeValues (getResponse ("list album" ++
maybe "" ((" artist " ++) . show) artist))
listAlbum :: Artist -> Album -> MPD [Song]
listAlbum artist album = find (MultiQuery [Query Artist artist
,Query Album album])
searchArtist :: Artist -> MPD [Song]
searchArtist = search . Query Artist
searchAlbum :: Album -> MPD [Song]
searchAlbum = search . Query Album
searchTitle :: Title -> MPD [Song]
searchTitle = search . Query Title
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