diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for hsforce + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Makoto Tajitsu (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,87 @@ +# hsforce + +## Usage + + +Login and create Salesforce client. +```haskell +main :: IO () +main = do + username <- getEnv "SALESFORCE_USERNAME" + password <- getEnv "SALESFORCE_PASSWORD" + endpoint <- getEnv "SALESFORCE_ENDPOINT" + version <- getEnv "SALESFORCE_VERSION" + client <- login username password endpoint version +``` + +create data type that is SObject class. +```haskell +import Data.Aeson as JSON +import Data.Maybe + +data Account = Account{ + sfid :: Maybe String, + name :: Maybe String, + ex :: Maybe String +} deriving Show + +instance SObject Account where + typeName a = "Account" + getSfid = fromJust . sfid + +instance FromJSON Account where + parseJSON = withObject "Account" $ \v -> do + sfid <- v .: "Id" + name <- v .:? "Name" + ex <- v .:? "Ex__c" + return Account{..} + +instance ToJSON Account where + toJSON (Account{sfid, name, ex}) = + object ["Name" .= name] +``` + +CRUD API +```haskell +-- insert object +insert client Account{sfid = Nothing, name = Just "hogehoge", ex = Nothing} + +-- update object +update client Account{sfid = Just "xxxx", name = Just "foobar"} + +-- upsert object +upsert client Account{sfid = Nothing, name = Just "foobar", ex = Just "aaa"} "Ex__c" "aaa" + +-- delete object +delete client Account{sfid = Just "xxxx"} + +-- query +query client "SELECT Id, Name FROM Account WHERE Name = 'foobar'" (Proxy :: Proxy Account) + +-- queryMore +queryMore client "/services/data/v20.0/query/01gD0000002HU6KIAW-2000" (Proxy :: Proxy Account) + +-- queryAll +queryAll client "SELECT Id, Name FROM Account WHERE Name = 'foobar'" (Proxy :: Proxy Account) + +-- queryAllMore +queryAllMore client "/services/data/v20.0/queryMore/01gD0000002HU6KIAW-2000" (Proxy :: Proxy Account) + +-- explain +explain client "SELECT Id FROM Account" + +-- describe +describe client "Account" (Proxy :: Proxy Account) + +-- describeDetail +describeDetail client "Account" + +-- describeGlobal +describeGlobal client + +-- recordCount +recordCount client ["Account", "Contact", "Opportunity"] + +-- versions +versions client +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hsforce.cabal b/hsforce.cabal new file mode 100644 --- /dev/null +++ b/hsforce.cabal @@ -0,0 +1,79 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.1. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 6764d99a784870da8c00196566658baa3bc1aedb33d2719c647a89080a667cd5 + +name: hsforce +version: 0.1.0.0 +synopsis: Salesforce API Client +description: This package provides bindings to Salesforce API +category: Web +homepage: https://github.com/tzmfreedom/hsforce#readme +bug-reports: https://github.com/tzmfreedom/hsforce/issues +author: Makoto Tajitsu +maintainer: makoto_tajitsu@hotmail.co.jp +copyright: 2019 Makoto Tajitsu +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/tzmfreedom/hsforce + +library + exposed-modules: + HSForce + HSForce.Client + HSForce.Types + HSForce.Util + other-modules: + Paths_hsforce + hs-source-dirs: + src + build-depends: + HaXml >=1.25.4 && <1.26 + , aeson >=1.4.2 && <1.5 + , base >=4.7 && <5 + , bytestring >=0.10.8 && <0.11 + , fast-tagsoup >=1.0.14 && <1.1 + , http-conduit >=2.3.4 && <2.4 + , network-uri >=2.6.1 && <2.7 + , regex-posix >=0.95.2 && <0.96 + , tagsoup >=0.14.7 && <0.15 + , template-haskell >=2.14.0 && <2.15 + , text >=1.2.2 && <1.3 + , unordered-containers >=0.2.7 && <0.3 + , uri-encode >=1.5.0 && <1.6 + default-language: Haskell2010 + +test-suite hsforce-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_hsforce + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + HaXml >=1.25.4 && <1.26 + , aeson >=1.4.2 && <1.5 + , base >=4.7 && <5 + , bytestring >=0.10.8 && <0.11 + , fast-tagsoup >=1.0.14 && <1.1 + , hsforce + , http-conduit >=2.3.4 && <2.4 + , network-uri >=2.6.1 && <2.7 + , regex-posix >=0.95.2 && <0.96 + , tagsoup >=0.14.7 && <0.15 + , template-haskell >=2.14.0 && <2.15 + , text >=1.2.2 && <1.3 + , unordered-containers >=0.2.7 && <0.3 + , uri-encode >=1.5.0 && <1.6 + default-language: Haskell2010 diff --git a/src/HSForce.hs b/src/HSForce.hs new file mode 100644 --- /dev/null +++ b/src/HSForce.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} + +module HSForce + ( login, + soapLogin, + restLogin, + defaultLoginRequest, + HSForce.versions, + HSForce.query, + HSForce.queryAll, + HSForce.queryMore, + HSForce.queryAllMore, + HSForce.recordCount, + HSForce.insert, + HSForce.update, + HSForce.upsert, + HSForce.delete, + HSForce.describe, + HSForce.describeDetail, + HSForce.describeGlobal, + HSForce.explain, + HSForce.Types.SObject(..), + HSForce.Client.SFClient(..), + ) where + +import Network.HTTP.Conduit +import Network.URI +import Network.URI.Encode as URI +import System.IO +import System.Environment +import Data.Aeson as JSON +import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..)) +import Data.ByteString.Char8 as B8 +import Data.ByteString.Lazy.Char8 as BL8 +import Data.Proxy as DP +import Data.Maybe +import Data.List as L +import Text.HTML.TagSoup.Entity +import Text.XML.HaXml +import Text.XML.HaXml.Posn +import Text.XML.HaXml.Util +import Text.XML.HaXml.Xtract.Parse +import Text.Regex.Posix +import GHC.Generics +import HSForce.Util +import HSForce.Client +import HSForce.Types + +query :: (FromJSON a) => SFClient -> String -> DP.Proxy a -> IO (QueryResponse a) +query client q _ = do + let path = dataPath client ++ "/query/?q=" ++ URI.encode q + response <- requestGet client path + let res = (JSON.decode $ responseBody response) :: (FromJSON a) => Maybe (QueryResponse a) + return (fromJust res) + +queryMore :: (FromJSON a) => SFClient -> String -> DP.Proxy a -> IO (QueryResponse a) +queryMore client qpath _ = do + response <- requestGet client qpath + let res = (JSON.decode $ responseBody response) :: (FromJSON a) => Maybe (QueryResponse a) + return (fromJust res) + +queryAll :: (FromJSON a) => SFClient -> String -> DP.Proxy a -> IO (QueryResponse a) +queryAll client q _ = do + let path = dataPath client ++ "/queryAll/?q=" ++ URI.encode q + response <- requestGet client path + let res = (JSON.decode $ responseBody response) :: (FromJSON a) => Maybe (QueryResponse a) + return (fromJust res) + +queryAllMore :: (FromJSON a) => SFClient -> String -> DP.Proxy a -> IO (QueryResponse a) +queryAllMore client qpath _ = do + response <- requestGet client qpath + let res = (JSON.decode $ responseBody response) :: (FromJSON a) => Maybe (QueryResponse a) + return (fromJust res) + +explain :: SFClient -> String -> IO (Explain) +explain client q = do + let path = dataPath client ++ "/query/?explain=" ++ URI.encode q + response <- requestGet client path + let res = (JSON.decode $ responseBody response) :: Maybe Explain + return (fromJust res) + +search :: (FromJSON a) => SFClient -> String -> DP.Proxy a -> IO (QueryResponse a) +search client q _ = do + let path = dataPath client ++ "/search/?q=" ++ URI.encode q + response <- requestGet client path + let res = (JSON.decode $ responseBody response) :: (FromJSON a) => Maybe (QueryResponse a) + return (fromJust res) + +recordCount :: SFClient -> [String] -> IO (RecordCount) +recordCount client objects = do + let path = dataPath client ++ "/limits/recordCount?sObjects=" ++ L.intercalate "," objects + response <- requestGet client path + let res = (JSON.decode $ responseBody response) :: Maybe RecordCount + return (fromJust res) + +versions :: SFClient -> IO ([Version]) +versions client = do + response <- requestGet client "/services/data" + let res = (JSON.decode $ responseBody response) :: Maybe [Version] + return (fromJust res) + +batchRequest :: (ToJSON a) => SFClient -> [BatchRequest a] -> IO () +batchRequest client requests = do + let path = dataPath client ++ "/composite/batch" + response <- requestPost client path $ BL8.unpack $ JSON.encode requests -- TODO: impl + return () + +tree :: (ToJSON a, SObject a) => SFClient -> [a] -> IO () +tree client objects = do + let path = dataPath client ++ "/composite/tree/" ++ typeName (objects !! 0) + response <- requestPost client path $ BL8.unpack $ JSON.encode objects + return () + +insert :: (SObject a, ToJSON a) => SFClient -> a -> IO () +insert client object = do + let path = dataPath client ++ "/sobjects/" ++ typeName object + response <- requestPost client path $ BL8.unpack $ JSON.encode object + return () + +update :: (SObject a, ToJSON a) => SFClient -> a -> IO () +update client object = do + let path = dataPath client ++ "/sobjects/" ++ typeName object ++ '/':getSfid object + response <- requestPatch client path $ BL8.unpack $ JSON.encode object + return () + +upsert :: (SObject a, ToJSON a) => SFClient -> a -> String -> String -> IO () +upsert client object upsertKey upsertKeyValue = do + let path = dataPath client ++ "/sobjects/" ++ typeName object ++ '/':upsertKey ++ '/':upsertKeyValue + response <- requestPatch client path $ BL8.unpack $ JSON.encode object + return () + +delete :: (SObject a, ToJSON a) => SFClient -> a -> IO () +delete client object = do + let path = dataPath client ++ "/sobjects/" ++ typeName object ++ '/':getSfid object + response <- requestDelete client path + return () + +describe :: (FromJSON a) => SFClient -> String -> DP.Proxy a -> IO (DescribeResponse a) +describe client objectName _ = do + let path = dataPath client ++ "/sobjects/" ++ objectName + response <- requestGet client path + let res = (JSON.decode $ responseBody response) :: (FromJSON a) => Maybe (DescribeResponse a) + return (fromJust res) + +describeDetail :: SFClient -> String -> IO (DescribeDetail) +describeDetail client objectName = do + let path = dataPath client ++ "/sobjects/" ++ objectName ++ "/describe" + response <- requestGet client path + let res = (JSON.decode $ responseBody response) :: Maybe DescribeDetail + return (fromJust res) + +describeGlobal :: SFClient -> IO GlobalDescribeResponse +describeGlobal client = do + let path = dataPath client ++ "/sobjects" + response <- requestGet client path + let res = (JSON.decode $ responseBody response) :: Maybe GlobalDescribeResponse + return (fromJust res) diff --git a/src/HSForce/Client.hs b/src/HSForce/Client.hs new file mode 100644 --- /dev/null +++ b/src/HSForce/Client.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} + +module HSForce.Client where + +import Network.HTTP.Conduit +import Network.URI +import Network.URI.Encode as URI +import System.IO +import System.Environment +import Data.Aeson as JSON +import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..)) +import Data.ByteString.Char8 as B8 +import Data.ByteString.Lazy.Char8 as BL8 +import Data.Proxy as DP +import Data.Maybe +import Data.Text as T +import Data.HashMap.Strict as M +import Data.List as L +import Text.HTML.TagSoup.Entity +import Text.XML.HaXml +import Text.XML.HaXml.Posn +import Text.XML.HaXml.Util +import Text.XML.HaXml.Xtract.Parse +import Text.Regex.Posix +import GHC.Generics +import HSForce.Util +import Control.Applicative + +data SFClient = SFClient { + clientAccessToken :: String, + clientInstanceUrl :: String, + clientApiVersion:: String, + clientDebug :: Bool +} deriving Show + +data LoginRequest = LoginRequest{ + sfUsername :: Maybe String, + sfPassword :: Maybe String, + sfEndpoint :: Maybe String, + sfVersion :: Maybe String, + sfClientID :: Maybe String, + sfClientSecret :: Maybe String +} deriving Show + +defaultLoginRequest :: IO LoginRequest +defaultLoginRequest = do + sfUsername <- lookupEnv "SALESFORCE_USERNAME" + sfPassword <- lookupEnv "SALESFORCE_PASSWORD" + endpoint <- lookupEnv "SALESFORCE_ENDPOINT" + version <- lookupEnv "SALESFORCE_VERSION" + sfClientID <- lookupEnv "SALESFORCE_CLINET_ID" + sfClientSecret <- lookupEnv "SALESFORCE_CLIENT_SECRET" + return (LoginRequest{ + sfUsername, + sfPassword, + sfEndpoint = endpoint <|> Just "login.salesforce.com", + sfVersion = version <|> Just "v44.0", + sfClientID, + sfClientSecret + }) + +login :: LoginRequest -> IO (SFClient) +login lr = do + if isOAuth lr then restLogin lr else soapLogin lr + +soapLogin :: LoginRequest -> IO (SFClient) +soapLogin LoginRequest{sfUsername, sfPassword, sfEndpoint, sfVersion} = do + let username = fromJust sfUsername + password = fromJust sfPassword + endpoint = fromJust sfEndpoint + clientApiVersion = fromJust sfVersion + let body = " \ + \ \ + \ \ + \ \ + \{username} \ + \{password} \ + \ \ + \ \ + \" :: String + initReq <- parseRequest $ "https://" ++ endpoint ++ "/services/Soap/u/" ++ clientApiVersion + manager <- newManager tlsManagerSettings + let requestBody = L.foldl (\body (bind,value) -> HSForce.Util.replace bind (escapeXML value) body) body [("{username}", username), ("{password}", password)] + let req = initReq { + method = "POST", + requestHeaders = [("Content-Type", "text/xml"), ("SOAPAction", "''")], + requestBody = RequestBodyBS $ B8.pack requestBody + } + response <- httpLbs req manager + let Document _ _ root _ = xmlParse "" $ (BL8.unpack (responseBody response)) + cont = CElem root noPos + result = xtract id "/soapenv:Envelope/soapenv:Body/loginResponse/result" cont !! 0 + clientAccessToken = tagText result "/result/sessionId" + clientServerUrl = tagText result "/result/serverUrl" + matches = clientServerUrl =~ ("^(https://[^/]*)/.*" :: String) :: [[String]] + return SFClient{clientAccessToken, clientApiVersion, clientInstanceUrl = matches !! 0 !! 1, clientDebug = False} + +restLogin :: LoginRequest -> IO (SFClient) +restLogin LoginRequest{sfUsername, sfPassword, sfEndpoint, sfVersion, sfClientID, sfClientSecret} = do + let username = fromJust sfUsername + password = fromJust sfPassword + endpoint = fromJust sfEndpoint + clientApiVersion = fromJust sfVersion + clientId = fromJust sfClientID + clientSecret = fromJust sfClientSecret + initReq <- parseRequest $ "https://" ++ endpoint ++ "/services/oauth2/token" + manager <- newManager tlsManagerSettings + let params = [ + ("grant_type", "password"), + ("client_id", clientId), + ("client_secret", clientSecret), + ("username", username), + ("password", password) + ] + requestBody = L.tail $ L.foldl (\body (k,v) -> body ++ "&" ++ k ++ "=" ++ URI.encode v) "" params + req = initReq { + method = "POST", + requestHeaders = [("Content-Type", "application/x-www-form-urlencoded")], + requestBody = RequestBodyBS $ B8.pack requestBody + } + response <- httpLbs req manager + let tokenObject = fromJust (JSON.decode $ responseBody response :: Maybe Object) + clientAccessToken = T.unpack . getText . fromJust $ M.lookup "access_token" tokenObject + clientInstanceUrl = T.unpack . getText . fromJust $ M.lookup "instance_url" tokenObject + return SFClient{clientAccessToken, clientApiVersion, clientInstanceUrl, clientDebug = False} + +isOAuth :: LoginRequest -> Bool +isOAuth LoginRequest{sfClientID = Just _, sfClientSecret = Just _} = True +isOAuth _ = False + +requestGet :: SFClient -> String -> IO (Response BL8.ByteString) +requestGet = requestWithoutBody "GET" + +requestDelete :: SFClient -> String -> IO (Response BL8.ByteString) +requestDelete = requestWithoutBody "DELETE" + +requestWithoutBody :: B8.ByteString -> SFClient -> String -> IO (Response BL8.ByteString) +requestWithoutBody method client path = do + initReq <- parseRequest $ clientInstanceUrl client ++ path + manager <- newManager tlsManagerSettings + let req = initReq { + method = method, + requestHeaders = [("Authorization", B8.pack $ "Bearer " ++ (clientAccessToken client))] + } + printDebug client req + response <- httpLbs req manager + printDebug client response + return (response) + +requestWithBody :: B8.ByteString -> SFClient -> String -> String -> IO (Response BL8.ByteString) +requestWithBody method client path body = do + initReq <- parseRequest $ clientInstanceUrl client ++ path + manager <- newManager tlsManagerSettings + let req = initReq { + method = method, + requestHeaders = [ + ("Content-Type", "application/json"), + ("Authorization", B8.pack $ "Bearer " ++ (clientAccessToken client)) + ], + requestBody = RequestBodyBS $ B8.pack body + } + printDebug client req + response <- httpLbs req manager + printDebug client response + return (response) + +requestPost :: SFClient -> String -> String -> IO (Response BL8.ByteString) +requestPost = requestWithBody "POST" + +requestPatch :: SFClient -> String -> String -> IO (Response BL8.ByteString) +requestPatch = requestWithBody "PATCH" + +printDebug :: (Show a) => SFClient -> a -> IO () +printDebug client var = do + if clientDebug client then print var else pure () + +dataPath :: SFClient -> String +dataPath client = do + "/services/data/" ++ (clientApiVersion client) + +getText :: Value -> Text +getText (String a) = a + +deriveJSON defaultOptions { fieldLabelModifier = defaultJsonLabelFilter "client" } ''SFClient diff --git a/src/HSForce/Types.hs b/src/HSForce/Types.hs new file mode 100644 --- /dev/null +++ b/src/HSForce/Types.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} + +module HSForce.Types where + +import Data.Aeson as JSON +import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..)) +import Data.Proxy as DP +import Data.Maybe +import Data.List as L +import GHC.Generics +import HSForce.Util + +data QueryResponse a = QueryResponse{ + qrRecords :: [a], + qrTotalSize :: Int, + qrDone :: Bool +} deriving Show + +class SObject a where + typeName :: a -> String + getSfid :: a -> String + +data DescribeResponse a = DescribeResponse{ + drObjectDescribe :: ObjectDescribe, + drRecentItems :: [a] +} deriving Show + +data ObjectDescribe = ObjectDescribe { + odActivateable :: Bool, + odCreateable :: Bool, + odCustom :: Bool, + odCustomSetting :: Bool, + odDeletable :: Bool, + odDeprecatedAndHidden :: Bool, + odFeedEnabled :: Bool, + odHasSubtypes :: Bool, + odIsSubtype :: Bool, + odKeyPrefix :: Maybe String, + odLabel :: String, + odLabelPlural :: String, + odLayoutable :: Bool, + odMergeable :: Bool, + odMruEnabled :: Bool, + odName :: String, + odQueryable :: Bool, + odReplicateable :: Bool, + odRetrieveable :: Bool, + odSearchable :: Bool, + odTriggerable :: Bool, + odUndeletable :: Bool, + odUpdateable :: Bool, + odUrls :: Object +} deriving Show + +data GlobalDescribeResponse = GlobalDescribeResponse{ + gdEncoding :: String, + gdMaxBatchSize :: Int, + gdSobjects :: [ObjectDescribe] +} deriving Show + +data DescribeDetail = DescribeDetail{ + ddActionOverrides :: Maybe [ActionOverride], + ddActivateable :: Maybe Bool, + ddChildRelationships :: Maybe [ChildRelationship], + ddCompactLayoutable :: Maybe Bool, + ddCreateable :: Maybe Bool, + ddCustom :: Maybe Bool, + ddCustomSetting :: Maybe Bool, + ddDeletable :: Maybe Bool, + ddDeprecatedAndHidden :: Maybe Bool, + ddFeedEnabled :: Maybe Bool, + ddFields :: Maybe [Field], + ddHasSubtypes :: Maybe Bool, + ddIsSubtype :: Maybe Bool, + ddKeyPrefix :: Maybe String, + ddLabel :: Maybe String, + ddLabelPlural :: Maybe String, + ddLayoutable :: Maybe Bool, + ddListviewable :: Maybe Bool, + ddLookupLayoutable :: Maybe Bool, + ddMergeable :: Maybe Bool, + ddMruEnabled :: Maybe Bool, + ddName :: Maybe String, + ddNamedLayoutInfos :: Maybe [String], + ddNetworkScopeFieldName :: Maybe String, + ddQueryable :: Maybe Bool, + ddRecordTypeInfos :: Maybe [RecordTypeInfo], + ddReplicateable :: Maybe Bool, + ddRetrieveable :: Maybe Bool, + ddSearchLayoutable :: Maybe Bool, + ddSearchable :: Maybe Bool, + ddSupportedScopes :: Maybe [Scope], + ddTriggerable :: Maybe Bool, + ddUndeletable :: Maybe Bool, + ddUpdateable :: Maybe Bool, + ddUrls :: Maybe Object +} deriving Show + +data ActionOverride = ActionOverride{ + aoFormFactor :: Maybe String, + aoIsAvailableInTouch :: Maybe Bool, + aoName :: Maybe String, + aoPageId :: Maybe String, + aoUrl :: Maybe String +} deriving Show + +data ChildRelationship = ChildRelationship{ + crCascadeDelete :: Maybe Bool, + crChildSObject :: Maybe String, + crDeprecatedAndHidden :: Maybe Bool, + crField :: Maybe String, + crJunctionIdListNames :: Maybe [String], + crJunctionReferenceTo :: Maybe [String], + crRelationshipName :: Maybe String, + crRestrictedDelte :: Maybe Bool +} deriving Show + +data Field = Field{ + fAggregatable :: Maybe Bool, + fAiPredictionField :: Maybe Bool, + fAutoNumber :: Maybe Bool, + fByteLength :: Maybe Int, + fCalculated :: Maybe Bool, + fCalculatedFormula :: Maybe String, + fCascadeDelete :: Maybe Bool, + fCaseSensitive :: Maybe Bool, + fCompoundFieldName :: Maybe String, + fControllerName :: Maybe String, + fCreateable :: Maybe Bool, + fCustom :: Maybe Bool, + fDefaultValue :: Maybe Bool, + fDefaultValueFormula :: Maybe String, + fDefaultedOnCreate :: Maybe Bool, + fDependentPicklist :: Maybe Bool, + fDeprecatedAndHidden :: Maybe Bool, + fDigits :: Maybe Int, + fDisplayLocationInDecimal :: Maybe Bool, + fEncrypted :: Maybe Bool, + fExternalId :: Maybe Bool, + fExtraTypeInfo :: Maybe String, + fFilterable :: Maybe Bool, + fFilteredLookupInfo :: Maybe String, + fFormulaTreatNullNumberAsZero :: Maybe Bool, + fGroupable :: Maybe Bool, + fHighScaleNumber :: Maybe Bool, + fHtmlFormatted :: Maybe Bool, + fIdLookup :: Maybe Bool, + fInlineHelpText :: Maybe String, + fLabel :: Maybe String, + fLength :: Maybe Int, + fMask :: Maybe String, + fMaskType :: Maybe String, + fName :: Maybe String, + fNameField :: Maybe Bool, + fNamePointing :: Maybe Bool, + fNillable :: Maybe Bool, + fPermissionable :: Maybe Bool, + fPicklistValues :: Maybe [PicklistEntry], + fPolymorphicForeignKey :: Maybe Bool, + fPrecision :: Maybe Int, + fQueryByDistance :: Maybe Bool, + fReferenceTargetField :: Maybe String, + fReferenceTo :: Maybe [String], + fRelationshipName :: Maybe String, + fRelationshipOrder :: Maybe Int, + fRestrictedDelete :: Maybe Bool, + fRestrictedPicklist :: Maybe Bool, + fScale :: Maybe Int, + fSearchPrefilterable :: Maybe Bool, + fSoapType :: Maybe String, + fSortable :: Maybe Bool, + fType :: Maybe String, + fUnique :: Maybe Bool, + fUpdateable :: Maybe Bool, + fWriteRequiresMasterRead :: Maybe Bool +} deriving Show + +data PicklistEntry = PicklistEntry{ + peValidFor :: Maybe String, + peActive :: Maybe Bool, + peDefaultValue :: Maybe Bool, + peLabel :: Maybe String, + peValue :: Maybe String +} deriving Show + +data RecordTypeInfo = RecordTypeInfo{ + rtAvailable :: Maybe Bool, + rtDefaultRecordTypeMapping :: Maybe Bool, + rtDeveloperName :: Maybe String, + rtMaster :: Maybe Bool, + rtName :: Maybe String, + rtRecordTypeId :: Maybe String +} deriving Show + +data Scope = Scope{ + scopeName :: Maybe String, + scopeValue :: Maybe String +} deriving Show + +data RecordCount = RecordCount{ + rcsObjects :: [SObjectCount] +} deriving Show + +data SObjectCount = SObjectCount{ + scCount :: Int, + scName :: String +} deriving Show + +data Version = Version{ + vVersion :: String, + vLabel :: String, + vUrl :: String +} deriving Show + +data BatchRequest a = BatchRequest{ + brBinaryPartName :: String, + brMethod :: String, + brRichInput :: a, + brUrl :: String, + brBinaryPartNameAlias :: String +} deriving Show + +data Explain = Explain{ + ePlans :: [Plan], + actionOverrides :: [String], + activateable :: Bool +} deriving Show + +data Plan = Plan{ + pCardinality :: Int, + pFields :: [String], + pNotes :: [Note], + pRelativeCost :: Float, + pSobjectCardinality :: Int, + pSobjectType :: String +} deriving Show + +data Note = Note{ + nDescription :: String, + nFields :: [String], + nTableEnumOrId :: String +} deriving Show + +deriveJSON defaultOptions { fieldLabelModifier = defaultJsonLabelFilter "qr" } ''QueryResponse +deriveJSON defaultOptions { fieldLabelModifier = defaultJsonLabelFilter "dr" } ''DescribeResponse +deriveJSON defaultOptions { fieldLabelModifier = defaultJsonLabelFilter "od" } ''ObjectDescribe +deriveJSON defaultOptions { fieldLabelModifier = defaultJsonLabelFilter "dd" } ''DescribeDetail +deriveJSON defaultOptions { fieldLabelModifier = defaultJsonLabelFilter "gd" } ''GlobalDescribeResponse +deriveJSON defaultOptions { fieldLabelModifier = drop 2 } ''RecordCount +deriveJSON defaultOptions { fieldLabelModifier = defaultJsonLabelFilter "sc" } ''SObjectCount +deriveJSON defaultOptions { fieldLabelModifier = defaultJsonLabelFilter "v" } ''Version +deriveJSON defaultOptions { fieldLabelModifier = defaultJsonLabelFilter "br" } ''BatchRequest +deriveJSON defaultOptions { fieldLabelModifier = defaultJsonLabelFilter "e" } ''Explain +deriveJSON defaultOptions { fieldLabelModifier = defaultJsonLabelFilter "p" } ''Plan +deriveJSON defaultOptions { fieldLabelModifier = defaultJsonLabelFilter "n" } ''Note +deriveJSON defaultOptions { fieldLabelModifier = defaultJsonLabelFilter "f" } ''Field +deriveJSON defaultOptions { fieldLabelModifier = defaultJsonLabelFilter "pe" } ''PicklistEntry +deriveJSON defaultOptions { fieldLabelModifier = defaultJsonLabelFilter "cr" } ''ChildRelationship +deriveJSON defaultOptions { fieldLabelModifier = defaultJsonLabelFilter "rt" } ''RecordTypeInfo +deriveJSON defaultOptions { fieldLabelModifier = defaultJsonLabelFilter "scope" } ''Scope +deriveJSON defaultOptions { fieldLabelModifier = defaultJsonLabelFilter "ao" } ''ActionOverride diff --git a/src/HSForce/Util.hs b/src/HSForce/Util.hs new file mode 100644 --- /dev/null +++ b/src/HSForce/Util.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HSForce.Util + ( defaultJsonLabelFilter, + tagText, + replace, + ) where + +import Data.List +import Data.Char +import Text.XML.HaXml +import Text.XML.HaXml.Util +import Text.XML.HaXml.Xtract.Parse + +defaultJsonLabelFilter :: String -> String -> String +defaultJsonLabelFilter name = firstLower . drop (length name) + +firstLower :: String -> String +firstLower (x:xs) = toLower x : xs +firstLower [] = error "Empty" + +tagText :: Content a -> String -> String +tagText result xpath = do + tagTextContent $ xtract id xpath result !! 0 + +replace :: String -> String -> String -> String +replace old new src = inner src where + inner [] = [] + inner str@(x:xs) + | isPrefixOf old str = new ++ inner (drop (length old) str) + | otherwise = x:inner xs diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"