diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,1 @@ +GPL diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/gen_gettext b/gen_gettext new file mode 100644 --- /dev/null +++ b/gen_gettext @@ -0,0 +1,27 @@ +#!/bin/bash + +hgettext -k __ -o i18n/messages.pot \ + src/Mp/UI/PlaylistPage.hs \ + src/Mp/UI/PlaylistPage.hs \ + src/Mp/UI/Menu.hs \ + src/Mp/UI/QueuePage.hs \ + src/Mp/UI/Main.hs \ + src/Mp/UI/StatusBar.hs \ + src/Mp/UI/PlaylistState.hs \ + src/Mp/UI/BrowserPage.hs \ + src/Mp/UI/HelpPage.hs \ + src/Mp/UI/EditBar.hs \ + src/Mp/Main.hs \ + src/Mp/Player/GstPlayer.hs \ + src/Mp/Player/ServerState.hs \ + src/Mp/Player/Daemon.hs \ + src/Mp/Player/Server.hs \ + src/Mp/Player/Client.hs \ + src/Mp/Configuration/ConfigurationFile.hs \ + src/Mp/Configuration/Configuration.hs \ + src/Mp/Utils/Utils.hs \ + src/Mp/Utils/Exception.hs \ + src/Mp/Utils/I18N.hs \ + src/Mp/Utils/Colors.hs \ + src/Mp/Utils/Network.hs \ + src/Mp/Utils/Shuffle.hs diff --git a/i18n/messages.pot b/i18n/messages.pot new file mode 100644 --- /dev/null +++ b/i18n/messages.pot @@ -0,0 +1,183 @@ +# Translation file + +msgid "" +msgstr "" + +"Project-Id-Version: PACKAGE VERSION\n" +"Report-Msgid-Bugs-To: \n" +"POT-Creation-Date: 2009-01-13 06:05-0800\n" +"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" +"Last-Translator: FULL NAME \n" +"Language-Team: LANGUAGE \n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" + +#: src/Mp/UI/Menu.hs:0 +msgid " [1] Help " +msgstr "" + +#: src/Mp/UI/Menu.hs:0 +msgid " [2] Queue " +msgstr "" + +#: src/Mp/UI/Menu.hs:0 +msgid " [3] Playlists " +msgstr "" + +#: src/Mp/UI/Menu.hs:0 +msgid " [4] Browser " +msgstr "" + +#: src/Mp/UI/Main.hs:0 +msgid "File exists. Overwrite (Y/N) ?" +msgstr "" + +#: src/Mp/UI/Main.hs:0 +msgid "Enter playlist name:" +msgstr "" + +#: src/Mp/UI/StatusBar.hs:0 +msgid "Stopped" +msgstr "" + +#: src/Mp/UI/StatusBar.hs:0 +msgid "Volume:" +msgstr "" + +#: src/Mp/UI/StatusBar.hs:0 +msgid "Playing" +msgstr "" + +#: src/Mp/UI/StatusBar.hs:0 +msgid "Paused" +msgstr "" + +#: src/Mp/UI/StatusBar.hs:0 +msgid "Unknown" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Detach from the server" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Quit" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Help screen" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Queue screen" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Playlists screen" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Browser screen" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Next screen" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Previous screen" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Move cursor up" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Move cursor down" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Page up" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Page down" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Start playing / Enter directory / Enter playlist" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Stop playing" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Pause / resume playing" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Add file / directory / playlist" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Remove file / directory / playlist" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Clear the queue" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Center" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Save playlist" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Delete playlist" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Go to root directory" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Go to parent directory" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Play next file" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Play previous file" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Seek forward" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Seek backward" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Toggle repeat mode" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Toggle random mode" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Decrease volume" +msgstr "" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Increase volume" +msgstr "" + diff --git a/i18n/pl.po b/i18n/pl.po new file mode 100644 --- /dev/null +++ b/i18n/pl.po @@ -0,0 +1,182 @@ +# Translation file +msgid "" +msgstr "" +"Project-Id-Version: workspace 4\n" +"Report-Msgid-Bugs-To: \n" +"POT-Creation-Date: 2009-01-13 06:05-0800\n" +"PO-Revision-Date: 2014-09-25 18:28+0000\n" +"Last-Translator: piotr \n" +"Language-Team: Polish\n" +"Language: pl\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"Plural-Forms: nplurals=2; plural=(n != 1);\n" + +#: src/Mp/UI/Menu.hs:0 +msgid " [1] Help " +msgstr " [1] Pomoc " + +#: src/Mp/UI/Menu.hs:0 +msgid " [2] Queue " +msgstr " [2] Lista " + +#: src/Mp/UI/Menu.hs:0 +msgid " [3] Playlists " +msgstr " [3] Playlisty " + +#: src/Mp/UI/Menu.hs:0 +msgid " [4] Browser " +msgstr " [4] Przeglądaj " + +#: src/Mp/UI/Main.hs:0 +msgid "File exists. Overwrite (Y/N) ?" +msgstr "Plik istnieje. Nadpisać (Y/N) ?" + +#: src/Mp/UI/Main.hs:0 +msgid "Enter playlist name:" +msgstr "Wpisza nazwę dla playlisty:" + +#: src/Mp/UI/StatusBar.hs:0 +msgid "Stopped" +msgstr "Zatrzymane" + +#: src/Mp/UI/StatusBar.hs:0 +msgid "Volume:" +msgstr "Głośność:" + +#: src/Mp/UI/StatusBar.hs:0 +msgid "Playing" +msgstr "Odtwarzanie" + +#: src/Mp/UI/StatusBar.hs:0 +msgid "Paused" +msgstr "Wstrzymane" + +#: src/Mp/UI/StatusBar.hs:0 +msgid "Unknown" +msgstr "Unknown" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Detach from the server" +msgstr "Wyjdź i odtwarzaj muzykę w tle" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Quit" +msgstr "Wyjdź" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Help screen" +msgstr "Ekran pomocy" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Queue screen" +msgstr "Ekran listy odwarzania" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Playlists screen" +msgstr "Ekran playlist" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Browser screen" +msgstr "Ekran przeglądania" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Next screen" +msgstr "Następny ekran" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Previous screen" +msgstr "Poprzedni ekran" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Move cursor up" +msgstr "Przesuń kursor w górę" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Move cursor down" +msgstr "Przesuń kursor w dół" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Page up" +msgstr "Przesuń o stronę do góry" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Page down" +msgstr "Przesuń o stronę w dół" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Start playing / Enter directory / Enter playlist" +msgstr "Odwarzaj / Otwórz katalog / Wejdź do playlisty" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Stop playing" +msgstr "Zatrzymaj odtwarzanie" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Pause / resume playing" +msgstr "Wstrzymaj odtwarzanie" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Add file / directory / playlist" +msgstr "Dodaj plik / katalog / playlistę do listy odtwarzania" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Remove file / directory / playlist" +msgstr "Usuń plik / katalog / playlistę z listy odtwarzania" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Clear the queue" +msgstr "Wyczyść listę odtwarzania" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Center" +msgstr "Wyśrodkuj" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Save playlist" +msgstr "Zapisz listę odtwarzania" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Delete playlist" +msgstr "Usuń listę odtwarzania" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Go to root directory" +msgstr "Przejdź do katalogu głównego" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Go to parent directory" +msgstr "przejdź do katalogu nadrzędnego" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Play next file" +msgstr "Następna ścieżka" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Play previous file" +msgstr "Poprzednia ścieżka" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Seek forward" +msgstr "Przewiń naprzód" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Seek backward" +msgstr "Przewiń wstecz" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Toggle repeat mode" +msgstr "Przełącz tryb powtarzania" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Toggle random mode" +msgstr "Przełącz tryb losowy" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Decrease volume" +msgstr "Przycisz" + +#: src/Mp/UI/HelpPage.hs:0 +msgid "Increase volume" +msgstr "Zgłośnij" diff --git a/i18n/pl/LC_MESSAGES/mp.mo b/i18n/pl/LC_MESSAGES/mp.mo new file mode 100644 Binary files /dev/null and b/i18n/pl/LC_MESSAGES/mp.mo differ diff --git a/mp.cabal b/mp.cabal new file mode 100644 --- /dev/null +++ b/mp.cabal @@ -0,0 +1,56 @@ +name: mp +version: 0.1.3 +cabal-version: >=1.16 +build-type: Simple +author: Piotr Borek +maintainer: Piotr Borek +license: GPL +license-file: LICENSE +synopsis: Music player for linux. +description: Music player for linux. +category: Sound + +data-files: + gen_gettext + i18n/messages.pot + i18n/pl.po + i18n/pl/LC_MESSAGES/mp.mo + +executable mp + hs-source-dirs: src + main-is: Mp/Main.hs + build-depends: base (>= 4 && < 5), vty-ui == 1.7.1, vty < 5, text, + directory (>= 1.2 && < 1.3), ConfigFile (>= 1.1 && < 1.2), + MissingH (>= 1.2 && < 1.3), filepath (>= 1.3 && < 1.4), + daemons (>= 0.2 && < 0.3), bytestring, network (>= 2.6 && < 2.7), + gstreamer (>= 0.12.5.0 && < 0.13), glib (>= 0.12.5.0 && < 0.13), + unordered-containers (>= 0.2 && < 0.3), binary (>= 0.7 && < 0.8), + hgettext (>= 0.1 && < 0.2), setlocale, unix, random, utf8-string, + mtl + default-language: Haskell2010 + ghc-options: -Wall -O2 -threaded + + other-modules: + Mp.UI.PlaylistPage + Mp.UI.Menu + Mp.UI.QueuePage + Mp.UI.Main + Mp.UI.StatusBar + Mp.UI.PlaylistState + Mp.UI.BrowserPage + Mp.UI.HelpPage + Mp.UI.EditBar + Mp.Player.GstPlayer + Mp.Player.ServerState + Mp.Player.Daemon + Mp.Player.Server + Mp.Player.Client + Mp.Configuration.ConfigurationFile + Mp.Configuration.Configuration + Mp.Utils.Utils + Mp.Utils.Exception + Mp.Utils.I18N + Mp.Utils.Shuffle + Mp.Utils.Colors + Mp.Utils.Network + diff --git a/src/Mp/Configuration/Configuration.hs b/src/Mp/Configuration/Configuration.hs new file mode 100644 --- /dev/null +++ b/src/Mp/Configuration/Configuration.hs @@ -0,0 +1,91 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Mp.Configuration.Configuration ( + configDirFilePath, + playlistDirFilePath, + readConfiguration, + getConfiguration, + getMusicDirectory, + getConfigurationColor, + makeDefaultConfiguration +) where + +import Control.Monad +import System.Environment +import System.Directory +import Data.Either.Utils +import Data.ConfigFile hiding (content) +import Graphics.Vty +import System.FilePath.Posix + +import Mp.Utils.Utils +import Mp.Configuration.ConfigurationFile + +configDir :: String +configDir = ".config/mp" + +configFile :: String +configFile = "mp.config" + +configDirFilePath :: IO FilePath +configDirFilePath = do + homeDir <- getEnv "HOME" + return $ homeDir configDir + +playlistDirFilePath :: IO FilePath +playlistDirFilePath = do + cfg <- configDirFilePath + return $ cfg "playlists" + +readConfiguration :: IO ConfigParser +readConfiguration = do + confDir <- configDirFilePath + let file = confDir configFile + conf <- readfile emptyCP file + return $ forceEither conf + +getConfiguration :: ConfigParser -> SectionSpec -> OptionSpec -> String +getConfiguration parser section option = + forceEither $ get parser section option + +getMusicDirectory :: ConfigParser -> String +getMusicDirectory conf = getConfiguration conf "general" "music_dir" + +getConfigurationColor :: ConfigParser -> OptionSpec -> (Color, Style) +getConfigurationColor parser option = toVtyColor $ getConfiguration parser "colors" option + +makeDefaultConfiguration :: IO () +makeDefaultConfiguration = do + confDir <- configDirFilePath + playlistDir <- playlistDirFilePath + createDirectoryIfMissing True confDir + createDirectoryIfMissing True playlistDir + makeDefaultConfigurationFile confDir + +makeDefaultConfigurationFile :: String -> IO () +makeDefaultConfigurationFile confDir = do + homeDir <- getEnv "HOME" + exist <- doesFileExist file + unless exist $ writeFile file $ defaultConfiguration homeDir + where + file = confDir configFile diff --git a/src/Mp/Configuration/ConfigurationFile.hs b/src/Mp/Configuration/ConfigurationFile.hs new file mode 100644 --- /dev/null +++ b/src/Mp/Configuration/ConfigurationFile.hs @@ -0,0 +1,81 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Mp.Configuration.ConfigurationFile where + +defaultConfiguration :: String -> String +defaultConfiguration home_dir = + "# mp configuration file\n" ++ + "\n" ++ + "[general]\n" ++ + "music_dir = " ++ home_dir ++ "\n\n" ++ + "[colors]\n" ++ + "# Valid colors :\n" ++ + "# black\n" ++ + "# white\n" ++ + "# cyan\n" ++ + "# magenta\n" ++ + "# blue\n" ++ + "# yellow\n" ++ + "# green\n" ++ + "# red\n" ++ + "#\n" ++ + "# Additional colors for foreground:\n" ++ + "#\n" ++ + "# brightBlack\n" ++ + "# brightYellow\n" ++ + "# brightGreen\n" ++ + "# brightRed\n" ++ + "# brightBlue\n" ++ + "# brightWhite\n" ++ + "# brightCyan\n" ++ + "# brightMagenta\n" ++ + "tab_foreground = black\n" ++ + "tab_background = green\n" ++ + "tab_active_foreground = brightWhite\n" ++ + "tab_active_background = blue\n" ++ + "\n" ++ + "status_foreground = brightWhite\n" ++ + "status_background = blue\n" ++ + "\n" ++ + "help_foreground = white\n" ++ + "help_background = black\n" ++ + "\n" ++ + "browser_background = black\n" ++ + "browser_dir_foreground = brightWhite\n" ++ + "browser_file_foreground = white\n" ++ + "browser_active_background = yellow\n" ++ + "browser_selected_foreground = brightCyan\n" ++ + "\n" ++ + "queue_foreground = white\n" ++ + "queue_background = black\n" ++ + "queue_active_background = yellow\n" ++ + "queue_selected_foreground = brightCyan\n" ++ + "\n" ++ + "playlist_background = black\n" ++ + "playlist_foreground = brightWhite\n" ++ + "playlist_file_foreground = white\n" ++ + "playlist_selected_foreground = brightCyan\n" ++ + "playlist_active_background = yellow\n" ++ + "\n" ++ + "edit_background = black\n" ++ + "edit_foreground = brightWhite\n" diff --git a/src/Mp/Main.hs b/src/Mp/Main.hs new file mode 100644 --- /dev/null +++ b/src/Mp/Main.hs @@ -0,0 +1,59 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Main where + +import Text.I18N.GetText +import System.Locale.SetLocale +import System.Directory +import System.Environment +import System.FilePath.Posix + +import Mp.Configuration.Configuration +import Mp.Player.Daemon +import Mp.UI.Main +import Mp.Utils.Utils + +main :: IO () +main = do + args <- getArgs + exePath <- findExecutable "mp" + dir <- getCurrentDirectory + + _ <- setLocale LC_ALL (Just "") + + _ <- case exePath of + Just path -> do + let (exeDir, _) = separateFilePath path + bindTextDomain "mp" (Just $ exeDir "i18n") + Nothing -> + bindTextDomain "mp" (Just $ dir "i18n") + + _ <- textDomain (Just "mp") + + makeDefaultConfiguration + runPlayerDaemon + + if any ("--daemon" == ) args then + return () + else + makeAndRunUI diff --git a/src/Mp/Player/Client.hs b/src/Mp/Player/Client.hs new file mode 100644 --- /dev/null +++ b/src/Mp/Player/Client.hs @@ -0,0 +1,164 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Mp.Player.Client ( + clientSendQuitMessage, + clientSendAddFile, + clientSendRemove, + clientSendClear, + clientSendGetPlaylist, + clientSendGetStatus, + clientSendSetPlaying, + clientSendGetPlaying, + clientSendStopPlaying, + clientSendPausePlaying, + clientSendResumePlaying, + clientSendPlayNext, + clientSendPlayPrev, + clientSendVolumeUp, + clientSendVolumeDown, + clientSendVolumeGet, + clientSendSeekForward, + clientSendSeekBackward, + clientSendGetFlags, + clientSendToggleRepeat, + clientSendToggleShuffle +) where + +import System.FilePath.Posix +import Network.Socket hiding (send, sendTo, recv, recvFrom) + +import Mp.Configuration.Configuration +import Mp.Utils.Network + +withConnection :: (Socket -> IO a) -> IO a +withConnection action = do + confPath <- configDirFilePath + let socName = confPath "mp.socket" + + sock <- socket AF_UNIX Stream defaultProtocol + connect sock $ SockAddrUnix socName + + value <- action sock + + close sock + return value + +sendMessage :: String -> Socket -> IO String +sendMessage msg sock = do + sendString sock msg -- send message + rval <- recvString sock -- receive answer + return rval + +sendMessage_ :: String -> Socket -> IO () +sendMessage_ msg sock = sendMessage msg sock >> return () + +clientSendQuitMessage :: IO () +clientSendQuitMessage = withConnection $ sendMessage_ "Quit" + +clientSendAddFile :: String -> IO () +clientSendAddFile file = do + withConnection $ \conn -> do + sendMessage_ "Add" conn + sendMessage_ file conn + +clientSendRemove :: Int -> IO () +clientSendRemove index = do + withConnection $ \conn -> do + sendMessage_ "Remove" conn + sendMessage_ (show index) conn + +clientSendClear :: IO () +clientSendClear = withConnection $ sendMessage_ "Clear" + +clientSendGetPlaylist :: IO [String] +clientSendGetPlaylist = do + withConnection $ \conn -> do + item <- sendMessage "GetPlaylist" conn + if item == "EndPlaylist" + then return [] + else processMessages [item] conn + where + processMessages xs conn = do + item <- sendMessage "Get" conn + if (item == "EndPlaylist") + then return xs + else processMessages (item : xs) conn + +clientSendGetStatus :: IO (String, Integer, Integer) +clientSendGetStatus = do + withConnection $ \conn -> do + status <- sendMessage "GetStatus" conn + dur <- sendMessage "GetDuration" conn + pos <- sendMessage "GetPosition" conn + return (status, (read dur :: Integer), (read pos :: Integer)) + +clientSendSetPlaying :: Int -> IO () +clientSendSetPlaying index = do + withConnection $ \conn -> do + sendMessage_ "SetPlay" conn + sendMessage_ (show index) conn + +clientSendGetPlaying :: IO Int +clientSendGetPlaying = do + withConnection $ \conn -> do + index <- sendMessage "GetPlay" conn + return (read index :: Int) + +clientSendStopPlaying :: IO () +clientSendStopPlaying = withConnection $ sendMessage_ "Stop" + +clientSendPausePlaying :: IO () +clientSendPausePlaying = withConnection $ sendMessage_ "Pause" + +clientSendResumePlaying :: IO () +clientSendResumePlaying = withConnection $ sendMessage_ "Resume" + +clientSendPlayNext :: IO () +clientSendPlayNext = withConnection $ sendMessage_ "Next" + +clientSendPlayPrev :: IO () +clientSendPlayPrev = withConnection $ sendMessage_ "Prev" + +clientSendVolumeUp :: IO () +clientSendVolumeUp = withConnection $ sendMessage_ "VolUp" + +clientSendVolumeDown :: IO () +clientSendVolumeDown = withConnection $ sendMessage_ "VolDown" + +clientSendVolumeGet :: IO String +clientSendVolumeGet = withConnection $ sendMessage "VolGet" + +clientSendSeekForward :: IO () +clientSendSeekForward = withConnection $ sendMessage_ "SeekForward" + +clientSendSeekBackward :: IO () +clientSendSeekBackward = withConnection $ sendMessage_ "SeekBackward" + +clientSendGetFlags :: IO String +clientSendGetFlags = withConnection $ sendMessage "GetFlags" + +clientSendToggleRepeat :: IO () +clientSendToggleRepeat = withConnection $ sendMessage_ "ToggleRepeat" + +clientSendToggleShuffle :: IO () +clientSendToggleShuffle = withConnection $ sendMessage_ "ToggleShuffle" diff --git a/src/Mp/Player/Daemon.hs b/src/Mp/Player/Daemon.hs new file mode 100644 --- /dev/null +++ b/src/Mp/Player/Daemon.hs @@ -0,0 +1,47 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Mp.Player.Daemon ( + runPlayerDaemon +) where + +import System.Directory +import System.Posix.Daemon +import System.FilePath.Posix + +import Mp.Configuration.Configuration +import Mp.Player.Server +import Mp.Utils.Exception + +runPlayerDaemon :: IO () +runPlayerDaemon = do + confDir <- configDirFilePath + let pidFile = confDir "pid" + let output_log = confDir "daemon_log" + let socName = confDir "mp.socket" + + alreadyRunning <- isRunning pidFile + if alreadyRunning + then return () + else do + _ <- try' $ removeFile socName + runDetached (Just pidFile) (ToFile output_log) (startServerBlocking socName) diff --git a/src/Mp/Player/GstPlayer.hs b/src/Mp/Player/GstPlayer.hs new file mode 100644 --- /dev/null +++ b/src/Mp/Player/GstPlayer.hs @@ -0,0 +1,167 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Mp.Player.GstPlayer ( + GstPlayer(), + initGstPlayer, + gstPlayerMainLoopBlocking, + gstPlayerQuit, + gstPlayerPlay, + gstPlayerPause, + gstPlayerStop, + gstPlayerResume, + gstPlayerSetVolume, + gstPlayerGetTimeInfo, + gstPlayerTimeoutAdd, + gstPlayerAddIdle, + gstBusAddWatch, + gstPlayerSeek +) where + +import System.Exit +import Control.Monad +import Data.Maybe +import Data.String.Utils + +import qualified Media.Streaming.GStreamer as Gst +import qualified Media.Streaming.GStreamer.Core.Types as Gst +import qualified System.Glib.MainLoop as G +import qualified System.Glib.Properties as G +import qualified System.Glib.Signals as G + +data GstPlayer = GstPlayer { + gstPlayerSource :: Gst.Element, + gstPlayerVolume :: Gst.Element, + gstPlayerPipeline :: Gst.Element, + gstPlayerMainLoop :: G.MainLoop +} + +makeElement :: String -> String -> IO Gst.Element +makeElement factoryName name = do + element <- Gst.elementFactoryMake factoryName $ Just name + case element of + Just e -> return e + Nothing -> do + putStrLn $ "Could not create GStreamer \"" ++ factoryName ++ "\"element." + exitFailure + +initGstPlayer :: IO GstPlayer +initGstPlayer = do + Gst.init + + mainLoop <- G.mainLoopNew Nothing True + + source <- makeElement "uridecodebin" "File source" + convert <- makeElement "audioconvert" "Audio converter" + volume <- makeElement "volume" "Audio volume" + sink <- makeElement "autoaudiosink" "Auto audio sink" + + pipeline <- Gst.pipelineNew "pipeline" + + mapM_ (Gst.binAdd $ Gst.castToBin pipeline) [source, convert, volume, sink] + _ <- Gst.elementLink convert volume + _ <- Gst.elementLink volume sink + + _ <- G.on source Gst.elementPadAdded $ padAddedHandler convert + + return $ GstPlayer source volume pipeline mainLoop + +padAddedHandler :: Gst.Element -> Gst.Pad -> IO () +padAddedHandler convert pad = do + maybeSinkPad <- Gst.elementGetStaticPad convert "sink" + let sinkPad = fromJust maybeSinkPad + sinkPadIsLinked <- Gst.padIsLinked sinkPad + + unless sinkPadIsLinked $ do + padCaps <- Gst.padGetCaps pad + let capsStruct = fromJust $ Gst.capsGetStructure padCaps 0 + let structName = Gst.structureName capsStruct + when (startswith "audio/x-raw" structName) $ Gst.padLink pad sinkPad >> return () + +gstPlayerGetTimeInfo :: GstPlayer -> IO (Maybe (Integer, Integer)) +gstPlayerGetTimeInfo player = do + position <- Gst.elementQueryPosition (gstPlayerPipeline player) Gst.FormatTime + duration <- Gst.elementQueryDuration (gstPlayerPipeline player) Gst.FormatTime + if (and [isJust position, isJust duration]) + then do + let (_, position') = fromJust position + let (_, duration') = fromJust duration + return $ Just (fromIntegral (position' `div` Gst.second) :: Integer, fromIntegral (duration' `div` Gst.second) :: Integer) + else + return Nothing + +gstPlayerTimeoutAdd :: Int -> IO Bool -> IO () +gstPlayerTimeoutAdd time action = flip G.timeoutAdd time action >> return () + +gstBusAddWatch :: GstPlayer -> Gst.BusFunc -> IO () +gstBusAddWatch player action = do + bus <- Gst.pipelineGetBus (Gst.castToPipeline $ gstPlayerPipeline player) + _ <- Gst.busAddWatch bus G.priorityDefault action + return () + +gstPlayerMainLoopBlocking :: GstPlayer -> IO () +gstPlayerMainLoopBlocking player = G.mainLoopRun $ gstPlayerMainLoop player + +-- Functions below can be called from any thread +gstPlayerAddIdle :: IO Bool -> IO () +gstPlayerAddIdle callback = G.idleAdd callback G.priorityDefaultIdle >> return () + +gstPlayerQuit :: GstPlayer -> IO () +gstPlayerQuit player = gstPlayerAddIdle $ do + G.mainLoopQuit $ gstPlayerMainLoop player + return False + +gstPlayerPlay :: GstPlayer -> FilePath -> IO () +gstPlayerPlay player file = gstPlayerAddIdle $ do + let pipeline = gstPlayerPipeline player + let source = gstPlayerSource player + _ <- Gst.elementSetState pipeline Gst.StateNull + G.objectSetPropertyString "uri" source $ "file://" ++ file + G.objectSetPropertyInt "buffer-size" source (4 * 1024 * 1024) + _ <- Gst.elementSetState pipeline Gst.StatePlaying + return False + +gstPlayerPause :: GstPlayer -> IO () +gstPlayerPause player = gstPlayerAddIdle $ do + _ <- Gst.elementSetState (gstPlayerPipeline player) Gst.StatePaused + return False + +gstPlayerStop :: GstPlayer -> IO () +gstPlayerStop player = gstPlayerAddIdle $ do + _ <- Gst.elementSetState (gstPlayerPipeline player) Gst.StateNull + return False + +gstPlayerResume :: GstPlayer -> IO () +gstPlayerResume player = gstPlayerAddIdle $ do + _ <- Gst.elementSetState (gstPlayerPipeline player) Gst.StatePlaying + return False + +gstPlayerSetVolume :: GstPlayer -> Double -> IO () +gstPlayerSetVolume player vol = gstPlayerAddIdle $ do + let volume = gstPlayerVolume player + G.objectSetPropertyDouble "volume" volume vol + return False + +gstPlayerSeek :: GstPlayer -> Integer -> IO () +gstPlayerSeek player pos = gstPlayerAddIdle $ do + _ <- Gst.elementSeekSimple (gstPlayerPipeline player) Gst.FormatTime [Gst.SeekFlagFlush] $ fromIntegral $ (fromIntegral pos) * Gst.second + return False diff --git a/src/Mp/Player/Server.hs b/src/Mp/Player/Server.hs new file mode 100644 --- /dev/null +++ b/src/Mp/Player/Server.hs @@ -0,0 +1,450 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Mp.Player.Server ( + startServerBlocking +) where + +import qualified Media.Streaming.GStreamer as Gst +import qualified Control.Monad.State as State + +import Network.Socket +import System.FilePath.Posix +import System.Posix.Signals +import System.Random +import Control.Monad +import Control.Concurrent +import System.Directory +import Data.Binary +import Data.Maybe + +import Mp.Configuration.Configuration +import Mp.Player.GstPlayer +import Mp.Utils.Utils +import Mp.Utils.Shuffle +import Mp.Utils.Exception +import Mp.Utils.Network +import Mp.Player.ServerState + +makeServerSocket :: String -> IO Socket +makeServerSocket socName = do + sock <- socket AF_UNIX Stream defaultProtocol + bind sock $ SockAddrUnix socName + listen sock 1 + return sock + +saveServerState :: MVar ServerState -> IO () +saveServerState serverState = do + cfgDir <- configDirFilePath + state <- readMVar serverState + encodeFile (cfgDir "server.state") state + +startServerBlocking :: String -> IO () +startServerBlocking socName = do + player <- initGstPlayer + + serverState <- newMVar defaultServerState + + readServerState player serverState + schedulePlayerInfo player serverState + + _ <- forkIO $ do + sock <- makeServerSocket socName + + _ <- installHandler sigINT (Catch $ close sock) Nothing + _ <- installHandler sigTERM (Catch $ close sock) Nothing + + talkBlocking serverState player sock + + close sock + _ <- try' $ removeFile socName + return () + + gstBusAddWatch player $ \_ message -> do + case Gst.messageType message of + Gst.MessageEOS -> playerPlay serverState player succ + _ -> return () + return True + + gstPlayerMainLoopBlocking player + + where + readServerState player serverState = do + cfgDir <- configDirFilePath + let file = cfgDir "server.state" + exists <- doesFileExist file + when exists $ do + modifyMVar_ serverState $ \_ -> do + state <- readStateFromFile file :: IO ServerState + gstPlayerSetVolume player $ getVolume state + when (getStatus state == "Playing") $ do + let f = getPlaylist state !! (shuffleFunc state) (getPlaying state) + gstPlayerPlay player f + return state + + schedulePlayerInfo player serverState = + gstPlayerTimeoutAdd 100 $ do + maybeInfo <- gstPlayerGetTimeInfo player + if (isJust maybeInfo) then do + let (pos, dur) = fromJust maybeInfo + modifyMVar_ serverState $ \st -> do + return st { + getCurrentPosition = pos, + getCurrentDuration = dur + } + else + modifyMVar_ serverState $ \st -> do + return st { + getCurrentPosition = 0, + getCurrentDuration = 0 + } + return True + +playerPlay :: MVar ServerState -> GstPlayer -> (Int -> Int) -> IO () +playerPlay serverState player indexFunction = do + _ <- forkIO $ do + threadDelay 400000 + st <- readMVar serverState + when (and [getCurrentDuration st == 0, getStatus st == "Playing"]) $ playerPlay serverState player succ + + modifyMVar_ serverState $ \st -> do + let list = getPlaylist st + let index = indexFunction $ getPlaying st + + if and [index >= 0, index < length list] + then + modifyPlayerPlay st player index + else + if isRepeatMode st then do + let newIndex = if index < 0 then + pred $ length list + else if index >= length list then + 0 + else + index + modifyPlayerPlay st player newIndex + else + modifyPlayerStop st player + +modifyPlayerStop :: ServerState -> GstPlayer -> IO ServerState +modifyPlayerStop st player = do + gstPlayerStop player + return st { + getCurrentPosition = 0, + getCurrentDuration = 0, + getPlaying = -1, + getStatus = "Stopped" + } + +modifyPlayerPlay :: ServerState -> GstPlayer -> Int -> IO ServerState +modifyPlayerPlay st player index = do + let list = getPlaylist st + let (f, d) = if isShuffleMode st then + State.runState shuffleFunction $ shuffleData st + else + (id, shuffleData st) + gstPlayerPlay player $ list !! (f index) + return st { + getPlaying = index, + getStatus = "Playing", + shuffleFunc = f, + shuffleData = d + } + +talkBlocking :: MVar ServerState -> GstPlayer -> Socket -> IO () +talkBlocking serverState player sock = do + _ <- try' processMessages + saveServerState serverState + gstPlayerStop player + gstPlayerQuit player + + where + processMessages = do + (conn, _) <- accept sock + msg <- recv conn 4096 + + case msg of + "Add" -> talkAdd serverState conn + "Remove" -> talkRemove serverState player conn + "Clear" -> talkClear serverState player conn + "GetPlaylist" -> talkGetPlaylist serverState conn + "GetStatus" -> talkGetStatus serverState conn + "SetPlay" -> talkSetPlay serverState conn player + "GetPlay" -> talkGetPlay serverState conn + "Stop" -> talkStop serverState conn player + "Pause" -> talkPause serverState conn player + "Resume" -> talkResume serverState conn player + "Next" -> talkNext serverState conn player + "Prev" -> talkPrev serverState conn player + "SeekForward" -> talkSeekForward serverState conn player + "SeekBackward" -> talkSeekBackward serverState conn player + "VolUp" -> talkVolumeUp serverState conn player + "VolDown" -> talkVolumeDown serverState conn player + "VolGet" -> talkVolumeGet serverState conn + "GetFlags" -> talkGetFlags serverState conn + "ToggleRepeat" -> talkToggleRepeat serverState conn + "ToggleShuffle" -> talkToggleShuffle serverState player conn + "Quit" -> sendString conn "OK" + _ -> sendString conn "NOK" + + close conn + + when (msg /= "Quit") processMessages + +talkGetPlaylist :: MVar ServerState -> Socket -> IO () +talkGetPlaylist serverState conn = do + list <- readMVar serverState + forM_ (reverse $ getPlaylist list) $ \item -> do + sendString conn item + recvString_ conn + return () + + sendString conn "EndPlaylist" + +talkGetStatus :: MVar ServerState -> Socket -> IO () +talkGetStatus serverState conn = do + st <- readMVar serverState + + let status = getStatus st + sendString conn status + + recvString_ conn + let dur = getCurrentDuration st + sendString conn $ show dur + + recvString_ conn + let pos = getCurrentPosition st + sendString conn $ show pos + +talkSetPlay :: MVar ServerState -> Socket -> GstPlayer -> IO () +talkSetPlay serverState conn player = do + sendString conn "OK" + index <- recvString conn + sendString conn "OK" + + st <- readMVar serverState + if isShuffleMode st + then + playerPlay serverState player $ const 0 + else + playerPlay serverState player $ const (read index :: Int) + +talkGetPlay :: MVar ServerState -> Socket -> IO () +talkGetPlay serverState conn = do + st <- readMVar serverState + if getStatus st == "Stopped" then + sendString conn "-1" + else + sendString conn $ show $ shuffleFunc st $ getPlaying st + +talkAdd :: MVar ServerState -> Socket -> IO () +talkAdd serverState conn = do + sendString conn "OK" + file <- recvString conn + sendString conn "OK" + + modifyMVar_ serverState $ \st -> do + let (_, d) = State.runState shuffleAdd $ shuffleData st + return st { + getPlaylist = getPlaylist st ++ [file], + shuffleData = d + } + +talkRemove :: MVar ServerState -> GstPlayer -> Socket -> IO () +talkRemove serverState player conn = do + sendString conn "OK" + sIndex <- recvString conn + sendString conn "OK" + + st <- takeMVar serverState + let shuffleEnabled = isShuffleMode st + let playing = getPlaying st + let index = read sIndex :: Int + let (_, d) = State.runState shuffleRemove $ shuffleData st + putMVar serverState $ update index playing d st + + when (or [shuffleEnabled, playing == index]) $ playerPlay serverState player id + + where + update index playing d st + | index < playing = + st { + getPlaying = pred playing, + getPlaylist = removeAt index $ getPlaylist st, + shuffleData = d + } + | otherwise = + st { + getPlaylist = removeAt index $ getPlaylist st, + shuffleData = d + } + +talkClear :: MVar ServerState -> GstPlayer -> Socket -> IO () +talkClear serverState player conn = do + sendString conn "OK" + gstPlayerStop player + modifyMVar_ serverState (const $ return defaultServerState) + +talkStop :: MVar ServerState -> Socket -> GstPlayer -> IO () +talkStop serverState conn player = do + sendString conn "OK" + modifyMVar_ serverState $ flip modifyPlayerStop player + +talkPause :: MVar ServerState -> Socket -> GstPlayer -> IO () +talkPause serverState conn player = do + sendString conn "OK" + modifyMVar_ serverState $ \st -> do + gstPlayerPause player + return st { + getStatus = "Paused" + } + +talkResume :: MVar ServerState -> Socket -> GstPlayer -> IO () +talkResume serverState conn player = do + sendString conn "OK" + modifyMVar_ serverState $ \st -> do + gstPlayerResume player + return st { + getStatus = "Playing" + } + +talkNext :: MVar ServerState -> Socket -> GstPlayer -> IO () +talkNext serverState conn player = do + sendString conn "OK" + st <- takeMVar serverState + let status = getStatus st + let index = succ $ getPlaying st + let len = length $ getPlaylist st + let rpt = isRepeatMode st + putMVar serverState st + + if rpt then + when (status == "Playing") $ playerPlay serverState player succ + else + when (and [status == "Playing", index < len]) $ playerPlay serverState player succ + +talkPrev :: MVar ServerState -> Socket -> GstPlayer -> IO () +talkPrev serverState conn player = do + sendString conn "OK" + st <- takeMVar serverState + let status = getStatus st + let index = pred $ getPlaying st + let rpt = isRepeatMode st + putMVar serverState st + + if rpt then + when (status == "Playing") $ playerPlay serverState player pred + else + when (and [status == "Playing", index >= 0]) $ playerPlay serverState player pred + +talkVolumeUp :: MVar ServerState -> Socket -> GstPlayer -> IO () +talkVolumeUp serverState conn player = do + sendString conn "OK" + modifyMVar_ serverState $ \st -> do + let vol0 = (getVolume st) + 0.04 + let vol1 = if vol0 > 1.0 then 1.0 else vol0 + gstPlayerSetVolume player vol1 + return st { + getVolume = vol1 + } + +talkVolumeDown :: MVar ServerState -> Socket -> GstPlayer -> IO () +talkVolumeDown serverState conn player = do + sendString conn "OK" + modifyMVar_ serverState $ \st -> do + let vol0 = (getVolume st) - 0.04 + let vol1 = if vol0 < 0.0 then 0.0 else vol0 + gstPlayerSetVolume player vol1 + return st { + getVolume = vol1 + } + +talkVolumeGet :: MVar ServerState -> Socket -> IO () +talkVolumeGet serverState conn = do + st <- readMVar serverState + let vol = ceiling $ (getVolume st) * 100 :: Int + sendString conn $ show vol + +talkSeekForward :: MVar ServerState -> Socket -> GstPlayer -> IO () +talkSeekForward serverState conn player = do + sendString conn "OK" + st <- readMVar serverState + let pos0 = (getCurrentPosition st) + 15 + let pos1 = if pos0 > getCurrentDuration st then getCurrentDuration st else pos0 + gstPlayerSeek player pos1 + +talkSeekBackward :: MVar ServerState -> Socket -> GstPlayer -> IO () +talkSeekBackward serverState conn player = do + sendString conn "OK" + st <- readMVar serverState + let pos0 = (getCurrentPosition st) - 15 + let pos1 = if pos0 < 0 then 0 else pos0 + gstPlayerSeek player pos1 + +talkGetFlags :: MVar ServerState -> Socket -> IO () +talkGetFlags serverState conn = do + st <- readMVar serverState + let r = if isRepeatMode st then 'r' else '-' + let z = if isShuffleMode st then 'z' else '-' + sendString conn $ [r, z] + +talkToggleRepeat :: MVar ServerState -> Socket -> IO () +talkToggleRepeat serverState conn = do + sendString conn "OK" + modifyMVar_ serverState $ \st -> do + return st { + isRepeatMode = not $ isRepeatMode st + } + +talkToggleShuffle :: MVar ServerState -> GstPlayer -> Socket -> IO () +talkToggleShuffle serverState player conn = do + sendString conn "OK" + + shuffleEnabled <- modifyMVar serverState $ \st -> do + if isShuffleMode st then do + newSt <- disableShuffle st + return (newSt, False) + else do + newSt <- enableShuffle st + return (newSt, getStatus st == "Playing") + + when (shuffleEnabled) $ playerPlay serverState player id + +disableShuffle :: ServerState -> IO ServerState +disableShuffle st = + return st { + getPlaying = shuffleFunc st $ getPlaying st, + isShuffleMode = False, + shuffleFunc = id + } + +enableShuffle :: ServerState -> IO ServerState +enableShuffle st = do + r <- randomIO + let (f, d) = State.runState (shuffleFilled $ length $ getPlaylist st) $ shuffleInitial (mkStdGen r) + return st { + getPlaying = 0, + isShuffleMode = True, + randomInitializer = r, + shuffleFunc = f, + shuffleData = d + } diff --git a/src/Mp/Player/ServerState.hs b/src/Mp/Player/ServerState.hs new file mode 100644 --- /dev/null +++ b/src/Mp/Player/ServerState.hs @@ -0,0 +1,116 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Mp.Player.ServerState where + +import qualified Control.Monad.State as State + +import Data.Binary +import System.Random + +import Mp.Utils.Shuffle +import Mp.Utils.Exception + +data ServerState = ServerState { + getPlaylist :: ![String], + getCurrentPosition :: !Integer, + getCurrentDuration :: !Integer, + getStatus :: !String, + getPlaying :: !Int, + getVolume :: !Double, + isRepeatMode :: !Bool, + isShuffleMode :: !Bool, + randomInitializer :: !Int, + shuffleFunc :: Int -> Int, + shuffleData :: !ShuffleData +} + +instance Binary ServerState where + put st = do + put (1113 :: Word32) + put (0 :: Int) + put $ getPlaying st + if getStatus st == "Paused" + then put "Playing" + else put $ getStatus st + put $ getVolume st + put $ getPlaylist st + put $ isRepeatMode st + put $ isShuffleMode st + put $ randomInitializer st + + get = do + magic <- get :: Get Word32 + if magic /= 1113 + then return defaultServerState + else do + version <- get :: Get Int + case version of + 0 -> getVersion0 + _ -> return defaultServerState + where + getVersion0 = do + playing <- get + status <- get + volume <- get + playlist <- get + repeatMode <- get + shuffleMode <- get + r <- get + + let g = mkStdGen r + let (f, d) = if shuffleMode then + State.runState (shuffleFilled $ length playlist) $ shuffleInitial g + else + (id, shuffleInitial g) + + return ServerState { + getPlaylist = playlist, + getCurrentPosition = 0, + getCurrentDuration = 0, + getStatus = status, + getPlaying = playing, + getVolume = volume, + isRepeatMode = repeatMode, + isShuffleMode = shuffleMode, + randomInitializer = r, + shuffleFunc = f, + shuffleData = d + } + +defaultServerState :: ServerState +defaultServerState = ServerState { + getPlaylist = [], + getCurrentPosition = 0, + getCurrentDuration = 0, + getStatus = "Stopped", + getPlaying = -1, + getVolume = 1.0, + isRepeatMode = False, + isShuffleMode = False, + randomInitializer = 0, + shuffleFunc = id, + shuffleData = shuffleInitial $ mkStdGen 0 +} + +readStateFromFile :: String -> IO ServerState +readStateFromFile file = decodeFile file `catchAny` (\_ -> return defaultServerState) diff --git a/src/Mp/UI/BrowserPage.hs b/src/Mp/UI/BrowserPage.hs new file mode 100644 --- /dev/null +++ b/src/Mp/UI/BrowserPage.hs @@ -0,0 +1,224 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Mp.UI.BrowserPage ( + BrowserPage (..), + BrowserPageWidget, + makeUIBrowserPage +) where + +import Graphics.Vty.Widgets.All +import Graphics.Vty hiding (Button) + +import qualified Data.HashMap.Strict as Map +import qualified Data.Text as T +import Data.ConfigFile +import Data.List +import Data.Maybe +import Data.Functor +import System.Directory +import System.FilePath.Posix +import Control.Monad +import Control.Concurrent + +import Mp.Utils.Colors +import Mp.Utils.Exception +import Mp.Utils.Utils +import Mp.Configuration.Configuration +import Mp.UI.QueuePage + +type BrowserPageWidget = Widget (List String FormattedText) + +data BrowserPage = BrowserPage { + browserPageWidget :: BrowserPageWidget, + browserPageFocusGroup :: Widget FocusGroup, + browserPageReset :: IO () +} + +data BrowserState = BrowserState { + topDir :: !String, + dirCache :: Map.HashMap String String +} + +makeUIBrowserPage :: ConfigParser -> QueuePage -> IO BrowserPage +makeUIBrowserPage conf queuePage = do + fg <- newFocusGroup + + lst <- newList (browserActiveAttribute conf ) 1 + >>= withBrowserBgAttribute conf + + let musicDir = getMusicDirectory conf + setCurrentDirectory musicDir + + browserState <- newMVar BrowserState { + topDir = musicDir, + dirCache = Map.empty + } + addAllFilesToList lst musicDir + + _ <- addToFocusGroup fg lst + _ <- addToFocusGroup fg lst + + let keyHandler = \_ k _ -> + case k of + KEnter -> do + maybeSel <- getSelected lst + let (_, (value, _)) = fromJust maybeSel + modifyMVar_ browserState $ changeDirectory lst value + return True + + KASCII '!' -> do + modifyMVar_ browserState $ changeDirectory lst musicDir + return True + + KASCII '@' -> do + modifyMVar_ browserState $ changeDirectory lst ".." + return True + + KASCII ' ' -> do + selectCurrentFile lst + return True + + KASCII 'd' -> do + removeCurrentFile lst + return True + + _ -> return False + + lst `onKeyPressed` keyHandler + + return BrowserPage { + browserPageWidget = lst, + browserPageFocusGroup = fg, + browserPageReset = resetBrowser lst browserState + } + where + addFileToList list text = addToList list text =<< (plainText (T.pack text) >>= withBrowserFileAttribute conf) + addDirToList list text = addToList list text =<< (plainText (T.pack text) >>= withBrowserDirectoryAttribute conf) + + addAllFilesToList list dir = do + clearList list + + files <- sort <$> getDirectoryContents dir + + forM_ files $ \file -> do + exists <- doesDirectoryExist $ dir file + when (and [exists, file /= "."]) $ addDirToList list file + + forM_ files $ \file -> do + exists <- doesFileExist $ dir file + when exists $ addFileToList list file + + changeDirectory list dir st = do + let oldDir = topDir st + ok <- try' $ setCurrentDirectory $ oldDir dir + if (isJust ok) + then do + newDir <- getCurrentDirectory + let newSt = if dir == ".." + then + st { + topDir = newDir + } + else + st { + topDir = newDir, + dirCache = Map.insert oldDir dir $ dirCache st + } + addAllFilesToList list newDir + when (dir == "..") $ do + let maybeVal = Map.lookup newDir $ dirCache newSt + when (isJust maybeVal) $ do + maybeIndex <- listFindFirst list $ fromJust maybeVal + case maybeIndex of + Just index -> setSelected list index + Nothing -> return () + return newSt + else + return st + + selectCurrentFile list = do + maybeSel <- getSelected list + when (isJust maybeSel) $ do + let (index, (file, item)) = fromJust maybeSel + currDir <- getCurrentDirectory + when (currDir /= "..") $ do + _ <- withBrowserSelectedAttribute conf item + setSelected list $ succ index + addAllFiles currDir file + return () + + addAllFiles dir file + | file == "." = return () + | file == ".." = return () + | otherwise = do + exists <- doesDirectoryExist $ dir file + if exists + then do + let newDir = dir file + files <- try' (sort <$> getDirectoryContents newDir) + when (isJust files) $ do + forM_ (fromJust files) $ \f -> do + addAllFiles newDir f + else + queuePageAdd queuePage dir file + + removeCurrentFile list = do + maybeSel <- getSelected list + when (isJust maybeSel) $ do + let (index, (file, item)) = fromJust maybeSel + currDir <- getCurrentDirectory + when (currDir /= "..") $ do + whenM (doesDirectoryExist $ currDir file) $ do + _ <- withBrowserDirectoryAttribute conf item + return () + + whenM (doesFileExist $ currDir file) $ do + _ <- withBrowserFileAttribute conf item + return () + + setSelected list $ succ index + removeAllFiles currDir file + return () + + removeAllFiles dir file + | file == "." = return () + | file == ".." = return () + | otherwise = do + exists <- doesDirectoryExist $ dir file + if exists + then do + let newDir = dir file + files <- try' (sort <$> getDirectoryContents newDir) + when (isJust files) $ do + forM_ (fromJust files) $ \f -> do + removeAllFiles newDir f + else + queuePageRemove queuePage dir file + + resetBrowser widget browserState = do + st <- readMVar browserState + maybeSel <- getSelected widget + addAllFilesToList widget $ topDir st + when (isJust maybeSel) $ do + let (sel, _) = fromJust maybeSel + setSelected widget sel diff --git a/src/Mp/UI/EditBar.hs b/src/Mp/UI/EditBar.hs new file mode 100644 --- /dev/null +++ b/src/Mp/UI/EditBar.hs @@ -0,0 +1,60 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{-# LANGUAGE OverloadedStrings #-} + +module Mp.UI.EditBar ( + EditBar (..), + EditBarWidget, + makeUIEditBar +) where + +import qualified Data.Text as T +import Control.Applicative + +import Graphics.Vty.Widgets.All +import Graphics.Vty hiding (Button) + +import Data.ConfigFile + +import Mp.Utils.Colors + +type EditBarWidget = Widget Edit + +data EditBar = EditBar { + editBarWidget :: EditBarWidget, + editBarGetText :: IO String, + editBarReset :: IO (), + editBarOnKeyPressed :: (Widget Edit -> Key -> [Modifier] -> IO Bool) -> IO () +} + +makeUIEditBar :: ConfigParser -> IO EditBar +makeUIEditBar conf = do + edit <- editWidget + >>= withEditAttribute conf + + return EditBar { + editBarWidget = edit, + editBarGetText = T.unpack <$> getEditText edit, + editBarReset = setEditText edit "", + editBarOnKeyPressed = onKeyPressed edit + } diff --git a/src/Mp/UI/HelpPage.hs b/src/Mp/UI/HelpPage.hs new file mode 100644 --- /dev/null +++ b/src/Mp/UI/HelpPage.hs @@ -0,0 +1,147 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Mp.UI.HelpPage ( + HelpPage (..), + HelpPageWidget, + makeUIHelpPage +) where + +import Graphics.Vty.Widgets.All +import Graphics.Vty hiding (Button) +import Data.ConfigFile +import Control.Monad + +import qualified Data.Text as T + +import Mp.Utils.Colors +import Mp.Utils.I18N + +type HelpPageWidget = Widget (List String FormattedText) + +data HelpPage = HelpPage { + helpPageWidget :: HelpPageWidget, + helpPageFocusGroup :: Widget FocusGroup +} + +makeUIHelpPage :: ConfigParser -> IO HelpPage +makeUIHelpPage conf = do + fg <- newFocusGroup + + lst <- newList (helpAttribute conf) 1 + >>= withHelpAttribute conf + + makeHelpContent lst + setSelected lst 0 + + _ <- addToFocusGroup fg lst + _ <- addToFocusGroup fg lst + + let keyHandler = \_ k _ -> do + size <- getCurrentSize lst + let height = fromIntegral $ region_height size + sel <- getSelected lst + case sel of + Just (index, _) -> + case k of + KUp -> do + scrollPageUp lst height index + return True + KDown -> do + scrollPageDown lst height index + return True + KPageUp -> do + scrollPageUp lst height index + return True + KPageDown -> do + scrollPageDown lst height index + return True + _ -> + return False + Nothing -> + return False + + fg `onKeyPressed` keyHandler + + return HelpPage { + helpPageWidget = lst, + helpPageFocusGroup = fg + } + + where + line list text = addToList list "" =<< (plainText (T.pack text) >>= withHelpAttribute conf) + + scrollPageUp list height index = do + scrollToBeginning list + scrollBy list $ height + index + setSelected list $ pred index + + scrollPageDown list height index = do + listLength <- getListSize list + when (index < listLength - height) $ do + scrollToBeginning list + scrollBy list $ height + index + setSelected list $ succ index + + makeHelpContent list = do + let ln = line list + ln " " + ln $ " q : " ++ (__ "Detach from the server") + ln $ " Q : " ++ (__ "Quit") + ln $ "" + ln $ " 1 : " ++ (__ "Help screen") + ln $ " 2 : " ++ (__ "Queue screen") + ln $ " 3 : " ++ (__ "Playlists screen") + ln $ " 4 : " ++ (__ "Browser screen") + ln $ "" + ln $ " Tab : " ++ (__ "Next screen") + ln $ " Shift+Tab : " ++ (__ "Previous screen") + ln $ "" + ln $ " Up : " ++ (__ "Move cursor up") + ln $ " Down : " ++ (__ "Move cursor down") + ln $ " PageUp : " ++ (__ "Page up") + ln $ " PageDown : " ++ (__ "Page down") + ln $ "" + ln $ " Enter : " ++ (__ "Start playing / Enter directory / Enter playlist") + ln $ " s : " ++ (__ "Stop playing") + ln $ " p : " ++ (__ "Pause / resume playing") + ln $ "" + ln $ " space : " ++ (__ "Add file / directory / playlist") + ln $ " d : " ++ (__ "Remove file / directory / playlist") + ln $ " c : " ++ (__ "Clear the queue") + ln $ " l : " ++ (__ "Center") + ln $ " S : " ++ (__ "Save playlist") + ln $ " Ctrl+d : " ++ (__ "Delete playlist") + ln $ " ! : " ++ (__ "Go to root directory") + ln $ " @ : " ++ (__ "Go to parent directory") + ln $ "" + ln $ " > : " ++ (__ "Play next file") + ln $ " < : " ++ (__ "Play previous file") + ln $ " f : " ++ (__ "Seek forward") + ln $ " b : " ++ (__ "Seek backward") + ln $ "" + ln $ " r : " ++ (__ "Toggle repeat mode") + ln $ " z : " ++ (__ "Toggle random mode") + ln $ "" + ln $ " [ : " ++ (__ "Decrease volume") + ln $ " ] : " ++ (__ "Increase volume") + ln " " diff --git a/src/Mp/UI/Main.hs b/src/Mp/UI/Main.hs new file mode 100644 --- /dev/null +++ b/src/Mp/UI/Main.hs @@ -0,0 +1,203 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{-# LANGUAGE OverloadedStrings #-} + +module Mp.UI.Main ( + makeAndRunUI +) where + +import System.Exit +import System.Directory +import System.FilePath.Posix +import System.Posix.Signals +import Graphics.Vty hiding (Button) +import Graphics.Vty.Widgets.All +import Control.Concurrent + +import Mp.Configuration.Configuration +import Mp.UI.HelpPage +import Mp.UI.QueuePage +import Mp.UI.PlaylistPage +import Mp.UI.BrowserPage +import Mp.UI.Menu +import Mp.UI.StatusBar +import Mp.UI.EditBar +import Mp.Utils.I18N +import Mp.Player.Client + +makeAndRunUI :: IO () +makeAndRunUI = do + _ <- installHandler sigINT (Catch $ schedule shutdownUi) Nothing + _ <- installHandler sigHUP (Catch $ schedule shutdownUi) Nothing + _ <- installHandler sigABRT (Catch $ schedule shutdownUi) Nothing + _ <- installHandler sigTERM (Catch $ schedule shutdownUi) Nothing + + conf <- readConfiguration + + menu <- makeUIMenu conf + status <- makeUIStatusBar conf + edit <- makeUIEditBar conf + + helpPage <- makeUIHelpPage conf + queuePage <- makeUIQueuePage conf status + playlistPage <- makeUIPlaylistPage conf queuePage + browserPage <- makeUIBrowserPage conf queuePage + + let fg1 = helpPageFocusGroup helpPage + let fg2 = queuePageFocusGroup queuePage + let fg3 = playlistPageFocusGroup playlistPage + let fg4 = browserPageFocusGroup browserPage + + _ <- addToFocusGroup fg2 $ editBarWidget edit + + ui1 <- makeUI menu status edit $ helpPageWidget helpPage + ui2 <- makeUI menu status edit $ queuePageWidget queuePage + ui3 <- makeUI menu status edit $ playlistPageWidget playlistPage + ui4 <- makeUI menu status edit $ browserPageWidget browserPage + + c <- newCollection + + switchToUI1 <- addToCollection c ui1 fg1 + switchToUI2 <- addToCollection c ui2 fg2 + switchToUI3 <- addToCollection c ui3 fg3 + switchToUI4 <- addToCollection c ui4 fg4 + + active <- newMVar 1 :: IO (MVar Int) + enabled <- newMVar True + + let makeActive = makeActiveFunction active menu [switchToUI1, switchToUI2, switchToUI3, switchToUI4] + makeActive 1 + + let keyHandler = \_ k _ -> do + e <- readMVar enabled + if (not e) then return False + else + case k of + KASCII '\t' -> do + index <- readMVar active + makeActive $ (succ index) `mod` 4 + return True + KBackTab -> do + index <- readMVar active + makeActive $ (pred index) `mod` 4 + return True + KASCII ']' -> do + clientSendVolumeUp + return True + KASCII '[' -> do + clientSendVolumeDown + return True + KASCII 'q' -> exitSuccess + KASCII 'Q' -> clientSendQuitMessage >> exitSuccess + KASCII '1' -> makeActive 0 >> return True + KASCII '2' -> makeActive 1 >> return True + KASCII '3' -> makeActive 2 >> playlistReset playlistPage >> return True + KASCII '4' -> makeActive 3 >> browserPageReset browserPage >> return True + _ -> return False + + question <- newMVar False + let editHandler = \_ k _ -> do + q <- readMVar question + + name <- editBarGetText edit + list <- queuePageGetAll queuePage + plsDir <- playlistDirFilePath + + if q then + case k of + KASCII 'y' -> do + restoreFocus status edit fg2 question enabled + playlistAdd playlistPage True name list + return True + + KASCII 'Y' -> do + restoreFocus status edit fg2 question enabled + playlistAdd playlistPage True name list + return True + + KASCII 'n' -> do + restoreFocus status edit fg2 question enabled + return True + + KASCII 'N' -> do + restoreFocus status edit fg2 question enabled + return True + + KEsc -> do + restoreFocus status edit fg2 question enabled + return True + + _ -> return True + else + case k of + KEsc -> do + restoreFocus status edit fg2 question enabled + return True + + KEnter -> do + modifyMVar_ enabled $ const (return True) + + exists <- doesFileExist $ plsDir name + if exists then do + statusBarSetText status (__ "File exists. Overwrite (Y/N) ?") + modifyMVar_ question $ const (return True) + else do + playlistAdd playlistPage False name list + restoreFocus status edit fg2 question enabled + return True + + _ -> return False + + let queueHandler = \_ k _ -> + case k of + KASCII 'S' -> do + modifyMVar_ enabled $ const (return False) + statusBarSetText status (__ "Enter playlist name:") + focus $ editBarWidget edit + return True + + _ -> return False + + fg1 `onKeyPressed` keyHandler + fg2 `onKeyPressed` keyHandler + fg3 `onKeyPressed` keyHandler + fg4 `onKeyPressed` keyHandler + + edit `editBarOnKeyPressed` editHandler + fg2 `onKeyPressed` queueHandler + + runUi c defaultContext + where + makeUI menu status edit widget = return (menuWidget menu) <--> return widget <--> return (statusBarWidget status) <--> return (editBarWidget edit) + + makeActiveFunction active menu switches = \index -> do + menuActivate menu index + _ <- (!!) switches index + modifyMVar_ active (const $ return index) + + restoreFocus status edit fg2 question enabled = do + modifyMVar_ question $ const (return False) + modifyMVar_ enabled $ const (return True) + focusPrevious fg2 + statusBarReset status + editBarReset edit diff --git a/src/Mp/UI/Menu.hs b/src/Mp/UI/Menu.hs new file mode 100644 --- /dev/null +++ b/src/Mp/UI/Menu.hs @@ -0,0 +1,68 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Mp.UI.Menu ( + Menu (..), + MenuWidget, + makeUIMenu +) where + +import qualified Data.Text as T + +import Graphics.Vty.Widgets.All +import Data.ConfigFile + +import Mp.Utils.Colors +import Mp.Utils.I18N + +type MenuWidget = (Widget (Box (Box (Box (Box FormattedText FormattedText) FormattedText) FormattedText) HFill)) + +data Menu = Menu { + menuWidget :: MenuWidget, + menuActivate :: Int -> IO () +} + +activateMenu :: [Widget a] -> ConfigParser -> Int -> IO () +activateMenu m_list conf n = do + mapM_ (withTabAttribute conf) m_list + _ <- withTabActiveAttribute conf $ m_list !! n + return () + +makeUIMenu :: ConfigParser -> IO Menu +makeUIMenu conf = do + m1 <- plainText (T.pack $ __ " [1] Help ") + >>= withTabAttribute conf + m2 <- plainText (T.pack $ __ " [2] Queue ") + >>= withTabAttribute conf + m3 <- plainText (T.pack $ __ " [3] Playlists ") + >>= withTabAttribute conf + m4 <- plainText (T.pack $ __ " [4] Browser ") + >>= withTabAttribute conf + m5 <- hFill ' ' 1 + >>= withTabAttribute conf + + menu <- return m1 <++> return m2 <++> return m3 <++> return m4 <++> return m5 + + return Menu { + menuWidget = menu, + menuActivate = activateMenu [m1, m2, m3, m4] conf + } diff --git a/src/Mp/UI/PlaylistPage.hs b/src/Mp/UI/PlaylistPage.hs new file mode 100644 --- /dev/null +++ b/src/Mp/UI/PlaylistPage.hs @@ -0,0 +1,263 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{-# LANGUAGE OverloadedStrings #-} + +module Mp.UI.PlaylistPage ( + PlaylistPage (..), + PlaylistPageWidget, + makeUIPlaylistPage +) where + +import qualified Data.HashMap.Strict as Map +import qualified Data.Binary as B +import qualified Data.Text as T + +import Control.Concurrent +import Control.Monad +import Data.ConfigFile +import Data.Maybe +import Graphics.Vty.Widgets.All +import Graphics.Vty hiding (Button) +import System.FilePath.Posix +import System.Directory + +import Mp.Utils.Colors +import Mp.Utils.Exception +import Mp.Utils.Utils +import Mp.Configuration.Configuration +import Mp.UI.PlaylistState +import Mp.UI.QueuePage + +type PlaylistPageWidget = Widget (List String FormattedText) + +data PlaylistPage = PlaylistPage { + playlistPageWidget :: PlaylistPageWidget, + playlistPageFocusGroup :: Widget FocusGroup, + playlistAdd :: Bool -> String -> [String] -> IO (), + playlistReset :: IO () +} + +data PlaylistState = PlaylistState { + playlistNames :: ![String], + playlistMap :: Map.HashMap String [String], + index :: !Int +} + +makeUIPlaylistPage :: ConfigParser -> QueuePage -> IO PlaylistPage +makeUIPlaylistPage conf queuePage = do + playlistState <- newMVar PlaylistState { + playlistNames = [], + playlistMap = Map.empty, + index = -1 + } + + fg <- newFocusGroup + + lst <- newList (playlistActiveAttribute conf) 1 + >>= withPlaylistBgAttribute conf + + _ <- addToFocusGroup fg lst + _ <- addToFocusGroup fg lst + + let keyHandler = \_ k ms -> + case k of + KASCII ' ' -> do + maybeSel <- getSelected lst + st <- readMVar playlistState + when (isJust maybeSel) $ do + let (idx, (value, item)) = fromJust maybeSel + _ <- withPlaylistSelectedAttribute conf item + if (index st == -1) then do + let maybePlaylist = Map.lookup value $ playlistMap st + when (isJust maybePlaylist) $ + forM_ (fromJust maybePlaylist) $ \path -> do + let (dir, file) = separateFilePath path + queuePageAdd queuePage dir file + else do + let maybePlaylist = Map.lookup (playlistNames st !! index st) $ playlistMap st + when (isJust maybePlaylist) $ do + let (dir, file) = separateFilePath $ (fromJust maybePlaylist) !! pred idx + queuePageAdd queuePage dir file + setSelected lst $ succ idx + return True + + KASCII 'd' -> do + st <- readMVar playlistState + maybeSel <- getSelected lst + when (isJust maybeSel) $ do + let (idx, (value, item)) = fromJust maybeSel + if any (MCtrl == ) ms then -- remove playlist + when (index st == -1) $ playlistRemoveAndDelete playlistState lst idx + else do -- delete from queue list + if (index st == -1) then do + _ <- withPlaylistNameAttribute conf item + let maybePlaylist = Map.lookup value $ playlistMap st + when (isJust maybePlaylist) $ + forM_ (fromJust maybePlaylist) $ \path -> do + let (dir, file) = separateFilePath path + queuePageRemove queuePage dir file + else do + _ <- withPlaylistFileAttribute conf item + let maybePlaylist = Map.lookup (playlistNames st !! index st) $ playlistMap st + when (isJust maybePlaylist) $ do + let (dir, file) = separateFilePath $ (fromJust maybePlaylist) !! pred idx + queuePageRemove queuePage dir file + setSelected lst $ succ idx + return True + + KASCII '!' -> do + modifyMVar_ playlistState $ \st -> do + if index st == -1 then + return st + else do + showNames lst st + setSelected lst $ index st + return st { + index = -1 + } + return True + + KASCII '@' -> do + modifyMVar_ playlistState $ \st -> do + if index st == -1 then + return st + else do + showNames lst st + setSelected lst $ index st + return st { + index = -1 + } + return True + + KEnter -> do + maybeSel <- getSelected lst + when (isJust maybeSel) $ do + let (idx, (value, _)) = fromJust maybeSel + if (and [value == "..", idx == 0]) then + modifyMVar_ playlistState $ \st -> do + showNames lst st + setSelected lst $ index st + return st { + index = -1 + } + else + modifyMVar_ playlistState $ \st -> do + if (index st == -1) then do + showFiles lst st value + return st { + index = idx + } + else + return st + return True + + _ -> return False + + lst `onKeyPressed` keyHandler + + readPlaylist playlistState lst + + return PlaylistPage { + playlistPageWidget = lst, + playlistPageFocusGroup = fg, + playlistAdd = playlistAddAndSave playlistState lst, + playlistReset = reset playlistState lst + } + + where + addNameTo widget name = addToList widget name =<< (plainText (T.pack name) >>= withPlaylistNameAttribute conf) + + addFileTo widget name = addToList widget name =<< (plainText (T.pack name) >>= withPlaylistFileAttribute conf) + + reset playlistState widget = do + st <- readMVar playlistState + maybeSel <- getSelected widget + if (index st == -1) then showNames widget st + else showFiles widget st (playlistNames st !! index st) + when (isJust maybeSel) $ do + let (sel, _) = fromJust maybeSel + setSelected widget sel + + showNames widget st = do + clearList widget + forM_ (playlistNames st) $ addNameTo widget + + showFiles widget st name = do + clearList widget + addNameTo widget ".." + let maybePlaylist = Map.lookup name $ playlistMap st + when (isJust maybePlaylist) $ + forM_ (fromJust maybePlaylist) $ \path -> do + let (_, file) = separateFilePath path + addFileTo widget file + + playlistAddState playlistState widget name list = do + modifyMVar_ playlistState $ \st -> do + when (index st == -1) $ addNameTo widget name + return st { + playlistNames = playlistNames st ++ [name], + playlistMap = Map.insert name list $ playlistMap st + } + + playlistAddAndSave playlistState widget overwrite name list = + when (not $ null name) $ do + when (not overwrite) $ do playlistAddState playlistState widget name list + cfgDir <- configDirFilePath + plsDir <- playlistDirFilePath + playlistSave playlistState cfgDir plsDir name list + + playlistSave playlistState cfgDir plsDir name list = do + st <- readMVar playlistState + B.encodeFile (cfgDir "playlists.state") (NameList $ playlistNames st) + B.encodeFile (plsDir name) $ SongList list + + playlistRemoveAndDelete playlistState widget idx = do + cfgDir <- configDirFilePath + plsDir <- playlistDirFilePath + st <- readMVar playlistState + _ <- removeFromList widget idx + playlistDelete playlistState cfgDir plsDir $ playlistNames st !! idx + playlistRemoveState playlistState idx + + playlistRemoveState playlistState idx = do + modifyMVar_ playlistState $ \st -> do + let name = playlistNames st !! idx + return st { + playlistNames = removeAt idx $ playlistNames st, + playlistMap = Map.delete name $ playlistMap st + } + + playlistDelete playlistState cfgDir plsDir name = do + st <- readMVar playlistState + B.encodeFile (cfgDir "playlists.state") (NameList $ playlistNames st) + removeFile (plsDir name) + + readPlaylist playlistState widget = do + cfgDir <- configDirFilePath + plsDir <- playlistDirFilePath + maybeNames <- try' (B.decodeFile (cfgDir "playlists.state") :: IO NameList) + when (isJust maybeNames) $ do + forM_ (nameListGet $ fromJust maybeNames) $ \name -> do + maybePlaylist <- try' (B.decodeFile (plsDir name) :: IO SongList) + when (isJust maybePlaylist) $ do + playlistAddState playlistState widget name $ songListGet $ fromJust maybePlaylist diff --git a/src/Mp/UI/PlaylistState.hs b/src/Mp/UI/PlaylistState.hs new file mode 100644 --- /dev/null +++ b/src/Mp/UI/PlaylistState.hs @@ -0,0 +1,73 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Mp.UI.PlaylistState where + +import Data.Binary + +data NameList = NameList { + nameListGet :: [String] +} + +data SongList = SongList { + songListGet :: [String] +} + +instance Binary NameList where + put (NameList d) = do + put (011110 :: Word32) + put (0 :: Int) + put d + + get = do + magic <- get :: Get Word32 + if magic /= 011110 + then return $ NameList [] + else do + version <- get :: Get Int + case version of + 0 -> getVersion0 + _ -> return $ NameList [] + where + getVersion0 = do + list <- get + return $ NameList list + +instance Binary SongList where + put (SongList d) = do + put (13131717 :: Word32) + put (0 :: Int) + put d + + get = do + magic <- get :: Get Word32 + if magic /= 13131717 + then return $ SongList [] + else do + version <- get :: Get Int + case version of + 0 -> getVersion0 + _ -> return $ SongList [] + where + getVersion0 = do + list <- get + return $ SongList list diff --git a/src/Mp/UI/QueuePage.hs b/src/Mp/UI/QueuePage.hs new file mode 100644 --- /dev/null +++ b/src/Mp/UI/QueuePage.hs @@ -0,0 +1,220 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Mp.UI.QueuePage ( + QueuePage (..), + QueuePageWidget, + AddToFunction, + RemoveFromFunction, + makeUIQueuePage +) where + +import Data.ConfigFile (ConfigParser) +import qualified Data.Text as T +import System.FilePath.Posix +import Data.Maybe +import Control.Monad +import Control.Concurrent + +import Graphics.Vty.Widgets.All +import Graphics.Vty hiding (Button) + +import Mp.Utils.Colors +import Mp.Utils.Exception +import Mp.Utils.Utils +import Mp.Player.Client +import Mp.UI.StatusBar + +type QueuePageWidget = Widget (List String FormattedText) +type AddToFunction = String -> String -> IO () +type RemoveFromFunction = String -> String -> IO () + +data QueuePage = QueuePage { + queuePageWidget :: QueuePageWidget, + queuePageFocusGroup :: Widget FocusGroup, + queuePageAdd :: String -> String -> IO (), + queuePageRemove :: String -> String -> IO (), + queuePageGetAll :: IO [String] +} + +makeUIQueuePage :: ConfigParser -> StatusBar -> IO QueuePage +makeUIQueuePage conf status = do + fg <- newFocusGroup + + lst <- newList (queueActiveAttribute conf) 1 + >>= withQueueBgAttribute conf + + _ <- addToFocusGroup fg lst + _ <- addToFocusGroup fg lst + + empty <- plainText $ T.pack "" + playingItem <- newMVar empty + + let keyHandler = \_ k _ -> + case k of + KASCII '>' -> do + clientSendPlayNext + centerList lst + return True + + KASCII '<' -> do + clientSendPlayPrev + centerList lst + return True + + KASCII 'c' -> do + clearList lst + clientSendClear + return True + + KASCII 'l' -> do + centerList lst + return True + + KASCII 'd' -> do + maybeSel <- getSelected lst + when (isJust maybeSel) $ do + let (index, _) = fromJust maybeSel + rmFromList2 lst index + return True + + KASCII 's' -> do + clientSendStopPlaying + return True + + KASCII 'r' -> do + clientSendToggleRepeat + return True + + KASCII 'z' -> do + clientSendToggleShuffle + return True + + KASCII 'p' -> do + stat <- statusBarServerStatus status + case stat of + "Paused" -> do + clientSendResumePlaying + return True + + "Playing" -> do + clientSendPausePlaying + return True + + _ -> return True + + KASCII 'f' -> do + clientSendSeekForward + return True + + KASCII 'b' -> do + clientSendSeekBackward + return True + + KEnter -> do + maybeSel <- getSelected lst + when (isJust maybeSel) $ do + let (index, _) = fromJust maybeSel + clientSendSetPlaying index + centerList lst + return True + + _ -> return False + + lst `onKeyPressed` keyHandler + scheduleReceiveFromServer lst playingItem + _ <- scheduleStatusFromServer lst playingItem + + return QueuePage { + queuePageWidget = lst, + queuePageFocusGroup = fg, + queuePageAdd = addFileAndSend lst, + queuePageRemove = rmFromList lst, + queuePageGetAll = getList lst + } + where + addFileToList list dir file = addToList list (dir file) =<< (plainText (T.pack file) >>= withQueueFileAttribute conf) + + addFileAndSend list dir file = do + addFileToList list dir file + + clientSendAddFile $ dir file + + getList widget = do + size <- getListSize widget + + items <- forM [0 .. (size - 1)] $ \i -> do + maybeItem <- getListItem widget i + let (value, _) = fromJust maybeItem + return value + return items + + selectItem list playingItem index = do + maybeItem <- getListItem list index + when (isJust maybeItem) $ + modifyMVar_ playingItem $ \oldWidget -> do + let (_, widget) = fromJust maybeItem + _ <- withQueueFileAttribute conf oldWidget -- deselect old widget + _ <- withQueueSelectedAttribute conf widget -- select new widget + return widget -- selected widget + + rmFromList2 list index = do + _ <- removeFromList list index + clientSendRemove index + + rmFromList list dir file = do + indexes <- listFindAll list $ dir file + when (not $ null indexes) $ rmFromList2 list $ last indexes + + centerList widget = do + index <- clientSendGetPlaying + centerListAt widget index + + centerListAt widget index = + when (index /= -1) $ do + size <- getCurrentSize widget + scrollToBeginning widget + let height = fromIntegral $ region_height size + let offset = index + (height `div` 2) + when (offset > 0) $ scrollBy widget offset + setSelected widget index + + receiveFromServer list playingItem = do + items <- clientSendGetPlaylist + index <- clientSendGetPlaying + clearList list + + forM_ items $ \i -> do + let (dir, file) = separateFilePath i + addFileToList list dir file + selectItem list playingItem index + centerListAt list index + + scheduleReceiveFromServer list playingItem = schedule $ do + success <- try' $ receiveFromServer list playingItem + when (not $ isJust success) $ scheduleReceiveFromServer list playingItem + + scheduleStatusFromServer list playingItem = forkIO $ forever $ do + threadDelay 100000 + schedule $ do + success <- try' $ clientSendGetPlaying + when (isJust success) $ selectItem list playingItem $ fromJust success diff --git a/src/Mp/UI/StatusBar.hs b/src/Mp/UI/StatusBar.hs new file mode 100644 --- /dev/null +++ b/src/Mp/UI/StatusBar.hs @@ -0,0 +1,106 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +{-# LANGUAGE OverloadedStrings #-} + +module Mp.UI.StatusBar ( + StatusBar (..), + StatusBarWidget, + makeUIStatusBar +) where + +import qualified Data.Text as T + +import Graphics.Vty.Widgets.All +import Data.ConfigFile +import Data.Maybe +import Control.Monad +import Control.Concurrent + +import Mp.Utils.Colors +import Mp.Utils.Utils +import Mp.Utils.Exception +import Mp.Player.Client +import Mp.Utils.I18N + +type StatusBarWidget = Widget (Box (Box FormattedText HFill) FormattedText) + +data StatusBar = StatusBar { + statusBarWidget :: StatusBarWidget, + statusBarSetText :: String -> IO (), + statusBarReset :: IO (), + statusBarServerStatus :: IO String +} + +makeUIStatusBar :: ConfigParser -> IO StatusBar +makeUIStatusBar conf = do + enabled <- newMVar True + stat <- newMVar (__ "Stopped") + + left <- plainText "" + >>= withStatusAttribute conf + fill <- hFill ' ' 1 + >>= withStatusAttribute conf + right <- plainText "" + >>= withStatusAttribute conf + + status <- return left <++> return fill <++> return right + + _ <- scheduleStatusFromServer enabled stat left right + + return StatusBar { + statusBarWidget = status, + statusBarSetText = statusSetText enabled left right, + statusBarReset = statusReset enabled, + statusBarServerStatus = readMVar stat + } + where + statusSetText enabled left right text = do + _ <- tryTakeMVar enabled + setText left $ T.pack text + setText right "" + + statusReset enabled = do + putMVar enabled True + + scheduleStatusFromServer switch stat left right = forkIO $ forever $ do + _ <- takeMVar switch + putMVar switch True + schedule $ do + success <- try' $ clientSendGetStatus + when (isJust success) $ do + let (status, dur, pos) = fromJust success + let dur' = timeToString dur + let pos' = timeToString pos + setText left $ T.pack (" " ++ (statusToString status) ++ " [" ++ pos' ++ "/" ++ dur' ++ "]") + modifyMVar_ stat (const $ return status) + + flags <- clientSendGetFlags + vol <- clientSendVolumeGet + setText right $ (T.pack $ "[" ++ flags ++ "] " ++ (__ "Volume:") ++ " " ++ vol ++ " % ") + threadDelay 200000 + + statusToString status = case status of + "Stopped" -> __ "Stopped" + "Playing" -> __ "Playing" + "Paused" -> __ "Paused" + _ -> __ "Unknown" diff --git a/src/Mp/Utils/Colors.hs b/src/Mp/Utils/Colors.hs new file mode 100644 --- /dev/null +++ b/src/Mp/Utils/Colors.hs @@ -0,0 +1,184 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Mp.Utils.Colors ( + withTabAttribute, + withTabActiveAttribute, + withHelpAttribute, + helpAttribute, + withStatusAttribute, + withBrowserFileAttribute, + withBrowserDirectoryAttribute, + withBrowserBgAttribute, + browserActiveAttribute, + withBrowserSelectedAttribute, + withQueueBgAttribute, + withQueueFileAttribute, + queueActiveAttribute, + withQueueSelectedAttribute, + playlistActiveAttribute, + withPlaylistBgAttribute, + withPlaylistNameAttribute, + withPlaylistFileAttribute, + withPlaylistSelectedAttribute, + withEditAttribute +) where + +import Graphics.Vty.Widgets.All +import Graphics.Vty.Attributes +import Data.ConfigFile + +import Mp.Configuration.Configuration + +setAttribute :: Widget w -> Attr -> IO (Widget w) +setAttribute w attr = do + setNormalAttribute w attr + setFocusAttribute w attr + return w + +withTabAttribute :: ConfigParser -> Widget w -> IO (Widget w) +withTabAttribute conf w = setAttribute w attr + where + (fg, st) = getConfigurationColor conf "tab_foreground" + (bg, _) = getConfigurationColor conf "tab_background" + attr = (fg `on` bg) `with_style` st + +withTabActiveAttribute :: ConfigParser -> Widget w -> IO (Widget w) +withTabActiveAttribute conf w = setAttribute w attr + where + (fg, st) = getConfigurationColor conf "tab_active_foreground" + (bg, _) = getConfigurationColor conf "tab_active_background" + attr = (fg `on` bg) `with_style` st + +withHelpAttribute :: ConfigParser -> Widget w -> IO (Widget w) +withHelpAttribute conf w = setAttribute w $ helpAttribute conf + +helpAttribute :: ConfigParser -> Attr +helpAttribute conf = attr + where + (fg, st) = getConfigurationColor conf "help_foreground" + (bg, _) = getConfigurationColor conf "help_background" + attr = (fg `on` bg) `with_style` st + + +withStatusAttribute :: ConfigParser -> Widget w -> IO (Widget w) +withStatusAttribute conf w = setAttribute w attr + where + (fg, st) = getConfigurationColor conf "status_foreground" + (bg, _) = getConfigurationColor conf "status_background" + attr = (fg `on` bg) `with_style` st + +withBrowserFileAttribute :: ConfigParser -> Widget w -> IO (Widget w) +withBrowserFileAttribute conf w = setAttribute w attr + where + (fg, st) = getConfigurationColor conf "browser_file_foreground" + (bg, _) = getConfigurationColor conf "browser_background" + attr = (fg `on` bg) `with_style` st + +withBrowserDirectoryAttribute :: ConfigParser -> Widget w -> IO (Widget w) +withBrowserDirectoryAttribute conf w = setAttribute w attr + where + (fg, st) = getConfigurationColor conf "browser_dir_foreground" + (bg, _) = getConfigurationColor conf "browser_background" + attr = (fg `on` bg) `with_style` st + +withBrowserBgAttribute :: ConfigParser -> Widget w -> IO (Widget w) +withBrowserBgAttribute conf w = setAttribute w attr + where + (bg, _) = getConfigurationColor conf "browser_background" + attr = bgColor bg + +browserActiveAttribute :: ConfigParser -> Attr +browserActiveAttribute conf = attr + where + (bg, _) = getConfigurationColor conf "browser_active_background" + attr = bgColor bg + +withBrowserSelectedAttribute :: ConfigParser -> Widget w -> IO (Widget w) +withBrowserSelectedAttribute conf w = setAttribute w attr + where + (fg, st) = getConfigurationColor conf "browser_selected_foreground" + attr = fgColor fg `with_style` st + +withQueueBgAttribute :: ConfigParser -> Widget w -> IO (Widget w) +withQueueBgAttribute conf w = setAttribute w attr + where + (bg, _) = getConfigurationColor conf "queue_background" + attr = bgColor bg + +withQueueFileAttribute :: ConfigParser -> Widget w -> IO (Widget w) +withQueueFileAttribute conf w = setAttribute w attr + where + (fg, st) = getConfigurationColor conf "queue_foreground" + (bg, _) = getConfigurationColor conf "queue_background" + attr = (fg `on` bg) `with_style` st + +queueActiveAttribute :: ConfigParser -> Attr +queueActiveAttribute conf = attr + where + (bg, _) = getConfigurationColor conf "queue_active_background" + attr = bgColor bg + +withQueueSelectedAttribute :: ConfigParser -> Widget w -> IO (Widget w) +withQueueSelectedAttribute conf w = setAttribute w attr + where + (fg, st) = getConfigurationColor conf "queue_selected_foreground" + attr = fgColor fg `with_style` st + +playlistActiveAttribute :: ConfigParser -> Attr +playlistActiveAttribute conf = attr + where + (bg, _) = getConfigurationColor conf "playlist_active_background" + attr = bgColor bg + +withPlaylistBgAttribute :: ConfigParser -> Widget w -> IO (Widget w) +withPlaylistBgAttribute conf w = setAttribute w attr + where + (bg, _) = getConfigurationColor conf "playlist_background" + attr = bgColor bg + +withPlaylistNameAttribute :: ConfigParser -> Widget w -> IO (Widget w) +withPlaylistNameAttribute conf w = setAttribute w attr + where + (fg, st) = getConfigurationColor conf "playlist_foreground" + (bg, _) = getConfigurationColor conf "playlist_background" + attr = (fg `on` bg) `with_style` st + +withPlaylistFileAttribute :: ConfigParser -> Widget w -> IO (Widget w) +withPlaylistFileAttribute conf w = setAttribute w attr + where + (fg, st) = getConfigurationColor conf "playlist_file_foreground" + (bg, _) = getConfigurationColor conf "playlist_background" + attr = (fg `on` bg) `with_style` st + +withPlaylistSelectedAttribute :: ConfigParser -> Widget w -> IO (Widget w) +withPlaylistSelectedAttribute conf w = setAttribute w attr + where + (fg, st) = getConfigurationColor conf "playlist_selected_foreground" + attr = fgColor fg `with_style` st + +withEditAttribute :: ConfigParser -> Widget w -> IO (Widget w) +withEditAttribute conf w = setAttribute w attr + where + (fg, st) = getConfigurationColor conf "edit_foreground" + (bg, _) = getConfigurationColor conf "edit_background" + attr = (fg `on` bg) `with_style` st diff --git a/src/Mp/Utils/Exception.hs b/src/Mp/Utils/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Mp/Utils/Exception.hs @@ -0,0 +1,31 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Mp.Utils.Exception where + +import Control.Exception + +catchAny :: IO a -> (SomeException -> IO a) -> IO a +catchAny = catch + +try' :: IO a -> IO (Maybe a) +try' action = (action >>= return . Just) `catchAny` \_ -> return Nothing diff --git a/src/Mp/Utils/I18N.hs b/src/Mp/Utils/I18N.hs new file mode 100644 --- /dev/null +++ b/src/Mp/Utils/I18N.hs @@ -0,0 +1,29 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Mp.Utils.I18N where + +import Text.I18N.GetText +import System.IO.Unsafe + +__ :: String -> String +__ = unsafePerformIO . getText diff --git a/src/Mp/Utils/Network.hs b/src/Mp/Utils/Network.hs new file mode 100644 --- /dev/null +++ b/src/Mp/Utils/Network.hs @@ -0,0 +1,38 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Mp.Utils.Network where + +import Network.Socket hiding (send, sendTo, recv, recvFrom) +import Network.Socket.ByteString +import Data.ByteString.UTF8 + +recvString :: Socket -> IO String +recvString sock = do + rval <- recv sock 4096 + return $ toString rval + +recvString_ :: Socket -> IO () +recvString_ sock = recvString sock >> return () + +sendString :: Socket -> String -> IO () +sendString sock msg = sendAll sock $ fromString msg diff --git a/src/Mp/Utils/Shuffle.hs b/src/Mp/Utils/Shuffle.hs new file mode 100644 --- /dev/null +++ b/src/Mp/Utils/Shuffle.hs @@ -0,0 +1,90 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Mp.Utils.Shuffle ( + ShuffleData, + ShuffleValue, + ShuffleState, + shuffleInitial, + shuffleEmpty, + shuffleFilled, + shuffleAdd, + shuffleRemove, + shuffleFunction +) where + +import Control.Monad.State +import System.Random +import Data.List + +type ShuffleData = (StdGen, Bool, Int, [(Int, Int)], [(Int, Int)]) +type ShuffleValue = Int -> Int +type ShuffleState = State ShuffleData ShuffleValue + +sortFunction :: (Int, Int) -> (Int, Int) -> Ordering +sortFunction (a, _) (b, _) + | a < b = LT + | a > b = GT + | otherwise = EQ + +shuffleInitial :: StdGen -> ShuffleData +shuffleInitial g = (g, True, 0, [], []) + +shuffleEmpty :: ShuffleState +shuffleEmpty = return id + +shuffleFilled :: Int -> ShuffleState +shuffleFilled ln = do + forM_ [1..ln] $ \_ -> + shuffleAdd + shuffleFunction + +shuffleAdd :: ShuffleState +shuffleAdd = do + (g0, _, index, list, sorted) <- get + let (r, g1) = random g0 + put (g1, True, succ index, (r, index) : list, sorted) + return id + +shuffleRemove :: ShuffleState +shuffleRemove = do + (g0, _, index, list, sorted) <- get + if (index == 0) then + return id + else do + put (g0, True, pred index, tail list, sorted) + return id + +shuffleFunction :: ShuffleState +shuffleFunction = do + (g0, changed, index, list, sorted) <- get + if changed + then do + let newList = sortBy sortFunction list + put (g0, False, index, list, newList) + return $ \i -> + if i < 0 then i + else snd (newList !! i) + else + return $ \i -> + if i < 0 then i + else snd (sorted !! i) diff --git a/src/Mp/Utils/Utils.hs b/src/Mp/Utils/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Mp/Utils/Utils.hs @@ -0,0 +1,72 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2014 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program 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 General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Mp.Utils.Utils where + +import Graphics.Vty +import Control.Monad + +toVtyColor :: String -> (Color, Style) +toVtyColor color = case color of + "black" -> (black, dim) + "white" -> (white, dim) + "cyan" -> (cyan, dim) + "magenta" -> (magenta, dim) + "blue" -> (blue, dim) + "yellow" -> (yellow, dim) + "green" -> (green, dim) + "red" -> (red, dim) + "brightBlack" -> (black, bold) + "brightYellow" -> (yellow, bold) + "brightGreen" -> (green, bold) + "brightRed" -> (red, bold) + "brightBlue" -> (blue, bold) + "brightWhite" -> (white, bold) + "brightCyan" -> (cyan, bold) + "brightMagenta" -> (magenta, bold) + _ -> (black, dim) + +whenM :: Monad m => m Bool -> m () -> m () +whenM cond action = do + b <- cond + when b action + +timeToString :: Integer -> String +timeToString time = + let h = time `div` 3600 + m = show $ (time `div` 60) `mod` 60 + m' = if (length m < 2) then "0" ++ m + else m + s = show $ time `mod` 60 + s' = if (length s < 2) then "0" ++ s + else s + in + if h == 0 then m ++ ":" ++ s' + else (show h) ++ ":" ++ m' ++ ":" ++ s' + +separateFilePath :: String -> (String, String) +separateFilePath file = + let (f, d) = span (/= '/') $ reverse file + in ((reverse $ tail d), (reverse f)) + +removeAt :: Int -> [a] -> [a] +removeAt index list = take index list ++ drop (succ index) list