Bitly-0.0.6: 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.Util (docContent)
import Text.XML.HaXml.Posn (noPos, Posn)
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
    ending d = foldr (\x xs -> if d `elem` xs then xs else x:xs) ""
    code = dropHeadIf (== '/') $ ending '/' url

dropHeadIf :: (a -> Bool) -> [a] -> [a]
dropHeadIf _ [] = []
dropHeadIf p all@(x:xs)
  | p x        = xs
  | otherwise  = all

-- | 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 doc = xmlParse "" . rspBody $ resp'
      return $ errorOrResult doc xmlpath
  where
    loginParams =
             [ ("login", login acc)
             , ("apiKey", apikey acc)
             , ("format", "xml")
             , ("version", "2.0.1")
             ]

-- | Analyze XML response
errorOrResult :: Document Posn -- ^ Parsed XML document
              -> [String]   -- ^ Path to the node with the result
              -> Result
errorOrResult rootelement xmlpath = do
  let root = docContent noPos rootelement
  let cs = tag "bitly" /> tag "statusCode" /> txt $ root
  case cs of
    [] -> Left "No statusCode in response"
    ((CString _ code _):_) ->
          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"