-----------------------------------------------------------------------------
--
-- 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 :: URI -> ErrIO Request
makeRequest URI
dest = forall (m :: * -> *). MonadThrow m => String -> m Request
Http.parseRequest forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
t2s forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> Text
uriT forall a b. (a -> b) -> a -> b
$ URI
dest


callHTTP8get :: Bool -> ServerURI  -> ErrIO  Text
-- call the http-conduit simple for a get
-- see https://haskell-lang.org/library/http-client
callHTTP8get :: Bool -> ServerURI -> ErrIO Text
callHTTP8get Bool
debug (ServerURI URI
dest) = do
    Request
req2 <- URI -> ErrIO Request
makeRequest URI
dest
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => [Text] -> m ()
putIOwords [Text
"callHTTP8get" 
                    , Text
"header req", forall {a}. Show a => a -> Text
showT Request
req2
                                ]
    Response ByteString
response <- forall a. IO a -> ErrIO a
callIO forall a b. (a -> b) -> a -> b
$  forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
Http.httpLBS Request
req2
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => [Text] -> m ()
putIOwords [Text
"The status code was: " ,
               forall {a}. Show a => a -> Text
showT (forall a. Response a -> Int
Http.getResponseStatusCode Response ByteString
response)]
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => [Text] -> m ()
putIOwords [forall {a}. Show a => a -> Text
showT (forall a. HeaderName -> Response a -> [ByteString]
Http.getResponseHeader HeaderName
"Content-Type" Response ByteString
response)]
--    L8.putStrLn $ getResponseBody response
    let res :: Text
res = ByteString -> Text
bb2t forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
bl2b forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Response a -> a
Http.getResponseBody forall a b. (a -> b) -> a -> b
$ Response ByteString
response :: Text
    -- stops if not an UTF8 encoded text
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => [Text] -> m ()
putIOwords [Text
"callHTTP8get response: ", Text
res]
    forall (m :: * -> *) a. Monad m => a -> m a
return Text
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 :: Bool
-> AppType
-> ServerURI
-> HttpPath
-> ByteString
-> HttpQueryParams
-> TimeOutSec
-> ErrIO Text
callHTTP10post Bool
debug (AppType Text
apptype) (ServerURI URI
dest) (HttpPath Text
path)
                     ByteString
txt HttpQueryParams
vars (TimeOutSec Maybe Int
timeout) = do
    Request
req1 <- URI -> ErrIO Request
makeRequest URI
dest
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => [Text] -> m ()
putIOwords [Text
"callHTTP10post", Text
"serverURI", forall {a}. Show a => a -> Text
showT URI
dest]
--    let length = lengthChar . b2s . bl2b $ txt
    let req2 :: Request
req2 = ByteString -> Request -> Request
Http.setRequestBodyLBS ByteString
txt -- (b2bl . t2b $ txt)
                forall a b. (a -> b) -> a -> b
$ HeaderName -> [ByteString] -> Request -> Request
Http.setRequestHeader HeaderName
"Content-Type" [Text -> ByteString
t2b Text
apptype]
                forall a b. (a -> b) -> a -> b
$ ByteString -> Request -> Request
Http.setRequestMethod ByteString
"POST"
                forall a b. (a -> b) -> a -> b
$ ByteString -> Request -> Request
Http.setRequestPath (Text -> ByteString
t2b Text
path)
                forall a b. (a -> b) -> a -> b
$ Query -> Request -> Request
Http.setRequestQueryString (forall a b. (a -> b) -> [a] -> [b]
map (Text, Maybe Text) -> (ByteString, Maybe ByteString)
formatQuery
                        forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpQueryParams -> [(Text, Maybe Text)]
unHttpQueryParams forall a b. (a -> b) -> a -> b
$ HttpQueryParams
vars)
                Request
req1
                    {responseTimeout :: ResponseTimeout
Conduit.responseTimeout =
                            forall b a. b -> (a -> b) -> Maybe a -> b
maybe ResponseTimeout
Conduit.responseTimeoutNone
                                    (Int -> ResponseTimeout
Conduit.responseTimeoutMicro forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
1000000 forall a. Num a => a -> a -> a
*))
                                    Maybe Int
