module Network.Shopify.Connection (
ShopifyConfig(..), Shopify
, shopifyGet, shopifySet, shopifyDelete
) where
import Data.Maybe
import Control.Monad.Trans
import Control.Monad.Reader
import Control.Concurrent.MVar
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy.Char8 as BSLC8
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Network.HTTP.Conduit as HTTP
import qualified Data.Aeson as JS
import qualified Data.Aeson.Types as JS
import qualified Data.Aeson.Encode.Pretty as JS
import qualified Data.HashMap.Strict as HMap
import qualified Control.Exception.Lifted as E
import qualified Network.HTTP.Types.Status as HTTP
import qualified Network.HTTP.Types.Header as HTTP
import Control.Concurrent.Lifted (threadDelay)
import Safe
data ShopifyConfig =
ShopifyConfig {
scStoreName :: String
, scApiKey :: BS.ByteString
, scSharedSecret :: BS.ByteString
, scRedirectUrl :: Maybe BS.ByteString
}
deriving (Show)
type Shopify = ReaderT ShopifyConfig IO
retrying :: Shopify r -> Shopify r
retrying action =
signalAndRetry $ signalAndRetry $ signalAndRetry $ signalAndRetry $ action
where
signalAndRetry a = E.catch a (\e -> case e of
HTTP.HttpExceptionRequest _ (HTTP.StatusCodeException r _) | (HTTP.statusCode $ HTTP.responseStatus r) == 429 -> threadDelay (truncate $ 1000000 * fromMaybe (2.1::Double) (lookup "Retry-After" (HTTP.responseHeaders r) >>= (readMay . T.unpack . TE.decodeUtf8))) >> action
_ -> liftIO $ (print e >> E.throw e))
shopifyGet :: JS.FromJSON r => String -> (a -> BS.ByteString) -> a -> Shopify r
shopifyGet basePath genQuery qps = retrying $ do
sc <- ask
req' <- HTTP.parseUrl $ url sc
let req = req' {HTTP.queryString = genQuery qps
,HTTP.requestHeaders = [("X-Shopify-Access-Token", scSharedSecret sc)]
,HTTP.responseTimeout = HTTP.responseTimeoutMicro 50000000
}
resp <- HTTP.withManager $ HTTP.httpLbs req
case JS.decode . HTTP.responseBody $ resp of
Nothing -> fail "JSON failed to decode to a Value."
Just v -> do
case JS.parseEither JS.parseJSON v of
Right r -> return r
Left err -> do
liftIO $ print resp
liftIO $ BSLC8.putStrLn $ JS.encodePretty v
fail $ "oh fuck: " ++ err
where
url sc =
concat [
"https://"
, scStoreName sc, ".myshopify.com"
, basePath
]
shopifySet :: JS.FromJSON r => String -> Bool -> JS.Value -> Shopify r
shopifySet basePath exists d = retrying $ do
sc <- ask
req' <- HTTP.parseUrl $ url sc
let req = req' {HTTP.method = if exists then "PUT" else "POST"
,HTTP.requestBody = HTTP.RequestBodyLBS $ JS.encodePretty d
,HTTP.requestHeaders = [("X-Shopify-Access-Token", scSharedSecret sc)
,("Content-Type", "application/json")]
,HTTP.responseTimeout = HTTP.responseTimeoutMicro 50000000
}
resp <- HTTP.withManager $ HTTP.httpLbs req
case JS.decode . HTTP.responseBody $ resp of
Nothing -> fail "JSON failed to decode to a Value."
Just v -> do
case JS.parseEither JS.parseJSON v of
Right r -> return r
Left err -> do
liftIO $ BSLC8.putStrLn $ JS.encodePretty d
liftIO $ print resp
liftIO $ BSLC8.putStrLn $ JS.encodePretty v
fail $ "oh fuck: " ++ err
where
url sc =
concat [
"https://"
, scStoreName sc, ".myshopify.com"
, basePath
]
shopifyDelete :: JS.FromJSON r => String -> Shopify r
shopifyDelete basePath = retrying $ do
sc <- ask
req' <- HTTP.parseUrl $ url sc
let req = req' {HTTP.method = "DELETE"
,HTTP.requestHeaders = [("X-Shopify-Access-Token", scSharedSecret sc)]
}
resp <- HTTP.withManager $ HTTP.httpLbs req
case JS.decode . HTTP.responseBody $ resp of
Nothing -> fail "JSON failed to decode to a Value."
Just v -> do
case JS.parseEither JS.parseJSON v of
Right r -> return r
Left err -> do
liftIO $ print resp
liftIO $ BSLC8.putStrLn $ JS.encodePretty v
fail $ "oh fuck: " ++ err
where
url sc =
concat [
"https://"
, scStoreName sc, ".myshopify.com"
, basePath
]