mp-1.0.0: src/Mp/Player/Server.hs
{-
* 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 MultiWayIf #-}
module Mp.Player.Server (
startServerBlocking
) where
import qualified Control.Monad.State as State
import qualified Data.Text as T
import qualified GI.Gst as G
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.Player.ServerState
import Mp.Utils.Network
import Mp.Utils.Shuffle
makeServerSocket :: MonadResource m => String -> m (ReleaseKey, Socket)
makeServerSocket socName = do
(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 :: MonadIO m => MVar ServerState -> m ()
saveServerState serverState = liftIO $ do
cfgDir <- configDirFilePath
state <- readMVar serverState
encodeFile (cfgDir </> "server.state") state
saveServerIndex :: MonadIO m => Int -> m ()
saveServerIndex index = liftIO $ do
cfgDir <- configDirFilePath
encodeFile (cfgDir </> "server.index") (PlayingIndex index)
startServerBlocking :: MonadResource m => String -> m ()
startServerBlocking socName = do
player <- initGstPlayer
serverState <- readServerState player
schedulePlayerInfo player serverState
(sockKey, sock) <- makeServerSocket socName
server <- liftIO $ async $ talkBlocking serverState player sock
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
return True
gstPlayerMainLoopBlocking player
liftIO $ wait server
release sockKey
where
readServerState player = liftIO $ do
cfgDir <- configDirFilePath
let file0 = cfgDir </> "server.state"
let file1 = cfgDir </> "server.index"
state0 <- readStateFromFile file0 :: IO ServerState
(PlayingIndex index) <- readIndexFromFile file1 :: IO PlayingIndex
let state = state0 {
getPlaying = index
}
stateVar <- newMVar state
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
modifyMVar_ serverState $ \st ->
return st {
getCurrentPosition = 0,
getCurrentDuration = 0
}
return True
modifyPlayerStop :: ServerState -> GstPlayer -> IO ServerState
modifyPlayerStop st player = do
saveServerIndex 0
gstPlayerStop player
return st {
getCurrentPosition = 0,
getCurrentDuration = 0,
getPlaying = -1,
getStatus = "Stopped"
}
modifyPlayerPlay :: ServerState -> GstPlayer -> Int -> IO ServerState
modifyPlayerPlay st player index = do
saveServerIndex index
let list = getPlaylist st
let (f, d) = if isShuffleMode st then
State.runState shuffleFunction $ shuffleData st
else
(id, shuffleData st)
gstPlayerPlay player $ list !! f index
return st {
getPlaying = index,
getStatus = "Playing",
shuffleFunc = f,
shuffleData = d
}
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 =
processMessages `finally` shutdownServer
where
shutdownServer = do
gstPlayerStop player
gstPlayerQuit player
processMessages = do
(conn, _ ) <- accept sock
msg <- talkServer conn `finally` close conn
when (msg /= "Quit") processMessages
talkServer conn = do
msg <- liftIO $ recvString' conn
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"
liftIO $ saveServerState serverState
talkGetPlaylist :: MonadIO m => MVar ServerState -> Socket -> m ()
talkGetPlaylist serverState conn = do
list <- liftIO $ readMVar serverState
forM_ (reverse $ getPlaylist list) $ \item -> do
sendString conn item
recvString_' conn
sendString conn "EndPlaylist"
talkGetStatus :: MonadIO m => MVar ServerState -> Socket -> m ()
talkGetStatus serverState conn = do
st <- liftIO $ readMVar serverState
let status = getStatus st
sendString conn status
recvString_' conn
let dur = getCurrentDuration st
sendString conn $ show dur
recvString_' conn
let pos = getCurrentPosition st
sendString conn $ show pos
talkSetPlay :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m ()
talkSetPlay serverState conn player = do
sendString conn "OK"
index <- recvString' conn
sendString conn "OK"
st <- liftIO $ readMVar serverState
if isShuffleMode st
then
playerPlay serverState player $ const 0
else
playerPlay serverState player $ const (read index :: Int)
talkGetPlay :: MonadIO m => MVar ServerState -> Socket -> m ()
talkGetPlay serverState conn = do
st <- liftIO $ readMVar serverState
if getStatus st == "Stopped" then
sendString conn "-1"
else
sendString conn $ show $ shuffleFunc st $ getPlaying st
talkAdd :: MonadIO m => MVar ServerState -> Socket -> m ()
talkAdd serverState conn = do
sendString conn "OK"
file <- recvString' conn
sendString conn "OK"
liftIO $ modifyMVar_ serverState $ \st -> do
let (_, d) = State.runState shuffleAdd $ shuffleData st
return st {
getPlaylist = getPlaylist st ++ [file],
shuffleData = d
}
talkRemove :: MonadIO m => MVar ServerState -> GstPlayer -> Socket -> m ()
talkRemove serverState player conn = do
sendString conn "OK"
sIndex <- recvString' conn
sendString conn "OK"
st <- liftIO $ takeMVar serverState
let shuffleEnabled = isShuffleMode st
let playing = getPlaying st
let index = read sIndex :: Int
let (_, d) = State.runState shuffleRemove $ shuffleData st
liftIO $ putMVar serverState $ update index playing d st
when (shuffleEnabled || playing == index) $ playerPlay serverState player id
where
update index playing d st
| index < playing =
st {
getPlaying = pred playing,
getPlaylist = removeAt index $ getPlaylist st,
shuffleData = d
}
| otherwise =
st {
getPlaylist = removeAt index $ getPlaylist st,
shuffleData = d
}
talkClear :: MonadIO m => MVar ServerState -> GstPlayer -> Socket -> m ()
talkClear serverState player conn = do
sendString conn "OK"
liftIO $ gstPlayerStop player
liftIO $ modifyMVar_ serverState (const $ return defaultServerState)
talkStop :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m ()
talkStop serverState conn player = do
sendString conn "OK"
liftIO $ modifyMVar_ serverState $ flip modifyPlayerStop player
talkPause :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m ()
talkPause serverState conn player = do
sendString conn "OK"
liftIO $ modifyMVar_ serverState $ \st -> do
gstPlayerPause player
return st {
getStatus = "Paused"
}
talkResume :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m ()
talkResume serverState conn player = do
sendString conn "OK"
liftIO $ modifyMVar_ serverState $ \st -> do
gstPlayerResume player
return st {
getStatus = "Playing"
}
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
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
talkVolumeUp :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m ()
talkVolumeUp serverState conn player = do
sendString conn "OK"
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 :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m ()
talkVolumeDown serverState conn player = do
sendString conn "OK"
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 :: MonadIO m => MVar ServerState -> Socket -> m ()
talkVolumeGet serverState conn = do
st <- liftIO $ readMVar serverState
let vol = ceiling $ getVolume st * 100 :: Int
sendString conn $ show vol
talkSeekForward :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m ()
talkSeekForward serverState conn player = do
sendString conn "OK"
st <- liftIO $ readMVar serverState
let pos0 = getCurrentPosition st + 15
let pos1 = if pos0 > getCurrentDuration st then getCurrentDuration st else pos0
liftIO $ gstPlayerSeek player pos1
talkSeekBackward :: MonadIO m => MVar ServerState -> Socket -> GstPlayer -> m ()
talkSeekBackward serverState conn player = do
sendString conn "OK"
st <- liftIO $ readMVar serverState
let pos0 = getCurrentPosition st - 15
let pos1 = if pos0 < 0 then 0 else pos0
liftIO $ gstPlayerSeek player pos1
talkGetFlags :: MonadIO m => MVar ServerState -> Socket -> m ()
talkGetFlags serverState conn = do
st <- liftIO $ readMVar serverState
let r = if isRepeatMode st then 'r' else '-'
let z = if isShuffleMode st then 'z' else '-'
sendString conn [r, z]
talkToggleRepeat :: MonadIO m => MVar ServerState -> Socket -> m ()
talkToggleRepeat serverState conn = do
sendString conn "OK"
liftIO $ modifyMVar_ serverState $ \st ->
return st {
isRepeatMode = not $ isRepeatMode st
}
talkToggleShuffle :: MonadIO m => MVar ServerState -> GstPlayer -> Socket -> m ()
talkToggleShuffle serverState player conn = do
sendString conn "OK"
shuffleEnabled <- liftIO $ modifyMVar serverState $ \st ->
if isShuffleMode st then do
newSt <- disableShuffle st
return (newSt, False)
else do
newSt <- enableShuffle st
return (newSt, getStatus st == "Playing")
when shuffleEnabled $ playerPlay serverState player id
disableShuffle :: MonadIO m => ServerState -> m ServerState
disableShuffle st =
return st {
getPlaying = shuffleFunc st $ getPlaying st,
isShuffleMode = False,
shuffleFunc = id
}
enableShuffle :: MonadIO m => ServerState -> m ServerState
enableShuffle st = do
r <- liftIO randomIO
let (f, d) = State.runState (shuffleFilled $ length $ getPlaylist st) $ shuffleInitial (mkStdGen r)
return st {
getPlaying = 0,
isShuffleMode = True,
randomInitializer = r,
shuffleFunc = f,
shuffleData = d
}