Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE DeriveGeneric #-}
module Main where
import System.Environment (getArgs, getEnv)
import System.IO
import Network.HTTP.Conduit
import Network.URI
import Network.URI.Encode as URI
import Data.Maybe
import Data.List as L
import Data.ByteString.Char8 as B8
import Data.ByteString.Lazy.Char8 as BL8
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 Data.Aeson as JSON
import Control.Applicative
import GHC.Generics
import Control.Monad (mzero)
data LoginRequest = LoginRequest{
username :: String,
password :: String,
endpoint :: String,
apiVersion :: String
} deriving Show
data LoginResult = LoginResult{
sessionId :: String,
userId :: String,
serverUrl :: String,
metadataServerUrl :: String,
instanceUrl :: String,
resApiVersion :: String
} deriving Show
data QueryResult = QueryResult{
done :: Bool,
totalSize :: Int,
records :: [Account]
} deriving Show
instance FromJSON QueryResult where
parseJSON (Object v) = QueryResult
<$> v .: "done"
<*> v .: "totalSize"
<*> v .: "records"
parseJSON _ = mzero
data Account = Account{
sfid :: String,
name :: String
} deriving Show
instance FromJSON Account where
parseJSON (Object v) = Account
<$> (v .: "Id")
<*> (v .: "Name")
main :: IO ()
main = do
args <- getArgs
case args !! 0 of
"login" -> do
username <- getEnv "SALESFORCE_USERNAME"
password <- getEnv "SALESFORCE_PASSWORD"
loginResult <- login LoginRequest{
username=username,
password=password,
endpoint="login.salesforce.com",
apiVersion="44.0"
}
System.IO.print loginResult
let query = args !! 1
queryResult <- Main.query loginResult query
System.IO.print queryResult
mapM (print . sfid) $ records queryResult
return ()
_ -> return ()
replace :: String -> String -> String -> String
replace x y src = inner src where
inner [] = []
inner str@(s:ss)
| L.isPrefixOf x str = y ++ inner (L.drop (L.length x) str)
| otherwise = s:inner ss
login :: LoginRequest -> IO LoginResult
login LoginRequest{ username, password, endpoint, apiVersion} = do
let body = "<?xml version=\"1.0\" encoding=\"utf-8\"?> \
\<env:Envelope xmlns:xsd=\"http://www.w3.org/2001/XMLSchema\" xmlns:xsi=\"http://www.w3.org/2001/XMLSchema-instance\" xmlns:env=\"http://schemas.xmlsoap.org/soap/envelope/\"> \
\<env:Body> \
\<n1:login xmlns:n1=\"urn:partner.soap.sforce.com\"> \
\<n1:username>{username}</n1:username> \
\<n1:password>{password}</n1:password> \
\</n1:login> \
\</env:Body> \
\</env:Envelope>" :: String
initReq <- parseRequest $ "https://" ++ endpoint ++ "/services/Soap/u/" ++ apiVersion
manager <- newManager tlsManagerSettings
let requestBody = L.foldl (\body (bind,value) -> 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
sessionId = tagTextContent $ xtract id "/result/sessionId" result !! 0
userId = tagTextContent $ xtract id "/result/userId" result !! 0
serverUrl = tagTextContent $ xtract id "/result/serverUrl" result !! 0
matches = serverUrl =~ ("^(https://[^/]*)/.*" :: String) :: [[String]]
metadataServerUrl = tagTextContent $ xtract id "/result/metadataServerUrl" result !! 0
System.IO.print matches
return LoginResult{sessionId, userId, serverUrl, metadataServerUrl, resApiVersion = apiVersion, instanceUrl = matches !! 0 !! 1}
query :: LoginResult -> String -> IO QueryResult
query lr query = do
let queryUrl = instanceUrl lr ++ "/services/data/v" ++ resApiVersion lr ++ "/query/?q=" ++ URI.encode query
System.IO.print queryUrl
response <- get lr queryUrl
let body = responseBody response
let result = JSON.decode body :: Maybe QueryResult
System.IO.print body
System.IO.print result
return (fromJust result)
get :: LoginResult -> String -> IO (Response BL8.ByteString)
get LoginResult{sessionId} url = do
initReq <- parseRequest url
manager <- newManager tlsManagerSettings
let req = initReq { method = "GET",
requestHeaders = [("Authorization", B8.pack $ "Bearer " ++ sessionId)]
}
httpLbs req manager
post :: LoginResult -> String -> String -> IO (Response BL8.ByteString)
post LoginResult{sessionId} url body = do
initReq <- parseRequest url
manager <- newManager tlsManagerSettings
let req = initReq { method = "POST",
requestHeaders = [("Authorization", B8.pack $ "Bearer " ++ sessionId)],
requestBody = RequestBodyBS $ B8.pack body
}
httpLbs req manager
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.