module Network.Factual.API
(
generateToken
, executeQuery
, executeMultiQuery
, get
, executeWrite
, post
, debugQuery
, debugWrite
, Options(..)
, Long
, Token(..)
, urlEncode
) where
import Data.Maybe (fromJust)
import Data.List (intersperse)
import Network.OAuth.Consumer
import Network.OAuth.Http.Request (Request(..), Method(..), parseURL, fromList)
import Network.OAuth.Http.Response (Response(..))
import Network.OAuth.Http.CurlHttpClient (CurlClient(..))
import Network.Curl.Opts (CurlOption(..))
import Data.Aeson (Value, decode)
import Data.Aeson.Encode (encode)
import Data.List.Utils (join)
import Data.Factual.Query
import Network.Curl.Types (Long)
import qualified Data.Factual.Write as W
import qualified Data.Map as M
import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.Factual.Response as F
import qualified Codec.Binary.Url as U
import qualified Codec.Binary.UTF8.String as S
type Key = String
type Secret = String
type Path = String
type Params = M.Map String String
type Body = M.Map String String
data Options = Options { token :: Token,
timeout :: Maybe Long }
generateToken :: Key -> Secret -> Token
generateToken key secret = fromApplication $ Application key secret OOB
executeQuery :: (Query query) => Options -> query -> IO F.Response
executeQuery options query = get options (path query) (params query)
executeMultiQuery :: (Query query) => Options -> M.Map String query -> IO (M.Map String F.Response)
executeMultiQuery options multiMap = do
let queryString = formMultiQueryString $ M.toList multiMap
response <- get'' options queryString
return $ formMultiResponse response $ M.keys multiMap
debugQuery :: (Query query) => query -> IO ()
debugQuery query = putStrLn $ "Query path: " ++ basePath ++ (formQueryString (path query) (params query))
executeWrite :: (W.Write write) => Options -> write -> IO F.Response
executeWrite options write = post options (W.path write) (W.params write) (W.body write)
debugWrite :: (W.Write write) => write -> IO ()
debugWrite write = do
putStrLn ("Write path: " ++ basePath ++ W.path write)
putStrLn "Write body:"
putStrLn $ formParamsString $ W.body write
get :: Options -> Path -> Params -> IO F.Response
get options path params = get' options (formQueryString path params)
post :: Options -> Path -> Params -> Body -> IO F.Response
post options path params body = post' options queryString bodyString
where queryString = formQueryString path params
bodyString = formParamsString body
get' :: Options -> String -> IO F.Response
get' options queryString = do
response <- get'' options queryString
return $ F.fromValue $ extractJSON response
get'' :: Options -> String -> IO Response
get'' options queryString = do
let fullPath = basePath ++ queryString
let request = generateRequest fullPath
execute options request
post' :: Options -> String -> String -> IO F.Response
post' options queryString bodyString = do
let fullPath = basePath ++ queryString
let request = generatePostRequest fullPath bodyString
response <- execute options request
return $ F.fromValue $ extractJSON response
execute :: Options -> Request -> IO Response
execute options request = runOAuthM auth $ setupOAuth request to
where auth = token options
to = timeout options
formQueryString :: String -> M.Map String String -> String
formQueryString path params = path ++ "?" ++ (formParamsString params)
formParamsString :: M.Map String String -> String
formParamsString params = formParamsString' $ M.toList params
formParamsString' :: [(String, String)] -> String
formParamsString' paramList = join "&" $ map formParamParts filteredParams
where filteredParams = filter (\(k,v) -> "" /= v) paramList
formParamParts :: (String, String) -> String
formParamParts (key, value) = key ++ "=" ++ (urlEncode value)
formMultiQueryString :: (Query query) => [(String, query)] -> String
formMultiQueryString ps = "/multi?queries=" ++ (urlEncode $ "{" ++ (join "," $ map queryPair ps) ++ "}")
where queryPair (n,q) = "\"" ++ n ++ "\":\"" ++ (formQueryString (path q) (params q)) ++ "\""
formMultiResponse :: Response -> [String] -> M.Map String F.Response
formMultiResponse res ks = M.fromList $ map formPair ks
where formPair k = (k, F.fromValue $ F.lookupValue k json)
json = extractJSON res
generateRequest :: String -> Request
generateRequest url = (fromJust $ parseURL url) { reqHeaders = (fromList headersList) }
generatePostRequest :: String -> String -> Request
generatePostRequest url body = baseRequest { reqHeaders = (fromList postHeaders)
, method = POST
, reqPayload = B.pack body }
where baseRequest = (fromJust $ parseURL url)
postHeaders = headersList ++ [("Content-Type", "application/x-www-form-urlencoded")]
setupOAuth :: Request -> Maybe Long -> OAuthMonadT IO Response
setupOAuth request Nothing = do
oauthRequest <- signRq2 HMACSHA1 Nothing request
serviceRequest CurlClient oauthRequest
setupOAuth request (Just timeout) = do
oauthRequest <- signRq2 HMACSHA1 Nothing request
serviceRequest (OptionsCurlClient [CurlTimeout timeout]) oauthRequest
extractJSON :: Response -> Value
extractJSON = fromJust . decode . rspPayload
urlEncode :: String -> String
urlEncode = U.encode . S.encode
headersList :: [(String, String)]
headersList = [("X-Factual-Lib", "factual-haskell-driver-0.6.1")]
basePath :: String
basePath = "http://api.v3.factual.com"