{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}

module Web.Eved.Client
    where

import           Control.Monad.Reader
import qualified Data.CaseInsensitive as CI
import           Data.List.NonEmpty   (NonEmpty (..))
import           Data.Maybe           (mapMaybe)
import           Data.Text            (Text)
import qualified Data.Text            as T
import           Data.Text.Encoding   (encodeUtf8)
import qualified Network.HTTP.Client  as HttpClient
import           Network.HTTP.Types   (hContentType, parseQuery,
                                       queryTextToQuery, queryToQueryText,
                                       renderQuery, renderStdMethod)
import qualified Web.Eved.ContentType as CT
import qualified Web.Eved.Header      as H
import           Web.Eved.Internal
import qualified Web.Eved.QueryParam  as QP
import qualified Web.Eved.UrlElement  as UE
import qualified Web.HttpApiData      as HttpApiData

newtype ClientM a = ClientM { ClientM a -> ReaderT Manager IO a
unClientM :: ReaderT HttpClient.Manager IO a }

runClientIO :: ClientM a -> IO a
runClientIO :: ClientM a -> IO a
runClientIO ClientM a
m = do
    ManagerSettings -> IO Manager
HttpClient.newManager ManagerSettings
HttpClient.defaultManagerSettings
        IO Manager -> (Manager -> IO a) -> IO a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT Manager IO a -> Manager -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ClientM a -> ReaderT Manager IO a
forall (m :: * -> *) env a.
(MonadIO m, MonadReader env m, HasHttpManager env) =>
ClientM a -> m a
runClient ClientM a
m)

runClient :: (MonadIO m, MonadReader env m, HttpClient.HasHttpManager env) => ClientM a -> m a
runClient :: ClientM a -> m a
runClient (ClientM ReaderT Manager IO a
m) =
    (env -> Manager) -> m Manager
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks env -> Manager
forall a. HasHttpManager a => a -> Manager
HttpClient.getHttpManager m Manager -> (Manager -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> (Manager -> IO a) -> Manager -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT Manager IO a -> Manager -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Manager IO a
m)

newtype EvedClient a = EvedClient
    { EvedClient a -> Request -> a
client :: HttpClient.Request -> a
    }

getClient :: EvedClient a -> Text -> a
getClient :: EvedClient a -> Text -> a
getClient (EvedClient Request -> a
f) = Request -> a
f (Request -> a) -> (Text -> Request) -> Text -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Request
HttpClient.parseRequest_ (String -> Request) -> (Text -> String) -> Text -> Request
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

instance Eved EvedClient ClientM where
    EvedClient a
l .<|> :: EvedClient a -> EvedClient b -> EvedClient (a :<|> b)
.<|> EvedClient b
r = (Request -> a :<|> b) -> EvedClient (a :<|> b)
forall a. (Request -> a) -> EvedClient a
EvedClient ((Request -> a :<|> b) -> EvedClient (a :<|> b))
-> (Request -> a :<|> b) -> EvedClient (a :<|> b)
forall a b. (a -> b) -> a -> b
$ \Request
req ->
        EvedClient a -> Request -> a
forall a. EvedClient a -> Request -> a
client EvedClient a
l Request
req a -> b -> a :<|> b
forall a b. a -> b -> a :<|> b
:<|> EvedClient b -> Request -> b
forall a. EvedClient a -> Request -> a
client EvedClient b
r Request
req

    lit :: Text -> EvedClient a -> EvedClient a
lit Text
s EvedClient a
next = (Request -> a) -> EvedClient a
forall a. (Request -> a) -> EvedClient a
EvedClient ((Request -> a) -> EvedClient a) -> (Request -> a) -> EvedClient a
forall a b. (a -> b) -> a -> b
$ \Request
req ->
        EvedClient a -> Request -> a
