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 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" }
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 ++ "\"]"