{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE OverloadedStrings #-}

module ERPNext.Client
  ( getDocTypeList
  , getDocType
  , postDocType
  , putDocType
  , deleteDocType
  , mkSecret
  , mkConfig
  , IsDocType (..)
  , Config ()
  , Secret ()
  , QueryStringParam (..)
  , ApiResponse (..)
  , getResponse
  ) where

import Network.HTTP.Client (Response (..), Request (..), Manager, httpLbs, parseRequest, RequestBody (..))
import Network.HTTP.Types (hAuthorization, hContentType, Header)
import Data.Text hiding (map)
import Data.Text.Encoding (encodeUtf8)
import Data.Aeson
import Data.ByteString qualified as BS
import Data.ByteString.Lazy qualified as LBS
import ERPNext.Client.QueryStringParams
import ERPNext.Client.Helper (urlEncode)

-- | Type class for types which represent an ERPNext DocType.
-- Each DocType has a unique name.
class IsDocType a where
  docTypeName :: Text
  -- TODO: implement auto-derive (using typename and generic)?

getDocTypeList :: forall a. (IsDocType a, FromJSON a)
               => Manager -> Config  -> [QueryStringParam]-> IO (ApiResponse [a])
getDocTypeList :: forall a.
(IsDocType a, FromJSON a) =>
Manager -> Config -> [QueryStringParam] -> IO (ApiResponse [a])
getDocTypeList Manager
manager Config
config [QueryStringParam]
qsParams = do
  let path :: Text
path = forall a. IsDocType a => Text
forall {k} (a :: k). IsDocType a => Text
getResourcePath @a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"?" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [QueryStringParam] -> Text
renderQueryStringParams [QueryStringParam]
qsParams
  Request
request <- Config -> Text -> ByteString -> IO Request
createRequest Config
config Text
path ByteString
"GET"
  Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
request Manager
manager
  ApiResponse [a] -> IO (ApiResponse [a])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ApiResponse [a] -> IO (ApiResponse [a]))
-> ApiResponse [a] -> IO (ApiResponse [a])
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ApiResponse [a]
forall a. FromJSON a => Response ByteString -> ApiResponse a
parseGetResponse Response ByteString
response

getDocType :: forall a. (IsDocType a, FromJSON a)
           => Manager -> Config -> Text -> IO (ApiResponse a)
getDocType :: forall a.
(IsDocType a, FromJSON a) =>
Manager -> Config -> Text -> IO (ApiResponse a)
getDocType Manager
manager Config
config Text
name = do
  let path :: Text
path = forall a. IsDocType a => Text
forall {k} (a :: k). IsDocType a => Text
getResourcePath @a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
  Request
request <- Config -> Text -> ByteString -> IO Request
createRequest Config
config Text
path ByteString
"GET"
  Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
request Manager
manager
  ApiResponse a -> IO (ApiResponse a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ApiResponse a -> IO (ApiResponse a))
-> ApiResponse a -> IO (ApiResponse a)
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ApiResponse a
forall a. FromJSON a => Response ByteString -> ApiResponse a
parseGetResponse Response ByteString
response

{- | Delete a named object.

The phantom type parameter @a@ is used to figure out the DocType.
A customer can be deleted like this:

@
res <- deleteDocType @Customer manager config "<customer name>"
@
-}
deleteDocType :: forall a. (IsDocType a)
              => Manager -> Config -> Text -> IO (ApiResponse ())
deleteDocType :: forall {k} (a :: k).
IsDocType a =>
Manager -> Config -> Text -> IO (ApiResponse ())
deleteDocType Manager
manager Config
config Text
name = do
  let path :: Text
path = forall (a :: k). IsDocType a => Text
forall {k} (a :: k). IsDocType a => Text
getResourcePath @a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
  Request
request <- Config -> Text -> ByteString -> IO Request
createRequest Config
config Text
path ByteString
"DELETE"
  Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
request Manager
manager
  ApiResponse () -> IO (ApiResponse ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ApiResponse () -> IO (ApiResponse ()))
-> ApiResponse () -> IO (ApiResponse ())
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ApiResponse ()
parseDeleteResponse Response ByteString
response

postDocType :: forall a. (IsDocType a, FromJSON a, ToJSON a)
            => Manager -> Config -> a -> IO (ApiResponse a)
postDocType :: forall a.
(IsDocType a, FromJSON a, ToJSON a) =>
Manager -> Config -> a -> IO (ApiResponse a)
postDocType Manager
manager Config
config a
doc = do
  let path :: Text
path = forall a. IsDocType a => Text
forall {k} (a :: k). IsDocType a => Text
getResourcePath @a
  Request
request <- Config -> Text -> ByteString -> a -> IO Request
forall a.
ToJSON a =>
Config -> Text -> ByteString -> a -> IO Request
createRequestWithBody Config
config Text
path ByteString
"POST" a
doc
  Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
request Manager
manager
  ApiResponse a -> IO (ApiResponse a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ApiResponse a -> IO (ApiResponse a))
