diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,510 +1,20 @@ - - GNU LESSER GENERAL PUBLIC LICENSE - Version 2.1, February 1999 - - Copyright (C) 1991, 1999 Free Software Foundation, Inc. - 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - -[This is the first released version of the Lesser GPL. It also counts - as the successor of the GNU Library Public License, version 2, hence - the version number 2.1.] - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -Licenses are intended to guarantee your freedom to share and change -free software--to make sure the software is free for all its users. - - This license, the Lesser General Public License, applies to some -specially designated software packages--typically libraries--of the -Free Software Foundation and other authors who decide to use it. You -can use it too, but we suggest you first think carefully about whether -this license or the ordinary General Public License is the better -strategy to use in any particular case, based on the explanations -below. - - When we speak of free software, we are referring to freedom of use, -not price. Our General Public Licenses are designed to make sure that -you have the freedom to distribute copies of free software (and charge -for this service if you wish); that you receive source code or can get -it if you want it; that you can change the software and use pieces of -it in new free programs; and that you are informed that you can do -these things. - - To protect your rights, we need to make restrictions that forbid -distributors to deny you these rights or to ask you to surrender these -rights. These restrictions translate to certain responsibilities for -you if you distribute copies of the library or if you modify it. - - For example, if you distribute copies of the library, whether gratis -or for a fee, you must give the recipients all the rights that we gave -you. You must make sure that they, too, receive or can get the source -code. If you link other code with the library, you must provide -complete object files to the recipients, so that they can relink them -with the library after making changes to the library and recompiling -it. And you must show them these terms so they know their rights. - - We protect your rights with a two-step method: (1) we copyright the -library, and (2) we offer you this license, which gives you legal -permission to copy, distribute and/or modify the library. - - To protect each distributor, we want to make it very clear that -there is no warranty for the free library. Also, if the library is -modified by someone else and passed on, the recipients should know -that what they have is not the original version, so that the original -author's reputation will not be affected by problems that might be -introduced by others. - - Finally, software patents pose a constant threat to the existence of -any free program. We wish to make sure that a company cannot -effectively restrict the users of a free program by obtaining a -restrictive license from a patent holder. Therefore, we insist that -any patent license obtained for a version of the library must be -consistent with the full freedom of use specified in this license. - - Most GNU software, including some libraries, is covered by the -ordinary GNU General Public License. This license, the GNU Lesser -General Public License, applies to certain designated libraries, and -is quite different from the ordinary General Public License. We use -this license for certain libraries in order to permit linking those -libraries into non-free programs. - - When a program is linked with a library, whether statically or using -a shared library, the combination of the two is legally speaking a -combined work, a derivative of the original library. The ordinary -General Public License therefore permits such linking only if the -entire combination fits its criteria of freedom. The Lesser General -Public License permits more lax criteria for linking other code with -the library. - - We call this license the "Lesser" General Public License because it -does Less to protect the user's freedom than the ordinary General -Public License. It also provides other free software developers Less -of an advantage over competing non-free programs. These disadvantages -are the reason we use the ordinary General Public License for many -libraries. However, the Lesser license provides advantages in certain -special circumstances. - - For example, on rare occasions, there may be a special need to -encourage the widest possible use of a certain library, so that it -becomes a de-facto standard. To achieve this, non-free programs must -be allowed to use the library. A more frequent case is that a free -library does the same job as widely used non-free libraries. In this -case, there is little to gain by limiting the free library to free -software only, so we use the Lesser General Public License. - - In other cases, permission to use a particular library in non-free -programs enables a greater number of people to use a large body of -free software. For example, permission to use the GNU C Library in -non-free programs enables many more people to use the whole GNU -operating system, as well as its variant, the GNU/Linux operating -system. - - Although the Lesser General Public License is Less protective of the -users' freedom, it does ensure that the user of a program that is -linked with the Library has the freedom and the wherewithal to run -that program using a modified version of the Library. - - The precise terms and conditions for copying, distribution and -modification follow. Pay close attention to the difference between a -"work based on the library" and a "work that uses the library". The -former contains code derived from the library, whereas the latter must -be combined with the library in order to run. - - GNU LESSER GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License Agreement applies to any software library or other -program which contains a notice placed by the copyright holder or -other authorized party saying it may be distributed under the terms of -this Lesser General Public License (also called "this License"). -Each licensee is addressed as "you". - - A "library" means a collection of software functions and/or data -prepared so as to be conveniently linked with application programs -(which use some of those functions and data) to form executables. - - The "Library", below, refers to any such software library or work -which has been distributed under these terms. A "work based on the -Library" means either the Library or any derivative work under -copyright law: that is to say, a work containing the Library or a -portion of it, either verbatim or with modifications and/or translated -straightforwardly into another language. (Hereinafter, translation is -included without limitation in the term "modification".) - - "Source code" for a work means the preferred form of the work for -making modifications to it. For a library, complete source code means -all the source code for all modules it contains, plus any associated -interface definition files, plus the scripts used to control -compilation and installation of the library. - - Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running a program using the Library is not restricted, and output from -such a program is covered only if its contents constitute a work based -on the Library (independent of the use of the Library in a tool for -writing it). Whether that is true depends on what the Library does -and what the program that uses the Library does. - - 1. You may copy and distribute verbatim copies of the Library's -complete source code as you receive it, in any medium, provided that -you conspicuously and appropriately publish on each copy an -appropriate copyright notice and disclaimer of warranty; keep intact -all the notices that refer to this License and to the absence of any -warranty; and distribute a copy of this License along with the -Library. - - You may charge a fee for the physical act of transferring a copy, -and you may at your option offer warranty protection in exchange for a -fee. - - 2. You may modify your copy or copies of the Library or any portion -of it, thus forming a work based on the Library, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) The modified work must itself be a software library. - - b) You must cause the files modified to carry prominent notices - stating that you changed the files and the date of any change. - - c) You must cause the whole of the work to be licensed at no - charge to all third parties under the terms of this License. - - d) If a facility in the modified Library refers to a function or a - table of data to be supplied by an application program that uses - the facility, other than as an argument passed when the facility - is invoked, then you must make a good faith effort to ensure that, - in the event an application does not supply such function or - table, the facility still operates, and performs whatever part of - its purpose remains meaningful. - - (For example, a function in a library to compute square roots has - a purpose that is entirely well-defined independent of the - application. Therefore, Subsection 2d requires that any - application-supplied function or table used by this function must - be optional: if the application does not supply it, the square - root function must still compute square roots.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Library, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Library, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote -it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Library. - -In addition, mere aggregation of another work not based on the Library -with the Library (or with a work based on the Library) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may opt to apply the terms of the ordinary GNU General Public -License instead of this License to a given copy of the Library. To do -this, you must alter all the notices that refer to this License, so -that they refer to the ordinary GNU General Public License, version 2, -instead of to this License. (If a newer version than version 2 of the -ordinary GNU General Public License has appeared, then you can specify -that version instead if you wish.) Do not make any other change in -these notices. - - Once this change is made in a given copy, it is irreversible for -that copy, so the ordinary GNU General Public License applies to all -subsequent copies and derivative works made from that copy. - - This option is useful when you wish to copy part of the code of -the Library into a program that is not a library. - - 4. You may copy and distribute the Library (or a portion or -derivative of it, under Section 2) in object code or executable form -under the terms of Sections 1 and 2 above provided that you accompany -it with the complete corresponding machine-readable source code, which -must be distributed under the terms of Sections 1 and 2 above on a -medium customarily used for software interchange. - - If distribution of object code is made by offering access to copy -from a designated place, then offering equivalent access to copy the -source code from the same place satisfies the requirement to -distribute the source code, even though third parties are not -compelled to copy the source along with the object code. - - 5. A program that contains no derivative of any portion of the -Library, but is designed to work with the Library by being compiled or -linked with it, is called a "work that uses the Library". Such a -work, in isolation, is not a derivative work of the Library, and -therefore falls outside the scope of this License. - - However, linking a "work that uses the Library" with the Library -creates an executable that is a derivative of the Library (because it -contains portions of the Library), rather than a "work that uses the -library". The executable is therefore covered by this License. -Section 6 states terms for distribution of such executables. - - When a "work that uses the Library" uses material from a header file -that is part of the Library, the object code for the work may be a -derivative work of the Library even though the source code is not. -Whether this is true is especially significant if the work can be -linked without the Library, or if the work is itself a library. The -threshold for this to be true is not precisely defined by law. - - If such an object file uses only numerical parameters, data -structure layouts and accessors, and small macros and small inline -functions (ten lines or less in length), then the use of the object -file is unrestricted, regardless of whether it is legally a derivative -work. (Executables containing this object code plus portions of the -Library will still fall under Section 6.) - - Otherwise, if the work is a derivative of the Library, you may -distribute the object code for the work under the terms of Section 6. -Any executables containing that work also fall under Section 6, -whether or not they are linked directly with the Library itself. - - 6. As an exception to the Sections above, you may also combine or -link a "work that uses the Library" with the Library to produce a -work containing portions of the Library, and distribute that work -under terms of your choice, provided that the terms permit -modification of the work for the customer's own use and reverse -engineering for debugging such modifications. - - You must give prominent notice with each copy of the work that the -Library is used in it and that the Library and its use are covered by -this License. You must supply a copy of this License. If the work -during execution displays copyright notices, you must include the -copyright notice for the Library among them, as well as a reference -directing the user to the copy of this License. Also, you must do one -of these things: - - a) Accompany the work with the complete corresponding - machine-readable source code for the Library including whatever - changes were used in the work (which must be distributed under - Sections 1 and 2 above); and, if the work is an executable linked - with the Library, with the complete machine-readable "work that - uses the Library", as object code and/or source code, so that the - user can modify the Library and then relink to produce a modified - executable containing the modified Library. (It is understood - that the user who changes the contents of definitions files in the - Library will not necessarily be able to recompile the application - to use the modified definitions.) - - b) Use a suitable shared library mechanism for linking with the - Library. A suitable mechanism is one that (1) uses at run time a - copy of the library already present on the user's computer system, - rather than copying library functions into the executable, and (2) - will operate properly with a modified version of the library, if - the user installs one, as long as the modified version is - interface-compatible with the version that the work was made with. - - c) Accompany the work with a written offer, valid for at least - three years, to give the same user the materials specified in - Subsection 6a, above, for a charge no more than the cost of - performing this distribution. - - d) If distribution of the work is made by offering access to copy - from a designated place, offer equivalent access to copy the above - specified materials from the same place. - - e) Verify that the user has already received a copy of these - materials or that you have already sent this user a copy. - - For an executable, the required form of the "work that uses the -Library" must include any data and utility programs needed for -reproducing the executable from it. However, as a special exception, -the materials to be distributed need not include anything that is -normally distributed (in either source or binary form) with the major -components (compiler, kernel, and so on) of the operating system on -which the executable runs, unless that component itself accompanies -the executable. - - It may happen that this requirement contradicts the license -restrictions of other proprietary libraries that do not normally -accompany the operating system. Such a contradiction means you cannot -use both them and the Library together in an executable that you -distribute. - - 7. You may place library facilities that are a work based on the -Library side-by-side in a single library together with other library -facilities not covered by this License, and distribute such a combined -library, provided that the separate distribution of the work based on -the Library and of the other library facilities is otherwise -permitted, and provided that you do these two things: - - a) Accompany the combined library with a copy of the same work - based on the Library, uncombined with any other library - facilities. This must be distributed under the terms of the - Sections above. - - b) Give prominent notice with the combined library of the fact - that part of it is a work based on the Library, and explaining - where to find the accompanying uncombined form of the same work. - - 8. You may not copy, modify, sublicense, link with, or distribute -the Library except as expressly provided under this License. Any -attempt otherwise to copy, modify, sublicense, link with, or -distribute the Library is void, and will automatically terminate your -rights under this License. However, parties who have received copies, -or rights, from you under this License will not have their licenses -terminated so long as such parties remain in full compliance. - - 9. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Library or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Library (or any work based on the -Library), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Library or works based on it. - - 10. Each time you redistribute the Library (or any work based on the -Library), the recipient automatically receives a license from the -original licensor to copy, distribute, link with or modify the Library -subject to these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties with -this License. - - 11. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Library at all. For example, if a patent -license would not permit royalty-free redistribution of the Library by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Library. - -If any portion of this section is held invalid or unenforceable under -any particular circumstance, the balance of the section is intended to -apply, and the section as a whole is intended to apply in other -circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 12. If the distribution and/or use of the Library is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Library under this License -may add an explicit geographical distribution limitation excluding those -countries, so that distribution is permitted only in or among -countries not thus excluded. In such case, this License incorporates -the limitation as if written in the body of this License. - - 13. The Free Software Foundation may publish revised and/or new -versions of the Lesser General Public License from time to time. -Such new versions will be similar in spirit to the present version, -but may differ in detail to address new problems or concerns. - -Each version is given a distinguishing version number. If the Library -specifies a version number of this License which applies to it and -"any later version", you have the option of following the terms and -conditions either of that version or of any later version published by -the Free Software Foundation. If the Library does not specify a -license version number, you may choose any version ever published by -the Free Software Foundation. - - 14. If you wish to incorporate parts of the Library into other free -programs whose distribution conditions are incompatible with these, -write to the author to ask for permission. For software which is -copyrighted by the Free Software Foundation, write to the Free -Software Foundation; we sometimes make exceptions for this. Our -decision will be guided by the two goals of preserving the free status -of all derivatives of our free software and of promoting the sharing -and reuse of software generally. - - NO WARRANTY - - 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO -WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. -EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR -OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY -KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE -LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME -THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN -WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY -AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU -FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR -CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE -LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING -RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A -FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF -SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH -DAMAGES. - - END OF TERMS AND CONDITIONS - - How to Apply These Terms to Your New Libraries - - If you develop a new library, and you want it to be of the greatest -possible use to the public, we recommend making it free software that -everyone can redistribute and change. You can do so by permitting -redistribution under these terms (or, alternatively, under the terms -of the ordinary General Public License). - - To apply these terms, attach the following notices to the library. -It is safest to attach them to the start of each source file to most -effectively convey the exclusion of warranty; and each file should -have at least the "copyright" line and a pointer to where the full -notice is found. - - - - Copyright (C) - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Lesser General Public - License as published by the Free Software Foundation; either - version 2.1 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Lesser General Public License for more details. - - You should have received a copy of the GNU Lesser General Public - License along with this library; if not, write to the Free Software - Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA - -Also add information on how to contact you by electronic and paper mail. - -You should also get your employer (if you work as a programmer) or -your school, if any, to sign a "copyright disclaimer" for the library, -if necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the - library `Frob' (a library for tweaking knobs) written by James - Random Hacker. - - , 1 April 1990 - Ty Coon, President of Vice +Copyright (c) 2012,2014 Joachim Fasting -That's all there is to it! +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/NEWS b/NEWS deleted file mode 100644 --- a/NEWS +++ /dev/null @@ -1,99 +0,0 @@ -* v0.8.0, 2012-04-21 - - Use bytestring for wire communication (sol) - - Increased type safety (sol) - - Improved memory usage (sol) - - `lsinfo` supports playlists (nandykins) - - `idle` now takes a list of subsystems (sol) - - `currentSong` works when playback is stopped (sol) - - Fixes failure on songs without associated paths (sol) - - `LsResult` replaces `EntryType` (nandykins) - - hspec based testing added to the test-suite - - More extensive parser testing - - 'MPDError' now has an 'Exception' instance - - Lower bound on Cabal bumped to 1.10 - -* v0.7.2, 2012-02-13 - - Release connections. Reported by Kanisterschleife on GitHub. - - Some minor internal changes (sol) - -* v0.7.1, 2012-02-07 - - Compatible with GHC 7.4.1 - -* v0.7.0, 2011-11-22 - - Several fixes to the test harness (Simon Hengel) - - Fixed issue with the (<$>) operator (Simon Hengel) - - Type safe handling of song IDs (Simon Hengel) - - Check MPD version on connect (now depends on MPD >= 0.15) (Simon Hengel) - - Compatibility with GHC 7.2 (Daniel Wagner) - -* v0.6.0, 2011-04-01 - - Reverted some changes from 0.5.0 that caused problems, - most notably the parser improvements have been removed for now. - - Support for GHC 7 - - Removed support for building against the deprecated base 3 package - - Added an `Enum' instance for `Metadata' - - Removed the `old_base' flag - -* v0.5.0, 2010-09-08 - - Moved extensions to Network.MPD.Commands.Extensions - These might be removed in a later version - - Non-blocking `idle' - - The API is closer to the MPD spec, by untangling functionality - - Better MPD API coverage - - Improved parser implementation, now runs in constant space - - Constructors of the `Subsystem' type have been renamed - - Passwords can be changed using `setPassword' - - The connection handle can be accessed via `getHandle' - - The version of the MPD server is available via `getVersion' - - Added support for connecting via unix sockets - -* v0.4.2, 2010-08-31 - - Only depend on QuickCheck when building the test target - -* v0.4.1, 2010-03-26 - - Fix building test and coverage targets - -* v0.4.0, 2010-03-26 - - New maintainer: Joachim Fasting - - Support QuickCheck 2 - - Better MPD api support - Should be mostly compatible with mpd 0.16 - - Separated operations on current playlist from those on specific - playlists - - Fixed password sending - - Several minor fixes and cleanups - -* v0.3.1, 2008-09-14 - - Now reconnects if MPD closes the connection. - -* v0.3.0, 2008-05-06 - - UTF-8 support (now depends on utf8-string package). - - Fixed corruption by `show' of command parameters. - - Tidied up `Query' interface. - - Moved StringConn out of Network.MPD to the tests directory. - -* v0.2.1, 2008-04-14 - - Cleaned up libmpd.cabal. - -* v0.2.0, 2008-04-14 - - A connection stub for testing purposes. - - QuickCheck tests for parsing. - - Partial unit test coverage. - - Many bug fixes. - - Precise error handling. - - Parsing improvements. - - Code coverage generation. - - Cabal 1.2 support. - - Uniform command names. - -* v0.1.3, 2007-10-02 - - Bugfixes. - -* v0.1.2, 2007-09-29 - - Changed name to libmpd. - -* v0.1.1, 2007-09-28 - - Missing files added to the source distribution. - -* v0.1, 2007-09-28 - - Initial public release. diff --git a/Network/MPD.hs b/Network/MPD.hs deleted file mode 100644 --- a/Network/MPD.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE CPP #-} --- | Module : Network.MPD --- Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 --- License : LGPL (see LICENSE) --- Maintainer : Joachim Fasting --- Stability : alpha --- --- An MPD client library. MPD is a daemon for playing music that is --- controlled over a network socket. Its site is at . --- --- To use the library, do: --- --- > {-# LANGUAGE OverloadedStrings #-} --- > import qualified Network.MPD as MPD - -module Network.MPD ( - -- * Basic data types - MonadMPD, MPD, MPDError(..), ACKType(..), Response, - Host, Port, Password, - -- * Connections - withMPD, withMPD_, withMPDEx, - module Network.MPD.Commands, -#ifdef TEST - getConnectionSettings, getEnvDefault -#endif - ) where - -import Prelude -import qualified Control.Exception as E -import Network.MPD.Commands -import Network.MPD.Core - -import System.Environment (getEnv) -import System.IO.Error (isDoesNotExistError) -import Data.Maybe (listToMaybe) - --- | A wrapper for 'withMPDEx' that uses localhost:6600 as the default --- host:port, or whatever is found in the environment variables MPD_HOST and --- MPD_PORT. If MPD_HOST is of the form \"password\@host\" the password --- will be supplied as well. --- --- Examples: --- --- > withMPD $ play Nothing --- > withMPD $ add_ "tool" >> play Nothing >> currentSong -withMPD :: MPD a -> IO (Response a) -withMPD = withMPD_ Nothing Nothing - --- | Same as `withMPD`, but takes optional arguments that override MPD_HOST and --- MPD_PORT. --- --- This is e.g. useful for clients that optionally take @--port@ and @--host@ --- as command line arguments, and fall back to `withMPD`'s defaults if those --- arguments are not given. -withMPD_ :: Maybe String -- ^ optional override for MPD_HOST - -> Maybe String -- ^ optional override for MPD_PORT - -> MPD a -> IO (Response a) -withMPD_ mHost mPort action = do - settings <- getConnectionSettings mHost mPort - case settings of - Right (host, port, pw) -> withMPDEx host port pw action - Left err -> (return . Left . Custom) err - -getConnectionSettings :: Maybe String -> Maybe String -> IO (Either String (Host, Port, Password)) -getConnectionSettings mHost mPort = do - (host, pw) <- parseHost `fmap` - maybe (getEnvDefault "MPD_HOST" "localhost") return mHost - port <- maybe (getEnvDefault "MPD_PORT" "6600") return mPort - case maybeRead port of - Just p -> (return . Right) (host, p, pw) - Nothing -> (return . Left) (show port ++ " is not a valid port!") - where - parseHost s = case breakChar '@' s of - (host, "") -> (host, "") - (pw, host) -> (host, pw) - -getEnvDefault :: String -> String -> IO String -getEnvDefault x dflt = - E.catch (getEnv x) (\e -> if isDoesNotExistError e - then return dflt else ioError e) - --- Break a string by character, removing the separator. -breakChar :: Char -> String -> (String, String) -breakChar c s = let (x, y) = break (== c) s in (x, drop 1 y) - -maybeRead :: Read a => String -> Maybe a -maybeRead = fmap fst . listToMaybe . reads diff --git a/Network/MPD/Commands.hs b/Network/MPD/Commands.hs deleted file mode 100644 --- a/Network/MPD/Commands.hs +++ /dev/null @@ -1,523 +0,0 @@ -{-# LANGUAGE PatternGuards, OverloadedStrings #-} - --- | Module : Network.MPD.Commands --- Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 --- License : LGPL (see LICENSE) --- Maintainer : Joachim Fasting --- Stability : alpha --- --- Interface to the user commands supported by MPD. - -module Network.MPD.Commands ( - -- * Command related data types - module Network.MPD.Commands.Types, - - -- * Query interface - module Network.MPD.Commands.Query, - - -- * Querying MPD's status - clearError, currentSong, idle, noidle, status, stats, - - -- * Playback options - consume, crossfade, random, repeat, setVolume, single, replayGainMode, - replayGainStatus, - - -- * Controlling playback - next, pause, play, playId, previous, seek, seekId, stop, - - -- * The current playlist - add, add_, addId, clear, delete, deleteId, move, moveId, playlist, playlistId, - playlistFind, playlistInfo, playlistSearch, plChanges, plChangesPosId, shuffle, swap, - swapId, - - -- * Stored playlist - listPlaylist, listPlaylistInfo, listPlaylists, load, playlistAdd, - playlistAdd_, playlistClear, playlistDelete, playlistMove, rename, rm, - save, - - -- * The music database - count, find, findAdd, list, listAll, listAllInfo, lsInfo, search, update, - rescan, - - -- * Stickers - stickerGet, stickerSet, stickerDelete, stickerList, stickerFind, - - -- * Connection - close, kill, password, ping, - - -- * Audio output devices - disableOutput, enableOutput, outputs, - - -- * Reflection - commands, notCommands, tagTypes, urlHandlers, decoders, - ) where - -import Network.MPD.Commands.Arg -import Network.MPD.Commands.Parse -import Network.MPD.Commands.Query -import Network.MPD.Commands.Types -import Network.MPD.Commands.Util -import Network.MPD.Core -import Network.MPD.Util - -import Control.Monad (liftM) -import Control.Monad.Error (throwError) -import Prelude hiding (repeat) - -import qualified Data.ByteString.UTF8 as UTF8 -import Data.ByteString (ByteString) - --- --- Querying MPD's status --- - --- | Clear the current error message in status. -clearError :: MonadMPD m => m () -clearError = getResponse_ "clearerror" - --- | Get the currently playing song. -currentSong :: (Functor m, MonadMPD m) => m (Maybe Song) -currentSong = getResponse "currentsong" >>= runParser parseMaybeSong . toAssocList - --- | Wait until there is a noteworthy change in one or more of MPD's --- susbystems. --- --- The first argument is a list of subsystems that should be considered. An --- empty list specifies that all subsystems should be considered. --- --- A list of subsystems that have noteworthy changes is returned. --- --- Note that running this command will block until either 'idle' returns or is --- cancelled by 'noidle'. -idle :: MonadMPD m => [Subsystem] -> m [Subsystem] -idle subsystems = - mapM f =<< toAssocList `liftM` getResponse ("idle" <$> foldr (<++>) (Args []) subsystems) - where - f ("changed", system) = - case system of - "database" -> return DatabaseS - "update" -> return UpdateS - "stored_playlist" -> return StoredPlaylistS - "playlist" -> return PlaylistS - "player" -> return PlayerS - "mixer" -> return MixerS - "output" -> return OutputS - "options" -> return OptionsS - k -> fail ("Unknown subsystem: " ++ UTF8.toString k) - f x = fail ("idle: Unexpected " ++ show x) - --- | Cancel 'idle'. -noidle :: MonadMPD m => m () -noidle = getResponse_ "noidle" - --- | Get server statistics. -stats :: MonadMPD m => m Stats -stats = getResponse "stats" >>= runParser parseStats - --- | Get the server's status. -status :: MonadMPD m => m Status -status = getResponse "status" >>= runParser parseStatus - --- --- Playback options --- - --- | Set consume mode -consume :: MonadMPD m => Bool -> m () -consume = getResponse_ . ("consume" <$>) - --- | Set crossfading between songs. -crossfade :: MonadMPD m => Seconds -> m () -crossfade secs = getResponse_ ("crossfade" <$> secs) - --- | Set random playing. -random :: MonadMPD m => Bool -> m () -random = getResponse_ . ("random" <$>) - --- | Set repeating. -repeat :: MonadMPD m => Bool -> m () -repeat = getResponse_ . ("repeat" <$>) - --- | Set the volume (0-100 percent). -setVolume :: MonadMPD m => Int -> m () -setVolume = getResponse_ . ("setvol" <$>) - --- | Set single mode -single :: MonadMPD m => Bool -> m () -single = getResponse_ . ("single" <$>) - --- | Set the replay gain mode. -replayGainMode :: MonadMPD m => ReplayGainMode -> m () -replayGainMode = getResponse_ . ("replay_gain_mode" <$>) - --- | Get the replay gain options. -replayGainStatus :: MonadMPD m => m [String] -replayGainStatus = map UTF8.toString `liftM` getResponse "replay_gain_status" - --- --- Controlling playback --- - --- | Play the next song. -next :: MonadMPD m => m () -next = getResponse_ "next" - --- | Pause playing. -pause :: MonadMPD m => Bool -> m () -pause = getResponse_ . ("pause" <$>) - --- | Begin\/continue playing. -play :: MonadMPD m => Maybe Int -> m () -play (Just pos) = getResponse_ ("play" <$> pos) -play _ = getResponse_ "play" - --- | Play a file with given id. -playId :: MonadMPD m => Id -> m () -playId id' = getResponse_ ("playid" <$> id') - --- | Play the previous song. -previous :: MonadMPD m => m () -previous = getResponse_ "previous" - --- | Seek to some point in a song. -seek :: MonadMPD m => Int -> Seconds -> m () -seek pos time = getResponse_ ("seek" <$> pos <++> time) - --- | Seek to some point in a song (id version) -seekId :: MonadMPD m => Id -> Seconds -> m () -seekId id' time = getResponse_ ("seekid" <$> id' <++> time) - --- | Stop playing. -stop :: MonadMPD m => m () -stop = getResponse_ "stop" - --- --- The current playlist --- - --- This might do better to throw an exception than silently return 0. --- | Like 'add', but returns a playlist id. -addId :: MonadMPD m => Path -> Maybe Integer -- ^ Optional playlist position - -> m Id -addId p pos = liftM (parse parseNum Id (Id 0) . snd . head . toAssocList) - $ getResponse1 ("addid" <$> p <++> pos) - --- | Like 'add_' but returns a list of the files added. -add :: MonadMPD m => Path -> m [Path] -add x = add_ x >> listAll x - --- | Add a song (or a whole directory) to the current playlist. -add_ :: MonadMPD m => Path -> m () -add_ path = getResponse_ ("add" <$> path) - --- | Clear the current playlist. -clear :: MonadMPD m => m () -clear = getResponse_ "clear" - --- | Remove a song from the current playlist. -delete :: MonadMPD m => Int -> m () -delete pos = getResponse_ ("delete" <$> pos) - --- | Remove a song from the current playlist. -deleteId :: MonadMPD m => Id -> m () -deleteId id' = getResponse_ ("deleteid" <$> id') - --- | Move a song to a given position in the current playlist. -move :: MonadMPD m => Int -> Int -> m () -move pos to = getResponse_ ("move" <$> pos <++> to) - --- | Move a song from (songid) to (playlist index) in the playlist. If to is --- negative, it is relative to the current song in the playlist (if there is one). -moveId :: MonadMPD m => Id -> Int -> m () -moveId id' to = getResponse_ ("moveid" <$> id' <++> to) - --- | Retrieve file paths and positions of songs in the current playlist. --- Note that this command is only included for completeness sake; it's --- deprecated and likely to disappear at any time, please use 'playlistInfo' --- instead. -playlist :: MonadMPD m => m [(Int, Path)] -playlist = mapM f =<< getResponse "playlist" - where f s | (pos, name) <- breakChar ':' s - , Just pos' <- parseNum pos - = return (pos', Path name) - | otherwise = throwError . Unexpected $ show s - --- | Search for songs in the current playlist with strict matching. -playlistFind :: MonadMPD m => Query -> m [Song] -playlistFind q = takeSongs =<< getResponse ("playlistfind" <$> q) - --- | Retrieve metadata for songs in the current playlist. -playlistInfo :: MonadMPD m => Maybe (Int, Int) -> m [Song] -playlistInfo range = takeSongs =<< getResponse ("playlistinfo" <$> range) - --- | Displays a list of songs in the playlist. --- If id is specified, only its info is returned. -playlistId :: MonadMPD m => Maybe Id -> m [Song] -playlistId id' = takeSongs =<< getResponse ("playlistinfo" <$> id') - --- | Search case-insensitively with partial matches for songs in the --- current playlist. -playlistSearch :: MonadMPD m => Query -> m [Song] -playlistSearch q = takeSongs =<< getResponse ("playlistsearch" <$> q) - --- | Retrieve a list of changed songs currently in the playlist since --- a given playlist version. -plChanges :: MonadMPD m => Integer -> m [Song] -plChanges version = takeSongs =<< getResponse ("plchanges" <$> version) - --- | Like 'plChanges' but only returns positions and ids. -plChangesPosId :: MonadMPD m => Integer -> m [(Int, Id)] -plChangesPosId plver = - getResponse ("plchangesposid" <$> plver) >>= - mapM f . splitGroups ["cpos"] . toAssocList - where f xs | [("cpos", x), ("Id", y)] <- xs - , Just (x', y') <- pair parseNum (x, y) - = return (x', Id y') - | otherwise = throwError . Unexpected $ show xs - --- | Shuffle the playlist. -shuffle :: MonadMPD m => Maybe (Int, Int) -- ^ Optional range (start, end) - -> m () -shuffle range = getResponse_ ("shuffle" <$> range) - --- | Swap the positions of two songs. -swap :: MonadMPD m => Int -> Int -> m () -swap pos1 pos2 = getResponse_ ("swap" <$> pos1 <++> pos2) - --- | Swap the positions of two songs (Id version -swapId :: MonadMPD m => Id -> Id -> m () -swapId id1 id2 = getResponse_ ("swapid" <$> id1 <++> id2) - --- --- Stored playlists --- - --- | Retrieve a list of files in a given playlist. -listPlaylist :: MonadMPD m => PlaylistName -> m [Path] -listPlaylist plname = - (map Path . takeValues) `liftM` getResponse ("listplaylist" <$> plname) - --- | Retrieve metadata for files in a given playlist. -listPlaylistInfo :: MonadMPD m => PlaylistName -> m [Song] -listPlaylistInfo plname = - takeSongs =<< getResponse ("listplaylistinfo" <$> plname) - --- | Retreive a list of stored playlists. -listPlaylists :: MonadMPD m => m [PlaylistName] -listPlaylists = (map PlaylistName . go [] . toAssocList) `liftM` getResponse "listplaylists" - where - -- After each playlist name we get a timestamp - go acc [] = acc - go acc ((_, b):_:xs) = go (b : acc) xs - go _ _ = error "listPlaylists: bug" - --- | Load an existing playlist. -load :: MonadMPD m => PlaylistName -> m () -load plname = getResponse_ ("load" <$> plname) - --- | Like 'playlistAdd' but returns a list of the files added. -playlistAdd :: MonadMPD m => PlaylistName -> Path -> m [Path] -playlistAdd plname path = playlistAdd_ plname path >> listAll path - --- | Add a song (or a whole directory) to a stored playlist. --- Will create a new playlist if the one specified does not already exist. -playlistAdd_ :: MonadMPD m => PlaylistName -> Path -> m () -playlistAdd_ plname path = getResponse_ ("playlistadd" <$> plname <++> path) - --- | Clear a playlist. If the specified playlist does not exist, it will be --- created. -playlistClear :: MonadMPD m => PlaylistName -> m () -playlistClear = getResponse_ . ("playlistclear" <$>) - --- | Remove a song from a playlist. -playlistDelete :: MonadMPD m => PlaylistName - -> Integer -- ^ Playlist position - -> m () -playlistDelete name pos = getResponse_ ("playlistdelete" <$> name <++> pos) - --- | Move a song to a given position in the playlist specified. -playlistMove :: MonadMPD m => PlaylistName -> Integer -> Integer -> m () -playlistMove name from to = - getResponse_ ("playlistmove" <$> name <++> from <++> to) - --- | Rename an existing playlist. -rename :: MonadMPD m - => PlaylistName -- ^ Original playlist - -> PlaylistName -- ^ New playlist name - -> m () -rename plname new = getResponse_ ("rename" <$> plname <++> new) - --- | Delete existing playlist. -rm :: MonadMPD m => PlaylistName -> m () -rm plname = getResponse_ ("rm" <$> plname) - --- | Save the current playlist. -save :: MonadMPD m => PlaylistName -> m () -save plname = getResponse_ ("save" <$> plname) - --- --- The music database --- - --- | Count the number of entries matching a query. -count :: MonadMPD m => Query -> m Count -count query = getResponse ("count" <$> query) >>= runParser parseCount - --- | Search the database for entries exactly matching a query. -find :: MonadMPD m => Query -> m [Song] -find query = getResponse ("find" <$> query) >>= takeSongs - --- | Adds songs matching a query to the current playlist. -findAdd :: MonadMPD m => Query -> m () -findAdd q = getResponse_ ("findadd" <$> q) - --- | List all tags of the specified type. -list :: MonadMPD m - => Metadata -- ^ Metadata to list - -> Query -> m [Value] -list mtype query = (map Value . takeValues) `liftM` getResponse ("list" <$> mtype <++> query) - - --- | List the songs (without metadata) in a database directory recursively. -listAll :: MonadMPD m => Path -> m [Path] -listAll path = liftM (map (Path . snd) . filter ((== "file") . fst) . toAssocList) - (getResponse $ "listall" <$> path) - --- Helper for lsInfo and listAllInfo. -lsInfo' :: MonadMPD m => Command -> Path -> m [LsResult] -lsInfo' cmd path = getResponse (cmd <$> path) >>= takeEntries - --- | Recursive 'lsInfo'. -listAllInfo :: MonadMPD m => Path -> m [LsResult] -listAllInfo = lsInfo' "listallinfo" - --- | Non-recursively list the contents of a database directory. -lsInfo :: MonadMPD m => Path -> m [LsResult] -lsInfo = lsInfo' "lsinfo" - --- | Search the database using case insensitive matching. -search :: MonadMPD m => Query -> m [Song] -search query = getResponse ("search" <$> query) >>= takeSongs - --- | Update the server's database. --- If no paths are given, all paths will be scanned. --- Unreadable or non-existent paths are silently ignored. -update :: MonadMPD m => [Path] -> m () -update [] = getResponse_ "update" -update [x] = getResponse_ ("update" <$> x) -update xs = getResponses (map ("update" <$>) xs) >> return () - --- | Like 'update' but also rescans unmodified files. -rescan :: MonadMPD m => [Path] -> m () -rescan [] = getResponse_ "rescan" -rescan [x] = getResponse_ ("rescan" <$> x) -rescan xs = getResponses (map ("rescan" <$>) xs) >> return () - --- --- Stickers --- - --- | Reads a sticker value for the specified object. -stickerGet :: MonadMPD m => ObjectType - -> String -- ^ Object URI - -> String -- ^ Sticker name - -> m [String] -stickerGet typ uri name = (map UTF8.toString . takeValues) `liftM` getResponse ("sticker get" <$> typ <++> uri <++> name) - --- | Adds a sticker value to the specified object. -stickerSet :: MonadMPD m => ObjectType - -> String -- ^ Object URI - -> String -- ^ Sticker name - -> String -- ^ Sticker value - -> m () -stickerSet typ uri name value = - getResponse_ ("sticker set" <$> typ <++> uri <++> name <++> value) - --- | Delete a sticker value from the specified object. -stickerDelete :: MonadMPD m => ObjectType - -> String -- ^ Object URI - -> String -- ^ Sticker name - -> m () -stickerDelete typ uri name = - getResponse_ ("sticker delete" <$> typ <++> uri <++> name) - --- an internal helper function -decodePair :: (ByteString, ByteString) -> (String, String) -decodePair (x, y) = (UTF8.toString x, UTF8.toString y) - --- | Lists the stickers for the specified object. -stickerList :: MonadMPD m => ObjectType - -> String -- ^ Object URI - -> m [(String, String)] -- ^ Sticker name\/sticker value -stickerList typ uri = - (map decodePair . toAssocList) `liftM` getResponse ("sticker list" <$> typ <++> uri) - --- | Searches the sticker database for stickers with the specified name, below --- the specified path. -stickerFind :: MonadMPD m => ObjectType - -> String -- ^ Path - -> String -- ^ Sticker name - -> m [(String, String)] -- ^ URI\/sticker value -stickerFind typ uri name = - (map decodePair . toAssocList) `liftM` - getResponse ("sticker find" <$> typ <++> uri <++> name) - --- --- Connection --- - --- XXX should the password be quoted? Change "++" to "<$>" if so. If --- it should, it also needs to be fixed in N.M.Core. --- | Send password to server to authenticate session. --- Password is sent as plain text. -password :: MonadMPD m => String -> m () -password = getResponse_ . ("password " ++) - --- | Check that the server is still responding. -ping :: MonadMPD m => m () -ping = getResponse_ "ping" - --- --- Audio output devices --- - --- | Turn off an output device. -disableOutput :: MonadMPD m => Int -> m () -disableOutput = getResponse_ . ("disableoutput" <$>) - --- | Turn on an output device. -enableOutput :: MonadMPD m => Int -> m () -enableOutput = getResponse_ . ("enableoutput" <$>) - --- | Retrieve information for all output devices. -outputs :: MonadMPD m => m [Device] -outputs = getResponse "outputs" >>= runParser parseOutputs - --- --- Reflection --- - --- | Retrieve a list of available commands. -commands :: MonadMPD m => m [String] -commands = (map UTF8.toString . takeValues) `liftM` getResponse "commands" - --- | Retrieve a list of unavailable (due to access restrictions) commands. -notCommands :: MonadMPD m => m [String] -notCommands = (map UTF8.toString . takeValues) `liftM` getResponse "notcommands" - --- | Retrieve a list of available song metadata. -tagTypes :: MonadMPD m => m [String] -tagTypes = (map UTF8.toString . takeValues) `liftM` (getResponse "tagtypes") - --- | Retrieve a list of supported urlhandlers. -urlHandlers :: MonadMPD m => m [String] -urlHandlers = (map UTF8.toString . takeValues) `liftM` (getResponse "urlhandlers") - --- | Retreive a list of decoder plugins with associated suffix and mime types. -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 (UTF8.toString p, map decodePair info) : takeDecoders rest diff --git a/Network/MPD/Commands/Arg.hs b/Network/MPD/Commands/Arg.hs deleted file mode 100644 --- a/Network/MPD/Commands/Arg.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, GeneralizedNewtypeDeriving #-} - --- | Module : Network.MPD.Commands.Arg --- Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 --- License : LGPL (see LICENSE) --- Maintainer : Joachim Fasting --- Stability : alpha --- --- Prepare command arguments. - -module Network.MPD.Commands.Arg (Command, Args(..), MPDArg(..), (<++>), (<$>)) where - -import Network.MPD.Util (showBool) - -import Data.ByteString (ByteString) -import qualified Data.ByteString.UTF8 as UTF8 -import Data.String - --- | Arguments for getResponse are accumulated as strings in values of --- this type after being converted from whatever type (an instance of --- MPDArg) they were to begin with. -newtype Args = Args [String] - deriving Show - --- | A uniform interface for argument preparation --- The basic idea is that one should be able --- to magically prepare an argument for use with --- an MPD command, without necessarily knowing/\caring --- how it needs to be represented internally. -class Show a => MPDArg a where - prep :: a -> Args - -- Note that because of this, we almost - -- never have to actually provide - -- an implementation of 'prep' - prep = Args . return . show - --- | Groups together arguments to getResponse. -infixl 3 <++> -(<++>) :: (MPDArg a, MPDArg b) => a -> b -> Args -x <++> y = Args $ xs ++ ys - where Args xs = prep x - Args ys = prep y - -newtype Command = Command String - deriving IsString - --- | Converts a command name and a string of arguments into the string --- to hand to getResponse. -infix 2 <$> -(<$>) :: (MPDArg a) => Command -> a -> String -Command x <$> y = unwords $ x : filter (not . null) y' - where Args y' = prep y - -instance MPDArg Args where prep = id - -instance MPDArg String where - -- We do this to avoid mangling - -- non-ascii characters with 'show' - prep x = Args ['"' : x ++ "\""] - -instance MPDArg ByteString where - prep = prep . UTF8.toString - -instance (MPDArg a) => MPDArg (Maybe a) where - prep Nothing = Args [] - prep (Just x) = prep x - -instance (MPDArg a, MPDArg b) => MPDArg (a, b) where - prep (x, y) = Args [show x ++ ":" ++ show y] - -instance MPDArg Int -instance MPDArg Integer -instance MPDArg Bool where prep = Args . return . showBool diff --git a/Network/MPD/Commands/Extensions.hs b/Network/MPD/Commands/Extensions.hs deleted file mode 100644 --- a/Network/MPD/Commands/Extensions.hs +++ /dev/null @@ -1,147 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | Module : Network.MPD.Commands.Extensions --- Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 --- License : LGPL (see LICENSE) --- Maintainer : Joachim Fasting --- Stability : alpha --- --- Extensions and shortcuts to the standard MPD command set. - -module Network.MPD.Commands.Extensions where - -import Network.MPD.Core -import Network.MPD.Commands -import Network.MPD.Commands.Arg -import Network.MPD.Commands.Util -import Network.MPD.Util (read) - -import Prelude hiding (read) -import Control.Monad (liftM) - --- | Like 'update', but returns the update job id. -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 - --- | Toggles play\/pause. Plays if stopped. -toggle :: MonadMPD m => m () -toggle = status >>= \st -> case stState st of Playing -> pause True - _ -> play Nothing - --- | Add a list of songs\/folders to a playlist. --- Should be more efficient than running 'add' many times. -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 - --- | Delete a list of songs from a playlist. --- If there is a duplicate then no further songs will be deleted, so --- take care to avoid them (see 'prune' for this). -{- 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 _ = "" - --- | Returns all songs and directories that match the given partial --- path name. -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 playlist. --- The bounds are inclusive. --- If 'Nothing' is passed the cropping will leave your playlist alone --- on that side. --- Using 'ID' will automatically find the absolute playlist position and use --- that as the cropping boundary. -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 - -- ensure that no songs are deleted twice with 'max'. - 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) - --- | Remove duplicate playlist entries. -prune :: MonadMPD m => m () -prune = findDuplicates >>= deleteMany "" - --- Find duplicate playlist entries. -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) - --- | List directories non-recursively. -lsDirs :: MonadMPD m => Path -> m [Path] -lsDirs path = - liftM (extractEntries (const Nothing,const Nothing, Just)) $ - takeEntries =<< getResponse ("lsinfo" <$> path) - --- | List files non-recursively. -lsFiles :: MonadMPD m => Path -> m [Path] -lsFiles path = - liftM (extractEntries (Just . sgFilePath, const Nothing, const Nothing)) $ - takeEntries =<< getResponse ("lsinfo" <$> path) - --- | List all playlists. -lsPlaylists :: MonadMPD m => m [PlaylistName] -lsPlaylists = liftM (extractEntries (const Nothing, Just, const Nothing)) $ - takeEntries =<< getResponse "lsinfo" -} - --- | List the artists in the database. -listArtists :: MonadMPD m => m [Artist] -listArtists = (map Value . takeValues) `liftM` (getResponse "list artist") - --- | List the albums in the database, optionally matching a given --- artist. -listAlbums :: MonadMPD m => Maybe Artist -> m [Album] -listAlbums artist = (map Value . takeValues) `liftM` - getResponse ("list album" <$> fmap (("artist" :: String) <++>) artist) - --- | List the songs in an album of some artist. -listAlbum :: MonadMPD m => Artist -> Album -> m [Song] -listAlbum artist album = find (Artist =? artist <&> Album =? album) - --- | Retrieve the current playlist. --- Equivalent to @playlistinfo Nothing@. -getPlaylist :: MonadMPD m => m [Song] -getPlaylist = playlistInfo Nothing - --- | Increase or decrease volume by a given percent, e.g. --- 'volume 10' will increase the volume by 10 percent, while --- 'volume (-10)' will decrease it by the same amount. -volume :: MonadMPD m => Int -> m () -volume n = do - current <- (fromIntegral . stVolume) `liftM` status - setVolume . round $ (fromIntegral n / (100 :: Double)) * current + current diff --git a/Network/MPD/Commands/Parse.hs b/Network/MPD/Commands/Parse.hs deleted file mode 100644 --- a/Network/MPD/Commands/Parse.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} - --- | Module : Network.MPD.Commands.Parse --- Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 --- License : LGPL (see LICENSE) --- Maintainer : Joachim Fasting --- Stability : alpha --- --- Parsers for MPD data types. - -module Network.MPD.Commands.Parse where - -import Network.MPD.Commands.Types - -import Control.Arrow ((***)) -import Control.Monad.Error -import Data.Maybe (fromMaybe) - -import Network.MPD.Util -import Network.MPD.Core (MonadMPD, MPDError(Unexpected)) - -import Data.ByteString.Char8 (ByteString) -import qualified Data.ByteString.UTF8 as UTF8 - --- | Builds a 'Count' instance from an assoc. list. -parseCount :: [ByteString] -> Either String Count -parseCount = foldM f defaultCount . toAssocList - where f :: Count -> (ByteString, ByteString) -> Either String Count - f a ("songs", x) = return $ parse parseNum - (\x' -> a { cSongs = x'}) a x - f a ("playtime", x) = return $ parse parseNum - (\x' -> a { cPlaytime = x' }) a x - f _ x = Left $ show x - --- | Builds a list of 'Device' instances from an assoc. list -parseOutputs :: [ByteString] -> Either String [Device] -parseOutputs = mapM (foldM f defaultDevice) - . splitGroups ["outputid"] - . toAssocList - where f a ("outputid", x) = return $ parse parseNum - (\x' -> a { dOutputID = x' }) a x - f a ("outputname", x) = return a { dOutputName = UTF8.toString x } - f a ("outputenabled", x) = return $ parse parseBool - (\x' -> a { dOutputEnabled = x'}) a x - f _ x = fail $ show x - --- | Builds a 'Stats' instance from an assoc. list. -parseStats :: [ByteString] -> Either String Stats -parseStats = foldM f defaultStats . toAssocList - where - f a ("artists", x) = return $ parse parseNum - (\x' -> a { stsArtists = x' }) a x - f a ("albums", x) = return $ parse parseNum - (\x' -> a { stsAlbums = x' }) a x - f a ("songs", x) = return $ parse parseNum - (\x' -> a { stsSongs = x' }) a x - f a ("uptime", x) = return $ parse parseNum - (\x' -> a { stsUptime = x' }) a x - f a ("playtime", x) = return $ parse parseNum - (\x' -> a { stsPlaytime = x' }) a x - f a ("db_playtime", x) = return $ parse parseNum - (\x' -> a { stsDbPlaytime = x' }) a x - f a ("db_update", x) = return $ parse parseNum - (\x' -> a { stsDbUpdate = x' }) a x - f _ x = fail $ show x - -parseMaybeSong :: [(ByteString, ByteString)] -> Either String (Maybe Song) -parseMaybeSong xs | null xs = Right Nothing - | otherwise = Just `fmap` parseSong xs - --- | Builds a 'Song' instance from an assoc. list. -parseSong :: [(ByteString, ByteString)] -> Either String Song -parseSong xs = case xs of - ("file", path):ys -> foldM f (defaultSong $ Path path) ys - _ -> Left "Got a song without a file path! This indicates a bug in either libmpd-haskell or MPD itself!" - - where - f :: Song -> (ByteString, ByteString) -> Either String Song - f s ("Last-Modified", v) = - return s { sgLastModified = parseIso8601 v } - f s ("Time", v) = - return s { sgLength = fromMaybe 0 $ parseNum v } - f s ("Id", v) = - return $ parse parseNum (\v' -> s { sgId = Just $ Id v' }) s v - f s ("Pos", v) = - maybe (return $ parse parseNum - (\v' -> s { sgIndex = Just v' }) s v) - (const $ return s) - (sgIndex s) - f s (k, v) = return . maybe s (\m -> sgAddTag m (Value v) s) $ - readMeta k - - -- Custom-made Read instance - readMeta "Artist" = Just Artist - readMeta "Album" = Just Album - readMeta "Title" = Just Title - readMeta "Genre" = Just Genre - readMeta "Name" = Just Name - readMeta "Composer" = Just Composer - readMeta "Performer" = Just Performer - readMeta "Date" = Just Date - readMeta "Track" = Just Track - readMeta "Disc" = Just Disc - readMeta "MUSICBRAINZ_ARTISTID" = Just MUSICBRAINZ_ARTISTID - readMeta "MUSICBRAINZ_TRACKID" = Just MUSICBRAINZ_TRACKID - readMeta _ = Nothing - --- | Builds a 'Status' instance from an assoc. list. -parseStatus :: [ByteString] -> Either String Status -parseStatus = foldM f defaultStatus . toAssocList - where f a ("state", x) - = return $ parse state (\x' -> a { stState = x' }) a x - f a ("volume", x) - = return $ parse parseNum (\x' -> a { stVolume = x' }) a x - f a ("repeat", x) - = return $ parse parseBool (\x' -> a { stRepeat = x' }) a x - f a ("random", x) - = return $ parse parseBool (\x' -> a { stRandom = x' }) a x - f a ("playlist", x) - = return $ parse parseNum (\x' -> a { stPlaylistVersion = x' }) a x - f a ("playlistlength", x) - = return $ parse parseNum (\x' -> a { stPlaylistLength = x' }) a x - f a ("xfade", x) - = return $ parse parseNum (\x' -> a { stXFadeWidth = x' }) a x - f a ("mixrampdb", x) - = return $ parse parseFrac (\x' -> a { stMixRampdB = x' }) a x - f a ("mixrampdelay", x) - = return $ parse parseFrac (\x' -> a { stMixRampDelay = x' }) a x - f a ("song", x) - = return $ parse parseNum (\x' -> a { stSongPos = Just x' }) a x - f a ("songid", x) - = return $ parse parseNum (\x' -> a { stSongID = Just $ Id x' }) a x - f a ("time", x) - = return $ parse time (\x' -> a { stTime = x' }) a x - f a ("elapsed", x) - = return $ parse parseFrac (\x' -> a { stTime = (x', snd $ stTime a) }) a x - f a ("bitrate", x) - = return $ parse parseNum (\x' -> a { stBitrate = x' }) a x - f a ("audio", x) - = return $ parse audio (\x' -> a { stAudio = x' }) a x - f a ("updating_db", x) - = return $ parse parseNum (\x' -> a { stUpdatingDb = x' }) a x - f a ("error", x) - = return a { stError = Just (UTF8.toString x) } - f a ("single", x) - = return $ parse parseBool (\x' -> a { stSingle = x' }) a x - f a ("consume", x) - = return $ parse parseBool (\x' -> a { stConsume = x' }) a x - f a ("nextsong", x) - = return $ parse parseNum (\x' -> a { stNextSongPos = Just x' }) a x - f a ("nextsongid", x) - = return $ parse parseNum (\x' -> a { stNextSongID = Just $ Id x' }) a x - f _ x - = fail $ show x - - state "play" = Just Playing - state "pause" = Just Paused - state "stop" = Just Stopped - state _ = Nothing - - time s = case parseFrac *** parseNum $ breakChar ':' s of - (Just a, Just b) -> Just (a, b) - _ -> Nothing - - audio = parseTriple ':' parseNum - --- | Run a parser and lift the result into the 'MPD' monad -runParser :: (MonadMPD m, MonadError MPDError m) - => (input -> Either String a) -> input -> m a -runParser f = either (throwError . Unexpected) return . f - --- | A helper that runs a parser on a string and, depending on the --- outcome, either returns the result of some command applied to the --- result, or a default value. Used when building structures. -parse :: (ByteString -> Maybe a) -> (a -> b) -> b -> ByteString -> b -parse parser f x = maybe x f . parser - --- | A helper for running a parser returning Maybe on a pair of strings. --- Returns Just if both strings where parsed successfully, Nothing otherwise. -pair :: (ByteString -> Maybe a) -> (ByteString, ByteString) -> Maybe (a, a) -pair p (x, y) = case (p x, p y) of - (Just a, Just b) -> Just (a, b) - _ -> Nothing diff --git a/Network/MPD/Commands/Query.hs b/Network/MPD/Commands/Query.hs deleted file mode 100644 --- a/Network/MPD/Commands/Query.hs +++ /dev/null @@ -1,56 +0,0 @@ --- | Module : Network.MPD.Commands.Query --- Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 --- License : LGPL (see LICENSE) --- Maintainer : Joachim Fasting --- Stability : alpha --- --- Query interface. - -module Network.MPD.Commands.Query (Query, (=?), (<&>), anything) where - -import Network.MPD.Commands.Arg -import Network.MPD.Commands.Types - -import Data.Monoid - --- | An interface for creating MPD queries. --- --- For example, to match any song where the value of artist is \"Foo\", we --- use: --- --- > Artist =? "Foo" --- --- We can also compose queries, thus narrowing the search. For example, to --- match any song where the value of artist is \"Foo\" and the value of album --- is \"Bar\", we use: --- --- > Artist =? "Foo" <&> Album =? "Bar" -newtype Query = Query [Match] deriving Show - --- A single query clause, comprising a metadata key and a desired value. -data Match = Match Metadata Value - -instance Show Match where - show (Match meta query) = show meta ++ " \"" ++ toString query ++ "\"" - showList xs _ = unwords $ map show xs - -instance Monoid Query where - mempty = Query [] - Query a `mappend` Query b = Query (a ++ b) - -instance MPDArg Query where - prep = foldl (<++>) (Args []) . f - where f (Query ms) = map (\(Match m q) -> Args [show m] <++> q) ms - --- | An empty query. Matches anything. -anything :: Query -anything = mempty - --- | Create a query. -(=?) :: Metadata -> Value -> Query -m =? s = Query [Match m s] - --- | Combine queries. -infixr 6 <&> -(<&>) :: Query -> Query -> Query -(<&>) = mappend diff --git a/Network/MPD/Commands/Types.hs b/Network/MPD/Commands/Types.hs deleted file mode 100644 --- a/Network/MPD/Commands/Types.hs +++ /dev/null @@ -1,285 +0,0 @@ -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, GeneralizedNewtypeDeriving #-} --- | Module : Network.MPD.Commands.Types --- Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 --- License : LGPL (see LICENSE) --- Maintainer : Joachim Fasting --- Stability : alpha --- --- Various MPD data structures and types - -module Network.MPD.Commands.Types where - -import Network.MPD.Commands.Arg (MPDArg(prep), Args(Args)) - -import qualified Data.Map as M -import Data.Time.Clock (UTCTime) -import Data.String - -import Data.Text (Text) -import qualified Data.Text.Encoding as Text -import Data.ByteString (ByteString) -import qualified Data.ByteString.UTF8 as UTF8 - --- The purpose of this class is to allow users to choose the optimal --- representation of response values. --- | A type class for values that can be converted to `String`s. -class ToString a where - - -- | Convert given value to `String`. - toString :: a -> String - - -- | Convert given value to `Text`. - toText :: a -> Text - - -- | Convert given value an UTF-8 encoded `ByteString`. - toUtf8 :: a -> ByteString - -type Artist = Value -type Album = Value -type Title = Value - --- | Used for commands which require a playlist name. --- If empty, the current playlist is used. -newtype PlaylistName = PlaylistName ByteString - deriving (Eq, Show, MPDArg) - -instance ToString PlaylistName where - toString (PlaylistName x) = UTF8.toString x - toText (PlaylistName x) = Text.decodeUtf8 x - toUtf8 (PlaylistName x) = x - -instance IsString PlaylistName where - fromString = PlaylistName . UTF8.fromString - --- | Used for commands which require a path within the database. --- If empty, the root path is used. -newtype Path = Path ByteString - deriving (Eq, Show, MPDArg) - -instance ToString Path where - toString (Path x) = UTF8.toString x - toText (Path x) = Text.decodeUtf8 x - toUtf8 (Path x) = x - -instance IsString Path where - fromString = Path . UTF8.fromString - --- | Available metadata types\/scope modifiers, used for searching the --- database for entries with certain metadata values. -data Metadata = Artist - -- NOTE: The commented constructors are not yet handled by the - -- parser. If you uncomment them, some test will fail. - -- | ArtistSort - | Album - -- | AlbumArtist - -- | AlbumArtistSort - | Title - | Track - | Name - | Genre - | Date - | Composer - | Performer - -- | Comment - | Disc - | MUSICBRAINZ_ARTISTID - -- | MUSICBRAINZ_ALBUMID - -- | MUSICBRAINZ_ALBUMARTISTID - | MUSICBRAINZ_TRACKID - deriving (Eq, Enum, Ord, Bounded, Show) - -instance MPDArg Metadata - --- | A metadata value. -newtype Value = Value ByteString - deriving (Eq, Show, MPDArg) - -instance ToString Value where - toString (Value x) = UTF8.toString x - toText (Value x) = Text.decodeUtf8 x - toUtf8 (Value x) = x - -instance IsString Value where - fromString = Value . UTF8.fromString - --- | Object types. -data ObjectType = SongObj - deriving (Eq, Show) - -instance MPDArg ObjectType where - prep SongObj = Args ["song"] - -type Seconds = Integer - --- | Represents the different playback states. -data State = Playing - | Stopped - | Paused - deriving (Show, Eq) - --- | Represents the various MPD subsystems. -data Subsystem - = DatabaseS -- ^ The song database - | UpdateS -- ^ Database updates - | StoredPlaylistS -- ^ Stored playlists - | PlaylistS -- ^ The current playlist - | PlayerS -- ^ The player - | MixerS -- ^ The volume mixer - | OutputS -- ^ Audio outputs - | OptionsS -- ^ Playback options - deriving (Eq, Show) - -instance MPDArg Subsystem where - prep DatabaseS = Args ["database"] - prep UpdateS = Args ["update"] - prep StoredPlaylistS = Args ["stored_playlist"] - prep PlaylistS = Args ["playlist"] - prep PlayerS = Args ["player"] - prep MixerS = Args ["mixer"] - prep OutputS = Args ["output"] - prep OptionsS = Args ["options"] - -data ReplayGainMode - = Off -- ^ Disable replay gain - | TrackMode -- ^ Per track mode - | AlbumMode -- ^ Per album mode - deriving (Eq, Show) - -instance MPDArg ReplayGainMode where - prep Off = Args ["off"] - prep TrackMode = Args ["track"] - prep AlbumMode = Args ["album"] - --- | Represents the result of running 'count'. -data Count = - Count { cSongs :: Integer -- ^ Number of songs matching the query - , cPlaytime :: Seconds -- ^ Total play time of matching songs - } - deriving (Eq, Show) - -defaultCount :: Count -defaultCount = Count { cSongs = 0, cPlaytime = 0 } - --- | Result of the lsInfo operation -data LsResult - = LsDirectory Path -- ^ Directory - | LsSong Song -- ^ Song - | LsPlaylist PlaylistName -- ^ Playlist - deriving (Eq, Show) - --- | Represents an output device. -data Device = - Device { dOutputID :: Int -- ^ Output's ID number - , dOutputName :: String -- ^ Output's name as defined in the MPD - -- configuration file - , dOutputEnabled :: Bool } - deriving (Eq, Show) - -defaultDevice :: Device -defaultDevice = - Device { dOutputID = 0, dOutputName = "", dOutputEnabled = False } - --- | Represents a single song item. -data Song = Song - { sgFilePath :: Path - -- | Map of available tags (multiple occurences of one tag type allowed) - , sgTags :: M.Map Metadata [Value] - -- | Last modification date - , sgLastModified :: Maybe UTCTime - -- | Length of the song in seconds - , sgLength :: Seconds - -- | Id in playlist - , sgId :: Maybe Id - -- | Position in playlist - , sgIndex :: Maybe Int - } deriving (Eq, Show) - -newtype Id = Id Int - deriving (Eq, Show) - -instance (MPDArg Id) where - prep (Id x) = prep x - --- | Get list of specific tag type -sgGetTag :: Metadata -> Song -> Maybe [Value] -sgGetTag meta s = M.lookup meta $ sgTags s - --- | Add metadata tag value. -sgAddTag :: Metadata -> Value -> Song -> Song -sgAddTag meta value s = s { sgTags = M.insertWith' (++) meta [value] (sgTags s) } - -defaultSong :: Path -> Song -defaultSong path = - Song { sgFilePath = path, sgTags = M.empty, sgLastModified = Nothing - , sgLength = 0, sgId = Nothing, sgIndex = Nothing } - --- | Container for database statistics. -data Stats = - Stats { stsArtists :: Integer -- ^ Number of artists. - , stsAlbums :: Integer -- ^ Number of albums. - , stsSongs :: Integer -- ^ Number of songs. - , stsUptime :: Seconds -- ^ Daemon uptime in seconds. - , stsPlaytime :: Seconds -- ^ Total playing time. - , stsDbPlaytime :: Seconds -- ^ Total play time of all the songs in - -- the database. - , stsDbUpdate :: Integer -- ^ Last database update in UNIX time. - } - deriving (Eq, Show) - -defaultStats :: Stats -defaultStats = - Stats { stsArtists = 0, stsAlbums = 0, stsSongs = 0, stsUptime = 0 - , stsPlaytime = 0, stsDbPlaytime = 0, stsDbUpdate = 0 } - --- | Container for MPD status. -data Status = - Status { stState :: State - -- | A percentage (0-100) - , stVolume :: Int - , stRepeat :: Bool - , stRandom :: Bool - -- | A value that is incremented by the server every time the - -- playlist changes. - , stPlaylistVersion :: Integer - -- | The number of items in the current playlist. - , stPlaylistLength :: Integer - -- | Current song's position in the playlist. - , stSongPos :: Maybe Int - -- | Current song's playlist ID. - , stSongID :: Maybe Id - -- | Next song's position in the playlist. - , stNextSongPos :: Maybe Int - -- | Next song's playlist ID. - , stNextSongID :: Maybe Id - -- | Time elapsed\/total time. - , stTime :: (Double, Seconds) - -- | Bitrate (in kilobytes per second) of playing song (if any). - , stBitrate :: Int - -- | Crossfade time. - , stXFadeWidth :: Seconds - -- | MixRamp threshold in dB - , stMixRampdB :: Double - -- | MixRamp extra delay in seconds - , stMixRampDelay :: Double - -- | Samplerate\/bits\/channels for the chosen output device - -- (see mpd.conf). - , stAudio :: (Int, Int, Int) - -- | Job ID of currently running update (if any). - , stUpdatingDb :: Integer - -- | If True, MPD will play only one song and stop after finishing it. - , stSingle :: Bool - -- | If True, a song will be removed after it has been played. - , stConsume :: Bool - -- | Last error message (if any). - , stError :: Maybe String } - deriving (Eq, Show) - -defaultStatus :: Status -defaultStatus = - Status { stState = Stopped, stVolume = 0, stRepeat = False - , stRandom = False, stPlaylistVersion = 0, stPlaylistLength = 0 - , stSongPos = Nothing, stSongID = Nothing, stTime = (0,0) - , stNextSongPos = Nothing, stNextSongID = Nothing - , stBitrate = 0, stXFadeWidth = 0, stMixRampdB = 0 - , stMixRampDelay = 0, stAudio = (0,0,0), stUpdatingDb = 0 - , stSingle = False, stConsume = False, stError = Nothing } diff --git a/Network/MPD/Commands/Util.hs b/Network/MPD/Commands/Util.hs deleted file mode 100644 --- a/Network/MPD/Commands/Util.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | Module : Network.MPD.Commands.Util --- Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 --- License : LGPL (see LICENSE) --- Maintainer : Joachim Fasting --- Stability : alpha --- --- Internal utilities for implementing MPD commands. - -module Network.MPD.Commands.Util where - -import Network.MPD.Commands.Parse -import Network.MPD.Commands.Types -import Network.MPD.Core -import Network.MPD.Util - -import Control.Monad.Error -import Data.List (intersperse) -import Data.Maybe (mapMaybe) - -import Data.ByteString.Char8 (ByteString) - --- Run getResponse but discard the response. -getResponse_ :: MonadMPD m => String -> m () -getResponse_ x = getResponse x >> return () - --- Get the lines of the daemon's response to a list of commands. -getResponses :: MonadMPD m => [String] -> m [ByteString] -getResponses cmds = getResponse . concat $ intersperse "\n" cmds' - where cmds' = "command_list_begin" : cmds ++ ["command_list_end"] - --- Helper that throws unexpected error if input is empty. -failOnEmpty :: MonadMPD m => [ByteString] -> m [ByteString] -failOnEmpty [] = throwError $ Unexpected "Non-empty response expected." -failOnEmpty xs = return xs - --- A wrapper for getResponse that fails on non-empty responses. -getResponse1 :: MonadMPD m => String -> m [ByteString] -getResponse1 x = getResponse x >>= failOnEmpty - --- Run 'toAssocList' and return only the values. -takeValues :: [ByteString] -> [ByteString] -takeValues = snd . unzip . toAssocList - --- Separate the result of an lsinfo\/listallinfo call into directories, --- playlists, and songs. -takeEntries :: MonadMPD m => [ByteString] -> m [LsResult] -takeEntries = mapM toEntry . splitGroups groupHeads . toAssocList - where - toEntry xs@(("file",_):_) = LsSong `liftM` runParser parseSong xs - toEntry (("directory",d):_) = (return . LsDirectory . Path) d - toEntry (("playlist",pl):_) = (return . LsPlaylist . PlaylistName) pl - toEntry _ = error "takeEntries: splitGroups is broken" - groupHeads = ["file", "directory", "playlist"] - --- Extract a subset of songs, directories, and playlists. -extractEntries :: (Song -> Maybe a, PlaylistName -> Maybe a, Path -> Maybe a) - -> [LsResult] -> [a] -extractEntries (fSong,fPlayList,fDir) = mapMaybe f - where - f (LsSong s) = fSong s - f (LsPlaylist pl) = fPlayList pl - f (LsDirectory d) = fDir d - --- Build a list of song instances from a response. -takeSongs :: MonadMPD m => [ByteString] -> m [Song] -takeSongs = mapM (runParser parseSong) - . splitGroups ["file"] - . toAssocList diff --git a/Network/MPD/Core.hs b/Network/MPD/Core.hs deleted file mode 100644 --- a/Network/MPD/Core.hs +++ /dev/null @@ -1,249 +0,0 @@ -{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Module : Network.MPD.Core --- Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 --- License : LGPL (see LICENSE) --- Maintainer : Joachim Fasting --- Stability : alpha --- --- The core datatypes and operations are defined here, including the --- primary instance of the 'MonadMPD' class, 'MPD'. - -module Network.MPD.Core ( - -- * Classes - MonadMPD(..), - -- * Data types - MPD, MPDError(..), ACKType(..), Response, Host, Port, Password, - -- * Running - withMPDEx, - -- * Interacting - getResponse, kill, - ) where - -import Network.MPD.Util -import Network.MPD.Core.Class -import Network.MPD.Core.Error - -import Data.Char (isDigit) -import Control.Applicative (Applicative(..), (<$>), (<*)) -import qualified Control.Exception as E -import Control.Monad (ap, unless) -import Control.Monad.Error (ErrorT(..), MonadError(..)) -import Control.Monad.Reader (ReaderT(..), ask) -import Control.Monad.State (StateT, MonadIO(..), modify, get, evalStateT) -import qualified Data.Foldable as F -import Network (PortID(..), withSocketsDo, connectTo) -import System.IO (Handle, hPutStrLn, hReady, hClose, hFlush) -import System.IO.Error (isEOFError) -import qualified System.IO.UTF8 as U -import Text.Printf (printf) - -import qualified Prelude -import Prelude hiding (break, drop, dropWhile, read) -import Data.ByteString.Char8 (ByteString, isPrefixOf, break, drop, dropWhile) -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.UTF8 as UTF8 - --- --- Data types. --- - -type Host = String -type Port = Integer - --- --- IO based MPD client implementation. --- - --- | The main implementation of an MPD client. It actually connects --- to a server and interacts with it. --- --- To use the error throwing\/catching capabilities: --- --- > import Control.Monad.Error (throwError, catchError) --- --- To run IO actions within the MPD monad: --- --- > import Control.Monad.Trans (liftIO) - -newtype MPD a = - MPD { runMPD :: ErrorT MPDError - (StateT MPDState - (ReaderT (Host, Port) IO)) a - } deriving (Functor, Monad, MonadIO, MonadError MPDError) - -instance Applicative MPD where - (<*>) = ap - pure = return - -instance MonadMPD MPD where - open = mpdOpen - close = mpdClose - send = mpdSend - getHandle = MPD $ stHandle <$> get - getPassword = MPD $ stPassword <$> get - setPassword pw = MPD $ modify (\st -> st { stPassword = pw }) - getVersion = MPD $ stVersion <$> get - --- | Inner state for MPD -data MPDState = - MPDState { stHandle :: Maybe Handle - , stPassword :: String - , stVersion :: (Int, Int, Int) - } - --- | A response is either an 'MPDError' or some result. -type Response = Either MPDError - --- | The most configurable API for running an MPD action. -withMPDEx :: Host -> Port -> Password -> MPD a -> IO (Response a) -withMPDEx host port pw x = withSocketsDo $ - runReaderT (evalStateT (runErrorT . runMPD $ open >> (x <* close)) initState) - (host, port) - where initState = MPDState Nothing pw (0, 0, 0) - -mpdOpen :: MPD () -mpdOpen = MPD $ do - (host, port) <- ask - runMPD close - handle <- liftIO (safeConnectTo host port) - modify (\st -> st { stHandle = handle }) - F.forM_ handle (const $ runMPD checkConn >>= flip unless (runMPD close)) - where - safeConnectTo host@('/':_) _ = - (Just <$> connectTo "" (UnixSocket host)) - `E.catch` (\(_ :: E.SomeException) -> return Nothing) - safeConnectTo host port = - (Just <$> connectTo host (PortNumber $ fromInteger port)) - `E.catch` (\(_ :: E.SomeException) -> return Nothing) - checkConn = do - [msg] <- send "" - if "OK MPD" `isPrefixOf` msg - then MPD $ checkVersion $ parseVersion msg - else return False - - checkVersion Nothing = throwError $ Custom "Couldn't determine MPD version" - checkVersion (Just version) - | version < requiredVersion = - throwError $ Custom $ printf - "MPD %s is not supported, upgrade to MPD %s or above!" - (formatVersion version) (formatVersion requiredVersion) - | otherwise = do - modify (\st -> st { stVersion = version }) - return True - where - requiredVersion = (0, 15, 0) - - parseVersion = parseTriple '.' parseNum . dropWhile (not . isDigit) - - formatVersion :: (Int, Int, Int) -> String - formatVersion (x, y, z) = printf "%d.%d.%d" x y z - - -mpdClose :: MPD () -mpdClose = - MPD $ do - get >>= F.mapM_ (liftIO . sendClose) . stHandle - modify (\st -> st { stHandle = Nothing }) - where - sendClose handle = - (hPutStrLn handle "close" >> hReady handle >> hClose handle) - `E.catch` whenEOF (return ()) - - whenEOF result err - | isEOFError err = result - | otherwise = ioError err - -mpdSend :: String -> MPD [ByteString] -mpdSend str = send' `catchError` handler - where - handler TimedOut = mpdOpen >> send' - handler err = throwError err - - send' = MPD $ get >>= maybe (throwError NoMPD) go . stHandle - - go handle = do - unless (null str) $ - liftIO $ U.hPutStrLn handle str >> hFlush handle - liftIO ((Right <$> getLines handle []) `E.catch` (return . Left)) - >>= either (\err -> if isEOFError err then - modify (\st -> st { stHandle = Nothing }) - >> throwError TimedOut - else liftIO (ioError err)) - return - - getLines :: Handle -> [ByteString] -> IO [ByteString] - getLines handle acc = do - l <- B.hGetLine handle - if "OK" `isPrefixOf` l || "ACK" `isPrefixOf` l - then (return . reverse) (l:acc) - else getLines handle (l:acc) - - --- --- Other operations. --- - -ignore :: (Monad m) => m a -> m () -ignore x = x >> return () - --- | Kill the server. Obviously, the connection is then invalid. -kill :: (MonadMPD m) => m () -kill = ignore (send "kill") `catchError` cleanup - where - cleanup e = if e == TimedOut then close else throwError e - --- | Send a command to the MPD server and return the result. -getResponse :: (MonadMPD m) => String -> m [ByteString] -getResponse cmd = (send cmd >>= parseResponse) `catchError` sendpw - where - sendpw e@(ACK Auth _) = do - pw <- getPassword - if null pw then throwError e - else send ("password " ++ pw) >>= parseResponse - >> send cmd >>= parseResponse - sendpw e = - throwError e - --- Consume response and return a Response. -parseResponse :: (MonadError MPDError m) => [ByteString] -> m [ByteString] -parseResponse xs - | null xs = throwError $ NoMPD - | "ACK" `isPrefixOf` x = throwError $ parseAck x - | otherwise = return $ Prelude.takeWhile ("OK" /=) xs - where - x = head xs - --- Turn MPD ACK into the corresponding 'MPDError' -parseAck :: ByteString -> MPDError -parseAck s = ACK ack (UTF8.toString msg) - where - ack = case code of - 2 -> InvalidArgument - 3 -> InvalidPassword - 4 -> Auth - 5 -> UnknownCommand - 50 -> FileNotFound - 51 -> PlaylistMax - 52 -> System - 53 -> PlaylistLoad - 54 -> Busy - 55 -> NotPlaying - 56 -> FileExists - _ -> UnknownACK - (code, _, msg) = splitAck s - --- Break an ACK into (error code, current command, message). --- ACKs are of the form: --- ACK [error@command_listNum] {current_command} message_text\n -splitAck :: ByteString -> (Int, ByteString, ByteString) -splitAck s = (read code, cmd, msg) - where - (code, notCode) = between '[' '@' s - (cmd, notCmd) = between '{' '}' notCode - msg = drop 1 $ dropWhile (' ' ==) notCmd - - -- take whatever is between 'f' and 'g'. - between a b xs = let (_, y) = break (== a) xs - in break (== b) (drop 1 y) diff --git a/Network/MPD/Core/Class.hs b/Network/MPD/Core/Class.hs deleted file mode 100644 --- a/Network/MPD/Core/Class.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - --- | Module : Network.MPD.Core.Class --- Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 --- License : LGPL (see LICENSE) --- Maintainer : Joachim Fasting --- Stability : alpha --- --- The MPD typeclass. - -module Network.MPD.Core.Class where - -import System.IO (Handle) -import Data.ByteString (ByteString) - -import Network.MPD.Core.Error (MPDError) - -import Control.Monad.Error (MonadError) - -type Password = String - --- | A typeclass to allow for multiple implementations of a connection --- to an MPD server. -class (Monad m, MonadError MPDError m) => MonadMPD m where - -- | Open (or re-open) a connection to the MPD server. - open :: m () - -- | Close the connection. - close :: m () - -- | Send a string to the server and return its response. - send :: String -> m [ByteString] - -- | Get underlying Handle (or Nothing, if no connection is estabilished) - getHandle :: m (Maybe Handle) - -- | Produce a password to send to the server should it ask for - -- one. - getPassword :: m Password - -- | Alters password to be sent to the server. - setPassword :: Password -> m () - -- | Get MPD protocol version - getVersion :: m (Int, Int, Int) diff --git a/Network/MPD/Core/Error.hs b/Network/MPD/Core/Error.hs deleted file mode 100644 --- a/Network/MPD/Core/Error.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - --- | Module : Network.MPD.Core.Error --- Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 --- License : LGPL (see LICENSE) --- Maintainer : Joachim Fasting --- Stability : alpha --- --- MPD errors. - -module Network.MPD.Core.Error where - -import qualified Control.Exception as E -import Control.Monad.Error (Error(..)) -import Data.Typeable - --- | The MPDError type is used to signal errors, both from the MPD and --- otherwise. -data MPDError = NoMPD -- ^ MPD not responding - | TimedOut -- ^ The connection timed out - | Unexpected String -- ^ MPD returned an unexpected response. - -- This is a bug, either in the library or - -- in MPD itself. - | Custom String -- ^ Used for misc. errors - | ACK ACKType String -- ^ ACK type and a message from the - -- server - deriving (Eq, Typeable) - -instance E.Exception MPDError - -instance Show MPDError where - show NoMPD = "Could not connect to MPD" - show TimedOut = "MPD connection timed out" - show (Unexpected s) = "MPD returned an unexpected response: " ++ s - show (Custom s) = s - show (ACK _ s) = s - -instance Error MPDError where - noMsg = Custom "An error occurred" - strMsg = Custom - --- | Represents various MPD errors (aka. ACKs). -data ACKType = InvalidArgument -- ^ Invalid argument passed (ACK 2) - | InvalidPassword -- ^ Invalid password supplied (ACK 3) - | Auth -- ^ Authentication required (ACK 4) - | UnknownCommand -- ^ Unknown command (ACK 5) - | FileNotFound -- ^ File or directory not found ACK 50) - | PlaylistMax -- ^ Playlist at maximum size (ACK 51) - | System -- ^ A system error (ACK 52) - | PlaylistLoad -- ^ Playlist loading failed (ACK 53) - | Busy -- ^ Update already running (ACK 54) - | NotPlaying -- ^ An operation requiring playback - -- got interrupted (ACK 55) - | FileExists -- ^ File already exists (ACK 56) - | UnknownACK -- ^ An unknown ACK (aka. bug) - deriving Eq diff --git a/Network/MPD/Util.hs b/Network/MPD/Util.hs deleted file mode 100644 --- a/Network/MPD/Util.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | Module : Network.MPD.Util --- Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 --- License : LGPL (see LICENSE) --- Maintainer : Joachim Fasting --- Stability : alpha --- --- Utilities. - -module Network.MPD.Util ( - parseDate, parseIso8601, formatIso8601, parseNum, parseFrac, - parseBool, showBool, breakChar, parseTriple, - toAssoc, toAssocList, splitGroups, read - ) where - -import Data.Char (isDigit) -import Data.Time.Format (ParseTime, parseTime, FormatTime, formatTime) -import System.Locale (defaultTimeLocale) - -import qualified Prelude -import Prelude hiding (break, take, drop, takeWhile, dropWhile, read, reads) -import Data.ByteString.Char8 (break, take, drop, takeWhile, dropWhile, ByteString) -import qualified Data.ByteString.UTF8 as UTF8 -import Data.String - --- | Like Prelude.read, but works with ByteString. -read :: Read a => ByteString -> a -read = Prelude.read . UTF8.toString - --- | Like Prelude.reads, but works with ByteString. -reads :: Read a => ByteString -> [(a, String)] -reads = Prelude.reads . UTF8.toString - --- Break a string by character, removing the separator. -breakChar :: Char -> ByteString -> (ByteString, ByteString) -breakChar c s = let (x, y) = break (== c) s in (x, drop 1 y) - --- XXX: need a more robust date parser. --- Parse a date value. --- > parseDate "2008" = Just 2008 --- > parseDate "2008-03-01" = Just 2008 -parseDate :: ByteString -> Maybe Int -parseDate = parseNum . takeWhile isDigit - --- Parse date in iso 8601 format -parseIso8601 :: (ParseTime t) => ByteString -> Maybe t -parseIso8601 = parseTime defaultTimeLocale iso8601Format . UTF8.toString - -formatIso8601 :: FormatTime t => t -> String -formatIso8601 = formatTime defaultTimeLocale iso8601Format - -iso8601Format :: String -iso8601Format = "%FT%TZ" - --- Parse a positive or negative integer value, returning 'Nothing' on failure. -parseNum :: (Read a, Integral a) => ByteString -> Maybe a -parseNum s = do - [(x, "")] <- return (reads s) - return x - --- Parse C style floating point value, returning 'Nothing' on failure. -parseFrac :: (Fractional a, Read a) => ByteString -> Maybe a -parseFrac s = - case s of - "nan" -> return $ Prelude.read "NaN" - "inf" -> return $ Prelude.read "Infinity" - "-inf" -> return $ Prelude.read "-Infinity" - _ -> do [(x, "")] <- return $ reads s - return x - --- Inverts 'parseBool'. -showBool :: IsString a => Bool -> a --- FIXME: can we change the type to (Bool -> ByteString)? -showBool x = if x then "1" else "0" - --- Parse a boolean response value. -parseBool :: ByteString -> Maybe Bool -parseBool s = case take 1 s of - "1" -> Just True - "0" -> Just False - _ -> Nothing - --- Break a string into triple. -parseTriple :: Char -> (ByteString -> Maybe a) -> ByteString -> Maybe (a, a, a) -parseTriple c f s = let (u, u') = breakChar c s - (v, w) = breakChar c u' in - case (f u, f v, f w) of - (Just a, Just b, Just c') -> Just (a, b, c') - _ -> Nothing - --- Break a string into an key-value pair, separating at the first ':'. -toAssoc :: ByteString -> (ByteString, ByteString) -toAssoc x = (k, dropWhile (== ' ') $ drop 1 v) - where - (k,v) = break (== ':') x - -toAssocList :: [ByteString] -> [(ByteString, ByteString)] -toAssocList = map toAssoc - --- Takes an association list with recurring keys and groups each cycle of keys --- with their values together. There can be several keys that begin cycles, --- (the elements of the first parameter). -splitGroups :: [ByteString] -> [(ByteString, ByteString)] -> [[(ByteString, ByteString)]] -splitGroups groupHeads = go - where - go [] = [] - go (x:xs) = - let - (ys, zs) = Prelude.break isGroupHead xs - in - (x:ys) : go zs - - isGroupHead = (`elem` groupHeads) . fst diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,110 +1,70 @@ # libmpd-haskell: a client library for MPD ## About -libmpd-haskell is a client library for [MPD] written in [Haskell] that -aims to provide a safe and flexible yet consistent and intuitive -interface to MPD's external API. +libmpd-haskell is a pure [Haskell] client library for [MPD], the +music playing daemon. [MPD]: http://www.musicpd.org [Haskell]: http://www.haskell.org ## Getting -* [Latest release] -* `git clone git://github.com/joachifm/libmpd-haskell.git` - -[Latest release]: http://hackage.haskell.org/package/libmpd "libmpd-haskell on Hackage" +* [Latest release on Hackage] +* `git clone git://github.com/vimus/libmpd-haskell.git` -## Building -The preferred method of building libmpd-haskell is using [cabal-install], which -takes care of dependency resolution and other minutiae. +[Latest release on Hackage]: http://hackage.haskell.org/package/libmpd "libmpd-haskell on Hackage" -To install libmpd-haskell, simply run: +## Installation +With [cabal-install], do `cd libmpd-haskell && cabal install` [cabal-install]: http://hackage.haskell.org/package/cabal-install -## Running tests -To run the libmpd testsuite, do: - -`cabal configure --enable-tests && cabal build && cabal test` - -## Compiler support -We try to support the two last major versions of GHC, but only the latest -version (provided by the [haskell-platform]) is actually tested for. - -[haskell-platform]: http://www.haskell.org/platform - -## MPD API compliance -We try to comply with the latest version of the MPD protocol specification; -any deviation from this is a bug. - ## Usage With GHCi: > :set -XOverloadedStrings > import Network.MPD > withMPD $ lsInfo "" - Right [Left "Tool", Left "Tom Waits",...] + Right [LsDirectory "Tool", LsDirectory "Tom Waits",...] > withMPD $ add "Tom Waits/Big Time" Right ["Tom Waits/Big Time/01 - 16 Shells from a Thirty-Ought-Six.mp3",...] -## Development - -### Getting started -Create the clone thus: - -`git clone git://github.com/joachifm/libmpd-haskell.git master` - -To pull in new changes from upstream, use: - -`git pull origin master` +## MPD API compliance +Any deviation from the latest version of the [MPD protocol reference] +is a bug. -To set up GIT hooks, see `hooks/README` in the source distribution. +## Submitting bug reports +See our [bug tracker]. Test cases are highly appreciated. -### Submitting patches +## Submitting patches To submit a patch, use `git format-patch` and email the resulting file(s) to one of the developers or upload it to the [bug tracker]. -Alternatively you can create your own fork of the [repository] and send a pull -request. +Alternatively you can create your own fork of the [GitHub repository] and +send a pull request. Well-formatted patches are appreciated. New features should have a test case. -### Submitting bug reports -See our [bug tracker]. Test cases are highly appreciated. - -### Resources +## Resources * [API documentation] -* [libmpd-haskell mailing list] -* [Protocol reference] +* [MPD protocol reference] * [Using GitHub] -* \#libmpd-haskell @ irc.freenode.net (defunct) +* \#vimus @ irc.freenode.net -[libmpd-haskell mailing list]: http://groups.google.com/group/libmpd-haskell -[bug tracker]: http://github.com/joachifm/libmpd-haskell/issues +[bug tracker]: http://github.com/vimus/libmpd-haskell/issues [GitHub]: http://www.github.com -[repository]: http://www.github.com/joachifm/libmpd-haskell -[API documentation]: http://hackage.haskell.org/packages/archive/libmpd/0.7.2/doc/html/Network-MPD.html -[Protocol reference]: http://www.musicpd.org/doc/protocol/ +[GitHub repository]: http://www.github.com/vimus/libmpd-haskell +[API documentation]: http://hackage.haskell.org/packages/archive/libmpd/latest/doc/html/Network-MPD.html +[MPD protocol reference]: http://www.musicpd.org/doc/protocol/ [Using GitHub]: http://help.github.com ## License -LGPL version 2.1 (see LICENSE) - -## Contributors (in order of appearance) -Ben Sinclair \ - -Joachim Fasting \ - -gwern0 \ - -Daniel Schoepe \ - -Andrzej Rybczak \ - -Simon Hengel \ +libmpd-haskell is distributed under the [MIT license]. -Daniel Wagner \ +[MIT license]: http://www.opensource.org/licenses/MIT -nandykins +## Contributors +See `CONTRIBUTORS` in the source distribution. +Feel free to add yourself to this list if you deem it appropriate +to do so. diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,118 @@ +* v0.9.0, 2014-09-21 + - New commands: `deleteRange`, `moveRange`, `playlistInfoRange`, + `searchAdd`, `searchAddpl`. + - Fix `playlistId` and `list` + - Add Mixramp commands + - Support for MPD 0.17 + - Support for missing metadata keys. + - Sticker idle events + - Subscription and message events + - New applicative interface which allows combining arbitrary commands + into command lists (sol). + - Consistent typing for song positions (sol). + - Command definitions closer to the MPD spec; compound commands + have been moved to `N.M.C.Extensions`. + - `Status.{stUpdatingDb,stTime,stBitrate,stVolume` are now `Maybe` + - `MonadMPD.getHandle` has been removed + - Re-connect and retry on `ResourceVanished` (e.g., when the + connection times out). + +* v0.8.0, 2012-04-21 + - Use bytestring for wire communication (sol) + - Increased type safety (sol) + - Improved memory usage (sol) + - `lsinfo` supports playlists (nandykins) + - `idle` now takes a list of subsystems (sol) + - `currentSong` works when playback is stopped (sol) + - Fixes failure on songs without associated paths (sol) + - `LsResult` replaces `EntryType` (nandykins) + - hspec based testing added to the test-suite + - More extensive parser testing + - 'MPDError' now has an 'Exception' instance + - Lower bound on Cabal bumped to 1.10 + +* v0.7.2, 2012-02-13 + - Release connections. Reported by Kanisterschleife on GitHub. + - Some minor internal changes (sol) + +* v0.7.1, 2012-02-07 + - Compatible with GHC 7.4.1 + +* v0.7.0, 2011-11-22 + - Several fixes to the test harness (Simon Hengel) + - Fixed issue with the (<$>) operator (Simon Hengel) + - Type safe handling of song IDs (Simon Hengel) + - Check MPD version on connect (now depends on MPD >= 0.15) (Simon Hengel) + - Compatibility with GHC 7.2 (Daniel Wagner) + +* v0.6.0, 2011-04-01 + - Reverted some changes from 0.5.0 that caused problems, + most notably the parser improvements have been removed for now. + - Support for GHC 7 + - Removed support for building against the deprecated base 3 package + - Added an `Enum' instance for `Metadata' + - Removed the `old_base' flag + +* v0.5.0, 2010-09-08 + - Moved extensions to Network.MPD.Commands.Extensions + These might be removed in a later version + - Non-blocking `idle' + - The API is closer to the MPD spec, by untangling functionality + - Better MPD API coverage + - Improved parser implementation, now runs in constant space + - Constructors of the `Subsystem' type have been renamed + - Passwords can be changed using `setPassword' + - The connection handle can be accessed via `getHandle' + - The version of the MPD server is available via `getVersion' + - Added support for connecting via unix sockets + +* v0.4.2, 2010-08-31 + - Only depend on QuickCheck when building the test target + +* v0.4.1, 2010-03-26 + - Fix building test and coverage targets + +* v0.4.0, 2010-03-26 + - New maintainer: Joachim Fasting + - Support QuickCheck 2 + - Better MPD api support + Should be mostly compatible with mpd 0.16 + - Separated operations on current playlist from those on specific + playlists + - Fixed password sending + - Several minor fixes and cleanups + +* v0.3.1, 2008-09-14 + - Now reconnects if MPD closes the connection. + +* v0.3.0, 2008-05-06 + - UTF-8 support (now depends on utf8-string package). + - Fixed corruption by `show' of command parameters. + - Tidied up `Query' interface. + - Moved StringConn out of Network.MPD to the tests directory. + +* v0.2.1, 2008-04-14 + - Cleaned up libmpd.cabal. + +* v0.2.0, 2008-04-14 + - A connection stub for testing purposes. + - QuickCheck tests for parsing. + - Partial unit test coverage. + - Many bug fixes. + - Precise error handling. + - Parsing improvements. + - Code coverage generation. + - Cabal 1.2 support. + - Uniform command names. + +* v0.1.3, 2007-10-02 + - Bugfixes. + +* v0.1.2, 2007-09-29 + - Changed name to libmpd. + +* v0.1.1, 2007-09-28 + - Missing files added to the source distribution. + +* v0.1, 2007-09-28 + - Initial public release. diff --git a/libmpd.cabal b/libmpd.cabal --- a/libmpd.cabal +++ b/libmpd.cabal @@ -1,31 +1,29 @@ Name: libmpd -Version: 0.8.0.5 +Version: 0.9.0 Synopsis: An MPD client library. -Description: A client library for MPD, the Music Player Daemon - (). +Description: A client library for MPD, the Music Player Daemon. Category: Network, Sound -License: LGPL +License: MIT License-file: LICENSE -Copyright: Ben Sinclair 2005-2009, Joachim Fasting 2014 +Copyright: Ben Sinclair 2005-2009, Joachim Fasting 2012-2014 Author: Ben Sinclair Maintainer: Joachim Fasting Stability: beta -Homepage: http://github.com/joachifm/libmpd-haskell#readme -Bug-reports: http://github.com/joachifm/libmpd-haskell/issues +Homepage: http://github.com/vimus/libmpd-haskell#readme +Bug-reports: http://github.com/vimus/libmpd-haskell/issues -Tested-With: GHC == 7.0.2 +Tested-With: GHC ==7.6.3, GHC ==7.8.3 Build-Type: Simple Cabal-Version: >= 1.10 Extra-Source-Files: README.md - NEWS + changelog.md tests/Arbitrary.hs tests/CommandSpec.hs tests/EnvSpec.hs - tests/Defaults.hs tests/ParserSpec.hs tests/StringConn.hs tests/TestUtil.hs @@ -35,27 +33,43 @@ Source-Repository head type: git - location: https://github.com/joachifm/libmpd-haskell + location: https://github.com/vimus/libmpd-haskell Library Default-Language: Haskell2010 + Hs-Source-Dirs: src + Build-Depends: + -- Platform dependencies base >= 4 && < 5 - , mtl >= 2.0 && < 3 - , network >= 2.1 && < 2.6 - , filepath >= 1.0 && < 1.4 - , utf8-string >= 0.3.1 && < 0.4 - , old-locale >= 1.0 && < 2.0 - , time >= 1.1 && < 2.0 - , containers >= 0.3 && < 0.6 - , data-default >= 0.4.0 && < 0.6 + , attoparsec >= 0.10.1 && < 1 , bytestring >= 0.9 && < 1 - , text >= 0.11 - , attoparsec >= 0.10.1 && < 0.13 + , containers >= 0.3 && < 1 + , filepath >= 1 && < 2 + , mtl >= 2.0 && < 3 + , old-locale >= 1 && < 2 + , text >= 0.11 && < 2 + , time >= 1.1 && < 2 + -- Additional dependencies + , data-default >= 0.4 && < 1 + , network >= 2.1 && < 3 + , utf8-string >= 0.3.1 && < 1 + Exposed-Modules: Network.MPD + , Network.MPD.Applicative + , Network.MPD.Applicative.Connection + , Network.MPD.Applicative.CurrentPlaylist + , Network.MPD.Applicative.Database + , Network.MPD.Applicative.Output + , Network.MPD.Applicative.PlaybackControl + , Network.MPD.Applicative.PlaybackOptions + , Network.MPD.Applicative.Reflection + , Network.MPD.Applicative.Status + , Network.MPD.Applicative.Stickers + , Network.MPD.Applicative.StoredPlaylists , Network.MPD.Commands.Extensions , Network.MPD.Core @@ -67,7 +81,18 @@ , Network.MPD.Commands.Parse , Network.MPD.Commands.Query , Network.MPD.Commands.Types - , Network.MPD.Commands.Util + , Network.MPD.Commands.Status + , Network.MPD.Commands.PlaybackOptions + , Network.MPD.Commands.PlaybackControl + , Network.MPD.Commands.CurrentPlaylist + , Network.MPD.Commands.StoredPlaylists + , Network.MPD.Commands.Database + , Network.MPD.Commands.Stickers + , Network.MPD.Commands.Connection + , Network.MPD.Commands.Output + , Network.MPD.Commands.Reflection + , Network.MPD.Applicative.Util + , Network.MPD.Applicative.Internal , Network.MPD.Util ghc-prof-options: -auto-all -prof @@ -76,23 +101,29 @@ Test-Suite specs type: exitcode-stdio-1.0 Default-Language: Haskell2010 - Main-Is: tests/Main.hs - Hs-Source-Dirs: . tests - cpp-options: -DTEST + Main-Is: Main.hs + Hs-Source-Dirs: src tests + cpp-options: -DTEST -Wall -Werror ghc-options: -fno-warn-missing-signatures Build-Depends: + -- Platform dependencies base - , utf8-string + , attoparsec , bytestring - , old-locale - , network + , containers + , filepath , mtl + , old-locale , text - , containers + , time + + -- Additional dependencies , data-default + , network + , utf8-string + + -- Test dependencies , unix - , time , QuickCheck >= 2.1 - , hspec - , HUnit + , hspec >= 1.3 diff --git a/src/Network/MPD.hs b/src/Network/MPD.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE CPP #-} + +{- | +Module : Network.MPD +Copyright : (c) Joachim Fasting, Simon Hengel 2012 +License : MIT + +Maintainer : Joachim Fasting +Stability : unstable +Portability : unportable + +An MPD client library. MPD is a daemon for playing music that is +controlled over a network socket. + +To use the library, do: + +> {-# LANGUAGE OverloadedStrings #-} +> import qualified Network.MPD as MPD +-} + +module Network.MPD ( + -- * Basic data types + MonadMPD, MPD, MPDError(..), ACKType(..), Response, + Host, Port, Password, + -- * Connections + withMPD, withMPD_, withMPDEx, + module Network.MPD.Commands, +#ifdef TEST + getConnectionSettings, getEnvDefault +#endif + ) where + +import Prelude +import qualified Control.Exception as E +import Network.MPD.Commands +import Network.MPD.Core + +import System.Environment (getEnv) +import System.IO.Error (isDoesNotExistError) +import Data.Maybe (listToMaybe) + +-- | A wrapper for 'withMPDEx' that uses localhost:6600 as the default +-- host:port, or whatever is found in the environment variables MPD_HOST and +-- MPD_PORT. If MPD_HOST is of the form \"password\@host\" the password +-- will be supplied as well. +-- +-- Examples: +-- +-- > withMPD $ play Nothing +-- > withMPD $ add_ "tool" >> play Nothing >> currentSong +withMPD :: MPD a -> IO (Response a) +withMPD = withMPD_ Nothing Nothing + +-- | Same as `withMPD`, but takes optional arguments that override MPD_HOST and +-- MPD_PORT. +-- +-- This is e.g. useful for clients that optionally take @--port@ and @--host@ +-- as command line arguments, and fall back to `withMPD`'s defaults if those +-- arguments are not given. +withMPD_ :: Maybe String -- ^ optional override for MPD_HOST + -> Maybe String -- ^ optional override for MPD_PORT + -> MPD a -> IO (Response a) +withMPD_ mHost mPort action = do + settings <- getConnectionSettings mHost mPort + case settings of + Right (host, port, pw) -> withMPDEx host port pw action + Left err -> (return . Left . Custom) err + +getConnectionSettings :: Maybe String -> Maybe String -> IO (Either String (Host, Port, Password)) +getConnectionSettings mHost mPort = do + (host, pw) <- parseHost `fmap` + maybe (getEnvDefault "MPD_HOST" "localhost") return mHost + port <- maybe (getEnvDefault "MPD_PORT" "6600") return mPort + case maybeRead port of + Just p -> (return . Right) (host, p, pw) + Nothing -> (return . Left) (show port ++ " is not a valid port!") + where + parseHost s = case breakChar '@' s of + (host, "") -> (host, "") + (pw, host) -> (host, pw) + +getEnvDefault :: String -> String -> IO String +getEnvDefault x dflt = + E.catch (getEnv x) (\e -> if isDoesNotExistError e + then return dflt else ioError e) + +-- Break a string by character, removing the separator. +breakChar :: Char -> String -> (String, String) +breakChar c s = let (x, y) = break (== c) s in (x, drop 1 y) + +maybeRead :: Read a => String -> Maybe a +maybeRead = fmap fst . listToMaybe . reads diff --git a/src/Network/MPD/Applicative.hs b/src/Network/MPD/Applicative.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Applicative.hs @@ -0,0 +1,47 @@ +module Network.MPD.Applicative ( + Command +, runCommand + +-- * Querying MPD's status +, module Network.MPD.Applicative.Status + +-- * Playback options +, module Network.MPD.Applicative.PlaybackOptions + +-- * Controlling playback +, module Network.MPD.Applicative.PlaybackControl + +-- * The current playlist +, module Network.MPD.Applicative.CurrentPlaylist + +-- * Stored playlists +, module Network.MPD.Applicative.StoredPlaylists + +-- * The music database +, module Network.MPD.Applicative.Database + +-- * Stickers +, module Network.MPD.Applicative.Stickers + +-- * Connection settings +, module Network.MPD.Applicative.Connection + +-- * Audio output devices +, module Network.MPD.Applicative.Output + +-- * Reflection +, module Network.MPD.Applicative.Reflection +) where + +import Network.MPD.Applicative.Internal + +import Network.MPD.Applicative.Connection +import Network.MPD.Applicative.CurrentPlaylist +import Network.MPD.Applicative.Database +import Network.MPD.Applicative.Output +import Network.MPD.Applicative.PlaybackControl +import Network.MPD.Applicative.PlaybackOptions +import Network.MPD.Applicative.Reflection +import Network.MPD.Applicative.Status +import Network.MPD.Applicative.Stickers +import Network.MPD.Applicative.StoredPlaylists diff --git a/src/Network/MPD/Applicative/Connection.hs b/src/Network/MPD/Applicative/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Applicative/Connection.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Network.MPD.Applicative.Connection +Copyright : (c) Joachim Fasting 2012 +License : MIT + +Maintainer : joachim.fasting@gmail.com +Stability : stable +Portability : unportable + +Connection settings. +-} + +module Network.MPD.Applicative.Connection + ( password + , ping + ) where + +import Network.MPD.Applicative.Internal +import Network.MPD.Core + +-- | Authenticate session. The password is sent in plain text. +password :: Password -> Command () +password pwd = Command emptyResponse ["password " ++ pwd] + +-- | Ping daemon. +ping :: Command () +ping = Command emptyResponse ["ping"] diff --git a/src/Network/MPD/Applicative/CurrentPlaylist.hs b/src/Network/MPD/Applicative/CurrentPlaylist.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Applicative/CurrentPlaylist.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Network.MPD.Applicative.CurrentPlaylist +Copyright : (c) Joachim Fasting 2012 +License : MIT + +Maintainer : joachim.fasting@gmail.com +Stability : stable +Portability : unportable + +The current playlist. +-} + +module Network.MPD.Applicative.CurrentPlaylist + ( add + , addId + , clear + , delete + , deleteRange + , deleteId + , move + , moveId + , moveRange + , playlistFind + , playlistInfo + , playlistInfoRange + , playlistId + , playlistSearch + , plChanges + , plChangesPosId + , shuffle + , swap + , swapId + ) where + +import Network.MPD.Commands.Arg hiding (Command) +import qualified Network.MPD.Commands.Arg as Arg +import Network.MPD.Util +import Network.MPD.Commands.Query +import Network.MPD.Commands.Parse +import Network.MPD.Commands.Types +import Network.MPD.Applicative.Internal +import Network.MPD.Applicative.Util + +-- | Add a song (or a whole directory) to the current playlist. +add :: Path -> Command () +add path = Command emptyResponse ["add" <@> path] + +-- | Add a song (non-recursively) and return its id. +addId :: Path -> Maybe Position -> Command Id +addId path pos = Command p c + where + c = ["addid" <@> path <++> pos] + p = do + r <- getResponse + case toAssocList r of + [("Id", n)] -> maybe (unexpected r) (return . Id) (parseNum n) + _ -> unexpected r + +-- | Clear the current playlist. +clear :: Command () +clear = Command emptyResponse ["clear"] + +-- | Delete song at the given playlist position. +delete :: Position -> Command () +delete pos = Command emptyResponse ["delete" <@> pos] + +-- XXX: this does not exist in the monadic version +-- | Delete a range of songs from the playlist. +deleteRange :: (Position, Position) -> Command () +deleteRange range = Command emptyResponse ["delete" <@> range] + +-- | Delete song by id. +deleteId :: Id -> Command () +deleteId i = Command emptyResponse ["deleteid" <@> i] + +-- | Move song from one position to another. +move :: Position -> Position -> Command () +move pos to = Command emptyResponse ["move" <@> pos <++> to] + +-- | Move a range of songs. +moveRange :: (Position, Position) -> Position -> Command () +moveRange range to = Command emptyResponse ["move" <@> range <++> to] + +-- | Move song id to position. +-- If the position is negative, it is relative to the current song. +moveId :: Id -> Position -> Command () +moveId i to = Command emptyResponse ["moveid" <@> i <++> to] + +-- Note: 'playlist' deliberately not defined here + +-- Internal helper for playlist* commands +playlist' :: MPDArg a => Arg.Command -> a -> Command [Song] +playlist' cmd q = Command (liftParser takeSongs) [cmd <@> q] + +-- | Find songs in current playlist with strict matching. +playlistFind :: Query -> Command [Song] +playlistFind = playlist' "playlistfind" + +-- | Get song metadata for all items in the current playlist. +-- Optionally restrict listing the song at the given position. +playlistInfo :: Maybe Position -> Command [Song] +playlistInfo = playlist' "playlistinfo" + +-- | Like 'playlistInfo' but can restrict listing to a range +-- of songs. +playlistInfoRange :: Maybe (Position, Position) -> Command [Song] +playlistInfoRange = playlist' "playlistinfo" + +-- | Get song metadata for all items in the current playlist. +-- Optionally restrict selection to a single song id. +playlistId :: Maybe Id -> Command [Song] +playlistId = playlist' "playlistid" + +-- | Search case-insensitively for partial matches in current playlist. +playlistSearch :: Query -> Command [Song] +playlistSearch = playlist' "playlistsearch" + +-- | Get song metadata for items that have changed in the playlist since +-- the given playlist version. +plChanges :: Integer -> Command [Song] +plChanges = playlist' "plchanges" + +-- | Get positions and ids of songs that have changed in the playlist +-- since the given playlist version. +plChangesPosId :: Integer -> Command [(Position, Id)] +plChangesPosId ver = Command p ["plchangesposid" <@> ver] + where + -- XXX: possibly suboptimal definition + p :: Parser [(Position, Id)] + p = liftParser $ mapM f . splitGroups ["cpos"] . toAssocList + f xs | [("cpos", x), ("Id", y)] <- xs + , Just (x', y') <- pair parseNum (x, y) + = Right (x', Id y') + | otherwise = Left "" + +-- | Shuffle the current playlist. +-- Optionally restrict to a range of songs. +shuffle :: Maybe (Position, Position) -> Command () +shuffle mbRange = Command emptyResponse ["shuffle" <@> mbRange] + +-- | Swap songs by position. +swap :: Position -> Position -> Command () +swap pos1 pos2 = Command emptyResponse ["swap" <@> pos1 <++> pos2] + +-- | Swap songs by id. +swapId :: Id -> Id -> Command () +swapId id1 id2 = Command emptyResponse ["swapid" <@> id1 <++> id2] diff --git a/src/Network/MPD/Applicative/Database.hs b/src/Network/MPD/Applicative/Database.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Applicative/Database.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Network.MPD.Applicative.Database +Copyright : (c) Joachim Fasting 2012 +License : MIT + +Maintainer : joachim.fasting@gmail.com +Stability : stable +Portability : unportable + +The music database. +-} + +module Network.MPD.Applicative.Database where + +import Control.Applicative + +import qualified Network.MPD.Commands.Arg as Arg +import Network.MPD.Commands.Arg hiding (Command) +import Network.MPD.Commands.Parse +import Network.MPD.Commands.Query +import Network.MPD.Util +import Network.MPD.Commands.Types +import Network.MPD.Applicative.Internal +import Network.MPD.Applicative.Util + +-- | Get a count of songs and their total playtime that exactly match the +-- query. +count :: Query -> Command Count +count q = Command (liftParser parseCount) ["count" <@> q] + +-- | Find songs matching the query exactly. +find :: Query -> Command [Song] +find q = Command p ["find" <@> q] + where + p :: Parser [Song] + p = liftParser takeSongs + +-- | Like 'find' but adds the results to the current playlist. +findAdd :: Query -> Command () +findAdd q = Command emptyResponse ["findadd" <@> q] + +-- | Lists all tags of the specified type. +-- +-- Note that the optional artist value is only ever used if the +-- metadata type is 'Album', and is then taken to mean that the albums +-- by that artist be listed. +list :: Metadata -> Maybe Artist -> Command [Value] +list m q = Command p c + where + p = map Value . takeValues <$> getResponse + c = case m of + Album -> ["list Album" <@> q] + _ -> ["list" <@> m] + +-- | List all songs and directories in a database path. +listAll :: Path -> Command [Path] +listAll path = Command p ["listall" <@> path] + where + p :: Parser [Path] + p = map (Path . snd) . filter ((== "file") . fst) + . toAssocList <$> getResponse + +-- Internal helper +lsInfo' :: Arg.Command -> Path -> Command [LsResult] +lsInfo' cmd path = Command p [cmd <@> path] + where + p :: Parser [LsResult] + p = liftParser takeEntries + +-- | Same as 'listAll' but also returns metadata. +listAllInfo :: Path -> Command [LsResult] +listAllInfo = lsInfo' "listallinfo" + +-- | List the contents of a database directory. +lsInfo :: Path -> Command [LsResult] +lsInfo = lsInfo' "lsinfo" + +-- | Like 'find' but with inexact matching. +search :: Query -> Command [Song] +search q = Command p ["search" <@> q] + where + p :: Parser [Song] + p = liftParser takeSongs + +-- | Like 'search' but adds the results to the current playlist. +-- +-- Since MPD 0.17. +searchAdd :: Query -> Command () +searchAdd q = Command emptyResponse ["searchadd" <@> q] + +-- | Like 'searchAdd' but adds results to the named playlist. +-- +-- Since MPD 0.17. +searchAddPl :: PlaylistName -> Query -> Command () +searchAddPl pl q = Command emptyResponse ["searchaddpl" <@> pl <++> q] + +-- | Update the music database. +-- If no path is supplied, the entire database is updated. +update :: Maybe Path -> Command Integer +update = update_ "update" + +-- | Like 'update' but also rescan unmodified files. +rescan :: Maybe Path -> Command Integer +rescan = update_ "rescan" + +-- A helper for 'update' and 'rescan. +update_ :: Arg.Command -> Maybe Path -> Command Integer +update_ cmd mPath = Command p [cmd <@> mPath] + where + p :: Parser Integer + p = do + r <- getResponse + case toAssocList r of + [("updating_db", id_)] -> maybe (unexpected r) + return + (parseNum id_) + _ -> unexpected r diff --git a/src/Network/MPD/Applicative/Internal.hs b/src/Network/MPD/Applicative/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Applicative/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 : joachim.fasting@gmail.com +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 Network.MPD.Applicative.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" diff --git a/src/Network/MPD/Applicative/Output.hs b/src/Network/MPD/Applicative/Output.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Applicative/Output.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Network.MPD.Applicative.Output +Copyright : (c) Joachim Fasting 2012 +License : MIT + +Maintainer : joachim.fasting@gmail.com +Stability : stable +Portability : unportable + +Audio output devices. +-} + +module Network.MPD.Applicative.Output + ( disableOutput + , enableOutput + , outputs + ) where + +import Network.MPD.Applicative.Internal +import Network.MPD.Commands.Arg hiding (Command) +import Network.MPD.Commands.Parse +import Network.MPD.Commands.Types + +-- | Turn off output. +disableOutput :: Int -> Command () +disableOutput n = Command emptyResponse ["disableoutput" <@> n] + +-- | Turn on output. +enableOutput :: Int -> Command () +enableOutput n = Command emptyResponse ["enableoutput" <@> n] + +-- | Get information about all available output devices. +outputs :: Command [Device] +outputs = Command (liftParser parseOutputs) ["outputs"] diff --git a/src/Network/MPD/Applicative/PlaybackControl.hs b/src/Network/MPD/Applicative/PlaybackControl.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Applicative/PlaybackControl.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Network.MPD.Applicative.PlaybackControl +Copyright : (c) Joachim Fasting 2012 +License : MIT + +Maintainer : joachim.fasting@gmail.com +Stability : stable +Portability : unportable + +Controlling playback. +-} + +module Network.MPD.Applicative.PlaybackControl + ( next + , pause + , play + , playId + , previous + , seek + , seekId + , stop + ) where + +import Network.MPD.Applicative.Internal +import Network.MPD.Commands.Arg hiding (Command) +import Network.MPD.Commands.Types + +-- | Play next song in the playlist. +next :: Command () +next = Command emptyResponse ["next"] + +-- | Toggle pause. +pause :: Bool -> Command () +pause f = Command emptyResponse ["pause" <@> f] + +-- | Begin playback (optionally at a specific position). +play :: Maybe Position -> Command () +play mbPos = Command emptyResponse c + where + c = return $ maybe "play" ("play" <@>) mbPos + +-- | Begin playback at the specified song id. +playId :: Id -> Command () +playId id' = Command emptyResponse ["playid" <@> id'] + +-- | Play previous song. +previous :: Command () +previous = Command emptyResponse ["previous"] + +-- | Seek to time in the song at the given position. +seek :: Position -> Seconds -> Command () +seek pos time = Command emptyResponse ["seek" <@> pos <++> time] + +-- | Seek to time in the song with the given id. +seekId :: Id -> Seconds -> Command () +seekId id' time = Command emptyResponse ["seekid" <@> id' <++> time] + +-- | Stop playback. +stop :: Command () +stop = Command emptyResponse ["stop"] diff --git a/src/Network/MPD/Applicative/PlaybackOptions.hs b/src/Network/MPD/Applicative/PlaybackOptions.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Applicative/PlaybackOptions.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Network.MPD.Applicative.PlaybackOptions +Copyright : (c) Joachim Fasting 2012 +License : MIT + +Maintainer : joachim.fasting@gmail.com +Stability : stable +Portability : unportable + +Playback options +-} + +module Network.MPD.Applicative.PlaybackOptions + ( consume + , crossfade + , random + , repeat + , setVolume + , single + , replayGainMode + , replayGainStatus + , mixrampDb + , mixrampDelay + ) where + +import Network.MPD.Applicative.Internal +import Network.MPD.Applicative.Util +import Network.MPD.Commands.Arg hiding (Command) +import Network.MPD.Commands.Types +import Network.MPD.Util (toAssocList) + +import Control.Applicative +import Prelude hiding (repeat) + +-- | Toggle consume mode. +consume :: Bool -> Command () +consume f = Command emptyResponse ["consume" <@> f] + +-- | Set crossfading between songs. +crossfade :: Seconds -> Command () +crossfade secs = Command emptyResponse ["crossfade" <@> secs] + +-- | Toggle random mode. +random :: Bool -> Command () +random f = Command emptyResponse ["random" <@> f] + +-- | Toggle repeat mode. +repeat :: Bool -> Command () +repeat f = Command emptyResponse ["repeat" <@> f] + +-- | Set volume in percent. +setVolume :: Int -> Command () +setVolume vol = Command emptyResponse ["setvol" <@> vol] + +-- | Toggle single mode. +single :: Bool -> Command () +single f = Command emptyResponse ["single" <@> f] + +-- | Set replay gain mode. +replayGainMode :: ReplayGainMode -> Command () +replayGainMode f = Command emptyResponse ["replay_gain_mode" <@> f] + +-- | Get replay gain status: option name and its value. +replayGainStatus :: Command [(String, String)] +replayGainStatus = Command p ["replay_gain_status"] + where + p = map decodePair . toAssocList <$> getResponse + +-- | Set MixRamp overlap threshold. +-- 0dB is the normalized maximum value; use negative values to adjust it. +-- +-- Songs must have MixRamp tags set by an external tool for this to +-- work; crossfading is used if no tags are present. +mixrampDb :: Decibels -> Command () +mixrampDb db = Command emptyResponse ["mixrampdb" <@> db] + +-- | Additional time subtracted from the overlap calculated by +-- 'mixrampDb'. +-- "NaN" disables MixRamp overlapping and reverts to crossfading. +mixrampDelay :: Seconds -> Command () +mixrampDelay sec = Command emptyResponse ["mixrampdelay" <@> sec] diff --git a/src/Network/MPD/Applicative/Reflection.hs b/src/Network/MPD/Applicative/Reflection.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Applicative/Reflection.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Network.MPD.Applicative.Reflection +Copyright : (c) Joachim Fasting 2012 +License : MIT + +Maintainer : joachim.fasting@gmail.com +Stability : stable +Portability : unportable + +Reflection. +-} + +module Network.MPD.Applicative.Reflection + ( commands + , notCommands + , tagTypes + , urlHandlers + , decoders + , config + ) where + +import Network.MPD.Util +import Network.MPD.Applicative.Internal +import Network.MPD.Applicative.Util + +import Control.Applicative +import Prelude hiding (repeat, read) + +import qualified Data.ByteString.UTF8 as UTF8 + +-- | Get a list of available commands. +commands :: Command [String] +commands = Command p ["commands"] + where + p = map UTF8.toString . takeValues <$> getResponse + +-- | Get a list of unavailable commands (i.e., commands that require +-- an authenticated session). +notCommands :: Command [String] +notCommands = Command p ["notcommands"] + where + p = map UTF8.toString . takeValues <$> getResponse + +-- | Get a list of available song metadata. +tagTypes :: Command [String] +tagTypes = Command p ["tagtypes"] + where + p = map UTF8.toString . takeValues <$> getResponse + +-- | Get a list of available URL handlers. +urlHandlers :: Command [String] +urlHandlers = Command p ["urlhandlers"] + where + p = map UTF8.toString . takeValues <$> getResponse + +-- | Get a list of available decoder plugins, with their supported +-- suffixes and MIME types. +decoders :: Command [(String, [(String, String)])] +decoders = Command p ["decoders"] + where + p = takeDecoders . toAssocList <$> getResponse + + takeDecoders [] = [] + takeDecoders ((_, m):xs) = + let (info, rest) = break ((==) "plugin" . fst) xs + in (UTF8.toString m, map decodePair info) : takeDecoders rest + +-- | Get configuration values of interest to a client. +-- +-- Note: only permitted for clients connected via a unix domain +-- socket (aka \"local clients\"). +config :: Command [(String, String)] +config = Command p ["config"] + where + p = map (\(k, v) -> (UTF8.toString k, UTF8.toString v)) . toAssocList <$> getResponse diff --git a/src/Network/MPD/Applicative/Status.hs b/src/Network/MPD/Applicative/Status.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Applicative/Status.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Network.MPD.Applicative.Status +Copyright : (c) Joachim Fasting 2012 +License : MIT + +Maintainer : joachim.fasting@gmail.com +Stability : stable +Portability : unportable + +Querying MPD's status. +-} + +module Network.MPD.Applicative.Status + ( clearError + , currentSong + , idle + , noidle + , status + , stats + ) where +import Control.Monad +import Control.Arrow ((***)) + +import Network.MPD.Util +import Network.MPD.Applicative.Internal +import Network.MPD.Commands.Arg hiding (Command) +import Network.MPD.Commands.Parse +import Network.MPD.Commands.Types + +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.UTF8 as UTF8 + +-- | Clear current error message in status. +clearError :: Command () +clearError = Command emptyResponse ["clearerror"] + +-- | Song metadata for currently playing song, if any. +currentSong :: Command (Maybe Song) +currentSong = Command (liftParser parseMaybeSong) ["currentsong"] + +takeSubsystems :: [ByteString] -> Either String [Subsystem] +takeSubsystems = mapM f . toAssocList + where + f :: (ByteString, ByteString) -> Either String Subsystem + f ("changed", system) = + case system of + "database" -> Right DatabaseS + "update" -> Right UpdateS + "stored_playlist" -> Right StoredPlaylistS + "playlist" -> Right PlaylistS + "player" -> Right PlayerS + "mixer" -> Right MixerS + "output" -> Right OutputS + "options" -> Right OptionsS + k -> Left ("Unknown subsystem: " ++ UTF8.toString k) + f x = Left ("idle: Unexpected " ++ show x) + +-- | Wait until there is noteworthy change in one or more of MPD's +-- subsystems. +-- When active, only 'noidle' commands are allowed. +idle :: [Subsystem] -> Command [Subsystem] +idle ss = Command (liftParser takeSubsystems) c + where + c = ["idle" <@> foldr (<++>) (Args []) ss] + +-- | Cancel an 'idle' request. +noidle :: Command () +noidle = Command emptyResponse ["noidle"] + +-- | Get database statistics. +stats :: Command Stats +stats = Command (liftParser parseStats) ["stats"] + +-- | Get the current status of the player. +status :: Command Status +status = Command (liftParser parseStatus) ["status"] + where + -- Builds a 'Status' instance from an assoc. list. + parseStatus :: [ByteString] -> Either String Status + parseStatus = foldM go def . toAssocList + where + go a p@(k, v) = case k of + "volume" -> vol $ \x -> a { stVolume = x } + "repeat" -> bool $ \x -> a { stRepeat = x } + "random" -> bool $ \x -> a { stRandom = x } + "single" -> bool $ \x -> a { stSingle = x } + "consume" -> bool $ \x -> a { stConsume = x } + "playlist" -> num $ \x -> a { stPlaylistVersion = x } + "playlistlength" -> num $ \x -> a { stPlaylistLength = x } + "state" -> state $ \x -> a { stState = x } + "song" -> int $ \x -> a { stSongPos = Just x } + "songid" -> int $ \x -> a { stSongID = Just $ Id x } + "nextsong" -> int $ \x -> a { stNextSongPos = Just x } + "nextsongid" -> int $ \x -> a { stNextSongID = Just $ Id x } + "time" -> time $ \x -> a { stTime = Just x } + "elapsed" -> frac $ \x -> a { stTime = fmap ((,) x . snd) (stTime a) } + "bitrate" -> int $ \x -> a { stBitrate = Just x } + "xfade" -> num $ \x -> a { stXFadeWidth = x } + "mixrampdb" -> frac $ \x -> a { stMixRampdB = x } + "mixrampdelay" -> frac $ \x -> a { stMixRampDelay = x } + "audio" -> audio $ \x -> a { stAudio = x } + "updating_db" -> num $ \x -> a { stUpdatingDb = Just x } + "error" -> Right a { stError = Just (UTF8.toString v) } + _ -> unexpectedPair + where + unexpectedPair = Left ("unexpected key-value pair: " ++ show p) + int f = maybe unexpectedPair (Right . f) (parseNum v :: Maybe Int) + num f = maybe unexpectedPair (Right . f) (parseNum v) + bool f = maybe unexpectedPair (Right . f) (parseBool v) + frac f = maybe unexpectedPair (Right . f) (parseFrac v) + + -- This is sometimes "audio: 0:?:0", so we ignore any parse + -- errors. + audio f = Right $ maybe a f (parseTriple ':' parseNum v) + + time f = case parseFrac *** parseNum $ breakChar ':' v of + (Just a_, Just b) -> (Right . f) (a_, b) + _ -> unexpectedPair + + state f = case v of + "play" -> (Right . f) Playing + "pause" -> (Right . f) Paused + "stop" -> (Right . f) Stopped + _ -> unexpectedPair + + -- A volume of -1 indicates an audio backend w/o a mixer + vol f = case parseNum v of + Nothing -> unexpectedPair -- does it really make sense to fail here? when does this occur? + Just v' -> (Right . f) (g v') + where g n | n < 0 = Nothing + | otherwise = Just (n::Int) diff --git a/src/Network/MPD/Applicative/Stickers.hs b/src/Network/MPD/Applicative/Stickers.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Applicative/Stickers.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Network.MPD.Applicative.Stickers +Copyright : (c) Joachim Fasting 2012 +License : MIT + +Maintainer : joachim.fasting@gmail.com +Stability : stable +Portability : unportable + +Stickers. +-} + +module Network.MPD.Applicative.Stickers + ( stickerGet + , stickerSet + , stickerDelete + , stickerList + , stickerFind + ) where + +import Network.MPD.Applicative.Internal +import Network.MPD.Applicative.Util +import Network.MPD.Commands.Arg hiding (Command) +import Network.MPD.Commands.Types +import Network.MPD.Util + +import Control.Applicative + +import qualified Data.ByteString.UTF8 as UTF8 + +-- | Read sticker value for the object specified. +stickerGet :: ObjectType -> String -> String -> Command [String] +stickerGet typ uri name = Command p c + where + p :: Parser [String] + p = map UTF8.toString . takeValues <$> getResponse + + c = ["sticker get" <@> typ <++> uri <++> name] + +-- | Add sticker value to the object. Will overwrite existing stickers +-- with the same name. +stickerSet :: ObjectType -> String -> String -> String -> Command () +stickerSet typ uri name value = Command emptyResponse c + where + c = ["sticker set" <@> typ <++> uri <++> name <++> value] + +-- | Delete a sticker value from the object. If no sticker name is +-- given, all sticker values attached to the object are deleted. +stickerDelete :: ObjectType -> String -> String -> Command () +stickerDelete typ uri name = Command emptyResponse c + where + c = ["sticker delete" <@> typ <++> uri <++> name] + +-- | List stickers for the object. +stickerList :: ObjectType -> String -> Command [(String, String)] +stickerList typ uri = Command p c + where + p = map decodePair . toAssocList <$> getResponse + + c = ["sticker list" <@> typ <++> uri] + +-- | Search the sticker database for stickers with the specified name, +-- below the specified directory. +stickerFind :: ObjectType -> String -> String -> Command [(String, String)] +stickerFind typ uri name = Command p c + where + p = map decodePair . toAssocList <$> getResponse + + c = ["sticker find" <@> typ <++> uri <++> name] diff --git a/src/Network/MPD/Applicative/StoredPlaylists.hs b/src/Network/MPD/Applicative/StoredPlaylists.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Applicative/StoredPlaylists.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Network.MPD.Applicative.StoredPlaylists +Copyright : (c) Joachim Fasting 2012 +License : MIT + +Maintainer : joachim.fasting@gmail.com +Stability : stable +Portability : unportable + +Stored playlists. +-} + +module Network.MPD.Applicative.StoredPlaylists + ( listPlaylist + , listPlaylistInfo + , listPlaylists + , load + , playlistAdd + , playlistClear + , playlistDelete + , playlistMove + , rename + , rm + , save + ) where + +import Network.MPD.Applicative.Internal +import Network.MPD.Applicative.Util +import Network.MPD.Commands.Arg hiding (Command) +import Network.MPD.Commands.Types +import Network.MPD.Util + +import Control.Applicative + +-- | List song items in the playlist. +listPlaylist :: PlaylistName -> Command [Path] +listPlaylist plName = Command p ["listplaylist" <@> plName] + where + p = map Path . takeValues <$> getResponse + +-- | List song items in the playlist with metadata. +listPlaylistInfo :: PlaylistName -> Command [Song] +listPlaylistInfo plName = + Command (liftParser takeSongs) ["listplaylistinfo" <@> plName] + +-- | Get a list of stored playlists. +listPlaylists :: Command [PlaylistName] +listPlaylists = Command p ["listplaylists"] + where + p = map PlaylistName . go [] . toAssocList <$> getResponse + + -- XXX: need to fail gracefully here + -- After each playlist name we get a timestamp + go acc [] = acc + go acc ((_, b):_:xs) = go (b : acc) xs + go _ _ = error "listPlaylists: bug" + +-- | Load playlist into the current queue. +load :: PlaylistName -> Command () +load plName = Command emptyResponse ["load" <@> plName] + +-- | Add a database path to the named playlist. +playlistAdd :: PlaylistName -> Path -> Command () +playlistAdd plName path = + Command emptyResponse ["playlistadd" <@> plName <++> path] + +-- | Clear the playlist. +playlistClear :: PlaylistName -> Command () +playlistClear plName = Command emptyResponse ["playlistclear" <@> plName] + +-- | Delete the item at the given position from the playlist. +playlistDelete :: PlaylistName -> Position -> Command () +playlistDelete name pos = + Command emptyResponse ["playlistdelete" <@> name <++> pos] + +-- | Move a song to a new position within the playlist. +playlistMove :: PlaylistName -> Id -> Position -> Command () +playlistMove name from to = + Command emptyResponse ["playlistmove" <@> name <++> from <++> to] + +-- | Rename the playlist. +rename :: PlaylistName -> PlaylistName -> Command () +rename plName new = Command emptyResponse ["rename" <@> plName <++> new] + +-- | Remove the playlist. +rm :: PlaylistName -> Command () +rm plName = Command emptyResponse ["rm" <@> plName] + +-- | Save current queue to the named playlist. +save :: PlaylistName -> Command () +save plName = Command emptyResponse ["save" <@> plName] diff --git a/src/Network/MPD/Applicative/Util.hs b/src/Network/MPD/Applicative/Util.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Applicative/Util.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.MPD.Applicative.Util where + +import Network.MPD.Commands.Parse +import Network.MPD.Commands.Types +import Network.MPD.Util + +import Control.Monad (liftM) + +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.UTF8 as UTF8 + +-- Separate the result of an lsinfo\/listallinfo call into directories, +-- playlists, and songs. +takeEntries :: [ByteString] -> Either String [LsResult] +takeEntries = mapM toEntry . splitGroups groupHeads . toAssocList + where + toEntry xs@(("file",_):_) = LsSong `liftM` parseSong xs + toEntry (("directory",d):_) = (return . LsDirectory . Path) d + toEntry (("playlist",pl):_) = (return . LsPlaylist . PlaylistName) pl + toEntry _ = error "takeEntries: splitGroups is broken" + groupHeads = ["file", "directory", "playlist"] + +takeSongs :: [ByteString] -> Either String [Song] +takeSongs = mapM parseSong . splitGroups ["file"] . toAssocList + +-- Run 'toAssocList' and return only the values. +takeValues :: [ByteString] -> [ByteString] +takeValues = snd . unzip . toAssocList + +-- an internal helper function +decodePair :: (ByteString, ByteString) -> (String, String) +decodePair (x, y) = (UTF8.toString x, UTF8.toString y) diff --git a/src/Network/MPD/Commands.hs b/src/Network/MPD/Commands.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Commands.hs @@ -0,0 +1,68 @@ +{- | +Module : Network.MPD.Commands +Copyright : (c) Joachim Fasting 2012 +License : MIT + +Maintainer : joachim.fasting@gmail.com +Stability : stable +Portability : unportable + +Interface to the user commands supported by MPD. +-} + +module Network.MPD.Commands ( + module Network.MPD.Commands.Query + + , ToString(..) + , Artist + , Album + , Title + , PlaylistName(..) + , Path + , Metadata(..) + , Value + , ObjectType(..) + , Seconds + , Decibels + , State(..) + , Subsystem(..) + , ReplayGainMode(..) + , Count(..) + , LsResult(..) + , Device(..) + , Song(..) + , Position + , Id(..) + , sgGetTag + , sgAddTag + , Stats(..) + , Status(..) + , def + + , module Network.MPD.Commands.Status + , module Network.MPD.Commands.PlaybackOptions + , module Network.MPD.Commands.PlaybackControl + , module Network.MPD.Commands.CurrentPlaylist + , module Network.MPD.Commands.StoredPlaylists + , module Network.MPD.Commands.Database + , module Network.MPD.Commands.Stickers + , module Network.MPD.Commands.Connection + , module Network.MPD.Commands.Output + , module Network.MPD.Commands.Reflection + , module Network.MPD.Commands.ClientToClient + ) where + +import Network.MPD.Commands.Query +import Network.MPD.Commands.Types + +import Network.MPD.Commands.Status +import Network.MPD.Commands.PlaybackOptions +import Network.MPD.Commands.PlaybackControl +import Network.MPD.Commands.CurrentPlaylist +import Network.MPD.Commands.StoredPlaylists +import Network.MPD.Commands.Database +import Network.MPD.Commands.Stickers +import Network.MPD.Commands.Connection +import Network.MPD.Commands.Output +import Network.MPD.Commands.Reflection +import Network.MPD.Commands.ClientToClient diff --git a/src/Network/MPD/Commands/Arg.hs b/src/Network/MPD/Commands/Arg.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Commands/Arg.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, GeneralizedNewtypeDeriving #-} + +{- | +Module : Network.MPD.Commands.Arg +Copyright : (c) Joachim Fasting, Simon Hengel 2012 +License : MIT + +Maintainer : Joachim Fasting +Stability : alpha +Portability : unportable + +Prepare command arguments. +-} + +module Network.MPD.Commands.Arg (Command, Args(..), MPDArg(..), (<++>), (<@>)) where + +import Network.MPD.Util (showBool) + +import Data.ByteString (ByteString) +import qualified Data.ByteString.UTF8 as UTF8 +import Data.String + +-- | Arguments for getResponse are accumulated as strings in values of +-- this type after being converted from whatever type (an instance of +-- MPDArg) they were to begin with. +newtype Args = Args [String] + deriving Show + +-- | A uniform interface for argument preparation +-- The basic idea is that one should be able +-- to magically prepare an argument for use with +-- an MPD command, without necessarily knowing/\caring +-- how it needs to be represented internally. +class Show a => MPDArg a where + prep :: a -> Args + -- Note that because of this, we almost + -- never have to actually provide + -- an implementation of 'prep' + prep = Args . return . show + +-- | Groups together arguments to getResponse. +infixl 3 <++> +(<++>) :: (MPDArg a, MPDArg b) => a -> b -> Args +x <++> y = Args $ xs ++ ys + where Args xs = prep x + Args ys = prep y + +newtype Command = Command String + deriving IsString + +-- | Converts a command name and a string of arguments into the string +-- to hand to getResponse. +infix 2 <@> +(<@>) :: (MPDArg a) => Command -> a -> String +Command x <@> y = unwords $ x : filter (not . null) y' + where Args y' = prep y + +instance MPDArg Args where prep = id + +instance MPDArg String where + -- We do this to avoid mangling + -- non-ascii characters with 'show' + prep x = Args ['"' : x ++ "\""] + +instance MPDArg ByteString where + prep = prep . UTF8.toString + +instance (MPDArg a) => MPDArg (Maybe a) where + prep Nothing = Args [] + prep (Just x) = prep x + +instance (MPDArg a, MPDArg b) => MPDArg (a, b) where + prep (x, y) = Args [show x ++ ":" ++ show y] + +instance MPDArg Int +instance MPDArg Integer +instance MPDArg Bool where prep = Args . return . showBool diff --git a/src/Network/MPD/Commands/Connection.hs b/src/Network/MPD/Commands/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Commands/Connection.hs @@ -0,0 +1,31 @@ +{- | +Module : Network.MPD.Commands.Connection +Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2012 +License : MIT (see LICENSE) + +Maintainer : joachim.fasting@gmail.com +Stability : stable +Portability : unportable + +Connection settings. +-} + +module Network.MPD.Commands.Connection + ( password + , ping + ) where + +import qualified Network.MPD.Applicative.Internal as A +import qualified Network.MPD.Applicative.Connection as A +import Network.MPD.Core + +-- XXX should the password be quoted? Change "++" to "<@>" if so. If +-- it should, it also needs to be fixed in N.M.Core. +-- | Send password to server to authenticate session. +-- Password is sent as plain text. +password :: MonadMPD m => String -> m () +password = A.runCommand . A.password + +-- | Check that the server is still responding. +ping :: MonadMPD m => m () +ping = A.runCommand A.ping diff --git a/src/Network/MPD/Commands/CurrentPlaylist.hs b/src/Network/MPD/Commands/CurrentPlaylist.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Commands/CurrentPlaylist.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Network.MPD.Commands.CurrentPlaylist +Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2012 +License : MIT (see LICENSE) + +Maintainer : joachim.fasting@gmail.com +Stability : stable +Portability : unportable + +The current playlist. +-} + +module Network.MPD.Commands.CurrentPlaylist + ( addId + , add + , clear + , delete + , deleteId + , move + , moveId + , playlist + , playlistFind + , playlistInfo + , playlistInfoRange + , playlistId + , playlistSearch + , plChanges + , plChangesPosId + , shuffle + , swap + , swapId + ) where + +import qualified Network.MPD.Applicative.Internal as A +import qualified Network.MPD.Applicative.CurrentPlaylist as A +import Network.MPD.Commands.Query +import Network.MPD.Commands.Types +import Network.MPD.Core +import Network.MPD.Util + +import Control.Monad.Error (throwError) + +-- | Like 'add', but returns a playlist id. +addId :: MonadMPD m => Path -> Maybe Position -> m Id +addId path = A.runCommand . A.addId path + +-- | Add a song (or a whole directory) to the current playlist. +add :: MonadMPD m => Path -> m () +add = A.runCommand . A.add + +-- | Clear the current playlist. +clear :: MonadMPD m => m () +clear = A.runCommand A.clear + +-- | Remove a song from the current playlist. +delete :: MonadMPD m => Position -> m () +delete = A.runCommand . A.delete + +-- | Remove a song from the current playlist. +deleteId :: MonadMPD m => Id -> m () +deleteId = A.runCommand . A.deleteId + +-- | Move a song to a given position in the current playlist. +move :: MonadMPD m => Position -> Position -> m () +move pos = A.runCommand . A.move pos + +-- | Move a song from (songid) to (playlist index) in the playlist. If to is +-- negative, it is relative to the current song in the playlist (if there is one). +moveId :: MonadMPD m => Id -> Position -> m () +moveId i = A.runCommand . A.moveId i + +-- | Retrieve file paths and positions of songs in the current playlist. +-- Note that this command is only included for completeness sake; it's +-- deprecated and likely to disappear at any time, please use 'playlistInfo' +-- instead. +playlist :: MonadMPD m => m [(Position, Path)] +playlist = mapM f =<< getResponse "playlist" + where f s | (pos, name) <- breakChar ':' s + , Just pos' <- parseNum pos + = return (pos', Path name) + | otherwise = throwError . Unexpected $ show s +{-# WARNING playlist "this is deprecated; please use 'playlistInfo' instead." #-} + +-- | Search for songs in the current playlist with strict matching. +playlistFind :: MonadMPD m => Query -> m [Song] +playlistFind = A.runCommand . A.playlistFind + +-- | Retrieve metadata for songs in the current playlist. +playlistInfo :: MonadMPD m => Maybe Position -> m [Song] +playlistInfo = A.runCommand . A.playlistInfo + +-- | Like 'playlistInfo' but can restrict to a range of songs. +playlistInfoRange :: MonadMPD m => Maybe (Position, Position) -> m [Song] +playlistInfoRange = A.runCommand . A.playlistInfoRange + +-- | Displays a list of songs in the playlist. +-- If id is specified, only its info is returned. +playlistId :: MonadMPD m => Maybe Id -> m [Song] +playlistId = A.runCommand . A.playlistId + +-- | Search case-insensitively with partial matches for songs in the +-- current playlist. +playlistSearch :: MonadMPD m => Query -> m [Song] +playlistSearch = A.runCommand . A.playlistSearch + +-- | Retrieve a list of changed songs currently in the playlist since +-- a given playlist version. +plChanges :: MonadMPD m => Integer -> m [Song] +plChanges = A.runCommand . A.plChanges + +-- | Like 'plChanges' but only returns positions and ids. +plChangesPosId :: MonadMPD m => Integer -> m [(Position, Id)] +plChangesPosId = A.runCommand . A.plChangesPosId + +-- | Shuffle the playlist. +shuffle :: MonadMPD m => Maybe (Position, Position) -- ^ Optional range (start, end) + -> m () +shuffle = A.runCommand . A.shuffle + +-- | Swap the positions of two songs. +swap :: MonadMPD m => Position -> Position -> m () +swap pos1 = A.runCommand . A.swap pos1 + +-- | Swap the positions of two songs (Id version) +swapId :: MonadMPD m => Id -> Id -> m () +swapId id1 = A.runCommand . A.swapId id1 diff --git a/src/Network/MPD/Commands/Database.hs b/src/Network/MPD/Commands/Database.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Commands/Database.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Network.MPD.Commands.Database +Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2012 +License : MIT (see LICENSE) + +Maintainer : joachim.fasting@gmail.com +Stability : stable +Portability : unportable + +The music database. +-} + +module Network.MPD.Commands.Database + ( count + , find + , findAdd + , list + , listAll + , listAllInfo + , lsInfo + , search + , update + , rescan + ) where + +import qualified Network.MPD.Applicative.Internal as A +import qualified Network.MPD.Applicative.Database as A +import Network.MPD.Commands.Query +import Network.MPD.Commands.Types +import Network.MPD.Core + +-- | Count the number of entries matching a query. +count :: MonadMPD m => Query -> m Count +count = A.runCommand . A.count + +-- | Search the database for entries exactly matching a query. +find :: MonadMPD m => Query -> m [Song] +find = A.runCommand . A.find + +-- | Adds songs matching a query to the current playlist. +findAdd :: MonadMPD m => Query -> m () +findAdd = A.runCommand . A.findAdd + +-- | List all tags of the specified type. +list :: MonadMPD m + => Metadata -- ^ Metadata to list + -> Maybe Artist -> m [Value] +list m = A.runCommand . A.list m + +-- | List the songs (without metadata) in a database directory recursively. +listAll :: MonadMPD m => Path -> m [Path] +listAll = A.runCommand . A.listAll + +-- | Recursive 'lsInfo'. +listAllInfo :: MonadMPD m => Path -> m [LsResult] +listAllInfo = A.runCommand . A.listAllInfo + +-- | Non-recursively list the contents of a database directory. +lsInfo :: MonadMPD m => Path -> m [LsResult] +lsInfo = A.runCommand . A.lsInfo + +-- | Search the database using case insensitive matching. +search :: MonadMPD m => Query -> m [Song] +search = A.runCommand . A.search + +-- | Update the server's database. +-- +-- If no path is given, the whole library will be scanned. Unreadable or +-- non-existent paths are silently ignored. +-- +-- The update job id is returned. +update :: MonadMPD m => Maybe Path -> m Integer +update = A.runCommand . A.update + +-- | Like 'update' but also rescans unmodified files. +rescan :: MonadMPD m => Maybe Path -> m Integer +rescan = A.runCommand . A.rescan diff --git a/src/Network/MPD/Commands/Extensions.hs b/src/Network/MPD/Commands/Extensions.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Commands/Extensions.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Network.MPD.Commands.Extensions +Copyright : (c) Joachim Fasting 2012 +License : MIT + +Maintainer : Joachim Fasting +Stability : unstable +Portability : unportable + +Extensions and shortcuts to the standard MPD command set. +-} + +module Network.MPD.Commands.Extensions where + +import Network.MPD.Core +import Network.MPD.Commands +import qualified Network.MPD.Applicative.Internal as A +import qualified Network.MPD.Applicative.CurrentPlaylist as A +import qualified Network.MPD.Applicative.StoredPlaylists as A + +import Control.Monad (liftM) +import Data.Traversable (for) +import Data.Foldable (for_) + +-- | This is exactly the same as `update`. +updateId :: MonadMPD m => Maybe Path -> m Integer +updateId = update +{-# DEPRECATED updateId "use `update` instead" #-} + +-- | Toggles play\/pause. Plays if stopped. +toggle :: MonadMPD m => m () +toggle = status >>= \st -> case stState st of Playing -> pause True + _ -> play Nothing + +-- | Add a list of songs\/folders to a playlist. +-- Should be more efficient than running 'add' many times. +addMany :: MonadMPD m => PlaylistName -> [Path] -> m () +addMany plname xs = A.runCommand (for_ xs cmd) + where cmd | plname == "" = A.add + | otherwise = A.playlistAdd plname + +-- | Recursive 'addId'. For directories, it will use the given position +-- for the first file in the directory and use the successor for the remaining +-- files. It returns a list of playlist ids for the songs added. +addIdMany :: MonadMPD m => Path -> Maybe Position -> m [Id] +addIdMany x (Just p) = do + fs <- listAll x + let fs' = map (\(a, b) -> (a, Just b)) $ zip fs [p ..] + A.runCommand $ for fs' (uncurry A.addId) +addIdMany x Nothing = do + fs <- listAll x + A.runCommand $ for fs (`A.addId` Nothing) + +-- | Like 'add' but returns a list of the files added. +addList :: MonadMPD m => Path -> m [Path] +addList x = add x >> listAll x +{-# DEPRECATED addList "will be removed in a future version" #-} + +-- | Like 'playlistAdd' but returns a list of the files added. +playlistAddList :: MonadMPD m => PlaylistName -> Path -> m [Path] +playlistAddList plname path = playlistAdd plname path >> listAll path +{-# DEPRECATED playlistAddList "will be removed in a future version" #-} + +{- +-- | Returns all songs and directories that match the given partial +-- path name. +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 +-} + +-- | List the artists in the database. +listArtists :: MonadMPD m => m [Artist] +listArtists = list Artist Nothing + +-- | List the albums in the database, optionally matching a given +-- artist. +listAlbums :: MonadMPD m => Maybe Artist -> m [Album] +listAlbums = list Album + +-- | List the songs in an album of some artist. +listAlbum :: MonadMPD m => Artist -> Album -> m [Song] +listAlbum artist album = find (Artist =? artist <&> Album =? album) + +-- | Retrieve the current playlist. +-- Equivalent to @playlistinfo Nothing@. +getPlaylist :: MonadMPD m => m [Song] +getPlaylist = playlistInfo Nothing + +-- | Increase or decrease volume by a given percent, e.g. +-- 'volume 10' will increase the volume by 10 percent, while +-- 'volume (-10)' will decrease it by the same amount. +volume :: MonadMPD m => Int -> m () +volume n = do + cur <- stVolume `liftM` status + case cur of + Nothing -> return () + Just v -> setVolume (adjust v) + where + adjust x = round $ (fromIntegral n / (100 :: Double)) * x' + x' + where x' = fromIntegral x diff --git a/src/Network/MPD/Commands/Output.hs b/src/Network/MPD/Commands/Output.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Commands/Output.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Network.MPD.Commands.Output +Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2012 +License : MIT (see LICENSE) + +Maintainer : joachim.fasting@gmail.com +Stability : stable +Portability : unportable + +Audio output devices. +-} + +module Network.MPD.Commands.Output + ( disableOutput + , enableOutput + , outputs + ) where + +import qualified Network.MPD.Applicative.Internal as A +import qualified Network.MPD.Applicative.Output as A +import Network.MPD.Core +import Network.MPD.Commands.Types + +-- | Turn off an output device. +disableOutput :: MonadMPD m => Int -> m () +disableOutput = A.runCommand . A.disableOutput + +-- | Turn on an output device. +enableOutput :: MonadMPD m => Int -> m () +enableOutput = A.runCommand . A.enableOutput + +-- | Retrieve information for all output devices. +outputs :: MonadMPD m => m [Device] +outputs = A.runCommand A.outputs diff --git a/src/Network/MPD/Commands/Parse.hs b/src/Network/MPD/Commands/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Commands/Parse.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} + +-- | Module : Network.MPD.Commands.Parse +-- Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 +-- License : MIT (see LICENSE) +-- Maintainer : Joachim Fasting +-- Stability : alpha +-- +-- Parsers for MPD data types. + +module Network.MPD.Commands.Parse where + +import Network.MPD.Commands.Types + +import Control.Applicative +import Control.Monad.Error +import Data.Maybe (fromMaybe) + +import Network.MPD.Util + +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.UTF8 as UTF8 + +-- | Builds a 'Count' instance from an assoc. list. +parseCount :: [ByteString] -> Either String Count +parseCount = foldM f def . toAssocList + where f :: Count -> (ByteString, ByteString) -> Either String Count + f a ("songs", x) = return $ parse parseNum + (\x' -> a { cSongs = x'}) a x + f a ("playtime", x) = return $ parse parseNum + (\x' -> a { cPlaytime = x' }) a x + f _ x = Left $ show x + +-- | Builds a list of 'Device' instances from an assoc. list +parseOutputs :: [ByteString] -> Either String [Device] +parseOutputs = mapM (foldM f def) + . splitGroups ["outputid"] + . toAssocList + where f a ("outputid", x) = return $ parse parseNum + (\x' -> a { dOutputID = x' }) a x + f a ("outputname", x) = return a { dOutputName = UTF8.toString x } + f a ("outputenabled", x) = return $ parse parseBool + (\x' -> a { dOutputEnabled = x'}) a x + f _ x = Left $ show x + +-- | Builds a 'Stats' instance from an assoc. list. +parseStats :: [ByteString] -> Either String Stats +parseStats = foldM f def . toAssocList + where + f a ("artists", x) = return $ parse parseNum + (\x' -> a { stsArtists = x' }) a x + f a ("albums", x) = return $ parse parseNum + (\x' -> a { stsAlbums = x' }) a x + f a ("songs", x) = return $ parse parseNum + (\x' -> a { stsSongs = x' }) a x + f a ("uptime", x) = return $ parse parseNum + (\x' -> a { stsUptime = x' }) a x + f a ("playtime", x) = return $ parse parseNum + (\x' -> a { stsPlaytime = x' }) a x + f a ("db_playtime", x) = return $ parse parseNum + (\x' -> a { stsDbPlaytime = x' }) a x + f a ("db_update", x) = return $ parse parseNum + (\x' -> a { stsDbUpdate = x' }) a x + f _ x = Left $ show x + +parseMaybeSong :: [ByteString] -> Either String (Maybe Song) +parseMaybeSong xs | null xs = Right Nothing + | otherwise = Just <$> (parseSong . toAssocList) xs + +-- | Builds a 'Song' instance from an assoc. list. +parseSong :: [(ByteString, ByteString)] -> Either String Song +parseSong xs = case xs of + ("file", path):ys -> foldM f (defaultSong (Path path)) ys + _ -> Left "Got a song without a file path! This indicates a bug in either libmpd-haskell or MPD itself!" + + where + f :: Song -> (ByteString, ByteString) -> Either String Song + f s ("Last-Modified", v) = + return s { sgLastModified = parseIso8601 v } + f s ("Time", v) = + return s { sgLength = fromMaybe 0 $ parseNum v } + f s ("Id", v) = + return $ parse parseNum (\v' -> s { sgId = Just $ Id v' }) s v + f s ("Pos", v) = + maybe (return $ parse parseNum + (\v' -> s { sgIndex = Just v' }) s v) + (const $ return s) + (sgIndex s) + f s (k, v) = return . maybe s (\m -> sgAddTag m (Value v) s) $ + readMeta k + + -- Custom-made Read instance + readMeta "ArtistSort" = Just ArtistSort + readMeta "Artist" = Just Artist + readMeta "Album" = Just Album + readMeta "AlbumArtist" = Just AlbumArtist + readMeta "AlbumArtistSort" = Just AlbumArtistSort + readMeta "Title" = Just Title + readMeta "Genre" = Just Genre + readMeta "Name" = Just Name + readMeta "Composer" = Just Composer + readMeta "Performer" = Just Performer + readMeta "Comment" = Just Comment + readMeta "Date" = Just Date + readMeta "Track" = Just Track + readMeta "Disc" = Just Disc + readMeta "MUSICBRAINZ_ARTISTID" = Just MUSICBRAINZ_ARTISTID + readMeta "MUSICBRAINZ_ALBUMID" = Just MUSICBRAINZ_ALBUMID + readMeta "MUSICBRAINZ_ALBUMARTISTID" = Just MUSICBRAINZ_ALBUMARTISTID + readMeta "MUSICBRAINZ_TRACKID" = Just MUSICBRAINZ_TRACKID + readMeta _ = Nothing + +-- | A helper that runs a parser on a string and, depending on the +-- outcome, either returns the result of some command applied to the +-- result, or a default value. Used when building structures. +parse :: (ByteString -> Maybe a) -> (a -> b) -> b -> ByteString -> b +parse parser f x = maybe x f . parser + +-- | A helper for running a parser returning Maybe on a pair of strings. +-- Returns Just if both strings where parsed successfully, Nothing otherwise. +pair :: (ByteString -> Maybe a) -> (ByteString, ByteString) -> Maybe (a, a) +pair p (x, y) = case (p x, p y) of + (Just a, Just b) -> Just (a, b) + _ -> Nothing diff --git a/src/Network/MPD/Commands/PlaybackControl.hs b/src/Network/MPD/Commands/PlaybackControl.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Commands/PlaybackControl.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Network.MPD.Commands.PlaybackControl +Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2012 +License : MIT (see LICENSE) + +Maintainer : joachim.fasting@gmail.com +Stability : stable +Portability : unportable + +Controlling playback. +-} + +module Network.MPD.Commands.PlaybackControl + ( next + , pause + , play + , playId + , previous + , seek + , seekId + , stop + ) where + +import qualified Network.MPD.Applicative.Internal as A +import qualified Network.MPD.Applicative.PlaybackControl as A +import Network.MPD.Commands.Types +import Network.MPD.Core + +-- | Play the next song. +next :: MonadMPD m => m () +next = A.runCommand A.next + +-- | Pause playing. +pause :: MonadMPD m => Bool -> m () +pause = A.runCommand . A.pause + +-- | Begin\/continue playing. +play :: MonadMPD m => Maybe Position -> m () +play = A.runCommand . A.play + +-- | Play a file with given id. +playId :: MonadMPD m => Id -> m () +playId = A.runCommand . A.playId + +-- | Play the previous song. +previous :: MonadMPD m => m () +previous = A.runCommand A.previous + +-- | Seek to some point in a song. +seek :: MonadMPD m => Position -> Seconds -> m () +seek pos = A.runCommand . A.seek pos + +-- | Seek to some point in a song (id version) +seekId :: MonadMPD m => Id -> Seconds -> m () +seekId id' = A.runCommand . A.seekId id' + +-- | Stop playing. +stop :: MonadMPD m => m () +stop = A.runCommand A.stop diff --git a/src/Network/MPD/Commands/PlaybackOptions.hs b/src/Network/MPD/Commands/PlaybackOptions.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Commands/PlaybackOptions.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Network.MPD.Commands.PlaybackOptions +Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2012 +License : MIT (see LICENSE) + +Maintainer : joachim.fasting@gmail.com +Stability : stable +Portability : unportable + +Playback options. +-} + +module Network.MPD.Commands.PlaybackOptions + ( consume + , crossfade + , random + , repeat + , setVolume + , single + , replayGainMode + , replayGainStatus + ) where + +import qualified Network.MPD.Applicative.Internal as A +import qualified Network.MPD.Applicative.PlaybackOptions as A +import Network.MPD.Commands.Types +import Network.MPD.Core + +import Prelude hiding (repeat) + +-- | Set consume mode +consume :: MonadMPD m => Bool -> m () +consume = A.runCommand . A.consume + +-- | Set crossfading between songs. +crossfade :: MonadMPD m => Seconds -> m () +crossfade = A.runCommand . A.crossfade + +-- | Set random playing. +random :: MonadMPD m => Bool -> m () +random = A.runCommand . A.random + +-- | Set repeating. +repeat :: MonadMPD m => Bool -> m () +repeat = A.runCommand . A.repeat + +-- | Set the volume (0-100 percent). +setVolume :: MonadMPD m => Int -> m () +setVolume = A.runCommand . A.setVolume + +-- | Set single mode +single :: MonadMPD m => Bool -> m () +single = A.runCommand . A.single + +-- | Set the replay gain mode. +replayGainMode :: MonadMPD m => ReplayGainMode -> m () +replayGainMode = A.runCommand . A.replayGainMode + +-- | Get the replay gain options. +replayGainStatus :: MonadMPD m => m [(String, String)] +replayGainStatus = A.runCommand A.replayGainStatus diff --git a/src/Network/MPD/Commands/Query.hs b/src/Network/MPD/Commands/Query.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Commands/Query.hs @@ -0,0 +1,60 @@ +{- | +Module : Network.MPD.Commands.Query +Copyright : (c) Joachim Fasting 2012 +License : MIT + +Maintainer : Joachim Fasting +Stability : unstable +Portability : unportable + +Query interface. +-} + +module Network.MPD.Commands.Query (Query, (=?), (<&>), anything) where + +import Network.MPD.Commands.Arg +import Network.MPD.Commands.Types + +import Data.Monoid + +-- | An interface for creating MPD queries. +-- +-- For example, to match any song where the value of artist is \"Foo\", we +-- use: +-- +-- > Artist =? "Foo" +-- +-- We can also compose queries, thus narrowing the search. For example, to +-- match any song where the value of artist is \"Foo\" and the value of album +-- is \"Bar\", we use: +-- +-- > Artist =? "Foo" <&> Album =? "Bar" +newtype Query = Query [Match] deriving Show + +-- A single query clause, comprising a metadata key and a desired value. +data Match = Match Metadata Value + +instance Show Match where + show (Match meta query) = show meta ++ " \"" ++ toString query ++ "\"" + showList xs _ = unwords $ map show xs + +instance Monoid Query where + mempty = Query [] + Query a `mappend` Query b = Query (a ++ b) + +instance MPDArg Query where + prep = foldl (<++>) (Args []) . f + where f (Query ms) = map (\(Match m q) -> Args [show m] <++> q) ms + +-- | An empty query. Matches anything. +anything :: Query +anything = mempty + +-- | Create a query. +(=?) :: Metadata -> Value -> Query +m =? s = Query [Match m s] + +-- | Combine queries. +infixr 6 <&> +(<&>) :: Query -> Query -> Query +(<&>) = mappend diff --git a/src/Network/MPD/Commands/Reflection.hs b/src/Network/MPD/Commands/Reflection.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Commands/Reflection.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Network.MPD.Commands.Reflection +Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2012 +License : MIT (see LICENSE) + +Maintainer : joachim.fasting@gmail.com +Stability : stable +Portability : unportable + +Reflection. +-} + +module Network.MPD.Commands.Reflection + ( commands + , notCommands + , tagTypes + , urlHandlers + , decoders + , config + ) where + +import qualified Network.MPD.Applicative.Internal as A +import qualified Network.MPD.Applicative.Reflection as A +import Network.MPD.Core + +-- | Retrieve a list of available commands. +commands :: MonadMPD m => m [String] +commands = A.runCommand A.commands + +-- | Retrieve a list of unavailable (due to access restrictions) commands. +notCommands :: MonadMPD m => m [String] +notCommands = A.runCommand A.notCommands + +-- | Retrieve a list of available song metadata. +tagTypes :: MonadMPD m => m [String] +tagTypes = A.runCommand A.tagTypes + +-- | Retrieve a list of supported urlhandlers. +urlHandlers :: MonadMPD m => m [String] +urlHandlers = A.runCommand A.urlHandlers + +-- | Retreive a list of decoder plugins with associated suffix and mime types. +decoders :: MonadMPD m => m [(String, [(String, String)])] +decoders = A.runCommand A.decoders + +-- | Retrieve configuration keys and values. +config :: MonadMPD m => m [(String, String)] +config = A.runCommand A.config diff --git a/src/Network/MPD/Commands/Status.hs b/src/Network/MPD/Commands/Status.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Commands/Status.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Network.MPD.Commands.Status +Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2012 +License : MIT (see LICENSE) + +Maintainer : joachim.fasting@gmail.com +Stability : stable +Portability : unportable + +Querying MPD's status. +-} + +module Network.MPD.Commands.Status + ( clearError + , currentSong + , idle + , noidle + , stats + , status + ) where + +import qualified Network.MPD.Applicative.Internal as A +import qualified Network.MPD.Applicative.Status as A +import Network.MPD.Commands.Types +import Network.MPD.Core + +-- | Clear the current error message in status. +clearError :: MonadMPD m => m () +clearError = A.runCommand A.clearError + +-- | Get the currently playing song. +currentSong :: MonadMPD m => m (Maybe Song) +currentSong = A.runCommand A.currentSong + +-- | Wait until there is a noteworthy change in one or more of MPD's +-- susbystems. +-- +-- The first argument is a list of subsystems that should be considered. An +-- empty list specifies that all subsystems should be considered. +-- +-- A list of subsystems that have noteworthy changes is returned. +-- +-- Note that running this command will block until either 'idle' returns or is +-- cancelled by 'noidle'. +idle :: MonadMPD m => [Subsystem] -> m [Subsystem] +idle = A.runCommand . A.idle + +-- | Cancel 'idle'. +noidle :: MonadMPD m => m () +noidle = A.runCommand A.noidle + +-- | Get server statistics. +stats :: MonadMPD m => m Stats +stats = A.runCommand A.stats + +-- | Get the server's status. +status :: MonadMPD m => m Status +status = A.runCommand A.status diff --git a/src/Network/MPD/Commands/Stickers.hs b/src/Network/MPD/Commands/Stickers.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Commands/Stickers.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Network.MPD.Commands.Stickers +Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2012 +License : MIT (see LICENSE) + +Maintainer : joachim.fasting@gmail.com +Stability : stable +Portability : unportable + +Stickers. +-} + +module Network.MPD.Commands.Stickers + ( stickerGet + , stickerSet + , stickerDelete + , stickerList + , stickerFind + ) where + +import qualified Network.MPD.Applicative.Internal as A +import qualified Network.MPD.Applicative.Stickers as A +import Network.MPD.Commands.Types +import Network.MPD.Core + +-- | Reads a sticker value for the specified object. +stickerGet :: MonadMPD m => ObjectType + -> String -- ^ Object URI + -> String -- ^ Sticker name + -> m [String] +stickerGet typ uri = A.runCommand . A.stickerGet typ uri + +-- | Adds a sticker value to the specified object. +stickerSet :: MonadMPD m => ObjectType + -> String -- ^ Object URI + -> String -- ^ Sticker name + -> String -- ^ Sticker value + -> m () +stickerSet typ uri name = A.runCommand . A.stickerSet typ uri name + +-- | Delete a sticker value from the specified object. +stickerDelete :: MonadMPD m => ObjectType + -> String -- ^ Object URI + -> String -- ^ Sticker name + -> m () +stickerDelete typ uri = A.runCommand . A.stickerDelete typ uri + +-- | Lists the stickers for the specified object. +stickerList :: MonadMPD m => ObjectType + -> String -- ^ Object URI + -> m [(String, String)] -- ^ Sticker name\/sticker value +stickerList typ = A.runCommand . A.stickerList typ + +-- | Searches the sticker database for stickers with the specified name, below +-- the specified path. +stickerFind :: MonadMPD m => ObjectType + -> String -- ^ Path + -> String -- ^ Sticker name + -> m [(String, String)] -- ^ URI\/sticker value +stickerFind typ uri = A.runCommand . A.stickerFind typ uri diff --git a/src/Network/MPD/Commands/StoredPlaylists.hs b/src/Network/MPD/Commands/StoredPlaylists.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Commands/StoredPlaylists.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module : Network.MPD.Commands.StoredPlaylists +Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2012 +License : MIT (see LICENSE) + +Maintainer : joachim.fasting@gmail.com +Stability : stable +Portability : unportable + +Stored playlists. +-} + +module Network.MPD.Commands.StoredPlaylists + ( listPlaylist + , listPlaylistInfo + , listPlaylists + , load + , playlistAdd + , playlistClear + , playlistDelete + , playlistMove + , rename + , rm + , save + ) where + +import qualified Network.MPD.Applicative.Internal as A +import qualified Network.MPD.Applicative.StoredPlaylists as A +import Network.MPD.Commands.Types +import Network.MPD.Core + +-- | Retrieve a list of files in a given playlist. +listPlaylist :: MonadMPD m => PlaylistName -> m [Path] +listPlaylist = A.runCommand . A.listPlaylist + +-- | Retrieve metadata for files in a given playlist. +listPlaylistInfo :: MonadMPD m => PlaylistName -> m [Song] +listPlaylistInfo = A.runCommand . A.listPlaylistInfo + +-- | Retreive a list of stored playlists. +listPlaylists :: MonadMPD m => m [PlaylistName] +listPlaylists = A.runCommand A.listPlaylists + +-- | Load an existing playlist. +load :: MonadMPD m => PlaylistName -> m () +load = A.runCommand . A.load + +-- | Add a song (or a whole directory) to a stored playlist. +-- Will create a new playlist if the one specified does not already exist. +playlistAdd :: MonadMPD m => PlaylistName -> Path -> m () +playlistAdd plname = A.runCommand . A.playlistAdd plname + +-- | Clear a playlist. If the specified playlist does not exist, it will be +-- created. +playlistClear :: MonadMPD m => PlaylistName -> m () +playlistClear = A.runCommand . A.playlistClear + +-- | Remove a song from a playlist. +playlistDelete :: MonadMPD m => PlaylistName -> Position -> m () +playlistDelete name = A.runCommand . A.playlistDelete name + +-- | Move a song to a given position in the playlist specified. +playlistMove :: MonadMPD m => PlaylistName -> Id -> Position -> m () +playlistMove name from = A.runCommand . A.playlistMove name from + +-- | Rename an existing playlist. +rename :: MonadMPD m + => PlaylistName -- ^ Original playlist + -> PlaylistName -- ^ New playlist name + -> m () +rename plname = A.runCommand . A.rename plname + +-- | Delete existing playlist. +rm :: MonadMPD m => PlaylistName -> m () +rm = A.runCommand . A.rm + +-- | Save the current playlist. +save :: MonadMPD m => PlaylistName -> m () +save = A.runCommand . A.save diff --git a/src/Network/MPD/Commands/Types.hs b/src/Network/MPD/Commands/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Commands/Types.hs @@ -0,0 +1,337 @@ +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, GeneralizedNewtypeDeriving #-} +-- | Module : Network.MPD.Commands.Types +-- Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 +-- License : MIT (see LICENSE) +-- Maintainer : Joachim Fasting +-- Stability : alpha +-- +-- Various MPD data structures and types + +module Network.MPD.Commands.Types + ( ToString(..) + , Artist + , Album + , Title + , PlaylistName(..) + , Path(..) + , Metadata(..) + , Value(..) + , ObjectType(..) + , Seconds + , Decibels + , State(..) + , Subsystem(..) + , ReplayGainMode(..) + , Count(..) + , LsResult(..) + , Device(..) + , Song(..) + , Position + , Id(..) + , sgGetTag + , sgAddTag + , Stats(..) + , Status(..) + , def + , defaultSong + ) where + +import Network.MPD.Commands.Arg (MPDArg(prep), Args(Args)) + +import Data.Default + +import qualified Data.Map as M +import Data.Time.Clock (UTCTime) +import Data.String + +import Data.Text (Text) +import qualified Data.Text.Encoding as Text +import Data.ByteString (ByteString) +import qualified Data.ByteString.UTF8 as UTF8 + +-- The purpose of this class is to allow users to choose the optimal +-- representation of response values. +-- | A type class for values that can be converted to `String`s. +class ToString a where + + -- | Convert given value to `String`. + toString :: a -> String + + -- | Convert given value to `Text`. + toText :: a -> Text + + -- | Convert given value to a UTF-8 encoded `ByteString`. + toUtf8 :: a -> ByteString + +type Artist = Value +type Album = Value +type Title = Value + +-- | Used for commands which require a playlist name. +-- If empty, the current playlist is used. +newtype PlaylistName = PlaylistName ByteString + deriving (Eq, Show, MPDArg) + +instance ToString PlaylistName where + toString (PlaylistName x) = UTF8.toString x + toText (PlaylistName x) = Text.decodeUtf8 x + toUtf8 (PlaylistName x) = x + +instance IsString PlaylistName where + fromString = PlaylistName . UTF8.fromString + +-- | Used for commands which require a path within the database. +-- If empty, the root path is used. +newtype Path = Path ByteString + deriving (Eq, Show, MPDArg) + +instance ToString Path where + toString (Path x) = UTF8.toString x + toText (Path x) = Text.decodeUtf8 x + toUtf8 (Path x) = x + +instance IsString Path where + fromString = Path . UTF8.fromString + +-- | Available metadata types\/scope modifiers, used for searching the +-- database for entries with certain metadata values. +data Metadata = Artist + | ArtistSort + | Album + | AlbumArtist + | AlbumArtistSort + | Title + | Track + | Name + | Genre + | Date + | Composer + | Performer + | Comment + | Disc + | MUSICBRAINZ_ARTISTID + | MUSICBRAINZ_ALBUMID + | MUSICBRAINZ_ALBUMARTISTID + | MUSICBRAINZ_TRACKID + deriving (Eq, Enum, Ord, Bounded, Show) + +instance MPDArg Metadata + +-- | A metadata value. +newtype Value = Value ByteString + deriving (Eq, Show, MPDArg) + +instance ToString Value where + toString (Value x) = UTF8.toString x + toText (Value x) = Text.decodeUtf8 x + toUtf8 (Value x) = x + +instance IsString Value where + fromString = Value . UTF8.fromString + +-- | Object types. +data ObjectType = SongObj + deriving (Eq, Show) + +instance MPDArg ObjectType where + prep SongObj = Args ["song"] + +type Seconds = Integer + +type Decibels = Integer + +-- | Represents the different playback states. +data State = Playing + | Stopped + | Paused + deriving (Show, Eq) + +-- | Represents the various MPD subsystems. +data Subsystem + = DatabaseS -- ^ The song database + | UpdateS -- ^ Database updates + | StoredPlaylistS -- ^ Stored playlists + | PlaylistS -- ^ The current playlist + | PlayerS -- ^ The player + | MixerS -- ^ The volume mixer + | OutputS -- ^ Audio outputs + | OptionsS -- ^ Playback options + | StickerS -- ^ Sticker database + | SubscriptionS -- ^ Subscription + | MessageS -- ^ Message on subscribed channel + deriving (Eq, Show) + +instance MPDArg Subsystem where + prep DatabaseS = Args ["database"] + prep UpdateS = Args ["update"] + prep StoredPlaylistS = Args ["stored_playlist"] + prep PlaylistS = Args ["playlist"] + prep PlayerS = Args ["player"] + prep MixerS = Args ["mixer"] + prep OutputS = Args ["output"] + prep OptionsS = Args ["options"] + prep StickerS = Args ["sticker"] + prep SubscriptionS = Args ["subscription"] + prep MessageS = Args ["message"] + +data ReplayGainMode + = Off -- ^ Disable replay gain + | TrackMode -- ^ Per track mode + | AlbumMode -- ^ Per album mode + deriving (Eq, Show) + +instance MPDArg ReplayGainMode where + prep Off = Args ["off"] + prep TrackMode = Args ["track"] + prep AlbumMode = Args ["album"] + +-- | Represents the result of running 'count'. +data Count = + Count { cSongs :: Integer -- ^ Number of songs matching the query + , cPlaytime :: Seconds -- ^ Total play time of matching songs + } + deriving (Eq, Show) + +defaultCount :: Count +defaultCount = Count { cSongs = 0, cPlaytime = 0 } + +instance Default Count where + def = defaultCount + +-- | Result of the lsInfo operation +data LsResult + = LsDirectory Path -- ^ Directory + | LsSong Song -- ^ Song + | LsPlaylist PlaylistName -- ^ Playlist + deriving (Eq, Show) + +-- | Represents an output device. +data Device = + Device { dOutputID :: Int -- ^ Output's ID number + , dOutputName :: String -- ^ Output's name as defined in the MPD + -- configuration file + , dOutputEnabled :: Bool } + deriving (Eq, Show) + +defaultDevice :: Device +defaultDevice = + Device { dOutputID = 0, dOutputName = "", dOutputEnabled = False } + +instance Default Device where + def = defaultDevice + +-- | Represents a single song item. +data Song = Song + { sgFilePath :: Path + -- | Map of available tags (multiple occurrences of one tag type allowed) + , sgTags :: M.Map Metadata [Value] + -- | Last modification date + , sgLastModified :: Maybe UTCTime + -- | Length of the song in seconds + , sgLength :: Seconds + -- | Id in playlist + , sgId :: Maybe Id + -- | Position in playlist + , sgIndex :: Maybe Position + } deriving (Eq, Show) + +-- | The position of a song in a playlist. +type Position = Int + +newtype Id = Id Int + deriving (Eq, Show) + +instance (MPDArg Id) where + prep (Id x) = prep x + +-- | Get list of specific tag type +sgGetTag :: Metadata -> Song -> Maybe [Value] +sgGetTag meta s = M.lookup meta $ sgTags s + +-- | Add metadata tag value. +sgAddTag :: Metadata -> Value -> Song -> Song +sgAddTag meta value s = s { sgTags = M.insertWith' (++) meta [value] (sgTags s) } + +defaultSong :: Path -> Song +defaultSong path = + Song { sgFilePath = path, sgTags = M.empty, sgLastModified = Nothing + , sgLength = 0, sgId = Nothing, sgIndex = Nothing } + +-- | Container for database statistics. +data Stats = + Stats { stsArtists :: Integer -- ^ Number of artists. + , stsAlbums :: Integer -- ^ Number of albums. + , stsSongs :: Integer -- ^ Number of songs. + , stsUptime :: Seconds -- ^ Daemon uptime in seconds. + , stsPlaytime :: Seconds -- ^ Total playing time. + , stsDbPlaytime :: Seconds -- ^ Total play time of all the songs in + -- the database. + , stsDbUpdate :: Integer -- ^ Last database update in UNIX time. + } + deriving (Eq, Show) + +defaultStats :: Stats +defaultStats = + Stats { stsArtists = 0, stsAlbums = 0, stsSongs = 0, stsUptime = 0 + , stsPlaytime = 0, stsDbPlaytime = 0, stsDbUpdate = 0 } + +instance Default Stats where + def = defaultStats + +-- | Container for MPD status. +data Status = + Status { stState :: State + -- | A percentage (0-100). + -- + -- 'Nothing' indicates that the output lacks mixer support. + , stVolume :: Maybe Int + , stRepeat :: Bool + , stRandom :: Bool + -- | A value that is incremented by the server every time the + -- playlist changes. + , stPlaylistVersion :: Integer + -- | The number of items in the current playlist. + , stPlaylistLength :: Integer + -- | Current song's position in the playlist. + , stSongPos :: Maybe Position + -- | Current song's playlist ID. + , stSongID :: Maybe Id + -- | Next song's position in the playlist. + , stNextSongPos :: Maybe Position + -- | Next song's playlist ID. + , stNextSongID :: Maybe Id + -- | Time elapsed\/total time of playing song (if any). + , stTime :: Maybe (Double, Seconds) + -- | Bitrate (in kilobytes per second) of playing song (if any). + , stBitrate :: Maybe Int + -- | Crossfade time. + , stXFadeWidth :: Seconds + -- | MixRamp threshold in dB + , stMixRampdB :: Double + -- | MixRamp extra delay in seconds + , stMixRampDelay :: Double + -- | Samplerate\/bits\/channels for the chosen output device + -- (see mpd.conf). + , stAudio :: (Int, Int, Int) + -- | Job ID of currently running update (if any). + , stUpdatingDb :: Maybe Integer + -- | If True, MPD will play only one song and stop after finishing it. + , stSingle :: Bool + -- | If True, a song will be removed after it has been played. + , stConsume :: Bool + -- | Last error message (if any). + , stError :: Maybe String } + deriving (Eq, Show) + +defaultStatus :: Status +defaultStatus = + Status { stState = Stopped, stVolume = Just 0, stRepeat = False + , stRandom = False, stPlaylistVersion = 0, stPlaylistLength = 0 + , stSongPos = Nothing, stSongID = Nothing, stTime = Nothing + , stNextSongPos = Nothing, stNextSongID = Nothing + , stBitrate = Nothing, stXFadeWidth = 0, stMixRampdB = 0 + , stMixRampDelay = 0, stAudio = (0,0,0), stUpdatingDb = Nothing + , stSingle = False, stConsume = False, stError = Nothing } + +instance Default Status where + def = defaultStatus diff --git a/src/Network/MPD/Core.hs b/src/Network/MPD/Core.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Core.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving, OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Module : Network.MPD.Core +-- Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 +-- License : MIT (see LICENSE) +-- Maintainer : Joachim Fasting +-- Stability : alpha +-- +-- The core datatypes and operations are defined here, including the +-- primary instance of the 'MonadMPD' class, 'MPD'. + +module Network.MPD.Core ( + -- * Classes + MonadMPD(..), + -- * Data types + MPD, MPDError(..), ACKType(..), Response, Host, Port, Password, + -- * Running + withMPDEx, + -- * Interacting + getResponse, kill, + ) where + +import Network.MPD.Util +import Network.MPD.Core.Class +import Network.MPD.Core.Error + +import Data.Char (isDigit) +import Control.Applicative (Applicative(..), (<$>), (<*)) +import qualified Control.Exception as E +import Control.Monad (ap, unless) +import Control.Monad.Error (ErrorT(..), MonadError(..)) +import Control.Monad.Reader (ReaderT(..), ask) +import Control.Monad.State (StateT, MonadIO(..), modify, gets, evalStateT) +import qualified Data.Foldable as F +import Network (PortID(..), withSocketsDo, connectTo) +import System.IO (Handle, hPutStrLn, hReady, hClose, hFlush) +import System.IO.Error (isEOFError, tryIOError, ioeGetErrorType) +import qualified System.IO.UTF8 as U +import Text.Printf (printf) +import qualified GHC.IO.Exception as GE + +import qualified Prelude +import Prelude hiding (break, drop, dropWhile, read) +import Data.ByteString.Char8 (ByteString, isPrefixOf, break, drop, dropWhile) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.UTF8 as UTF8 + +-- +-- Data types. +-- + +type Host = String +type Port = Integer + +-- +-- IO based MPD client implementation. +-- + +-- | The main implementation of an MPD client. It actually connects +-- to a server and interacts with it. +-- +-- To use the error throwing\/catching capabilities: +-- +-- > import Control.Monad.Error (throwError, catchError) +-- +-- To run IO actions within the MPD monad: +-- +-- > import Control.Monad.Trans (liftIO) + +newtype MPD a = + MPD { runMPD :: ErrorT MPDError + (StateT MPDState + (ReaderT (Host, Port) IO)) a + } deriving (Functor, Monad, MonadIO, MonadError MPDError) + +instance Applicative MPD where + (<*>) = ap + pure = return + +instance MonadMPD MPD where + open = mpdOpen + close = mpdClose + send = mpdSend + getPassword = MPD $ gets stPassword + setPassword pw = MPD $ modify (\st -> st { stPassword = pw }) + getVersion = MPD $ gets stVersion + +-- | Inner state for MPD +data MPDState = + MPDState { stHandle :: Maybe Handle + , stPassword :: String + , stVersion :: (Int, Int, Int) + } + +-- | A response is either an 'MPDError' or some result. +type Response = Either MPDError + +-- | The most configurable API for running an MPD action. +withMPDEx :: Host -> Port -> Password -> MPD a -> IO (Response a) +withMPDEx host port pw x = withSocketsDo $ + runReaderT (evalStateT (runErrorT . runMPD $ open >> (x <* close)) initState) + (host, port) + where initState = MPDState Nothing pw (0, 0, 0) + +mpdOpen :: MPD () +mpdOpen = MPD $ do + (host, port) <- ask + runMPD close + mHandle <- liftIO (safeConnectTo host port) + modify (\st -> st { stHandle = mHandle }) + F.forM_ mHandle $ \_ -> runMPD checkConn >>= (`unless` runMPD close) + where + safeConnectTo host@('/':_) _ = + (Just <$> connectTo "" (UnixSocket host)) + `E.catch` (\(_ :: E.SomeException) -> return Nothing) + safeConnectTo host port = + (Just <$> connectTo host (PortNumber $ fromInteger port)) + `E.catch` (\(_ :: E.SomeException) -> return Nothing) + checkConn = do + [msg] <- send "" + if "OK MPD" `isPrefixOf` msg + then MPD $ checkVersion $ parseVersion msg + else return False + + checkVersion Nothing = throwError $ Custom "Couldn't determine MPD version" + checkVersion (Just version) + | version < requiredVersion = + throwError $ Custom $ printf + "MPD %s is not supported, upgrade to MPD %s or above!" + (formatVersion version) (formatVersion requiredVersion) + | otherwise = do + modify (\st -> st { stVersion = version }) + return True + where + requiredVersion = (0, 15, 0) + + parseVersion = parseTriple '.' parseNum . dropWhile (not . isDigit) + + formatVersion :: (Int, Int, Int) -> String + formatVersion (x, y, z) = printf "%d.%d.%d" x y z + + +mpdClose :: MPD () +mpdClose = + MPD $ do + mHandle <- gets stHandle + F.forM_ mHandle $ \h -> do + modify $ \st -> st{stHandle = Nothing} + r <- liftIO $ sendClose h + F.forM_ r throwError + where + sendClose handle = + (hPutStrLn handle "close" >> hReady handle >> hClose handle >> return Nothing) + `E.catch` handler + + handler err + | isEOFError err = return Nothing + | otherwise = (return . Just . ConnectionError) err + +mpdSend :: String -> MPD [ByteString] +mpdSend str = send' `catchError` handler + where + handler err + | ConnectionError e <- err, isRetryable e = mpdOpen >> send' + | otherwise = throwError err + + send' :: MPD [ByteString] + send' = MPD $ gets stHandle >>= maybe (throwError NoMPD) go + + go handle = (liftIO . tryIOError $ do + unless (null str) $ U.hPutStrLn handle str >> hFlush handle + getLines handle []) + >>= either (\err -> modify (\st -> st { stHandle = Nothing }) + >> throwError (ConnectionError err)) return + + getLines :: Handle -> [ByteString] -> IO [ByteString] + getLines handle acc = do + l <- B.hGetLine handle + if "OK" `isPrefixOf` l || "ACK" `isPrefixOf` l + then (return . reverse) (l:acc) + else getLines handle (l:acc) + +-- | Re-connect and retry for these Exceptions. +isRetryable :: E.IOException -> Bool +isRetryable e = or [ isEOFError e, isResourceVanished e ] + +-- | Predicate to identify ResourceVanished exceptions. +-- Note: these are GHC only! +isResourceVanished :: GE.IOException -> Bool +isResourceVanished e = ioeGetErrorType e == GE.ResourceVanished + +-- +-- Other operations. +-- + +-- | Kill the server. Obviously, the connection is then invalid. +kill :: (MonadMPD m) => m () +kill = send "kill" >> return () + +-- | Send a command to the MPD server and return the result. +getResponse :: (MonadMPD m) => String -> m [ByteString] +getResponse cmd = (send cmd >>= parseResponse) `catchError` sendpw + where + sendpw e@(ACK Auth _) = do + pw <- getPassword + if null pw then throwError e + else send ("password " ++ pw) >>= parseResponse + >> send cmd >>= parseResponse + sendpw e = + throwError e + +-- Consume response and return a Response. +parseResponse :: (MonadError MPDError m) => [ByteString] -> m [ByteString] +parseResponse xs + | null xs = throwError $ NoMPD + | "ACK" `isPrefixOf` x = throwError $ parseAck x + | otherwise = return $ Prelude.takeWhile ("OK" /=) xs + where + x = head xs + +-- Turn MPD ACK into the corresponding 'MPDError' +parseAck :: ByteString -> MPDError +parseAck s = ACK ack (UTF8.toString msg) + where + ack = case code of + 2 -> InvalidArgument + 3 -> InvalidPassword + 4 -> Auth + 5 -> UnknownCommand + 50 -> FileNotFound + 51 -> PlaylistMax + 52 -> System + 53 -> PlaylistLoad + 54 -> Busy + 55 -> NotPlaying + 56 -> FileExists + _ -> UnknownACK + (code, _, msg) = splitAck s + +-- Break an ACK into (error code, current command, message). +-- ACKs are of the form: +-- ACK [error@command_listNum] {current_command} message_text\n +splitAck :: ByteString -> (Int, ByteString, ByteString) +splitAck s = (read code, cmd, msg) + where + (code, notCode) = between '[' '@' s + (cmd, notCmd) = between '{' '}' notCode + msg = drop 1 $ dropWhile (' ' ==) notCmd + + -- take whatever is between 'f' and 'g'. + between a b xs = let (_, y) = break (== a) xs + in break (== b) (drop 1 y) diff --git a/src/Network/MPD/Core/Class.hs b/src/Network/MPD/Core/Class.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Core/Class.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | Module : Network.MPD.Core.Class +-- Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 +-- License : MIT (see LICENSE) +-- Maintainer : Joachim Fasting +-- Stability : alpha +-- +-- The MPD typeclass. + +module Network.MPD.Core.Class where + +import Data.ByteString (ByteString) + +import Network.MPD.Core.Error (MPDError) + +import Control.Monad.Error (MonadError) + +type Password = String + +-- | A typeclass to allow for multiple implementations of a connection +-- to an MPD server. +class (Monad m, MonadError MPDError m) => MonadMPD m where + -- | Open (or re-open) a connection to the MPD server. + open :: m () + -- | Close the connection. + close :: m () + -- | Send a string to the server and return its response. + send :: String -> m [ByteString] + -- | Produce a password to send to the server should it ask for + -- one. + getPassword :: m Password + -- | Alters password to be sent to the server. + setPassword :: Password -> m () + -- | Get MPD protocol version + getVersion :: m (Int, Int, Int) diff --git a/src/Network/MPD/Core/Error.hs b/src/Network/MPD/Core/Error.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Core/Error.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +{- | +Module : Network.MPD.Core.Error +Copyright : (c) Joachim Fasting 2012 +License : MIT + +Maintainer : Joachim Fasting +Stability : unstable +Portability : unportable + +MPD errors. +-} + +module Network.MPD.Core.Error where + +import qualified Control.Exception as E +import Control.Monad.Error (Error(..)) +import Data.Typeable + +-- | The MPDError type is used to signal errors, both from the MPD and +-- otherwise. +data MPDError = NoMPD -- ^ MPD not responding + | ConnectionError E.IOException -- ^ An error occurred while talking to MPD. + | Unexpected String -- ^ MPD returned an unexpected response. + -- This is a bug, either in the library or + -- in MPD itself. + | Custom String -- ^ Used for misc. errors + | ACK ACKType String -- ^ ACK type and a message from the + -- server + deriving (Eq, Typeable) + +instance E.Exception MPDError + +instance Show MPDError where + show NoMPD = "Could not connect to MPD" + show (ConnectionError e) = "Connection error (" ++ show e ++ ")" + show (Unexpected s) = "MPD returned an unexpected response: " ++ unlines [ + s + , "" + , "This is most likely a bug in libmpd! Please report it here:" + , "" + , "https://github.com/vimus/libmpd-haskell/issues/new" + ] + show (Custom s) = s + show (ACK _ s) = s + +instance Error MPDError where + noMsg = Custom "An error occurred" + strMsg = Custom + +-- | Represents various MPD errors (aka. ACKs). +data ACKType = InvalidArgument -- ^ Invalid argument passed (ACK 2) + | InvalidPassword -- ^ Invalid password supplied (ACK 3) + | Auth -- ^ Authentication required (ACK 4) + | UnknownCommand -- ^ Unknown command (ACK 5) + | FileNotFound -- ^ File or directory not found ACK 50) + | PlaylistMax -- ^ Playlist at maximum size (ACK 51) + | System -- ^ A system error (ACK 52) + | PlaylistLoad -- ^ Playlist loading failed (ACK 53) + | Busy -- ^ Update already running (ACK 54) + | NotPlaying -- ^ An operation requiring playback + -- got interrupted (ACK 55) + | FileExists -- ^ File already exists (ACK 56) + | UnknownACK -- ^ An unknown ACK (aka. bug) + deriving Eq diff --git a/src/Network/MPD/Util.hs b/src/Network/MPD/Util.hs new file mode 100644 --- /dev/null +++ b/src/Network/MPD/Util.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Module : Network.MPD.Util +-- Copyright : (c) Ben Sinclair 2005-2009, Joachim Fasting 2010 +-- License : MIT (see LICENSE) +-- Maintainer : Joachim Fasting +-- Stability : alpha +-- +-- Utilities. + +module Network.MPD.Util ( + parseDate, parseIso8601, formatIso8601, parseNum, parseFrac, + parseBool, showBool, breakChar, parseTriple, + toAssoc, toAssocList, splitGroups, read + ) where + +import Control.Arrow + +import Data.Time.Format (ParseTime, parseTime, FormatTime, formatTime) +import System.Locale (defaultTimeLocale) + +import qualified Prelude +import Prelude hiding (break, take, drop, dropWhile, read) +import Data.ByteString.Char8 (break, drop, dropWhile, ByteString) +import qualified Data.ByteString.UTF8 as UTF8 +import Data.String + +import Control.Applicative +import qualified Data.Attoparsec.ByteString.Char8 as A + +-- | Like Prelude.read, but works with ByteString. +read :: Read a => ByteString -> a +read = Prelude.read . UTF8.toString + +-- Break a string by character, removing the separator. +breakChar :: Char -> ByteString -> (ByteString, ByteString) +breakChar c = second (drop 1) . break (== c) + +-- Parse a date value. +-- > parseDate "2008" = Just 2008 +-- > parseDate "2008-03-01" = Just 2008 +parseDate :: ByteString -> Maybe Int +parseDate = parseMaybe p + where + p = A.decimal <* A.skipMany (A.char '-' <|> A.digit) + +-- Parse date in iso 8601 format +parseIso8601 :: (ParseTime t) => ByteString -> Maybe t +parseIso8601 = parseTime defaultTimeLocale iso8601Format . UTF8.toString + +formatIso8601 :: FormatTime t => t -> String +formatIso8601 = formatTime defaultTimeLocale iso8601Format + +iso8601Format :: String +iso8601Format = "%FT%TZ" + +-- Parse a positive or negative integer value, returning 'Nothing' on failure. +parseNum :: (Read a, Integral a) => ByteString -> Maybe a +parseNum = parseMaybe (A.signed A.decimal) + +-- Parse C style floating point value, returning 'Nothing' on failure. +parseFrac :: (Fractional a, Read a) => ByteString -> Maybe a +parseFrac = parseMaybe p + where + p = A.string "nan" *> pure (Prelude.read "NaN") + <|> A.string "inf" *> pure (Prelude.read "Infinity") + <|> A.string "-inf" *> pure (Prelude.read "-Infinity") + <|> A.rational + +-- Inverts 'parseBool'. +showBool :: IsString a => Bool -> a +-- FIXME: can we change the type to (Bool -> ByteString)? +-- not without also changing Arg to use bytestrings rather than plain String. +showBool x = if x then "1" else "0" + +-- Parse a boolean response value. +parseBool :: ByteString -> Maybe Bool +parseBool = parseMaybe p + where + p = A.char '1' *> pure True <|> A.char '0' *> pure False + +-- Break a string into triple. +parseTriple :: Char -> (ByteString -> Maybe a) -> ByteString -> Maybe (a, a, a) +parseTriple c f s = let (u, u') = breakChar c s + (v, w) = breakChar c u' in + case (f u, f v, f w) of + (Just a, Just b, Just c') -> Just (a, b, c') + _ -> Nothing + +-- Break a string into a key-value pair, separating at the first ':'. +toAssoc :: ByteString -> (ByteString, ByteString) +toAssoc = second (dropWhile (== ' ') . drop 1) . break (== ':') + +toAssocList :: [ByteString] -> [(ByteString, ByteString)] +toAssocList = map toAssoc + +-- Takes an association list with recurring keys and groups each cycle of keys +-- with their values together. There can be several keys that begin cycles, +-- (the elements of the first parameter). +splitGroups :: [ByteString] -> [(ByteString, ByteString)] -> [[(ByteString, ByteString)]] +splitGroups groupHeads = go + where + go [] = [] + go (x:xs) = + let + (ys, zs) = Prelude.break isGroupHead xs + in + (x:ys) : go zs + + isGroupHead = (`elem` groupHeads) . fst + +-- A helper for running a Parser, turning errors into Nothing. +parseMaybe :: A.Parser a -> ByteString -> Maybe a +parseMaybe p s = either (const Nothing) Just $ A.parseOnly (p <* A.endOfInput) s diff --git a/tests/Arbitrary.hs b/tests/Arbitrary.hs --- a/tests/Arbitrary.hs +++ b/tests/Arbitrary.hs @@ -29,8 +29,8 @@ arbitrary = UTF8.fromString <$> arbitrary -- No longer provided by QuickCheck 2 -two :: Monad m => m a -> m (a, a) -two m = liftM2 (,) m m +-- two :: Monad m => m a -> m (a, a) +-- two m = liftM2 (,) m m three :: Monad m => m a -> m (a, a, a) three m = liftM3 (,,) m m m diff --git a/tests/CommandSpec.hs b/tests/CommandSpec.hs --- a/tests/CommandSpec.hs +++ b/tests/CommandSpec.hs @@ -12,30 +12,26 @@ module CommandSpec (main, spec) where import Arbitrary () -import Defaults () import StringConn import TestUtil import Unparse -import Test.Hspec.Monadic -import Test.Hspec.HUnit () - +import Network.MPD.Core import Network.MPD.Commands +import Network.MPD.Commands.Types import Network.MPD.Commands.Extensions -import Network.MPD.Core (MPDError(..), ACKType(..)) import Prelude hiding (repeat) -import Data.Default (Default(def)) main :: IO () -main = hspecX spec +main = hspec spec -spec :: Specs +spec :: Spec spec = do -- * Admin commands describe "enableOutput" $ do it "sends an enableoutput command" $ testEnableOutput - + describe "disableOutput" $ do it "sends an disableoutput command" $ testDisableOutput @@ -43,15 +39,30 @@ it "lists available outputs" $ testOutputs describe "update" $ do - it "updates entire collection by default" $ testUpdate0 - it "can update single paths" $ testUpdate1 - it "can update multiple paths" $ testUpdateMany + it "updates entire collection by default" $ do + cmd [("update", Right "updating_db: 23\nOK")] (Right 23) + (update Nothing) + it "can update a specific path" $ do + cmd [("update \"foo\"", Right "updating_db: 23\nOK")] (Right 23) + (update $ Just "foo") + + describe "rescan" $ do + it "returns entire collection by default" $ do + cmd [("rescan", Right "updating_db: 23\nOK")] (Right 23) + (rescan Nothing) + + it "can rescan a specific path" $ do + cmd [("rescan \"foo\"", Right "updating_db: 23\nOK")] (Right 23) + (rescan $ Just "foo") + -- * Database commands +{- XXX: incorrect; fixed in the applicative version describe "list" $ do it "returns a list of values for a given metadata type" $ testListAny it "can constrain listing to entries matching a query" $ testListQuery +-} describe "listAll" $ do it "lists everything" $ testListAll @@ -66,28 +77,17 @@ it "returns a count of items matching a query" $ testCount -- * Playlist commands - - describe "add" $ do - it "adds a url to the current playlist" $ testAdd - - describe "add_" $ do - it "adds a url to current playlist, returning nothing" $ testAdd_ - describe "playlistAdd" $ do it "adds a url to a stored playlist" $ testPlaylistAdd - describe "addId" $ do - it "adds a url to a stored playlist, returning the pl index" $ testAddId - describe "playlistClear" $ do it "clears a stored playlist" $ testPlaylistClear - describe "clear" $ do - it "clears current play list" $ testClear - describe "plChangesPosid" $ do it "does something ..." $ testPlChangesPosId +{- XXX: doesn't work it "fails on weird input" $ testPlChangesPosIdWeird +-} -- XXX: this is ill-defined {- @@ -160,11 +160,6 @@ it "gets database stats" $ testStats -- * Extensions - - describe "updateId" $ do - it "returns the job id" $ do - testUpdateId0 - testUpdateId1 describe "toggle" $ do it "starts playback if paused" $ testTogglePlay it "stops playback if playing" $ testToggleStop @@ -173,10 +168,14 @@ it "can also add to stored playlists" $ testAddMany1 describe "volume" $ do it "adjusts volume relative to current volume" $ testVolume - -cmd_ expect f = cmd expect (Right ()) f -cmd expect resp f = testMPD expect resp "" f `shouldBe` Ok + +cmd_ :: [(Expect, Response String)] -> StringMPD () -> Expectation +cmd_ expect f = cmd expect (Right ()) f + +cmd :: (Eq a, Show a) => [(Expect, Response String)] -> Response a -> StringMPD a -> Expectation +cmd expect resp f = testMPD expect f `shouldBe` resp + -- -- Admin commands -- @@ -191,18 +190,13 @@ resp = concatMap unparse [obj1, obj2] ++ "OK" cmd [("outputs", Right resp)] (Right [obj1, obj2]) outputs -testUpdate0 = cmd_ [("update", Right "updating_db: 1\nOK")] (update []) -testUpdate1 = - cmd_ [("update \"foo\"", Right "updating_db: 1\nOK")] (update ["foo"]) -testUpdateMany = - cmd_ [("command_list_begin\nupdate \"foo\"\nupdate \"bar\"\ncommand_list_end", Right "updating_db: 1\nOK")] - (update ["foo","bar"]) -- -- Database commands -- +{- XXX: this is incorrect -- XXX: generalize to arbitrary Metadata values testListAny = cmd [("list Title", Right "Title: Foo\nTitle: Bar\nOK")] (Right ["Foo", "Bar"]) @@ -211,6 +205,7 @@ testListQuery = cmd [("list Title Artist \"Muzz\"", Right "Title: Foo\nOK")] (Right ["Foo"]) (list Title (Artist =? "Muzz")) +-} testListAll = cmd [("listall \"\"", Right "directory: FooBand\n\ @@ -243,41 +238,25 @@ -- -- Playlist commands -- - -testAdd = - cmd [("add \"foo\"", Right "OK"), - ("listall \"foo\"", Right "file: Foo\nfile: Bar\nOK")] - (Right ["Foo", "Bar"]) - (add "foo") - -testAdd_ = - cmd_ [("add \"foo\"", Right "OK")] (add_ "foo") - testPlaylistAdd = cmd_ [("playlistadd \"foo\" \"bar\"", Right "OK")] - (playlistAdd_ "foo" "bar") - -testAddId = - cmd [("addid \"dir/Foo-Bar.ogg\"", Right "Id: 20\nOK")] - (Right $ Id 20) - (addId "dir/Foo-Bar.ogg" Nothing) + (playlistAdd "foo" "bar") testPlaylistClear = cmd_ [("playlistclear \"foo\"", Right "OK")] (playlistClear "foo") -testClear = - cmd_ [("clear", Right "OK")] clear - testPlChangesPosId = cmd [("plchangesposid 10", Right "OK")] (Right []) (plChangesPosId 10) +{- XXX: testPlChangesPosIdWeird = cmd [("plchangesposid 10", Right "cpos: foo\nId: bar\nOK")] (Left $ Unexpected "[(\"cpos\",\"foo\"),(\"Id\",\"bar\")]") (plChangesPosId 10) +-} -- XXX: this is ill-defined {- @@ -293,7 +272,7 @@ testLoad = cmd_ [("load \"foo\"", Right "OK")] (load "foo") -testMove2 = cmd_ [("playlistmove \"foo\" 1 2", Right "OK")] (playlistMove "foo" 1 2) +testMove2 = cmd_ [("playlistmove \"foo\" 23 2", Right "OK")] (playlistMove "foo" (Id 23) 2) testRm = cmd_ [("rm \"foo\"", Right "OK")] (rm "foo") @@ -365,7 +344,7 @@ testPassword = cmd_ [("password foo", Right "OK")] (password "foo") testPasswordSucceeds = - testMPD convo expected_resp "foo" cmd_in `shouldBe` Ok + testMPDWithPassword convo "foo" cmd_in `shouldBe` expected_resp where convo = [("lsinfo \"/\"", Right "ACK [4@0] {play} you don't have \ \permission for \"play\"") @@ -375,7 +354,7 @@ cmd_in = lsInfo "/" testPasswordFails = - testMPD convo expected_resp "foo" cmd_in `shouldBe` Ok + testMPDWithPassword convo "foo" cmd_in `shouldBe` expected_resp where convo = [("play", Right "ACK [4@0] {play} you don't have \ \permission for \"play\"") @@ -397,14 +376,6 @@ -- Extensions\/shortcuts -- -testUpdateId0 = cmd [("update", Right "updating_db: 1")] - (Right 1) - (updateId []) - -testUpdateId1 = cmd [("update \"foo\"", Right "updating_db: 1")] - (Right 1) - (updateId ["foo"]) - testTogglePlay = cmd_ [("status", Right resp) ,("pause 1", Right "OK")] @@ -432,4 +403,4 @@ (addMany "foo" ["bar"]) testVolume = cmd_ [("status", Right st), ("setvol 90", Right "OK")] (volume (-10)) - where st = unparse def { stVolume = 100 } + where st = unparse def { stVolume = Just 100 } diff --git a/tests/Defaults.hs b/tests/Defaults.hs deleted file mode 100644 --- a/tests/Defaults.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Defaults where - -import Data.Default -import Network.MPD.Commands.Types - -instance Default Count where - def = defaultCount - -instance Default Device where - def = defaultDevice - --- XXX: note Song has no sensible default value --- XXX: or does it? - -instance Default Stats where - def = defaultStats - -instance Default Status where - def = defaultStatus diff --git a/tests/EnvSpec.hs b/tests/EnvSpec.hs --- a/tests/EnvSpec.hs +++ b/tests/EnvSpec.hs @@ -1,15 +1,14 @@ module EnvSpec (main, spec) where import TestUtil -import Test.Hspec.Monadic import Network.MPD import System.Posix.Env hiding (getEnvDefault) main :: IO () -main = hspecX spec +main = hspec spec -spec :: Specs +spec :: Spec spec = do describe "getEnvDefault" $ do it "returns the value of an environment variable" $ do diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,14 +1,1 @@ -module Main (main) where - -import qualified CommandSpec -import qualified EnvSpec -import qualified ParserSpec -import qualified UtilSpec -import Test.Hspec.Monadic (describe, hspecX) - -main :: IO () -main = hspecX $ do - describe "CommandSpec" CommandSpec.spec - describe "EnvSpec" EnvSpec.spec - describe "ParserSpec" ParserSpec.spec - describe "UtilSpec" UtilSpec.spec +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tests/ParserSpec.hs b/tests/ParserSpec.hs --- a/tests/ParserSpec.hs +++ b/tests/ParserSpec.hs @@ -4,11 +4,9 @@ module ParserSpec (main, spec) where import Arbitrary () -import Defaults () import Unparse -import Test.Hspec.Monadic -import Test.Hspec.HUnit () +import Test.Hspec import Test.Hspec.QuickCheck (prop) import Network.MPD.Commands.Parse @@ -21,9 +19,9 @@ import Data.Time main :: IO () -main = hspecX spec +main = hspec spec -spec :: Specs +spec :: Spec spec = do describe "parseIso8601" $ do prop "parses dates in ISO8601 format" prop_parseIso8601 diff --git a/tests/StringConn.hs b/tests/StringConn.hs --- a/tests/StringConn.hs +++ b/tests/StringConn.hs @@ -3,7 +3,7 @@ -- | Module : StringConn -- Copyright : (c) Ben Sinclair 2005-2009 --- License : LGPL (see LICENSE) +-- License : MIT (see LICENSE) -- Maintainer : bsinclai@turing.une.edu.au -- Stability : alpha -- @@ -35,26 +35,14 @@ | BadRequest StringMPDError deriving (Show, Eq) -newtype MatchError = MErr (Either StringMPDError MPDError) -instance Error MatchError where - strMsg = MErr . Right . strMsg - newtype StringMPD a = - SMPD { runSMPD :: ErrorT MatchError + SMPD { runSMPD :: ErrorT MPDError (StateT [(Expect, Response String)] (ReaderT Password Identity)) a - } deriving (Functor, Monad) - -instance MonadError MPDError StringMPD where - throwError = SMPD . throwError . MErr . Right - catchError m f = SMPD $ catchError (runSMPD m) handler - where - handler err@(MErr (Left _)) = throwError err - handler (MErr (Right err)) = runSMPD (f err) + } deriving (Functor, Monad, MonadError MPDError) instance MonadMPD StringMPD where getVersion = error "StringConn.getVersion: undefined" - getHandle = error "StringConn.getHandle: undefined" setPassword = error "StringConn.setPassword: undefined" open = return () @@ -64,33 +52,24 @@ SMPD $ do ~pairs@((expected_request,response):rest) <- get when (null pairs) - (throwError . MErr $ Left TooManyRequests) + (throwError $ Custom "too many requests") when (expected_request /= request) - (throwError . MErr . Left - $ UnexpectedRequest expected_request request) + (throwError . Custom $ "unexpected request: " ++ show request ++ ", expected: " ++ show expected_request) put rest - either (throwError . MErr . Right) (return . B.lines . UTF8.fromString) response + either throwError (return . B.lines . UTF8.fromString) response +testMPD :: (Eq a) => [(Expect, Response String)] -> StringMPD a -> Response a +testMPD pairs m = testMPDWithPassword pairs "" m + -- | Run an action against a set of expected requests and responses, -- and an expected result. The result is Nothing if everything matched -- what was expected. If anything differed the result of the -- computation is returned along with pairs of expected and received -- requests. -testMPD :: (Eq a) +testMPDWithPassword :: (Eq a) => [(Expect, Response String)] -- ^ The expected requests and their -- ^ corresponding responses. - -> Response a -- ^ The expected final result. -> Password -- ^ A password to be supplied. -> StringMPD a -- ^ The MPD action to run. - -> Result a -testMPD pairs expected passwd m = - let result = runIdentity - $ runReaderT (evalStateT (runErrorT $ runSMPD m) pairs) passwd - in case result of - Right r - | Right r == expected -> Ok - | otherwise -> BadResult expected (Right r) - Left (MErr (Right r)) - | Left r == expected -> Ok - | otherwise -> BadResult expected (Left r) - Left (MErr (Left e)) -> BadRequest e + -> Response a +testMPDWithPassword pairs passwd m = runIdentity $ runReaderT (evalStateT (runErrorT $ runSMPD m) pairs) passwd diff --git a/tests/TestUtil.hs b/tests/TestUtil.hs --- a/tests/TestUtil.hs +++ b/tests/TestUtil.hs @@ -1,7 +1,21 @@ -module TestUtil (shouldBe) where +module TestUtil ( + with +, withPassword +, module StringConn +, module Test.Hspec +) where -import Test.Hspec.HUnit () -import Test.HUnit +import Network.MPD.Core +import Network.MPD.Applicative -shouldBe :: (Eq a, Show a) => a -> a -> Assertion -shouldBe = (@?=) +import Test.Hspec +import StringConn + +with :: Eq a => Command a -> [(Expect, Response String)] -> Response a +with = flip testMPD . runCommand + +withPassword :: Eq a => Password + -> [(Expect, Response String)] + -> Command a + -> Response a +withPassword pwd ps m = testMPDWithPassword ps pwd (runCommand m) diff --git a/tests/Unparse.hs b/tests/Unparse.hs --- a/tests/Unparse.hs +++ b/tests/Unparse.hs @@ -9,6 +9,10 @@ class Unparse parsed where unparse :: parsed -> String +instance Unparse a => Unparse (Maybe a) where + unparse Nothing = "" + unparse (Just x) = unparse x + instance Unparse Count where unparse x = unlines [ "songs: " ++ show (cSongs x) @@ -54,22 +58,21 @@ [ "state: " ++ (case stState s of Playing -> "play" Paused -> "pause" _ -> "stop") - , "volume: " ++ show (stVolume s) + , "volume: " ++ maybe "-1" show (stVolume s) , "repeat: " ++ showBool (stRepeat s) , "random: " ++ showBool (stRandom s) , "playlist: " ++ show (stPlaylistVersion s) , "playlistlength: " ++ show (stPlaylistLength s) , "xfade: " ++ show (stXFadeWidth s) - , "time: " ++ (let (x, y) = stTime s in show x ++ ":" ++ show y) - , "bitrate: " ++ show (stBitrate s) , "xfade: " ++ show (stXFadeWidth s) - , "audio: " ++ (let (x, y, z) = stAudio s in show x ++ ":" ++ show y ++ ":" ++ show z) - , "updating_db: " ++ show (stUpdatingDb s) - , "error: " ++ show (stError s) , "single: " ++ showBool (stSingle s) , "consume: " ++ showBool (stConsume s) ] + ++ maybe [] (\n -> ["updating_db: " ++ show n]) (stUpdatingDb s) ++ maybe [] (\n -> ["song: " ++ show n]) (stSongPos s) ++ maybe [] (\n -> ["songid: " ++ show n]) (stSongID s) + ++ maybe [] (\n -> ["error: " ++ show n]) (stError s) + ++ maybe [] (\(x, y) -> ["time: " ++ show x ++ ":" ++ show y]) (stTime s) + ++ maybe [] (\n -> ["bitrate: " ++ show n]) (stBitrate s) diff --git a/tests/UtilSpec.hs b/tests/UtilSpec.hs --- a/tests/UtilSpec.hs +++ b/tests/UtilSpec.hs @@ -6,8 +6,6 @@ import Arbitrary import TestUtil -import Test.Hspec.Monadic -import Test.Hspec.HUnit () import Test.Hspec.QuickCheck (prop) import Test.QuickCheck @@ -19,9 +17,9 @@ import Network.MPD.Util main :: IO () -main = hspecX spec +main = hspec spec -spec :: Specs +spec :: Spec spec = do describe "splitGroups" $ do it "breaks an association list into sublists" $ do