Bitly-0.0.1: Network/Bitly.hs

-- | 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 <http://bit.ly/account/>
    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"