mp 0.2.2 → 1.0.0
raw patch · 36 files changed
+2052/−2254 lines, 36 filesdep +asyncdep +containersdep +data-default-classdep −bytestringdep −glibdep −gstreamerdep ~MissingHdep ~basedep ~binarysetup-changed
Dependencies added: async, containers, data-default-class, deepseq, exceptions, gi-glib, gi-gobject, gi-gst, haskell-gi-base, haskell-gi-overloading, lens, resourcet, simple-ui, stm, template-haskell, transformers, transformers-base, vector
Dependencies removed: bytestring, glib, gstreamer, hgettext, setlocale, unordered-containers, vty-ui
Dependency ranges changed: MissingH, base, binary, directory, filepath, mtl, random, text, unix, utf8-string, vty
Files
- Setup.hs +0/−1
- gen_gettext +0/−27
- i18n/messages.pot +0/−183
- i18n/pl.po +0/−182
- i18n/pl/LC_MESSAGES/mp.mo binary
- mp.cabal +72/−43
- src/Main.hs +81/−0
- src/Mp/Configuration/AppColors.hs +100/−0
- src/Mp/Configuration/Configuration.hs +10/−13
- src/Mp/Locale/TranslateFile.hs +240/−0
- src/Mp/Main.hs +0/−59
- src/Mp/Player/Client.hs +46/−41
- src/Mp/Player/Daemon.hs +35/−13
- src/Mp/Player/GstPlayer.hs +111/−87
- src/Mp/Player/Server.hs +220/−207
- src/Mp/Player/ServerState.hs +4/−4
- src/Mp/UI/BrowserPage.hs +143/−171
- src/Mp/UI/EditBar.hs +86/−30
- src/Mp/UI/HelpPage.hs +52/−121
- src/Mp/UI/Main.hs +56/−167
- src/Mp/UI/MainMenuBar.hs +80/−0
- src/Mp/UI/MainStatusBar.hs +69/−0
- src/Mp/UI/Menu.hs +0/−68
- src/Mp/UI/MpData.hs +97/−0
- src/Mp/UI/PlaylistPage.hs +190/−211
- src/Mp/UI/PlaylistState.hs +0/−73
- src/Mp/UI/QuestionBar.hs +104/−0
- src/Mp/UI/QueuePage.hs +119/−165
- src/Mp/UI/SongList.hs +62/−0
- src/Mp/UI/StatusBar.hs +0/−106
- src/Mp/Utils/Colors.hs +0/−184
- src/Mp/Utils/Exception.hs +0/−31
- src/Mp/Utils/I18N.hs +0/−29
- src/Mp/Utils/Network.hs +31/−11
- src/Mp/Utils/Utils.hs +28/−27
- stack.yaml +16/−0
Setup.hs view
@@ -1,3 +1,2 @@ import Distribution.Simple- main = defaultMain
− gen_gettext
@@ -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
− i18n/messages.pot
@@ -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 <EMAIL@ADDRESS>\n"-"Language-Team: LANGUAGE <LL@li.org>\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 ""-
− i18n/pl.po
@@ -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 <piotrborek@op.pl>\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"
− i18n/pl/LC_MESSAGES/mp.mo
binary file changed (2941 → absent bytes)
mp.cabal view
@@ -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 <piotrborek@op.pl> maintainer: Piotr Borek <piotrborek@op.pl>-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
+ src/Main.hs view
@@ -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."
+ src/Mp/Configuration/AppColors.hs view
@@ -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"+ }
src/Mp/Configuration/Configuration.hs view
@@ -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
+ src/Mp/Locale/TranslateFile.hs view
@@ -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
− src/Mp/Main.hs
@@ -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
src/Mp/Player/Client.hs view
@@ -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"
src/Mp/Player/Daemon.hs view
@@ -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
src/Mp/Player/GstPlayer.hs view
@@ -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
src/Mp/Player/Server.hs view
@@ -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,
src/Mp/Player/ServerState.hs view
@@ -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)
src/Mp/UI/BrowserPage.hs view
@@ -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
src/Mp/UI/EditBar.hs view
@@ -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
src/Mp/UI/HelpPage.hs view
@@ -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|]+ ]
src/Mp/UI/Main.hs view
@@ -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
+ src/Mp/UI/MainMenuBar.hs view
@@ -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
+ src/Mp/UI/MainStatusBar.hs view
@@ -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+ )
− src/Mp/UI/Menu.hs
@@ -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- }
+ src/Mp/UI/MpData.hs view
@@ -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
src/Mp/UI/PlaylistPage.hs view
@@ -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)
− src/Mp/UI/PlaylistState.hs
@@ -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
+ src/Mp/UI/QuestionBar.hs view
@@ -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
src/Mp/UI/QueuePage.hs view
@@ -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)
+ src/Mp/UI/SongList.hs view
@@ -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
− src/Mp/UI/StatusBar.hs
@@ -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"
− src/Mp/Utils/Colors.hs
@@ -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
− src/Mp/Utils/Exception.hs
@@ -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
− src/Mp/Utils/I18N.hs
@@ -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
src/Mp/Utils/Network.hs view
@@ -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
src/Mp/Utils/Utils.hs view
@@ -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 ())
+ stack.yaml view
@@ -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