forall a. EvedClient a -> Request -> a
client EvedClient a
next Request
req{ path :: ByteString
HttpClient.path = Request -> ByteString
HttpClient.path Request
req ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
encodeUtf8 (Text -> Text
forall a. ToHttpApiData a => a -> Text
HttpApiData.toUrlPiece Text
s) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/"}
    capture :: Text -> UrlElement a -> EvedClient b -> EvedClient (a -> b)
capture Text
s UrlElement a
el EvedClient b
next = (Request -> a -> b) -> EvedClient (a -> b)
forall a. (Request -> a) -> EvedClient a
EvedClient ((Request -> a -> b) -> EvedClient (a -> b))
-> (Request -> a -> b) -> EvedClient (a -> b)
forall a b. (a -> b) -> a -> b
$ \Request
req a
a ->
        EvedClient b -> Request -> b
forall a. EvedClient a -> Request -> a
client EvedClient b
next Request
req{ path :: ByteString
HttpClient.path = Request -> ByteString
HttpClient.path Request
req ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
encodeUtf8 (UrlElement a -> a -> Text
forall a. UrlElement a -> a -> Text
UE.toUrlPiece UrlElement a
el a
a) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/" }
    reqBody :: NonEmpty (ContentType a) -> EvedClient b -> EvedClient (a -> b)
reqBody (ContentType a
ctype:|[ContentType a]
_) EvedClient b
next = (Request -> a -> b) -> EvedClient (a -> b)
forall a. (Request -> a) -> EvedClient a
EvedClient ((Request -> a -> b) -> EvedClient (a -> b))
-> (Request -> a -> b) -> EvedClient (a -> b)
forall a b. (a -> b) -> a -> b
$ \Request
req a
a ->
        EvedClient b -> Request -> b
forall a. EvedClient a -> Request -> a
client EvedClient b
next Request
req{ requestBody :: RequestBody
HttpClient.requestBody = ByteString -> RequestBody
HttpClient.RequestBodyLBS ((RequestHeaders, ByteString) -> ByteString
forall a b. (a, b) -> b
snd ((RequestHeaders, ByteString) -> ByteString)
-> (RequestHeaders, ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ ContentType a -> a -> (RequestHeaders, ByteString)
forall a. ContentType a -> a -> (RequestHeaders, ByteString)
CT.toContentType ContentType a
ctype a
a)
                       , requestHeaders :: RequestHeaders
HttpClient.requestHeaders = ContentType a -> Header
forall a. ContentType a -> Header
CT.contentTypeHeader ContentType a
ctypeHeader -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
:Request -> RequestHeaders
HttpClient.requestHeaders Request
req
                       }
    queryParam :: Text -> QueryParam a -> EvedClient b -> EvedClient (a -> b)
queryParam Text
argName QueryParam a
el EvedClient b
next = (Request -> a -> b) -> EvedClient (a -> b)
forall a. (Request -> a) -> EvedClient a
EvedClient ((Request -> a -> b) -> EvedClient (a -> b))
-> (Request -> a -> b) -> EvedClient (a -> b)
forall a b. (a -> b) -> a -> b
$ \Request
req a
val ->
        EvedClient b -> Request -> b
forall a. EvedClient a -> Request -> a
client EvedClient b
next Request
req{queryString :: ByteString
HttpClient.queryString =
            let query :: Query
query = ByteString -> Query
parseQuery (ByteString -> Query) -> ByteString -> Query
forall a b. (a -> b) -> a -> b
$ Request -> ByteString
HttpClient.queryString Request
req
                queryText :: QueryText
queryText = Query -> QueryText
queryToQueryText Query
query
                newArgs :: QueryText
newArgs = (\Text
v -> (Text -> Text
forall a. ToHttpApiData a => a -> Text
HttpApiData.toUrlPiece Text
argName, Text -> Maybe Text
forall a. a -> Maybe a
Just Text
v)) (Text -> (Text, Maybe Text)) -> [Text] -> QueryText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QueryParam a -> a -> [Text]
forall a. QueryParam a -> a -> [Text]
QP.toQueryParam QueryParam a
el a
val
            in Bool -> Query -> ByteString
renderQuery Bool
False (Query -> ByteString) -> Query -> ByteString
forall a b. (a -> b) -> a -> b
$ QueryText -> Query
queryTextToQuery (QueryText
newArgs QueryText -> QueryText -> QueryText
forall a. Semigroup a => a -> a -> a
<> QueryText
queryText)}


    header :: Text -> Header a -> EvedClient b -> EvedClient (a -> b)
header Text
headerName Header a
el EvedClient b
next = (Request -> a -> b) -> EvedClient (a -> b)
forall a. (Request -> a) -> EvedClient a
EvedClient ((Request -> a -> b) -> EvedClient (a -> b))
-> (Request -> a -> b) -> EvedClient (a -> b)
forall a b. (a -> b) -> a -> b
$ \Request
req a
val ->
        let headers :: RequestHeaders
headers = Request -> RequestHeaders
HttpClient.requestHeaders Request
req
            ciHeaderName :: CI ByteString
ciHeaderName = ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (Text -> ByteString
encodeUtf8 Text
headerName)
            newHeaders :: RequestHeaders
newHeaders = RequestHeaders
-> (ByteString -> RequestHeaders)
-> Maybe ByteString
-> RequestHeaders
forall b a. b -> (a -> b) -> Maybe a -> b
maybe RequestHeaders
headers (\ByteString
v -> (CI ByteString
ciHeaderName, ByteString
v)Header -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
:RequestHeaders
headers) (Header a -> a -> Maybe ByteString
forall a. Header a -> a -> Maybe ByteString
H.toHeaderValue Header a
el a
val)
        in EvedClient b -> Request -> b
forall a. EvedClient a -> Request -> a
client EvedClient b
next Request
req{requestHeaders :: RequestHeaders
HttpClient.requestHeaders = RequestHeaders
newHeaders}


    verb :: StdMethod
-> Status -> NonEmpty (ContentType a) -> EvedClient (ClientM a)
verb StdMethod
method Status
_status NonEmpty (ContentType a)
ctypes = (Request -> ClientM a) -> EvedClient (ClientM a)
forall a. (Request -> a) -> EvedClient a
EvedClient ((Request -> ClientM a) -> EvedClient (ClientM a))
-> (Request -> ClientM a) -> EvedClient (ClientM a)
forall a b. (a -> b) -> a -> b
$ \Request
req -> ReaderT Manager IO a -> ClientM a
forall a. ReaderT Manager IO a -> ClientM a
ClientM (ReaderT Manager IO a -> ClientM a)
-> ReaderT Manager IO a -> ClientM a
forall a b. (a -> b) -> a -> b
$ do
        let reqWithMethod :: Request
reqWithMethod = Request
req{ method :: ByteString
HttpClient.method = StdMethod -> ByteString
renderStdMethod StdMethod
method
                               , requestHeaders :: RequestHeaders
HttpClient.requestHeaders = NonEmpty (ContentType a) -> Header
forall a. NonEmpty (ContentType a) -> Header
CT.acceptHeader NonEmpty (ContentType a)
ctypesHeader -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
:Request -> RequestHeaders
HttpClient.requestHeaders Request
req
                               }
        Manager
manager <- ReaderT Manager IO Manager
forall r (m :: * -> *). MonadReader r m => m r
ask
        Response ByteString
resp <- IO (Response ByteString)
-> ReaderT Manager IO (Response ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Response ByteString)
 -> ReaderT Manager IO (Response ByteString))
-> IO (Response ByteString)
-> ReaderT Manager IO (Response ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
HttpClient.httpLbs Request
reqWithMethod Manager
manager
        let mBodyParser :: Maybe (ByteString -> Either Text a)
mBodyParser = NonEmpty (ContentType a)
-> RequestHeaders
-> ByteString
-> Maybe (ByteString -> Either Text a)
forall a.
NonEmpty (ContentType a)
-> RequestHeaders
-> ByteString
-> Maybe (ByteString -> Either Text a)
CT.chooseContentCType NonEmpty (ContentType a)
ctypes RequestHeaders
forall a. Monoid a => a
mempty (ByteString -> Maybe (ByteString -> Either Text a))
-> Maybe ByteString -> Maybe (ByteString -> Either Text a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CI ByteString -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
hContentType (Response ByteString -> RequestHeaders
forall body. Response body -> RequestHeaders
HttpClient.responseHeaders Response ByteString
resp)
        case Maybe (ByteString -> Either Text a)
mBodyParser of
          Just ByteString -> Either Text a
bodyParser  -> case ByteString -> Either Text a
bodyParser (Response ByteString -> ByteString
forall body. Response body -> body
HttpClient.responseBody Response ByteString
resp) of
                                Right a
a -> a -> ReaderT Manager IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
                                Left Text
_ -> String -> ReaderT Manager IO a
forall a. HasCallStack => String -> a
error String
"Unimplemented: Content-Type matched but parse failed"
          Maybe (ByteString -> Either Text a)
Nothing -> String -> ReaderT Manager IO a
forall a. HasCallStack => String -> a
error String
"Unimplemented: No Matching Content-Type"