diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Network/Shopify.hs b/Network/Shopify.hs new file mode 100644 --- /dev/null +++ b/Network/Shopify.hs @@ -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 + diff --git a/Network/Shopify/Connection.hs b/Network/Shopify/Connection.hs new file mode 100644 --- /dev/null +++ b/Network/Shopify/Connection.hs @@ -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" + ] +-} diff --git a/Network/Shopify/Metafield.hs b/Network/Shopify/Metafield.hs new file mode 100644 --- /dev/null +++ b/Network/Shopify/Metafield.hs @@ -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] diff --git a/Network/Shopify/Orders.hs b/Network/Shopify/Orders.hs new file mode 100644 --- /dev/null +++ b/Network/Shopify/Orders.hs @@ -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 +-} diff --git a/Network/Shopify/Permissions.hs b/Network/Shopify/Permissions.hs new file mode 100644 --- /dev/null +++ b/Network/Shopify/Permissions.hs @@ -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" diff --git a/Network/Shopify/Products.hs b/Network/Shopify/Products.hs new file mode 100644 --- /dev/null +++ b/Network/Shopify/Products.hs @@ -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" diff --git a/Network/Shopify/Types.hs b/Network/Shopify/Types.hs new file mode 100644 --- /dev/null +++ b/Network/Shopify/Types.hs @@ -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" 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/shopify.cabal b/shopify.cabal new file mode 100644 --- /dev/null +++ b/shopify.cabal @@ -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 +