module MPlayer.Spot where
import Conduit (ConduitT, awaitForever, iterMC, runConduit, yield, (.|))
import Control.Applicative ((<|>))
import Control.Concurrent.Async (Concurrently(..))
import Control.Concurrent.MVar (MVar, modifyMVar_, newMVar, tryReadMVar)
import Control.Exception (IOException, finally, try)
import Control.Monad (void)
import Control.Monad.IO.Class (liftIO)
import Data.Attoparsec.ByteString.Char8
( Parser, char, notInClass, parseOnly, rational, skipSpace, skipWhile
, string, takeWhile1
)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as C8
import Data.Conduit.Combinators (stderr, stdin, stdout)
import Data.Conduit.Process (streamingProcess, waitForStreamingProcess)
import Data.Monoid ((<>))
import Data.Streaming.Process (StreamingProcessHandle)
import Data.Text (unpack)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Void (Void)
import System.Directory (createDirectoryIfMissing, getHomeDirectory, removeFile)
import System.Environment (getArgs)
import System.Exit (exitWith)
import System.FilePath (takeFileName, (</>))
import System.IO (BufferMode(..), hSetBuffering)
import qualified System.IO as IO
import System.Process (proc)
default (T.Text, Int)
data Config = Config { configMPlayerSpotRCDir :: FilePath
, configSpotsDir :: FilePath
, configIgnoreSeconds :: Float
}
deriving Show
defaultConfig :: IO Config
defaultConfig = do
homeDir <- getHomeDirectory
let rcDir = homeDir </> ".mplayer-spot"
let spotsDir = rcDir </> "spots"
let ignoreSeconds = 180
pure $ Config rcDir spotsDir ignoreSeconds
data MediaInfo = MediaInfo { mediaInfoLength :: Maybe Float
, mediaInfoFilename :: Maybe ByteString
, mediaInfoCurPos :: Maybe Float
, mediaInfoAlreadySetOldLocation :: Bool
}
deriving Show
defaultMediaInfo :: MediaInfo
defaultMediaInfo = MediaInfo { mediaInfoLength = Nothing
, mediaInfoFilename = Nothing
, mediaInfoCurPos = Nothing
, mediaInfoAlreadySetOldLocation = False
}
data MPlayer = MPlayer { mplayerStdin :: ConduitT ByteString Void IO ()
, mplayerStdout :: ConduitT () ByteString IO ()
, mplayerStderr :: ConduitT () ByteString IO ()
, mplayerProcHandle :: StreamingProcessHandle
}
createMPlayerProcess :: [String] -> IO MPlayer
createMPlayerProcess programArgs = do
let mplayerArgs = ["-identify", "-slave"] <> programArgs
( processStdin :: ConduitT ByteString Void IO ()
, processStdout :: ConduitT () ByteString IO ()
, processStderr :: ConduitT () ByteString IO ()
, processHandle) <-
streamingProcess (proc "mplayer" mplayerArgs)
return $! MPlayer processStdin processStdout processStderr processHandle
genericParser :: forall a . ByteString -> Parser a -> ByteString -> Maybe a
genericParser str parser mplayerLine =
either (const Nothing) Just $ parseOnly go mplayerLine
where
go :: Parser a
go = do
skipWhile (/= C8.head str)
string str *> parser
<|> char (C8.head str) *> go
getLength :: ByteString -> Maybe Float
getLength = genericParser "ID_LENGTH=" rational
getFilename :: ByteString -> Maybe ByteString
getFilename = genericParser "ID_FILENAME=" $ takeWhile1 (notInClass "\n")
getCurPos :: ByteString -> Maybe Float
getCurPos = genericParser "A:" $ skipSpace *> rational
updateLength :: MVar MediaInfo -> ByteString -> IO ()
updateLength mediaInfoMVar mplayerLine = do
maybeMediaInfo <- tryReadMVar mediaInfoMVar
case maybeMediaInfo of
Just (MediaInfo (Just _) _ _ _) -> pure ()
_ ->
case getLength mplayerLine of
Nothing -> pure ()
Just mediaLength ->
modifyMVar_ mediaInfoMVar $ updateMediaInfo mediaLength
where
updateMediaInfo :: Float -> MediaInfo -> IO MediaInfo
updateMediaInfo mediaLength mediaInfo =
pure mediaInfo { mediaInfoLength = Just mediaLength }
updateFilename :: MVar MediaInfo -> ByteString -> IO ()
updateFilename mediaInfoMVar mplayerLine = do
maybeMediaInfo <- tryReadMVar mediaInfoMVar
case maybeMediaInfo of
Just (MediaInfo _ (Just _) _ _) -> pure ()
_ ->
case getFilename mplayerLine of
Nothing -> pure ()
Just mediaFilename ->
modifyMVar_ mediaInfoMVar $ updateMediaInfo mediaFilename
where
updateMediaInfo :: ByteString -> MediaInfo -> IO MediaInfo
updateMediaInfo mediaFilename mediaInfo =
pure mediaInfo { mediaInfoFilename = Just mediaFilename }
updateCurPos :: MVar MediaInfo -> ByteString -> IO ()
updateCurPos mediaInfoMVar mplayerLine =
maybe (pure ()) (modifyMVar_ mediaInfoMVar . updateMediaInfo) $ getCurPos mplayerLine
where
updateMediaInfo :: Float -> MediaInfo -> IO MediaInfo
updateMediaInfo mediaCurPos mediaInfo =
pure mediaInfo { mediaInfoCurPos = Just mediaCurPos }
processMPlayerStdout :: MVar MediaInfo -> ByteString -> IO ()
processMPlayerStdout mediaInfoMVar mplayerLine = do
updateLength mediaInfoMVar mplayerLine
updateFilename mediaInfoMVar mplayerLine
updateCurPos mediaInfoMVar mplayerLine
sendMPlayerCommands :: ConduitT ByteString ByteString IO ()
sendMPlayerCommands = awaitForever go
where
go :: ByteString -> ConduitT ByteString ByteString IO ()
go inputChar
| inputChar == "q" = yield "quit\n"
| inputChar == "p" = yield "pause\n"
| inputChar == " " = yield "pause\n"
| inputChar == "\ESC[D" = yield "seek -10\n"
| inputChar == "\ESC[C" = yield "seek 10\n"
| inputChar == "\ESC[B" = yield "seek -60\n"
| inputChar == "\ESC[A" = yield "seek 60\n"
| inputChar == "\ESC[6~" = yield "seek -600\n"
| inputChar == "\ESC[5~" = yield "seek 600\n"
| otherwise =
liftIO $ print $ "got keypress " <> inputChar <> " but don't know what to do with it"
calculateFullSpotsPath :: Config -> ByteString -> FilePath
calculateFullSpotsPath (Config _ spotsDir _) filename =
spotsDir </> takeFileName (unpack (decodeUtf8 filename))
setOldLocation :: Config -> MVar MediaInfo -> ConduitT i ByteString IO ()
setOldLocation config mediaInfoMVar = do
maybeMediaInfo <- liftIO $ tryReadMVar mediaInfoMVar
case maybeMediaInfo of
Just (MediaInfo _ _ _ True) -> pure ()
Just (MediaInfo _ (Just filename) _ False) -> do
let fullPath = calculateFullSpotsPath config filename
filecontents <- liftIO $ try $ readFile fullPath
case filecontents of
Right oldLocation -> do
yield $ "seek " <> encodeUtf8 (T.pack oldLocation) <> "\n"
Left (_ :: IOException) -> pure ()
liftIO $ modifyMVar_ mediaInfoMVar $ \mediaInfo -> pure mediaInfo { mediaInfoAlreadySetOldLocation = True }
_ -> setOldLocation config mediaInfoMVar
runMPlayerUpdateMediaInfo :: Config -> MPlayer -> MVar MediaInfo -> IO ()
runMPlayerUpdateMediaInfo config mplayer mediaInfoMVar = do
hSetBuffering IO.stdin NoBuffering
let oldLocationToMplayerStdin =
runConduit $ setOldLocation config mediaInfoMVar .| mplayerStdin mplayer
let stdinToMplayerStdin =
runConduit $
stdin .|
sendMPlayerCommands .|
mplayerStdin mplayer
let mplayerStdoutToStdout =
runConduit $
mplayerStdout mplayer .|
iterMC (processMPlayerStdout mediaInfoMVar) .|
stdout
let mplayerStderrToStderr = runConduit $ mplayerStderr mplayer .| stderr
let mplayerHandle = mplayerProcHandle mplayer
runConcurrently $
Concurrently mplayerStdoutToStdout *>
Concurrently mplayerStderrToStderr *>
Concurrently oldLocationToMplayerStdin *>
Concurrently stdinToMplayerStdin *>
Concurrently (waitForStreamingProcess mplayerHandle >>= exitWith)
createMPlayerSpotsDir :: Config -> IO ()
createMPlayerSpotsDir (Config rcDir spotsDir _) = do
createDirectoryIfMissing True rcDir
createDirectoryIfMissing True spotsDir
writeSpotFile :: Config -> MVar MediaInfo -> IO ()
writeSpotFile config@(Config _ _ ignoreLength) mediaInfoMVar = do
maybeMediaInfo <- tryReadMVar mediaInfoMVar
case maybeMediaInfo of
Just (MediaInfo (Just mediaLength) (Just filename) (Just exitPos) _) -> do
let spotFilename = calculateFullSpotsPath config filename
writeSpotFile' mediaLength spotFilename exitPos
_ -> putStrLn "When exiting, do not currently have all fields of media info, so cannot write out spot file."
where
writeSpotFile' :: Float -> FilePath -> Float -> IO ()
writeSpotFile' mediaLength spotFilename exitPos
| exitPos <= ignoreLength = do
putStrLn $ "exit position is " <> show exitPos <> " seconds so not writing spot file (not far enough)"
| exitPos >= (mediaLength - ignoreLength) = do
putStrLn $ "exit position is " <> show exitPos <> " seconds so not writing spot file (too close to end)"
removeOldSpotFile spotFilename
| otherwise =
writeFloatToFile spotFilename (max (exitPos - 10) 0)
writeFloatToFile :: FilePath -> Float -> IO ()
writeFloatToFile spotFilename exitPos = do
putStrLn $ "writing to file: " <> spotFilename <> " (" <> show exitPos <> ")"
writeFile spotFilename $ show exitPos
removeOldSpotFile :: FilePath -> IO ()
removeOldSpotFile =
void . (try :: IO () -> IO (Either IOException ())) . removeFile
defaultMain :: IO ()
defaultMain = do
programArgs <- getArgs
config <- defaultConfig
createMPlayerSpotsDir config
mplayerProcess <- createMPlayerProcess programArgs
mediaInfoMVar <- newMVar defaultMediaInfo
finally (runMPlayerUpdateMediaInfo config mplayerProcess mediaInfoMVar) $
writeSpotFile config mediaInfoMVar