bunrui.cabal

Name: bunrui
Version: 1.0
License: BSD3
Cabal-Version: >= 1.2
Build-Type: Simple

Executable bunrui
  Main-is: Main.hs
  Build-Depends: base, containers, directory, filepath, process,
                 filemanip, spawn, parsec >= 3
  GHC-Options: -Wall -O2 -threaded

Core.hs

module Bunrui.Core
    ( Command
    , Metadata(..)
    , Opts(..)
    , findSourceFiles
    , missingDirectories
    , readMetadata
    ) where

import Control.Applicative ((<$>), (<*), (<*>))
import Control.Monad       (filterM, when)
import Data.Char           (toLower)
import Data.List           (delete, inits, nub)
import System.Directory    (doesDirectoryExist)
import System.FilePath     (dropFileName, joinPath, splitDirectories,
                            takeExtension)
import qualified Data.Map as M

import System.FilePath.Find (always, extension, find)
import Text.Parsec          (Parsec, runParser, many,
                             many1, getState, modifyState, noneOf,
                             oneOf, char, newline, sepEndBy1)

import Bunrui.Util


data Opts = Opts
    { assumeYes         :: Bool
    , incomingDirectory :: FilePath
    , mastersDirectory  :: FilePath
    , encodedDirectory  :: FilePath
    }

type Command = Opts -> IO ()

data Metadata = Metadata
    { metaExtension     :: String
    , metaAlbum         :: String
    , metaTitle         :: String
    , metaArtist        :: String
    , metaTrack         :: Integer
    , metaYear          :: Maybe Integer
    , metaGenre         :: Maybe String
    }

type StringMap = M.Map String String


(!) :: Ord k => M.Map k a -> k -> Either k a
a ! k = maybeToEither k (M.lookup k a)

metadata :: String
         -> M.Map String String
         -> Either String Metadata
metadata ext m = do
  album <- m ! "album"
  title <- m ! "title"
  artist <- m ! "artist"
  track <- m ! "tracknumber"
  let genre = M.lookup "genre" m
      errMsg = "tracknumber did not parse: " ++ track
  trackNumber <- maybeToEither errMsg $ maybeRead track
  when (trackNumber < 1) $ Left "non-positive track"
  year <- case M.lookup "year" m of
            Nothing   -> return Nothing
            Just year -> maybeToEither ("bad year: " ++ year) $ maybeRead year
  return Metadata
             { metaExtension = ext
             , metaAlbum = album
             , metaTitle = title
             , metaArtist = artist
             , metaTrack = trackNumber
             , metaGenre = genre
             , metaYear = year
             }

commentParser :: Parsec String StringMap StringMap
commentParser = many (lineParser `sepEndBy1` newline) >> getState
    where lineParser = M.insert <$> key <* char '=' <*> value >>=
                       modifyState
          key = map toLower <$> many1 (oneOf $ delete '=' [' '..'}'])
          value = many (noneOf "\n\r")

readMetadata :: FilePath -> IO Metadata
readMetadata path = either metadataError id .
                   either (error . show) (metadata ext) .
                   runParser commentParser M.empty path <$>
                   getMeta ext
    where ext = takeExtension path
          getMeta ".flac" = runCommand "metaflac"
                            ["--export-tags-to=-", path]
          getMeta ".ogg"  = runCommand "vorbiscomment" ["-e", path]
          getMeta _       = error $ "unhandled extension " ++ ext
          metadataError e = error $ path ++ ": " ++ e

findSourceFiles :: FilePath -> IO [FilePath]
findSourceFiles = find always isSourceExtension
    where isSourceExtension = flip elem sourceExtensions <$> extension
          sourceExtensions = [".ogg", ".flac"]

leadingPathComponents :: FilePath -> [FilePath]
leadingPathComponents = drop 1 . map joinPath . inits .
                        splitDirectories . dropFileName

missingDirectories :: [FilePath] -> IO [FilePath]
missingDirectories = filterM (fmap not . doesDirectoryExist) .
                     nub . concatMap leadingPathComponents

Incoming.hs

module Bunrui.Incoming (sortIncoming) where

import Control.Monad       (filterM, forM_, unless, when)
import Data.List           (intercalate)
import Text.Printf         (printf)
import System.FilePath     ((</>), combine)
import System.Directory    (createDirectory, doesDirectoryExist,
                            doesFileExist, renameFile)

import Bunrui.Core
import Bunrui.Util


masterPath :: Integer -> Metadata -> FilePath
masterPath lastTrack meta =
    foldr1 combine $ map (replace '/' '_') parts
    where parts = [metaArtist meta, metaAlbum meta, fileName]
          fileName = printf ("%." ++ lastTrackLength ++ "d %s%s")
                     (metaTrack meta) (metaTitle meta)
                     (metaExtension meta)
          lastTrackLength = show $ min 2 $ length $ show lastTrack

