Commits

kenko committed 90e2dc4

initial import

Comments (0)

Files changed (6)

+syntax: glob
+*~
+*.hi
+*.o
+
+syntax: re
+
+#.*#
+\.#.*
+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 ()
+{-# OPTIONS_GHC -XArrows -XScopedTypeVariables -XNamedFieldPuns #-}
+
+module Emx.Emx where
+
+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 isPrefixOf oldSub 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 "&#039;" "'" else id
+
+mktrack a al e tc t d l au dc dn tn = do
+  artist <- a
+  album <- al
+  ext <- e
+  trackcount <- tc
+  title <- t
+  dlurl <- d
+  label <- l
+  arturl <- au
+  disccount <- dc
+  discnum <- dn
+  tracknum <- tn
+  return Tr {artist, album, ext, trackcount, title, dlurl, label, arturl,
+             disccount, discnum, tracknum}
+
+gettrack repu repapo = atTag "TRACK" >>>
+           (proc t -> do
+              artist <- c <<< tagtext "ARTIST" -< t
+              album <- c <<< tagtext "ALBUM"-< t
+              title <- c <<< tagtext "TITLE"-< t
+              ext <- tagtext "EXTENSION" -< t
+              dlurl <- tagtext "TRACKURL" -< t
+              label <- c <<< tagtext "LABEL" -< t
+              arturl <- tagtext "ALBUMART" -< t
+              disccount <- rtag "DISCCOUNT" -< t
+              discnum <- rtag "DISCNUM" -< t
+              tc <- rtag "TRACKCOUNT" -< t
+              tracknum <- tr <<< rtag "TRACKNUM" -< t
+              returnA -< mktrack artist album ext tc title dlurl label arturl disccount discnum tracknum)
+    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 $ (take 2 . show)
+
+collect repu repapo = atTag "PACKAGE" >>> (tagtext "ACTION" &&& tagtext "EXP_DATE" &&& (listA $ gettrack repu repapo)) >>> arr f
+    where
+      f (action, (exp, tracks)) = do
+        t <- sequence tracks
+        a <- action
+        e <- exp
+        return (a,e,t)
+
+parseXML = readDocument [withValidate False]
+
+readfile f repu repapo = do
+  [r] <- liftIO $ runX (parseXML f >>> (collect repu repapo))
+  case r of 
+    Right s -> return s
+    Left e -> throwError e
+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 "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 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 s remove = stripped
+    where
+      (_,rest) = span (`elem` remove) s
+      (stripped,_) = break (`elem` remove) rest
+split s splite = (before, after)
+    where
+      (before,rest) = break (==splite) s
+      (_,after) = span (==splite) rest
+stripw = (`strip` " \t\n")
+
+optline :: Options -> String -> Either String Options
+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 (fmap u (subfromstring v))
+                     (\t -> throwError $ t++" (error in option \""++on++"\")")
+
+--readopts :: IO Options
+readopts = do
+  dotfile <- fmap (</> ".emxdownloader") getHomeDirectory
+  h <- openFile dotfile ReadMode
+  contents <- fmap lines $ hGetContents h
+  curdir <- getCurrentDirectory
+  let default_options = Opt True True True curdir default_dlf default_dlfm
+  return (foldM optline default_options contents)
+module Emx.Track where
+
+data Track = Tr {artist, album, title, ext, dlurl, label, arturl, 
+                 tracknum :: String,
+                 disccount, discnum, trackcount :: Int } deriving Show
+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