Commits

Sergey Astanin committed 86518d9

Initial commit: Network.Bitly.shorten and command line tool

Comments (0)

Files changed (2)

+-- | 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, Result)
+where
+
+import Network.HTTP
+import Network.URL
+import Text.XML.HaXml
+import Text.XML.HaXml.Pretty (element, content)
+
+import Control.Applicative ((<$>), (<*>))
+import Control.Monad (liftM2)
+
+-- | Service credentials
+data Account = Account
+  { username :: 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@
+  }
+
+-- | Account to use with bit.ly
+bitlyAccount = Account
+  { username = "", apikey = "", server = "http://api.bit.ly" }
+
+-- | Account to use with j.mp
+jmpAccount = Account
+  { username = "", apikey = "", server = "http://api.j.mp" }
+
+-- | Either error message or modified URL
+type Result = Either String String
+
+-- | Given a long URL, shorten encodes it as a shorter one and returns it.
+shorten :: Account -> String -> IO Result
+shorten a url = do
+  let reqURL = foldl (liftM2 $ add_param) base $ Just <$> params :: Maybe URL
+  let req = getRequest <$> exportURL <$> reqURL :: Maybe (Request String)
+  case req of
+    Nothing -> return $ Left "Bad config"
+    Just req'  -> do
+      resp <- simpleHTTP req'
+      case resp of
+        Left _ -> return $ Left "Network error"
+        Right resp' -> do
+          let Document _ _ xmlroot _ = xmlParse "" . rspBody $ resp'
+          let r = CElem xmlroot
+          let cs = tag "bitly" /> tag "statusCode" /> txt $ r
+          case cs of
+            [] -> return $ Left "No statusCode in response"
+            (c:_) -> do
+              let CString _ code = c
+              if (code /= "OK")
+                then
+                  let err = concatMap (render . content) $
+                            tag "bitly" /> tag "errorMessage" /> txt $ r
+                  in  return $ Left $ "Bit.ly error: " ++ err
+                else
+                  let url' = concatMap (render . content) $
+                            tag "bitly" /> tag "results" />
+                            tag "nodeKeyVal" /> tag "shortUrl" /> txt $ r
+                  in  return $ Right url'
+  where
+    base = importURL $ (server a) ++ "/shorten" :: Maybe URL
+    params = [ ("login", username a)
+             , ("apiKey", apikey a)
+             , ("format", "xml")
+             , ("version", "2.0.1")
+             , ("longUrl", url) ]
+module Main where
+
+import Network.Bitly
+import System.Environment (getArgs)
+
+main = do
+  login:key:url:_ <- getArgs
+  let acc = bitlyAccount { username = login , apikey = key }
+  res <- shorten acc url
+  case res of
+    Left msg -> error msg
+    Right url' -> putStrLn url'