Commits

Sergey Astanin committed 01cfa93

Network.Bitly.expand, DRY-refactoring, haddock comments

  • Participants
  • Parent commits defbdd2

Comments (0)

Files changed (1)

 -- from Haskell programs. See also "Network.TinyURL" module.
 
 module Network.Bitly
-  (Account(..), bitlyAccount, jmpAccount, shorten, Result)
+  (Account(..), bitlyAccount, jmpAccount, shorten, expand, Result)
 where
 
 import Network.HTTP
 import Text.XML.HaXml
 import Text.XML.HaXml.Pretty (element, content)
 
-import Control.Applicative ((<$>), (<*>))
+import Control.Applicative ((<$>))
 import Control.Monad (liftM2)
 
--- | Service credentials
+-- | Service credentials.
 data Account = Account
   { username :: String, -- ^ bit.ly login name
     apikey :: String,   -- ^ API key as found at <http://bit.ly/account/>
   }
 
 -- | Account to use with bit.ly
+bitlyAccount :: Account
 bitlyAccount = Account
   { username = "", apikey = "", server = "http://api.bit.ly" }
 
 -- | Account to use with j.mp
+jmpAccount :: Account
 jmpAccount = Account
   { username = "", apikey = "", server = "http://api.j.mp" }
 
--- | Either error message or modified URL
+-- | Either an error message or a 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
+-- | 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 = importURL $ (server acc) ++ "/" ++ path :: Maybe URL
+  let params' = loginParams ++ params :: [ (String, String) ]
+  let reqURL = foldl (liftM2 $ add_param) baseURL $ Just <$> params' :: Maybe URL
   let req = getRequest <$> exportURL <$> reqURL :: Maybe (Request String)
   case req of
     Nothing -> return $ Left "Bad config"
         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'
+          return $ errorOrResult (CElem xmlroot) xmlpath
   where
-    base = importURL $ (server a) ++ "/shorten" :: Maybe URL
-    params = [ ("login", username a)
-             , ("apiKey", apikey a)
+    loginParams =
+             [ ("login", username acc)
+             , ("apiKey", apikey acc)
              , ("format", "xml")
              , ("version", "2.0.1")
-             , ("longUrl", url) ]
+             ]
+
+-- | 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"
+