Base.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}

module Web.Twitter.Conduit.Base
       ( getResponse
       , call
       , call'
       , callWithResponse
       , callWithResponse'
       , checkResponse
       , sourceWithMaxId
       , sourceWithMaxId'
       , sourceWithCursor
       , sourceWithCursor'
       , sourceWithSearchResult
       , sourceWithSearchResult'
       , endpoint
       , makeRequest
       , sinkJSON
       , sinkFromJSON
       ) where

import Web.Twitter.Conduit.Cursor
import Web.Twitter.Conduit.Parameters hiding (url)
import Web.Twitter.Conduit.Request
import Web.Twitter.Conduit.Response
import Web.Twitter.Conduit.Types
import Web.Twitter.Types.Lens

import Control.Lens
import Control.Monad.Base
import Control.Monad.Catch (MonadThrow (..))
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource (MonadResource, ResourceT, runResourceT)
import Data.Aeson
import Data.Aeson.Lens
import Data.ByteString (ByteString)
import qualified Data.Conduit as C
import qualified Data.Conduit.Attoparsec as CA
import qualified Data.Conduit.List as CL
import qualified Data.Map as M
import Data.Monoid
import qualified Data.Text.Encoding as T
import Network.HTTP.Client.MultipartFormData
import qualified Network.HTTP.Conduit as HTTP
import qualified Network.HTTP.Types as HT
import Unsafe.Coerce
import Web.Authenticate.OAuth (signOAuth)

makeRequest :: APIRequest apiName responseType
            -> IO HTTP.Request
makeRequest (APIRequestGet u pa) = makeRequest' "GET" u (makeSimpleQuery pa)
makeRequest (APIRequestPost u pa) = makeRequest' "POST" u (makeSimpleQuery pa)
makeRequest (APIRequestPostMultipart u param prt) =
    formDataBody body =<< makeRequest' "POST" u []
  where
    body = prt ++ partParam
    partParam = Prelude.map (uncurry partBS . over _1 T.decodeUtf8) (makeSimpleQuery param)

makeRequest' :: HT.Method -- ^ HTTP request method (GET or POST)
             -> String -- ^ API Resource URL
             -> HT.SimpleQuery -- ^ Query
             -> IO HTTP.Request
makeRequest' m url query = do
#if MIN_VERSION_http_client(0,4,30)
    req <- HTTP.parseRequest url
#else
    req <- HTTP.parseUrl url
#endif
    let addParams =
            if m == "POST"
            then HTTP.urlEncodedBody query
            else \r -> r { HTTP.queryString = HT.renderSimpleQuery False query }
    return $ addParams $ req { HTTP.method = m
#if !MIN_VERSION_http_client(0,4,30)
                             , HTTP.checkStatus = \_ _ _ -> Nothing
#endif
                             }

getResponse :: MonadResource m
            => TWInfo
            -> HTTP.Manager
            -> HTTP.Request
#if MIN_VERSION_http_conduit(2,3,0)
            -> m (Response (C.ConduitM () ByteString m ()))
#else
            -> m (Response (C.ResumableSource m ByteString))
#endif
getResponse TWInfo{..} mgr req = do
    signedReq <- signOAuth (twOAuth twToken) (twCredential twToken) $ req { HTTP.proxy = twProxy }
    res <- HTTP.http signedReq mgr
    return
        Response { responseStatus = HTTP.responseStatus res
                 , responseHeaders = HTTP.responseHeaders res
                 , responseBody = HTTP.responseBody res
                 }

endpoint :: String
endpoint = "https://api.twitter.com/1.1/"

getValue ::
#if MIN_VERSION_http_conduit(2,3,0)
            Response (C.ConduitM () ByteString (ResourceT IO) ())
#else
            Response (C.ResumableSource (ResourceT IO) ByteString)
#endif
         -> ResourceT IO (Response Value)
getValue res = do
    value <-
#if MIN_VERSION_http_conduit(2,3,0)
      C.runConduit $ responseBody res C..| sinkJSON
#else
      responseBody res C.$$+- sinkJSON
#endif
    return $ res { responseBody = value }

checkResponse :: Response Value
              -> Either TwitterError Value
checkResponse Response{..} =
    case responseBody ^? key "errors" of
        Just errs@(Array _) ->
            case fromJSON errs of
                Success errList -> Left $ TwitterErrorResponse responseStatus responseHeaders errList
                Error msg -> Left $ FromJSONError msg
        Just err ->
            Left $ TwitterUnknownErrorResponse responseStatus responseHeaders err
        Nothing ->
            if sci < 200 || sci > 400
                then Left $ TwitterStatusError responseStatus responseHeaders responseBody
                else Right responseBody
  where
    sci = HT.statusCode responseStatus

