uniform-http-0.1.5.1: src/Uniform/HttpCall.hs
-----------------------------------------------------------------------------
--
-- Module : Uniform.HttpCall
--
-- | using http simple to sparql queries and to create requests
-- part of uniform (to use only text
-- uses the newer http-conduit module
-- because teh old HTTP cannot do https
-----------------------------------------------------------------------------
--{-# OPTIONS_GHC -F -pgmF htfpp #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables, DeriveGeneric, DeriveAnyClass,
RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
-- {-# OPTIONS_GHC -fno-warn-missing-methods #-}
module Uniform.HttpCall (module Uniform.HttpCall
-- , module Uniform.Error
, mkServerURI, ServerURI
) where
import UniformBase
import qualified Network.HTTP.Simple as Http
import qualified Network.HTTP.Conduit as Conduit
-- import Data.Text (take)
import Uniform.HttpURI
import GHC.Generics hiding (S)
makeRequest :: URI -> ErrIO Conduit.Request
makeRequest dest = Http.parseRequest . t2s . uriT $ dest
callHTTP8get :: Bool -> ServerURI -> ErrIO Text
-- call the http-conduit simple for a get
-- see https://haskell-lang.org/library/http-client
callHTTP8get debug (ServerURI dest) = do
req2 <- makeRequest dest
when debug $ putIOwords ["callHTTP8get"
, "header req", showT req2
]
response <- callIO $ Http.httpLBS req2
when debug $ putIOwords ["The status code was: " ,
showT (Http.getResponseStatusCode response)]
when debug $ putIOwords [showT (Http.getResponseHeader "Content-Type" response)]
-- L8.putStrLn $ getResponseBody response
let res = bb2t . bl2b . Http.getResponseBody $ response :: Text
-- stops if not an UTF8 encoded text
when debug $ putIOwords ["callHTTP8get response: ", res]
return res
callHTTP10post :: Bool -> AppType -> ServerURI -> HttpPath -> LazyByteString
-> HttpQueryParams -> TimeOutSec -> ErrIO Text
-- post a body to the url given as a type given
--application/sparql-update
-- timeout in seconds - will be converted, mkTimeOutDefault gives default
-- URI not text for destination
-- if serverURI is http the post is made 'secure' which
-- causes "Failed reading: invalid header type: 72"
callHTTP10post debug (AppType apptype) (ServerURI dest) (HttpPath path)
txt vars (TimeOutSec timeout) = do
req1 <- makeRequest dest
when debug $ putIOwords ["callHTTP10post", "serverURI", showT dest]
-- let length = lengthChar . b2s . bl2b $ txt
let req2 = Http.setRequestBodyLBS txt -- (b2bl . t2b $ txt)
$ Http.setRequestHeader "Content-Type" [t2b apptype]
$ Http.setRequestMethod "POST"
$ Http.setRequestPath (t2b path)
$ Http.setRequestQueryString (map formatQuery
. unHttpQueryParams $ vars)
req1
{Conduit.responseTimeout =
maybe Conduit.responseTimeoutNone
(Conduit.responseTimeoutMicro . (1000000 *))
timeout
}
when debug $ putIOwords ["callHTTP10post" , "header req", showT req2
, "\nbody", bl2t txt ]
-- "text length"
-- , showT length]
res <- callIO $ Http.httpLBS req2
-- callIO does itself catch, additional should not be needed, except perhaps for not providing good informaiton
-- `catch` \e -> do
-- -- putIOwords ["callHTTP10post error caught 3", showT e
-- -- , "\n should not occur - caught by callIO ??"
-- -- , "\n note hint: replace localhost by 127.0.0.1"
-- -- , "\n", showT req2]
-- fail . unwords $ [ "callHTTP10post httperror 3", show e]
-- -- is in the IO monad, not ErrIO
let statusCode = Http.getResponseStatusCode res
-- when debug $
putIOwords ["callHTTP10post The status code was: ", showT statusCode]
when debug $ putIOwords [showT (Http.getResponseHeader "Content-Type" res)]
let res2 = bb2t . bl2b . Http.getResponseBody $ res :: Text
-- stops if not an UTF8 encoded text
return res2
-- -- TODO merge the post7 and post9
-- -- post7 has a query paramter with
-- makeHttpPost7 :: Bool -> URI -> Text -> HttpQueryParams
-- -> Text -> Text -> ErrIO Text
-- -- post a body to the url given as a type given
-- --application/sparql-update
-- -- path is query .. or something which is type,value pairs
-- -- is not used anymore?
-- makeHttpPost7 debug dest path query appType txt = do
-- callHTTP10post debug appType ( dest) path (b2bl . t2b $ txt) query (Just 300)
formatQuery :: (Text, Maybe Text) -> (ByteString, Maybe ByteString)
formatQuery (a, mb) = (t2b a, fmap t2b mb)
--
-- makeHttpPost7x :: Bool -> URI -> Text ->
-- HttpQueryParams -> Text -> Text -> ErrIO Text
-- -- post a body to the url given as a type given
-- --application/sparql-update
-- -- path is query .. or something which is type,value pairs
-- makeHttpPost7x debug dest path vars appType txt = do
-- req1 <- makeRequest dest
-- let length = lengthChar txt
-- let req2 = Http.setRequestBodyLBS (b2bl . t2b $ txt)
-- $ Http.setRequestHeader "Content-Type" [t2b appType]
-- $ Http.setRequestMethod "POST"
-- $ Http.setRequestPath (t2b path)
-- $ Http.setRequestQueryString
-- (map formatQuery . unHttpQueryParams $ vars)
-- -- $ Conduit.ResponseTimeout 300000 -- msecs
-- req1
-- {Conduit.responseTimeout = Conduit.responseTimeoutMicro 300000000}
-- ---- }
-- when debug $ putIOwords ["makeHttpPost7", showT req2, "text length", showT length]
-- res <- callIO $
-- do
-- Http.httpLBS req2
-- `catchError` \e -> do
-- putIOwords ["makeHttpPost7 error caught 3", showT e
-- , "\n should not occur - caught by callIO ??"
-- , "\n note hint: replace localhost by 127.0.0.1"
-- , "\n", showT req2]
-- fail . unwords $ [ "makeHttpPost7 httperror 3", show e]
-- -- is in the IO monad, not ErrIO
-- let statusCode = Http.getResponseStatusCode res
-- when debug $ putIOwords ["makeHttpPost7 The status code was: ", showT statusCode]
-- when debug $ putIOwords ["\t", showT (Http.getResponseHeader "Content-Type" res)]
-- let res2 = bb2t . bl2b . Http.getResponseBody $ res :: Text
-- -- stops if not an UTF8 encoded text
-- -- when True $ putIOwords ["makeHttpPost7 response: ", res2]
-- return res2
-- | a timeout in seconds
newtype TimeOutSec = TimeOutSec (Maybe Int)
deriving (Eq, Ord, Show, Read, Generic, Zeros)
mkTimeOutSec :: Int -> TimeOutSec
mkTimeOutSec i = TimeOutSec (Just i)
mkTimeOutDefault = TimeOutSec Nothing
instance NiceStrings TimeOutSec where
shownice (TimeOutSec (Just i)) = unwords' ["TimeOut", shownice i, "sec"]
shownice (TimeOutSec Nothing) = "TimeOut default"
-- | a special type for the app type argumetn
newtype AppType = AppType Text
deriving (Eq, Ord, Show, Read, Generic, Zeros)
mkAppType = AppType