{-# LANGUAGE FlexibleInstances #-}
module Network.LongURL 
    ( CurlInstance(..)
    , longURL
    , SupportedSite(..)
    , supportedSites
    , URLInfo(..)
    ) where

import Network.Curl (Curl, CurlResponse, CurlResponse_(..), do_curl_, method_GET)
import Network.Curl.Code (CurlCode(..))
import Network.Curl.Opts (CurlOption(..))
import Network.Curl.Types (URLString)
import Text.JSON.String (readJSObject, runGetJSON)
import Text.JSON.Types (fromJSObject, fromJSString, JSObject, JSValue(..))
import Util.Codec.Percent (getEncodedString)

import Control.Applicative ((<$>))
import Data.List (intersperse)

data CurlInstance = CurlInstance { curl :: Curl
                                 , userAgent :: String
                                 }

data QueryParam = QueryParam { paramName :: String
                             , paramValue :: String
                             }

class ShowSC a where
    showS :: a -> ShowS

{-
instance Show a => ShowSC a where
    showS = shows
-}

instance ShowSC QueryParam where
    showS (QueryParam { paramName = n, paramValue = v }) = ((getEncodedString n ++ ('=' : getEncodedString v)) ++)

instance ShowSC [QueryParam] where
    showS = foldr1 (.) . (('?' :) :) . intersperse ('&' :) . (showS <$>)

data SupportedSite = SupportedSite { siteName :: String
                                   , domains :: [String]
                                   }

data URLInfo = URLInfo { longURL' :: String
                       , pageTitle :: Maybe String
                       }

simple_get :: CurlInstance -> URLString -> IO String
simple_get ci url = handleResponse =<< do_curl_ (curl ci) url
                    (CurlUserAgent (userAgent ci) : CurlVerbose False : CurlNoProgress True : method_GET)
    where
      handleResponse :: CurlResponse -> IO String
      handleResponse r = do { (CurlResponse { respCurlCode = CurlOK, respBody = b }) <- return r; return b }

getJSArray :: Monad m => JSValue -> m [JSValue]
getJSArray v = do { (JSArray a) <- return v; return a }

getJSString :: Monad m => JSValue -> m String
getJSString v = do { (JSString jss) <- return v; return $ fromJSString jss }

apiSite :: String
apiSite = "http://api.longurl.org"

apiVersion :: String
apiVersion = "v1"

jsonFormat :: QueryParam
jsonFormat = QueryParam { paramName = "format", paramValue = "json" }

-- | Makes a call to the JSON web API
apiCall :: CurlInstance -> String -> [QueryParam] -> IO [(String, JSValue)]
apiCall ci path ps = do
  (Right (JSObject jso)) <- (runGetJSON readJSObject <$>) . simple_get ci
                            $ apiSite ++ ('/' : apiVersion ++ ('/' : path ++ showS (jsonFormat : ps) ""))
  return $ fromJSObject jso

supportedSites :: CurlInstance -> IO [SupportedSite]
supportedSites ci =
    mapM (\(n, ds) -> SupportedSite n <$> (mapM getJSString =<< getJSArray ds)) =<< apiCall ci "services" []

longURL :: CurlInstance -> String -> IO URLInfo
longURL ci url = do
  rec <- apiCall ci "expand" [QueryParam { paramName = "url", paramValue = url }]
  (Just jsURL) <- return $ lookup "long_url" rec
  url' <- getJSString jsURL
  title <- maybe (return Nothing) ((return <$>) . getJSString) $ lookup "title" rec
  return $ URLInfo { longURL' = url', pageTitle = title }

instance Show URLInfo where
    show (URLInfo { longURL' = url', pageTitle = Nothing })    = url'
    show (URLInfo { longURL' = url', pageTitle = Just title }) = url' ++ " [\"" ++ title ++ "\"]"