module Network.Bitly
(Account(..), bitlyAccount, jmpAccount, shorten, expand, Result)
where
import Network.HTTP
import Text.XML.HaXml
import Text.XML.HaXml.Pretty (element, content)
data Account = Account
{ login :: String,
apikey :: String,
server :: String
} deriving (Read, Show)
bitlyAccount :: Account
bitlyAccount = Account
{ login = "", apikey = "", server = "http://api.bit.ly" }
jmpAccount :: Account
jmpAccount = Account
{ login = "", apikey = "", server = "http://api.j.mp" }
type Result = Either String String
shorten :: Account
-> String
-> IO Result
shorten acc url = request acc "shorten" [("longUrl", url)]
[ "bitly", "results", "nodeKeyVal", "shortUrl" ]
expand :: Account
-> String
-> IO Result
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
request :: Account
-> String
-> [(String,String)]
-> [String]
-> 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")
]
errorOrResult :: Content
-> [String]
-> Result
errorOrResult root xmlpath = do
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"