{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, LambdaCase #-} module Network.Shopify.Connection ( ShopifyConfig(..), Shopify -- , authorize , 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 -- where to direct after authorization (will get a "code" parameter) , 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 ] {- authorize :: BS.ByteString -> BS.ByteString -> [ShopifyScopes] -> IO String authorize storename apikey scopes = do authorizeUrl :: BS.ByteString -> BS.ByteString -> [ShopifyScopes] -> String authorizeUrl storename apikey scopes = concat [ "https://" , storename, ".myshopify.com" , "/admin/oauth/authorize" , BSC8.unpack $ HT.renderSimpleQuery True ([ ("client_id", apikey) , ("scope", BS.intercalate "," $ map (BSC8.pack . show) scopes) ] ++ case scRedirectUrl sc of Nothing -> [] Just rduri -> [("redirect_uri", rduri)]) ] -} -- | This doesn't seem to work for some reason. --startSession :: ShopifyConfig -> IO ShopifySession --startSession sc = do -- return $ ShopifySession { ssShopifyConfig = sc } {- req' <- HTTP.parseUrl $ BSC8.unpack access_url resp <- HTTP.withManager $ HTTP.httpLbs $ HTTP.urlEncodedBody params $ req' { HTTP.checkStatus = const $ const Nothing } print resp where params = [ ("client_id", scApiKey sc) , ("client_secret", scSharedSecret sc) , ("code",code)] access_url = BSC8.concat [ "https://" , scStoreName sc, ".myshopify.com" , "/admin/oauth/access_token" ] -}