diff --git a/Sound/Freesound.hs b/Sound/Freesound.hs --- a/Sound/Freesound.hs +++ b/Sound/Freesound.hs @@ -19,6 +19,7 @@ download ) where +import qualified Data.ByteString.Lazy as BS import Data.List (find, intercalate, stripPrefix) import Data.Maybe (listToMaybe, mapMaybe) import Network.Curl @@ -82,6 +83,7 @@ -- | Curl handle. type Handle = Curl +type Response b = CurlResponse_ [(String, String)] b -- | The 'Freesound' monad. @@ -93,10 +95,10 @@ -- | Make a request using 'Handle' and converting propagating failure codes -- to the ErrorT monad. -request :: URLString -> [CurlOption] -> Freesound CurlResponse +request :: CurlBuffer b => URLString -> [CurlOption] -> Freesound (Response b) request url options = do curl <- ask - resp <- liftIO $ do_curl curl url (defaultCurlOptions ++ options) + resp <- liftIO $ do_curl_ curl url (defaultCurlOptions ++ options) case respCurlCode resp of CurlOK -> return resp code -> throwError (CurlError code) @@ -104,7 +106,7 @@ -- | Make a request and parse the returned XML data. requestXML :: URLString -> [CurlOption] -> Freesound XML.Element requestXML url options = do - resp <- request url options + resp <- request url options :: Freesound (Response BS.ByteString) case XML.parseXMLDoc (respBody resp) of Nothing -> throwError XMLError Just xml -> return xml @@ -166,7 +168,7 @@ Just p -> return p Nothing -> throwError $ Error ("Properties for sample " ++ (show $ sampleId sample) ++ " not found") --- | Download a 'Sample' as a 'String'. -download :: Sample -> Freesound String +-- | Download a 'Sample' as an instance of 'CurlBuffer'. +download :: CurlBuffer b => Sample -> Freesound b download sample = respBody `fmap` request url [] where url = URL.addParams [("id", show (sampleId sample))] audioURL diff --git a/freesound.cabal b/freesound.cabal --- a/freesound.cabal +++ b/freesound.cabal @@ -1,5 +1,5 @@ name: freesound -version: 0.0.2 +version: 0.1.0 synopsis: Access the Freesound Project database description: Access the Freesound Project database. The Freesound Project is a collaborative database of Creative Commons @@ -11,12 +11,12 @@ license: BSD3 license-file: LICENSE category: Sound, Web -copyright: Copyright (c) Stefan Kersten 2008 +copyright: Copyright (c) Stefan Kersten 2008-2010 author: Stefan Kersten maintainer: Stefan Kersten stability: provisional homepage: http://code.haskell.org/~StefanKersten/code/freesound -tested-with: GHC == 6.10.1 +tested-with: GHC == 6.10.1, GHC == 6.10.4, GHC == 6.12.1 build-type: Simple cabal-version: >= 1.2 @@ -27,13 +27,14 @@ Sound.Freesound.Sample other-modules: Sound.Freesound.URL Sound.Freesound.Util - build-depends: base >= 3, - curl == 1.3.*, - data-accessor == 0.1.*, - data-accessor-template == 0.1.4, - directory >= 1, - mtl == 1.1.*, - xml == 1.3.* + build-depends: base >= 3 && < 5 + , bytestring >= 0.9 && < 1.0 + , curl >= 1.3 && < 1.4 + , data-accessor >= 0.1 && < 0.3 + , data-accessor-template >= 0.1 && < 0.3 + , directory >= 1 + , mtl >= 1.1 + , xml >= 1.3 && < 1.4 extensions: GeneralizedNewtypeDeriving diff --git a/freesound/Main.hs b/freesound/Main.hs --- a/freesound/Main.hs +++ b/freesound/Main.hs @@ -3,21 +3,24 @@ -- /TODO/: -- * flesh out error handling -- -import Control.Monad.Trans (liftIO) -import Sound.Freesound -import Sound.Freesound.Query -import Sound.Freesound.Util -import System.IO (hGetLine, hGetEcho, hSetEcho, stdin) -import Text.XML.Light as XML -import System.Console.GetOpt -import Data.Accessor.Template -import Data.Accessor +import qualified Data.ByteString.Lazy as BS +import Control.Monad.Trans (liftIO) +import Sound.Freesound +import qualified Sound.Freesound.Properties as Props +import Sound.Freesound.Query +import Sound.Freesound.Util +import System.IO (hGetLine, hGetEcho, hSetEcho, stdin) +import Text.XML.Light as XML +import System.Console.GetOpt -import System.Exit -import System.IO -import System.Environment (getArgs) +import Data.Accessor.Template +import Data.Accessor +import System.Exit +import System.IO +import System.Environment (getArgs) + data Options = Options { optHelp_ :: Bool , optUser_ :: Maybe String @@ -37,11 +40,13 @@ } deriving (Eq, Show) data PropertiesOptions = PropertiesOptions - { optXML_ :: Bool + { optXML_ :: Bool } deriving (Eq, Show) data DownloadOptions = DownloadOptions - { optOutputFile_ :: Maybe FilePath + { optOutputFile_ :: Maybe FilePath + , optAddExtension_ :: Bool + , optUseOriginalFileName_ :: Bool } deriving (Eq, Show) $( deriveAccessors ''Options ) @@ -69,21 +74,23 @@ optSimilarity_ = Similar } , optProperties_ = PropertiesOptions { optXML_ = False } - , optDownload_ = DownloadOptions { - optOutputFile_ = Nothing } + , optDownload_ = DownloadOptions + { optOutputFile_ = Nothing + , optAddExtension_ = False + , optUseOriginalFileName_ = False } } globalOptions :: [OptDescr (Options -> Options)] globalOptions = - [ Option ['h'] ["help"] - (NoArg (optHelp ^= True)) - "Print this help message." - ,Option ['u'] ["user"] - (ReqArg (\x -> optUser ^= Just x) "STRING") - "Freesound user name." - ,Option ['p'] ["password"] - (ReqArg (\x -> optPassword ^= Just x) "STRING") - "Freesound password." + [ Option ['h'] ["help"] + (NoArg (optHelp ^= True)) + "Print this help message." + , Option ['u'] ["user"] + (ReqArg (\x -> optUser ^= Just x) "STRING") + "Freesound user name." + , Option ['p'] ["password"] + (ReqArg (\x -> optPassword ^= Just x) "STRING") + "Freesound password." ] searchOptions :: [OptDescr (Options -> Options)] @@ -91,23 +98,29 @@ searchSimilarOptions :: [OptDescr (Options -> Options)] searchSimilarOptions = - [ Option [] ["dissimilar"] - (NoArg (optSearchSimilar ^: optSimilarity ^= Dissimilar)) - "Dissimilar" + [ Option [] ["dissimilar"] + (NoArg (optSearchSimilar ^: optSimilarity ^= Dissimilar)) + "Dissimilar" ] propertiesOptions :: [OptDescr (Options -> Options)] propertiesOptions = - [ Option [] ["xml"] - (NoArg (optProperties ^: optXML ^= True)) - "List xml" + [ Option [] ["xml"] + (NoArg (optProperties ^: optXML ^= True)) + "List xml" ] downloadOptions :: [OptDescr (Options -> Options)] downloadOptions = - [ Option ['o'] ["output-file"] - (ReqArg (\x -> optDownload ^: optOutputFile ^= Just x) "PATH") - "Output file" + [ Option ['o'] ["output-file"] + (ReqArg (\x -> optDownload ^: optOutputFile ^= Just x) "PATH") + "Output file name (overrides --use-original-filename)" + , Option ['e'] ["add-extension"] + (NoArg (optDownload ^: optAddExtension ^= True)) + "Add original extension to output file" + , Option ['O'] ["use-original-filename"] + (NoArg (optDownload ^: optUseOriginalFileName ^= True)) + "Use original file name for output" ] -- Utilities @@ -146,11 +159,15 @@ do_download options args = case readSample args of Left e -> Left e - Right s -> Right $ download s >>= fout - where - fout = case options^.optDownload^.optOutputFile of - Nothing -> liftIO . putStrLn - Just path -> liftIO . writeFile path + Right s -> Right $ do + path <- if options^.optDownload^.optUseOriginalFileName + then properties s >>= return . Just . Props.originalFileName + else case options^.optDownload^.optOutputFile of + Nothing -> return Nothing + Just p -> if options^.optDownload^.optAddExtension + then properties s >>= return . Just . (\props -> p ++ "." ++ Props.extension props) + else return (Just p) + download s >>= maybe (liftIO . BS.putStrLn) (\p -> liftIO . BS.writeFile p) path commands :: [(String, Command)] commands = [