diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,24 @@
+Copyright (c) Stefan Kersten 2008
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+2. 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.
+
+THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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/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/Sound/Freesound.hs b/Sound/Freesound.hs
new file mode 100644
--- /dev/null
+++ b/Sound/Freesound.hs
@@ -0,0 +1,172 @@
+-- | This module provides access to the Freesound Project, a database of
+-- Creative Commons licensed sounds.
+--
+-- *
+--
+-- *
+module Sound.Freesound (
+ -- * The Freesound monad
+ Freesound,
+ withFreesound,
+ -- * Error handling
+ Error(..), errorString,
+ -- * Sample handles
+ Sample(..),
+ -- * API methods
+ search,
+ Similarity(..), searchSimilar,
+ propertiesXML, properties,
+ download
+) where
+
+import Data.List (find, intercalate, stripPrefix)
+import Data.Maybe (listToMaybe, mapMaybe)
+import Network.Curl
+import qualified Network.Curl.Easy as Curl
+import Control.Monad.Error (ErrorT(..), MonadError, MonadIO, liftIO, noMsg, strMsg, throwError)
+import Control.Monad.Reader (MonadReader, ReaderT(..), ask)
+import qualified Control.Monad.Error as Error
+import Numeric (readDec)
+import qualified Text.XML.Light as XML
+
+import Sound.Freesound.Properties (Properties)
+import qualified Sound.Freesound.Properties as Properties
+import Sound.Freesound.Query (Query)
+import qualified Sound.Freesound.Query as Query
+import Sound.Freesound.Sample (Sample(..))
+import qualified Sound.Freesound.Sample as Sample
+import qualified Sound.Freesound.URL as URL
+import Sound.Freesound.Util (findString, readMaybe)
+
+mkURL :: String -> URLString
+mkURL page = baseURL ++ "/" ++ page
+
+-- The various API URLs.
+baseURL = "http://www.freesound.org"
+loginURL = mkURL "forum/login.php"
+loginRedirect = "../index.php"
+searchURL = mkURL "searchTextXML.php"
+searchSimilarURL = mkURL "searchSimilarXML.php"
+xmlURL = mkURL "samplesViewSingleXML.php"
+audioURL = mkURL "samplesDownload.php"
+
+-- | Curl options used by default in all the interaction with the database.
+defaultCurlOptions :: [CurlOption]
+defaultCurlOptions = [
+ -- Some servers require this to be set
+ CurlUserAgent "libcurl-agent/1.0",
+ -- Enable cookie handling; cookies are passed around in the session
+ -- handle and not saved to disk
+ CurlCookieFile ""
+ ]
+
+-- | Error type.
+data Error =
+ Error String
+ | CurlError CurlCode
+ | LoginError
+ | XMLError
+ | UnknownError
+ deriving (Show)
+
+instance Error.Error Error where
+ noMsg = UnknownError
+ strMsg s = Error s
+
+-- | Convert an 'Error' into a 'String'.
+errorString :: Error -> String
+errorString (Error s) = s
+errorString (CurlError c) = maybe s id (stripPrefix "Curl" (show c))
+ where s = show c
+errorString e = show e
+
+-- | Curl handle.
+type Handle = Curl
+
+-- | The 'Freesound' monad.
+
+-- Adds an environment (the 'Curl' handle) and error handling to the 'IO'
+-- monad. Actions in the 'Freesound' monad can only be executed by
+-- 'withFreesound', which handles all the initialization and cleanup details.
+newtype Freesound a = Freesound { runFreesound :: ReaderT Handle (ErrorT Error IO) a }
+ deriving (Functor, Monad, MonadError Error, MonadIO, MonadReader Handle)
+
+-- | Make a request using 'Handle' and converting propagating failure codes
+-- to the ErrorT monad.
+request :: URLString -> [CurlOption] -> Freesound CurlResponse
+request url options = do
+ curl <- ask
+ resp <- liftIO $ do_curl curl url (defaultCurlOptions ++ options)
+ case respCurlCode resp of
+ CurlOK -> return resp
+ code -> throwError (CurlError code)
+
+-- | Make a request and parse the returned XML data.
+requestXML :: URLString -> [CurlOption] -> Freesound XML.Element
+requestXML url options = do
+ resp <- request url options
+ case XML.parseXMLDoc (respBody resp) of
+ Nothing -> throwError XMLError
+ Just xml -> return xml
+
+-- | Log into freesound.
+login :: String -> String -> Freesound ()
+login user password = do
+ resp <- request loginURL opts
+ -- Check for login success (duh!)
+ -- TODO: Figure out a better way
+ case findString "logged" (respBody resp) of
+ Nothing -> throwError LoginError
+ _ -> return ()
+ where
+ post = URL.postFields [
+ ("username", user),
+ ("password", password),
+ ("login", "login"),
+ ("redirect", loginRedirect) ]
+ opts = [ CurlPostFields post,
+ -- CurlCookieJar cookieFile,
+ CurlFollowLocation True ]
+
+-- | Log into Freesound with and perform an action in the 'Freesound' monad.
+withFreesound :: String -> String -> Freesound a -> IO (Either Error a)
+withFreesound user password f =
+ withCurlDo $ liftIO Curl.initialize >>= runErrorT . runReaderT action
+ where action = runFreesound (login user password >> f)
+
+-- | Search the Freesound database.
+search :: Query -> Freesound [Sample]
+search query = Sample.listFromXML `fmap` requestXML searchURL opts
+ where opts = [ CurlPostFields (Query.toPostFields query) ]
+
+-- | Similarity type used by 'searchSimilar'.
+data Similarity = Similar | Dissimilar deriving (Eq, Show)
+
+-- | Search samples similar (or dissimilar) to a 'Sample'.
+searchSimilar :: Similarity -> Sample -> Freesound [Sample]
+searchSimilar similarity sample = Sample.listFromXML `fmap` requestXML url []
+ where
+ url = URL.addParams params searchSimilarURL
+ params = [ ("id", show (sampleId sample)),
+ ("inverse", case similarity of
+ Similar -> "false"
+ Dissimilar -> "true") ]
+
+-- | Get the properties of a 'Sample' as an XML document.
+propertiesXML :: Sample -> Freesound XML.Element
+propertiesXML sample = requestXML url []
+ where url = URL.addParams [("id", show (sampleId sample))] xmlURL
+
+-- | Get the properties of a 'Sample'.
+properties :: Sample -> Freesound Properties
+properties sample = do
+ xml <- propertiesXML sample
+ let props = Properties.listFromXML xml
+ case find ((== sampleId sample) . Properties.sampleId) props of
+ 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 sample = respBody `fmap` request url []
+ where url = URL.addParams [("id", show (sampleId sample))] audioURL
diff --git a/Sound/Freesound/Properties.hs b/Sound/Freesound/Properties.hs
new file mode 100644
--- /dev/null
+++ b/Sound/Freesound/Properties.hs
@@ -0,0 +1,147 @@
+module Sound.Freesound.Properties (
+ User(..),
+ Description(..),
+ Statistics(..),
+ Tag,
+ Properties(..),
+ fromXML, listFromXML
+) where
+
+import Data.Maybe (mapMaybe)
+import Network.Curl (URLString)
+import Sound.Freesound.Util
+import Text.XML.Light (unqual)
+import qualified Text.XML.Light as XML
+
+-- | User of the Freesound database.
+data User = User {
+ userId :: Int,
+ userName :: String
+} deriving (Eq, Show)
+
+-- | Description of a 'Sample', containing user and text.
+data Description = Description User String deriving (Eq, Show)
+
+-- | Tag (a single word) for describing a 'Sound'
+type Tag = String
+
+-- | Statistics of a 'Sample' in the database.
+data Statistics = Statistics {
+ downloads :: Int,
+ rating :: (Int, Int)
+} deriving (Eq, Show)
+
+-- | Properties of a 'Sample' in the database.
+data Properties = Properties {
+ sampleId :: Int,
+
+ user :: User,
+ date :: String,
+ originalFileName :: String,
+ statistics :: Statistics,
+
+ image :: URLString,
+ preview :: URLString,
+ colors :: URLString,
+
+ -- descriptors ??
+ -- parent ??
+ -- geotag ??
+
+ extension :: String,
+ sampleRate :: Int,
+ bitRate :: Int,
+ bitDepth :: Int,
+ channels :: Int,
+ duration :: Double,
+ fileSize :: Int,
+
+ descriptions :: [Description],
+ tags :: [Tag]
+
+ -- comments ??
+} deriving (Eq, Show)
+
+-- | Read a 'User' value from an 'XML.Element' in the 'Maybe' monad.
+userFromXML :: XML.Element -> Maybe User
+userFromXML e = do
+ _userId <- XML.findAttr (unqual "id") e >>= readMaybe
+ _userName <- XML.findChild (unqual "name") e >>= return . XML.strContent
+ return (User _userId _userName)
+
+-- | Read a rating from an 'XML.Element' in the 'Maybe' monad.
+ratingFromXML :: XML.Element -> Maybe (Int, Int)
+ratingFromXML e = do
+ count <- findAttr "count" e >>= readMaybe
+ value <- strContent e >>= readMaybe
+ return (count, value)
+
+-- | Read a 'Statistics' value from an 'XML.Element' in the 'Maybe' monad.
+statisticsFromXML :: XML.Element -> Maybe Statistics
+statisticsFromXML e = do
+ _downloads <- findChild "downloads" e >>= strContent >>= readMaybe
+ _rating <- findChild "rating" e >>= ratingFromXML
+ return (Statistics _downloads _rating)
+
+-- | Read a 'Description' value from an 'XML.Element' in the 'Maybe' monad.
+descriptionFromXML :: XML.Element -> Maybe Description
+descriptionFromXML e = do
+ _user <- userFromXML e
+ _text <- findChild "text" e >>= strContent
+ return (Description _user _text)
+
+-- | Read a list of 'Description's from an 'XML.Element' in the 'Maybe' monad.
+descriptionsFromXML :: XML.Element -> Maybe [Description]
+descriptionsFromXML = return . mapMaybe descriptionFromXML . findChildren "description"
+
+-- | Read a list of 'Tag's from an 'XML.Element' in the 'Maybe' monad.
+tagsFromXML :: XML.Element -> Maybe [Tag]
+tagsFromXML = return . map XML.strContent . findChildren "tag"
+
+-- | Read a 'Properties' value from an 'XML.Element' in the 'Maybe' monad.
+fromXML :: XML.Element -> Maybe Properties
+fromXML e = do
+ _sampleId <- findAttr "id" e >>= readMaybe
+ _user <- findChild "user" e >>= userFromXML
+ _date <- findChild "date" e >>= strContent
+ _originalFileName <- findChild "originalFilename" e >>= strContent
+ _statistics <- findChild "statistics" e >>= statisticsFromXML
+ _image <- findChild "image" e >>= strContent
+ _preview <- findChild "preview" e >>= strContent
+ _colors <- findChild "colors" e >>= strContent
+ _extension <- findChild "extension" e >>= strContent
+ _sampleRate <- findChild "samplerate" e >>= strContent >>= readMaybe
+ _bitRate <- findChild "bitrate" e >>= strContent >>= readMaybe
+ _bitDepth <- findChild "bitdepth" e >>= strContent >>= readMaybe
+ _channels <- findChild "channels" e >>= strContent >>= readMaybe
+ _duration <- findChild "duration" e >>= strContent >>= readMaybe
+ _fileSize <- findChild "filesize" e >>= strContent >>= readMaybe
+ _descriptions <- findChild "descriptions" e >>= descriptionsFromXML
+ _tags <- findChild "tags" e >>= tagsFromXML
+ return $ Properties {
+ sampleId = _sampleId,
+
+ user = _user,
+ date = _date,
+ originalFileName = _originalFileName,
+ statistics = _statistics,
+
+ image = _image,
+ preview = _preview,
+ colors = _colors,
+
+ extension = _extension,
+ sampleRate = _sampleRate,
+ bitRate = _bitRate,
+ bitDepth = _bitDepth,
+ channels = _channels,
+ duration = _duration,
+ fileSize = _fileSize,
+
+ descriptions = _descriptions,
+ tags = _tags
+ }
+
+-- | Read a list of 'Properties' from an 'XML.Element'.
+listFromXML :: XML.Element -> [Properties]
+listFromXML = mapMaybe fromXML . XML.findChildren (unqual "sample")
diff --git a/Sound/Freesound/Query.hs b/Sound/Freesound/Query.hs
new file mode 100644
--- /dev/null
+++ b/Sound/Freesound/Query.hs
@@ -0,0 +1,31 @@
+module Sound.Freesound.Query (
+ Query(..),
+ stringQuery,
+ toPostFields
+) where
+
+import qualified Sound.Freesound.URL as URL
+
+-- | A 'Query' type for searching the database.
+data Query = Query {
+ string :: String, -- ^ The query string
+ minDur :: Maybe Double, -- ^ Minimum duration in seconds
+ maxDur :: Maybe Double, -- ^ Maximum duration in seconds
+ bitRate :: Maybe Int, -- ^ Bit rate of the soundfile
+ bitDepth :: Maybe Int, -- ^ Bit depth of the soundfile
+ sampleRate :: Maybe Int -- ^ Sample rate of the soundfile
+}
+
+-- | Construct a 'Query' to search the database for a 'String'.
+stringQuery :: String -> Query
+stringQuery s = Query s Nothing Nothing Nothing Nothing Nothing
+
+-- | Convert a query to POST request fields.
+toPostFields :: Query -> [String]
+toPostFields query = URL.postFields [ x | Just x <- [
+ Just ("search", string query),
+ fmap ((,) "durationMin" . show) (minDur query),
+ fmap ((,) "durationMax" . show) (maxDur query),
+ fmap ((,) "bitrate" . show) (bitRate query),
+ fmap ((,) "bitdepth" . show) (bitDepth query),
+ fmap ((,) "samplerate" . show) (sampleRate query) ] ]
diff --git a/Sound/Freesound/URL.hs b/Sound/Freesound/URL.hs
new file mode 100644
--- /dev/null
+++ b/Sound/Freesound/URL.hs
@@ -0,0 +1,21 @@
+module Sound.Freesound.URL (
+ postFields, addParams
+) where
+
+import Data.List (intercalate)
+import Network.Curl (URLString)
+
+-- | Construct a POST field from a key/value pair.
+postField :: String -> String -> String
+postField k v = k ++ "=" ++ v
+
+postFields :: [(String, String)] -> [String]
+postFields = map (uncurry postField)
+
+addParams :: [(String, String)] -> URLString -> URLString
+addParams [] u = u
+addParams (p:ps) u = addpn ps (addp1 p u)
+ where
+ addp1 (k, v) u = u ++ "?" ++ (postField k v)
+ addpn [] u = u
+ addpn ((k, v):rest) u = u ++ "&" ++ postField k v ++ addpn rest u
diff --git a/Sound/Freesound/Util.hs b/Sound/Freesound/Util.hs
new file mode 100644
--- /dev/null
+++ b/Sound/Freesound/Util.hs
@@ -0,0 +1,42 @@
+module Sound.Freesound.Util (
+ readMaybe,
+ findAttr,
+ findChild,
+ findChildren,
+ strContent,
+ findString
+) where
+
+import Data.List (isPrefixOf)
+import qualified Text.XML.Light as XML
+
+-- | Find substring.
+findString :: String -> String -> Maybe String
+findString "" xs = Just xs
+findString a "" = Nothing
+findString a xs
+ | isPrefixOf a xs = Just xs
+findString a (_:xs) = findString a xs
+
+-- | Read a value from a 'String', returning 'Nothing' when the parse fails.
+readMaybe :: (Read a) => String -> Maybe a
+readMaybe s = case reads s of
+ [(a, "")] -> Just a
+ _ -> Nothing
+
+-- | Find an attribute of an 'XML.Element'.
+findAttr :: String -> XML.Element -> Maybe String
+findAttr name = XML.findAttr (XML.unqual name)
+
+-- | Find a child element of an 'XML.Element'.
+findChild :: String -> XML.Element -> Maybe XML.Element
+findChild name = XML.findChild (XML.unqual name)
+
+-- | Find all child elements of an 'XML.Element'.
+findChildren :: String -> XML.Element -> [XML.Element]
+findChildren name = XML.findChildren (XML.unqual name)
+
+-- | Return the string content of an 'XML.Element' in the 'Maybe' monad.
+strContent :: XML.Element -> Maybe String
+strContent = return . XML.strContent
+
diff --git a/freesound.cabal b/freesound.cabal
new file mode 100644
--- /dev/null
+++ b/freesound.cabal
@@ -0,0 +1,45 @@
+name: freesound
+version: 0.0.1
+synopsis: Access the Freesound Project database
+description: Access the Freesound Project database. The Freesound
+ Project is a collaborative database of Creative Commons
+ licensed sounds.
+ .
+
+ .
+
+license: BSD3
+license-file: LICENSE
+category: Sound, Web
+copyright: Copyright (c) Stefan Kersten 2008
+author: Stefan Kersten
+maintainer: Stefan Kersten
+stability: provisional
+homepage: http://code.haskell.org/~StefanKersten/code/freesound
+tested-with: GHC == 6.10.1
+build-type: Simple
+cabal-version: >= 1.2
+
+library
+ exposed-modules: Sound.Freesound
+ Sound.Freesound.Properties
+ Sound.Freesound.Query
+ 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.*
+
+ extensions: GeneralizedNewtypeDeriving
+
+ ghc-options: -O2 -funbox-strict-fields
+
+executable freesound
+ hs-source-dirs: ., freesound
+ main-is: Main.hs
+ extensions: GeneralizedNewtypeDeriving,
+ TemplateHaskell
diff --git a/freesound/Main.hs b/freesound/Main.hs
new file mode 100644
--- /dev/null
+++ b/freesound/Main.hs
@@ -0,0 +1,233 @@
+-- | Access the freesound database from the command line.
+--
+-- /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 System.Exit
+import System.IO
+import System.Environment (getArgs)
+
+data Options = Options
+ { optHelp_ :: Bool
+ , optUser_ :: Maybe String
+ , optPassword_ :: Maybe String
+ , optSearch_ :: SearchOptions
+ , optSearchSimilar_ :: SearchSimilarOptions
+ , optProperties_ :: PropertiesOptions
+ , optDownload_ :: DownloadOptions
+ } deriving (Eq, Show)
+
+data SearchOptions = SearchOptions
+ {
+ } deriving (Eq, Show)
+
+data SearchSimilarOptions = SearchSimilarOptions
+ { optSimilarity_ :: Similarity
+ } deriving (Eq, Show)
+
+data PropertiesOptions = PropertiesOptions
+ { optXML_ :: Bool
+ } deriving (Eq, Show)
+
+data DownloadOptions = DownloadOptions
+ { optOutputFile_ :: Maybe FilePath
+ } deriving (Eq, Show)
+
+$( deriveAccessors ''Options )
+-- $( deriveAccessors ''SearchOptions )
+$( deriveAccessors ''SearchSimilarOptions )
+$( deriveAccessors ''PropertiesOptions )
+$( deriveAccessors ''DownloadOptions )
+
+type Action = Freesound ()
+type Result = Either String Action
+
+data Command = Command {
+ cmdOptions :: [OptDescr (Options -> Options)],
+ cmdHelp :: String,
+ cmdAction :: Options -> [String] -> Result
+}
+
+defaultOptions :: Options
+defaultOptions = Options
+ { optHelp_ = False
+ , optUser_ = Nothing
+ , optPassword_ = Nothing
+ , optSearch_ = SearchOptions { }
+ , optSearchSimilar_ = SearchSimilarOptions {
+ optSimilarity_ = Similar }
+ , optProperties_ = PropertiesOptions {
+ optXML_ = False }
+ , optDownload_ = DownloadOptions {
+ optOutputFile_ = Nothing }
+ }
+
+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."
+ ]
+
+searchOptions :: [OptDescr (Options -> Options)]
+searchOptions = [ ]
+
+searchSimilarOptions :: [OptDescr (Options -> Options)]
+searchSimilarOptions =
+ [ Option [] ["dissimilar"]
+ (NoArg (optSearchSimilar ^: optSimilarity ^= Dissimilar))
+ "Dissimilar"
+ ]
+
+propertiesOptions :: [OptDescr (Options -> Options)]
+propertiesOptions =
+ [ 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"
+ ]
+
+-- Utilities
+
+readSample :: [String] -> Either String Sample
+readSample [] = Left "Missing sample ID"
+readSample (x:_) = case readMaybe x of
+ Nothing -> Left "Invalid sample ID"
+ Just i -> Right (Sample i)
+
+printSamples :: [Sample] -> Action
+printSamples = liftIO . mapM_ (print . sampleId)
+
+-- Commands
+
+do_search :: Options -> [String] -> Result
+do_search options args = Right $ do
+ samples <- search (stringQuery $ unwords args)
+ printSamples samples
+
+do_searchSimilar :: Options -> [String] -> Result
+do_searchSimilar options args =
+ case readSample args of
+ Left e -> Left e
+ Right s -> Right $ searchSimilar (options^.optSearchSimilar^.optSimilarity) s >>= printSamples
+
+do_properties :: Options -> [String] -> Result
+do_properties options args =
+ case readSample args of
+ Left e -> Left e
+ Right s -> if options^.optProperties^.optXML
+ then Right $ propertiesXML s >>= liftIO . putStrLn . XML.ppElement
+ else Right $ properties s >>= liftIO . print
+
+do_download :: Options -> [String] -> Result
+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
+
+commands :: [(String, Command)]
+commands = [
+ ("search", Command searchOptions "freesound search [OPTION...] PREDICATES.." do_search),
+ ("similar", Command searchSimilarOptions "freesound similar [OPTION...] SAMPLE" do_searchSimilar),
+ ("properties", Command propertiesOptions "freesound properties [OPTION...] SAMPLE" do_properties),
+ ("download", Command downloadOptions "freesound download [OPTION...] SAMPLE" do_download)
+ ]
+
+printHelp :: ExitCode -> String -> [OptDescr (Options -> Options)] -> IO a
+printHelp code header options = do
+ hPutStr stderr (usageInfo header options)
+ exitWith code
+
+parseOptions :: String -> [OptDescr (Options -> Options)] -> [String] -> IO (Options, [String])
+parseOptions header options argv =
+ case getOpt Permute options argv of
+ (o, n, []) -> let o' = foldl (flip ($)) defaultOptions o in
+ if o'^.optHelp
+ then printHelp ExitSuccess header options
+ else return (o', n)
+ (_, _, es) -> ioError (userError (concat es ++ usageInfo header options))
+
+globalHelp :: String
+globalHelp = "Usage: freesound COMMAND [OPTION...] [ARG...]\
+ \\n\n\
+ \Try freesound COMMAND --help for individual command options.\
+ \\n\n\
+ \Commands:\n\n\
+ \ search\n\
+ \ similar\n\
+ \ properties\n\
+ \ downloads\n\n\
+ \Global options:\n"
+
+-- | Read username from stdin.
+getUser :: IO String
+getUser = putStrLn "User:" >> hGetLine stdin
+
+-- | Read password from stdin.
+getPassword :: IO String
+getPassword = do
+ putStrLn "Password:"
+ echo <- hGetEcho stdin
+ hSetEcho stdin False
+ password <- hGetLine stdin
+ hSetEcho stdin echo
+ return password
+
+-- | Read credentials that are still unknown from stdin.
+getCredentials :: Maybe String -> Maybe String -> IO (String, String)
+getCredentials user password = do
+ user' <- maybe getUser return user
+ password' <- maybe getPassword return password
+ return (user', password')
+
+-- | Perform a command with the given user name and password.
+doCommand :: String -> String -> Action -> IO ()
+doCommand user password action = do
+ res <- withFreesound user password action
+ case res of
+ Left e -> putStrLn ("ERROR: " ++ errorString e)
+ Right r -> return ()
+
+main :: IO ()
+main = do
+ argv <- getArgs
+ case argv of
+ [] -> printHelp (ExitFailure 1) globalHelp globalOptions
+ (cmdName:rest) ->
+ case lookup cmdName commands of
+ Nothing ->
+ printHelp (ExitFailure 1) globalHelp globalOptions
+ Just cmd -> do
+ (options, args) <- parseOptions (cmdHelp cmd) (globalOptions ++ cmdOptions cmd) rest
+ case cmdAction cmd options args of
+ Left e -> putStrLn ("ERROR: " ++ e)
+ Right a -> do
+ (user, password) <- getCredentials (options^.optUser) (options^.optPassword)
+ doCommand user password a