{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables, DeriveGeneric, DeriveAnyClass,
RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Uniform.HttpCall (module Uniform.HttpCall
, mkServerURI, ServerURI
) where
import UniformBase
import qualified Network.HTTP.Simple as Http
import qualified Network.HTTP.Conduit as Conduit
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
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)]
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
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
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 req2 :: Request
req2 = ByteString -> Request -> Request
Http.setRequestBodyLBS ByteString
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 ]
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
let statusCode :: Int
statusCode = forall a. Response a -> Int
Http.getResponseStatusCode Response ByteString
res
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
forall (m :: * -> *) a. Monad m => a -> m a
return Text
res2
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)
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"
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