getValueOrThrow :: FromJSON a
#if MIN_VERSION_http_conduit(2,3,0)
                => Response (C.ConduitM () ByteString (ResourceT IO) ())
#else
                => Response (C.ResumableSource (ResourceT IO) ByteString)
#endif
                -> ResourceT IO (Response a)
getValueOrThrow res = do
    res' <- getValue res
    case checkResponse res' of
        Left err -> throwM err
        Right _ -> return ()
    case fromJSON (responseBody res') of
        Success r -> return $ res' { responseBody = r }
        Error err -> throwM $ FromJSONError err

-- | Perform an 'APIRequest' and then provide the response which is mapped to a suitable type of
-- <http://hackage.haskell.org/package/twitter-types twitter-types>.
--
-- Example:
--
-- @
-- user <- 'call' twInfo mgr $ 'accountVerifyCredentials'
-- print user
-- @
--
-- If you need raw JSON value which is parsed by <http://hackage.haskell.org/package/aeson aeson>,
-- use 'call'' to obtain it.
call :: FromJSON responseType
     => TWInfo -- ^ Twitter Setting
     -> HTTP.Manager
     -> APIRequest apiName responseType
     -> IO responseType
call = call'

-- | Perform an 'APIRequest' and then provide the response.
-- The response of this function is not restrict to @responseType@,
-- so you can choose an arbitrarily type of FromJSON instances.
call' :: FromJSON value
      => TWInfo -- ^ Twitter Setting
      -> HTTP.Manager
      -> APIRequest apiName responseType
      -> IO value
call' info mgr req = responseBody `fmap` callWithResponse' info mgr req

-- | Perform an 'APIRequest' and then provide the 'Response'.
--
-- Example:
--
-- @
-- res \<- 'callWithResponse' twInfo mgr $ 'accountVerifyCredentials'
-- 'print' $ 'responseStatus' res
-- 'print' $ 'responseHeaders' res
-- 'print' $ 'responseBody' res
-- @
callWithResponse :: FromJSON responseType
                 => TWInfo -- ^ Twitter Setting
                 -> HTTP.Manager
                 -> APIRequest apiName responseType
                 -> IO (Response responseType)
callWithResponse = callWithResponse'

-- | Perform an 'APIRequest' and then provide the 'Response'.
-- The response of this function is not restrict to @responseType@,
-- so you can choose an arbitrarily type of FromJSON instances.
--
-- Example:
--
-- @
-- res \<- 'callWithResponse'' twInfo mgr $ 'accountVerifyCredentials'
-- 'print' $ 'responseStatus' res
-- 'print' $ 'responseHeaders' res
-- 'print' $ 'responseBody' (res :: Value)
-- @
callWithResponse' :: FromJSON value
                  => TWInfo
                  -> HTTP.Manager
                  -> APIRequest apiName responseType
                  -> IO (Response value)
callWithResponse' info mgr req =
    runResourceT $ do
        res <- getResponse info mgr =<< liftIO (makeRequest req)
        getValueOrThrow res

-- | A wrapper function to perform multiple API request with changing @max_id@ parameter.
--
-- This function cooperate with instances of 'HasMaxIdParam'.
sourceWithMaxId :: ( MonadIO m
                   , FromJSON responseType
                   , AsStatus responseType
                   , HasMaxIdParam (APIRequest apiName [responseType])
                   )
                => TWInfo -- ^ Twitter Setting
                -> HTTP.Manager
                -> APIRequest apiName [responseType]
                -> C.Source m responseType
sourceWithMaxId info mgr = loop
  where
    loop req = do
        res <- liftIO $ call info mgr req
        case getMinId res of
            Just mid -> do
                CL.sourceList res
                loop $ req & maxId ?~ mid - 1
            Nothing -> CL.sourceList res
    getMinId = minimumOf (traverse . status_id)

-- | A wrapper function to perform multiple API request with changing @max_id@ parameter.
-- The response of this function is not restrict to @responseType@,
-- so you can choose an arbitrarily type of FromJSON instances.
--
-- This function cooperate with instances of 'HasMaxIdParam'.
sourceWithMaxId' :: ( MonadIO m
                    , HasMaxIdParam (APIRequest apiName [responseType])
                    )
                 => TWInfo -- ^ Twitter Setting
                 -> HTTP.Manager
                 -> APIRequest apiName [responseType]
                 -> C.Source m Value
sourceWithMaxId' info mgr = loop
  where
    loop req = do
        res <- liftIO $ call' info mgr req
        case getMinId res of
            Just mid -> do
                CL.sourceList res
                loop $ req & maxId ?~ mid - 1
            Nothing -> CL.sourceList res
    getMinId = minimumOf (traverse . key "id" . _Integer)

