<commit_before>{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}


-- |This module implements HTTP requests using the
-- <https://github.com/facebook/Haxl Haxl library>. As of the current version
-- implements only the concrete type 'GetHTML' which is used to fetch HTML
-- pages.
module Dropp.HttpDataSource
  ( HttpException
  , URL (..)
  , Urls (..)
  , getHTML
  , getJSON
  , getPages
  , initDataSource)
  where


import Data.Typeable
import Dropp.DataTypes
import Control.Monad (void)
import Text.Printf (printf)
import Control.Concurrent (threadDelay)
import Data.ByteString.Lazy (ByteString)
import Data.Aeson (decode)

import Data.Hashable
  ( Hashable
  , hashWithSalt)

import Haxl.Core
  ( StateKey
  , DataSource
  , DataSourceName
  , State
  , Show1
  , GenHaxl
  , BlockedFetch (BlockedFetch)
  , PerformFetch (SyncFetch)
  , initEnv
  , stateSet
  , stateEmpty
  , runHaxl
  , show1
  , dataSourceName
  , dataFetch
  , putFailure
  , putSuccess
  , fetch)

import Control.Exception
  ( SomeException
  , try)

import Network.HTTP.Conduit
  ( Manager
  , HttpException
  , newManager
  , tlsManagerSettings
  , parseUrl
  , responseBody
  , httpLbs)


-- ------------------------------------------------------------------------- --
--              BOILERPLATE
-- ------------------------------------------------------------------------- --

-- |Haxl GADT
data HttpReq a where
    -- HTML fetching concrete type
    GetHTML
        :: URL --  URL literal to be fetched.
        -> HttpReq ByteString --  HTML bytestring boxed in a Haxl fetch.

    GetJSON
        :: URL --  URL literal to be fetched.
           -> HttpReq (Maybe [Urls]) --  Aeson JSON boxed in a Haxl fetch.

deriving instance Show (HttpReq a)

deriving instance Typeable HttpReq

instance Show1 HttpReq where show1 = show

deriving instance Eq (HttpReq a)

instance Hashable (HttpReq a) where
    hashWithSalt salt (GetHTML (url :: URL)) =
        hashWithSalt salt (0 :: Int, url :: URL)

    hashWithSalt salt (GetJSON (url :: URL)) =
        hashWithSalt salt (1 :: Int, url :: URL)

instance DataSourceName HttpReq where
    dataSourceName _ = "HttpDataSource"

instance StateKey HttpReq where
    data State HttpReq = HttpState Manager


-- ------------------------------------------------------------------------- --
--              IMPLEMENTATION
-- ------------------------------------------------------------------------- --

-- | Initialise the HTTP data source with a blank conduit manager.
initDataSource :: IO (State HttpReq)
initDataSource = HttpState <$> newManager tlsManagerSettings


instance DataSource u HttpReq where
  fetch (HttpState mgr) _flags _userEnv blockedFetches =
      SyncFetch $ mapM_ (fetchURL mgr) blockedFetches


-- |Perform HTTP requests of HTML URL's. All requests are intended to be GET
-- and the server will return an HTML document.
fetchURL
    :: Manager -- ^ Initalised Conduit manager.
    -> BlockedFetch HttpReq -- ^ Accepts any concrete type of the HttpReq GADT.
    -> IO ()

fetchURL mgr (BlockedFetch (GetHTML (HtmlUrl url)) var) = do
    printf $ "Fetching " ++ show url ++ "\n" -- FIXME: log instead of print.
    threadDelay 1000000
    fetchedHtml <- try $ do
        req <- parseUrl $ url
        responseBody <$> httpLbs req mgr

    either (putFailure var) (putSuccess var)
        (fetchedHtml :: Either SomeException ByteString)


fetchURL mgr (BlockedFetch (GetJSON (JsonUrl url)) var) = do
    printf $ "Fetching " ++ show url ++ "\n" -- FIXME: log instead of print.
    threadDelay 1000000
    fetchedJson <- try $ do
        req <- parseUrl $ url
        body <- responseBody <$> httpLbs req mgr
        return (decode body)

    either (putFailure var) (putSuccess var)
        (fetchedJson :: Either SomeException (Maybe [Urls]))<commit_msg>[DPP-47] Refactored fetch method in HttpDataSource<commit_after>{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}


-- |This module implements HTTP requests using the
-- <https://github.com/facebook/Haxl Haxl library>. As of the current version
-- implements only the concrete type 'GetHTML' which is used to fetch HTML
-- pages.
module Dropp.HttpDataSource
  ( HttpException
  , URL (..)
  , Urls (..)
  , getHTML
  , getJSON
  , getPages
  , initDataSource)
  where


