diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,2 @@ import Distribution.Simple - main = defaultMain diff --git a/gen_gettext b/gen_gettext deleted file mode 100644 --- a/gen_gettext +++ /dev/null @@ -1,27 +0,0 @@ -#!/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 deleted file mode 100644 --- a/i18n/messages.pot +++ /dev/null @@ -1,183 +0,0 @@ -# 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 deleted file mode 100644 --- a/i18n/pl.po +++ /dev/null @@ -1,182 +0,0 @@ -# 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 deleted file mode 100644 Binary files a/i18n/pl/LC_MESSAGES/mp.mo and /dev/null differ diff --git a/mp.cabal b/mp.cabal --- a/mp.cabal +++ b/mp.cabal @@ -1,56 +1,85 @@ name: mp -version: 0.2.2 -cabal-version: >=1.16 +version: 1.0.0 +cabal-version: >=1.22 build-type: Simple author: Piotr Borek maintainer: Piotr Borek -license: GPL +license: GPL-2 license-file: LICENSE synopsis: Music player for linux. description: Music player for linux. category: Sound -homepage: http://code.google.com/p/linux-music-player +homepage: http://bitbucket.org/borekpiotr/linux-music-player data-files: - gen_gettext - i18n/messages.pot - i18n/pl.po - i18n/pl/LC_MESSAGES/mp.mo + stack.yaml 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 + hs-source-dirs: src + main-is: Main.hs + default-language: Haskell2010 + ghc-options: -Wall -threaded + default-extensions: + CPP + FlexibleInstances + DataKinds - 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 + build-depends: + base (>= 4.9 && < 5), + haskell-gi-base (>= 0.18 && < 1), + -- disable overloading labels in haskell-gi modules + haskell-gi-overloading == 0.0.*, + gi-gobject (>= 2.0 && < 2.1), + gi-glib (>= 2.0 && < 2.1), + gi-gst (>= 1.0 && < 1.1), + transformers (>= 0.5 && < 0.6), + transformers-base (>= 0.4 && < 0.5), + text (>= 1.2 && < 1.3), + mtl (>= 2.2 && < 2.3), + random (>= 1.1 && < 1.2), + binary (>= 0.8 && < 0.9), + network (>= 2.6 && < 2.7), + directory (>= 1.3 && < 1.4), + unix (>= 2.7 && < 2.8), + filepath (>= 1.4 && < 1.5), + utf8-string (>= 1.0 && < 1.1), + ConfigFile (>= 1.1 && < 1.2), + MissingH (>= 1.4 && < 1.5), + resourcet (>= 1.1 && < 1.2), + exceptions (>= 0.8 && < 0.9), + async (>= 2.1 && < 2.3), + daemons (>= 0.2 && < 0.3), + vty (>= 5.16 && < 5.22), + lens (>= 4.15 && < 4.17), + containers (>= 0.5 && < 0.6), + deepseq (>= 1.4 && < 1.5), + vector (>= 0.11 && < 0.13), + data-default-class (>= 0.1 && < 0.2), + template-haskell (>= 2.11 && < 2.14), + stm (>= 2.4 && < 2.5), + simple-ui == 0.1.* + + other-modules: + Mp.UI.Main + Mp.UI.MpData + Mp.UI.MainMenuBar + Mp.UI.MainStatusBar + Mp.UI.HelpPage + Mp.UI.QueuePage + Mp.UI.PlaylistPage + Mp.UI.QuestionBar + Mp.UI.BrowserPage + Mp.UI.EditBar + Mp.UI.SongList + Mp.Locale.TranslateFile + Mp.Configuration.Configuration + Mp.Configuration.ConfigurationFile + Mp.Configuration.AppColors + Mp.Player.Client + Mp.Player.Daemon + Mp.Player.GstPlayer + Mp.Player.Server + Mp.Player.ServerState + Mp.Utils.Network + Mp.Utils.Shuffle + Mp.Utils.Utils diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,81 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2016 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 Control.Monad +import qualified Data.Map.Strict as Map +import System.Environment + +import Mp.Configuration.AppColors +import Mp.Configuration.Configuration +import Mp.Player.Client +import Mp.Player.Daemon +import Mp.UI.Main +import Mp.UI.MpData + +import Simple.UI.Core.Attribute +import Simple.UI.Core.UIApp + +main :: IO () +main = do + makeDefaultConfiguration + + conf <- readConfiguration + songList <- attributeNew [] + songMap <- attributeNew Map.empty + let appColors = parseColors conf + let musicDirectory = getMusicDirectory conf + let mpData = MpData + { _mpColors = appColors + , _mpMusicDirectory = musicDirectory + , _mpSongList = songList + , _mpSongMap = songMap + } + + args <- getArgs + case args of + [] -> do + runPlayerDaemon + runUIApp mpData mainLoop + printDaemonLog + + ["--daemon"] -> do + runPlayerDaemon + printDaemonLog + + -- all below is for testing + ["--status"] -> do + (stat, dur, pos) <- clientSendGetStatus + putStrLn $ "Status: " ++ stat + putStrLn $ "Duration: " ++ show dur + putStrLn $ "Position: " ++ show pos + + ["--quit"] -> + clientSendQuitMessage + + ["--list"] -> do + list <- clientSendGetPlaylist + forM_ list putStrLn + + _ -> + putStrLn "Wrong number of parameters." diff --git a/src/Mp/Configuration/AppColors.hs b/src/Mp/Configuration/AppColors.hs new file mode 100644 --- /dev/null +++ b/src/Mp/Configuration/AppColors.hs @@ -0,0 +1,100 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2017 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 TemplateHaskell #-} + +module Mp.Configuration.AppColors where + +import Control.Lens +import Data.ConfigFile +import Graphics.Vty as Vty + +import Mp.Configuration.Configuration +import Mp.Utils.Utils + +data AppColors = AppColors + { _tabForeground :: Vty.Color + , _tabBackground :: Vty.Color + , _tabActiveForeground :: Vty.Color + , _tabActiveBackground :: Vty.Color + + , _statusForeground :: Vty.Color + , _statusBackground :: Vty.Color + + , _helpForeground :: Vty.Color + , _helpBackground :: Vty.Color + + , _browserBackground :: Vty.Color + , _browserDirForeground :: Vty.Color + , _browserFileForeground :: Vty.Color + , _browserActiveBackground :: Vty.Color + , _browserSelectedForeground :: Vty.Color + + , _queueForeground :: Vty.Color + , _queueBackground :: Vty.Color + , _queueActiveBackground :: Vty.Color + , _queueSelectedForeground :: Vty.Color + + , _playlistBackground :: Vty.Color + , _playlistForeground :: Vty.Color + , _playlistFileForeground :: Vty.Color + , _playlistSelectedForeground :: Vty.Color + , _playlistActiveBackground :: Vty.Color + + , _editBackground :: Vty.Color + , _editForeground :: Vty.Color + } + +makeLenses ''AppColors + +parseColors :: ConfigParser -> AppColors +parseColors conf = AppColors + { _tabForeground = toVtyColor $ getConfigurationColor conf "tab_foreground" + , _tabBackground = toVtyColor $ getConfigurationColor conf "tab_background" + , _tabActiveForeground = toVtyColor $ getConfigurationColor conf "tab_active_foreground" + , _tabActiveBackground = toVtyColor $ getConfigurationColor conf "tab_active_background" + + , _statusForeground = toVtyColor $ getConfigurationColor conf "status_foreground" + , _statusBackground = toVtyColor $ getConfigurationColor conf "status_background" + + , _helpForeground = toVtyColor $ getConfigurationColor conf "help_foreground" + , _helpBackground = toVtyColor $ getConfigurationColor conf "help_background" + + , _browserBackground = toVtyColor $ getConfigurationColor conf "browser_background" + , _browserDirForeground = toVtyColor $ getConfigurationColor conf "browser_dir_foreground" + , _browserFileForeground = toVtyColor $ getConfigurationColor conf "browser_file_foreground" + , _browserActiveBackground = toVtyColor $ getConfigurationColor conf "browser_active_background" + , _browserSelectedForeground = toVtyColor $ getConfigurationColor conf "browser_selected_foreground" + + , _queueForeground = toVtyColor $ getConfigurationColor conf "queue_foreground" + , _queueBackground = toVtyColor $ getConfigurationColor conf "queue_background" + , _queueActiveBackground = toVtyColor $ getConfigurationColor conf "queue_active_background" + , _queueSelectedForeground = toVtyColor $ getConfigurationColor conf "queue_selected_foreground" + + , _playlistBackground = toVtyColor $ getConfigurationColor conf "playlist_background" + , _playlistForeground = toVtyColor $ getConfigurationColor conf "playlist_foreground" + , _playlistFileForeground = toVtyColor $ getConfigurationColor conf "playlist_file_foreground" + , _playlistSelectedForeground = toVtyColor $ getConfigurationColor conf "playlist_selected_foreground" + , _playlistActiveBackground = toVtyColor $ getConfigurationColor conf "playlist_active_background" + + , _editBackground = toVtyColor $ getConfigurationColor conf "edit_background" + , _editForeground = toVtyColor $ getConfigurationColor conf "edit_foreground" + } diff --git a/src/Mp/Configuration/Configuration.hs b/src/Mp/Configuration/Configuration.hs --- a/src/Mp/Configuration/Configuration.hs +++ b/src/Mp/Configuration/Configuration.hs @@ -1,4 +1,4 @@ -{- +{- * Programmer: Piotr Borek * E-mail: piotrborek@op.pl * Copyright 2014 Piotr Borek @@ -24,22 +24,19 @@ 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 Control.Monad +import Data.ConfigFile +import Data.Either.Utils +import System.Directory +import System.Environment +import System.FilePath.Posix -import Mp.Utils.Utils -import Mp.Configuration.ConfigurationFile +import Mp.Configuration.ConfigurationFile configDir :: String configDir = ".config/mp" @@ -71,8 +68,8 @@ getMusicDirectory :: ConfigParser -> String getMusicDirectory conf = getConfiguration conf "general" "music_dir" -getConfigurationColor :: ConfigParser -> OptionSpec -> (Color, Style) -getConfigurationColor parser option = toVtyColor $ getConfiguration parser "colors" option +getConfigurationColor :: ConfigParser -> OptionSpec -> String +getConfigurationColor parser = getConfiguration parser "colors" makeDefaultConfiguration :: IO () makeDefaultConfiguration = do diff --git a/src/Mp/Locale/TranslateFile.hs b/src/Mp/Locale/TranslateFile.hs new file mode 100644 --- /dev/null +++ b/src/Mp/Locale/TranslateFile.hs @@ -0,0 +1,240 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2016 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 +-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DataKinds #-} + +module Mp.Locale.TranslateFile ( + translate +) where + +import GHC.TypeLits + +import Simple.Locale.Languages +import Simple.Locale.TranslateClass + +instance Translate "GstPlayerElementFactoryException: Could not create element" where + translate LANG_PL _ = "GstPlayerElementFactoryException: Nie mogę utworzyć elementu" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "GstPlayerElementLinkException: Could not link elements" where + translate LANG_PL _ = "GstPlayerElementLinkException: Nie mogę połączyć elementów" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Help " where + translate LANG_PL _ = "Pomoc " + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Queue " where + translate LANG_PL _ = "Lista " + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Playlist" where + translate LANG_PL _ = "Playlisty " + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Browser " where + translate LANG_PL _ = "Przeglądaj" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Detach from the server" where + translate LANG_PL _ = "Wyjdź i odtwarzaj muzykę w tle" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Quit" where + translate LANG_PL _ = "Wyjdź" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Help screen" where + translate LANG_PL _ = "Ekran pomocy" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Queue screen" where + translate LANG_PL _ = "Ekran listy odtwarzania" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Playlists screen" where + translate LANG_PL _ = "Ekran playlist" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Browser screen" where + translate LANG_PL _ = "Ekran przeglądania" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Next screen" where + translate LANG_PL _ = "Następny ekran" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Previous screen" where + translate LANG_PL _ = "Poprzedni ekran" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Move cursor up" where + translate LANG_PL _ = "Przesuń kursor w górę" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Move cursor down" where + translate LANG_PL _ = "Przesuń kursor w dół" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Page up" where + translate LANG_PL _ = "Przesuń o stronę w górę" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Page down" where + translate LANG_PL _ = "Przesuń o stronę w dół" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Start playing" where + translate LANG_PL _ = "Odtwarzaj" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Enter directory" where + translate LANG_PL _ = "Otwórz katalog" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Enter playlist" where + translate LANG_PL _ = "Wejdź do playlisty" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Stop playing" where + translate LANG_PL _ = "Zatrzymaj odtwarzanie" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Pause" where + translate LANG_PL _ = "Wstrzymaj" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "resume playing" where + translate LANG_PL _ = "wznów odtwarzanie" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Add file" where + translate LANG_PL _ = "Dodaj plik" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "directory" where + translate LANG_PL _ = "katalog" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "playlist" where + translate LANG_PL _ = "playliste" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Remove file" where + translate LANG_PL _ = "usuń plik" + translate LANG_UNKNOWN p = symbolVal p + +-- + +instance Translate "Clear the queue" where + translate LANG_PL _ = "Wyczyść listę odtwarzania" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Center" where + translate LANG_PL _ = "Wyśrodkuj" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Save playlist" where + translate LANG_PL _ = "Zapisz listę odtwarzania" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Delete playlist" where + translate LANG_PL _ = "Usuń listę odtwarzania" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Go to root directory" where + translate LANG_PL _ = "Przejdź do katalogu głównego" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Go to parent directory" where + translate LANG_PL _ = "Przejdź do katalogu nadrzędnego" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Play next file" where + translate LANG_PL _ = "Następna ścieżka" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Play previous file" where + translate LANG_PL _ = "Poprzednia ścieżka" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Seek forward" where + translate LANG_PL _ = "Przewiń naprzód" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Seek backward" where + translate LANG_PL _ = "Przewiń wstecz" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Toggle repeat mode" where + translate LANG_PL _ = "Przełącz tryb powtarzania" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Toggle random mode" where + translate LANG_PL _ = "Przełącz tryb losowy" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Decrease volume" where + translate LANG_PL _ = "Przycisz" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Increase volume" where + translate LANG_PL _ = "Zgłośnij" + translate LANG_UNKNOWN p = symbolVal p + +-- + +instance Translate "Stopped" where + translate LANG_PL _ = "Zatrzymane" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Playing" where + translate LANG_PL _ = "Odtwarzanie" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Paused" where + translate LANG_PL _ = "Wstrzymane" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Unknown" where + translate LANG_PL _ = "Stan nieznany" + translate LANG_UNKNOWN p = symbolVal p + +-- + +instance Translate "Connection error" where + translate LANG_PL _ = "Brak połączenia" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "Volume" where + translate LANG_PL _ = "Głośność" + translate LANG_UNKNOWN p = symbolVal p + +-- + +instance Translate "Enter playlist name" where + translate LANG_PL _ = "Wpisz nazwę" + translate LANG_UNKNOWN p = symbolVal p + +instance Translate "File exists. Overwrite ?" where + translate LANG_PL _ = "Plik istnieje. Nadpisać ?" + translate LANG_UNKNOWN p = symbolVal p diff --git a/src/Mp/Main.hs b/src/Mp/Main.hs deleted file mode 100644 --- a/src/Mp/Main.hs +++ /dev/null @@ -1,59 +0,0 @@ -{- - * 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 --- a/src/Mp/Player/Client.hs +++ b/src/Mp/Player/Client.hs @@ -1,4 +1,4 @@ -{- +{- * Programmer: Piotr Borek * E-mail: piotrborek@op.pl * Copyright 2014 Piotr Borek @@ -45,14 +45,20 @@ clientSendSaveState ) where -import System.FilePath.Posix -import Network.Socket hiding (send, sendTo, recv, recvFrom) +import Control.Monad +import Control.Monad.IO.Class +import Network.Socket (Family (AF_UNIX), + SockAddr (SockAddrUnix), + SocketType (Stream), close, + connect, defaultProtocol, + socket) +import System.FilePath.Posix -import Mp.Configuration.Configuration -import Mp.Utils.Network +import Mp.Configuration.Configuration +import Mp.Utils.Network -withConnection :: (Socket -> IO a) -> IO a -withConnection action = do +withConnection :: MonadIO m => (Socket -> IO a) -> m a +withConnection action = liftIO $ do confPath <- configDirFilePath let socName = confPath "mp.socket" @@ -66,33 +72,32 @@ sendMessage :: String -> Socket -> IO String sendMessage msg sock = do - sendString sock msg -- send message - rval <- recvString sock -- receive answer - return rval + sendString sock msg -- send message + recvString' sock -- receive answer sendMessage_ :: String -> Socket -> IO () -sendMessage_ msg sock = sendMessage msg sock >> return () +sendMessage_ msg sock = void $ sendMessage msg sock -clientSendQuitMessage :: IO () +clientSendQuitMessage :: MonadIO m => m () clientSendQuitMessage = withConnection $ sendMessage_ "Quit" -clientSendAddFile :: String -> IO () -clientSendAddFile file = do +clientSendAddFile :: MonadIO m => String -> m () +clientSendAddFile file = withConnection $ \conn -> do sendMessage_ "Add" conn sendMessage_ file conn -clientSendRemove :: Int -> IO () -clientSendRemove index = do +clientSendRemove :: MonadIO m => Int -> m () +clientSendRemove index = withConnection $ \conn -> do sendMessage_ "Remove" conn sendMessage_ (show index) conn -clientSendClear :: IO () +clientSendClear :: MonadIO m => m () clientSendClear = withConnection $ sendMessage_ "Clear" -clientSendGetPlaylist :: IO [String] -clientSendGetPlaylist = do +clientSendGetPlaylist :: MonadIO m => m [String] +clientSendGetPlaylist = withConnection $ \conn -> do item <- sendMessage "GetPlaylist" conn if item == "EndPlaylist" @@ -101,68 +106,68 @@ where processMessages xs conn = do item <- sendMessage "Get" conn - if (item == "EndPlaylist") + if item == "EndPlaylist" then return xs else processMessages (item : xs) conn -clientSendGetStatus :: IO (String, Integer, Integer) -clientSendGetStatus = do +clientSendGetStatus :: MonadIO m => m (String, Integer, Integer) +clientSendGetStatus = withConnection $ \conn -> do status <- sendMessage "GetStatus" conn dur <- sendMessage "GetDuration" conn pos <- sendMessage "GetPosition" conn - return (status, (read dur :: Integer), (read pos :: Integer)) + return (status, read dur :: Integer, read pos :: Integer) -clientSendSetPlaying :: Int -> IO () -clientSendSetPlaying index = do +clientSendSetPlaying :: MonadIO m => Int -> m () +clientSendSetPlaying index = withConnection $ \conn -> do sendMessage_ "SetPlay" conn sendMessage_ (show index) conn -clientSendGetPlaying :: IO Int -clientSendGetPlaying = do +clientSendGetPlaying :: MonadIO m => m Int +clientSendGetPlaying = withConnection $ \conn -> do index <- sendMessage "GetPlay" conn return (read index :: Int) -clientSendStopPlaying :: IO () +clientSendStopPlaying :: MonadIO m => m () clientSendStopPlaying = withConnection $ sendMessage_ "Stop" -clientSendPausePlaying :: IO () +clientSendPausePlaying :: MonadIO m => m () clientSendPausePlaying = withConnection $ sendMessage_ "Pause" -clientSendResumePlaying :: IO () +clientSendResumePlaying :: MonadIO m => m () clientSendResumePlaying = withConnection $ sendMessage_ "Resume" -clientSendPlayNext :: IO () +clientSendPlayNext :: MonadIO m => m () clientSendPlayNext = withConnection $ sendMessage_ "Next" -clientSendPlayPrev :: IO () +clientSendPlayPrev :: MonadIO m => m () clientSendPlayPrev = withConnection $ sendMessage_ "Prev" -clientSendVolumeUp :: IO () +clientSendVolumeUp :: MonadIO m => m () clientSendVolumeUp = withConnection $ sendMessage_ "VolUp" -clientSendVolumeDown :: IO () +clientSendVolumeDown :: MonadIO m => m () clientSendVolumeDown = withConnection $ sendMessage_ "VolDown" -clientSendVolumeGet :: IO String +clientSendVolumeGet :: MonadIO m => m String clientSendVolumeGet = withConnection $ sendMessage "VolGet" -clientSendSeekForward :: IO () +clientSendSeekForward :: MonadIO m => m () clientSendSeekForward = withConnection $ sendMessage_ "SeekForward" -clientSendSeekBackward :: IO () +clientSendSeekBackward :: MonadIO m => m () clientSendSeekBackward = withConnection $ sendMessage_ "SeekBackward" -clientSendGetFlags :: IO String +clientSendGetFlags :: MonadIO m => m String clientSendGetFlags = withConnection $ sendMessage "GetFlags" -clientSendToggleRepeat :: IO () +clientSendToggleRepeat :: MonadIO m => m () clientSendToggleRepeat = withConnection $ sendMessage_ "ToggleRepeat" -clientSendToggleShuffle :: IO () +clientSendToggleShuffle :: MonadIO m => m () clientSendToggleShuffle = withConnection $ sendMessage_ "ToggleShuffle" -clientSendSaveState :: IO () +clientSendSaveState :: MonadIO m => m () clientSendSaveState = withConnection $ sendMessage_ "SaveState" diff --git a/src/Mp/Player/Daemon.hs b/src/Mp/Player/Daemon.hs --- a/src/Mp/Player/Daemon.hs +++ b/src/Mp/Player/Daemon.hs @@ -1,4 +1,4 @@ -{- +{- * Programmer: Piotr Borek * E-mail: piotrborek@op.pl * Copyright 2014 Piotr Borek @@ -19,18 +19,25 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} +{-# LANGUAGE MultiWayIf #-} module Mp.Player.Daemon ( - runPlayerDaemon + runPlayerDaemon, + printDaemonLog ) where -import System.Directory -import System.Posix.Daemon -import System.FilePath.Posix +import Control.Concurrent +import Control.Monad +import Control.Monad.Catch +import Control.Monad.Trans.Resource +import Data.List +import System.Directory +import System.FilePath.Posix +import System.IO +import System.Posix.Daemon -import Mp.Configuration.Configuration -import Mp.Player.Server -import Mp.Utils.Exception +import Mp.Configuration.Configuration +import Mp.Player.Server runPlayerDaemon :: IO () runPlayerDaemon = do @@ -40,8 +47,23 @@ 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) + unless alreadyRunning $ do + catchAll (removeFile socName) (const $ return ()) + catchAll (removeFile output_log) (const $ return ()) + runDetached (Just pidFile) (ToFile output_log) $ + catchAll + (void $ runResourceT $ startServerBlocking socName) + print + + threadDelay 250000 + +printDaemonLog :: IO () +printDaemonLog = do + confDir <- configDirFilePath + withFile (confDir "daemon_log") ReadMode $ \h -> do + text <- hGetContents h + forM_ (lines text) $ \s -> + -- get rid of warning from gst + if | isSubsequenceOf "gst_structure_free" s -> return () + | null s -> return () + | True -> putStrLn s diff --git a/src/Mp/Player/GstPlayer.hs b/src/Mp/Player/GstPlayer.hs --- a/src/Mp/Player/GstPlayer.hs +++ b/src/Mp/Player/GstPlayer.hs @@ -1,7 +1,7 @@ -{- +{- * Programmer: Piotr Borek * E-mail: piotrborek@op.pl - * Copyright 2014 Piotr Borek + * Copyright 2016 Piotr Borek * * Distributed under the terms of the GPL (GNU Public License) * @@ -20,148 +20,172 @@ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + module Mp.Player.GstPlayer ( - GstPlayer(), + GstPlayer (), initGstPlayer, + gstPlayerAddIdle, + gstPlayerTimeoutAdd, gstPlayerMainLoopBlocking, + gstBusAddWatch, + gstPlayerGetTimeInfo, 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 Data.GI.Base.Properties as G +import qualified Data.Text as T +import qualified GI.GLib as G +import qualified GI.Gst as G -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 +import Control.Monad +import Control.Monad.Catch +import Control.Monad.IO.Class +import Data.Maybe +import Data.Typeable +import Data.Word +import Mp.Locale.TranslateFile () +import Simple.Locale.TranslateTH + +data GstPlayerException = GstPlayerElementFactoryException T.Text + | GstPlayerElementLinkException (Maybe T.Text) (Maybe T.Text) + deriving Typeable + +instance Exception GstPlayerException + +instance Show GstPlayerException where + show (GstPlayerElementFactoryException text) = [tr|GstPlayerElementFactoryException: Could not create element|] ++ " \"" ++ show text ++ "\"." + show (GstPlayerElementLinkException nameA nameB) = [tr|GstPlayerElementLinkException: Could not link elements|] ++ ": " ++ show nameA ++ " -> " ++ show nameB ++ "." + data GstPlayer = GstPlayer { - gstPlayerSource :: Gst.Element, - gstPlayerVolume :: Gst.Element, - gstPlayerPipeline :: Gst.Element, + gstPlayerSource :: G.Element, + gstPlayerConvert :: G.Element, + gstPlayerVolume :: G.Element, + gstPlayerPipeline :: G.Pipeline, gstPlayerMainLoop :: G.MainLoop } -makeElement :: String -> String -> IO Gst.Element -makeElement factoryName name = do - element <- Gst.elementFactoryMake factoryName $ Just name +elementMake :: (MonadIO m, MonadThrow m) => String -> m G.Element +elementMake name = do + let name' = T.pack name + element <- liftIO $ G.elementFactoryMake name' $ Just name' case element of - Just e -> return e - Nothing -> do - putStrLn $ "Could not create GStreamer \"" ++ factoryName ++ "\"element." - exitFailure + Just element' -> return element' + Nothing -> throwM $ GstPlayerElementFactoryException name' -initGstPlayer :: IO GstPlayer +elementLink :: (MonadIO m, MonadThrow m) => G.Element -> G.Element -> m () +elementLink a b = do + ok <- G.elementLink a b + unless ok $ do + nameA <- G.objectGetName a + nameB <- G.objectGetName b + throwM $ GstPlayerElementLinkException nameA nameB + +initGstPlayer :: (MonadIO m, MonadThrow m) => m GstPlayer initGstPlayer = do - Gst.init + liftIO $ void $ G.init Nothing - mainLoop <- G.mainLoopNew Nothing True + mainLoop <- liftIO $ 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" + source <- elementMake "uridecodebin" + convert <- elementMake "audioconvert" + volume <- elementMake "volume" + sink <- elementMake "autoaudiosink" - pipeline <- Gst.pipelineNew "pipeline" + pipeline <- liftIO $ G.pipelineNew (Just "pipeline") - mapM_ (Gst.binAdd $ Gst.castToBin pipeline) [source, convert, volume, sink] - _ <- Gst.elementLink convert volume - _ <- Gst.elementLink volume sink + mapM_ (G.binAdd pipeline) [source, convert, volume, sink] - _ <- G.on source Gst.elementPadAdded $ padAddedHandler convert + elementLink convert volume + elementLink volume sink - return $ GstPlayer source volume pipeline mainLoop + let gstPlayer = GstPlayer source convert 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 + void $ G.onElementPadAdded source (padAddedHandler gstPlayer) - 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 () + return gstPlayer -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 +padAddedHandler :: GstPlayer -> G.Pad -> IO () +padAddedHandler gstPlayer pad = do + sinkPad <- G.elementGetStaticPad (gstPlayerConvert gstPlayer) "sink" + when (isJust sinkPad) $ do + isLinked <- G.padIsLinked $ fromJust sinkPad + unless isLinked $ do + padCaps <- G.padGetCurrentCaps pad + when (isJust padCaps) $ do + capsStruct <- G.capsGetStructure (fromJust padCaps) 0 + structName <- G.structureGetName capsStruct + when (T.take 11 structName == "audio/x-raw") $ G.padLink pad (fromJust sinkPad) >> return () -gstPlayerTimeoutAdd :: Int -> IO Bool -> IO () -gstPlayerTimeoutAdd time action = flip G.timeoutAdd time action >> return () +gstPlayerMainLoopBlocking :: MonadIO m => GstPlayer -> m () +gstPlayerMainLoopBlocking player = liftIO $ G.mainLoopRun $ gstPlayerMainLoop player -gstBusAddWatch :: GstPlayer -> Gst.BusFunc -> IO () +gstBusAddWatch :: MonadIO m => GstPlayer -> G.BusFunc -> m () gstBusAddWatch player action = do - bus <- Gst.pipelineGetBus (Gst.castToPipeline $ gstPlayerPipeline player) - _ <- Gst.busAddWatch bus G.priorityDefault action - return () + bus <- G.pipelineGetBus $ gstPlayerPipeline player + void $ G.busAddWatch bus G.PRIORITY_DEFAULT action -gstPlayerMainLoopBlocking :: GstPlayer -> IO () -gstPlayerMainLoopBlocking player = G.mainLoopRun $ gstPlayerMainLoop player +gstPlayerGetTimeInfo :: MonadIO m => GstPlayer -> m (Maybe (Integer, Integer)) +gstPlayerGetTimeInfo player = liftIO $ do + (hasPosition, position) <- G.elementQueryPosition (gstPlayerPipeline player) G.FormatTime + (hasDuration, duration) <- G.elementQueryDuration (gstPlayerPipeline player) G.FormatTime + if (and [hasPosition, hasDuration]) + then + return $ Just (fromIntegral (position `div` fromIntegral G.SECOND) :: Integer, fromIntegral (duration `div` fromIntegral G.SECOND) :: Integer) + else + return Nothing -- Functions below can be called from any thread -gstPlayerAddIdle :: IO Bool -> IO () -gstPlayerAddIdle callback = G.idleAdd callback G.priorityDefaultIdle >> return () +gstPlayerAddIdle :: MonadIO m => IO Bool -> m () +gstPlayerAddIdle callback = liftIO $ void $ G.idleAdd G.PRIORITY_DEFAULT_IDLE callback -gstPlayerQuit :: GstPlayer -> IO () +gstPlayerTimeoutAdd :: MonadIO m => Word32 -> IO Bool -> m () +gstPlayerTimeoutAdd time action = liftIO $ void $ G.timeoutAdd G.PRIORITY_DEFAULT_IDLE time action + +gstPlayerQuit :: MonadIO m => GstPlayer -> m () gstPlayerQuit player = gstPlayerAddIdle $ do G.mainLoopQuit $ gstPlayerMainLoop player return False -gstPlayerPlay :: GstPlayer -> FilePath -> IO () +gstPlayerPlay :: MonadIO m => GstPlayer -> FilePath -> m () 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 + void $ G.elementSetState pipeline G.StateNull + G.setObjectPropertyString source "uri" (Just . T.pack $ "file://" ++ file) + G.setObjectPropertyInt source "buffer-size" (4 * 1024 * 1024) + void $ G.elementSetState pipeline G.StatePlaying return False -gstPlayerPause :: GstPlayer -> IO () +gstPlayerPause :: MonadIO m => GstPlayer -> m () gstPlayerPause player = gstPlayerAddIdle $ do - _ <- Gst.elementSetState (gstPlayerPipeline player) Gst.StatePaused + void $ G.elementSetState (gstPlayerPipeline player) G.StatePaused return False -gstPlayerStop :: GstPlayer -> IO () +gstPlayerStop :: MonadIO m => GstPlayer -> m () gstPlayerStop player = gstPlayerAddIdle $ do - _ <- Gst.elementSetState (gstPlayerPipeline player) Gst.StateNull + void $ G.elementSetState (gstPlayerPipeline player) G.StateNull return False -gstPlayerResume :: GstPlayer -> IO () +gstPlayerResume :: MonadIO m => GstPlayer -> m () gstPlayerResume player = gstPlayerAddIdle $ do - _ <- Gst.elementSetState (gstPlayerPipeline player) Gst.StatePlaying + void $ G.elementSetState (gstPlayerPipeline player) G.StatePlaying return False -gstPlayerSetVolume :: GstPlayer -> Double -> IO () +gstPlayerSetVolume :: MonadIO m => GstPlayer -> Double -> m () gstPlayerSetVolume player vol = gstPlayerAddIdle $ do - let volume = gstPlayerVolume player - G.objectSetPropertyDouble "volume" volume vol + G.setObjectPropertyDouble (gstPlayerVolume player) "volume" vol return False -gstPlayerSeek :: GstPlayer -> Integer -> IO () +gstPlayerSeek :: MonadIO m => GstPlayer -> Integer -> m () gstPlayerSeek player pos = gstPlayerAddIdle $ do - _ <- Gst.elementSeekSimple (gstPlayerPipeline player) Gst.FormatTime [Gst.SeekFlagFlush] $ fromIntegral $ (fromIntegral pos) * Gst.second + void $ G.elementSeekSimple (gstPlayerPipeline player) G.FormatTime [G.SeekFlagsFlush] $ fromIntegral $ pos * fromIntegral G.SECOND return False diff --git a/src/Mp/Player/Server.hs b/src/Mp/Player/Server.hs --- a/src/Mp/Player/Server.hs +++ b/src/Mp/Player/Server.hs @@ -1,7 +1,7 @@ -{- +{- * Programmer: Piotr Borek * E-mail: piotrborek@op.pl - * Copyright 2014 Piotr Borek + * Copyright 2016 Piotr Borek * * Distributed under the terms of the GPL (GNU Public License) * @@ -19,139 +19,130 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} +{-# LANGUAGE MultiWayIf #-} module Mp.Player.Server ( startServerBlocking ) where -import qualified Media.Streaming.GStreamer as Gst -import qualified Control.Monad.State as State +import qualified Control.Monad.State as State +import qualified Data.Text as T +import qualified GI.Gst as G -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 Control.Concurrent +import Control.Concurrent.Async +import Control.Monad +import Control.Monad.Catch +import Control.Monad.Trans +import Control.Monad.Trans.Resource +import Data.Binary +import Data.Maybe +import Network.Socket +import Simple.UI.Utils +import System.Directory +import System.FilePath.Posix +import System.Random -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 +import Mp.Configuration.Configuration +import Mp.Player.GstPlayer +import Mp.Player.ServerState +import Mp.Utils.Network +import Mp.Utils.Shuffle -makeServerSocket :: String -> IO Socket +makeServerSocket :: MonadResource m => String -> m (ReleaseKey, Socket) makeServerSocket socName = do - sock <- socket AF_UNIX Stream defaultProtocol - bind sock $ SockAddrUnix socName - listen sock 1 - return sock + (sockKey, sock) <- allocate (socket AF_UNIX Stream defaultProtocol) closeSocket + liftIO $ bind sock $ SockAddrUnix socName + liftIO $ listen sock 5 + return (sockKey, sock) + where + closeSocket sock = do + close sock + catchAll (removeFile socName) (const $ return ()) -saveServerState :: MVar ServerState -> IO () -saveServerState serverState = do +saveServerState :: MonadIO m => MVar ServerState -> m () +saveServerState serverState = liftIO $ do cfgDir <- configDirFilePath state <- readMVar serverState encodeFile (cfgDir "server.state") state -saveServerIndex :: Int -> IO () -saveServerIndex index = do +saveServerIndex :: MonadIO m => Int -> m () +saveServerIndex index = liftIO $ do cfgDir <- configDirFilePath encodeFile (cfgDir "server.index") (PlayingIndex index) -startServerBlocking :: String -> IO () +startServerBlocking :: MonadResource m => String -> m () startServerBlocking socName = do - player <- initGstPlayer - serverState <- newMVar defaultServerState + player <- initGstPlayer - readServerState player serverState + serverState <- readServerState player schedulePlayerInfo player serverState - _ <- forkIO $ do - sock <- makeServerSocket socName - - _ <- installHandler sigINT (Catch $ close sock) Nothing - _ <- installHandler sigTERM (Catch $ close sock) Nothing - - talkBlocking serverState player sock + (sockKey, sock) <- makeServerSocket socName - close sock - _ <- try' $ removeFile socName - return () + server <- liftIO $ async $ talkBlocking serverState player sock gstBusAddWatch player $ \_ message -> do - case Gst.messageType message of - Gst.MessageEOS -> playerPlay serverState player succ - _ -> return () + messageType <- G.getMessageType message + when (G.MessageTypeError `elem` messageType) $ do + modifyMVar_ serverState $ flip modifyPlayerStop player + (_, errText) <- G.messageParseError message + putStrLn $ T.unpack errText + when (G.MessageTypeEos `elem` messageType) $ playerPlay serverState player succ return True gstPlayerMainLoopBlocking player - where - readServerState player serverState = do - cfgDir <- configDirFilePath - let file0 = cfgDir "server.state" - let file1 = cfgDir "server.index" - modifyMVar_ serverState $ \_ -> do - state0 <- readStateFromFile file0 :: IO ServerState - (PlayingIndex index) <- readIndexFromFile file1 :: IO PlayingIndex - let state = state0 { - getPlaying = index - } - gstPlayerSetVolume player $ getVolume state - when (getStatus state == "Playing") $ do - let f = getPlaylist state !! (shuffleFunc state) (getPlaying state) - gstPlayerPlay player f - return state + liftIO $ wait server - 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 + release sockKey + where + readServerState player = liftIO $ do + cfgDir <- configDirFilePath + let file0 = cfgDir "server.state" + let file1 = cfgDir "server.index" -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 + state0 <- readStateFromFile file0 :: IO ServerState + (PlayingIndex index) <- readIndexFromFile file1 :: IO PlayingIndex - modifyMVar_ serverState $ \st -> do - let list = getPlaylist st - let index = indexFunction $ getPlaying st + let state = state0 { + getPlaying = index + } + stateVar <- newMVar state - if and [index >= 0, index < length list] - then - modifyPlayerPlay st player index + gstPlayerSetVolume player $ getVolume state + + when (getStatus state == "Playing") $ + catchAll + (do + let f = getPlaylist state !! shuffleFunc state index + -- gstPlayerPlay adds play command to queue + -- need to force evaluation of f + gstPlayerPlay player $! f) + (\_ -> do + newState <- modifyPlayerStop state player + modifyMVar_ stateVar $ const $ return newState) + + return stateVar + + schedulePlayerInfo player serverState = + gstPlayerTimeoutAdd 100 $ do + maybeInfo <- gstPlayerGetTimeInfo player + if isJust maybeInfo then do + let (pos, dur) = fromJust maybeInfo + modifyMVar_ serverState $ \st -> + return st { + getCurrentPosition = pos, + getCurrentDuration = dur + } 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 + modifyMVar_ serverState $ \st -> + return st { + getCurrentPosition = 0, + getCurrentDuration = 0 + } + return True modifyPlayerStop :: ServerState -> GstPlayer -> IO ServerState modifyPlayerStop st player = do @@ -172,7 +163,7 @@ State.runState shuffleFunction $ shuffleData st else (id, shuffleData st) - gstPlayerPlay player $ list !! (f index) + gstPlayerPlay player $ list !! f index return st { getPlaying = index, getStatus = "Playing", @@ -180,124 +171,146 @@ shuffleData = d } +playerPlay :: MonadIO m => MVar ServerState -> GstPlayer -> (Int -> Int) -> m () +playerPlay serverState player indexFunction = liftIO $ + modifyMVar_ serverState $ \st -> do + let list = getPlaylist st + let index = indexFunction $ getPlaying st + + if index >= 0 && index < length list + then + modifyPlayerPlay st player index + else + if isRepeatMode st + then + if | null list -> modifyPlayerStop st player + | index < 0 -> modifyPlayerPlay st player (length list - 1) + | index >= length list -> modifyPlayerPlay st player 0 + else + modifyPlayerStop st player + talkBlocking :: MVar ServerState -> GstPlayer -> Socket -> IO () -talkBlocking serverState player sock = do - _ <- try' processMessages - gstPlayerStop player - gstPlayerQuit player +talkBlocking serverState player sock = + processMessages `finally` shutdownServer + where + shutdownServer = do + gstPlayerStop player + gstPlayerQuit player - where - processMessages = do - (conn, _) <- accept sock - msg <- recv conn 4096 + processMessages = do + (conn, _ ) <- accept sock - 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 - "SaveState" -> talkSaveState serverState conn - "Quit" -> sendString conn "OK" - _ -> sendString conn "NOK" + msg <- talkServer conn `finally` close conn - close conn + when (msg /= "Quit") processMessages - when (msg /= "Quit") processMessages + talkServer conn = do + msg <- liftIO $ recvString' conn -talkSaveState :: MVar ServerState -> Socket -> IO () + 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 + "SaveState" -> talkSaveState serverState conn + "Quit" -> sendString conn "OK" + _ -> sendString conn "NOK" + + return msg + +talkSaveState :: MonadIO m => MVar ServerState -> Socket -> m () talkSaveState serverState conn = do sendString conn "OK" - saveServerState serverState + liftIO $ saveServerState serverState -talkGetPlaylist :: MVar ServerState -> Socket -> IO () +talkGetPlaylist :: MonadIO m => MVar ServerState -> Socket -> m () talkGetPlaylist serverState conn = do - list <- readMVar serverState + list <- liftIO $ readMVar serverState forM_ (reverse $ getPlaylist list) $ \item -> do sendString conn item - recvString_ conn - return () + recvString_' conn sendString conn "EndPlaylist" -talkGetStatus :: MVar ServerState -> Socket -> IO () +talkGetStatus :: MonadIO m => MVar ServerState -> Socket -> m () talkGetStatus serverState conn = do - st <- readMVar serverState + st <- liftIO $ readMVar serverState let status = getStatus st sendString conn status - recvString_ conn + recvString_' conn let dur = getCurrentDuration st sendString conn $ show dur - recvString_ conn + recvString_' conn let pos = getCurrentPosition st - sendString conn $ show pos + sendString conn $ show pos -talkSetPlay :: MVar ServerState -> Socket -> GstPlayer -> IO () +talkSetPlay :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m () talkSetPlay serverState conn player = do sendString conn "OK" - index <- recvString conn + index <- recvString' conn sendString conn "OK" - st <- readMVar serverState + st <- liftIO $ 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 :: MonadIO m => MVar ServerState -> Socket -> m () talkGetPlay serverState conn = do - st <- readMVar serverState + st <- liftIO $ readMVar serverState if getStatus st == "Stopped" then sendString conn "-1" else sendString conn $ show $ shuffleFunc st $ getPlaying st -talkAdd :: MVar ServerState -> Socket -> IO () +talkAdd :: MonadIO m => MVar ServerState -> Socket -> m () talkAdd serverState conn = do sendString conn "OK" - file <- recvString conn + file <- recvString' conn sendString conn "OK" - modifyMVar_ serverState $ \st -> do + liftIO $ 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 :: MonadIO m => MVar ServerState -> GstPlayer -> Socket -> m () talkRemove serverState player conn = do sendString conn "OK" - sIndex <- recvString conn + sIndex <- recvString' conn sendString conn "OK" - - st <- takeMVar serverState + + st <- liftIO $ 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 + liftIO $ putMVar serverState $ update index playing d st - when (or [shuffleEnabled, playing == index]) $ playerPlay serverState player id + when (shuffleEnabled || playing == index) $ playerPlay serverState player id where update index playing d st @@ -313,128 +326,128 @@ shuffleData = d } -talkClear :: MVar ServerState -> GstPlayer -> Socket -> IO () +talkClear :: MonadIO m => MVar ServerState -> GstPlayer -> Socket -> m () talkClear serverState player conn = do sendString conn "OK" - gstPlayerStop player - modifyMVar_ serverState (const $ return defaultServerState) + liftIO $ gstPlayerStop player + liftIO $ modifyMVar_ serverState (const $ return defaultServerState) -talkStop :: MVar ServerState -> Socket -> GstPlayer -> IO () +talkStop :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m () talkStop serverState conn player = do sendString conn "OK" - modifyMVar_ serverState $ flip modifyPlayerStop player + liftIO $ modifyMVar_ serverState $ flip modifyPlayerStop player -talkPause :: MVar ServerState -> Socket -> GstPlayer -> IO () +talkPause :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m () talkPause serverState conn player = do sendString conn "OK" - modifyMVar_ serverState $ \st -> do + liftIO $ modifyMVar_ serverState $ \st -> do gstPlayerPause player return st { getStatus = "Paused" } -talkResume :: MVar ServerState -> Socket -> GstPlayer -> IO () +talkResume :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m () talkResume serverState conn player = do sendString conn "OK" - modifyMVar_ serverState $ \st -> do + liftIO $ modifyMVar_ serverState $ \st -> do gstPlayerResume player return st { getStatus = "Playing" } -talkNext :: MVar ServerState -> Socket -> GstPlayer -> IO () +talkNext :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m () talkNext serverState conn player = do sendString conn "OK" - st <- takeMVar serverState + st <- liftIO $ takeMVar serverState let status = getStatus st let index = succ $ getPlaying st let len = length $ getPlaylist st let rpt = isRepeatMode st - putMVar serverState st + liftIO $ putMVar serverState st if rpt then when (status == "Playing") $ playerPlay serverState player succ else - when (and [status == "Playing", index < len]) $ playerPlay serverState player succ + when (status == "Playing" && index < len) $ playerPlay serverState player succ -talkPrev :: MVar ServerState -> Socket -> GstPlayer -> IO () +talkPrev :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m () talkPrev serverState conn player = do sendString conn "OK" - st <- takeMVar serverState + st <- liftIO $ takeMVar serverState let status = getStatus st let index = pred $ getPlaying st let rpt = isRepeatMode st - putMVar serverState st + liftIO $ putMVar serverState st if rpt then when (status == "Playing") $ playerPlay serverState player pred else - when (and [status == "Playing", index >= 0]) $ playerPlay serverState player pred + when (status == "Playing" && index >= 0) $ playerPlay serverState player pred -talkVolumeUp :: MVar ServerState -> Socket -> GstPlayer -> IO () +talkVolumeUp :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m () talkVolumeUp serverState conn player = do sendString conn "OK" - modifyMVar_ serverState $ \st -> do - let vol0 = (getVolume st) + 0.04 + liftIO $ 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 :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m () talkVolumeDown serverState conn player = do sendString conn "OK" - modifyMVar_ serverState $ \st -> do - let vol0 = (getVolume st) - 0.04 + liftIO $ 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 :: MonadIO m => MVar ServerState -> Socket -> m () talkVolumeGet serverState conn = do - st <- readMVar serverState - let vol = ceiling $ (getVolume st) * 100 :: Int + st <- liftIO $ readMVar serverState + let vol = ceiling $ getVolume st * 100 :: Int sendString conn $ show vol -talkSeekForward :: MVar ServerState -> Socket -> GstPlayer -> IO () +talkSeekForward :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m () talkSeekForward serverState conn player = do sendString conn "OK" - st <- readMVar serverState - let pos0 = (getCurrentPosition st) + 15 + st <- liftIO $ readMVar serverState + let pos0 = getCurrentPosition st + 15 let pos1 = if pos0 > getCurrentDuration st then getCurrentDuration st else pos0 - gstPlayerSeek player pos1 + liftIO $ gstPlayerSeek player pos1 -talkSeekBackward :: MVar ServerState -> Socket -> GstPlayer -> IO () +talkSeekBackward :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m () talkSeekBackward serverState conn player = do sendString conn "OK" - st <- readMVar serverState - let pos0 = (getCurrentPosition st) - 15 + st <- liftIO $ readMVar serverState + let pos0 = getCurrentPosition st - 15 let pos1 = if pos0 < 0 then 0 else pos0 - gstPlayerSeek player pos1 + liftIO $ gstPlayerSeek player pos1 -talkGetFlags :: MVar ServerState -> Socket -> IO () +talkGetFlags :: MonadIO m => MVar ServerState -> Socket -> m () talkGetFlags serverState conn = do - st <- readMVar serverState + st <- liftIO $ readMVar serverState let r = if isRepeatMode st then 'r' else '-' let z = if isShuffleMode st then 'z' else '-' - sendString conn $ [r, z] + sendString conn [r, z] -talkToggleRepeat :: MVar ServerState -> Socket -> IO () +talkToggleRepeat :: MonadIO m => MVar ServerState -> Socket -> m () talkToggleRepeat serverState conn = do sendString conn "OK" - modifyMVar_ serverState $ \st -> do + liftIO $ modifyMVar_ serverState $ \st -> return st { isRepeatMode = not $ isRepeatMode st } -talkToggleShuffle :: MVar ServerState -> GstPlayer -> Socket -> IO () +talkToggleShuffle :: MonadIO m => MVar ServerState -> GstPlayer -> Socket -> m () talkToggleShuffle serverState player conn = do sendString conn "OK" - shuffleEnabled <- modifyMVar serverState $ \st -> do + shuffleEnabled <- liftIO $ modifyMVar serverState $ \st -> if isShuffleMode st then do newSt <- disableShuffle st return (newSt, False) @@ -442,19 +455,19 @@ newSt <- enableShuffle st return (newSt, getStatus st == "Playing") - when (shuffleEnabled) $ playerPlay serverState player id + when shuffleEnabled $ playerPlay serverState player id -disableShuffle :: ServerState -> IO ServerState -disableShuffle st = +disableShuffle :: MonadIO m => ServerState -> m ServerState +disableShuffle st = return st { getPlaying = shuffleFunc st $ getPlaying st, isShuffleMode = False, shuffleFunc = id } -enableShuffle :: ServerState -> IO ServerState +enableShuffle :: MonadIO m => ServerState -> m ServerState enableShuffle st = do - r <- randomIO + r <- liftIO randomIO let (f, d) = State.runState (shuffleFilled $ length $ getPlaylist st) $ shuffleInitial (mkStdGen r) return st { getPlaying = 0, diff --git a/src/Mp/Player/ServerState.hs b/src/Mp/Player/ServerState.hs --- a/src/Mp/Player/ServerState.hs +++ b/src/Mp/Player/ServerState.hs @@ -1,4 +1,4 @@ -{- +{- * Programmer: Piotr Borek * E-mail: piotrborek@op.pl * Copyright 2014 Piotr Borek @@ -24,11 +24,11 @@ import qualified Control.Monad.State as State +import Control.Monad.Catch import Data.Binary import System.Random import Mp.Utils.Shuffle -import Mp.Utils.Exception data PlayingIndex = PlayingIndex Int @@ -163,7 +163,7 @@ } readStateFromFile :: String -> IO ServerState -readStateFromFile file = decodeFile file `catchAny` (\_ -> return defaultServerState) +readStateFromFile file = decodeFile file `catchAll` (\_ -> return defaultServerState) readIndexFromFile :: String -> IO PlayingIndex -readIndexFromFile file = decodeFile file `catchAny` (\_ -> return $ PlayingIndex 0) +readIndexFromFile file = decodeFile file `catchAll` (\_ -> return $ PlayingIndex 0) diff --git a/src/Mp/UI/BrowserPage.hs b/src/Mp/UI/BrowserPage.hs --- a/src/Mp/UI/BrowserPage.hs +++ b/src/Mp/UI/BrowserPage.hs @@ -1,7 +1,7 @@ -{- +{- * Programmer: Piotr Borek * E-mail: piotrborek@op.pl - * Copyright 2014 Piotr Borek + * Copyright 2018 Piotr Borek * * Distributed under the terms of the GPL (GNU Public License) * @@ -19,206 +19,178 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TemplateHaskell #-} module Mp.UI.BrowserPage ( - BrowserPage (..), - BrowserPageWidget, - makeUIBrowserPage + BrowserPageClass, + BrowserPage, + castToBrowserPage, + browserPageNew ) where -import Graphics.Vty.Widgets.All -import Graphics.Vty hiding (Button) +import Control.Lens (ix, makeLensesFor, (.=), (^.), (^?)) +import Control.Monad +import Control.Monad.IO.Class +import Data.List (elemIndex, isPrefixOf, isSuffixOf, + sort) +import qualified Graphics.Vty as Vty +import Simple.UI.All +import System.Directory (doesDirectoryExist, doesFileExist, + getCurrentDirectory, + getDirectoryContents, + setCurrentDirectory) +import System.FilePath.Posix (()) -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.Player.Client +import Mp.UI.MpData -import Mp.Utils.Colors -import Mp.Utils.Exception -import Mp.Utils.Utils -import Mp.Configuration.Configuration -import Mp.UI.QueuePage +newtype BrowserPage = BrowserPage + { _browserPageParent :: Widget + } -type BrowserPageWidget = Widget (List String FormattedText) +makeLensesFor [("_browserPageParent", "browserPageParent")] ''BrowserPage -data BrowserPage = BrowserPage { - browserPageWidget :: BrowserPageWidget, - browserPageFocusGroup :: Widget FocusGroup, - browserPageReset :: IO () -} +data FileAttr = FileAttrFile + | FileAttrDirectory -data BrowserState = BrowserState { - topDir :: !String, - dirCache :: Map.HashMap String String -} +class BrowserPageClass w where + castToBrowserPage :: w -> BrowserPage -makeUIBrowserPage :: ConfigParser -> QueuePage -> IO BrowserPage -makeUIBrowserPage conf queuePage = do - fg <- newFocusGroup +instance BrowserPageClass BrowserPage where + castToBrowserPage = id - lst <- newList (browserActiveAttribute conf ) 1 - >>= withBrowserBgAttribute conf +instance WidgetClass BrowserPage where + castToWidget = _browserPageParent - let musicDir = getMusicDirectory conf - setCurrentDirectory musicDir + overrideWidget = overrideWidgetHelper browserPageParent - browserState <- newMVar BrowserState { - topDir = musicDir, - dirCache = Map.empty - } - addAllFilesToList lst musicDir +browserPageNew :: UIApp MpData BrowserPage +browserPageNew = do + mpData <- view appUserData - _ <- addToFocusGroup fg lst - _ <- addToFocusGroup fg lst + let rootMusicDir = mpData ^. mpMusicDirectory + liftIO $ setCurrentDirectory rootMusicDir - let keyHandler = \_ k _ -> - case k of - KEnter -> do - maybeSel <- getSelected lst - let (_, (value, _)) = fromJust maybeSel - modifyMVar_ browserState $ changeDirectory lst value - return True + content <- directoryList rootMusicDir + attrContent <- attributeNew content - KASCII '!' -> do - modifyMVar_ browserState $ changeDirectory lst musicDir - return True + textListView <- textListViewNew $ \item index -> do + cont <- readAttr attrContent - KASCII '@' -> do - modifyMVar_ browserState $ changeDirectory lst ".." - return True + case cont ^? ix index of + Just (fileAttr, file) -> do + dir <- liftIO getCurrentDirectory + set item text $ Just file + set item itemData $ Just (dir file) + case fileAttr of + FileAttrFile -> do + songExists <- liftUIApp mpData $ mpSongExists (dir file) + if songExists + then set item colorForeground $ mpData ^. mpColors . browserSelectedForeground + else set item colorForeground $ mpData ^. mpColors . browserFileForeground + set item colorStyle DrawStyleNormal + FileAttrDirectory -> do + set item colorForeground $ mpData ^. mpColors . browserDirForeground + set item colorStyle DrawStyleBold + Nothing -> do + set item text Nothing + set item itemData Nothing - KASCII ' ' -> do - selectCurrentFile lst - return True + on_ textListView textItemActivated $ \item -> do + (Just dir) <- get item itemData + isDir <- liftIO $ doesDirectoryExist dir + when isDir $ + goToDirectory attrContent textListView dir - KASCII 'd' -> do - removeCurrentFile lst - return True + let browser = overrideWidget + BrowserPage { _browserPageParent = castToWidget textListView } + $ virtualWidgetName .= "browserpage" - _ -> return False + set browser colorForeground $ mpData ^. mpColors . browserFileForeground + set browser colorBackground $ mpData ^. mpColors . browserBackground + set browser colorBackgroundSelected $ mpData ^. mpColors . browserActiveBackground - lst `onKeyPressed` keyHandler + on_ browser keyPressed $ \key _ -> + case key of + Vty.KChar '!' -> + goToDirectory attrContent textListView rootMusicDir - 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) + Vty.KChar '@' -> do + dir <- liftIO getCurrentDirectory + goToDirectory attrContent textListView (dir "..") - addAllFilesToList list dir = do - clearList list + Vty.KChar ' ' -> do + index <- textListViewGetPos textListView + files <- readAttr attrContent + dir <- liftIO getCurrentDirectory + liftUIApp mpData $ browserPageAddSong dir (files !! index) + textListViewGoDown textListView - files <- sort <$> getDirectoryContents dir + Vty.KChar 'd' -> do + index <- textListViewGetPos textListView + files <- readAttr attrContent + dir <- liftIO getCurrentDirectory + liftUIApp mpData $ browserPageRemoveSong dir (files !! index) + textListViewGoDown textListView - forM_ files $ \file -> do - exists <- doesDirectoryExist $ dir file - when (and [exists, file /= "."]) $ addDirToList list file + _ -> + return () - forM_ files $ \file -> do - exists <- doesFileExist $ dir file - when exists $ addFileToList list file + return browser + where + directoryList currentDir = liftIO $ do + content <- getDirectoryContents currentDir - 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 + directories <- sort <$> filterM (isDirectory currentDir) content + files <- sort <$> filterM (isFile currentDir) content - 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 () + return $ map (\d -> (FileAttrDirectory, d)) directories ++ + map (\f -> (FileAttrFile, f)) files - 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 + isDirectory dir file = do + exists <- doesDirectoryExist $ dir file + return $ exists && file /= "." && (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 () + isFile dir file = doesFileExist $ dir file - whenM (doesFileExist $ currDir file) $ do - _ <- withBrowserFileAttribute conf item - return () + goToDirectory attrContent textListView dir = do + liftIO $ setCurrentDirectory dir + dir' <- liftIO getCurrentDirectory + files <- directoryList dir' + writeAttr attrContent files + if ".." `isSuffixOf` dir + then do + let _selDir = drop (length dir') (take (length dir - 3) dir) + let selDir = if "/" `isPrefixOf` _selDir then drop 1 _selDir else _selDir + case elemIndex selDir (fmap snd files) of + Nothing -> return () + Just index -> textListViewCenterAt textListView index (length files) + else + textListViewCenterAt textListView 0 (length files) - setSelected list $ succ index - removeAllFiles currDir file - return () + browserPageAddSong _ (_, "..") = return () + browserPageAddSong dir (fileAttr, file) = + case fileAttr of + FileAttrDirectory -> do + let newDir = dir file + content <- directoryList newDir + forM_ content $ \f -> browserPageAddSong newDir f - 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 + FileAttrFile -> do + mpSongAdd (dir file) + clientSendAddFile (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 + browserPageRemoveSong _ (_, "..") = return () + browserPageRemoveSong dir (fileAttr, file) = + case fileAttr of + FileAttrDirectory -> do + let newDir = dir file + content <- directoryList newDir + forM_ content $ \f -> browserPageRemoveSong newDir f + + FileAttrFile -> do + songInList <- mpSongExists (dir file) + when songInList $ do + listIndex <- mpSongRemove (dir file) + clientSendRemove listIndex diff --git a/src/Mp/UI/EditBar.hs b/src/Mp/UI/EditBar.hs --- a/src/Mp/UI/EditBar.hs +++ b/src/Mp/UI/EditBar.hs @@ -1,7 +1,7 @@ -{- +{- * Programmer: Piotr Borek * E-mail: piotrborek@op.pl - * Copyright 2014 Piotr Borek + * Copyright 2016 Piotr Borek * * Distributed under the terms of the GPL (GNU Public License) * @@ -19,42 +19,98 @@ * 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 #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} module Mp.UI.EditBar ( - EditBar (..), - EditBarWidget, - makeUIEditBar + editBarNew ) where -import qualified Data.Text as T -import Control.Applicative +import Control.Lens (makeLensesFor) +import Control.Monad +import Control.Monad.IO.Class +import qualified Graphics.Vty as Vty +import Simple.Locale.TranslateTH +import Simple.UI.All +import System.Directory (doesFileExist) +import System.FilePath.Posix (()) -import Graphics.Vty.Widgets.All -import Graphics.Vty hiding (Button) +import Mp.Configuration.Configuration +import Mp.Locale.TranslateFile () +import Mp.UI.MpData +import Mp.UI.QuestionBar +import Mp.UI.SongList -import Data.ConfigFile +newtype EditBar = EditBar + { _editBarParent :: Widget + } -import Mp.Utils.Colors +makeLensesFor [("_editBarParent", "editBarParent")] ''EditBar -type EditBarWidget = Widget Edit +instance WidgetClass EditBar where + castToWidget = _editBarParent -data EditBar = EditBar { - editBarWidget :: EditBarWidget, - editBarGetText :: IO String, - editBarReset :: IO (), - editBarOnKeyPressed :: (Widget Edit -> Key -> [Modifier] -> IO Bool) -> IO () -} + overrideWidget = overrideWidgetHelper editBarParent -makeUIEditBar :: ConfigParser -> IO EditBar -makeUIEditBar conf = do - edit <- editWidget - >>= withEditAttribute conf +editBarNew :: UIApp MpData EditBar +editBarNew = do + mpData <- view appUserData - return EditBar { - editBarWidget = edit, - editBarGetText = T.unpack <$> getEditText edit, - editBarReset = setEditText edit "", - editBarOnKeyPressed = onKeyPressed edit - } + layout1 <- fillLayoutVerticalNew + container1 <- containerNew layout1 + + layout2 <- fillLayoutHorizontalNew + container2 <- containerNew layout2 + + l1 <- labelNew $ Just ([tr|Enter playlist name|] ++ ": ") + addTo container2 l1 def { fillLayoutHExpand = False } + + edit <- editNew Nothing + addTo container2 edit def + + questionBar <- questionBarNew + set questionBar visible False + + addTo container1 container2 def { fillLayoutVExpand = False } + addTo container1 questionBar def { fillLayoutVExpand = False } + + on_ edit keyPressed $ \key _ -> + case key of + Vty.KEsc -> do + set edit text Nothing + mainLoopQuit + + Vty.KEnter -> do + _text <- get edit text + forM_ _text $ \_name -> do + list <- readAttr $ mpData ^. mpSongList + dir <- liftIO playlistDirFilePath + exists <- liftIO $ doesFileExist (dir _name) + if exists + then do + set questionBar visible True + runDialogLoop questionBar + set questionBar visible False + _answer <- get questionBar answer + when (_answer == Yes) $ + songListWrite (dir _name) list + else + songListWrite (dir _name) list + + set edit text Nothing + mainLoopQuit + + _ -> + return () + + container1 `connectColorsTo` l1 + container1 `connectColorsTo` edit + + set container1 colorForeground $ mpData ^. mpColors . editForeground + set container1 colorBackground $ mpData ^. mpColors . editBackground + + let editBar = overrideWidget + EditBar { _editBarParent = castToWidget container1 } + $ virtualWidgetName .= "editbar" + + return editBar diff --git a/src/Mp/UI/HelpPage.hs b/src/Mp/UI/HelpPage.hs --- a/src/Mp/UI/HelpPage.hs +++ b/src/Mp/UI/HelpPage.hs @@ -1,7 +1,7 @@ -{- +{- * Programmer: Piotr Borek * E-mail: piotrborek@op.pl - * Copyright 2014 Piotr Borek + * Copyright 2017 Piotr Borek * * Distributed under the terms of the GPL (GNU Public License) * @@ -19,129 +19,60 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} +{-# LANGUAGE QuasiQuotes #-} module Mp.UI.HelpPage ( - HelpPage (..), - HelpPageWidget, - makeUIHelpPage + helpPageNew ) 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) +import Simple.Locale.TranslateTH +import Simple.UI.All - scrollPageUp list height index = do - scrollToBeginning list - scrollBy list $ height + index - setSelected list $ pred index +import Mp.Locale.TranslateFile () +import Mp.UI.MpData - scrollPageDown list height index = do - listLength <- getListSize list - when (index < listLength - height) $ do - scrollToBeginning list - scrollBy list $ height + index - setSelected list $ succ index +helpPageNew :: UIApp MpData TextView +helpPageNew = textViewNew $ Just helpPageText - 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 " " +helpPageText :: String +helpPageText = unlines + [ " q : " ++ [tr|Detach from the server|] + , " Q : " ++ [tr|Quit|] + , "" + , " 1 : " ++ [tr|Help screen|] + , " 2 : " ++ [tr|Queue screen|] + , " 3 : " ++ [tr|Playlists screen|] + , " 4 : " ++ [tr|Browser screen|] + , "" + , " Tab : " ++ [tr|Next screen|] + , " Shift+Tab : " ++ [tr|Previous screen|] + , "" + , " Up : " ++ [tr|Move cursor up|] + , " Down : " ++ [tr|Move cursor down|] + , " PageUp : " ++ [tr|Page up|] + , " PageDown : " ++ [tr|Page down|] + , "" + , " Enter : " ++ [tr|Start playing|] ++ " / " ++ [tr|Enter directory|] ++ " / " ++ [tr|Enter playlist|] + , " s : " ++ [tr|Stop playing|] + , " p : " ++ [tr|Pause|] ++ " / " ++ [tr|resume playing|] + , "" + , " space : " ++ [tr|Add file|] ++ " / " ++ [tr|directory|] ++ " / " ++ [tr|playlist|] + , " d : " ++ [tr|Remove file|] ++ " / " ++ [tr|directory|] ++ " / " ++ [tr|playlist|] + , " c : " ++ [tr|Clear the queue|] + , " l : " ++ [tr|Center|] + , " S : " ++ [tr|Save playlist|] + , " Ctrl+d : " ++ [tr|Delete playlist|] + , " ! : " ++ [tr|Go to root directory|] + , " @ : " ++ [tr|Go to parent directory|] + , "" + , " > : " ++ [tr|Play next file|] + , " < : " ++ [tr|Play previous file|] + , " f : " ++ [tr|Seek forward|] + , " b : " ++ [tr|Seek backward|] + , "" + , " r : " ++ [tr|Toggle repeat mode|] + , " z : " ++ [tr|Toggle random mode|] + , "" + , " [ : " ++ [tr|Decrease volume|] + , " ] : " ++ [tr|Increase volume|] + ] diff --git a/src/Mp/UI/Main.hs b/src/Mp/UI/Main.hs --- a/src/Mp/UI/Main.hs +++ b/src/Mp/UI/Main.hs @@ -1,7 +1,7 @@ -{- +{- * Programmer: Piotr Borek * E-mail: piotrborek@op.pl - * Copyright 2014 Piotr Borek + * Copyright 2016 Piotr Borek * * Distributed under the terms of the GPL (GNU Public License) * @@ -20,187 +20,76 @@ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} -{-# LANGUAGE OverloadedStrings #-} - module Mp.UI.Main ( - makeAndRunUI + mainLoop ) 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 - -exitUI :: IO () -exitUI = clientSendSaveState >> shutdownUi - -makeAndRunUI :: IO () -makeAndRunUI = do - _ <- installHandler sigINT (Catch $ schedule exitUI) Nothing - _ <- installHandler sigHUP (Catch $ schedule exitUI) Nothing - _ <- installHandler sigABRT (Catch $ schedule exitUI) Nothing - _ <- installHandler sigTERM (Catch $ schedule exitUI) 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' -> clientSendSaveState >> exitSuccess - KASCII 'Q' -> clientSendSaveState >> 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 +import Control.Monad +import qualified Graphics.Vty as Vty +import Simple.UI.All - if q then - case k of - KASCII 'y' -> do - restoreFocus status edit fg2 question enabled - playlistAdd playlistPage True name list - return True +import Mp.Player.Client +import Mp.UI.BrowserPage +import Mp.UI.EditBar +import Mp.UI.HelpPage +import Mp.UI.MainMenuBar +import Mp.UI.MainStatusBar +import Mp.UI.MpData +import Mp.UI.PlaylistPage +import Mp.UI.QueuePage - KASCII 'Y' -> do - restoreFocus status edit fg2 question enabled - playlistAdd playlistPage True name list - return True +mainLoop :: UIApp MpData () +mainLoop = do + windowLayout <- fillLayoutVerticalNew + window <- windowNew WindowTypeTopLevel windowLayout - KASCII 'n' -> do - restoreFocus status edit fg2 question enabled - return True + containerLayout <- singleLayoutNew + container <- containerNew containerLayout - KASCII 'N' -> do - restoreFocus status edit fg2 question enabled - return True + menuBar <- mainMenuBarNew containerLayout 1 + addTo window menuBar def { fillLayoutVExpand = False } - KEsc -> do - restoreFocus status edit fg2 question enabled - return True + helpPage <- helpPageNew + addTo container helpPage def - _ -> return True - else - case k of - KEsc -> do - restoreFocus status edit fg2 question enabled - return True + queuePage <- queuePageNew + addTo container queuePage def - KEnter -> do - modifyMVar_ enabled $ const (return True) + playlistPage <- playlistPageNew + addTo container playlistPage def - 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 + browserPage <- browserPageNew + addTo container browserPage def - _ -> return False + addTo window container def - let queueHandler = \_ k _ -> - case k of - KASCII 'S' -> do - modifyMVar_ enabled $ const (return False) - statusBarSetText status (__ "Enter playlist name:") - focus $ editBarWidget edit - return True + statusBar <- mainStatusBarNew + addTo window statusBar def { fillLayoutVExpand = False } - _ -> return False + editBar <- editBarNew + addTo window editBar def { fillLayoutVExpand = False } + set editBar visible False - fg1 `onKeyPressed` keyHandler - fg2 `onKeyPressed` keyHandler - fg3 `onKeyPressed` keyHandler - fg4 `onKeyPressed` keyHandler + on_ window keyPressed $ \key _ -> + case key of + Vty.KChar 'q' -> do + clientSendSaveState + mainLoopQuit - edit `editBarOnKeyPressed` editHandler - fg2 `onKeyPressed` queueHandler + Vty.KChar 'Q' -> do + clientSendSaveState + clientSendQuitMessage + mainLoopQuit - runUi c defaultContext - where - makeUI menu status edit widget = return (menuWidget menu) <--> return widget <--> return (statusBarWidget status) <--> return (editBarWidget edit) + Vty.KChar 'S' -> do + i <- get containerLayout layoutIndex + when (i == 1) $ do + set editBar visible True + runDialogLoop editBar + set editBar visible False + playlistPageUpdate playlistPage - makeActiveFunction active menu switches = \index -> do - menuActivate menu index - _ <- (!!) switches index - modifyMVar_ active (const $ return index) + _ -> + return () - restoreFocus status edit fg2 question enabled = do - modifyMVar_ question $ const (return False) - modifyMVar_ enabled $ const (return True) - focusPrevious fg2 - statusBarReset status - editBarReset edit + runMainLoop window diff --git a/src/Mp/UI/MainMenuBar.hs b/src/Mp/UI/MainMenuBar.hs new file mode 100644 --- /dev/null +++ b/src/Mp/UI/MainMenuBar.hs @@ -0,0 +1,80 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2017 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 QuasiQuotes #-} + +module Mp.UI.MainMenuBar ( + mainMenuBarNew +) where + +import Control.Monad +import qualified Graphics.Vty as Vty +import Simple.Locale.TranslateTH +import Simple.UI.All + +import Mp.Locale.TranslateFile () +import Mp.UI.MpData + +mainMenuBarNew :: SingleLayout -> Int -> UIApp MpData SimpleMenuBar +mainMenuBarNew _layout activeMenu = do + mpData <- view appUserData + menuBar <- simpleMenuBarNew + + set menuBar colorForeground (mpData ^. mpColors . tabForeground) + set menuBar colorBackground (mpData ^. mpColors . tabBackground) + set menuBar colorForegroundSelected (mpData ^. mpColors . tabActiveForeground) + set menuBar colorBackgroundSelected (mpData ^. mpColors . tabActiveBackground) + set menuBar colorStyleSelected DrawStyleBold + + item1 <- simpleMenuItemNew '1' [tr|Help |] + item2 <- simpleMenuItemNew '2' [tr|Queue |] + item3 <- simpleMenuItemNew '3' [tr|Playlist|] + item4 <- simpleMenuItemNew '4' [tr|Browser |] + + let items = [item1, item2, item3, item4] + forM_ items $ menuBarItemAdd menuBar + + on_ item1 activated $ + set _layout layoutIndex 0 + + on_ item2 activated $ + set _layout layoutIndex 1 + + on_ item3 activated $ + set _layout layoutIndex 2 + + on_ item4 activated $ + set _layout layoutIndex 3 + + on_ menuBar keyPressed $ \key _ -> + case key of + Vty.KChar '\t' -> do + i <- get _layout layoutIndex + menuItemActivate (items !! (succ i `mod` 4)) + Vty.KBackTab -> do + i <- get _layout layoutIndex + menuItemActivate (items !! (pred i `mod` 4)) + _ -> + return () + + menuItemActivate (items !! activeMenu) + + return menuBar diff --git a/src/Mp/UI/MainStatusBar.hs b/src/Mp/UI/MainStatusBar.hs new file mode 100644 --- /dev/null +++ b/src/Mp/UI/MainStatusBar.hs @@ -0,0 +1,69 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2017 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 QuasiQuotes #-} + +module Mp.UI.MainStatusBar ( + mainStatusBarNew +) where + +import Control.Monad.Catch +import Simple.Locale.TranslateTH +import Simple.UI.All + +import Mp.Locale.TranslateFile () +import Mp.Player.Client +import Mp.UI.MpData +import Mp.Utils.Utils + +mainStatusBarNew :: UIApp MpData StatusBar +mainStatusBarNew = do + statusBar <- statusBarNew + set statusBar textLeft $ Just "Left" + set statusBar textRight $ Just "Right" + + mpData <- view appUserData + set statusBar colorForeground (mpData ^. mpColors . statusForeground) + set statusBar colorBackground (mpData ^. mpColors . statusBackground) + set statusBar colorStyle DrawStyleBold + + scheduleStatusFromServer statusBar + return statusBar + where + statusToString status = case status of + "Stopped" -> [tr|Stopped|] + "Playing" -> [tr|Playing|] + "Paused" -> [tr|Paused|] + _ -> [tr|Unknown|] + + scheduleStatusFromServer statusBar = mainScheduleRepeat 200 $ + catchAll + (do + (status, dur, pos) <- clientSendGetStatus + flags <- clientSendGetFlags + vol <- clientSendVolumeGet + set statusBar textLeft $ Just (" " ++ statusToString status ++ " [" ++ timeToString pos ++ "/" ++ timeToString dur ++ "]") + set statusBar textRight $ Just ("[" ++ flags ++ "] " ++ [tr|Volume|] ++ ": " ++ vol ++ " % ") + ) + (\_ -> do + set statusBar textLeft $ Just [tr|Connection error|] + set statusBar textRight Nothing + ) diff --git a/src/Mp/UI/Menu.hs b/src/Mp/UI/Menu.hs deleted file mode 100644 --- a/src/Mp/UI/Menu.hs +++ /dev/null @@ -1,68 +0,0 @@ -{- - * 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/MpData.hs b/src/Mp/UI/MpData.hs new file mode 100644 --- /dev/null +++ b/src/Mp/UI/MpData.hs @@ -0,0 +1,97 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2017 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 TemplateHaskell #-} + +module Mp.UI.MpData ( + MpData (..), + mpColors, + mpMusicDirectory, + mpSongList, + mpSongMap, + mpSongInit, + mpSongAdd, + mpSongRemove, + mpSongExists, + + module Mp.Configuration.AppColors +) where + +import Control.Lens +import Control.Monad +import Data.List +import qualified Data.Map.Strict as Map +import Simple.UI.All + +import Mp.Configuration.AppColors + +data MpData = MpData + { _mpColors :: AppColors + , _mpMusicDirectory :: String + , _mpSongList :: Attribute [String] + , _mpSongMap :: Attribute (Map.Map String Integer) + } + +makeLenses ''MpData + +mpSongInit :: [String] -> UIApp MpData () +mpSongInit songList = do + mpData <- view appUserData + writeAttr (mpData ^. mpSongList) songList + let songList' = map (\x -> (x, 1)) songList + writeAttr (mpData ^. mpSongMap) $ Map.fromList songList' + +mpSongAdd :: String -> UIApp MpData () +mpSongAdd _name = do + mpData <- view appUserData + modifyAttr (mpData ^. mpSongList) $ \xs -> xs ++ [_name] + modifyAttr (mpData ^. mpSongMap) $ \m -> + let v = Map.lookup _name m in + case v of + Just x -> Map.insert _name (succ x) m + Nothing -> Map.insert _name 1 m + +mpSongRemove :: String -> UIApp MpData Int +mpSongRemove _name = do + mpData <- view appUserData + songList <- readAttr (mpData ^. mpSongList) + let _indices = elemIndices _name songList + + when (null _indices) $ error "MpData.hs:79: indices == []" + + let _index = last _indices + writeAttr (mpData ^. mpSongList) $ removeAt _index songList + modifyAttr (mpData ^. mpSongMap) $ \songMap -> + let v = Map.lookup _name songMap in + case v of + Just 1 -> Map.delete _name songMap + Just _ -> Map.adjust pred _name songMap + Nothing -> songMap + + return _index + +mpSongExists :: String -> UIApp MpData Bool +mpSongExists _name = do + mpData <- view appUserData + songMap <- readAttr (mpData ^. mpSongMap) + case Map.lookup _name songMap of + Just v -> if v > 0 then return True else return False + Nothing -> return False diff --git a/src/Mp/UI/PlaylistPage.hs b/src/Mp/UI/PlaylistPage.hs --- a/src/Mp/UI/PlaylistPage.hs +++ b/src/Mp/UI/PlaylistPage.hs @@ -1,7 +1,7 @@ -{- +{- * Programmer: Piotr Borek * E-mail: piotrborek@op.pl - * Copyright 2014 Piotr Borek + * Copyright 2018 Piotr Borek * * Distributed under the terms of the GPL (GNU Public License) * @@ -19,245 +19,224 @@ * 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 #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} module Mp.UI.PlaylistPage ( - PlaylistPage (..), - PlaylistPageWidget, - makeUIPlaylistPage + PlaylistPageClass, + PlaylistPage, + castToPlaylistPage, + playlistPageNew, + playlistPageUpdate ) where -import qualified Data.HashMap.Strict as Map -import qualified Data.Binary as B -import qualified Data.Text as T +import Control.Lens (ix, makeLensesFor, (.=), (^?)) +import Control.Monad +import Control.Monad.IO.Class +import Data.List (isSuffixOf, sort) +import qualified Graphics.Vty as Vty +import Simple.UI.All +import System.Directory (doesFileExist, + getDirectoryContents, + removeFile) +import System.FilePath.Posix (()) -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.Configuration.Configuration +import Mp.Player.Client +import Mp.UI.MpData +import Mp.UI.SongList +import Mp.Utils.Utils -import Mp.Utils.Colors -import Mp.Utils.Exception -import Mp.Utils.Utils -import Mp.Configuration.Configuration -import Mp.UI.PlaylistState -import Mp.UI.QueuePage +data PlaylistView = PlaylistViewPlaylist + | PlaylistViewSongs + deriving Eq -type PlaylistPageWidget = Widget (List String FormattedText) +data PlaylistPage = PlaylistPage + { _playlistPageParent :: Widget + , _playlistPageContent :: Attribute [String] + , _playlistPageState :: Attribute PlaylistView + } -data PlaylistPage = PlaylistPage { - playlistPageWidget :: PlaylistPageWidget, - playlistPageFocusGroup :: Widget FocusGroup, - playlistAdd :: Bool -> String -> [String] -> IO (), - playlistReset :: IO () -} +makeLensesFor [("_playlistPageParent", "playlistPageParent")] ''PlaylistPage -data PlaylistState = PlaylistState { - playlistNames :: ![String], - playlistMap :: Map.HashMap String [String], - index :: !Int -} +class PlaylistPageClass w where + castToPlaylistPage :: w -> PlaylistPage -makeUIPlaylistPage :: ConfigParser -> QueuePage -> IO PlaylistPage -makeUIPlaylistPage conf queuePage = do - playlistState <- newMVar PlaylistState { - playlistNames = [], - playlistMap = Map.empty, - index = -1 - } + playlistPageUpdate :: w -> UIApp u () + playlistPageUpdate (castToPlaylistPage -> playlistPage) = do + state <- get playlistPage _playlistPageState + when (state == PlaylistViewPlaylist) $ do + files <- fileList + set playlistPage _playlistPageContent files - fg <- newFocusGroup +instance PlaylistPageClass PlaylistPage where + castToPlaylistPage = id - lst <- newList (playlistActiveAttribute conf) 1 - >>= withPlaylistBgAttribute conf +instance WidgetClass PlaylistPage where + castToWidget = _playlistPageParent - _ <- addToFocusGroup fg lst - _ <- addToFocusGroup fg lst + overrideWidget = overrideWidgetHelper playlistPageParent - 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 +playlistPageNew :: UIApp MpData PlaylistPage +playlistPageNew = do + mpData <- view appUserData + playlistState <- attributeNew PlaylistViewPlaylist + files <- fileList + content <- attributeNew files + savedPos <- attributeNew 0 - 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 + textListView <- textListViewNew $ \item index -> do + state <- readAttr playlistState + case state of + PlaylistViewPlaylist -> liftUIApp mpData $ viewPlaylistsCallback content item index + PlaylistViewSongs -> liftUIApp mpData $ viewSongsCallback content item index - 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 + on_ textListView textItemActivated $ \item -> do + state <- readAttr playlistState + case state of + PlaylistViewPlaylist -> viewSongs textListView item content playlistState savedPos - 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 + PlaylistViewSongs -> viewPlaylist textListView content playlistState savedPos - 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 + on_ textListView keyPressed $ \key modifiers -> do + state <- readAttr playlistState + index <- textListViewGetPos textListView + case key of + Vty.KChar '!' -> + when (state == PlaylistViewSongs) $ + viewPlaylist textListView content playlistState savedPos - _ -> return False + Vty.KChar '@' -> + when (state == PlaylistViewSongs) $ + viewPlaylist textListView content playlistState savedPos - lst `onKeyPressed` keyHandler + Vty.KChar ' ' -> do + _files <- readAttr content + let file = _files !! index + case state of + PlaylistViewPlaylist -> liftUIApp mpData $ playlistPageAddPlaylist file + PlaylistViewSongs -> liftUIApp mpData $ playlistPageAddSong file + textListViewGoDown textListView - readPlaylist playlistState lst + Vty.KChar 'd' | Vty.MCtrl `elem` modifiers -> + when (state == PlaylistViewPlaylist) $ do + _files <- readAttr content + dir <- liftIO playlistDirFilePath - return PlaylistPage { - playlistPageWidget = lst, - playlistPageFocusGroup = fg, - playlistAdd = playlistAddAndSave playlistState lst, - playlistReset = reset playlistState lst - } + liftIO $ removeFile (dir (_files !! index)) + writeAttr content $ removeAt index _files - where - addNameTo widget name = addToList widget name =<< (plainText (T.pack name) >>= withPlaylistNameAttribute conf) + Vty.KChar 'd' -> do + _files <- readAttr content + let file = _files !! index + case state of + PlaylistViewPlaylist -> liftUIApp mpData $ playlistPageRemovePlaylist file + PlaylistViewSongs -> liftUIApp mpData $ playlistPageRemoveSong file + textListViewGoDown textListView - 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 + _ -> + return () - showNames widget st = do - clearList widget - forM_ (playlistNames st) $ addNameTo widget + let playlist = overrideWidget + PlaylistPage { _playlistPageParent = castToWidget textListView + , _playlistPageContent = content + , _playlistPageState = playlistState + } + $ virtualWidgetName .= "playlistpage" - 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 + set playlist colorForeground $ mpData ^. mpColors . playlistForeground + set playlist colorBackground $ mpData ^. mpColors . playlistBackground + set playlist colorBackgroundSelected $ mpData ^. mpColors . playlistActiveBackground - 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 - } + return playlist + where + playlistPageAddPlaylist file = do + dir <- liftIO playlistDirFilePath + playlist <- songListRead (dir file) + forM_ playlist playlistPageAddSong - 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 + playlistPageRemovePlaylist file = do + dir <- liftIO playlistDirFilePath + playlist <- songListRead (dir file) + forM_ playlist playlistPageRemoveSong - playlistSave playlistState cfgDir plsDir name list = do - st <- readMVar playlistState - B.encodeFile (cfgDir "playlists.state") (NameList $ playlistNames st) - B.encodeFile (plsDir name) $ SongList list + playlistPageAddSong file = + unless ("/.." `isSuffixOf` file) $ do + mpSongAdd file + clientSendAddFile file - 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 + playlistPageRemoveSong file = + unless ("/.." `isSuffixOf` file) $ do + songInList <- mpSongExists file + when songInList $ do + listIndex <- mpSongRemove file + clientSendRemove listIndex - 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 - } +fileList :: MonadIO m => m [String] +fileList = liftIO $ do + dir <- playlistDirFilePath + content <- getDirectoryContents dir + sort <$> filterM (isFile dir) content - playlistDelete playlistState cfgDir plsDir name = do - st <- readMVar playlistState - B.encodeFile (cfgDir "playlists.state") (NameList $ playlistNames st) - removeFile (plsDir name) +isFile :: String -> String -> IO Bool +isFile dir file = doesFileExist $ dir file - 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 +viewPlaylistsCallback :: Attribute [String] -> TextItem String -> Int -> UIApp MpData () +viewPlaylistsCallback content item index = do + mpData <- view appUserData + files <- readAttr content + case files ^? ix index of + Just file -> do + set item text $ Just file + set item itemData Nothing + set item colorStyle DrawStyleBold + set item colorForeground $ mpData ^. mpColors . playlistForeground + Nothing -> do + set item text Nothing + set item itemData Nothing + +viewSongsCallback :: Attribute [String] -> TextItem String -> Int -> UIApp MpData () +viewSongsCallback content item index = do + mpData <- view appUserData + files <- readAttr content + case files ^? ix index of + Just file -> do + let (_, s) = separateFilePath file + set item text $ Just s + set item itemData $ Just file + if "/.." `isSuffixOf` file + then do + set item colorStyle DrawStyleBold + set item colorForeground $ mpData ^. mpColors . playlistForeground + else do + set item colorStyle DrawStyleNormal + songExists <- mpSongExists file + if songExists + then set item colorForeground $ mpData ^. mpColors . playlistSelectedForeground + else set item colorForeground $ mpData ^. mpColors . playlistFileForeground + + Nothing -> do + set item text Nothing + set item itemData Nothing + +viewSongs :: TextListView String -> TextItem String -> Attribute [String] -> Attribute PlaylistView -> Attribute Int -> UIApp' () +viewSongs textListView item content playlistState savedPos = do + writeAttr playlistState PlaylistViewSongs + pos <- textListViewGetPos textListView + writeAttr savedPos pos + + dir <- liftIO playlistDirFilePath + file <- get item text + c <- case file of + Just f -> songListRead (dir f) + Nothing -> return [] + writeAttr content ((dir "..") : c) + textListViewReset textListView + +viewPlaylist :: TextListView String -> Attribute [String] -> Attribute PlaylistView -> Attribute Int -> UIApp' () +viewPlaylist textListView content playlistState savedPos = do + writeAttr playlistState PlaylistViewPlaylist + f <- fileList + writeAttr content f + pos <- readAttr savedPos + textListViewCenterAt textListView pos (length f) diff --git a/src/Mp/UI/PlaylistState.hs b/src/Mp/UI/PlaylistState.hs deleted file mode 100644 --- a/src/Mp/UI/PlaylistState.hs +++ /dev/null @@ -1,73 +0,0 @@ -{- - * 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/QuestionBar.hs b/src/Mp/UI/QuestionBar.hs new file mode 100644 --- /dev/null +++ b/src/Mp/UI/QuestionBar.hs @@ -0,0 +1,104 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2016 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 QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Mp.UI.QuestionBar ( + YesNo (..), + questionBarNew, + castToQuestionBar, + answer +) where + +import Control.Lens (makeLensesFor, (.=)) +import qualified Graphics.Vty as Vty +import Simple.Locale.TranslateTH +import Simple.UI.All + +import Mp.Locale.TranslateFile () +import Mp.UI.MpData + +data YesNo = Yes + | No + deriving Eq + +data QuestionBar = QuestionBar + { _questionBarParent :: Label + , _questionBarAnswer :: Attribute YesNo + } + +makeLensesFor [("_questionBarParent", "questionBarParent")] ''QuestionBar + +class QuestionBarClass w where + castToQuestionBar :: w -> QuestionBar + + answer :: w -> Attribute YesNo + answer = _questionBarAnswer . castToQuestionBar + +instance QuestionBarClass QuestionBar where + castToQuestionBar = id + +instance TextClass QuestionBar where + castToText = castToText . _questionBarParent + +instance WidgetClass QuestionBar where + castToWidget = castToWidget . _questionBarParent + + overrideWidget = overrideWidgetHelper questionBarParent + +questionBarNew :: UIApp MpData QuestionBar +questionBarNew = do + mpData <- view appUserData + + label <- labelNew $ Just ([tr|File exists. Overwrite ?|] ++ " (y/n)") + + noAnswer <- attributeNew No + let questionBar = overrideWidget + QuestionBar { _questionBarParent = label + , _questionBarAnswer = noAnswer + } + $ virtualWidgetName .= "questionbar" + + on_ questionBar keyPressed $ \key _ -> + case key of + Vty.KChar 'y' -> do + set questionBar answer Yes + mainLoopQuit + + Vty.KChar 'Y' -> do + set questionBar answer Yes + mainLoopQuit + + Vty.KChar 'n' -> do + set questionBar answer No + mainLoopQuit + + Vty.KChar 'N' -> do + set questionBar answer No + mainLoopQuit + + _ -> return () + + set questionBar colorForeground $ mpData ^. mpColors . editForeground + set questionBar colorBackground $ mpData ^. mpColors . editBackground + + return questionBar diff --git a/src/Mp/UI/QueuePage.hs b/src/Mp/UI/QueuePage.hs --- a/src/Mp/UI/QueuePage.hs +++ b/src/Mp/UI/QueuePage.hs @@ -1,7 +1,7 @@ -{- +{- * Programmer: Piotr Borek * E-mail: piotrborek@op.pl - * Copyright 2014 Piotr Borek + * Copyright 2018 Piotr Borek * * Distributed under the terms of the GPL (GNU Public License) * @@ -19,202 +19,156 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} +{-# LANGUAGE TemplateHaskell #-} module Mp.UI.QueuePage ( - QueuePage (..), - QueuePageWidget, - AddToFunction, - RemoveFromFunction, - makeUIQueuePage + QueuePageClass, + QueuePage, + castToQueuePage, + queuePageNew ) 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 +import Control.Lens (ix, makeLensesFor, (.=), (^.), (^?)) +import Control.Monad +import qualified Graphics.Vty as Vty +import Simple.UI.All - lst <- newList (queueActiveAttribute conf) 1 - >>= withQueueBgAttribute conf +import Mp.Player.Client +import Mp.UI.MpData +import Mp.Utils.Utils - _ <- addToFocusGroup fg lst - _ <- addToFocusGroup fg lst +data QueuePage = QueuePage + { _queuePageParent :: Widget + , _queuePageSongIndex :: Attribute Int + } - empty <- plainText $ T.pack "" - playingItem <- newMVar empty +makeLensesFor [("_queuePageParent", "queuePageParent")] ''QueuePage - let keyHandler = \_ k _ -> - case k of - KASCII '>' -> do - clientSendPlayNext - centerList lst - return True +class QueuePageClass w where + castToQueuePage :: w -> QueuePage - KASCII '<' -> do - clientSendPlayPrev - centerList lst - return True +instance QueuePageClass QueuePage where + castToQueuePage = id - KASCII 'c' -> do - clearList lst - clientSendClear - return True +instance WidgetClass QueuePage where + castToWidget = _queuePageParent - KASCII 'l' -> do - centerList lst - return True + overrideWidget = overrideWidgetHelper queuePageParent - KASCII 'd' -> do - maybeSel <- getSelected lst - when (isJust maybeSel) $ do - let (index, _) = fromJust maybeSel - rmFromList2 lst index - return True +queuePageNew :: UIApp MpData QueuePage +queuePageNew = do + mpData <- view appUserData + songIndex <- attributeNew (-1 :: Int) - KASCII 's' -> do - clientSendStopPlaying - return True + textListView <- textListViewNew $ \item index -> do + files <- readAttr (mpData ^. mpSongList) + i <- readAttr songIndex + case files ^? ix index of + Just song -> do + let (_, s) = separateFilePath song + set item text $ Just s + set item itemData $ Just index + if i == index + then do + set item colorForeground $ mpData ^. mpColors . queueSelectedForeground + set item colorStyle DrawStyleBold + else do + set item colorForeground $ mpData ^. mpColors . queueForeground + set item colorStyle DrawStyleNormal + Nothing -> do + set item text Nothing + set item itemData Nothing - KASCII 'r' -> do - clientSendToggleRepeat - return True + let queue = overrideWidget + QueuePage { _queuePageParent = castToWidget textListView + , _queuePageSongIndex = songIndex + } + $ virtualWidgetName .= "queuepage" - KASCII 'z' -> do - clientSendToggleShuffle - return True + set queue colorForeground $ mpData ^. mpColors . queueForeground + set queue colorBackground $ mpData ^. mpColors . queueBackground + set queue colorBackgroundSelected $ mpData ^. mpColors . queueActiveBackground - KASCII 'p' -> do - stat <- statusBarServerStatus status - case stat of - "Paused" -> do - clientSendResumePlaying - return True + on_ textListView textItemActivated $ \item -> do + maybeIndex <- get item itemData + forM_ maybeIndex (catchIgnoreAll . clientSendSetPlaying) - "Playing" -> do - clientSendPausePlaying - return True + getColors queue >>= setColors textListView - _ -> return True + on_ queue keyPressed $ \key _ -> + case key of + Vty.KChar 'p' -> catchIgnoreAll $ do + (status, _, _) <- clientSendGetStatus + case status of + "Paused" -> clientSendResumePlaying + "Playing" -> clientSendPausePlaying + _ -> error "QueuePage.hs:105: Internal error." - KASCII 'f' -> do - clientSendSeekForward - return True + Vty.KChar 's' -> + catchIgnoreAll clientSendStopPlaying - KASCII 'b' -> do - clientSendSeekBackward - return True + Vty.KChar 'c' -> + catchIgnoreAll $ do + clientSendClear + liftUIApp mpData $ readFullStatusFromServer queue - KEnter -> do - maybeSel <- getSelected lst - when (isJust maybeSel) $ do - let (index, _) = fromJust maybeSel - clientSendSetPlaying index - centerList lst - return True + Vty.KChar 'l' -> + centerQueue mpData textListView - _ -> return False + Vty.KChar '>' -> do + catchIgnoreAll clientSendPlayNext + centerQueue mpData textListView - lst `onKeyPressed` keyHandler - scheduleReceiveFromServer lst playingItem - _ <- scheduleStatusFromServer lst playingItem + Vty.KChar '<' -> do + catchIgnoreAll clientSendPlayPrev + centerQueue mpData textListView - 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) + Vty.KChar 'f' -> + catchIgnoreAll clientSendSeekForward - addFileAndSend list dir file = do - addFileToList list dir file + Vty.KChar 'b' -> + catchIgnoreAll clientSendSeekBackward - clientSendAddFile $ dir file + Vty.KChar 'r' -> + catchIgnoreAll clientSendToggleRepeat - getList widget = do - size <- getListSize widget + Vty.KChar 'z' -> + catchIgnoreAll clientSendToggleShuffle - items <- forM [0 .. (size - 1)] $ \i -> do - maybeItem <- getListItem widget i - let (value, _) = fromJust maybeItem - return value - return items + Vty.KChar '[' -> + catchIgnoreAll clientSendVolumeDown - 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 + Vty.KChar ']' -> + catchIgnoreAll clientSendVolumeUp - rmFromList2 list index = do - _ <- removeFromList list index - clientSendRemove index + Vty.KChar 'd' -> do + viewIndex <- textListViewGetPos textListView + when (viewIndex >= 0) $ do + files <- readAttr (mpData ^. mpSongList) + void $ liftUIApp mpData $ mpSongRemove (files !! viewIndex) + clientSendRemove viewIndex + textListViewUpdate textListView - rmFromList list dir file = do - indexes <- listFindAll list $ dir file - when (not $ null indexes) $ rmFromList2 list $ last indexes + _ -> + return () - centerList widget = do - index <- clientSendGetPlaying - centerListAt widget index + readFullStatusFromServer queue + scheduleIndexFromServer queue - 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 + return queue + where + readFullStatusFromServer queuePage = catchIgnoreAll $ do + items <- clientSendGetPlaylist + index <- clientSendGetPlaying + set queuePage _queuePageSongIndex index + mpSongInit items - receiveFromServer list playingItem = do - items <- clientSendGetPlaylist + scheduleIndexFromServer queuePage = mainScheduleRepeat 200 $ + catchIgnoreAll $ do 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 + set queuePage _queuePageSongIndex index - scheduleStatusFromServer list playingItem = forkIO $ forever $ do - threadDelay 100000 - schedule $ do - success <- try' $ clientSendGetPlaying - when (isJust success) $ selectItem list playingItem $ fromJust success + centerQueue mpData textListView = catchIgnoreAll $ do + files <- readAttr (mpData ^. mpSongList) + index <- clientSendGetPlaying + textListViewCenterAt textListView index (length files) diff --git a/src/Mp/UI/SongList.hs b/src/Mp/UI/SongList.hs new file mode 100644 --- /dev/null +++ b/src/Mp/UI/SongList.hs @@ -0,0 +1,62 @@ +{- + * 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.SongList ( + songListRead, + songListWrite +) where + +import Control.Monad.Catch +import Control.Monad.IO.Class +import Data.Binary + +newtype SongList = SongList { + songListGet :: [String] +} + +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 = SongList <$> get + +songListRead :: MonadIO m => String -> m [String] +songListRead file = liftIO $ + catchAll + (songListGet <$> decodeFile file) + (\_ -> return []) + +songListWrite :: MonadIO m => String -> [String] -> m () +songListWrite fileName list = + liftIO . encodeFile fileName $ SongList list diff --git a/src/Mp/UI/StatusBar.hs b/src/Mp/UI/StatusBar.hs deleted file mode 100644 --- a/src/Mp/UI/StatusBar.hs +++ /dev/null @@ -1,106 +0,0 @@ -{- - * 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 deleted file mode 100644 --- a/src/Mp/Utils/Colors.hs +++ /dev/null @@ -1,184 +0,0 @@ -{- - * 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 deleted file mode 100644 --- a/src/Mp/Utils/Exception.hs +++ /dev/null @@ -1,31 +0,0 @@ -{- - * 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 deleted file mode 100644 --- a/src/Mp/Utils/I18N.hs +++ /dev/null @@ -1,29 +0,0 @@ -{- - * 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 --- a/src/Mp/Utils/Network.hs +++ b/src/Mp/Utils/Network.hs @@ -1,4 +1,4 @@ -{- +{- * Programmer: Piotr Borek * E-mail: piotrborek@op.pl * Copyright 2014 Piotr Borek @@ -20,19 +20,39 @@ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} -module Mp.Utils.Network where +module Mp.Utils.Network ( + sendString, + recvString, + recvString_, + recvString', + recvString_', + -- reexport + Socket +) where +import Control.Monad +import Control.Monad.Trans + +import Data.ByteString.UTF8 (fromString, toString) + 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 +sendString :: MonadIO m => Socket -> String -> m () +sendString sock msg = liftIO $ sendAll sock $ fromString msg -recvString_ :: Socket -> IO () -recvString_ sock = recvString sock >> return () +recvString :: MonadIO m => Socket -> Int -> m String +recvString sock size = liftIO receive + where + receive = do + rval <- recv sock size + return $ toString rval -sendString :: Socket -> String -> IO () -sendString sock msg = sendAll sock $ fromString msg +recvString_ :: MonadIO m => Socket -> Int -> m () +recvString_ sock size = liftIO $ void $ recvString sock size + +recvString' :: MonadIO m => Socket -> m String +recvString' conn = recvString conn 4096 + +recvString_' :: MonadIO m => Socket -> m () +recvString_' conn = recvString_ conn 4096 diff --git a/src/Mp/Utils/Utils.hs b/src/Mp/Utils/Utils.hs --- a/src/Mp/Utils/Utils.hs +++ b/src/Mp/Utils/Utils.hs @@ -1,4 +1,4 @@ -{- +{- * Programmer: Piotr Borek * E-mail: piotrborek@op.pl * Copyright 2014 Piotr Borek @@ -22,28 +22,29 @@ module Mp.Utils.Utils where -import Graphics.Vty -import Control.Monad +import Control.Monad +import Control.Monad.Catch +import Graphics.Vty -toVtyColor :: String -> (Color, Style) +toVtyColor :: String -> Color 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) + "black" -> black + "white" -> white + "cyan" -> cyan + "magenta" -> magenta + "blue" -> blue + "yellow" -> yellow + "green" -> green + "red" -> red + "brightBlack" -> brightBlack + "brightYellow" -> brightYellow + "brightGreen" -> brightGreen + "brightRed" -> brightRed + "brightBlue" -> brightBlue + "brightWhite" -> brightWhite + "brightMagenta" -> brightMagenta + "brightCyan" -> brightCyan + _ -> black whenM :: Monad m => m Bool -> m () -> m () whenM cond action = do @@ -54,19 +55,19 @@ timeToString time = let h = time `div` 3600 m = show $ (time `div` 60) `mod` 60 - m' = if (length m < 2) then "0" ++ m + m' = if length m < 2 then "0" ++ m else m s = show $ time `mod` 60 - s' = if (length s < 2) then "0" ++ s + s' = if length s < 2 then "0" ++ s else s in if h == 0 then m ++ ":" ++ s' - else (show h) ++ ":" ++ 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)) + in (reverse $ tail d, reverse f) -removeAt :: Int -> [a] -> [a] -removeAt index list = take index list ++ drop (succ index) list +catchIgnoreAll :: MonadCatch m => m () -> m () +catchIgnoreAll action = catchAll action (const $ return ()) diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,16 @@ +resolver: lts-9.21 +packages: +- '.' +extra-deps: +- gi-gst-1.0.15 +- gi-glib-2.0.16 +- gi-gobject-2.0.16 +- haskell-gi-0.21.0 +- haskell-gi-base-0.21.0 +- haskell-gi-overloading-0.0 +- daemons-0.2.1 +- clock-0.7.2 +- simple-ui-0.1.1 +flags: {} +extra-package-dbs: [] +allow-newer: true