Bitly 0.0.8 → 0.1.0

raw patch · 2 files changed

+34/−36 lines, 2 filesdep +json2dep −HaXml

Dependencies added: json2

Dependencies removed: HaXml

Files

• Bitly.cabal +5/−9
• Network/Bitly.hs +29/−27

@@ -1,5 +1,5 @@ Name:          Bitly-Version:       0.0.8+Version:       0.1.0 Cabal-version: >= 1.2 Build-type:    Simple @@ -15,22 +15,18 @@   shortening service from Haskell. Currently it supports   shorten and expand requests.   .-  API key is required. Please find yours at <https://bitly.com/a/account>.-  .-  Configuration file (`~/.bitly`) format:-  .-  > login = your_bit.ly_login-  > apikey = your_API_key+  API key is required.   .   For command line utility see `bitly-cli` package.  Homepage:      http://bitbucket.org/jetxee/hs-bitly/ Bug-reports:   http://bitbucket.org/jetxee/hs-bitly/issues/-Tested-with:   GHC == 7.2.1+Tested-with:   GHC == 7.0.3, GHC == 7.2.1  Library   Build-depends:                  base >= 3 && < 5                , HTTP >= 4000-               , HaXml >= 1.20 && < 1.23+               , json2 >= 0.8   Exposed-modules: Network.Bitly+  Ghc-options:  -Wall

@@ -6,11 +6,11 @@ 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) +import Data.JSON2 (Json(..))+import Data.JSON2.Parser (parseJson)+import Data.JSON2.Query (getFromKey, (>>>))+ -- | Service credentials. data Account = Account   { login  :: String,   -- ^ bit.ly login name@@ -69,36 +69,38 @@   case resp of     Left _ -> return $ Left "Network error"     Right resp' -> do-      let doc = xmlParse "" . rspBody $ resp'-      return $ errorOrResult doc xmlpath+      return $ errorOrResult (rspBody resp') xmlpath   where     loginParams =              [ ("login", login acc)              , ("apiKey", apikey acc)-             , ("format", "xml")+             , ("format", "json")              , ("version", "2.0.1")              ] --- | Analyze XML response-errorOrResult :: Document Posn -- ^ Parsed XML document+-- | Analyze JSON response+errorOrResult :: String     -- ^ Server response               -> [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"+errorOrResult response path = do+  case (parseJson response) of+    Left parseError -> Left (show parseError)+    Right json ->+       let code' = query ["bitly", "statusCode"] json+           err' = query ["bitly", "errorMessage"] json+           url' = query path json+       in case (code',err',url') of+          (Just "OK", _, Just "") -> Left "Empty result"+          (Just "OK", _, Just url) -> Right url+          (Just code, Just err, _) -> Left $ "Bit.ly error: " ++ err+          (Just code, Nothing, _) -> Left $ "Bit.ly error: statusCode = " ++ code+          (Nothing, _, _) -> Left $ "No statusCode in response" +  where+  query :: [String] -> Json -> Maybe String+  query path json =+     let search = foldr1 (>>>) . map getFromKey $ path+     in  case (search json) of+         (JString str:_) -> Just str+         _               -> Nothing+