diff --git a/Emx/Dl.hs b/Emx/Dl.hs new file mode 100644 --- /dev/null +++ b/Emx/Dl.hs @@ -0,0 +1,66 @@ +module Emx.Dl where + +import System.FilePath +import System.Directory +import System.IO +import Control.Applicative +import System.Process (runProcess, waitForProcess) +import Text.Printf (printf) +import Control.Monad +import Network.Curl +import Network.Curl.Easy +import Network.Curl.Opts +import Data.Ratio +import Data.Char +import Data.List +import Data.IORef + + +dl :: String -> String -> IO (String, String) -> IO () +dl a epath remloc = do + (rem, loc) <- remloc + notexists <- not <$> doesFileExist loc + when notexists $ runProcess epath [rem, a, loc] Nothing Nothing Nothing Nothing Nothing >>= waitForProcess >> return () +dlcurl = dl "-o" +dlwget = dl "-O" + +-- native download. How likely is it that curl(1) won't be available +-- but libcurl will be? +colheaders :: IORef Integer -> String -> IO () +colheaders tot s = do + (key, val) <- return $ parseHeader $ map toLower s + when (key == "content-length") $ writeIORef tot $ read val + +writebody sofar tot handle s = do + clen <- readIORef tot + modifyIORef sofar (+ genericLength s) + sof <- readIORef sofar + if clen /= 0 + then do + if sof == clen + then putStrLn "\b\b\b100%" + else putStr $ printf "\b\b\b%2.0f%%" (fromRational (100*sof%clen)::Float) + hFlush stdout + else when (sof == clen) $ putStrLn "... Done" + hPutStr handle s + return () + +dlnative :: IO (String, String) -> IO () +dlnative remloc = do + (rem, loc) <- remloc + tot <- newIORef (0::Integer) + sofar <- newIORef (0::Integer) + curl <- initialize + h <- openFile loc WriteMode + setopts curl [CurlHeaderFunction $ callbackWriter (colheaders tot), + CurlWriteFunction $ callbackWriter (writebody sofar tot h), + CurlURL rem, + CurlFailOnError True] + setDefaultSSLOpts curl rem + putStrLn $ printf "Downloading %s ..." rem + putStrLn $ printf "To %s" loc + perform curl + rspCode <- getResponseCode curl + hFlush h + hClose h + return () diff --git a/Emx/Emx.hs b/Emx/Emx.hs new file mode 100644 --- /dev/null +++ b/Emx/Emx.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE Arrows, ScopedTypeVariables, NamedFieldPuns #-} + +module Emx.Emx where +import Control.Applicative +import System.FilePath +import Data.List (isPrefixOf) +import Control.Monad.Error +import Text.XML.HXT.Core +import Emx.Track + +atTag :: (ArrowXml a) => String -> a XmlTree XmlTree +atTag = deep . hasName +text :: (ArrowXml a) => a XmlTree String +text = getChildren >>> getText +opttagtext :: (ArrowXml a) => String -> a XmlTree String +opttagtext = (<<<) text . atTag + +tagtext t = (opttagtext t >>> arr Right) `orElse` constA (Left $ "Bad XML: couldn't find tag "++t) + +replace::(Eq a) => [a] -> [a] -> [a] -> [a] +replace [] newSub list = joins newSub list +replace oldSub newSub list = _replace list where + _replace list@(h:ts) = if oldSub `isPrefixOf` list + then newSub ++ _replace (drop len list) + else h : _replace ts + _replace [] = [] + len = length oldSub + +joins::[a] -> [a] -> [a] +joins glue [h] = [h] +joins glue (h:ts) = h : glue ++ joins glue ts +joins _ [] = [] + +clean repu repapo = pthc . uc . apoc + where + pthc = replace [pathSeparator] "_" + uc = if repu then replace "_" " " else id + apoc = if repapo then replace "'" "'" else id + +instance Applicative (Either a) where + pure = Right + (Right f) <*> (Right x) = Right $ f x + (Left f) <*> _ = Left f + _ <*> (Left x) = Left x + +gettrack repu repapo = atTag "TRACK" >>> + (proc t -> do + ar <- c <<< tagtext "ARTIST" -< t + al <- c <<< tagtext "ALBUM"-< t + ti <- c <<< tagtext "TITLE"-< t + ext <- tagtext "EXTENSION" -< t + url <- tagtext "TRACKURL" -< t + lbl <- c <<< tagtext "LABEL" -< t + art <- tagtext "ALBUMART" -< t + dc <- rtag "DISCCOUNT" -< t + dn <- rtag "DISCNUM" -< t + tc <- rtag "TRACKCOUNT" -< t + gr <- tagtext "GENRE" -< t + tn <- tr <<< rtag "TRACKNUM" -< t + returnA -< Tr <$> ar <*> al <*> ti <*> ext <*> url <*> lbl <*> art <*> tn <*> gr <*> dc <*> dn <*> tc) + where + c = right $ arr $ clean repu repapo + r t = arr $ \i -> do + v <- i + case reads v of + [] -> throwError $ "Bad XML: couldn't parse int in tag "++t + [(x::Int,_)] -> return x + rtag t = tagtext t >>> r t + tr = right $ arr (fill '0' 2 . show) -- bad assumption: < 100 tracks + +fill fille until s = if length s < until then fill fille until (fille:s) + else s + +collect repu repapo = atTag "PACKAGE" >>> (tagtext "ACTION" &&& tagtext "EXP_DATE" &&& listA (gettrack repu repapo)) >>> arr f + where + f (action, (exp, tracks)) = (,,) <$> action <*> exp <*> (sequence tracks) + +parseXML = readDocument [withValidate False] + +readfile f repu repapo = do + r <- liftIO $ runX (parseXML f >>> collect repu repapo) + case r of + [] -> throwError $ "Couldn't parse emx file "++f++" at all!" + [Right s] -> return s + [Left e] -> throwError e diff --git a/Emx/Options.hs b/Emx/Options.hs new file mode 100644 --- /dev/null +++ b/Emx/Options.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +module Emx.Options where +import System.IO +import System.FilePath +import System.Directory +import Control.Applicative +import Control.Monad.Error +import Emx.Track + +data Subs = Txt String | IntSub (Track -> Int) | StrSub (Track -> String) + +data Options = Opt {repu, repapo, get_art :: Bool, dldir :: String, + dlfmt, dlfmt_m :: [Subs]} + +lookupsub "a" = return $ StrSub artist +lookupsub "A" = return $ StrSub album +lookupsub "D" = return $ IntSub disccount +lookupsub "d" = return $ IntSub discnum +lookupsub "e" = return $ StrSub ext +lookupsub "t" = return $ StrSub title +lookupsub "l" = return $ StrSub label +lookupsub "g" = return $ StrSub genre +lookupsub "n" = return $ StrSub tracknum +lookupsub x = throwError $ "Unrecognized format option: \""++x++"\"" + +subfromstring s = go s [] + where + go "" a = return $ reverse a + go "%" a = throwError $ "Unescaped parenthesis at end of option string \""++s++"\"" + go ('%':'(':cs) a = do + (kind, rest) <- return $ break (==')') cs + when (null rest) $ throwError $ "Unclosed parenthesis in option string \""++s++"\"" + sub <- lookupsub kind + go (tail rest) (sub:a) + go ('%':'%':cs) as = + case as of + Txt s:r -> go cs ((Txt $ s++"%"):r) + _ -> go cs (Txt "%":as) + go s as = + case as of + Txt s:r -> go rest ((Txt $ s++run):as) + _ -> go rest (Txt run:as) + where + (run,rest) = break (=='%') s + +(Right default_dlf) = subfromstring "%(a)/%(A)/%(a) - %(A) - %(n) - %(t)" +(Right default_dlfm) = subfromstring "%(a)/%(A): %(d)/%(a) - %(A): %(d) - %(n) - %(t)" + +strip rem = reverse.snd.span (`elem` rem).reverse.snd.span (`elem` rem) +split s splite = (before, after) + where + (before,rest) = break (==splite) s + (_,after) = span (==splite) rest +stripw = strip " \t\n" + +optline o line = ps (stripw s) (stripw e) + where + (s,e) = split line '=' + ps ('#':rest) _ = return o + ps s e = + case s of + "replace_underscores" -> bconv (\x -> o {repu = x}) s e + "replace_apostrophe_identity" -> bconv (\x -> o {repapo = x}) s e + "get_art" -> bconv (\x -> o {get_art = x}) s e + "dlfmt" -> sconv (\x -> o {dlfmt = x}) s e + "dlfmt_multidisc" -> sconv (\x -> o {dlfmt_m = x}) s e + "dldir" -> return $ o {dldir = e} + "" -> return o + x -> throwError $ "Unrecognized option: " ++ x + bconv u oname v + | v `elem` ["f", "false"] = return $ u False + | v `elem` ["t", "true"] = return $ u True + | otherwise = throwError $ "Boolean values must be one of 'f', 't', 'true', and 'false', not `"++v++"\', in option "++oname + sconv u on v = catchError (u `liftM` (subfromstring v)) + (\t -> throwError $ t++" (error in option \""++on++"\")") + +readopts = do + dotfile <- fmap ( ".emxdownloader") getHomeDirectory + curdir <- getCurrentDirectory + let default_options = Opt True True True curdir default_dlf default_dlfm + exists <- doesFileExist dotfile + if exists + then do + h <- openFile dotfile ReadMode + contents <- fmap lines $ hGetContents h + return (foldM optline default_options contents) + else return $ return default_options diff --git a/Emx/Track.hs b/Emx/Track.hs new file mode 100644 --- /dev/null +++ b/Emx/Track.hs @@ -0,0 +1,5 @@ +module Emx.Track where + +data Track = Tr {artist, album, title, ext, dlurl, label, arturl, + tracknum, genre :: String, + disccount, discnum, trackcount :: Int } deriving Show diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Ben Wolfson + +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 Ben Wolfson 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/README.rst b/README.rst new file mode 100644 --- /dev/null +++ b/README.rst @@ -0,0 +1,89 @@ +====== +GETEMX +====== + +getemx reads the .emx files used by `Emusic +`_ and downloads the files they describe. Its +behavior is controlled by the file ~/.emxdownloader, which contains +instructions for file naming, art downloading, etc (see below in +`Invocation`_). It downloads files using either wget, curl, or +Haskell's interface to libcurl (though I would be surprised if anyone +who had libcurl installed didn't also have the curl binary). + +Building & Installation +======================= + +It should be possible to build and install getemx using `cabal +`_. + +Invocation +========== + +getemx accepts no options on the command line. Its arguments should +consist simply of .emx files; the simplest way to invoke it is:: + + $ getemx *.emx + +where the .emx files are in the current directory. + +getemx will read a file in your home directory called ".emxdownloader" +which can define options to control its behavior. Options may either +be *boolean* or *string*; the values of boolean options must be one of +"f", "t", "false", or "true" while string options may be any +string. The syntax of the .emxdownloader file is very simple:: + + option = value + +Any amount of whitespace may occur before or after the "=". The +following are boolean options: + +- **replace_underscores**: if true, underscores in the filename will be replaced by spaces. True by default. +- **replace_apostrophe_identity**: if true, the string "``'``" in filenames will be replaced by "``'``". True by default. +- **get_art**: if true, cover art will be downloaded for each album. True by default. + +Currently the only string options control the filenames of the +downloaded files. There are two classes here: **dldir** specifies a +directory *relative to which* further processing will take place, +while **dlfmt** and **dlfmt_multidisc** specify how to process +*individual files*. The latter two accept a number of replacement +options: + +================== ================ +**Format string:** **Replaced by:** +================== ================ +``%(a)`` Artist name +``%(A)`` Album name +``%(n)`` Track number +``%(t)`` Track name +``%(D)`` Total number of discs in set +``%(d)`` Number of present disc in set (e.g. 2 out of 4) +``%(l)`` Label +``%(e)`` File extension +``%(g)`` Genre +``%%`` ``%`` +================== ================ + +The defaults for the string options are: + +- **dldir**: ``.`` +- **dlfmt**: ``%(a)/%(A)/%(a) - %(A) - %(n) - %(t)`` +- **dlfmt_multidisc**: ``%(a)/%(A): %(d)/%(a) - %(A): %(d) - %(n) - %(t)`` + +**dlfmt_multidisc** is used if a track is being downloaded that +belongs to a set with more than one disc; otherwise, **dlfmt** is +used. Note that at present the default for dlfmt_multidisc will +probably do the wrong thing on OS X. Note also that neither of the +default values ends with ``%(e)``: the file extension is supplied +automatically if it is not explicitly specified. + +A ~/.emxdownloader file that set every option to its default value +could look like this:: + + get_art = t + replace_underscores = t + replace_apostrophe_identity = t + dldir = . + dlfmt = %(a)/%(A)/%(a) - %(A) - %(n) - %(t) + dlfmt_multidisc = %(a)/%(A): %(d)/%(a) - %(A): %(d) - %(n) - %(t) + +"Could" because one could also write "true" out in full for "t". 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/getemx.cabal b/getemx.cabal new file mode 100644 --- /dev/null +++ b/getemx.cabal @@ -0,0 +1,62 @@ +-- getemx.cabal auto-generated by cabal init. For additional options, +-- see +-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. +-- The name of the package. +Name: getemx + +-- The package version. See the Haskell package versioning policy +-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for +-- standards guiding when and how versions should be incremented. +Version: 0.1 + +-- A short (one-line) description of the package. +Synopsis: Fetch from emusic using .emx files + +-- A longer description of the package. +-- Description: + +-- URL for the project homepage or repository. +Homepage: http://bitbucket.org/kenko/getemx + +-- The license under which the package is released. +License: BSD3 + +-- The file containing the license text. +License-file: LICENSE + +-- The package author(s). +Author: Ben Wolfson + +-- An email address to which users can send suggestions, bug reports, +-- and patches. +Maintainer: wolfson@gmail.com + +-- A copyright notice. +-- Copyright: + +Category: Web + +Build-type: Simple +Description: Read emusic's .emx files and download media +-- Extra files to be distributed with the package, such as examples or +-- a README. +Extra-source-files: README.rst + +-- Constraint on the version of Cabal needed to build this package. +Cabal-version: >=1.2 + + +Executable getemx + + Other-modules: Emx.Emx, Emx.Track, Emx.Options, Emx.Dl + -- .hs or .lhs file containing the Main module. + Main-is: getemx.hs + + -- Packages needed in order to build this package. + Build-depends: base >= 3 && < 5, curl >= 1.3, hxt >= 9, mtl >= 1, filepath >= 1, directory >= 1, process >= 1, old-locale >= 1, time >= 1, haskell98 + + -- Modules not exported by this package. + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + -- Build-tools: + diff --git a/getemx.hs b/getemx.hs new file mode 100644 --- /dev/null +++ b/getemx.hs @@ -0,0 +1,83 @@ +import System (getArgs, exitFailure) +import System.IO +import Data.Time.Clock (getCurrentTime) +import Data.Time.Format (readTime) +import Control.Monad.Error +import System.FilePath +import System.Directory +import System.Locale (defaultTimeLocale) +import Prelude hiding (catch) + + +import Emx.Dl +import Emx.Options +import Emx.Track +import Emx.Emx + +-- all tracks for the same album have the same artwork. +artdl :: (IO (String, String) -> IO ()) -> IO (String, String) -> IO () +artdl dler remloc = do + (rem, loc) <- remloc + exists <- doesFileExist loc + unless exists $ dler remloc + return () + +findPathAndName p = findExecutable p >>= maybe (return Nothing) (\path -> return $ Just (path,p)) + +preptrack opts track = do + made <- foldM joinandtest (dldir opts) $ splitPath ldir + return (dlurl track, combine made lname) + where + joinandtest :: String -> FilePath -> IO String + joinandtest sofar component = do + let jed = combine sofar component + exists <- doesDirectoryExist jed + unless exists (createDirectory jed) + return jed + (ldir, lname) = splitFileName $ if disccount track == 1 + then getlocalname (dlfmt opts) track [] + else getlocalname (dlfmt_m opts) track [] + getlocalname [] tr [] = ext tr + getlocalname [] tr (a:acc) + | a == ext tr = concat $ reverse (a:acc) + | otherwise = concat $ reverse (ext tr:a:acc) + getlocalname (Txt s:st) tr acc = getlocalname st tr (s:acc) + getlocalname (IntSub s:st) tr acc = getlocalname st tr ((show$s tr):acc) + getlocalname (StrSub s:st) tr acc = getlocalname st tr (s tr:acc) + +prepart opts track = do + trackdir <- (liftM $dropFileName.snd) $ preptrack opts track + let artname = takeFileName $ arturl track + return (arturl track, combine trackdir artname) + +process' opts f = + do + (action, expiry, tracks) <- readfile f (repu opts) (repapo opts) + unless (action == "download") $ throwError ("Unrecognized EMX action: "++action++". Skipping file "++f) + now <- liftIO getCurrentTime + let exp = readTime defaultTimeLocale "%m/%d/%Y %H:%M" expiry + unless (now < exp) $ throwError ("EMX file "++f++" has expired!") + dlp <- liftIO $ findPathAndName "wget" `mplus` findPathAndName "curl" + let dler = case dlp of + Nothing -> dlnative + Just (path, "wget") -> dlwget path + Just (path, "curl") -> dlcurl path + mapM_ (liftIO.dler.preptrack opts) tracks + when (get_art opts) $ mapM_ (liftIO.artdl dler.prepart opts) tracks + return () + +process o f = do + r <- runErrorT $ process' o f + case r of + (Left e) -> putStrLn e + _ -> return () + +main :: IO () +main = do + args <- getArgs + eopts <- readopts + case eopts of + (Right opts) -> mapM_ (process opts) args + (Left e) -> do + putStrLn $ "Error reading options: " ++ e + exitFailure