-> ApiResponse a -> IO (ApiResponse a)
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ApiResponse a
forall a. FromJSON a => Response ByteString -> ApiResponse a
parseGetResponse Response ByteString
response

putDocType :: forall a. (IsDocType a, FromJSON a, ToJSON a)
           => Manager -> Config -> Text -> a -> IO (ApiResponse a)
putDocType :: forall a.
(IsDocType a, FromJSON a, ToJSON a) =>
Manager -> Config -> Text -> a -> IO (ApiResponse a)
putDocType Manager
manager Config
config Text
name a
doc = do
  let path :: Text
path = forall a. IsDocType a => Text
forall {k} (a :: k). IsDocType a => Text
getResourcePath @a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
  Request
request <- Config -> Text -> ByteString -> a -> IO Request
forall a.
ToJSON a =>
Config -> Text -> ByteString -> a -> IO Request
createRequestWithBody Config
config Text
path ByteString
"PUT" a
doc
  Response ByteString
response <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
request Manager
manager
  ApiResponse a -> IO (ApiResponse a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ApiResponse a -> IO (ApiResponse a))
-> ApiResponse a -> IO (ApiResponse a)
forall a b. (a -> b) -> a -> b
$ Response ByteString -> ApiResponse a
forall a. FromJSON a => Response ByteString -> ApiResponse a
parseGetResponse Response ByteString
response


mkConfig :: Text -> Text -> Secret -> Config
mkConfig :: Text -> Text -> Secret -> Config
mkConfig Text
baseUrl Text
apiKey Secret
apiSecret = Config
  { baseUrl :: Text
baseUrl = Text
baseUrl
  , apiKey :: Text
apiKey = Text
apiKey
  , apiSecret :: Secret
apiSecret = Secret
apiSecret
  }

-- | Create the API secret used together with the API key for authorization.
mkSecret :: Text -> Secret
mkSecret :: Text -> Secret
mkSecret = Text -> Secret
Secret


-- | Create the API Request.
createRequest :: Config -> Text -> BS.ByteString -> IO Request
createRequest :: Config -> Text -> ByteString -> IO Request
createRequest Config
config Text
path ByteString
method = do
  Request
request <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (String -> IO Request) -> String -> IO Request
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack (Config -> Text
baseUrl Config
config Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path)
  Request -> IO Request
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Request
request
    { method = method
    , requestHeaders = [mkAuthHeader config]
    }

createRequestWithBody :: ToJSON a => Config -> Text -> BS.ByteString -> a -> IO Request
createRequestWithBody :: forall a.
ToJSON a =>
Config -> Text -> ByteString -> a -> IO Request
createRequestWithBody Config
config Text
path ByteString
method a
doc = do
  Request
request <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest (String -> IO Request) -> String -> IO Request
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack (Config -> Text
baseUrl Config
config Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
path)
  Request -> IO Request
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Request
request
    { method = method
    , requestHeaders = mkAuthHeader config : [(hContentType, encodeUtf8 "application/json")]
    , requestBody = RequestBodyLBS (encode doc)
    }

-- | API client configuration.
data Config = Config
  { Config -> Text
baseUrl :: Text
  , Config -> Text
apiKey :: Text
  , Config -> Secret
apiSecret :: Secret
  }

-- | Opaque type to store the API secret.
data Secret = Secret
  { Secret -> Text
getSecret :: Text
  }

data DataWrapper a = DataWrapper { forall a. DataWrapper a -> a
getData :: a }
  deriving Int -> DataWrapper a -> ShowS
[DataWrapper a] -> ShowS
DataWrapper a -> String
(Int -> DataWrapper a -> ShowS)
-> (DataWrapper a -> String)
-> ([DataWrapper a] -> ShowS)
-> Show (DataWrapper a)
forall a. Show a => Int -> DataWrapper a -> ShowS
forall a. Show a => [DataWrapper a] -> ShowS
forall a. Show a => DataWrapper a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> DataWrapper a -> ShowS
showsPrec :: Int -> DataWrapper a -> ShowS
$cshow :: forall a. Show a => DataWrapper a -> String
show :: DataWrapper a -> String
$cshowList :: forall a. Show a => [DataWrapper a] -> ShowS
showList :: [DataWrapper a] -> ShowS
Show

instance FromJSON a => FromJSON (DataWrapper a) where
  parseJSON :: Value -> Parser (DataWrapper a)
parseJSON = String
-> (Object -> Parser (DataWrapper a))
-> Value
-> Parser (DataWrapper a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"DataWrapper" ((Object -> Parser (DataWrapper a))
 -> Value -> Parser (DataWrapper a))
-> (Object -> Parser (DataWrapper a))
-> Value
-> Parser (DataWrapper a)
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    a
dataValue <- Object
obj Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"data"
    DataWrapper a -> Parser (DataWrapper a)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> DataWrapper a
forall a. a -> DataWrapper a
DataWrapper a
dataValue)

