Request.hs

module Test.Integration.Framework.Request
    ( HasHttpClient
    , request
    , request_
    , successfulRequest
    , unsafeRequest
    , ($-)
    ) where

import           Universum hiding (ByteString)

import           Data.Aeson (FromJSON)
import qualified Data.Aeson as Aeson
import           Data.ByteString.Lazy (ByteString)
import           Data.Generics.Product.Typed (HasType, typed)
import qualified Data.Sequence as Seq
import qualified Data.Text as T
import           GHC.Exts (IsList (..))
import           Network.HTTP.Client (RequestBody (..), httpLbs, method,
                     parseRequest, requestBody, requestHeaders, responseBody,
                     responseHeaders, responseStatus, responseVersion)
import qualified Network.HTTP.Client as HC
import qualified Network.HTTP.Client as HTTP
import           Network.HTTP.Types.Method (Method)
import           Network.HTTP.Types.Status (status200, status300, status404)
import           Servant.Client.Core.Internal.BaseUrl (BaseUrl (..),
                     showBaseUrl)
import           Servant.Client.Core.Internal.Request (ServantError (..))
import qualified Servant.Client.Core.Internal.Request as Servant

import           Cardano.Wallet.Client.Http (ClientError (..), Manager,
                     WalletClient)
import           Pos.Util.Servant (APIResponse (..))

class (HasType (WalletClient IO) ctx) => HasHttpClient ctx where
    httpClient :: Lens' ctx (WalletClient IO)
    httpClient = typed @(WalletClient IO)
instance (HasType (WalletClient IO) ctx) => HasHttpClient ctx

class (HasType (BaseUrl, Manager) ctx) => HasManager ctx where
    manager :: Lens' ctx (BaseUrl, Manager)
    manager = typed @(BaseUrl, Manager)
instance (HasType (BaseUrl, Manager) ctx) => HasManager ctx

-- | Removes some boilerplates getting the content of a 'Resp' directly.
class Request originalResponse where
    type Response originalResponse :: *

    -- | Run a given request and transform the response
    request
        :: forall m ctx. (MonadIO m, MonadReader ctx m, HasHttpClient ctx)
        => (WalletClient IO -> IO (Either ClientError originalResponse))
        -> m (Either ClientError (Response originalResponse))

    -- | Run a given request and discard the response
    request_
        :: forall m ctx. (MonadIO m, MonadReader ctx m, HasHttpClient ctx)
        => (WalletClient IO -> IO (Either ClientError originalResponse))
        -> m ()
    request_ =
        void . request

    -- | Run a given request as above, but throws if it fails
    successfulRequest
        :: forall m ctx. (MonadIO m, MonadFail m, MonadReader ctx m, HasHttpClient ctx)
        => (WalletClient IO -> IO (Either ClientError originalResponse))
        -> m (Response originalResponse)
    successfulRequest =
        request >=> \case
            Left e  ->
                fail . ("expected a successful response but got an error: " <>) . show $ e
            Right a ->
                return a

instance Request (APIResponse a) where
    type Response (APIResponse a) = a
    request action =
        view httpClient >>= liftIO . fmap (fmap wrData) . action

instance Request () where
    type Response () = ()
    request action =
        view httpClient >>= liftIO . action

unsafeRequest
    :: forall a m ctx.
        ( FromJSON a
        , MonadIO m
        , MonadThrow m
        , MonadReader ctx m
        , HasManager ctx
        )
    => (Method, Text)
    -> Maybe Aeson.Value
    -> m (Either ClientError a)
unsafeRequest (verb, path) body = do
    (base, man) <- view manager
    req <- parseRequest (showBaseUrl $ base { baseUrlPath = T.unpack path })
    res <- liftIO $ httpLbs (prepare req) man
    return $ case responseStatus res of
        s
            | s >= status200 && s <= status300 ->
                maybe
                    (Left $ decodeFailure res)
                    (Right . wrData)
                    (Aeson.decode $ responseBody res)
            | s == status404 ->
                Left
                    $ ClientHttpError
                    $ FailureResponse
                    $ Servant.Response
                    { Servant.responseStatusCode =
                        HC.responseStatus res
                    , Servant.responseHeaders =
                        Seq.fromList (HC.responseHeaders res)
                    , Servant.responseHttpVersion =
                        HC.responseVersion res
                    , Servant.responseBody =
                        HC.responseBody res
                    }

        _ -> fromMaybe (Left $ decodeFailure res) $ asum
            [ Left . ClientWalletError <$> Aeson.decode (responseBody res)
            , Left . ClientJSONError <$> Aeson.decode (responseBody res)
            ]

  where
    prepare :: HTTP.Request -> HTTP.Request
    prepare req = req
        { method = verb
        , requestBody = maybe mempty (RequestBodyLBS . Aeson.encode) body
        , requestHeaders =
            [ ("Content-Type", "application/json")
            , ("Accept", "application/json")
            ]
        }

    decodeFailure :: HTTP.Response ByteString -> ClientError
    decodeFailure res = ClientHttpError $ DecodeFailure mempty $ Servant.Response
        { Servant.responseStatusCode = responseStatus res
        , Servant.responseHeaders = fromList $ responseHeaders res
        , Servant.responseHttpVersion = responseVersion res
        , Servant.responseBody = responseBody res
        }


-- | Provide "next" arguments to a function, leaving the first one untouched.
--
-- e.g.
--    myFunction  :: Ctx -> Int -> String -> Result
--    myFunction' :: Ctx -> Result
--    myFunction' = myFunction $- 14 $- "patate"
infixl 1 $-
($-) :: (a -> b -> c) -> b -> a -> c
($-) = flip