shopify (empty) → 0
raw patch · 10 files changed
+1431/−0 lines, 10 filesdep +aesondep +aeson-prettydep +attoparsecsetup-changed
Dependencies added: aeson, aeson-pretty, attoparsec, base, base64-bytestring, bytestring, containers, control-monad-exception, http-conduit, http-types, lifted-base, mtl, resourcet, safe, text, time, unordered-containers, vector
Files
- LICENSE +30/−0
- Network/Shopify.hs +16/−0
- Network/Shopify/Connection.hs +171/−0
- Network/Shopify/Metafield.hs +73/−0
- Network/Shopify/Orders.hs +576/−0
- Network/Shopify/Permissions.hs +31/−0
- Network/Shopify/Products.hs +418/−0
- Network/Shopify/Types.hs +66/−0
- Setup.hs +2/−0
- shopify.cabal +48/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, davean++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 davean 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.
+ Network/Shopify.hs view
@@ -0,0 +1,16 @@+module Network.Shopify (+ module Network.Shopify.Types+ , module Network.Shopify.Permissions+ , module Network.Shopify.Connection+ , module Network.Shopify.Metafield+ , module Network.Shopify.Products+ , module Network.Shopify.Orders+ ) where++import Network.Shopify.Types+import Network.Shopify.Permissions+import Network.Shopify.Connection+import Network.Shopify.Metafield+import Network.Shopify.Products+import Network.Shopify.Orders+
+ Network/Shopify/Connection.hs view
@@ -0,0 +1,171 @@+{-# 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"+ ]+-}
+ Network/Shopify/Metafield.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.Shopify.Metafield (+ MetaFields, MetaValue(..), MetaNamespace+ , emptyMeta, setMeta, lookupMeta, lookupMetaString+ ) where++import Control.Monad+import qualified Data.Text as T+import Data.Aeson ((.:), (.=))+import qualified Data.Aeson as JS+import qualified Data.Aeson.Types as JS+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HMap+import qualified Data.Vector as V++type MetaNamespace = T.Text++data MetaValue =+ MetaString T.Text+ | MetaInt Integer+ deriving (Show)++newtype MetaFields =+ MetaFields { unMetaField :: HashMap MetaNamespace (HashMap T.Text MetaValue) }+ deriving (Show)++emptyMeta :: MetaFields+emptyMeta = MetaFields HMap.empty++setMeta :: MetaNamespace -> T.Text -> MetaValue -> MetaFields -> MetaFields+setMeta ns key val = MetaFields . HMap.insertWith HMap.union ns (HMap.singleton key val) . unMetaField++lookupMeta :: MetaNamespace -> T.Text -> MetaFields -> Maybe MetaValue+lookupMeta ns key = join . fmap (HMap.lookup key) . HMap.lookup ns . unMetaField++lookupMetaString :: MetaNamespace -> T.Text -> MetaFields -> Maybe T.Text+lookupMetaString ns key mf = + case lookupMeta ns key mf of+ Just (MetaString s) -> Just s+ _ -> Nothing++instance JS.FromJSON MetaFields where+ parseJSON (JS.Array a) = do+ fields <- mapM parseFields $ V.toList a+ return $ foldl (\mfs (ns, k, v) -> setMeta ns k v mfs) emptyMeta fields+ where+ parseFields (JS.Object o) = do+ ns <- o .: "namespace"+ key <- o .: "key"+ typ <- ((o .: "value_type")::JS.Parser String)+ case typ of + "integer" -> do+ i <- o .: "value"+ return (ns, key, MetaInt i)+ "string" -> do+ s <- o .: "value"+ return (ns, key, MetaString s)+ _ -> mzero+ parseFields _ = mzero+ parseJSON _ = mzero++instance JS.ToJSON MetaFields where+ toJSON =+ JS.toJSON . concatMap (\(ns, nsmap) -> map (\(k, v) -> objectify ns k v) $ HMap.toList nsmap) . HMap.toList . unMetaField+ where+ objectify ns k (MetaString s) = JS.object ["namespace" .= ns+ ,"key" .= k+ ,"value_type" .= ("string"::T.Text)+ ,"value" .= s]+ objectify ns k (MetaInt i) = JS.object ["namespace" .= ns+ ,"key" .= k+ ,"value_type" .= ("integer"::T.Text)+ ,"value" .= i]
+ Network/Shopify/Orders.hs view
@@ -0,0 +1,576 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, DeriveDataTypeable #-}+module Network.Shopify.Orders (+ Order(..), Address(..), LineItem(..), OrderShipping(..), ShopifyProperty(..), OrderFulfillmentStatus(..), OrderFulfillment(..), DiscountCode(..), TaxLine(..)+ , OrderQuery(..), OrderStatus(..), FinancialStatus(..), FulfillmentStatus(..)+ , TransactionFailed+ , fulfillOrder, captureOrder+ , queryOrder, queryOrders+ ) where++import Data.Int+import Data.Fixed+import Data.Maybe+import Data.Time.Clock+import Control.Monad+import Control.Applicative+import qualified Data.Text as T+import Data.Aeson ((.:), (.:?), (.=))+import qualified Data.Aeson as JS+import qualified Data.Aeson.Types as JS+import qualified Data.ByteString as BS+import Network.HTTP.Types (renderQuery)+import Network.HTTP.Types.QueryLike (toQueryValue)+import qualified Control.Exception as E+import qualified Data.Map as Map+import Data.Typeable++import Network.Shopify.Types+import Network.Shopify.Connection++data OrderQuery =+ OQCreatedBefore UTCTime+ | OQCreatedAfter UTCTime+ | OQFinancialStatus FinancialStatus+ | OQFulfillmentStatus FulfillmentStatus+ | OQGreaterThen OrderID+ | OQStatus OrderStatus+ | OQUpdatedBefore UTCTime+ | OQUpdatedAfter UTCTime+ deriving (Show)++isStatusQuery :: OrderQuery -> Bool+isStatusQuery (OQStatus _) = True+isStatusQuery _ = False++encodeOrderQuery :: OrderQuery -> (BS.ByteString, Maybe BS.ByteString)+encodeOrderQuery (OQCreatedBefore t) = ("created_at_max", dateToQuery t)+encodeOrderQuery (OQCreatedAfter t) = ("created_at_min", dateToQuery t)+encodeOrderQuery (OQFinancialStatus fs) = ("financial_status", toQueryValue $ financialStatusToQuery fs)+encodeOrderQuery (OQFulfillmentStatus fs) = ("fulfillment_status", toQueryValue $ fulfillmentStatusToQuery fs)+encodeOrderQuery (OQGreaterThen oid) = ("since_id", toQueryValue $ show oid)+encodeOrderQuery (OQStatus sts) = ("status", orderStatusToQuery sts)+encodeOrderQuery (OQUpdatedBefore t) = ("updated_at_max", dateToQuery t)+encodeOrderQuery (OQUpdatedAfter t) = ("updated_at_min", dateToQuery t)++financialStatusToQuery :: FinancialStatus -> T.Text+financialStatusToQuery FinancialStatusNull = "abandoned"+financialStatusToQuery FinancialStatusPending = "pending"+financialStatusToQuery FinancialStatusAuthorized = "authorized"+financialStatusToQuery FinancialStatusPaid = "paid"+financialStatusToQuery FinancialStatusPartiallyPaid = "partially_paid"+financialStatusToQuery FinancialStatusVoided = "voided"+financialStatusToQuery FinancialStatusPartialRefund = "partially_refunded"+financialStatusToQuery FinancialStatusRefunded = "refunded"++fulfillmentStatusToQuery :: FulfillmentStatus -> T.Text+fulfillmentStatusToQuery FulfillmentStatusNil = "unshipped"+fulfillmentStatusToQuery FulfillmentStatusPartial = "partial"+fulfillmentStatusToQuery FulfillmentStatusFulfilled = "shipped"++orderStatusToQuery :: OrderStatus -> Maybe BS.ByteString+orderStatusToQuery OrderOpen = Just "open"+orderStatusToQuery OrderClosed = Just "closed"+orderStatusToQuery OrderCancelled = Just "cancelled"++queryOrder :: OrderID -> Shopify Order+queryOrder oid = do+ pw <- shopifyGet ("/admin/orders/"++show oid++".json") (const "") ()+ case Map.lookup ("order"::T.Text) pw of+ Just p -> return p+ Nothing -> error "order not pressent"++queryOrders :: [OrderQuery] -> Shopify [Order]+queryOrders q =+ getBlock 1 []+ where+ baseQuery = ("limit", Just "250"):(if any isStatusQuery q+ then []+ else [("status", Just "any")])++map encodeOrderQuery q+ genQuery i qry= renderQuery False (("page", toQueryValue (show i)):qry)+ getBlock :: Int -> [Order] -> Shopify [Order]+ getBlock i ops = do+ psw <- shopifyGet "/admin/orders.json" (genQuery i) baseQuery+ ps <- case Map.lookup ("orders"::T.Text) psw of+ Just ps -> return ps+ Nothing -> error "orders not pressent"+ if length ps < 250+ then return ((reverse ps) ++ ops)+ else getBlock (i+1) ((reverse ps) ++ ops)++data OrderStatus =+ OrderOpen+ | OrderClosed+ | OrderCancelled+ deriving (Show)++type TrackingNumber = T.Text++fulfillOrder :: Order -> Maybe TrackingNumber -> Shopify ()+fulfillOrder order mTracking = do+ (_::JS.Value) <- shopifySet ("/admin/orders/"++(show . metaId . oMeta) order++"/fulfillments.json") False $+ JS.object+ [ ("fulfillment", JS.object $ catMaybes+ [ fmap ((,) "tracking_number" . JS.toJSON) mTracking+ , Just ("notify_customer" .= True) ] ) ]+ return ()++data Transaction =+ TransactionCapture {+ tcFailed :: Bool+ }+ deriving (Show)+ +instance JS.FromJSON Transaction where+ parseJSON (JS.Object v) = do+ (k::String) <- v .: "kind"+ case k of+ "capture" ->+ TransactionCapture <$>+ ((v .: "status") >>= return . (==) ("failure"::T.Text))+ _ -> fail "Unknown transaction type"+ parseJSON _ = fail "Transaction must be an object"++transactionFailed :: Transaction -> Bool+transactionFailed (TransactionCapture {tcFailed=f}) = f++data TransactionFailed =+ TransactionFailed + deriving (Show, Typeable)++instance E.Exception TransactionFailed++captureOrder :: Order -> Shopify ()+captureOrder order = do+ ts <- shopifySet ("/admin/orders/"++(show . metaId . oMeta) order++"/transactions.json") False $+ JS.object+ [ ("transaction", JS.object $ catMaybes+ [ Just ("kind", "capture") ] ) ]+ case fmap transactionFailed . Map.lookup ("transaction"::T.Text) $ ts of+ Just False -> return ()+ _ -> E.throw TransactionFailed+++data Order =+ Order {+ oMeta :: ShopifyMeta+ , oEmail :: T.Text+ , oNumber :: Int64+ , oOrderNum :: Int64+ , oOrderName :: T.Text+ , oToken :: T.Text+ , oNote :: Maybe T.Text+ , oAcceptsMarketing :: Bool+ , oReferrer :: Maybe T.Text+ , oBillingAddress :: Address+ , oShippingAddress :: Address+ , oShippings :: [OrderShipping]+ , oProperties :: [ShopifyProperty]+ , oItems :: [LineItem]+ , oTaxesIncluded :: Bool+ , oTaxLines :: [TaxLine]+ , oTotalTax :: Centi+ , oDiscounts :: [DiscountCode]+ , oTotalDiscounts :: Centi+ , oTotalLineItemsPrice :: Centi+ , oSubtotal :: Centi+ , oCurrency :: T.Text+ , oTotalPrice :: Centi+ , oTotalPriceUSD :: Centi+ , oGrams :: Int+ , oFinancialStatus :: FinancialStatus+ , oFulfillmentStatus :: OrderFulfillmentStatus+ , oFulfillments :: [OrderFulfillment]+ , oClosedAt :: Maybe UTCTime+ , oCancelledAt :: Maybe UTCTime+ , oCancelReason :: Maybe T.Text+ }+ deriving (Show)++emptyTxtToNothing :: T.Text -> Maybe T.Text+emptyTxtToNothing "" = Nothing+emptyTxtToNothing o = Just o++instance JS.FromJSON Order where+ parseJSON (o@(JS.Object v)) =+ Order <$>+ JS.parseJSON o <*>+ (v .: "email" <|> fail "email") <*>+ (v .: "number" <|> fail "number") <*>+ (v .: "order_number" <|> fail "order number") <*>+ (v .: "name" <|> fail "name") <*>+ (v .: "token" <|> fail "token") <*>+ ((v .:? "note" >>= return . join . fmap emptyTxtToNothing) <|> fail "note") <*>+ (v .: "buyer_accepts_marketing" <|> fail "accepts marketing") <*>+ ((v .:? "referring_site" >>= return . join . fmap emptyTxtToNothing) <|> fail "ref site") <*>+ (v .: "billing_address" <|> fail "billing addr") <*>+ (v .: "shipping_address" <|> v .: "billing_address") <*>+ (v .: "shipping_lines" <|> fail "shipping lines") <*>+ (v .: "note_attributes" <|> fail "note attrib") <*>+ (v .: "line_items" <|> fail "line item") <*>+ (v .: "taxes_included" <|> fail "taxes inc.") <*>+ (v .: "tax_lines" <|> fail "tax lines") <*>+ ((v .: "total_tax" >>= return . read) <|> fail "total tax") <*>+ (v .: "discount_codes" <|> fail "discount codes") <*>+ ((v .: "total_discounts" >>= return . read) <|> fail "total discounts") <*>+ ((v .: "total_line_items_price" >>= return . read) <|> fail "total line items price") <*>+ ((v .: "subtotal_price" >>= return . read) <|> fail "subtotal") <*>+ (v .: "currency" <|> fail "currency") <*>+ ((v .: "total_price" >>= return . read) <|> fail "total price") <*>+ ((v .: "total_price_usd" >>= return . read) <|> fail "total price USD") <*>+ (v .: "total_weight" <|> fail "mass") <*>+ (v .: "financial_status") <*>+ (v .: "fulfillment_status" <|> fail "fulfillment status") <*>+ (v .: "fulfillments") <*> -- <|> fail "fulfillments") <*>+ ((v .:? "closed_at" >>= return . fmap actualTime) <|> fail "closed_at") <*>+ ((v .:? "cancelled_at" >>= return . fmap actualTime) <|> fail "cancelled_at") <*>+ (v .: "cancel_reason")+ parseJSON _ = fail "Order not an object"++{-+-"buyer_accepts_marketing": false,+-"cancel_reason": null,+-"cancelled_at": null,+-"cart_token": "68778783ad298f1c80c3bafcddeea02f",+-"closed_at": null,+- "id": 450789469,+-"created_at": "2008-01-10T11:00:00-05:00",+-"updated_at": "2008-01-10T11:00:00-05:00",+-"currency": "USD",+-"email": "bob.norman@hostmail.com",+-"financial_status": "authorized",+-"fulfillment_status": null,+ "gateway": "authorize_net",+-"landing_site": "http://www.example.com?source=abc",+-"name": "#1001",+-"note": null,+-"number": 1,+-"referring_site": "http://www.otherexample.com",+-"subtotal_price": "398.00",+-"taxes_included": false,+-"token": "b1946ac92492d2347c6235b4d2611184",+-"total_discounts": "0.00",+-"total_line_items_price": "398.00",+-"total_price": "409.94",+-"total_price_usd": "409.94",+-"total_tax": "11.94",+-"total_weight": 0,+ "browser_ip": null,+ "landing_site_ref": "abc",+-"order_number": 1001,+-"discount_codes": [DiscountCode],+-"note_attributes": [ ShopifyProperty ],+ "processing_method": "direct",+-"line_items": [ LineItem ]+-"shipping_lines": [OrderShipping],+-"tax_lines": [ TaxLine ],+ "payment_details": {+ "avs_result_code": null,+ "credit_card_bin": null,+ "cvv_result_code": null,+ "credit_card_number": "XXXX-XXXX-XXXX-4242",+ "credit_card_company": "Visa"+ },+-"billing_address": Address+-"shipping_address": Address+-"fulfillments": [ Fulfillment ],+ "client_details": {+ "accept_language": null,+ "browser_ip": "0.0.0.0",+ "session_hash": null,+ "user_agent": null+ },+ "customer": Customer+-}++{- Address+-"address1": "Chestnut Street 92",+-"address2": "",+-"city": "Louisville",+-"company": null,+-"country": "United States",+-"first_name": "Bob",+-"last_name": "Norman",+-"latitude": "45.41634",+-"longitude": "-75.6868",+-"phone": "555-625-1199",+-"province": "Kentucky",+-"zip": "40202",+-"name": "Bob Norman",+-"country_code": "US",+-"province_code": "KY"+-}++data Address =+ Address {+ aFirstName :: T.Text+ , aLastName :: T.Text+ , aName :: T.Text+ , aCompany :: Maybe T.Text+ , aStreet1 :: T.Text+ , aStreet2 :: Maybe T.Text+ , aCity :: T.Text+ , aProvince :: T.Text+ , aProvinceCode :: T.Text+ , aZip :: Maybe T.Text+ , aCountry :: T.Text+ , aCountryCode :: T.Text+ , aPhone :: Maybe T.Text+ , aLatLong :: Maybe (Double, Double)+ }+ deriving (Show)++instance JS.FromJSON Address where+ parseJSON (JS.Object v) =+ Address <$>+ (v .: "first_name" <|> return "" <|> fail "first name") <*>+ (v .: "last_name" <|> return "" <|> fail "last name") <*>+ (v .: "name" <|> fail "name") <*>+ (v .: "company" <|> fail "company") <*>+ (v .: "address1" <|> fail "address1") <*>+ ((v .: "address2" >>= return . join . fmap emptyTxtToNothing) <|> fail "address2") <*>+ (v .: "city" <|> fail "city") <*>+ ((v .:? "province" >>= return . fromMaybe "") <|> fail "province") <*>+ ((v .:? "province_code" >>= return . fromMaybe "") <|> fail "province code") <*>+ (v .: "zip" <|> fail "zip") <*>+ (v .: "country" <|> fail "country") <*>+ (v .: "country_code" <|> fail "country code") <*>+ (v .: "phone" <|> fail "phone") <*>+ ((do { latStr <- v .: "latitude"; lonStr <- v .: "longitude"; return $ Just (read latStr, read lonStr) }) <|>+ pure Nothing)+ parseJSON _ = fail "Address not an object"++{-+-"code": "TENOFF",+-"amount": "10.00"+-}+data DiscountCode =+ DiscountCode {+ dcCode :: T.Text+ , dcAmount :: Centi+ }+ deriving (Show)++instance JS.FromJSON DiscountCode where+ parseJSON (JS.Object v) =+ DiscountCode <$>+ v .: "code" <*>+ ((v .: "amount") >>= return . read)+ parseJSON _ = fail "DiscountCode must be an object"++{-+ "code": "Free Shipping",+ "price": "0.00",+ "source": "shopify",+ "title": "Free Shipping"+-}+data OrderShipping =+ OrderShipping {+ osCode :: T.Text+ , osPrice :: Centi+ , osSource :: T.Text+ , osTitle :: T.Text+ }+ deriving (Show)++instance JS.FromJSON OrderShipping where+ parseJSON (JS.Object v) =+ OrderShipping <$>+ v .: "code" <*>+ ((v .: "price") >>= return . read) <*>+ v .: "source" <*>+ v .: "title"+ parseJSON _ = fail "OrderShipping must be an object"++{-+-"name": "Custom Engraving",+-"value": "Happy Birthday"+-}+data ShopifyProperty =+ ShopifyProperty {+ spName :: T.Text+ , spValue :: T.Text+ }+ deriving (Show)++instance JS.FromJSON ShopifyProperty where+ parseJSON (JS.Object v) =+ ShopifyProperty <$>+ v .: "name" <*>+ v .: "value"+ parseJSON _ = fail "ShopifyProperty not an object"++{-+ "price": "11.94",+ "rate": 0.06,+ "title": "State Tax"+-}+data TaxLine =+ TaxLine {+ tlTitle :: T.Text+ , tlRate :: Double+ , tlPRice :: Centi+ }+ deriving (Show)++instance JS.FromJSON TaxLine where+ parseJSON (JS.Object v) =+ TaxLine <$>+ v .: "title" <*>+ v .: "rate" <*>+ (v .: "price" >>= return . read)+ parseJSON _ = fail "TaxLine not an object"++{- LineItem+ "fulfillment_service": "manual",+ "fulfillment_status": null,+- "grams": 200,+-"id": 466157049,+-"price": "199.00",+ "product_id": 632910392,+-"quantity": 1,+-"requires_shipping": true,+-"sku": "IPOD2008GREEN",+-"title": "IPod Nano - 8gb",+ "variant_id": 39072856,+ "variant_title": "green",+ "vendor": null,+-"name": "IPod Nano - 8gb - green",+ "variant_inventory_management": "shopify",+-"properties": [ ShopifyProperties ]+-}+data LineItem =+ LineItem {+ liId :: LineItemID+ , liGrams :: Int+ , liPrice :: Centi+ , liSku :: T.Text+ , liQuantity :: Int+ , liTitle :: T.Text+ , liName :: T.Text+ , liShips :: Bool+ , liProperties :: [ShopifyProperty]+ }+ deriving (Show)++instance JS.FromJSON LineItem where+ parseJSON (JS.Object v) =+ LineItem <$>+ v .: "id" <*>+ v .: "grams" <*>+ (v .: "price" >>= return . read) <*>+ v .: "sku" <*>+ v .: "quantity" <*>+ v .: "title" <*>+ v .: "name" <*>+ v .: "requires_shipping" <*>+ v .: "properties"+ parseJSON _ = fail "LineItem must be an object"++data FinancialStatus = + FinancialStatusNull+ | FinancialStatusPending+ | FinancialStatusAuthorized+ | FinancialStatusPaid+ | FinancialStatusPartiallyPaid+ | FinancialStatusVoided+ | FinancialStatusPartialRefund+ | FinancialStatusRefunded+ deriving (Show)++instance JS.FromJSON FinancialStatus where+ parseJSON (JS.Null) = return FinancialStatusNull+ parseJSON (JS.String "null") = return FinancialStatusNull+ parseJSON (JS.String "pending") = return FinancialStatusPending+ parseJSON (JS.String "authorized") = return FinancialStatusAuthorized+ parseJSON (JS.String "paid") = return FinancialStatusPaid+ parseJSON (JS.String "partially_paid") = return FinancialStatusPartiallyPaid+ parseJSON (JS.String "voided") = return FinancialStatusVoided+ parseJSON (JS.String "partially_refunded") = return FinancialStatusPartialRefund+ parseJSON (JS.String "refunded") = return FinancialStatusRefunded+ parseJSON (JS.String s) = fail ("unknown FinancialStatus: "++T.unpack s)+ parseJSON _ = fail "unknown FinancialStatus"++data FulfillmentStatus =+ FulfillmentStatusNil+ | FulfillmentStatusPartial+ | FulfillmentStatusFulfilled+ deriving (Show)++data OrderFulfillmentStatus =+ OrderFulfillmentStatusNil+ | OrderFulfillmentStatusPartial+ | OrderFulfillmentStatusFulfilled+ | OrderFulfillmentStatusRestocked+ deriving (Show)++instance JS.FromJSON OrderFulfillmentStatus where+ parseJSON (JS.Null) = return OrderFulfillmentStatusNil+ parseJSON (JS.String "nil") = return OrderFulfillmentStatusNil+ parseJSON (JS.String "partial") = return OrderFulfillmentStatusPartial+ parseJSON (JS.String "fulfilled") = return OrderFulfillmentStatusFulfilled+ parseJSON (JS.String "success") = return OrderFulfillmentStatusFulfilled+ parseJSON (JS.String "restocked") = return OrderFulfillmentStatusRestocked+ parseJSON _ = fail "unknown OrderFulfillmentStatus"++{- Fulfillment+-"created_at": "2012-10-30T16:09:40-04:00",+-"id": 255858046,+ "order_id": 450789469,+ "service": "manual",+ "status": "failure",+ "tracking_company": null,+-"tracking_number": "1Z2345",+-"tracking_url": "http://www.google.com/search?q=1Z2345",+-"updated_at": "2012-10-30T16:09:40-04:00",+ "receipt": {+ "testcase": true,+ "authorization": "123456"+ },+-"line_items": [ LineItem ]+-}+data OrderFulfillment =+ OrderFulfillment {+ fMeta :: ShopifyMeta+ , fStatus :: OrderFulfillmentStatus+ , fLineItems :: [LineItem]+ , fTrackingUrl :: Maybe T.Text+ , fTrackingNumber :: Maybe T.Text+ , fService :: FulfillmentService+ }+ deriving (Show)++instance JS.FromJSON OrderFulfillment where+ parseJSON (o@(JS.Object v)) =+ OrderFulfillment <$>+ JS.parseJSON o <*>+ (v .: "status" <|> fail "fulfillment status") <*>+ (v .: "line_items" <|> fail "fulfillment line items") <*>+ (v .: "tracking_url" <|> fail "fulfillment tracking url") <*>+ ((v .: "tracking_number") <|> ((v .: "tracking_number"::JS.Parser (Maybe Int)) >>= return . Just . T.pack . show) <|> fail "fulfillment tracking number") <*>+ (v .: "service" <|> fail "fulfillment service")+ parseJSON _ = fail "ShopifyProperty not an object"++data FulfillmentService =+ ManualFulfillment+ deriving (Show)++instance JS.FromJSON FulfillmentService where+ parseJSON (JS.String "manual") = return ManualFulfillment+ parseJSON _ = fail "FulfillmentService only currently knows the string \"manual\""++{- Customer+ "accepts_marketing": false,+ "id": 207119551,+ "created_at": "2012-10-30T16:09:40-04:00",+ "updated_at": "2012-10-30T16:09:40-04:00",+ "email": "bob.norman@hostmail.com",+ "first_name": "Bob",+ "last_name": "Norman",+ "last_order_id": null,+ "note": null,+ "orders_count": 0,+ "state": null,+ "total_spent": "0.00",+ "tags": "",+ "last_order_name": null+-}
+ Network/Shopify/Permissions.hs view
@@ -0,0 +1,31 @@+module Network.Shopify.Permissions (+ ShopifyScopes(..), ShopifyAccessLevel(..)+ ) where++data ShopifyAccessLevel =+ ShopifyRead+ | ShopifyWrite -- Implies ShopifyRead for the scope.+ deriving (Eq)++data ShopifyScopes = + ScopeContent ShopifyAccessLevel+ | ScopeThemes ShopifyAccessLevel+ | ScopeProducts ShopifyAccessLevel+ | ScopeCustomers ShopifyAccessLevel+ | ScopeOrders ShopifyAccessLevel+ | ScopeScriptTags ShopifyAccessLevel+ | ScopeShipping ShopifyAccessLevel+ deriving (Eq)++instance Show ShopifyAccessLevel where+ show ShopifyRead = "read"+ show ShopifyWrite = "write"++instance Show ShopifyScopes where+ show (ScopeContent l) = show l ++ "_content"+ show (ScopeThemes l) = show l ++ "_themes"+ show (ScopeProducts l) = show l ++ "_products"+ show (ScopeCustomers l) = show l ++ "_customers"+ show (ScopeOrders l) = show l ++ "_orders"+ show (ScopeScriptTags l) = show l ++ "_script_tags"+ show (ScopeShipping l) = show l ++ "_shipping"
+ Network/Shopify/Products.hs view
@@ -0,0 +1,418 @@+{-# LANGUAGE OverloadedStrings, FlexibleInstances, ScopedTypeVariables #-}+module Network.Shopify.Products (+ Product(..), ProductWithMeta(..)+ , ProductVariant(..), VariantWithMeta(..), ProductImage(..)+ , InventoryPolicy(..), InventoryManagement(..)+ , queryProduct, queryProductMetaFields+ , queryProducts, ProductQuery(..)+ , createProduct, updateProduct, deleteProduct+ , updateStock+ ) where++import Data.Int+import Data.Fixed+import Data.List+import Data.Maybe+import Data.Time.Clock+import Control.Monad+import Control.Applicative+import Control.Monad.Trans+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Aeson ((.:), (.:?), (.=))+import qualified Data.Aeson as JS+import qualified Data.Aeson.Types as JS+import qualified Data.Aeson.Encode.Pretty as JS+import qualified Data.Set as Set+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Char8 as BSLC8+import qualified Data.ByteString.Base64 as B64+import Network.HTTP.Types (renderQuery)+import Network.HTTP.Types.QueryLike (toQueryValue)+import qualified Network.HTTP.Conduit as HTTP+import qualified Control.Exception as E+import qualified Data.Map as Map+import Safe++import Network.Shopify.Types+import Network.Shopify.Metafield+import Network.Shopify.Connection++-- http://wiki.shopify.com/Product_(API)++data Positioned a =+ Positioned Int a++position :: [a] -> [Positioned a]+position = zipWith Positioned [1..]++unposition :: [Positioned a] -> [a]+unposition = map positionedItem . sortBy positionedCmp++positionedCmp :: Positioned a -> Positioned a -> Ordering+positionedCmp (Positioned i1 _) (Positioned i2 _) = compare i1 i2++positionedItem :: Positioned a -> a+positionedItem (Positioned _ a) = a++instance JS.FromJSON a => JS.FromJSON (Positioned a) where+ parseJSON (JS.Object v) = Positioned <$>+ v .: "position" <*>+ JS.parseJSON (JS.Object v)+ parseJSON _ = fail "Positioned not an object"++instance JsonExtending a => JS.ToJSON (Positioned a) where+ toJSON (Positioned p a) =+ JS.object $ (jsonExtender a) ++ ["position" .= p]++type Title = T.Text+type ProductType = T.Text+type Vendor = T.Text++deleteProduct :: ProductWithMeta -> Shopify ()+deleteProduct (PWM meta _ _) = do+ (_::JS.Value) <- shopifyDelete ("/admin/products/"++show (metaId meta)++".json")+ return ()++createProduct :: Product ProductVariant -> Shopify ProductWithMeta+createProduct pb = do+ pw <- shopifySet "/admin/products.json" False (JS.object ["product" .= pb])+ case Map.lookup ("product"::T.Text) pw of+ Just p -> return p+ Nothing -> error "product not pressent"++updateStock :: ShopifyID -> Int -> Shopify ()+updateStock vid stock = do+ (_::JS.Value) <- shopifySet ("/admin/variants/"++show vid++".json") True (+ JS.object [("variant", JS.object+ [ ("id", JS.toJSON vid)+ , ("inventory_quantity", JS.toJSON stock) ])])+ return ()++updateProduct :: ProductWithMeta -> Product ProductVariant -> Shopify ProductWithMeta+updateProduct (PWM meta pubtime old) new = do+ let variantMetas = map (\(VWM vmeta prod (ProductVariant {pvSku=sku})) -> (sku, (vmeta, prod))) . pVariants $ old+ let updateVariants = map (\(v@ProductVariant {pvSku=sku}) ->+ (VWMM (fmap fst $ lookup sku variantMetas) (fmap snd $ lookup sku variantMetas) v)) .+ pVariants $ new+ let updateRequest = PMMV meta pubtime (new { pVariants = updateVariants+ , pImages = [] })+ liftIO $ print updateRequest+ pw <- shopifySet ("/admin/products/"++show (metaId meta)++".json") True (JS.object [("product", JS.toJSON updateRequest)])+ p <- case Map.lookup ("product"::T.Text) pw of+ Just p' -> return p'+ Nothing -> error "product not pressent"+ forM_ (pImages old) $ \i -> do+ (_::JS.Value) <- shopifyDelete ("/admin/products/"++show (metaId meta)++"/images/"++show (metaId $ piMeta i)++".json")+ return ()+ forM_ (pImages new) $ \i -> do+ shopifySet ("/admin/products/"++show (metaId meta)++"/images.json") False (JS.object [("image", JS.toJSON i)])::Shopify JS.Value+ return p++data ProductQuery =+ PQCollection CollectionID+ | PQCreatedBefore UTCTime+ | PQCreatedAfter UTCTime+ | PQHandle T.Text+ | PQType ProductType+ | PQPublishedBefore UTCTime+ | PQPublishedAfter UTCTime+ | PQPublished Bool+ | PQVendor Vendor+ | PQUpdatedBefore UTCTime+ | PQUpdatedAfter UTCTime+ | PQIdGreaterThen ProductID+ deriving (Show)++encodeProductQuery :: ProductQuery -> (BS.ByteString, Maybe BS.ByteString)+encodeProductQuery (PQCollection cid) = ("collection_id", toQueryValue $ show cid)+encodeProductQuery (PQCreatedBefore t) = ("created_at_max", dateToQuery t)+encodeProductQuery (PQCreatedAfter t) = ("created_at_min", dateToQuery t)+encodeProductQuery (PQHandle txt) = ("handle", toQueryValue txt)+encodeProductQuery (PQType txt) = ("product_type", toQueryValue txt)+encodeProductQuery (PQPublishedBefore t) = ("published_at_max", dateToQuery t)+encodeProductQuery (PQPublishedAfter t) = ("published_at_min", dateToQuery t)+encodeProductQuery (PQPublished p) = ("published_status"+ ,toQueryValue $+ if p+ then "published"::String+ else "unpublished")+encodeProductQuery (PQVendor txt) = ("vendor", toQueryValue txt)+encodeProductQuery (PQUpdatedBefore t) = ("updated_at_max", dateToQuery t)+encodeProductQuery (PQUpdatedAfter t) = ("updated_at_min", dateToQuery t)+encodeProductQuery (PQIdGreaterThen pid) = ("since_id", toQueryValue $ show pid)++queryProductMetaFields :: ProductID -> Shopify MetaFields+queryProductMetaFields pid = do+ pw <- shopifyGet ("/admin/products/"++show pid++"/metafields.json") (const "") ()+ case Map.lookup ("metafields"::T.Text) pw of+ Just mf -> return mf+ Nothing -> error "product not pressent"++queryProduct :: ProductID -> Shopify ProductWithMeta+queryProduct pid = do+ pw <- shopifyGet ("/admin/products/"++show pid++".json") (const "") ()+ case Map.lookup ("product"::T.Text) pw of+ Just p -> return p+ Nothing -> error "product not pressent"++queryProducts :: [ProductQuery] -> Shopify [ProductWithMeta]+queryProducts q =+ getBlock 1 []+ where+ baseQuery = ("limit", Just "250"):map encodeProductQuery q+ genQuery i qry= renderQuery False (("page", toQueryValue (show i)):qry)+ getBlock :: Int -> [ProductWithMeta] -> Shopify [ProductWithMeta] + getBlock i ops = do+ psw <- shopifyGet "/admin/products.json" (genQuery i) baseQuery+ ps <- case Map.lookup ("products"::T.Text) psw of+ Just ps -> return ps+ Nothing -> error "products not pressent"+ if length ps < 250+ then return (ps ++ ops)+ else getBlock (i+1) (ps ++ ops)++data Product a =+ Product {+ pTitle :: Title + , pNameTag :: Maybe T.Text+ , pType :: ProductType+ , pHtml :: T.Text+ , pVendor :: Vendor+ , pTags :: Set.Set T.Text+ , pVariants :: [a]+ , pImages :: [ProductImage]+ , pOptions :: [T.Text]+ , pMetaFields :: MetaFields+ }+ deriving (Show)++data ProductWithMeta =+ PWM { pwmMeta :: ShopifyMeta, pwmPublished :: Maybe UTCTime, pwmProduct :: Product VariantWithMeta }+ deriving (Show)++data ProductMaybeMetaVariant =+ PMMV { pmmvMeta :: ShopifyMeta, pmmvPublished :: Maybe UTCTime, pmmvProduct :: Product VariantWithMaybeMeta }+ deriving (Show)++instance JS.ToJSON ProductMaybeMetaVariant where+ toJSON (PMMV meta pub p) = JS.object $ (jsonExtender meta) +++ ["published_at" .= (fmap ShopifyDate pub)] +++ (jsonExtender p)++instance JS.ToJSON (Product ProductVariant) where+ toJSON = JS.object . jsonExtender++instance JS.FromJSON ProductWithMeta where+ parseJSON (o@(JS.Object v)) = PWM <$>+ JS.parseJSON o <*>+ (v .:? "published_at" >>= (return . fmap actualTime)) <*>+ JS.parseJSON o+ parseJSON _ = fail "ProductWithMeta not an object"++instance JS.FromJSON a => JS.FromJSON (Product a) where+ parseJSON (JS.Object v) = Product <$>+ v .: "title" <*>+ v .:? "handle" <*>+ v .: "product_type" <*>+ ((v .:? "body_html") >>= (return . fromMaybe "")) <*>+ v .: "vendor" <*>+ ((v .: "tags") >>= (return . Set.fromList . T.splitOn ", ")) <*>+ ((v .: "variants") >>= (return . unposition)) <*>+ (((v .:? "images") >>= (return . maybe [] unposition)) <|> pure []) <*>+ ((v .:? "options") >>= (return . maybe [] (map (\(ProductOption t) -> t)))) <*>+ pure emptyMeta+ parseJSON _ = fail "Product not an object"++instance JsonExtending a => JsonExtending (Product a) where+ jsonExtender (p@Product {}) =+ ["body_html" .= pHtml p+ ,"handle" .= pNameTag p+ ,"title" .= pTitle p+ ,"product_type" .= pType p+ ,"vendor" .= pVendor p+ ,"tags" .= (T.intercalate ", " . Set.toList . pTags) p+ ,"variants" .= position (pVariants p)+ ,"images" .= position (pImages p)+ ,"metafields" .= pMetaFields p+ ] ++ if null . pOptions $ p + then []+ else ["options" .= (map ProductOption $ pOptions p)]++data ProductOption = ProductOption T.Text++instance JS.FromJSON ProductOption where+ parseJSON (JS.Object v) = ProductOption <$> v .: "name"+ parseJSON _ = fail "ProductOption not an object"++instance JS.ToJSON ProductOption where+ toJSON (ProductOption t) = JS.object ["name" .= t]++{-+-- "created_at": "2012-07-19T15:42:24-04:00",+-- "id": 850703190,+ "position": 1,+-- "product_id": 632910392,+-- "updated_at": "2012-07-19T15:42:24-04:00",+-- "src": "http://static.shopify.com/s/files/1/0006/9093/3842/products/ipod-nano.png?0"+-}++data ProductImage =+ ProductImageRemote {+ piMeta :: ShopifyMeta+ , piProductID :: ProductID+ , piSrc :: T.Text+ }+ | ProductImageLocal {+ piData :: BS.ByteString+ , piFilename :: T.Text+ }+ deriving (Show)++instance JS.FromJSON ProductImage where+ -- The only sort of image that can be sent to us is the remote type.+ parseJSON (o@(JS.Object v)) = ProductImageRemote <$>+ JS.parseJSON o <*>+ v .: "product_id" <*>+ v .: "src"+ parseJSON _ = fail "ProductImage not an object"++instance JS.ToJSON ProductImage where+ toJSON = JS.object . jsonExtender++instance JsonExtending ProductImage where+ jsonExtender (ProductImageRemote m pid src) =+ jsonExtender m ++ [+ "product_id" .= pid+ ,"src" .= src+ ]+ jsonExtender (ProductImageLocal d fn) = [("attachment" .= (TE.decodeUtf8 . B64.encode $ d)), ("filename" .= fn)]++{-+ "compare_at_price": null,+-- "created_at": "2012-07-19T15:42:24-04:00",+ "fulfillment_service": "manual",+-- "grams": 200,+-- "id": 808950810,+-- "inventory_management": "shopify",+-- "inventory_policy": "continue",+-- "option1": "Pink",+-- "option2": null,+-- "option3": null,+-- "position": 1,+-- "price": "199.00",+-- "product_id": 632910392,+-- "requires_shipping": true,+-- "sku": "IPOD2008PINK",+-- "taxable": true,+-- "title": "Pink",+-- "updated_at": "2012-07-19T15:42:24-04:00",+-- "inventory_quantity": 10+-}+data ProductVariant =+ ProductVariant+ { pvSku :: Sku+ , pvTitle :: T.Text+ , pvPrice :: Centi+ , pvGrams :: Int+ , pvInventory :: Int+ , pvInventoryManagement :: InventoryManagement+ , pvInventoryPolicy :: InventoryPolicy+ , pvTaxable :: Bool+ , pvShips :: Bool+ , pvOption1 :: Maybe T.Text+ , pvOption2 :: Maybe T.Text+ , pvOption3 :: Maybe T.Text+ }+ deriving (Show)++data VariantWithMeta =+ VWM { variantMeta :: ShopifyMeta, variantProductID :: ProductID, variantVariant :: ProductVariant }+ deriving (Show)++data VariantWithMaybeMeta =+ VWMM { vwmmMeta :: (Maybe ShopifyMeta), vwmmProduct :: (Maybe ProductID), vwmmVariant :: ProductVariant }+ deriving (Show)++instance JsonExtending VariantWithMaybeMeta where+ jsonExtender (VWMM mm mp p) = (fromMaybe [] $ fmap jsonExtender mm) +++ (fromMaybe [] $ fmap (\pid -> ["product_id" .= pid]) mp) +++ (jsonExtender p)++instance JS.FromJSON VariantWithMeta where+ parseJSON (o@(JS.Object v)) = VWM <$>+ JS.parseJSON o <*>+ (v .: "product_id") <*>+ JS.parseJSON o+ parseJSON _ = fail "VariantWithMeta not an object"++instance JS.FromJSON ProductVariant where+ parseJSON (JS.Object v) = ProductVariant <$>+ v .: "sku" <*>+ v .: "title" <*>+ ((v .: "price"::JS.Parser String) >>=+ (\s -> case readMay s of+ Just c -> pure c+ Nothing -> fail "Couldn't read price")) <*>+ v .: "grams" <*>+ v .: "inventory_quantity" <*>+ ((v .: "inventory_management") >>= (return . fromMaybe InvManagedShopify)) <*>+ v .: "inventory_policy" <*>+ v .: "taxable" <*>+ v .: "requires_shipping" <*>+ v .:? "option1" <*>+ v .:? "option2" <*>+ v .:? "option3"+ parseJSON _ = fail "ProductVariant not an object"++instance JsonExtending ProductVariant where+ jsonExtender (pv@ProductVariant {}) =+ ["sku" .= pvSku pv+ ,"title" .= pvTitle pv+ ,"price" .= (show . pvPrice $ pv)+ ,"grams" .= pvGrams pv+ ,"inventory_quantity" .= pvInventory pv+ ,"inventory_management" .= pvInventoryManagement pv+ ,"inventory_policy" .= pvInventoryPolicy pv+ ,"taxable" .= pvTaxable pv+ ,"requires_shipping" .= pvShips pv+ ] ++ options+ where+ options = option 1 pvOption1 ++ option 2 pvOption2 ++ option 3 pvOption3+ option :: Int -> (ProductVariant -> Maybe T.Text) -> [JS.Pair]+ option i f = maybeToList $ fmap ((T.pack $ "option"++show i) .= ) (f pv)++data InventoryPolicy =+ InvPolicyContinue+ | InvPolicyDeny+ deriving (Show)++instance JS.FromJSON InventoryPolicy where+ parseJSON (JS.String "continue") = return InvPolicyContinue+ parseJSON (JS.String "deny") = return InvPolicyDeny+ parseJSON _ = fail "InventoryPolocy unknown"++instance JS.ToJSON InventoryPolicy where+ toJSON InvPolicyContinue = JS.String "continue"+ toJSON InvPolicyDeny = JS.String "deny"++data InventoryManagement =+ InvManagedShopify+ | InvManagedShipwire+ | InvManagedAmazon+ | InvManagedWebgistix+ deriving (Show)++instance JS.FromJSON InventoryManagement where+ parseJSON (JS.String "shopify") = return InvManagedShopify+ parseJSON (JS.String "shipwire") = return InvManagedShipwire+ parseJSON (JS.String "amazon_marketplace_web") = return InvManagedAmazon+ parseJSON (JS.String "webgistix") = return InvManagedWebgistix+ parseJSON _ = fail "InventoryManagement unknown"++instance JS.ToJSON InventoryManagement where+ toJSON InvManagedShopify = JS.String "shopify"+ toJSON InvManagedShipwire = JS.String "shipwire"+ toJSON InvManagedAmazon = JS.String "amazon_marketplace_web"+ toJSON InvManagedWebgistix = JS.String "webgistix"
+ Network/Shopify/Types.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.Shopify.Types (+ ShopifyID+ , JsonExtending(..), ShopifyMeta(..), ShopifyDate(..), dateToQuery+ , ProductID, LineItemID, CollectionID, OrderID+ , Sku+ ) where++import Data.Int+import Control.Applicative+import qualified Data.Text as T+import Data.Aeson ((.:), (.=))+import qualified Data.Aeson as JS+import qualified Data.Aeson.Types as JS+import qualified Data.ByteString as BS+import Data.Time+import Network.HTTP.Types.QueryLike (toQueryValue)+++type ShopifyID = Int64+type ProductID = ShopifyID+type LineItemID = ShopifyID+type CollectionID = ShopifyID+type OrderID = ShopifyID++type Sku = T.Text++class JsonExtending a where+ jsonExtender :: a -> [JS.Pair]++dateToQuery :: UTCTime -> Maybe BS.ByteString+dateToQuery = toQueryValue . formatTime defaultTimeLocale (iso8601DateFormat $ Just "")++data ShopifyDate = ShopifyDate {actualTime::UTCTime}++instance JS.FromJSON ShopifyDate where+ parseJSON (JS.String t) =+ case parseTimeM True defaultTimeLocale "%FT%T%Z" (T.unpack t) of+ Just d -> pure $ ShopifyDate d+ Nothing -> fail "could not parse ISO-8601 date"+ parseJSON v = fail ("ShopifyDate not a string: "++show v)++instance JS.ToJSON ShopifyDate where+ toJSON (ShopifyDate t) = JS.String (T.pack $ formatTime defaultTimeLocale "%FT%T%z" t)++data ShopifyMeta =+ ShopifyMeta {+ metaId :: ShopifyID+ , metaCreated :: UTCTime+ , metaUpdated :: UTCTime+ }+ deriving (Show)++instance JsonExtending ShopifyMeta where+ jsonExtender m =+ ["id" .= metaId m+ ,"created_at" .= (ShopifyDate $ metaCreated m)+ ,"updated_at" .= (ShopifyDate $ metaUpdated m)+ ]++instance JS.FromJSON ShopifyMeta where+ parseJSON (JS.Object v) = ShopifyMeta <$>+ v .: "id" <*>+ (v .: "created_at" >>= return . actualTime) <*>+ (v .: "updated_at" >>= return . actualTime)+ parseJSON _ = fail "ShopifyMeta not an object"
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ shopify.cabal view
@@ -0,0 +1,48 @@+name: shopify+version: 0+synopsis: A haskell API binding for shopify.com+description: A haskell API binding for shopify.com+homepage: https://oss.xkcd.com/+license: BSD3+license-file: LICENSE+author: davean+maintainer: oss@xkcd.com+copyright: davean 2012-2017+category: Network+build-type: Simple+cabal-version: >=1.16++source-repository head+ type: git+ location: https://code.xkrd.net/haskell/shopify.git++library+ exposed-modules:+ Network.Shopify+ , Network.Shopify.Types+ , Network.Shopify.Metafield+ , Network.Shopify.Permissions+ , Network.Shopify.Connection+ , Network.Shopify.Products+ , Network.Shopify.Orders+ default-language: Haskell2010+ build-depends:+ base >= 4.4 && < 4.10+ , lifted-base >= 0.2 && < 0.3+ , containers >= 0.5 && < 0.6+ , unordered-containers >= 0.2 && < 0.3+ , vector >= 0.11 && < 0.13+ , mtl >= 2.0 && < 2.3+ , safe >= 0.3 && < 0.4+ , http-types >= 0.9 && < 0.10+ , bytestring >= 0.10 && < 0.11+ , text >= 1.0 && < 1.3+ , resourcet >= 1.1 && < 1.2+ , http-conduit >= 2.2 && < 2.3+ , attoparsec >= 0.13 && < 0.14+ , aeson >= 1.0 && < 1.3+ , aeson-pretty >= 0.8 && < 0.9+ , time >= 1.6 && < 1.9+ , base64-bytestring >= 1.0 && < 1.1+ , control-monad-exception >= 0.11 && < 0.12+