import Data.Typeable
import Dropp.DataTypes
import GHC.Exception (Exception)
import Control.Monad (void)
import Text.Printf (printf)
import Control.Concurrent (threadDelay)
import Data.ByteString.Lazy (ByteString)
import Data.Aeson (decode)

import Data.Hashable
  ( Hashable
  , hashWithSalt)

import Haxl.Core
  ( StateKey
  , DataSource
  , DataSourceName
  , State
  , Show1
  , GenHaxl
  , BlockedFetch (BlockedFetch)
  , PerformFetch (SyncFetch)
  , initEnv
  , stateSet
  , stateEmpty
  , runHaxl
  , show1
  , dataSourceName
  , dataFetch
  , putFailure
  , putSuccess
  , fetch)

import Control.Exception
  ( SomeException
  , try)

import Network.HTTP.Conduit
  ( Manager
  , HttpException
  , newManager
  , tlsManagerSettings
  , parseUrl
  , responseBody
  , httpLbs)


-- ------------------------------------------------------------------------- --
--              BOILERPLATE
-- ------------------------------------------------------------------------- --

-- |Haxl GADT
data HttpReq a where
    -- HTML fetching concrete type
    GetHTML
        :: URL --  URL literal to be fetched.
        -> HttpReq ByteString --  HTML bytestring boxed in a Haxl fetch.

    GetJSON
        :: URL --  URL literal to be fetched.
           -> HttpReq (Maybe [Urls]) --  Aeson JSON boxed in a Haxl fetch.

deriving instance Show (HttpReq a)

deriving instance Typeable HttpReq

instance Show1 HttpReq where show1 = show

deriving instance Eq (HttpReq a)

instance Hashable (HttpReq a) where
    hashWithSalt salt (GetHTML (url :: URL)) =
        hashWithSalt salt (0 :: Int, url :: URL)

    hashWithSalt salt (GetJSON (url :: URL)) =
        hashWithSalt salt (1 :: Int, url :: URL)

instance DataSourceName HttpReq where
    dataSourceName _ = "HttpDataSource"

instance StateKey HttpReq where
    data State HttpReq = HttpState Manager


-- ------------------------------------------------------------------------- --
--              IMPLEMENTATION
-- ------------------------------------------------------------------------- --

-- | Initialise the HTTP data source with a blank conduit manager.
initDataSource :: IO (State HttpReq)
initDataSource = HttpState <$> newManager tlsManagerSettings


instance DataSource u HttpReq where
  fetch (HttpState mgr) _flags _userEnv blockedFetches =
      SyncFetch $ mapM_ (fetchURL mgr) blockedFetches


-- |Perform HTTP requests of HTML URL's. All requests are intended to be GET
-- and the server will return an HTML document.
fetchURL
    :: Manager -- ^ Initalised Conduit manager.
    -> BlockedFetch HttpReq -- ^ Accepts any concrete type of the HttpReq GADT.
    -> IO ()

fetchURL mgr (BlockedFetch (GetHTML (HtmlUrl url)) var) = do
    fetchedHtml <- fetchHttp mgr url

    either (putFailure var) (putSuccess var)
        (fetchedHtml :: Either SomeException ByteString)


fetchURL mgr (BlockedFetch (GetJSON (JsonUrl url)) var) = do
    fetchedHtml <- fetchHttp mgr url

    let fetchedJson = decode <$> fetchedHtml

    either (putFailure var) (putSuccess var)
        (fetchedJson :: Either SomeException (Maybe [Urls]))


fetchHttp
    :: Manager -- ^ Initalised Conduit manager.
    -> String -- ^ Url to be fetched
    -> IO (Either SomeException ByteString)
fetchHttp mgr url = do
    printf $ "Fetching " ++ show url ++ "\n" -- FIXME: log instead of print.
    threadDelay 1000000
    fetchedHtml <- try $ do
        req <- parseUrl $ url
        responseBody <$> httpLbs req mgr

    return fetchedHtml
{'fraction_non_alphanumeric': 0.16062553036731725, 'fraction_numerical': 0.004242938538004607, 'mean_word_length': 2.289473684210526, 'pattern_counts': {'":': 0, '<': 20, '<?xml version=': 0, '>': 21, 'https://': 2, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2200060', 'n_tokens_mistral': 2490, 'n_tokens_neox': 2407, 'n_words': 765}