MPD.hs

   1 {-
   2     libmpd for Haskell, a MPD client library.
   3     Copyright (C) 2005  Ben Sinclair <bsinclai@turing.une.edu.au>
   4
   5     This library is free software; you can redistribute it and/or
   6     modify it under the terms of the GNU Lesser General Public
   7     License as published by the Free Software Foundation; either
   8     version 2.1 of the License, or (at your option) any later version.
   9
  10     This library is distributed in the hope that it will be useful,
  11     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13     Lesser General Public License for more details.
  14
  15     You should have received a copy of the GNU Lesser General Public
  16     License along with this library; if not, write to the Free Software
  17     Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
  18 -}
  19
  20 -- | Module    : MPD
  21 -- Copyright   : (c) Ben Sinclair 2005
  22 -- License     : LGPL
  23 -- Maintainer  : bsinclai@turing.une.edu.au
  24 -- Stability   : alpha
  25 -- Portability : Haskell 98
  26 --
  27 -- MPD client library.
  28
  29 module MPD (
  30             -- * Data types
  31             Connection,
  32             State(..), Status(..), Stats(..),
  33             Device(..),
  34             Query(..), Meta(..),
  35             Artist, Album, Title, Seconds, PLIndex(..),
  36             Song(..), Count(..),
  37
  38             -- * Connections
  39             withMPD, connect,
  40
  41             -- * Admin commands
  42             disableoutput, enableoutput, kill, outputs, update,
  43
  44             -- * Database commands
  45             find, list, listAll, listAllinfo, lsinfo, search, count,
  46
  47             -- * Playlist commands
  48             -- $playlist
  49             add, add_, addid, clear, currentSong, delete, load, move,
  50             playlistinfo, listplaylist, listplaylistinfo, playlist, plchanges,
  51             plchangesposid, playlistfind, playlistsearch, rm, rename, save,
  52             shuffle, swap,
  53
  54             -- * Playback commands
  55             crossfade, next, pause, play, previous, random, repeat, seek,
  56             setVolume, volume, stop,
  57
  58             -- * Miscellaneous commands
  59             clearerror, close, commands, notcommands, tagtypes, urlhandlers,
  60             password, ping, stats, status,
  61
  62             -- * Extensions\/shortcuts
  63             addMany, deleteMany, crop, prune, lsdirs, lsfiles, lsplaylists,
  64             findArtist, findAlbum, findTitle, listArtists, listAlbums,
  65             listAlbum, searchArtist, searchAlbum, searchTitle, getPlaylist,
  66             toggle
  67            ) where
  68
  69 import Control.Exception (bracket)
  70 import Control.Monad (liftM, unless)
  71 import Prelude hiding (repeat)
  72 import Data.List (isPrefixOf, findIndex)
  73 import Data.Maybe
  74 import Network
  75 import System.IO
  76
  77 --
  78 -- Data Types
  79 --
  80
  81 -- | A connection to an MPD server.
  82 newtype Connection = Conn Handle
  83
  84 type Artist  = String
  85 type Album   = String
  86 type Title   = String
  87 type Seconds = Integer
  88
  89 -- | Available metadata types\/scope modifiers, used for searching the
  90 -- database for entries with certain metadata values.
  91 data Meta = Artist | Album | Title | Track | Name | Genre | Date
  92     | Composer | Performer | Disc | Any | Filename
  93
  94 instance Show Meta where
  95     show Artist    = "Artist"
  96     show Album     = "Album"
  97     show Title     = "Title"
  98     show Track     = "Track"
  99     show Name      = "Name"
 100     show Genre     = "Genre"
 101     show Date      = "Date"
 102     show Composer  = "Composer"
 103     show Performer = "Performer"
 104     show Disc      = "Disc"
 105     show Any       = "Any"
 106     show Filename  = "Filename"
 107
 108 -- | A query is comprised of a scope modifier and a query string.
 109 data Query = Query Meta String  -- ^ Simple query.
 110            | MultiQuery [Query] -- ^ Query with multiple conditions.
 111
 112 instance Show Query where
 113     show (Query meta query) = show meta ++ " " ++ show query
 114     show (MultiQuery xs)    = show xs
 115     showList xs _ = unwords $ map show xs
 116
 117 -- | Represents a song's playlist index.
 118 data PLIndex = Pos Integer  -- ^ A playlist position index (starting from 0).
 119              | ID Integer   -- ^ A playlist ID number.
 120                deriving Show
 121
 122 -- | Represents the different playback states.
 123 data State = Playing
 124            | Stopped
 125            | Paused
 126              deriving (Show, Eq)
 127
 128 -- | Container for MPD status.
 129 data Status =
 130     Status { stState             :: State,
 131              -- | A percentage (0-100).
 132              stVolume            :: Int,
 133              stRepeat, stRandom  :: Bool,
 134              -- | This value gets incremented by the server every time the
 135              --   playlist changes.
 136              stPlaylistVersion   :: Integer,
 137              stPlaylistLength    :: Integer,
 138              -- | Current song's position in the playlist.
 139              stSongPos           :: Maybe PLIndex,
 140              -- | Each song in the playlist has an identifier to more
 141              --   robustly identify it.
 142              stSongID            :: Maybe PLIndex,
 143              -- | (Seconds played, song length in seconds).
 144              stTime              :: (Seconds,Seconds),
 145              -- | Bitrate of playing song in kilobytes per second.
 146              stBitrate           :: Int,
 147              -- | MPD can fade between tracks. This is the time it takes to
 148              --   do so.
 149              stXFadeWidth        :: Seconds,
 150              -- | (samplerate, bits, channels)
 151              stAudio             :: (Int,Int,Int),
 152              -- | Job id of currently running update (if any).
 153              stUpdatingDb        :: Integer,
 154              -- | Last error message (if any)
 155              stError             :: String }
 156     deriving Show
 157
 158 -- | Container for database statistics.
 159 data Stats =
 160     Stats { stsArtists    :: Integer -- ^ Number of artists.
 161           , stsAlbums     :: Integer -- ^ Number of albums.
 162           , stsSongs      :: Integer -- ^ Number of songs.
 163           , stsUptime     :: Seconds -- ^ Daemon uptime in seconds.
 164           , stsPlaytime   :: Seconds -- ^ Time length of music played.
 165           , stsDbPlaytime :: Seconds -- ^ Sum of all song times in db.
 166           , stsDbUpdate   :: Integer -- ^ Last db update in UNIX time.
 167           }
 168     deriving Show
 169
 170 -- | Description of a song.
 171 data Song = Song { sgArtist, sgAlbum, sgTitle, sgFilePath, sgGenre, sgName
 172                   ,sgComposer, sgPerformer :: String
 173                   ,sgLength :: Seconds    -- ^ length in seconds
 174                   ,sgDate   :: Int        -- ^ year
 175                   ,sgTrack  :: (Int, Int) -- ^ (track number, total tracks)
 176                   ,sgDisc   :: (Int, Int) -- ^ (pos. in set, total in set)
 177                   ,sgIndex  :: Maybe PLIndex }
 178             deriving Show
 179
 180 -- Temporarily avoid writing an overloaded version of 'elem' for use in
 181 -- 'prune'.
 182 instance Eq Song where
 183     (==) x y = sgFilePath x == sgFilePath y
 184
 185 -- | Describes a 'count'.
 186 data Count = Count { cSongs    :: Integer -- ^ Number of songs that matches
 187                                           -- a query
 188                    , cPlaytime :: Seconds -- ^ Total play time of matching
 189                                           -- songs
 190                    }
 191     deriving Show
 192
 193 -- | Represents an output device.
 194 data Device =
 195     Device { dOutputID      :: Int    -- ^ Output's id number
 196            , dOutputName    :: String -- ^ Output's name as defined in the MPD
 197                                       -- configuration file
 198            , dOutputEnabled :: Bool }
 199     deriving Show
 200
 201 --
 202 -- Basic connection functions
 203 --
 204
 205 -- | Open a connection to a MPD and perform some action on it in a safe
 206 -- manner.
 207 withMPD :: String -> Integer -> (Connection -> IO a) -> IO a
 208 withMPD host port = bracket (connect host port) close
 209
 210 -- | Create an MPD connection.
 211 connect :: String   -- ^ Hostname.
 212         -> Integer  -- ^ Port number.
 213         -> IO Connection
 214 connect host port = withSocketsDo $ do
 215     conn <- liftM Conn . connectTo host . PortNumber $ fromInteger port
 216     mpd <- checkConn conn
 217     if mpd then return conn
 218            else close conn >> fail ("no MPD at " ++ host ++ ":" ++ show port)
 219
 220 -- | Check that an MPD daemon is at the other end of a connection.
 221 checkConn :: Connection -> IO Bool
 222 checkConn (Conn h) = liftM (isPrefixOf "OK MPD") (hGetLine h)
 223
 224 --
 225 -- Admin commands
 226 --
 227
 228 -- | Turn off an output device.
 229 disableoutput :: Connection -> Int -> IO ()
 230 disableoutput conn = getResponse_ conn . ("disableoutput " ++) . show
 231
 232 -- | Turn on an output device.
 233 enableoutput :: Connection -> Int -> IO ()
 234 enableoutput conn = getResponse_ conn . ("enableoutput " ++) . show
 235
 236 -- | Kill the server. Obviously, the connection is then invalid.
 237 kill :: Connection -> IO ()
 238 kill (Conn h) = hPutStrLn h "kill" >> hClose h
 239
 240 -- | Retrieve information for all output devices.
 241 outputs :: Connection -> IO [Device]
 242 outputs conn = liftM (map takeDevInfo . splitGroups . kvise)
 243     (getResponse conn "outputs")
 244     where
 245         takeDevInfo xs = Device {
 246             dOutputID      = takeNum "outputid" xs,
 247             dOutputName    = takeString "outputname" xs,
 248             dOutputEnabled = takeBool "outputenabled" xs
 249             }
 250
 251 -- | Update the server's database.
 252 update :: Connection -> [String] -> IO ()
 253 update conn  [] = getResponse_ conn "update"
 254 update conn [x] = getResponse_ conn ("update " ++ x)
 255 update conn  xs = getResponses conn (map ("update " ++) xs) >> return ()
 256
 257 --
 258 -- Database commands
 259 --
 260
 261 -- | List all metadata of metadata (sic).
 262 list :: Connection -> Meta -- ^ Metadata to list
 263      -> Maybe Query -> IO [String]
 264 list conn mtype query = liftM takeValues (getResponse conn cmd)
 265     where cmd = "list " ++ show mtype ++ maybe "" ((" "++) . show) query
 266
 267 -- | Non-recursively list the contents of a database directory.
 268 lsinfo :: Connection -> Maybe String -- ^ Optionally specify a path.
 269        -> IO [Either String Song]
 270 lsinfo conn path = do
 271     (dirs,_,songs) <- liftM takeEntries
 272                       (getResponse conn ("lsinfo " ++ maybe "" show path))
 273     return (map Left dirs ++ map Right songs)
 274
 275 -- | List the songs (without metadata) in a database directory recursively.
 276 listAll :: Connection -> Maybe String -> IO [String]
 277 listAll conn path = liftM (map snd . filter ((== "file") . fst) . kvise)
 278                           (getResponse conn ("listall " ++ maybe "" show path))
 279
 280 -- | Recursive 'lsinfo'.
 281 listAllinfo :: Connection -> Maybe String -- ^ Optionally specify a path
 282             -> IO [Either String Song]
 283 listAllinfo conn path = do
 284     (dirs,_,songs) <- liftM takeEntries
 285                       (getResponse conn ("listallinfo " ++ maybe "" show path))
 286     return (map Left dirs ++ map Right songs)
 287
 288 -- | Search the database for entries exactly matching a query.
 289 find :: Connection -> Query -> IO [Song]
 290 find conn query = liftM takeSongs (getResponse conn ("find " ++ show query))
 291
 292 -- | Search the database using case insensitive matching.
 293 search :: Connection -> Query -> IO [Song]
 294 search conn query = liftM takeSongs (getResponse conn ("search " ++ show query))
 295
 296 -- | Count the number of entries matching a query.
 297 count :: Connection -> Query -> IO Count
 298 count conn query = liftM (takeCountInfo . kvise)
 299     (getResponse conn ("count " ++ show query))
 300     where takeCountInfo xs = Count { cSongs    = takeNum "songs" xs,
 301                                      cPlaytime = takeNum "playtime" xs }
 302
 303 --
 304 -- Playlist commands
 305 --
 306 -- $playlist
 307 -- Unless otherwise noted all playlist commands operate on the current
 308 -- playlist.
 309
 310 -- | Like 'add', but returns a playlist id.
 311 addid :: Connection -> String -> IO Integer
 312 addid conn x =
 313     liftM (read . snd . head . kvise) (getResponse conn ("addid " ++ show x))
 314
 315 -- | Like 'add_' but returns a list of the files added.
 316 add :: Connection -> Maybe String -> String -> IO [String]
 317 add conn plname x = add_ conn plname x >> listAll conn (Just x)
 318
 319 -- | Add a song (or a whole directory) to a playlist.
 320 -- Adds to current if no playlist is specified.
 321 -- Will create a new playlist if the one specified does not already exist.
 322 add_ :: Connection
 323      -> Maybe String -- ^ Optionally specify a playlist to operate on
 324      -> String
 325      -> IO ()
 326 add_ conn Nothing       = getResponse_ conn . ("add " ++) . show
 327 add_ conn (Just plname) = getResponse_ conn .
 328                           (("playlistadd " ++ show plname ++ " ") ++) . show
 329
 330 -- | Clear a playlist. Clears current playlist if no playlist is specified.
 331 -- If the specified playlist does not exist, it will be created.
 332 clear :: Connection
 333       -> Maybe String -- ^ Optional name of a playlist to clear.
 334       -> IO ()
 335 clear conn Nothing       = getResponse_ conn "clear"
 336 clear conn (Just plname) = getResponse_ conn ("playlistclear " ++ show plname)
 337
 338 -- | Remove a song from a playlist.
 339 -- If no playlist is specified, current playlist is used.
 340 -- Note that a playlist position ('Pos') is required when operating on
 341 -- playlists other than the current.
 342 delete :: Connection
 343        -> Maybe String -- ^ Optionally specify a playlist to operate on
 344        -> PLIndex -> IO ()
 345 delete conn Nothing (Pos x) = getResponse_ conn ("delete " ++ show x)
 346 delete conn Nothing (ID x) = getResponse_ conn ("deleteid " ++ show x)
 347 delete conn (Just plname) (Pos x) =
 348     getResponse_ conn ("playlistdelete " ++ show plname ++ " " ++ show x)
 349 delete _ _ _ = return ()
 350
 351 -- | Load an existing playlist.
 352 load :: Connection -> String -> IO ()
 353 load conn = getResponse_ conn . ("load " ++) . show
 354
 355 -- | Move a song to a given position.
 356 -- Note that a playlist position ('Pos') is required when operating on
 357 -- playlists other than the current.
 358 move :: Connection
 359      -> Maybe String -- ^ Optionally specify a playlist to operate on
 360      -> PLIndex -> Integer -> IO ()
 361 move conn Nothing (Pos from) to =
 362     getResponse_ conn ("move " ++ show from ++ " " ++ show to)
 363 move conn Nothing (ID from) to =
 364     getResponse_ conn ("moveid " ++ show from ++ " " ++ show to)
 365 move conn (Just plname) (Pos from) to =
 366     getResponse_ conn ("playlistmove " ++ show plname ++ " " ++ show from ++
 367                        " " ++ show to)
 368 move _ _ _ _ = return ()
 369
 370 -- | Delete existing playlist.
 371 rm :: Connection -> String -> IO ()
 372 rm conn = getResponse_ conn . ("rm " ++) . show
 373
 374 -- | Rename an existing playlist.
 375 rename :: Connection
 376        -> String -- ^ Name of playlist to be renamed
 377        -> String -- ^ New playlist name
 378        -> IO ()
 379 rename conn plname new =
 380     getResponse_ conn ("rename " ++ show plname ++ " " ++ show new)
 381
 382 -- | Save the current playlist.
 383 save :: Connection -> String -> IO ()
 384 save conn = getResponse_ conn . ("save " ++) . show
 385
 386 -- | Swap the positions of two songs.
 387 -- Note that the positions must be of the same type, i.e. mixing 'Pos' and 'ID'
 388 -- will result in a no-op.
 389 swap :: Connection -> PLIndex -> PLIndex -> IO ()
 390 swap conn (Pos x) (Pos y) =
 391     getResponse_ conn ("swap " ++ show x ++ " " ++ show y)
 392 swap conn (ID x) (ID y) =
 393     getResponse_ conn ("swapid " ++ show x ++ " " ++ show y)
 394 swap _ _ _ = return ()
 395
 396 -- | Shuffle the playlist.
 397 shuffle :: Connection -> IO ()
 398 shuffle = flip getResponse_ "shuffle"
 399
 400 -- | Retrieve metadata for songs in the current playlist.
 401 playlistinfo :: Connection
 402             -> Maybe PLIndex   -- ^ Optional playlist index.
 403             -> IO [Song]
 404 playlistinfo conn x = liftM takeSongs (getResponse conn cmd)
 405     where cmd = case x of
 406                     Just (Pos x') -> "playlistinfo " ++ show x'
 407                     Just (ID x')  -> "playlistid " ++ show x'
 408                     Nothing       -> "playlistinfo"
 409
 410 -- | Retrieve metadata for files in a given playlist.
 411 listplaylistinfo :: Connection -> String -> IO [Song]
 412 listplaylistinfo conn = liftM takeSongs . getResponse conn .
 413     ("listplaylistinfo " ++) . show
 414
 415 -- | Retrieve a list of files in a given playlist.
 416 listplaylist :: Connection -> String -> IO [String]
 417 listplaylist conn = liftM takeValues . getResponse conn .
 418     ("listplaylist " ++) . show
 419
 420 -- | Retrieve file paths and positions of songs in the current playlist.
 421 -- Note that this command is only included for completeness sake; it's
 422 -- deprecated and likely to disappear at any time.
 423 playlist :: Connection -> IO [(PLIndex, String)]
 424 playlist = liftM (map f) . flip getResponse "playlist"
 425     -- meh, the response here deviates from just about all other commands
 426     where f s = let (pos, name) = break (== ':') s
 427                 in (Pos $ read pos, drop 1 name)
 428
 429 -- | Retrieve a list of changed songs currently in the playlist since
 430 -- a given playlist version.
 431 plchanges :: Connection -> Integer -> IO [Song]
 432 plchanges conn = liftM takeSongs . getResponse conn . ("plchanges " ++) . show
 433
 434 -- | Like 'plchanges' but only returns positions and ids.
 435 plchangesposid :: Connection -> Integer -> IO [(PLIndex, PLIndex)]
 436 plchangesposid conn plver =
 437     liftM (map takePosid . splitGroups . kvise) (getResponse conn cmd)
 438     where cmd          = "plchangesposid " ++ show plver
 439           takePosid xs = (Pos $ takeNum "cpos" xs, ID $ takeNum "Id" xs)
 440
 441 -- | Search for songs in the current playlist with strict matching.
 442 playlistfind :: Connection -> Query -> IO [Song]
 443 playlistfind conn query = liftM takeSongs
 444     (getResponse conn ("playlistfind " ++ show query))
 445
 446 -- | Search case-insensitively with partial matches for songs in the
 447 -- current playlist.
 448 playlistsearch :: Connection -> Query -> IO [Song]
 449 playlistsearch conn query = liftM takeSongs
 450     (getResponse conn ("playlistsearch " ++ show query))
 451
 452 -- | Get the currently playing song.
 453 currentSong :: Connection -> IO (Maybe Song)
 454 currentSong conn = do
 455     currStatus <- status conn
 456     if stState currStatus == Stopped
 457         then return Nothing
 458         else do ls <- liftM kvise (getResponse conn "currentsong")
 459                 return $ if null ls then Nothing
 460                                     else Just (takeSongInfo ls)
 461
 462 --
 463 -- Playback commands
 464 --
 465
 466 -- | Set crossfading between songs.
 467 crossfade :: Connection -> Seconds -> IO ()
 468 crossfade conn = getResponse_ conn . ("crossfade " ++) . show
 469
 470 -- | Begin\/continue playing.
 471 play :: Connection -> Maybe PLIndex -> IO ()
 472 play conn Nothing        = getResponse_ conn "play"
 473 play conn (Just (Pos x)) = getResponse_ conn ("play " ++ show x)
 474 play conn (Just (ID x))  = getResponse_ conn ("playid " ++ show x)
 475
 476 -- | Pause playing.
 477 pause :: Connection -> Bool -> IO ()
 478 pause conn = getResponse_ conn . ("pause " ++) . showBool
 479
 480 -- | Stop playing.
 481 stop :: Connection -> IO ()
 482 stop = flip getResponse_ "stop"
 483
 484 -- | Play the next song.
 485 next :: Connection -> IO ()
 486 next = flip getResponse_ "next"
 487
 488 -- | Play the previous song.
 489 previous :: Connection -> IO ()
 490 previous = flip getResponse_ "previous"
 491
 492 -- | Seek to some point in a song.
 493 -- Seeks in current song if no position is given.
 494 seek :: Connection -> Maybe PLIndex -> Seconds -> IO ()
 495 seek conn (Just (Pos x)) time =
 496     getResponse_ conn ("seek " ++ show x ++ " " ++ show time)
 497 seek conn (Just (ID x)) time =
 498     getResponse_ conn ("seekid " ++ show x ++ " " ++ show time)
 499 seek conn Nothing time = do
 500     st <- status conn
 501     unless (stState st == Stopped) (seek conn (stSongID st) time)
 502
 503 -- | Set random playing.
 504 random :: Connection -> Bool -> IO ()
 505 random conn = getResponse_ conn . ("random " ++) . showBool
 506
 507 -- | Set repeating.
 508 repeat :: Connection -> Bool -> IO ()
 509 repeat conn = getResponse_ conn . ("repeat " ++) . showBool
 510
 511 -- | Set the volume.
 512 setVolume :: Connection -> Int -> IO ()
 513 setVolume conn = getResponse_ conn . ("setvol " ++) . show
 514
 515 -- | Increase or decrease volume by a given percent, e.g.
 516 -- 'volume 10' will increase the volume by 10 percent, while
 517 -- 'volume (-10)' will decrease it by the same amount.
 518 -- Note that this command is only included for completeness sake ; it's
 519 -- deprecated and may disappear at any time.
 520 volume :: Connection -> Int -> IO ()
 521 volume conn = getResponse_ conn . ("volume " ++) . show
 522
 523 --
 524 -- Miscellaneous commands
 525 --
 526
 527 -- | Clear the current error message in status.
 528 clearerror :: Connection -> IO ()
 529 clearerror (Conn h) = hPutStrLn h "clearerror" >> hClose h
 530
 531 -- | Close a MPD connection.
 532 close :: Connection -> IO ()
 533 close (Conn h) = hPutStrLn h "close" >> hClose h
 534
 535 -- | Retrieve a list of available commands.
 536 commands :: Connection -> IO [String]
 537 commands = liftM takeValues . flip getResponse "commands"
 538
 539 -- | Retrieve a list of unavailable commands.
 540 notcommands :: Connection -> IO [String]
 541 notcommands = liftM takeValues . flip getResponse "notcommands"
 542
 543 -- | Retrieve a list of available song metadata.
 544 tagtypes :: Connection -> IO [String]
 545 tagtypes = liftM takeValues . flip getResponse "tagtypes"
 546
 547 -- | Retrieve a list of supported urlhandlers.
 548 urlhandlers :: Connection -> IO [String]
 549 urlhandlers = liftM takeValues . flip getResponse "urlhandlers"
 550
 551 -- XXX should the password be quoted?
 552 -- | Send password to server to authenticate session.
 553 -- Password is sent as plain text.
 554 password :: Connection -> String -> IO ()
 555 password conn = getResponse_ conn . ("password " ++)
 556
 557 -- | Check that the server is still responding.
 558 ping :: Connection -> IO ()
 559 ping = flip getResponse_ "ping"
 560
 561 -- | Get server statistics.
 562 stats :: Connection -> IO Stats
 563 stats = liftM (parseStats . kvise) . flip getResponse "stats"
 564     where parseStats xs =
 565                 Stats { stsArtists = takeNum "artists" xs,
 566                         stsAlbums = takeNum "albums" xs,
 567                         stsSongs = takeNum "songs" xs,
 568                         stsUptime = takeNum "uptime" xs,
 569                         stsPlaytime = takeNum "playtime" xs,
 570                         stsDbPlaytime = takeNum "db_playtime" xs,
 571                         stsDbUpdate = takeNum "db_update" xs }
 572
 573 -- | Get the server's status.
 574 status :: Connection -> IO Status
 575 status = liftM (parseStatus . kvise) . flip getResponse "status"
 576     where parseStatus xs =
 577               Status { stState = maybe Stopped parseState $ lookup "state" xs,
 578                      stVolume = takeNum "volume" xs,
 579                      stRepeat = takeBool "repeat" xs,
 580                      stRandom = takeBool "random" xs,
 581                      stPlaylistVersion = takeNum "playlist" xs,
 582                      stPlaylistLength = takeNum "playlistlength" xs,
 583                      stXFadeWidth = takeNum "xfade" xs,
 584                      stSongPos = takeIndex Pos "song" xs,
 585                      stSongID = takeIndex ID "songid" xs,
 586                      stTime = maybe (0,0) parseTime $ lookup "time" xs,
 587                      stBitrate = takeNum "bitrate" xs,
 588                      stAudio = maybe (0,0,0) parseAudio $ lookup "audio" xs,
 589                      stUpdatingDb = takeNum "updating_db" xs,
 590                      stError = takeString "error" xs
 591                    }
 592           parseState x = case x of "play"  -> Playing
 593                                    "pause" -> Paused
 594                                    _       -> Stopped
 595           parseTime  x = let (y,_:z) = break (== ':') x in (read y, read z)
 596           parseAudio x =
 597               let (u,_:u') = break (== ':') x; (v,_:w) = break (== ':') u' in
 598                   (read u, read v, read w)
 599
 600 --
 601 -- Extensions\/shortcuts.
 602 --
 603
 604 -- | Toggles play\/pause. Plays if stopped.
 605 toggle :: Connection -> IO ()
 606 toggle conn = do
 607     st <- status conn
 608     case stState st of
 609          Playing -> pause conn True
 610          _       -> play conn Nothing
 611
 612 -- | Add a list of songs\/folders to a playlist.
 613 -- Should be more efficient than running 'add' many times.
 614 addMany :: Connection -> Maybe String -> [String] -> IO ()
 615 addMany _ _ [] = return ()
 616 addMany conn plname [x] = add_ conn plname x
 617 addMany conn plname xs = getResponses conn (map (cmd ++) xs) >> return ()
 618     where cmd = maybe ("add ") (\pl -> "playlistadd " ++ show pl ++ " ") plname
 619
 620 -- | Delete a list of songs from a playlist.
 621 -- If there is a duplicate then no further songs will be deleted, so
 622 -- take care to avoid them.
 623 deleteMany :: Connection -> Maybe String -> [PLIndex] -> IO ()
 624 deleteMany _ _ [] = return ()
 625 deleteMany conn plname [x] = delete conn plname x
 626 deleteMany conn (Just plname) xs = getResponses conn (map cmd xs) >> return ()
 627     where cmd (Pos x) = "playlistdelete " ++ show plname ++ " " ++ show x
 628           cmd _       = ""
 629 deleteMany conn Nothing xs = getResponses conn (map cmd xs) >> return ()
 630     where cmd (Pos x) = "delete " ++ show x
 631           cmd (ID x)  = "deleteid " ++ show x
 632
 633 -- | Crop playlist.
 634 -- The bounds are inclusive.
 635 -- If 'Nothing' or 'ID' is passed the cropping will leave your playlist alone
 636 -- on that side.
 637 crop :: Connection -> Maybe PLIndex -> Maybe PLIndex -> IO ()
 638 crop conn x y = do
 639     pl <- playlistinfo conn Nothing
 640     let x' = case x of Just (Pos p) -> fromInteger p
 641                        Just (ID i)  -> maybe 0 id (findByID i pl)
 642                        Nothing      -> 0
 643         -- ensure that no songs are deleted twice with 'max'.
 644         ys = case y of Just (Pos p) -> drop (max (fromInteger p) x') pl
 645                        Just (ID i)  -> maybe [] (flip drop pl . max x' . (+1))
 646                                       (findByID i pl)
 647                        Nothing      -> []
 648     deleteMany conn Nothing (mapMaybe sgIndex (take x' pl ++ ys))
 649     where findByID i = findIndex ((==) i . (\(ID j) -> j) . fromJust . sgIndex)
 650
 651 -- | Remove duplicate playlist entries.
 652 prune :: Connection -> IO ()
 653 prune conn = findDuplicates conn >>= deleteMany conn Nothing
 654
 655 -- Find duplicate playlist entries.
 656 findDuplicates :: Connection -> IO [PLIndex]
 657 findDuplicates =
 658     liftM (map ((\(ID x) -> ID x) . fromJust . sgIndex) . flip dups ([],[])) .
 659         flip playlistinfo Nothing
 660     where dups [] (_, dup) = dup
 661           dups (x:xs) (ys, dup)
 662             | x `elem` xs && x `notElem` ys = dups xs (ys, x:dup)
 663             | otherwise                     = dups xs (x:ys, dup)
 664
 665 -- | List directories non-recursively.
 666 lsdirs :: Connection
 667        -> Maybe String -- ^ optional path.
 668        -> IO [String]
 669 lsdirs conn path = liftM ((\(x,_,_) -> x) . takeEntries)
 670                          (getResponse conn ("lsinfo " ++ maybe "" show path))
 671
 672 -- | List files non-recursively.
 673 lsfiles :: Connection
 674         -> Maybe String -- ^ optional path.
 675         -> IO [String]
 676 lsfiles conn path = liftM (map sgFilePath . (\(_,_,x) -> x) . takeEntries)
 677                           (getResponse conn ("lsinfo " ++ maybe "" show path))
 678
 679 -- | List all playlists.
 680 lsplaylists :: Connection -> IO [String]
 681 lsplaylists = liftM ((\(_,x,_) -> x) . takeEntries) . flip getResponse "lsinfo"
 682
 683 -- | Search the database for songs relating to an artist.
 684 findArtist :: Connection -> Artist -> IO [Song]
 685 findArtist c = find c . Query Artist
 686
 687 -- | Search the database for songs relating to an album.
 688 findAlbum :: Connection -> Album -> IO [Song]
 689 findAlbum c = find c . Query Album
 690
 691 -- | Search the database for songs relating to a song title.
 692 findTitle :: Connection -> Title -> IO [Song]
 693 findTitle c = find c . Query Title
 694
 695 -- | List the artists in the database.
 696 listArtists :: Connection -> IO [Artist]
 697 listArtists = liftM takeValues . flip getResponse "list artist"
 698
 699 -- | List the albums in the database, optionally matching a given
 700 -- artist.
 701 listAlbums :: Connection -> Maybe Artist -> IO [Album]
 702 listAlbums conn artist = liftM takeValues (getResponse conn ("list album" ++
 703     maybe "" ((" artist " ++) . show) artist))
 704
 705 -- | List the songs in an album of some artist.
 706 listAlbum :: Connection -> Artist -> Album -> IO [Song]
 707 listAlbum conn artist album = find conn (MultiQuery [Query Artist artist
 708                                                     ,Query Album album])
 709
 710 -- | Search the database for songs relating to an artist using 'search'.
 711 searchArtist :: Connection -> Artist -> IO [Song]
 712 searchArtist c = search c . Query Artist
 713
 714 -- | Search the database for songs relating to an album using 'search'.
 715 searchAlbum :: Connection -> Album -> IO [Song]
 716 searchAlbum c = search c . Query Album
 717
 718 -- | Search the database for songs relating to a song title.
 719 searchTitle :: Connection -> Title -> IO [Song]
 720 searchTitle c = search c . Query Title
 721
 722 -- | Retrieve the current playlist.
 723 -- Equivalent to 'playlistinfo Nothing'.
 724 getPlaylist :: Connection -> IO [Song]
 725 getPlaylist = flip playlistinfo Nothing
 726
 727 --
 728 -- Miscellaneous functions.
 729 --
 730
 731 -- | Run getResponse but discard the response.
 732 getResponse_ :: Connection -> String -> IO ()
 733 getResponse_ c x = getResponse c x >> return ()
 734
 735 -- | Get the lines of the daemon's response to a given command.
 736 getResponse :: Connection -> String -> IO [String]
 737 getResponse (Conn h) cmd = hPutStrLn h cmd >> hFlush h >> f []
 738     where f acc = do
 739               l <- hGetLine h
 740               case l of
 741                   "OK"              -> return (reverse acc)
 742                   ('A':'C':'K':_:e) -> fail e
 743                   _                 -> f (l:acc)
 744
 745 -- | Get the lines of the daemon's response to a list of commands.
 746 getResponses :: Connection -> [String] -> IO [String]
 747 getResponses conn cmds = getResponse conn .
 748     unlines $ "command_list_begin" : cmds ++ ["command_list_end"]
 749
 750 -- | Break up a list of strings into an assoc list, separating at
 751 -- the first ':'.
 752 kvise :: [String] -> [(String, String)]
 753 kvise = map f
 754     where f x = let (k,v) = break (== ':') x in
 755                 (k,dropWhile (== ' ') $ drop 1 v)
 756
 757 -- | Takes a assoc list with recurring keys, and groups each cycle of
 758 --   keys with their values together. The first key of each cycle needs
 759 --   to be present in every cycle for it to work, but the rest don't
 760 --   affect anything.
 761 --
 762 -- > splitGroups [(1,'a'),(2,'b'),(1,'c'),(2,'d')] ==
 763 -- >     [[(1,'a'),(2,'b')],[(1,'c'),(2,'d')]]
 764 splitGroups :: Eq a => [(a, b)] -> [[(a, b)]]
 765 splitGroups [] = []
 766 splitGroups (x:xs) = ((x:us):splitGroups vs)
 767     where (us,vs) = break (\y -> fst x == fst y) xs
 768
 769 -- | Run 'kvise' and return only the values.
 770 takeValues :: [String] -> [String]
 771 takeValues = snd . unzip . kvise
 772
 773 -- | Separate the result of an lsinfo\/listallinfo call into directories,
 774 -- playlists, and songs.
 775 takeEntries :: [String] -> ([String], [String], [Song])
 776 takeEntries s =
 777     (dirs, playlists, map takeSongInfo $ splitGroups (reverse filedata))
 778     where (dirs, playlists, filedata) = foldl split ([], [], []) $ kvise s
 779           split (ds, pls, ss) x@(k, v) | k == "directory" = (v:ds, pls, ss)
 780                                        | k == "playlist"  = (ds, v:pls, ss)
 781                                        | otherwise        = (ds, pls, x:ss)
 782
 783 -- | Build a list of song instances from a response.
 784 -- Returns an empty list if input is empty.
 785 takeSongs :: [String] -> [Song]
 786 takeSongs = map takeSongInfo . splitGroups . kvise
 787
 788 -- |  Builds a song instance from an assoc list.
 789 takeSongInfo :: [(String,String)] -> Song
 790 takeSongInfo xs =
 791     Song {
 792           sgArtist    = takeString "Artist" xs,
 793           sgAlbum     = takeString "Album" xs,
 794           sgTitle     = takeString "Title" xs,
 795           sgGenre     = takeString "Genre" xs,
 796           sgName      = takeString "Name" xs,
 797           sgComposer  = takeString "Composer" xs,
 798           sgPerformer = takeString "Performer" xs,
 799           sgDate      = takeNum "Date" xs,
 800           sgTrack     = maybe (0, 0) parseTrack $ lookup "Track" xs,
 801           sgDisc      = maybe (0, 0) parseTrack $ lookup "Disc" xs,
 802           sgFilePath  = takeString "file" xs,
 803           sgLength    = takeNum "Time" xs,
 804           sgIndex     = takeIndex ID "Id" xs
 805          }
 806     where parseTrack x = let (trck, tot) = break (== '/') x
 807                          in (read trck, parseNum (drop 1 tot))
 808
 809
 810 -- Helpers for retrieving values from an assoc. list.
 811 takeString :: String -> [(String, String)] -> String
 812 takeString v = fromMaybe "" . lookup v
 813
 814 takeIndex :: (Integer -> PLIndex) -> String -> [(String, String)]
 815           -> Maybe PLIndex
 816 takeIndex c v = maybe Nothing (Just . c . parseNum) . lookup v
 817
 818 takeNum :: (Read a, Num a) => String -> [(String, String)] -> a
 819 takeNum v = maybe 0 parseNum . lookup v
 820
 821 takeBool :: String -> [(String, String)] -> Bool
 822 takeBool v = maybe False parseBool . lookup v
 823
 824 -- Parse a numeric value, returning 0 on failure.
 825 parseNum :: (Read a, Num a) => String -> a
 826 parseNum = fromMaybe 0 . maybeReads
 827     where maybeReads s = do ; [(x, "")] <- return (reads s) ; return x
 828
 829 -- Inverts 'parseBool'.
 830 showBool :: Bool -> String
 831 showBool x = if x then "1" else "0"
 832
 833 -- Parse a boolean response value.
 834 parseBool :: String -> Bool
 835 parseBool = (== "1") . take 1