packages feed

haskell-player (empty) → 0.1.1.0

raw patch · 10 files changed

+494/−0 lines, 10 filesdep +basedep +brickdep +bytestringsetup-changed

Dependencies added: base, brick, bytestring, data-default, directory, filepath, haskell-player, microlens, process, text, transformers, vector, vty, xml-conduit

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,9 @@+module Main where++import Control.Monad (void)++import Player (appMain)+++main :: IO ()+main = void appMain
+ haskell-player.cabal view
@@ -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
+ src/Player.hs view
@@ -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
+ src/Player/AudioInfo.hs view
@@ -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"
+ src/Player/AudioPlay.hs view
@@ -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
+ src/Player/Types.hs view
@@ -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
+ src/Player/Widgets.hs view
@@ -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 _ = " "
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"