sortIncoming :: Command
sortIncoming (Opts { assumeYes = yes
                   , incomingDirectory = incoming
                   , mastersDirectory  = masters
                   }) = do
  hasIncoming <- doesDirectoryExist incoming
  unless hasIncoming $ error $ "no such directory " ++ incoming
  sourceFiles <- findSourceFiles incoming
  unless (null sourceFiles) $ do
    annotated <- mapM readMetadata sourceFiles
    let lastTrack = maximum (map metaTrack annotated)
        destFiles = map ((masters </>) . masterPath lastTrack) annotated
        toMove = zip sourceFiles destFiles
    wouldOverwrite <- filterM doesFileExist destFiles
    unless (null wouldOverwrite) $
           error ("refusing to overwrite target files (would overwrite " ++
                  intercalate ", " wouldOverwrite ++ ")")
    missing <- missingDirectories destFiles
    continue <- orM [ return yes
                    , forM_ toMove (uncurry $ printf "  %s -> %s\n") >> prompt
                    ]
    when continue $ do
      mapM_ createDirectory missing
      mapM_ (uncurry renameFile) toMove

Main.hs

module Main where

import Control.Category   ((>>>))
import Data.List          (intercalate)
import System.Environment (getArgs, getProgName)
import System.Exit        (exitFailure)
import System.FilePath    (addTrailingPathSeparator)
import System.IO          (hPutStrLn, stderr)
import System.Console.GetOpt

import Bunrui.Core
import Bunrui.Incoming
import Bunrui.Transcode
import Bunrui.Util


commands :: [(String, Command)]
commands = [("incoming", sortIncoming),
            ("transcode", transcode)]

options :: [OptDescr (Opts -> Opts)]
options =
    [ Option "i" [] (ReqArg (addTrailingPathSeparator >>> \x o ->
                                 o {incomingDirectory = x}) "DIR")
                 "incoming directory"
    , Option "o" [] (ReqArg (addTrailingPathSeparator >>> \x o ->
                                 o {mastersDirectory = x})  "DIR")
                 "masters directory"
    , Option "e" [] (ReqArg (addTrailingPathSeparator >>> \x o ->
                                 o {encodedDirectory = x})  "DIR")
                 "encoded directory"
    , Option "y" [] (NoArg (\o -> o {assumeYes = True})) "assume yes"
    ]

optionDefaults :: Opts
optionDefaults =
    Opts { assumeYes = False
         , incomingDirectory = "Incoming/"
         , mastersDirectory  = "Masters/"
         , encodedDirectory  = "Encoded/"
         }

usage :: String -> IO a
usage msg = do
  progName <- getProgName
  let puts = hPutStrLn stderr
      commandList = intercalate ",\n  " $ map fst commands
  puts msg
  puts $ usageInfo (progName ++ " command") options
  puts $ "where command is:\n  " ++ commandList
  exitFailure

