diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Giovanni Cappellotto (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,9 @@ +module Main where + +import Control.Monad (void) + +import Player (appMain) + + +main :: IO () +main = void appMain diff --git a/haskell-player.cabal b/haskell-player.cabal new file mode 100644 --- /dev/null +++ b/haskell-player.cabal @@ -0,0 +1,59 @@ +name: haskell-player +version: 0.1.1.0 +synopsis: A terminal music player based on afplay +description: Please see README.md +homepage: https://github.com/potomak/haskell-player +license: BSD3 +license-file: LICENSE +author: Giovanni Cappellotto +maintainer: potomak84@gmail.com +copyright: 2016 Giovanni Cappellotto +category: Sound +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Player + , Player.AudioInfo + , Player.AudioPlay + , Player.Types + , Player.Widgets + ghc-options: -Wall + build-depends: base >= 4.7 && < 5 + , brick >= 0.6.4 + , bytestring + , data-default + , directory + , filepath + , microlens + , process + , text + , transformers + , vector + , vty + , xml-conduit + default-language: Haskell2010 + +executable haskell-player + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: base + , haskell-player + + default-language: Haskell2010 + +test-suite haskell-player-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , haskell-player + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/potomak/haskell-player diff --git a/src/Player.hs b/src/Player.hs new file mode 100644 --- /dev/null +++ b/src/Player.hs @@ -0,0 +1,242 @@ +-- TODO: playlist +-- TODO: search +-- TODO: go to playing song +-- TODO: next/previous +-- TODO: stop on exit + +{-# LANGUAGE OverloadedStrings #-} + +module Player ( + appMain +) where + +import qualified Brick.AttrMap as A +import qualified Brick.Main as M +import Brick.Types (Widget, EventM, Next, Name(Name), handleEvent) +import Brick.Widgets.Core ((<+>), str, vBox) +import qualified Brick.Widgets.Border as B +import qualified Brick.Widgets.List as L +import qualified Brick.Widgets.ProgressBar as P +import Brick.Util (on) +import Control.Concurrent (Chan, ThreadId, forkIO, killThread, newChan, + writeChan, threadDelay) +import Control.Monad.IO.Class (liftIO) +import Data.Default (def) +import Data.List (isPrefixOf, stripPrefix) +import Data.Maybe (fromMaybe) +import qualified Data.Vector as Vec +import GHC.Float (double2Float) +import qualified Graphics.Vty as V +import Lens.Micro ((^.)) +import System.Directory (doesDirectoryExist, getDirectoryContents) +import System.Environment (getEnv) +import System.FilePath (()) +import System.Process (ProcessHandle) + +import Player.AudioInfo (SongInfo(SongInfo), fetchSongInfo) +import Player.AudioPlay (play, pause, resume, stop) +import Player.Types (Song(Song, songStatus), PlayerApp(PlayerApp, songsList, + playerStatus, playback), Playback(Playback, playhead), Status(Play, Pause, + Stop), PlayheadAdvance(VtyEvent, PlayheadAdvance)) +import Player.Widgets (songWidget) + +drawUI :: PlayerApp -> [Widget] +drawUI (PlayerApp l _ _ mPlayback) = [ui] + where + playheadWidget Nothing = str " " + playheadWidget (Just (Playback _ _ ph d _)) = str $ + "Duration: " ++ show ph ++ + " - Progress: " ++ show (1 - (double2Float ph / double2Float d)) + playheadProgressBar Nothing = str " " + playheadProgressBar (Just (Playback _ _ ph d _)) = + P.progressBar Nothing (1 - (double2Float ph / double2Float d)) + label = str "Item " <+> cur <+> str " of " <+> total + cur = + case l ^. L.listSelectedL of + Nothing -> str "-" + Just i -> str (show (i + 1)) + total = str $ show $ Vec.length $ l ^. L.listElementsL + box = B.borderWithLabel label $ L.renderList l (const songWidget) + ui = vBox [ box + , playheadProgressBar mPlayback + , playheadWidget mPlayback + , str "Press spacebar to play/pause, q to exit." + ] + +appEvent :: PlayerApp -> PlayheadAdvance -> EventM (Next PlayerApp) +appEvent app@(PlayerApp l status chan mPlayback) e = + case e of + -- press spacebar to play/pause + VtyEvent (V.EvKey (V.KChar ' ') []) -> do + let mPos = l ^. L.listSelectedL + songs = L.listElements l + case mPos of + Nothing -> M.continue app + Just pos -> do + let selectedSong = songs Vec.! pos + case status of + Play -> + -- pause/stop playing the selected song + case mPlayback of + Nothing -> M.continue app + Just pb@(Playback playPos playProc _ _ _) -> do + app' <- if playPos == pos + then do + let songs' = songs Vec.// [(pos, selectedSong { songStatus = Pause })] + liftIO $ pause playProc + return app { + songsList = L.listReplace songs' (Just pos) l, + playerStatus = Pause + } + else do + let song = songs Vec.! playPos + songs' = songs Vec.// [(playPos, song { songStatus = Stop })] + liftIO $ stopPlayingSong pb + return app { + songsList = L.listReplace songs' (Just pos) l, + playerStatus = Stop, + playback = Nothing + } + M.continue app' + Pause -> + -- resume/play the selected song + case mPlayback of + Nothing -> M.continue app + Just (Playback playPos playProc _ _ _) -> do + app' <- do + let song = songs Vec.! playPos + songs' = songs Vec.// [(playPos, song { songStatus = Play })] + liftIO $ resume playProc + return app { + songsList = L.listReplace songs' (Just pos) l, + playerStatus = Play + } + M.continue app' + Stop -> do + let songs' = songs Vec.// [(pos, selectedSong { songStatus = Play })] + -- play selected song + (proc, duration, tId) <- liftIO $ playSong selectedSong chan + M.continue app { + songsList = L.listReplace songs' (Just pos) l, + playerStatus = Play, + playback = Just (Playback pos proc duration duration tId) + } + -- press q to quit + VtyEvent (V.EvKey (V.KChar 'q') []) -> + -- TODO: stop any current playing process + M.halt app + -- any other event + VtyEvent ev -> do + l' <- handleEvent ev l + M.continue app { songsList = l' } + PlayheadAdvance -> + case status of + Play -> + case mPlayback of + Nothing -> M.continue app + Just pb@(Playback playPos _ ph _ _) -> + if ph > 0 + then + -- advance playhead + M.continue app { + playback = Just pb { playhead = ph - 1.0 } + } + else do + let songs = L.listElements l + song = songs Vec.! playPos + nextPos = (playPos + 1) `mod` Vec.length songs + nextSong = songs Vec.! nextPos + songs' = songs Vec.// [ + (playPos, song { songStatus = Stop }), + (nextPos, nextSong { songStatus = Play }) + ] + -- stop current song + liftIO $ stopPlayingSong pb + -- play next song + (proc, duration, tId) <- liftIO $ playSong nextSong chan + M.continue app { + songsList = L.listReplace songs' (l ^. L.listSelectedL) l, + playback = Just (Playback nextPos proc duration duration tId) + } + _ -> M.continue app + + +playheadAdvanceLoop :: Chan PlayheadAdvance -> IO ThreadId +playheadAdvanceLoop chan = forkIO loop + where + loop = do + threadDelay 1000000 + writeChan chan PlayheadAdvance + loop + + +stopPlayingSong :: Playback -> IO () +stopPlayingSong (Playback _ playProc _ _ threadId) = do + stop playProc + killThread threadId + + +playSong :: Song -> Chan PlayheadAdvance -> IO (ProcessHandle, Double, ThreadId) +playSong (Song _ path _) chan = do + musicDir <- defaultMusicDirectory + (SongInfo duration) <- fetchSongInfo $ musicDir path + proc <- play $ musicDir path + tId <- playheadAdvanceLoop chan + return (proc, duration, tId) + + +initialState :: IO PlayerApp +initialState = do + chan <- newChan + paths <- listMusicDirectory + let songs = map (\p -> Song Nothing p Stop) paths + listWidget = L.list (Name "list") (Vec.fromList songs) 1 + return $ PlayerApp listWidget Stop chan Nothing + + +theMap :: A.AttrMap +theMap = A.attrMap V.defAttr + [ (L.listAttr, V.white `on` V.blue) + , (L.listSelectedAttr, V.blue `on` V.white) + , (P.progressCompleteAttr, V.blue `on` V.white) + ] + + +theApp :: M.App PlayerApp PlayheadAdvance +theApp = + M.App { M.appDraw = drawUI + , M.appChooseCursor = M.showFirstCursor + , M.appHandleEvent = appEvent + , M.appStartEvent = return + , M.appAttrMap = const theMap + , M.appLiftVtyEvent = VtyEvent + } + + +listMusicDirectory :: IO [FilePath] +listMusicDirectory = do + musicDir <- defaultMusicDirectory + map (stripMusicDirectory musicDir) <$> listMusicDirectoryRic [musicDir] + where + listMusicDirectoryRic [] = return [] + listMusicDirectoryRic (p:ps) = do + isDirectory <- doesDirectoryExist p + if isDirectory + then do + files <- map (p ) . filter visible <$> getDirectoryContents p + listMusicDirectoryRic (files ++ ps) + else do + files <- listMusicDirectoryRic ps + return $ p:files + visible = not . isPrefixOf "." + stripMusicDirectory musicDir = fromMaybe musicDir . stripPrefix musicDir + + +defaultMusicDirectory :: IO FilePath +defaultMusicDirectory = ( "Music/") <$> getEnv "HOME" + + +appMain :: IO PlayerApp +appMain = do + playerApp@(PlayerApp _ _ chan _) <- initialState + M.customMain (V.mkVty def) chan theApp playerApp diff --git a/src/Player/AudioInfo.hs b/src/Player/AudioInfo.hs new file mode 100644 --- /dev/null +++ b/src/Player/AudioInfo.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Player.AudioInfo ( + SongInfo(..), + fetchSongInfo +) where + +import Control.Exception (SomeException) +import Data.ByteString.Lazy (ByteString, hGetContents) +import qualified Data.Text as T +import System.Process (StdStream(CreatePipe), CreateProcess(std_out), + createProcess, proc) +import Text.XML (def, parseLBS) +import Text.XML.Cursor (($//), (&//), fromDocument, content, element) + + +data SongInfo = SongInfo { + duration :: Double + } deriving (Show) + + +fetchSongInfo :: FilePath -> IO SongInfo +fetchSongInfo path = do + songInfoXML <- fetchRawSongInfo path + case parseSongInfo songInfoXML of + Left _ -> fail "Song info parsing error" + Right songInfo -> return songInfo + + +fetchRawSongInfo :: FilePath -> IO ByteString +fetchRawSongInfo path = do + (_, Just hout, _, _) <- + createProcess (proc "afinfo" ["-x", path]) { + std_out = CreatePipe + } + hGetContents hout + + +parseSongInfo :: ByteString -> Either SomeException SongInfo +parseSongInfo contents = do + doc <- parseLBS def contents + let durations = fromDocument doc $// durationElement &// content + return . SongInfo . read . T.unpack . T.concat $ durations + where + durationElement = + element "{http://apple.com/core_audio/audio_info}duration" diff --git a/src/Player/AudioPlay.hs b/src/Player/AudioPlay.hs new file mode 100644 --- /dev/null +++ b/src/Player/AudioPlay.hs @@ -0,0 +1,42 @@ +module Player.AudioPlay ( + play, + pause, + resume, + stop +) where + +import Control.Monad (void) +import Data.Maybe (fromJust) +import System.Process (ProcessHandle, createProcess, proc, terminateProcess) +import System.Process.Internals (ProcessHandle__(OpenHandle, ClosedHandle), + PHANDLE, withProcessHandle) + + +play :: FilePath -> IO ProcessHandle +play path = do + (_, _, _, processHandle) <- createProcess (proc "afplay" [path]) + return processHandle + + +pause :: ProcessHandle -> IO () +pause ph = do + mPid <- getPid ph + void $ createProcess (proc "kill" ["-17", show $ fromJust mPid]) + + +resume :: ProcessHandle -> IO () +resume ph = do + mPid <- getPid ph + void $ createProcess (proc "kill" ["-19", show $ fromJust mPid]) + + +stop :: ProcessHandle -> IO () +stop = terminateProcess + + +-- See https://mail.haskell.org/pipermail/haskell-cafe/2012-October/104028.html +getPid :: ProcessHandle -> IO (Maybe PHANDLE) +getPid ph = withProcessHandle ph (return . go) + where + go (OpenHandle pid) = Just pid + go (ClosedHandle _) = Nothing diff --git a/src/Player/Types.hs b/src/Player/Types.hs new file mode 100644 --- /dev/null +++ b/src/Player/Types.hs @@ -0,0 +1,45 @@ +module Player.Types ( + PlayerApp(..), + Playback(..), + Song(..), + Status(..), + PlayheadAdvance(..) +) where + +import Brick.Widgets.List (List) +import Control.Concurrent (ThreadId, Chan) +import qualified Graphics.Vty as V +import System.Process (ProcessHandle) + +import Player.AudioInfo (SongInfo) + + +data PlayerApp = PlayerApp { + songsList :: List Song, + playerStatus :: Status, + playbackChan :: Chan PlayheadAdvance, + playback :: Maybe Playback + } + + +data Playback = Playback { + position :: Int, + process :: ProcessHandle, + playhead :: Double, + duration :: Double, + playheadThread :: ThreadId + } + + +data Song = Song { + songInfo :: Maybe SongInfo, + songPath :: FilePath, + songStatus :: Status + } deriving (Show) + + +data Status = Play | Pause | Stop + deriving (Show) + + +data PlayheadAdvance = VtyEvent V.Event | PlayheadAdvance diff --git a/src/Player/Widgets.hs b/src/Player/Widgets.hs new file mode 100644 --- /dev/null +++ b/src/Player/Widgets.hs @@ -0,0 +1,17 @@ +module Player.Widgets ( + songWidget +) where + +import Brick.Types (Widget) +import Brick.Widgets.Core ((<+>), str, fill, vLimit) + +import Player.Types (Song(Song), Status(Play, Pause)) + + +songWidget :: Song -> Widget +songWidget (Song _ path status) = + vLimit 1 $ str (statusSymbol status) <+> str " " <+> str path <+> fill ' ' + where + statusSymbol Play = "♫" + statusSymbol Pause = "►" + statusSymbol _ = " " diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"