-- | 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, expand, Result)
where

import Network.HTTP

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
    apikey :: String,   -- ^ API key as found at <http://bit.ly/account/>
    server :: String    -- ^ Server to use, e.g. @http:\/\/api.j.mp@
  } deriving (Read, Show)

-- | Account to use with bit.ly
bitlyAccount :: Account
bitlyAccount = Account
  { login = "", apikey = "", server = "http://api.bit.ly" }

-- | Account to use with j.mp
jmpAccount :: Account
jmpAccount = Account
  { login = "", apikey = "", server = "http://api.j.mp" }

-- | Either an error message or a modified URL
type Result = Either String String

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

-- | 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 = 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
      return $ errorOrResult (rspBody resp') xmlpath
  where
    loginParams =
             [ ("login", login acc)
             , ("apiKey", apikey acc)
             , ("format", "json")
             , ("version", "2.0.1")
             ]

-- | Analyze JSON response
errorOrResult :: String     -- ^ Server response
              -> [String]   -- ^ Path to the node with the result
              -> Result
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