Commits

Sebastián Magrí committed b094582

Initial commit. Right now the executable can fetch downloadable track from SoundCloud. Work is still needed to support the whole SoundCloud API

  • Participants

Comments (0)

Files changed (4)

+Copyright (c) <YEAR>, <OWNER>
+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.
+3. Neither the name of the <ORGANIZATION> nor the names of its
+   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.
+name: hscd
+version: 0.0.1
+category: Network
+license: BSD3
+license-file: LICENSE
+author: Sebastián Ramírez Magrí
+maintainer: Sebastián Ramírez Magrí <sebasmagri@gmail.com>
+stability: experimental
+build-type: Simple
+cabal-version: >= 1.8
+synopsis: A client and library for SoundCloud.com written in Haskell
+description: A client and library for SoundCloud.com written in Haskell
+executable hscd
+           build-depends: aeson
+                        , attoparsec
+                        , base
+                        , bytestring
+                        , ghc-prim
+                        , HTTP
+                        , network
+                        , text
+           main-is: hscd.hs
+           hs-source-dirs: src/
+           ghc-options: -W -Wall

File src/Network/SoundCloud.hs

+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+{-
+  Implementing the SoundCloud API
+-}
+module Network.SoundCloud where
+
+import Data.Aeson
+import qualified Data.ByteString.Lazy.Char8 as StrLazy
+import qualified Data.Text as Txt
+import GHC.Generics (Generic)
+import Network.HTTP
+import System.IO
+
+
+data ScUser = ScUser {
+    userId               :: Int
+  , userPermalink        :: Txt.Text
+  , userName             :: Txt.Text
+  , userUri              :: Txt.Text
+  , userPermalinkUrl     :: Txt.Text
+  , userAvatarUrl        :: Txt.Text
+  } deriving (Show, Generic)
+
+data ScTrack = ScTrack { id                       :: Int
+                       , user_id                  :: Int
+                       , original_content_size :: Int
+                       , downloadable        :: Bool
+                       , title               :: Txt.Text
+                       , original_format      :: Txt.Text
+                       , download_url          :: Txt.Text
+                       } deriving (Show, Generic)
+
+instance FromJSON ScUser
+instance ToJSON   ScUser
+instance FromJSON ScTrack
+instance ToJSON   ScTrack
+
+
+clientId :: Txt.Text
+clientId = "934a79db328a60a0ea459ab9e45c1735"
+
+apiURL :: Txt.Text
+apiURL = "http://api.soundcloud.com"
+
+apiURLS :: Txt.Text
+apiURLS = "https://api.soundcloud.com"
+
+apiMeURLS :: Txt.Text
+apiMeURLS = Txt.append apiURLS "/me"
+
+authURLS :: Txt.Text
+authURLS = "https://soundcloud.com/connect"
+
+tokenURLS :: Txt.Text
+tokenURLS = Txt.append apiURLS "/oauth2/token"
+
+tracksURL :: Txt.Text
+tracksURL = Txt.append apiURL "/tracks"
+
+usersURL :: Txt.Text
+usersURL = Txt.append apiURL "/users"
+
+playlistsURL :: Txt.Text
+playlistsURL = Txt.append apiURL "/playlists"
+
+groupsURL :: Txt.Text
+groupsURL = Txt.append apiURL "/groups"
+
+commentsURL :: Txt.Text
+commentsURL = Txt.append apiURL "/comments"
+
+meURLS :: Txt.Text
+meURLS = apiMeURLS
+
+meConnectionsURLS :: Txt.Text
+meConnectionsURLS = Txt.append apiMeURLS "/connections"
+
+meActivitiesURLS :: Txt.Text
+meActivitiesURLS = Txt.append apiMeURLS "/activities"
+
+appsURLS :: Txt.Text
+appsURLS = Txt.append apiURL "/apps"
+
+resolveURL :: Txt.Text
+resolveURL = Txt.append apiURL "/resolve"
+
+scDownload :: Txt.Text -> IO (Maybe StrLazy.ByteString)
+scDownload url =
+    do res <- simpleHTTP $ getRequest $ Txt.unpack url
+       case res of
+         Left _ -> return Nothing
+         Right r ->
+             case rspCode r of
+               (2,_,_) -> return $ Just $ StrLazy.pack $ rspBody r
+               (3,_,_) ->
+                   case findHeader HdrLocation r of
+                     Nothing -> return Nothing
+                     Just uri -> scDownload (Txt.pack uri)
+               _ -> return Nothing
+
+getJSONText :: Txt.Text -> IO (StrLazy.ByteString)
+getJSONText url = 
+    do result <- scDownload url
+       case result of
+         Nothing    -> return "{}"
+         Just     r -> return r
+
+
+scResolve :: [Char] -> IO ()
+scResolve url =
+    do dat <- getJSONText resolveUrl
+       let o = decode dat :: Maybe ScTrack
+       case o of
+         Nothing  -> StrLazy.putStrLn "Couldn't get anything from response"
+         Just obj ->
+             case downloadable obj of
+               True ->
+                   do let dUrlStr = Txt.concat [download_url obj, "?client_id=", clientId]
+                      let filename = "./" ++ Txt.unpack (title obj) ++ "." ++ Txt.unpack (original_format obj)
+                      StrLazy.putStrLn $ StrLazy.pack ("Fetching to: " ++ filename)
+                      contents <- scDownload dUrlStr
+                      case contents of
+                        Nothing -> StrLazy.putStrLn "Could not fetch file contents"
+                        Just  c ->
+                            do file <- openBinaryFile filename WriteMode
+                               hPutStr file (StrLazy.unpack c)
+                               hClose file
+               False -> StrLazy.putStrLn "Track is not downloadable"
+    where
+        txtUrl = Txt.pack url
+        resolveUrl = Txt.concat [resolveURL, ".json?url=", txtUrl, "&client_id=", clientId]
+
+module Main where
+
+import System.Exit
+import System.IO
+import System.Console.GetOpt
+import System.Environment
+
+import Network.SoundCloud
+
+data Options = Options { optURL :: IO String
+                       , optOutput :: String -> IO ()}
+options :: [OptDescr (Options -> IO Options)]
+options = [
+        Option "u" ["url"]
+            (ReqArg (\arg opt -> return opt { optURL = return arg })
+                "URL")
+            "Track URL"
+      , Option "o" ["output"]
+            (ReqArg
+                (\arg opt -> return opt { optOutput = writeFile arg })
+                "OUTPUT")
+            "Output File"
+      , Option "h" ["help"]
+           (NoArg
+               (\_ -> exitHelp))
+           "Show usage info"
+      ]
+
+defaultOptions :: Options
+defaultOptions = Options
+    { optURL     = exitErrorHelp "use -u to indicate the track's URL"
+    , optOutput  = putStr
+    }
+
+main :: IO ()
+main = do
+     args <- getArgs
+     let (actions, nonOptions, errors) = getOpt RequireOrder options args
+
+     opts <- foldl (>>=) (return defaultOptions) actions
+
+     let Options { optURL = url
+                 , optOutput = output } = opts
+     strUrl <- url
+     scResolve strUrl
+
+
+exitErrorHelp :: String -> IO a
+exitErrorHelp msg = do
+    hPutStrLn stderr msg
+    hPutStrLn stderr ""
+    showHelp
+    exitFailure
+
+showHelp :: IO ()
+showHelp = do
+    prg <- getProgName
+    hPutStrLn stderr (usageInfo prg options)
+    hFlush stderr
+
+exitHelp :: IO a
+exitHelp = do
+    showHelp
+    exitWith ExitSuccess