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

{-|
Description: Generic API client library for ERPNext

This is a Haskell API client for ERPNext. It aims to be a light-weight
library based on http-client and user-provided record types.

API documentation:

https://docs.frappe.io/framework/user/en/api/rest
-}

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 but there can still be multiple
-- „views“ (i.e. records types) for one DocType.
class IsDocType a where
  docTypeName :: Text

{-|
  Get a list of all documents of a given DocType.
  The 'QueryStringParam's can select fields, filter, order, enable
  paging, and more.
-}
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

-- | Get a single document of a given DocType by name.
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 single document of a given DocType by name.

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

-- | Create a new document of a given DocType.
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

-- | Update a document of a given DocType by name.
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

-- | Create an API client configuration.
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]
    }

-- | Create the API 'Request' with a JSON body.
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 wrapper type just to parse the JSON returned by ERPNext.
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)

-- | The API response.
data ApiResponse a
  = Ok -- ^ The OK response.
      (Response LBS.ByteString) -- ^ The server's full response including header information.
      Value -- ^ The returned JSON.
      a -- ^ The result parsed from the returned JSON.
  | Err -- ^ The error response.
      (Response LBS.ByteString) -- ^ The server's full response including header information.
      (Maybe (Value, Text)) -- ^ If the response is valid JSON, 'Just' the returned JSON and
                            -- the parse error message telling why 'Value' couldn't be parsed
                            -- into @a@.
  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

-- | Get the full response from the API response.
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)