diff --git a/Bitly.cabal b/Bitly.cabal new file mode 100644 --- /dev/null +++ b/Bitly.cabal @@ -0,0 +1,44 @@ +Name: Bitly +Version: 0.0.1 +Cabal-version: >= 1.2 +Build-type: Simple + +Stability: experimental +Category: Web +License: BSD3 +License-file: LICENSE +Maintainer: Sergey Astanin + +Synopsis: A library and a command line tool to access bit.ly URL shortener. +Description: + This package allows to use bit.ly and j.mp URL + shortening service from Haskell. Currently it supports + shorten and expand requests. + . + API key is required. Please find yours at . + . + An optional command line utility is provided (use `-f buildCLI` to build it). + +Homepage: http://bitbucket.org/jetxee/hs-bitly/ +Bug-reports: http://bitbucket.org/jetxee/hs-bitly/issues/ +Tested-with: GHC == 6.10 + +Flag buildCLI + Description: Build a command line tool to access bit.ly service. + Default: False + +Library + Build-depends: + base >= 3 && < 5 + , HTTP >= 4000 + , HaXml + Exposed-modules: Network.Bitly + +Executable bitly + Main-is: bitly.hs + if !flag(buildCLI) + Buildable: False + Build-depends: + filepath + , directory + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright (c) 2009, Sergey Astanin +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * 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. + * Neither the name of the Sergey Astanin nor the names of other + 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 HOLDER 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/Network/Bitly.hs b/Network/Bitly.hs new file mode 100644 --- /dev/null +++ b/Network/Bitly.hs @@ -0,0 +1,94 @@ +-- | This package allows to use @bit.ly@ and @j.mp@ URL shortening service +-- from Haskell programs. See also "Network.TinyURL" module. + +module Network.Bitly + (Account(..), bitlyAccount, jmpAccount, shorten, expand, Result) +where + +import Network.HTTP +import Text.XML.HaXml +import Text.XML.HaXml.Pretty (element, content) + +-- | Service credentials. +data Account = Account + { login :: String, -- ^ bit.ly login name + apikey :: String, -- ^ API key as found at + server :: String -- ^ Server to use, e.g. @http:\/\/api.j.mp@ + } deriving (Read, Show) + +-- | Account to use with bit.ly +bitlyAccount :: Account +bitlyAccount = Account + { login = "", apikey = "", server = "http://api.bit.ly" } + +-- | Account to use with j.mp +jmpAccount :: Account +jmpAccount = Account + { login = "", apikey = "", server = "http://api.j.mp" } + +-- | Either an error message or a modified URL +type Result = Either String String + +-- | Given a long URL, @shorten@ encodes it as a shorter one. +shorten :: Account -- ^ Account to use + -> String -- ^ Long URL + -> IO Result -- ^ Either error or short bit.ly URL +shorten acc url = request acc "shorten" [("longUrl", url)] + [ "bitly", "results", "nodeKeyVal", "shortUrl" ] + +-- | Given a short bit.ly URL, @expand@ decodes it back into a long source URL. +expand :: Account -- ^ Account to use + -> String -- ^ Short bit.ly URL + -> IO Result -- ^ Either error or long source URL +expand acc url = request acc "expand" [("shortUrl", url)] + [ "bitly", "results", code, "longUrl" ] + where code = reverse . takeWhile (/= '/') . reverse $ url -- ending of the URL + + +-- | Internal function to accomodate all types of requests +request :: Account -- ^ Account to use + -> String -- ^ Name of the API request (e.g. @shorten@ or @expand@) + -> [(String,String)] -- ^ Alist of the parameters specific to the request + -> [String] -- ^ Path to the node with the result in the XML response + -> IO Result +request acc path params xmlpath = do + let baseURL = (server acc) ++ "/" ++ path + let params' = loginParams ++ params :: [ (String, String) ] + let reqURL = baseURL ++ "?" ++ (urlEncodeVars params') + let req = getRequest reqURL :: Request String + resp <- simpleHTTP req + case resp of + Left _ -> return $ Left "Network error" + Right resp' -> do + let Document _ _ xmlroot _ = xmlParse "" . rspBody $ resp' + return $ errorOrResult (CElem xmlroot) xmlpath + where + loginParams = + [ ("login", login acc) + , ("apiKey", apikey acc) + , ("format", "xml") + , ("version", "2.0.1") + ] + +-- | Analyze XML response +errorOrResult :: Content -- ^ XML root element + -> [String] -- ^ Path to the node with the result + -> Result +errorOrResult root xmlpath = do + let cs = tag "bitly" /> tag "statusCode" /> txt $ root + case cs of + [] -> Left "No statusCode in response" + (CString _ code:_) -> do + if (code /= "OK") + then + let err = concatMap (render . content) $ + tag "bitly" /> tag "errorMessage" /> txt $ root + in Left $ "Bit.ly error: " ++ err + else + let url' = concatMap (render . content) $ + (foldr (/>) txt $ map tag xmlpath ) $ root + in if null url' + then Left "Result not found" + else Right url' + _ -> Left "Unexpected statusCode in response" + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/bitly.hs b/bitly.hs new file mode 100644 --- /dev/null +++ b/bitly.hs @@ -0,0 +1,63 @@ +module Main where + +import Network.Bitly + +import Control.Applicative ((<$>)) +import Data.Char (isSpace) +import Data.Maybe (fromJust, isJust, isNothing) +import System.Directory (getHomeDirectory) +import System.Environment (getArgs) +import System.Exit (exitFailure, exitSuccess) +import System.FilePath (makeValid, combine) +import System.IO (hPutStrLn, stderr) + +confFileName :: IO String +confFileName = makeValid <$> flip combine ".bitly" <$> getHomeDirectory + +readConfig :: IO (Maybe Account) +readConfig = do + file <- confFileName + conf <- map (brk '=') . lines <$> readFile file `catch` (\_ -> return "") + let l = lookup "login" conf + let k = lookup "apikey" conf + if isJust l && isJust k + then return $ Just bitlyAccount { login = fromJust l, apikey = fromJust k } + else return Nothing + +brk d str = + let (a,b) = break (== d) str + in (trim a, trim . dropWhile (== d) $ b) + +trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse + +errorExit s = hPutStrLn stderr s >> exitFailure + +printModifiedUrl :: (String -> IO Result) -> String -> IO () +printModifiedUrl op url = do + r <- op url + case r of + Left err -> errorExit err + Right url' -> putStrLn url' + +usage = "Usage: bitly ( help | [shorten] [url ...] | expand [url ...] )\n\n\ +\Configuration file format:\n\ +\ login = your_bit.ly_login\n\ +\ apikey = your_API_key" + +main = do + args <- getArgs + if "help" `elem` args || "--help" `elem` args + then putStrLn usage >> exitSuccess + else do + + conf <- readConfig + case conf of + Nothing -> do + f <- confFileName + errorExit $ "Configuration file is incomplete or not found (" ++ f ++ ")" + Just acc -> + case args of + ("expand":urls) -> printModifiedUrl (expand acc) `mapM_` urls + ("shorten":urls) -> printModifiedUrl (shorten acc) `mapM_` urls + _ -> printModifiedUrl (shorten acc) `mapM_` args -- shorten by default +