timeout
                    }
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => [Text] -> m ()
putIOwords [Text
"callHTTP10post" , Text
"header req", forall {a}. Show a => a -> Text
showT Request
req2
                                , Text
"\nbody", ByteString -> Text
bl2t ByteString
txt ]
--            "text length"
--                    , showT length]
    Response ByteString
res <- forall a. IO a -> ErrIO a
callIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
Http.httpLBS Request
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 :: Int
statusCode = forall a. Response a -> Int
Http.getResponseStatusCode Response ByteString
res
--    when debug $
    forall (m :: * -> *). MonadIO m => [Text] -> m ()
putIOwords [Text
"callHTTP10post The status code was: ", forall {a}. Show a => a -> Text
showT Int
statusCode]
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => [Text] -> m ()
putIOwords [forall {a}. Show a => a -> Text
showT (forall a. HeaderName -> Response a -> [ByteString]
Http.getResponseHeader HeaderName
"Content-Type" Response ByteString
res)]
    let res2 :: Text
res2 = ByteString -> Text
bb2t forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
bl2b forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Response a -> a
Http.getResponseBody forall a b. (a -> b) -> a -> b
$ Response ByteString
res :: Text
    -- stops if not an UTF8 encoded text
    forall (m :: * -> *) a. Monad m => a -> m a
return Text
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 :: (Text, Maybe Text) -> (ByteString, Maybe ByteString)
formatQuery (Text
a, Maybe Text
mb) = (Text -> ByteString
t2b Text
a, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ByteString
t2b Maybe Text
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 (TimeOutSec -> TimeOutSec -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TimeOutSec -> TimeOutSec -> Bool
$c/= :: TimeOutSec -> TimeOutSec -> Bool
== :: TimeOutSec -> TimeOutSec -> Bool
$c== :: TimeOutSec -> TimeOutSec -> Bool
Eq, Eq TimeOutSec
TimeOutSec -> TimeOutSec -> Bool
TimeOutSec -> TimeOutSec -> Ordering
TimeOutSec -> TimeOutSec -> TimeOutSec
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TimeOutSec -> TimeOutSec -> TimeOutSec
$cmin :: TimeOutSec -> TimeOutSec -> TimeOutSec
max :: TimeOutSec -> TimeOutSec -> TimeOutSec
$cmax :: TimeOutSec -> TimeOutSec -> TimeOutSec
>= :: TimeOutSec -> TimeOutSec -> Bool
$c>= :: TimeOutSec -> TimeOutSec -> Bool
> :: TimeOutSec -> TimeOutSec -> Bool
$c> :: TimeOutSec -> TimeOutSec -> Bool
<= :: TimeOutSec -> TimeOutSec -> Bool
$c<= :: TimeOutSec -> TimeOutSec -> Bool
< :: TimeOutSec -> TimeOutSec -> Bool
$c< :: TimeOutSec -> TimeOutSec -> Bool
compare :: TimeOutSec -> TimeOutSec -> Ordering
$ccompare :: TimeOutSec -> TimeOutSec -> Ordering
Ord, Int -> TimeOutSec -> ShowS
[TimeOutSec] -> ShowS
TimeOutSec -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TimeOutSec] -> ShowS
$cshowList :: [TimeOutSec] -> ShowS
show :: TimeOutSec -> String
$cshow :: TimeOutSec -> String
showsPrec :: Int -> TimeOutSec -> ShowS
$cshowsPrec :: Int -> TimeOutSec -> ShowS
Show, ReadPrec [TimeOutSec]
ReadPrec TimeOutSec
Int -> ReadS TimeOutSec
ReadS [TimeOutSec]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TimeOutSec]
$creadListPrec :: ReadPrec [TimeOutSec]
readPrec :: ReadPrec TimeOutSec
$creadPrec :: ReadPrec TimeOutSec
readList :: ReadS [TimeOutSec]
$creadList :: ReadS [TimeOutSec]
readsPrec :: Int -> ReadS TimeOutSec
$creadsPrec :: Int -> ReadS TimeOutSec
Read, forall x. Rep TimeOutSec x -> TimeOutSec
forall x. TimeOutSec -> Rep TimeOutSec x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TimeOutSec x -> TimeOutSec
$cfrom :: forall x. TimeOutSec -> Rep TimeOutSec x
Generic, TimeOutSec
Eq TimeOutSec => TimeOutSec -> Bool
forall z.
z -> (Eq z => z -> Bool) -> (Eq z => z -> Bool) -> Zeros z
notZero :: Eq TimeOutSec => TimeOutSec -> Bool
$cnotZero :: Eq TimeOutSec => TimeOutSec -> Bool
isZero :: Eq TimeOutSec => TimeOutSec -> Bool
$cisZero :: Eq TimeOutSec => TimeOutSec -> Bool
zero :: TimeOutSec
$czero :: TimeOutSec
Zeros)
mkTimeOutSec :: Int -> TimeOutSec
mkTimeOutSec :: Int -> TimeOutSec
mkTimeOutSec Int
i = Maybe Int -> TimeOutSec
TimeOutSec (forall a. a -> Maybe a
Just Int
i)
mkTimeOutDefault :: TimeOutSec
mkTimeOutDefault = Maybe Int -> TimeOutSec
TimeOutSec forall a. Maybe a
Nothing

