Commits

Sergey Astanin committed 73dfc65

Drop HaXml dependency, use JSON2. Version bump.

Comments (0)

Files changed (2)

 Name:          Bitly
-Version:       0.0.8
+Version:       0.1.0
 Cabal-version: >= 1.2
 Build-type:    Simple
 
   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

lib/Network/Bitly.hs

 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
   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
+