diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/mp.cabal b/mp.cabal --- a/mp.cabal +++ b/mp.cabal @@ -1,5 +1,5 @@ name: mp -version: 1.0.2 +version: 1.1.0 cabal-version: >=1.22 build-type: Simple author: Piotr Borek @@ -18,7 +18,7 @@ hs-source-dirs: src main-is: Main.hs default-language: Haskell2010 - ghc-options: -Wall -threaded + ghc-options: -Wall -threaded -fprof-auto -fprof-cafs default-extensions: CPP FlexibleInstances @@ -36,20 +36,21 @@ mtl (>= 2.2 && < 2.3), random (>= 1.1 && < 1.2), binary (>= 0.8 && < 0.9), - network (>= 2.6 && < 2.7), + network (>= 2.6 && < 2.9), directory (>= 1.3 && < 1.4), 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), + resourcet (>= 1.1 && < 1.3), + exceptions (>= 0.8 && < 0.11), 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), - template-haskell (>= 2.11 && < 2.14), + vty (>= 5.16 && < 5.26), + lens (>= 4.15 && < 4.18), + containers (>= 0.5 && < 0.7), + template-haskell (>= 2.11 && < 2.15), + unix (>= 2.7 && < 2.8), simple-ui == 0.1.* other-modules: @@ -71,6 +72,7 @@ Mp.Player.Client Mp.Player.Daemon Mp.Player.GstPlayer + Mp.Player.PlaySong Mp.Player.Server Mp.Player.ServerState Mp.Utils.Network diff --git a/src/Mp/Player/PlaySong.hs b/src/Mp/Player/PlaySong.hs new file mode 100644 --- /dev/null +++ b/src/Mp/Player/PlaySong.hs @@ -0,0 +1,32 @@ +{- + * Programmer: Piotr Borek + * E-mail: piotrborek@op.pl + * Copyright 2019 Piotr Borek + * + * Distributed under the terms of the GPL (GNU Public License) + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module Mp.Player.PlaySong where + +data PlaySong = PlaySongNext + | PlaySongPrevious + | PlaySongIndex Int + +playSongNextIndex :: PlaySong -> Int -> Int +playSongNextIndex PlaySongNext index = succ index +playSongNextIndex PlaySongPrevious index = pred index +playSongNextIndex (PlaySongIndex newIndex) _ = newIndex diff --git a/src/Mp/Player/Server.hs b/src/Mp/Player/Server.hs --- a/src/Mp/Player/Server.hs +++ b/src/Mp/Player/Server.hs @@ -28,6 +28,7 @@ import qualified Control.Monad.State as State import qualified Data.Text as T import qualified GI.Gst as G +import qualified System.Posix.Signals as Posix import Control.Concurrent import Control.Concurrent.Async @@ -46,6 +47,8 @@ import Mp.Configuration.Configuration import Mp.Player.GstPlayer import Mp.Player.ServerState +import Mp.Player.PlaySong +import Mp.Player.Client (clientSendQuitMessage) import Mp.Utils.Network import Mp.Utils.Shuffle @@ -71,8 +74,21 @@ cfgDir <- configDirFilePath encodeFile (cfgDir "server.index") (PlayingIndex index) -startServerBlocking :: MonadResource m => String -> m () +unixSignalHandler :: Posix.Handler +unixSignalHandler = Posix.Catch $ clientSendQuitMessage + +installSigTerm :: MonadIO m => m () +installSigTerm = liftIO $ + void $ Posix.installHandler Posix.sigTERM unixSignalHandler Nothing + +installSigKill :: MonadIO m => m () +installSigKill = liftIO $ + void $ Posix.installHandler Posix.sigKILL unixSignalHandler Nothing + +startServerBlocking :: (MonadResource m, MonadThrow m) => String -> m () startServerBlocking socName = do + installSigTerm + installSigKill player <- initGstPlayer @@ -86,10 +102,21 @@ gstBusAddWatch player $ \_ message -> do 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 + incrementErrorCounter serverState + st <- readMVar serverState + if errorCounter st > 25 + then do + playerStop serverState player + else + case lastOperation st of + PlaySongNext -> playerPlay serverState player PlaySongNext + PlaySongPrevious -> playerPlay serverState player PlaySongPrevious + PlaySongIndex _ -> playerPlay serverState player PlaySongNext + when (G.MessageTypeEos `elem` messageType) $ do + resetErrorCounter serverState + playerPlay serverState player PlaySongNext return True gstPlayerMainLoopBlocking player @@ -144,6 +171,20 @@ } return True +incrementErrorCounter :: MonadIO m => MVar ServerState -> m () +incrementErrorCounter serverState = liftIO $ + modifyMVar_ serverState $ \st -> + return st { + errorCounter = succ $ errorCounter st + } + +resetErrorCounter :: MonadIO m => MVar ServerState -> m () +resetErrorCounter serverState = liftIO $ + modifyMVar_ serverState $ \st -> + return st { + errorCounter = 0 + } + modifyPlayerStop :: ServerState -> GstPlayer -> IO ServerState modifyPlayerStop st player = do saveServerIndex 0 @@ -155,8 +196,8 @@ getStatus = "Stopped" } -modifyPlayerPlay :: ServerState -> GstPlayer -> Int -> IO ServerState -modifyPlayerPlay st player index = do +modifyPlayerPlay :: ServerState -> GstPlayer -> Int -> PlaySong -> IO ServerState +modifyPlayerPlay st player index playSongOperation = do saveServerIndex index let list = getPlaylist st let (f, d) = if isShuffleMode st then @@ -168,27 +209,33 @@ getPlaying = index, getStatus = "Playing", shuffleFunc = f, - shuffleData = d + shuffleData = d, + lastOperation = playSongOperation } -playerPlay :: MonadIO m => MVar ServerState -> GstPlayer -> (Int -> Int) -> m () -playerPlay serverState player indexFunction = liftIO $ +playerPlay :: MonadIO m => MVar ServerState -> GstPlayer -> PlaySong -> m () +playerPlay serverState player playSongOperation = liftIO $ modifyMVar_ serverState $ \st -> do let list = getPlaylist st - let index = indexFunction $ getPlaying st + let index = playSongNextIndex playSongOperation $ getPlaying st if index >= 0 && index < length list then - modifyPlayerPlay st player index + modifyPlayerPlay st player index playSongOperation 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 + | index < 0 -> modifyPlayerPlay st player (length list - 1) playSongOperation + | index >= length list -> modifyPlayerPlay st player 0 playSongOperation else modifyPlayerStop st player +playerStop :: MonadIO m => MVar ServerState -> GstPlayer -> m () +playerStop serverState player = liftIO $ do + resetErrorCounter serverState + modifyMVar_ serverState $ flip modifyPlayerStop player + talkBlocking :: MVar ServerState -> GstPlayer -> Socket -> IO () talkBlocking serverState player sock = processMessages `finally` shutdownServer @@ -269,12 +316,13 @@ index <- recvString' conn sendString conn "OK" + resetErrorCounter serverState st <- liftIO $ readMVar serverState if isShuffleMode st then - playerPlay serverState player $ const 0 + playerPlay serverState player $ PlaySongIndex 0 else - playerPlay serverState player $ const (read index :: Int) + playerPlay serverState player $ PlaySongIndex (read index :: Int) talkGetPlay :: MonadIO m => MVar ServerState -> Socket -> m () talkGetPlay serverState conn = do @@ -310,21 +358,25 @@ let (_, d) = State.runState shuffleRemove $ shuffleData st liftIO $ putMVar serverState $ update index playing d st - when (shuffleEnabled || playing == index) $ playerPlay serverState player id + if shuffleEnabled + then + playerPlay serverState player (PlaySongIndex 0) + else + when (playing == index) $ playerPlay serverState player (PlaySongIndex index) - where - update index playing d st - | index < playing = - st { - getPlaying = pred playing, - getPlaylist = removeAt index $ getPlaylist st, - shuffleData = d - } - | otherwise = - st { - getPlaylist = removeAt index $ getPlaylist st, - shuffleData = d - } + where + update index playing d st + | index < playing = + st { + getPlaying = pred playing, + getPlaylist = removeAt index $ getPlaylist st, + shuffleData = d + } + | otherwise = + st { + getPlaylist = removeAt index $ getPlaylist st, + shuffleData = d + } talkClear :: MonadIO m => MVar ServerState -> GstPlayer -> Socket -> m () talkClear serverState player conn = do @@ -335,7 +387,7 @@ talkStop :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m () talkStop serverState conn player = do sendString conn "OK" - liftIO $ modifyMVar_ serverState $ flip modifyPlayerStop player + liftIO $ playerStop serverState player talkPause :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m () talkPause serverState conn player = do @@ -358,31 +410,14 @@ talkNext :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m () talkNext serverState conn player = do sendString conn "OK" - st <- liftIO $ takeMVar serverState - let status = getStatus st - let index = succ $ getPlaying st - let len = length $ getPlaylist st - let rpt = isRepeatMode st - liftIO $ putMVar serverState st - - if rpt then - when (status == "Playing") $ playerPlay serverState player succ - else - when (status == "Playing" && index < len) $ playerPlay serverState player succ + resetErrorCounter serverState + playerPlay serverState player PlaySongNext talkPrev :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m () talkPrev serverState conn player = do sendString conn "OK" - st <- liftIO $ takeMVar serverState - let status = getStatus st - let index = pred $ getPlaying st - let rpt = isRepeatMode st - liftIO $ putMVar serverState st - - if rpt then - when (status == "Playing") $ playerPlay serverState player pred - else - when (status == "Playing" && index >= 0) $ playerPlay serverState player pred + resetErrorCounter serverState + playerPlay serverState player PlaySongPrevious talkVolumeUp :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m () talkVolumeUp serverState conn player = do @@ -455,7 +490,7 @@ newSt <- enableShuffle st return (newSt, getStatus st == "Playing") - when shuffleEnabled $ playerPlay serverState player id + when shuffleEnabled $ playerPlay serverState player (PlaySongIndex 0) disableShuffle :: MonadIO m => ServerState -> m ServerState disableShuffle st = diff --git a/src/Mp/Player/ServerState.hs b/src/Mp/Player/ServerState.hs --- a/src/Mp/Player/ServerState.hs +++ b/src/Mp/Player/ServerState.hs @@ -29,6 +29,7 @@ import System.Random import Mp.Utils.Shuffle +import Mp.Player.PlaySong data PlayingIndex = PlayingIndex Int @@ -43,7 +44,9 @@ isShuffleMode :: !Bool, randomInitializer :: !Int, shuffleFunc :: Int -> Int, - shuffleData :: !ShuffleData + shuffleData :: !ShuffleData, + errorCounter :: !Int, + lastOperation :: !PlaySong } instance Binary PlayingIndex where @@ -120,7 +123,9 @@ isShuffleMode = shuffleMode, randomInitializer = r, shuffleFunc = f, - shuffleData = d + shuffleData = d, + errorCounter = 0, + lastOperation = PlaySongNext } getVersion1 = do @@ -144,7 +149,9 @@ isShuffleMode = shuffleMode, randomInitializer = r, shuffleFunc = f, - shuffleData = d + shuffleData = d, + errorCounter = 0, + lastOperation = PlaySongNext } defaultServerState :: ServerState @@ -159,7 +166,9 @@ isShuffleMode = False, randomInitializer = 0, shuffleFunc = id, - shuffleData = shuffleInitial $ mkStdGen 0 + shuffleData = shuffleInitial $ mkStdGen 0, + errorCounter = 0, + lastOperation = PlaySongNext } readStateFromFile :: String -> IO ServerState diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-9.21 +resolver: lts-13.18 packages: - '.' extra-deps: @@ -10,7 +10,8 @@ - haskell-gi-overloading-0.0 - daemons-0.2.1 - clock-0.7.2 -- simple-ui-0.1.1 +- simple-ui-0.1.2 +- ConfigFile-1.1.4 flags: {} extra-package-dbs: [] allow-newer: true