-- | A wrapper function to perform multiple API request with changing @cursor@ parameter.
--
-- This function cooperate with instances of 'HasCursorParam'.
sourceWithCursor :: ( MonadIO m
                    , FromJSON responseType
                    , CursorKey ck
                    , HasCursorParam (APIRequest apiName (WithCursor ck responseType))
                    )
                 => TWInfo -- ^ Twitter Setting
                 -> HTTP.Manager
                 -> APIRequest apiName (WithCursor ck responseType)
                 -> C.Source m responseType
sourceWithCursor info mgr req = loop (-1)
  where
    loop 0 = CL.sourceNull
    loop cur = do
        res <- liftIO $ call info mgr $ req & cursor ?~ cur
        CL.sourceList $ contents res
        loop $ nextCursor res

-- | A wrapper function to perform multiple API request with changing @cursor@ parameter.
-- The response of this function is not restrict to @responseType@,
-- so you can choose an arbitrarily type of FromJSON instances.
--
-- This function cooperate with instances of 'HasCursorParam'.
sourceWithCursor' :: ( MonadIO m
                     , CursorKey ck
                     , HasCursorParam (APIRequest apiName (WithCursor ck responseType))
                     )
                  => TWInfo -- ^ Twitter Setting
                  -> HTTP.Manager
                  -> APIRequest apiName (WithCursor ck responseType)
                  -> C.Source m Value
sourceWithCursor' info mgr req = loop (-1)
  where
    relax :: APIRequest apiName (WithCursor ck responseType)
          -> APIRequest apiName (WithCursor ck Value)
    relax = unsafeCoerce
    loop 0 = CL.sourceNull
    loop cur = do
        res <- liftIO $ call info mgr $ relax $ req & cursor ?~ cur
        CL.sourceList $ contents res
        loop $ nextCursor res

-- | A wrapper function to perform multiple API request with @SearchResult@.
sourceWithSearchResult :: ( MonadIO m
                          , FromJSON responseType
                          )
                       => TWInfo -- ^ Twitter Setting
                       -> HTTP.Manager
                       -> APIRequest apiName (SearchResult [responseType])
                       -> m (SearchResult (C.Source m responseType))
sourceWithSearchResult info mgr req = do
    res <- liftIO $ call info mgr req
    let body = CL.sourceList (res ^. searchResultStatuses) <>
               loop (res ^. searchResultSearchMetadata . searchMetadataNextResults)
    return $ res & searchResultStatuses .~ body
  where
    origQueryMap = req ^. params . to M.fromList
    loop Nothing = CL.sourceNull
    loop (Just nextResultsStr) = do
        let nextResults = nextResultsStr & HT.parseSimpleQuery . T.encodeUtf8 & traversed . _2 %~ (PVString . T.decodeUtf8)
            nextParams = M.toList $ M.union (M.fromList nextResults) origQueryMap
        res <- liftIO $ call info mgr $ req & params .~ nextParams
        CL.sourceList (res ^. searchResultStatuses)
        loop $ res ^. searchResultSearchMetadata . searchMetadataNextResults

-- | A wrapper function to perform multiple API request with @SearchResult@.
sourceWithSearchResult' :: ( MonadIO m
                           )
                        => TWInfo -- ^ Twitter Setting
                        -> HTTP.Manager
                        -> APIRequest apiName (SearchResult [responseType])
                        -> m (SearchResult (C.Source m Value))
sourceWithSearchResult' info mgr req = do
    res <- liftIO $ call info mgr $ relax req
    let body = CL.sourceList (res ^. searchResultStatuses) <>
               loop (res ^. searchResultSearchMetadata . searchMetadataNextResults)
    return $ res & searchResultStatuses .~ body
  where
    origQueryMap = req ^. params . to M.fromList
    relax :: APIRequest apiName (SearchResult [responseType])
          -> APIRequest apiName (SearchResult [Value])
    relax = unsafeCoerce
    loop Nothing = CL.sourceNull
    loop (Just nextResultsStr) = do
        let nextResults = nextResultsStr & HT.parseSimpleQuery . T.encodeUtf8 & traversed . _2 %~ (PVString . T.decodeUtf8)
            nextParams = M.toList $ M.union (M.fromList nextResults) origQueryMap
        res <- liftIO $ call info mgr $ relax $ req & params .~ nextParams
        CL.sourceList (res ^. searchResultStatuses)
        loop $ res ^. searchResultSearchMetadata . searchMetadataNextResults

sinkJSON :: ( MonadThrow m
            ) => C.Consumer ByteString m Value
sinkJSON = CA.sinkParser json

sinkFromJSON :: ( FromJSON a
                , MonadThrow m
                ) => C.Consumer ByteString m a
sinkFromJSON = do
    v <- sinkJSON
    case fromJSON v of
        Error err -> throwM $ FromJSONError err
        Success r -> return r