packages feed

freesound (empty) → 0.0.1

raw patch · 9 files changed

+717/−0 lines, 9 filesdep +basedep +curldep +data-accessorsetup-changed

Dependencies added: base, curl, data-accessor, data-accessor-template, directory, mtl, xml

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Sound/Freesound.hs view
@@ -0,0 +1,172 @@+-- | This module provides access to the Freesound Project, a database of+-- Creative Commons licensed sounds.+--+-- * <http://www.freesound.org/>+--+-- * <http://www.creativecommons.org/>+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
+ Sound/Freesound/Properties.hs view
@@ -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")
+ Sound/Freesound/Query.hs view
@@ -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) ] ]
+ Sound/Freesound/URL.hs view
@@ -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
+ Sound/Freesound/Util.hs view
@@ -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+
+ freesound.cabal view
@@ -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.+                    .+                    <http://www.freesound.org/>+                    .+                    <http://www.creativecommons.org/>+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
+ freesound/Main.hs view
@@ -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