Server.hs

{-  
 *  Programmer:	Piotr Borek
 *  E-mail:     piotrborek@op.pl
 *  Copyright 2014 Piotr Borek
 *
 *  Distributed under the terms of the GPL (GNU Public License)
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

module Mp.Player.Server (
    startServerBlocking
) where

import qualified Media.Streaming.GStreamer as Gst
import qualified Control.Monad.State as State

import Network.Socket
import System.FilePath.Posix
import System.Posix.Signals
import System.Random
import Control.Monad
import Control.Concurrent
import System.Directory
import Data.Binary
import Data.Maybe

import Mp.Configuration.Configuration
import Mp.Player.GstPlayer
import Mp.Utils.Utils
import Mp.Utils.Shuffle
import Mp.Utils.Exception
import Mp.Utils.Network
import Mp.Player.ServerState

makeServerSocket :: String -> IO Socket
makeServerSocket socName = do
    sock <- socket AF_UNIX Stream defaultProtocol
    bind sock $ SockAddrUnix socName
    listen sock 1
    return sock

saveServerState :: MVar ServerState -> IO ()
saveServerState serverState = do
    cfgDir <- configDirFilePath
    state <- readMVar serverState
    encodeFile (cfgDir </> "server.state") state

startServerBlocking :: String -> IO ()
startServerBlocking socName = do
    player <- initGstPlayer

    serverState <- newMVar defaultServerState

    readServerState player serverState
    schedulePlayerInfo player serverState

    _ <- forkIO $ do
        sock <- makeServerSocket socName

        _ <- installHandler sigINT  (Catch $ close sock) Nothing
        _ <- installHandler sigTERM (Catch $ close sock) Nothing

        talkBlocking serverState player sock

        close sock
        _ <- try' $ removeFile socName
        return ()

    gstBusAddWatch player $ \_ message -> do
        case Gst.messageType message of
            Gst.MessageEOS -> playerPlay serverState player succ
            _              -> return ()
        return True

    gstPlayerMainLoopBlocking player

    where
        readServerState player serverState = do
            cfgDir <- configDirFilePath
            let file = cfgDir </> "server.state"
            exists <- doesFileExist file
            when exists $ do
                modifyMVar_ serverState $ \_ -> do
                    state <- readStateFromFile file :: IO ServerState
                    gstPlayerSetVolume player $ getVolume state
                    when (getStatus state == "Playing") $ do
                        let f = getPlaylist state !! (shuffleFunc state) (getPlaying state)
                        gstPlayerPlay player f
                    return state

        schedulePlayerInfo player serverState =
            gstPlayerTimeoutAdd 100 $ do
                maybeInfo <- gstPlayerGetTimeInfo player
                if (isJust maybeInfo) then do
                    let (pos, dur) = fromJust maybeInfo
                    modifyMVar_ serverState $ \st -> do
                        return st {
                            getCurrentPosition = pos,
                            getCurrentDuration = dur
                        }
                else
                    modifyMVar_ serverState $ \st -> do
                        return st {
                            getCurrentPosition = 0,
                            getCurrentDuration = 0
                        }
                return True

playerPlay :: MVar ServerState -> GstPlayer -> (Int -> Int) -> IO ()
playerPlay serverState player indexFunction = do
    _ <- forkIO $ do
        threadDelay 400000
        st <- readMVar serverState
        when (and [getCurrentDuration st == 0, getStatus st == "Playing"]) $ playerPlay serverState player succ

    modifyMVar_ serverState $ \st -> do
        let list = getPlaylist st
        let index = indexFunction $ getPlaying st

        if and [index >= 0, index < length list]
            then
                modifyPlayerPlay st player index
            else
                if isRepeatMode st then do
                    let newIndex = if index < 0 then
                                       pred $ length list
                                   else if index >= length list then
                                       0
                                   else
                                       index
                    modifyPlayerPlay st player newIndex
                else
                    modifyPlayerStop st player

modifyPlayerStop :: ServerState -> GstPlayer -> IO ServerState
modifyPlayerStop st player = do
    gstPlayerStop player
    return st {
        getCurrentPosition = 0,
        getCurrentDuration = 0,
        getPlaying = -1,
        getStatus = "Stopped"
    }

modifyPlayerPlay :: ServerState -> GstPlayer -> Int -> IO ServerState
modifyPlayerPlay st player index = do
    let list = getPlaylist st
    let (f, d) = if isShuffleMode st then
                     State.runState shuffleFunction $ shuffleData st
                 else
                    (id, shuffleData st)
    gstPlayerPlay player $ list !! (f index)
    return st {
        getPlaying = index,
        getStatus = "Playing",
        shuffleFunc = f,
        shuffleData = d
    }

talkBlocking :: MVar ServerState -> GstPlayer -> Socket -> IO ()
talkBlocking serverState player sock = do
    _ <- try' processMessages
    saveServerState serverState
    gstPlayerStop player
    gstPlayerQuit player

    where
        processMessages = do
            (conn, _) <- accept sock
            msg <- recv conn 4096

            case msg of
                "Add"            -> talkAdd serverState conn
                "Remove"         -> talkRemove serverState player conn
                "Clear"          -> talkClear serverState player conn
                "GetPlaylist"    -> talkGetPlaylist serverState conn
                "GetStatus"      -> talkGetStatus serverState conn
                "SetPlay"        -> talkSetPlay serverState conn player
                "GetPlay"        -> talkGetPlay serverState conn
                "Stop"           -> talkStop serverState conn player
                "Pause"          -> talkPause serverState conn player
                "Resume"         -> talkResume serverState conn player
                "Next"           -> talkNext serverState conn player
                "Prev"           -> talkPrev serverState conn player
                "SeekForward"    -> talkSeekForward serverState conn player
                "SeekBackward"   -> talkSeekBackward serverState conn player
                "VolUp"          -> talkVolumeUp serverState conn player
                "VolDown"        -> talkVolumeDown serverState conn player
                "VolGet"         -> talkVolumeGet serverState conn
                "GetFlags"       -> talkGetFlags serverState conn
                "ToggleRepeat"   -> talkToggleRepeat serverState conn
                "ToggleShuffle"  -> talkToggleShuffle serverState player conn
                "Quit"           -> sendString conn "OK"
                _                -> sendString conn "NOK"

            close conn

            when (msg /= "Quit") processMessages

talkGetPlaylist :: MVar ServerState -> Socket -> IO ()
talkGetPlaylist serverState conn = do
    list <- readMVar serverState
    forM_ (reverse $ getPlaylist list) $ \item -> do
        sendString conn item
        recvString_ conn
        return ()

    sendString conn "EndPlaylist"

talkGetStatus :: MVar ServerState -> Socket -> IO ()
talkGetStatus serverState conn = do
    st <- readMVar serverState

    let status = getStatus st
    sendString conn status

    recvString_ conn
    let dur = getCurrentDuration st
    sendString conn $ show dur

    recvString_ conn
    let pos = getCurrentPosition st
    sendString conn  $ show pos

talkSetPlay :: MVar ServerState -> Socket -> GstPlayer -> IO ()
talkSetPlay serverState conn player = do
    sendString conn "OK"
    index <- recvString conn
    sendString conn "OK"

    st <- readMVar serverState
    if isShuffleMode st
        then
            playerPlay serverState player $ const 0
        else
            playerPlay serverState player $ const (read index :: Int)

talkGetPlay :: MVar ServerState -> Socket -> IO ()
talkGetPlay serverState conn = do
    st <- readMVar serverState
    if getStatus st == "Stopped" then
        sendString conn "-1"
    else
        sendString conn $ show $ shuffleFunc st $ getPlaying st

talkAdd :: MVar ServerState -> Socket -> IO ()
talkAdd serverState conn = do
    sendString conn "OK"
    file <- recvString conn
    sendString conn "OK"

    modifyMVar_ serverState $ \st -> do
        let (_, d) = State.runState shuffleAdd $ shuffleData st
        return st {
            getPlaylist = getPlaylist st ++ [file],
            shuffleData = d
        }

talkRemove :: MVar ServerState -> GstPlayer -> Socket -> IO ()
talkRemove serverState player conn = do
    sendString conn "OK"
    sIndex <- recvString conn
    sendString conn "OK"
    
    st <- takeMVar serverState
    let shuffleEnabled = isShuffleMode st
    let playing = getPlaying st
    let index = read sIndex :: Int
    let (_, d) = State.runState shuffleRemove $ shuffleData st
    putMVar serverState $ update index playing d st

    when (or [shuffleEnabled, playing == index]) $ playerPlay serverState player id

    where
        update index playing d st
            | index < playing  =
                  st {
                      getPlaying  = pred playing,
                      getPlaylist = removeAt index $ getPlaylist st,
                      shuffleData = d
                  }
            | otherwise =
                  st {
                      getPlaylist = removeAt index $ getPlaylist st,
                      shuffleData = d
                  }

talkClear :: MVar ServerState -> GstPlayer -> Socket -> IO ()
talkClear serverState player conn = do
    sendString conn "OK"
    gstPlayerStop player
    modifyMVar_ serverState (const $ return defaultServerState)

talkStop :: MVar ServerState -> Socket -> GstPlayer -> IO ()
talkStop serverState conn player = do
    sendString conn "OK"
    modifyMVar_ serverState $ flip modifyPlayerStop player

talkPause :: MVar ServerState -> Socket -> GstPlayer -> IO ()
talkPause serverState conn player = do
    sendString conn "OK"
    modifyMVar_ serverState $ \st -> do
        gstPlayerPause player
        return st {
            getStatus = "Paused"
        }

talkResume :: MVar ServerState -> Socket -> GstPlayer -> IO ()
talkResume serverState conn player = do
    sendString conn "OK"
    modifyMVar_ serverState $ \st -> do
        gstPlayerResume player
        return st {
            getStatus = "Playing"
        }

talkNext :: MVar ServerState -> Socket -> GstPlayer -> IO ()
talkNext serverState conn player = do
    sendString conn "OK"
    st <- takeMVar serverState
    let status = getStatus st
    let index  = succ $ getPlaying st
    let len    = length $ getPlaylist st
    let rpt    = isRepeatMode st
    putMVar serverState st

    if rpt then
        when (status == "Playing") $ playerPlay serverState player succ
    else
        when (and [status == "Playing", index < len]) $ playerPlay serverState player succ

talkPrev :: MVar ServerState -> Socket -> GstPlayer -> IO ()
talkPrev serverState conn player = do
    sendString conn "OK"
    st <- takeMVar serverState
    let status = getStatus st
    let index  = pred $ getPlaying st
    let rpt    = isRepeatMode st
    putMVar serverState st

    if rpt then
        when (status == "Playing") $ playerPlay serverState player pred
    else
        when (and [status == "Playing", index >= 0]) $ playerPlay serverState player pred

talkVolumeUp :: MVar ServerState -> Socket -> GstPlayer -> IO ()
talkVolumeUp serverState conn player = do
    sendString conn "OK"
    modifyMVar_ serverState $ \st -> do
        let vol0 = (getVolume st) + 0.04
        let vol1 = if vol0 > 1.0 then 1.0 else vol0
        gstPlayerSetVolume player vol1
        return st {
            getVolume = vol1
        }

talkVolumeDown :: MVar ServerState -> Socket -> GstPlayer -> IO ()
talkVolumeDown serverState conn player = do
    sendString conn "OK"
    modifyMVar_ serverState $ \st -> do
        let vol0 = (getVolume st) - 0.04
        let vol1 = if vol0 < 0.0 then 0.0 else vol0
        gstPlayerSetVolume player vol1
        return st {
            getVolume = vol1
        }

talkVolumeGet :: MVar ServerState -> Socket -> IO ()
talkVolumeGet serverState conn = do
    st <- readMVar serverState
    let vol = ceiling $ (getVolume st) * 100 :: Int
    sendString conn $ show vol

talkSeekForward :: MVar ServerState -> Socket -> GstPlayer -> IO ()
talkSeekForward serverState conn player = do
    sendString conn "OK"
    st <- readMVar serverState
    let pos0 = (getCurrentPosition st) + 15
    let pos1 = if pos0 > getCurrentDuration st then getCurrentDuration st else pos0
    gstPlayerSeek player pos1

talkSeekBackward :: MVar ServerState -> Socket -> GstPlayer -> IO ()
talkSeekBackward serverState conn player = do
    sendString conn "OK"
    st <- readMVar serverState
    let pos0 = (getCurrentPosition st) - 15
    let pos1 = if pos0 < 0 then 0 else pos0
    gstPlayerSeek player pos1

talkGetFlags :: MVar ServerState -> Socket -> IO ()
talkGetFlags serverState conn = do
    st <- readMVar serverState
    let r = if isRepeatMode st then 'r' else '-'
    let z = if isShuffleMode st then 'z' else '-'
    sendString conn $ [r, z]

talkToggleRepeat :: MVar ServerState -> Socket -> IO ()
talkToggleRepeat serverState conn = do
    sendString conn "OK"
    modifyMVar_ serverState $ \st -> do
        return st {
            isRepeatMode = not $ isRepeatMode st
        }

talkToggleShuffle :: MVar ServerState -> GstPlayer -> Socket -> IO ()
talkToggleShuffle serverState player conn = do
    sendString conn "OK"

    shuffleEnabled <- modifyMVar serverState $ \st -> do
        if isShuffleMode st then do
            newSt <- disableShuffle st
            return (newSt, False)
        else do
            newSt <- enableShuffle st
            return (newSt, getStatus st == "Playing")

    when (shuffleEnabled) $ playerPlay serverState player id

disableShuffle :: ServerState -> IO ServerState
disableShuffle st = 
    return st {
        getPlaying = shuffleFunc st $ getPlaying st,
        isShuffleMode = False,
        shuffleFunc = id
    }

enableShuffle :: ServerState -> IO ServerState
enableShuffle st = do
    r <- randomIO
    let (f, d) = State.runState (shuffleFilled $ length $ getPlaylist st) $ shuffleInitial (mkStdGen r)
    return st {
        getPlaying = 0,
        isShuffleMode = True,
        randomInitializer = r,
        shuffleFunc = f,
        shuffleData = d
    }