parseOpts :: [String] -> Either String (Command, Opts)
parseOpts argv = do
  (opts, arg) <- case getOpt RequireOrder options argv of
                   (opts, [arg], [])  -> return (opts, arg)
                   (_,    _,     [])  -> Left "command required"
                   (_,    _,     e:_) -> Left e
  let errMsg = "invalid command " ++ arg
      opts' = foldl (flip id) optionDefaults opts
  cmd <- maybeToEither errMsg $ lookup arg commands
  return (cmd, opts')

main :: IO ()
main = getArgs >>=
       either usage return .
       parseOpts >>=
       uncurry id

Transcode.hs

{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
module Bunrui.Transcode (transcode) where

import Control.Applicative ((<$>), (<*>), liftA2)
import Control.Arrow    ((&&&))
import Control.Monad    (filterM, forM_, join, unless, when, void)
import Data.Function    (on)
import Data.List        (stripPrefix)
import Data.Maybe       (fromMaybe)
import System.Directory (copyFile, createDirectory, doesDirectoryExist,
                         doesFileExist, getModificationTime)
import System.FilePath  ((</>), replaceExtension, takeExtension,
                         takeFileName)
import System.IO        (Handle, IOMode(WriteMode), withFile)
import System.Process
import Text.Printf      (printf)

import Control.Concurrent.Spawn (parMapIO_, pool)
import GHC.Conc (numCapabilities)

import Bunrui.Core
import Bunrui.Util


type Extension = String
data Strategy = Transcode | Copy


isNewerThan :: FilePath -> FilePath -> IO Bool
isNewerThan = liftA2 (>) `on` getModificationTime

isStale :: FilePath -> FilePath -> IO Bool
isStale x y = orM [ not <$> doesFileExist y
                  , x `isNewerThan` y
                  ]

extensions :: [(Extension, Strategy)]
extensions = [ (".ogg", Transcode)
             , (".flac", Transcode)
             , (".m4a", Copy)
             , (".mp3", Copy)
             ]

strategyForFile :: FilePath -> Strategy
strategyForFile = fromMaybe (error "unknown extension") .
                  flip lookup extensions .
                  takeExtension

encodedExtension :: FilePath -> FilePath
encodedExtension src = go strategy src
    where go Transcode = flip replaceExtension ".m4a"
          go Copy      = id
          strategy     = strategyForFile src

pipeSource :: String -> [String] -> IO Handle
pipeSource name args = do
  (_, Just hout, _, _) <- createProcess $
                          (proc name args) {std_out = CreatePipe}
  return hout

decodeOgg :: FilePath -> IO Handle
decodeOgg path = pipeSource "oggdec" ["--quiet", "--output", "-", "--", path]

decodeFlac :: FilePath -> IO Handle
decodeFlac path = pipeSource "flac" ["--decode", "--stdout", "--silent",
                                     "--warnings-as-errors", path]

encodeM4A :: FilePath -> Metadata -> Handle -> IO ()
encodeM4A dest metadata inputStream =
    withFile "/dev/null" WriteMode $ \nul -> do
      (_, _, _, h) <- runFaac nul
      void $ waitForProcess h
    where runFaac nul = createProcess $ (proc "faac" faacArgs) {
                          std_err = UseHandle nul
                        , std_in  = UseHandle inputStream
                        }
          faacArgs = metadataArgs ++ ["-o", dest, "-q", "150", "-w", "-"]
          metadataArgs = concatMap (uncurry doArg) $
                         [ ("--title",  return . metaTitle)
                         , ("--artist", return . metaArtist)
                         , ("--album",  return . metaAlbum)
                         , ("--track",  return . show . metaTrack)
                         , ("--year",   fmap show . metaYear)
                         , ("--genre",  metaGenre)
                         ]
          doArg :: String -> (Metadata -> Maybe String) -> [String]
          doArg name meta = maybe [] ((name:) . return) (meta metadata)

doTranscode :: FilePath -> FilePath -> IO ()
doTranscode src dest = go (strategyForFile src) (takeExtension src)
    where go :: Strategy -> Extension -> IO ()
          go Transcode ".ogg"  = join $ encode <*> decodeOgg src
          go Transcode ".flac" = join $ encode <*> decodeFlac src
          go Transcode _       = error "unhandled extension"
          go Copy      _       = copyFile src dest
          encode = encodeM4A dest <$> readMetadata src

rewritePath :: FilePath -> FilePath -> (FilePath -> FilePath)
rewritePath masters encoded = encodedExtension . (encoded </>) .
                              fromMaybe (error "not in " ++ masters) .
                              stripPrefix masters

transcode :: Command
transcode (Opts { mastersDirectory = masters
                , encodedDirectory = encoded
                , assumeYes = yes
                }) = do
  hasMasters <- doesDirectoryExist masters
  unless (hasMasters) $ error ("no such directory " ++ show masters)
  transcodes <- map (id &&& rewritePath masters encoded) <$>
                findSourceFiles masters
  stale <- filterM (uncurry isStale) transcodes
  unless (null stale) $ do
    continue <- orM [ return yes
                    , do forM_ stale (uncurry $ printf "  %s -> %s\n")
                         prompt
                    ]
    when continue $ do
      let width = maximum $ map (length . takeFileName . snd) stale
          format = "[%d/%d] Encoding %-" ++ show width ++ "s ( %s, %s )\n"
          total = length stale
      missing <- missingDirectories (map snd stale)
      mapM_ createDirectory missing
      p <- pool numCapabilities
      flip parMapIO_ (zip [1..] stale) $ \(n, (src, dest)) -> p $ do
          printf format (n::Int) total (takeFileName dest) src dest
          doTranscode src dest

Util.hs

module Bunrui.Util where

import Prelude hiding (any, foldr)
import Control.Applicative ((<$>))
import Control.Monad  (foldM)
import System.Exit    (ExitCode(..))
import System.Process (readProcessWithExitCode)
import System.IO      (hFlush, stdout)


maybeToEither :: e -> Maybe a -> Either e a
maybeToEither e = maybe (Left e) Right

maybeRead :: (Read a) => String -> Maybe a
maybeRead s = case reads s of
                [(x, "")] -> Just x
                _         -> Nothing

replace :: (Functor f, Eq a) => a -> a -> f a -> f a
replace x y = fmap $ \a -> if a == x then y else a

runCommand :: String -> [String] -> IO String
runCommand cmd args = do
  res <- readProcessWithExitCode cmd args ""
  case res of
    (ExitSuccess, out, _)   -> return out
    (_,           _,   err) -> error err

orM :: Monad m => [m Bool] -> m Bool
orM = foldM (\a x -> if a then return a else x) False

prompt :: IO Bool
prompt = do
  putStr "\nContinue [y/N]? "
  hFlush stdout
  flip elem ["Y", "y"] <$> getLine