data ApiResponse a
  = Ok (Response LBS.ByteString) Value a
  | Err (Response LBS.ByteString) (Maybe (Value, Text))
  deriving Int -> ApiResponse a -> ShowS
[ApiResponse a] -> ShowS
ApiResponse a -> String
(Int -> ApiResponse a -> ShowS)
-> (ApiResponse a -> String)
-> ([ApiResponse a] -> ShowS)
-> Show (ApiResponse a)
forall a. Show a => Int -> ApiResponse a -> ShowS
forall a. Show a => [ApiResponse a] -> ShowS
forall a. Show a => ApiResponse a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> ApiResponse a -> ShowS
showsPrec :: Int -> ApiResponse a -> ShowS
$cshow :: forall a. Show a => ApiResponse a -> String
show :: ApiResponse a -> String
$cshowList :: forall a. Show a => [ApiResponse a] -> ShowS
showList :: [ApiResponse a] -> ShowS
Show

getResponse :: ApiResponse a -> Response LBS.ByteString
getResponse :: forall a. ApiResponse a -> Response ByteString
getResponse (Ok Response ByteString
r Value
_ a
_) = Response ByteString
r
getResponse (Err Response ByteString
r Maybe (Value, Text)
_) = Response ByteString
r

mkAuthHeader :: Config -> Header
mkAuthHeader :: Config -> Header
mkAuthHeader Config
config = let authToken :: Text
authToken = Config -> Text
apiKey Config
config Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Secret -> Text
getSecret (Config -> Secret
apiSecret Config
config)
                          in (HeaderName
hAuthorization, Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text
"token " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
authToken)

parseGetResponse :: forall a. FromJSON a => Response LBS.ByteString -> ApiResponse a
parseGetResponse :: forall a. FromJSON a => Response ByteString -> ApiResponse a
parseGetResponse Response ByteString
response =
  case forall a. FromJSON a => ByteString -> Maybe a
decode @Value (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
response) of
    Just Value
value -> case Value -> Result (DataWrapper a)
forall a. FromJSON a => Value -> Result a
fromJSON Value
value :: Result (DataWrapper a) of
      Success DataWrapper a
result -> Response ByteString -> Value -> a -> ApiResponse a
forall a. Response ByteString -> Value -> a -> ApiResponse a
Ok Response ByteString
response Value
value (DataWrapper a -> a
forall a. DataWrapper a -> a
getData DataWrapper a
result)
      Error String
err -> Response ByteString -> Maybe (Value, Text) -> ApiResponse a
forall a.
Response ByteString -> Maybe (Value, Text) -> ApiResponse a
Err Response ByteString
response ((Value, Text) -> Maybe (Value, Text)
forall a. a -> Maybe a
Just (Value
value, String -> Text
pack String
err))
    Maybe Value
Nothing -> Response ByteString -> Maybe (Value, Text) -> ApiResponse a
forall a.
Response ByteString -> Maybe (Value, Text) -> ApiResponse a
Err Response ByteString
response Maybe (Value, Text)
forall a. Maybe a
Nothing

parseDeleteResponse :: Response LBS.ByteString -> ApiResponse ()
parseDeleteResponse :: Response ByteString -> ApiResponse ()
parseDeleteResponse Response ByteString
response =
  case forall a. FromJSON a => ByteString -> Maybe a
decode @Value (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
response) of
    Just Value
value -> case Value -> Result (DataWrapper Text)
forall a. FromJSON a => Value -> Result a
fromJSON Value
value :: Result (DataWrapper Text) of
      Success (DataWrapper Text
message)
        | Text
message Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"ok" -> Response ByteString -> Value -> () -> ApiResponse ()
forall a. Response ByteString -> Value -> a -> ApiResponse a
Ok Response ByteString
response Value
value ()
        | Bool
otherwise -> Response ByteString -> Maybe (Value, Text) -> ApiResponse ()
forall a.
Response ByteString -> Maybe (Value, Text) -> ApiResponse a
Err Response ByteString
response ((Value, Text) -> Maybe (Value, Text)
forall a. a -> Maybe a
Just (Value
value, Text
message))
      Error String
err -> Response ByteString -> Maybe (Value, Text) -> ApiResponse ()
forall a.
Response ByteString -> Maybe (Value, Text) -> ApiResponse a
Err Response ByteString
response ((Value, Text) -> Maybe (Value, Text)
forall a. a -> Maybe a
Just (Value
value, String -> Text
pack String
err))
    Maybe Value
Nothing -> Response ByteString -> Maybe (Value, Text) -> ApiResponse ()
forall a.
Response ByteString -> Maybe (Value, Text) -> ApiResponse a
Err Response ByteString
response Maybe (Value, Text)
forall a. Maybe a
Nothing

getResourcePath :: forall a. IsDocType a => Text
getResourcePath :: forall {k} (a :: k). IsDocType a => Text
getResourcePath = Text
"/resource/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
urlEncode (forall (a :: k). IsDocType a => Text
forall {k} (a :: k). IsDocType a => Text
docTypeName @a)