instance NiceStrings TimeOutSec where
    shownice :: TimeOutSec -> Text
shownice (TimeOutSec (Just Int
i)) = forall a. CharChains a => [a] -> a
unwords' [Text
"TimeOut", forall a. NiceStrings a => a -> Text
shownice Int
i, Text
"sec"]
    shownice (TimeOutSec Maybe Int
Nothing) =   Text
"TimeOut default"

-- | a special type for the app type argumetn
newtype AppType = AppType Text
    deriving (AppType -> AppType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AppType -> AppType -> Bool
$c/= :: AppType -> AppType -> Bool
== :: AppType -> AppType -> Bool
$c== :: AppType -> AppType -> Bool
Eq, Eq AppType
AppType -> AppType -> Bool
AppType -> AppType -> Ordering
AppType -> AppType -> AppType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AppType -> AppType -> AppType
$cmin :: AppType -> AppType -> AppType
max :: AppType -> AppType -> AppType
$cmax :: AppType -> AppType -> AppType
>= :: AppType -> AppType -> Bool
$c>= :: AppType -> AppType -> Bool
> :: AppType -> AppType -> Bool
$c> :: AppType -> AppType -> Bool
<= :: AppType -> AppType -> Bool
$c<= :: AppType -> AppType -> Bool
< :: AppType -> AppType -> Bool
$c< :: AppType -> AppType -> Bool
compare :: AppType -> AppType -> Ordering
$ccompare :: AppType -> AppType -> Ordering
Ord, Int -> AppType -> ShowS
[AppType] -> ShowS
AppType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AppType] -> ShowS
$cshowList :: [AppType] -> ShowS
show :: AppType -> String
$cshow :: AppType -> String
showsPrec :: Int -> AppType -> ShowS
$cshowsPrec :: Int -> AppType -> ShowS
Show, ReadPrec [AppType]
ReadPrec AppType
Int -> ReadS AppType
ReadS [AppType]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [AppType]
$creadListPrec :: ReadPrec [AppType]
readPrec :: ReadPrec AppType
$creadPrec :: ReadPrec AppType
readList :: ReadS [AppType]
$creadList :: ReadS [AppType]
readsPrec :: Int -> ReadS AppType
$creadsPrec :: Int -> ReadS AppType
Read, forall x. Rep AppType x -> AppType
forall x. AppType -> Rep AppType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AppType x -> AppType
$cfrom :: forall x. AppType -> Rep AppType x
Generic, AppType
Eq AppType => AppType -> Bool
forall z.
z -> (Eq z => z -> Bool) -> (Eq z => z -> Bool) -> Zeros z
notZero :: Eq AppType => AppType -> Bool
$cnotZero :: Eq AppType => AppType -> Bool
isZero :: Eq AppType => AppType -> Bool
$cisZero :: Eq AppType => AppType -> Bool
zero :: AppType
$czero :: AppType
Zeros)
mkAppType :: Text -> AppType
mkAppType = Text -> AppType
AppType