module Network.LongURL
( CurlInstance(..)
, longURL
, SupportedSite(..)
, supportedSites
, URLInfo(..)
) where
import Network.Curl (Curl, 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 ((<$>))
data CurlInstance = CurlInstance { curl :: Curl
, userAgent :: String
}
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"
apiCall :: CurlInstance -> String -> IO [(String, JSValue)]
apiCall ci query = do
(Right (JSObject jso)) <- (runGetJSON readJSObject <$>) . simple_get ci
$ apiSite ++ "/" ++ apiVersion ++ "/" ++ query
return $ fromJSObject jso
supportedSites :: CurlInstance -> IO [SupportedSite]
supportedSites ci =
mapM (\(n, ds) -> SupportedSite n <$> (mapM getJSString =<< getJSArray ds)) =<< apiCall ci "services?format=json"
longURL :: CurlInstance -> String -> IO URLInfo
longURL ci url = do
rec <- apiCall ci $ "expand?url=" ++ getEncodedString url ++ "&format=json"
(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 ++ "\"]"