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

module Web.Eved.Client
    where

import           Control.Monad.Reader
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           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 -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ 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 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ 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 (ContentType a -> a -> ByteString
forall a. ContentType a -> a -> ByteString
CT.toContentType ContentType a
ctype a
a)
                       , requestHeaders :: RequestHeaders
HttpClient.requestHeaders = (ContentType a -> Header
forall a. ContentType a -> Header
CT.contentTypeHeader ContentType a
ctype)Header -> 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 -> (Text, Maybe Text)) -> [Text] -> QueryText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\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] -> QueryText) -> [Text] -> QueryText
forall a b. (a -> b) -> a -> 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)}

    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)
ctypes)Header -> 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)
-> ByteString -> Maybe (ByteString -> Either Text a)
forall a.
NonEmpty (ContentType a)
-> ByteString -> Maybe (ByteString -> Either Text a)
CT.chooseContentCType NonEmpty (ContentType a)
ctypes (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
=<< (HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType (RequestHeaders -> Maybe ByteString)
-> RequestHeaders -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ 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"