diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 Andrew Rademacher + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 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/amazon-products.cabal b/amazon-products.cabal new file mode 100644 --- /dev/null +++ b/amazon-products.cabal @@ -0,0 +1,54 @@ + +name: amazon-products +version: 0.1.0.0 +synopsis: Connector for Amazon Products API +description: Allows users to directly access Amazon Products API, + without having to work with the underlying REST and + authentication layers. +license: MIT +license-file: LICENSE +author: Andrew Rademacher +maintainer: andrewrademacher@gmail.com +category: Web +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: Amazon + , Amazon.Item + , Amazon.Utils + , Amazon.Types + , Amazon.Types.Item + + build-depends: base >=4.6 && <4.7 + , old-locale >=1.0 && <1.1 + , time >=1.4 && <1.5 + , text >=1.1 && <1.2 + , bytestring >=0.10 && <0.11 + , mtl >=2.1 && <2.2 + , transformers >=0.3 && <0.4 + , transformers-base >=0.4 && <0.5 + , resourcet >=1.1 && <1.2 + , conduit >=1.1 && <1.2 + , http-conduit >=2.1 && <2.2 + , xml-types >=0.3 && <0.4 + , xml-picklers >=0.3 && <0.4 + , xml-conduit >=1.2 && <1.3 + , http-types >=0.8 && <0.9 + , base64-bytestring >=1.0 && <1.1 + , containers >=0.5 && <0.6 + , cryptohash >=0.11 && <0.12 + , byteable >=0.1 && <0.2 + +executable repl + main-is: Main.hs + hs-source-dirs: repl + default-language: Haskell2010 + build-depends: base >=4.6 && <4.7 + , text >=1.0 && <1.2 + , bytestring >=0.10 && <0.11 + , transformers >=0.3 && <0.4 + , http-conduit >=2.1 && <2.2 + , amazon-products diff --git a/repl/Main.hs b/repl/Main.hs new file mode 100644 --- /dev/null +++ b/repl/Main.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE OverloadedStrings #-} + +import qualified Data.ByteString.Lazy.Char8 as Char8 +import Data.Text as T +import Network.HTTP.Conduit +import System.Environment + +import Amazon +import Amazon.Item + +main :: IO () +main = do + conf <- getSandbox + {-res <- runAmazonT conf $ itemLookup "B00F0DD0I6" IdASIN [Images, ItemAttributes] CAll-} + {-res <- runAmazonT conf $ itemLookup "B00EV97UD6" IdASIN [Images, ItemAttributes] CAll-} + res <- runAmazonT conf $ itemSearch "jambox" All [ItemAttributes] CAll Nothing Nothing + print res + +getSandbox :: IO AmazonConf +getSandbox = do + accessId <- getEnv "AWS_ACCESS_ID" + accessSecret <- getEnv "AWS_ACCESS_SECRET" + associateTag <- getEnv "AWS_ASSOCIATE_TAG" + manager <- newManager conduitManagerSettings + return $ liveConf manager (T.pack accessId) (Char8.pack accessSecret) (T.pack associateTag) diff --git a/src/Amazon.hs b/src/Amazon.hs new file mode 100644 --- /dev/null +++ b/src/Amazon.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Amazon + ( liveConf + + , AmazonT (..) + , runAmazonT + + , amazonRequest + , amazonGet + + , module Amazon.Types + ) where + +import Control.Applicative +import Control.Monad.Base +import Control.Monad.Error +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import Crypto.Hash +import Data.Byteable +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.ByteString.Lazy as LBS +import Data.Conduit +import Data.Function +import Data.List +import Data.String +import Data.Text as T +import Data.Text.Encoding as TE +import Data.Time +import Data.XML.Pickle +import Data.XML.Types +import Network.HTTP.Conduit +import Network.HTTP.Types.Status +import Network.HTTP.Types.URI +import System.Locale +import Text.XML.Unresolved + +import Amazon.Types + +version :: Text +version = "2011-08-01" + +liveConf :: Manager -> AccessID -> AccessSecret -> AssociateTag -> AmazonConf +liveConf = AmazonConf $ AmazonEndpoint + { endpointURL = "http://webservices.amazon.com/onca/xml" + , endpointHost = "webservices.amazon.com" + , endpointPath = "/onca/xml" + } + +newtype AmazonT a = AmazonT + { unAmazonT :: ResourceT (ReaderT AmazonConf (ErrorT AmazonFailure IO)) a + } deriving ( Functor, Applicative, Monad, MonadIO, MonadThrow + , MonadError AmazonFailure + , MonadReader AmazonConf + , MonadBase IO + , MonadResource ) + +runAmazonT :: AmazonConf -> AmazonT a -> IO (Either AmazonFailure a) +runAmazonT conf = runErrorT . flip runReaderT conf . runResourceT . unAmazonT + +amazonRequest :: (MonadIO m, MonadThrow m, MonadReader AmazonConf m) => + Text -> [(Text, Text)] -> m Request +amazonRequest opName opParams = do + now <- liftIO $ getCurrentTime + (AmazonConf{..}) <- ask + let defParams = [ ("AssociateTag", amazonAssociateTag) + , ("AWSAccessKeyId", amazonAccessId) + , ("Operation", opName) + , ("Version", version) + , ("Timestamp", T.pack $ formatTime defaultTimeLocale timeFormat now) + ] + fnParams = sortBy (compare `on` fst) $ defParams ++ opParams + paramsTxt = T.intercalate "&" $ + fmap (\(k, v) -> T.concat [k, "=", (encodeText v)]) fnParams + signTxt = T.intercalate "\n" [ "GET" + , endpointHost amazonEndpoint + , endpointPath amazonEndpoint + , paramsTxt + ] + paramsUrl = TE.encodeUtf8 paramsTxt + signature = urlEncode True $ Base64.encode $ toBytes $ hmacAlg SHA256 + (LBS.toStrict amazonAccessSecret) (TE.encodeUtf8 signTxt) + parseUrl $ (endpointURL amazonEndpoint) ++ "?" ++ (Char8.unpack paramsUrl) ++ + "&Signature=" ++ (Char8.unpack signature) + +encodeText :: Text -> Text +encodeText = TE.decodeUtf8 . urlEncode True . TE.encodeUtf8 + +amazonGet :: (Parameterize a) => Text -> a -> PU [Node] b -> AmazonT (OperationRequest, b) +amazonGet opName opParams resPickler = do + (AmazonConf{..}) <- ask + initReq <- amazonRequest opName (toParams opParams) + res <- http initReq amazonManager + case responseStatus res of + s | s == status200 -> handleResult res resXp (return) + | otherwise -> handleResult res errXp (throwError . AmazonFailure . Just) + where errName = fromString $ T.unpack $ + T.concat [ "{http://webservices.amazon.com/AWSECommerceService/2011-08-01}" + , opName + , "ErrorResponse" + ] + errXp = xpRoot $ xpElemNodes errName $ xpAmazonError + resName = fromString $ T.unpack $ + T.concat [ "{http://webservices.amazon.com/AWSECommerceService/2011-08-01}" + , opName + , "Response" + ] + resXp = xpRoot $ xpElemNodes resName $ + xpPair + (xpElemNodes (nsName "OperationRequest") xpOperationRequest) + resPickler + +handleResult :: (MonadBase IO m, MonadResource m, MonadThrow m, MonadError AmazonFailure m) => + Response (ResumableSource m BS.ByteString) -> PU Node a -> (a -> m b) -> m b +handleResult res xpOut constOut = do + doc@(Document _ root _) <- responseBody res $$+- sinkDoc def + let out = unpickle xpOut (NodeElement root) + case out of + Left e -> throwError $ ParseFailure $ Just e + Right s -> constOut s diff --git a/src/Amazon/Item.hs b/src/Amazon/Item.hs new file mode 100644 --- /dev/null +++ b/src/Amazon/Item.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Amazon.Item + ( itemSearch + , itemLookup + + , module Amazon.Types.Item + ) where + +import Data.Text as T +import Data.XML.Pickle + +import Amazon +import Amazon.Types.Item + +itemSearch :: Text -> SearchIndex -> [ResponseGroup] -> Condition -> + Maybe Int -> Maybe Int -> AmazonT (OperationRequest, [Item]) +itemSearch keyword si res cond max min = amazonGet "ItemSearch" req xpSearch + where req = ItemSearchRequest cond keyword res si max min + xpSearch = xpElemNodes (nsName "Items") $ xpClean $ + xpFindMatches $ xpElemNodes (nsName "Item") xpItem + +itemLookup :: ItemID -> IdType -> [ResponseGroup] -> Condition -> + AmazonT (OperationRequest, Item) +itemLookup iid iType resGroup cond = amazonGet "ItemLookup" req xpLookup + where req = ItemLookupRequest cond iType iid resGroup VPAll + xpLookup = xpElemNodes (nsName "Items") $ xpClean $ + xpElemNodes (nsName "Item") xpItem diff --git a/src/Amazon/Types.hs b/src/Amazon/Types.hs new file mode 100644 --- /dev/null +++ b/src/Amazon/Types.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Amazon.Types + ( nsName + , timeFormat + , AccessID + , AccessSecret + , AssociateTag + + , AmazonEndpoint (..) + , AmazonConf (..) + , AmazonFailure (..) + + , ResponseGroup (..) + + , OperationRequest (..) + , AmazonError (..) + , RequestContainer (..) + + , xpResponseGroup + , xpOperationRequest + , xpAmazonError + , xpRequestContainer + + , Parameterize (..) + ) where + +import Control.Monad.Trans.Error (Error, noMsg, strMsg) +import Data.ByteString.Lazy as LBS +import Data.Map as Map +import Data.Text as T +import Data.XML.Pickle +import Data.XML.Types +import Network.HTTP.Conduit + +nsName :: Text -> Name +nsName n = Name n (Just "http://webservices.amazon.com/AWSECommerceService/2011-08-01") + Nothing + +timeFormat :: String +timeFormat = "%Y-%m-%dT%H:%M:%S.000Z" + +type AccessID = Text +type AccessSecret = LBS.ByteString +type AssociateTag = Text + +data AmazonEndpoint = AmazonEndpoint + { endpointURL :: String + , endpointHost :: Text + , endpointPath :: Text + } deriving (Eq, Show) + +data AmazonConf = AmazonConf + { amazonEndpoint :: AmazonEndpoint + , amazonManager :: Manager + , amazonAccessId :: AccessID + , amazonAccessSecret :: AccessSecret + , amazonAssociateTag :: AssociateTag + } + +data AmazonFailure = AmazonFailure (Maybe AmazonError) + | ParseFailure (Maybe UnpickleError) + | OtherFailure (Maybe Text) + deriving (Show) + +instance Error AmazonFailure where + noMsg = OtherFailure Nothing + strMsg = OtherFailure . Just . T.pack + +data ResponseGroup = Accessories + | AlternateVersions + | BrowseNodeInfo + | BrowseNodes + | Cart + | CartNewReleases + | CartTopSellers + | CartSimilarities + | EditoralReview + | Images + | ItemAttributes + | ItemIds + | Large + | Medium + | MostGifted + | MostWishedFor + | NewReleases + | OfferFull + | OfferListings + | Offers + | OfferSummary + | PromotionSummary + | RelatedItems + | Request + | Reviews + | SalesRank + | SearchBins + | Similarities + | Small + | TopSellers + | Tracks + | Variations + | VariationImages + | VariationMatrix + | VariationOffers + | VariationSummary + deriving (Eq, Show, Read) + +xpResponseGroup :: PU Text ResponseGroup +xpResponseGroup = xpPrim + +data OperationRequest = OperationRequest + { opRequestId :: Text + , opArguments :: Map Text Text + , opRequestProcessingTime :: Double + } deriving (Eq, Show) + +xpOperationRequest :: PU [Node] OperationRequest +xpOperationRequest = + xpWrap (\(r, a, t) -> OperationRequest r (Map.fromList a) t) + (\(OperationRequest r a t) -> (r, (Map.toList a), t)) $ + xp3Tuple + (xpElemText (nsName "RequestId")) + (xpElemNodes (nsName "Arguments") $ + xpList $ xpElemAttrs (nsName "Argument") $ + xp2Tuple (xpAttr "Name" xpId) + (xpAttr "Value" xpId)) + (xpElemNodes (nsName "RequestProcessingTime") $ xpContent xpPrim) + +data AmazonError = AmazonError + { errorCode :: Text + , errorMessage :: Text + , errorRequestId :: Text + } deriving (Eq, Show) + +xpAmazonError :: PU [Node] AmazonError +xpAmazonError = + xpWrap wrap unwrap $ + xp2Tuple + (xpElemNodes (nsName "Error") $ + xp2Tuple (xpElemText (nsName "Code")) + (xpElemText (nsName "Message"))) + (xpElemText (nsName "RequestId")) + where wrap :: ((Text, Text), Text) -> AmazonError + wrap ((code, message), reqId) = AmazonError code message reqId + + unwrap :: AmazonError -> ((Text, Text), Text) + unwrap (AmazonError code message reqId) = ((code, message), reqId) + +class Parameterize a where + toParams :: a -> [(Text, Text)] + +---- + +data RequestContainer a = RequestContainer + { requestIsValid :: Bool + , requestSubset :: a + } deriving (Eq, Show) + +xpRequestContainer :: (Eq a, Show a) => Name -> PU [Node] a -> PU [Node] (RequestContainer a) +xpRequestContainer elemName xpSubset = + xpWrap (\(a, b) -> RequestContainer a b) + (\(RequestContainer a b) -> (a, b)) $ + xp2Tuple + (xpElemNodes (nsName "IsValid") $ + xpContent xpPrim) + (xpElemNodes elemName $ xpSubset) diff --git a/src/Amazon/Types/Item.hs b/src/Amazon/Types/Item.hs new file mode 100644 --- /dev/null +++ b/src/Amazon/Types/Item.hs @@ -0,0 +1,420 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Amazon.Types.Item + ( ItemLookupRequest (..) + , ItemSearchRequest (..) + , Item (..) + , ItemID + , SearchIndex (..) + , Condition (..) + , IdType (..) + , VariationPage (..) + , ImageSetType (..) + , ImageSet (..) + , Attributes (..) + , Dimensions (..) + , ListPrice (..) + + , HundredthInch (..) + , HundredthPound (..) + + , parseCondition + , parseIdType + , parseVariationPage + + , xpItem + , xpItemLookupRequest + , xpItemSearchRequest + , xpItemId + , xpSearchIndex + , xpCondition + , xpIdType + , xpVariationPage + , xpImageSetType + , xpImageSet + , xpAttributes + , xpDimensions + , xpListPrice + + , xpHundredthInch + , xpHundredthPound + ) where + +import Data.Text as T +import Data.XML.Pickle +import Data.XML.Types +import Prelude as P + +import Amazon.Types + +type ItemID = Text + +xpItemId :: PU Text ItemID +xpItemId = xpId + +data SearchIndex = All + | Apparel + | Appliances + | ArtsAndCrafts + | Automotive + | Baby + | Beauty + | Blended + | Books + | Classical + | Collectibles + | DigitalMusic + | Grocery + | DVD + | Electronics + | HealthPersonalCare + | HomeGarden + | Industrial + | Jewelry + | KindleStore + | Kitchen + | LawnGarden + | Magazines + | Marketplace + | Merchants + | Miscellaneous + | MobileApps + | MP3Downloads + | Music + | MusicalInstruments + | MusicTracks + | OfficeProducts + | OutdoorLiving + | PCHardware + | PetSupplies + | Photo + | Shoes + | Software + | SportingGoods + | Tools + | Toys + | UnboxVideo + | VHS + | Video + | VideoGames + | Watches + | Wireless + | WirelessAccessories + deriving (Eq, Show, Read) + +xpSearchIndex :: PU Text SearchIndex +xpSearchIndex = xpPrim + +data Condition = CAll | CNew | CUsed | CCollectible | CRefurbished deriving (Eq) + +instance Show Condition where + show CAll = "All" + show CNew = "New" + show CUsed = "Used" + show CCollectible = "Collectible" + show CRefurbished = "Refurbished" + +parseCondition :: Text -> Condition +parseCondition "All" = CAll +parseCondition "New" = CNew +parseCondition "Used" = CUsed +parseCondition "Collectible" = CCollectible +parseCondition "Refurbished" = CRefurbished + +xpCondition :: PU Text Condition +xpCondition = PU { unpickleTree = return . parseCondition + , pickleTree = T.pack . show + } + +data IdType = IdASIN | IdSKU | IdUPC | IdEAN | IdISBN deriving (Eq) + +instance Show IdType where + show IdASIN = "ASIN" + show IdSKU = "SKU" + show IdUPC = "UPC" + show IdEAN = "EAN" + show IdISBN = "ISBN" + +parseIdType :: Text -> IdType +parseIdType "ASIN" = IdASIN +parseIdType "SKU" = IdSKU +parseIdType "UPC" = IdUPC +parseIdType "EAN" = IdEAN +parseIdType "ISBN" = IdISBN + +xpIdType :: PU Text IdType +xpIdType = PU { unpickleTree = return . parseIdType + , pickleTree = T.pack . show + } + +data VariationPage = VPAll + deriving (Eq) + +instance Show VariationPage where + show VPAll = "All" + +parseVariationPage :: Text -> VariationPage +parseVariationPage "All" = VPAll + +xpVariationPage :: PU Text VariationPage +xpVariationPage = PU { unpickleTree = return . parseVariationPage + , pickleTree = T.pack . show + } + +---- + +data ItemLookupRequest = ItemLookupRequest + { lookupCondition :: Condition + , lookupIdType :: IdType + , lookupItemId :: ItemID + , lookupResponseGroups :: [ResponseGroup] + , lookupVariationPage :: VariationPage + } deriving (Eq, Show) + +xpItemLookupRequest :: PU [Node] ItemLookupRequest +xpItemLookupRequest = + xpWrap (\(a, b, c, d, e) -> ItemLookupRequest a b c d e) + (\(ItemLookupRequest a b c d e) -> (a, b, c, d, e)) $ + xp5Tuple + (xpElemNodes (nsName "Condition") $ + xpContent xpCondition) + (xpElemNodes (nsName "IdType") $ + xpContent xpIdType) + (xpElemNodes (nsName "ItemId") $ + xpContent xpItemId) + (xpList $ xpElemNodes (nsName "ResponseGroup") $ + xpContent xpResponseGroup) + (xpElemNodes (nsName "VariationPage") $ + xpContent xpVariationPage) + +instance Parameterize ItemLookupRequest where + toParams (ItemLookupRequest{..}) = + [ ("Condition", (T.pack $ show lookupCondition)) + , ("IdType", (T.pack $ show lookupIdType)) + , ("ItemId", lookupItemId) + , ("ResponseGroup", intercalate "," (P.map (T.pack . show) lookupResponseGroups)) + ] + +---- + +data ItemSearchRequest = ItemSearchRequest + { searchCondition :: Condition + , searchKeywords :: Text + , searchResponseGroups :: [ResponseGroup] + , searchIndex :: SearchIndex + , searchMaxPrice :: Maybe Int + , searchMinPrice :: Maybe Int + } deriving (Eq, Show) + +xpItemSearchRequest :: PU [Node] ItemSearchRequest +xpItemSearchRequest = + xpWrap (\(a, b, c, d, e, f) -> ItemSearchRequest a b c d e f) + (\(ItemSearchRequest a b c d e f) -> (a, b, c, d, e, f)) $ + xp6Tuple + (xpElemNodes (nsName "Condition") $ + xpContent xpCondition) + (xpElemText (nsName "Keywords")) + (xpList $ xpElemNodes (nsName "ResponseGroup") $ + xpContent xpResponseGroup) + (xpElemNodes (nsName "SearchIndex") $ + xpContent xpSearchIndex) + (xpElemNodes (nsName "MaximumPrice") $ xpContent xpPrim) + (xpElemNodes (nsName "MinimumPrice") $ xpContent xpPrim) + +instance Parameterize ItemSearchRequest where + toParams (ItemSearchRequest{..}) = + [ ("Condition", (T.pack $ show searchCondition)) + , ("Keywords", searchKeywords) + , ("ResponseGroup", intercalate "," (P.map (T.pack . show) searchResponseGroups)) + , ("SearchIndex", (T.pack $ show searchIndex)) + ] ++ P.concatMap hPrice [ ("MaximumPrice", searchMaxPrice) + , ("MinimumPrice", searchMinPrice) ] + where hPrice (_, Nothing) = [] + hPrice (n, Just v) = [(n, (T.pack $ show v))] + +---- + +data Item = Item + { itemASIN :: Text + , itemParentASIN :: Maybe Text + , itemAttributes :: Maybe Attributes + , itemImageSets :: Maybe [ImageSet] + } deriving (Eq, Show) + +xpItem :: PU [Node] Item +xpItem = + xpWrap (\(a, b, c, d) -> Item a b c (fmap (fmap removeTuple) d)) + (\(Item a b c d) -> (a, b, c, (fmap (fmap addTuple) d))) $ + xpClean $ xp4Tuple + (xpElemText (nsName "ASIN")) + (xpOption $ xpElemText (nsName "ParentASIN")) + (xpOption $ xpElemNodes (nsName "ItemAttributes") $ xpClean xpAttributes) + (xpOption $ xpElemNodes (nsName "ImageSets") $ + xpList $ xpElem (nsName "ImageSet") (xpAttr ("Category") xpId) xpImageSet) + where removeTuple (_,d) = d + addTuple d = ("",d) + +---- + +data Attributes = Attributes + { attrBinding :: Text + , attrBrand :: Text + , attrCatalogNumbers :: Maybe [Text] + , attrColor :: Maybe Text + , attrEAN :: Int + , attrEANList :: [Int] + , attrFeatures :: [Text] + , attrAutographed :: Maybe Bool + , attrEligibleForTradeIn :: Maybe Bool + , attrMemorabilia :: Maybe Bool + , attrDimensions :: Maybe Dimensions + , attrLabel :: Text + , attrLegalDisclaimer :: Maybe Text + , attrListPrice :: ListPrice + , attrManufacturer :: Maybe Text + , attrModel :: Maybe Text + , attrMPN :: Maybe Text + , attrNumberOfItems :: Maybe Int + , attrPackageDimensions :: Dimensions + , attrPackageQuantity :: Int + , attrPartNumber :: Maybe Text + , attrProductGroup :: Text + , attrProductTypeName :: Text + , attrTitle :: Text + , attrUPC :: Maybe Int + , attrUPCList :: Maybe [Int] + } deriving (Eq, Show) + +xpAttributes :: PU [Node] Attributes +xpAttributes = + xpWrap (\(((((((((((((((((((((((((a, b), c), d), e), f), g), h), i), j), k), l), m), n), o), p), q), r), s), t), u), v), x), y), z), aa) + -> Attributes a b c d e f g h i j k l m n o p q r s t u v x y z aa) + (\(Attributes a b c d e f g h i j k l m n o p q r s t u v x y z aa) + -> (((((((((((((((((((((((((a, b), c), d), e), f), g), h), i), j), k), l), m), n), o), p), q), r), s), t), u), v), x), y), z), aa)) $ + (xpElemText (nsName "Binding")) + <#> (xpElemText (nsName "Brand")) + <#> (xpOption $ xpElemNodes (nsName "CatalogNumberList") $ + xpList $ xpElemText (nsName "CatalogNumberListElement")) + <#> (xpOption $ xpElemText (nsName "Color")) + <#> (xpElemNodes (nsName "EAN") $ xpContent xpPrim) + <#> (xpElemNodes (nsName "EANList") $ + xpList $ xpElemNodes (nsName "EANListElement") $ xpContent xpPrim) + <#> (xpList $ xpElemText (nsName "Feature")) + <#> (xpOption $ xpElemNodes (nsName "IsAutographed") $ xpContent xpTextBool) + <#> (xpOption $ xpElemNodes (nsName "IsEligibleForTradeIn") $ xpContent xpTextBool) + <#> (xpOption $ xpElemNodes (nsName "IsMemorabilia") $ xpContent xpTextBool) + <#> (xpOption $ xpElemNodes (nsName "ItemDimensions") xpDimensions) + <#> (xpElemText (nsName "Label")) + <#> (xpOption $ xpElemText (nsName "LegalDisclaimer")) + <#> (xpElemNodes (nsName "ListPrice") xpListPrice) + <#> (xpOption $ xpElemText (nsName "Manufacturer")) + <#> (xpOption $ xpElemText (nsName "Model")) + <#> (xpOption $ xpElemText (nsName "MPN")) + <#> (xpOption $ xpElemNodes (nsName "NumberOfItems") $ xpContent xpPrim) + <#> (xpElemNodes (nsName "PackageDimensions") xpDimensions) + <#> (xpElemNodes (nsName "PackageQuantity") $ xpContent xpPrim) + <#> (xpOption $ xpElemText (nsName "PartNumber")) + <#> (xpElemText (nsName "ProductGroup")) + <#> (xpElemText (nsName "ProductTypeName")) + <#> (xpElemText (nsName "Title")) + <#> (xpOption $ xpElemNodes (nsName "UPC") $ xpContent xpPrim) + <#> (xpOption $ xpElemNodes (nsName "UPCList") $ + xpList $ xpElemNodes (nsName "UPCListElement") $ xpContent xpPrim) + +xpTextBool :: PU Text Bool +xpTextBool = PU up down + where up "0" = return False + up _ = return True + down False = "0" + down True = "1" + +---- + +newtype HundredthInch = HundredthInch Int deriving (Eq, Show) +newtype HundredthPound = HundredthPound Int deriving (Eq, Show) + +xpHundredthInch :: PU Text HundredthInch +xpHundredthInch = PU (return . HundredthInch . read . T.unpack) (T.pack . show) + +xpHundredthPound :: PU Text HundredthPound +xpHundredthPound = PU (return . HundredthPound . read . T.unpack) (T.pack . show) + +data Dimensions = Dimensions + { dimHeight :: Maybe HundredthInch + , dimLength :: Maybe HundredthInch + , dimWidth :: Maybe HundredthInch + , dimWeight :: Maybe HundredthPound + } deriving (Eq, Show) + +xpDimensions :: PU [Node] Dimensions +xpDimensions = + xpWrap (\(a, b, c, d) -> Dimensions (rt a) (rt b) (rt c) (rt d)) + (\(Dimensions a b c d) -> ((at a), (at b), (at c), (at d))) $ + xp4Tuple + (xpOption $ xpElem (nsName "Height") (xpClean $ xpOption $ xpAttr ("Units") xpId) $ + xpContent xpHundredthInch) + (xpOption $ xpElem (nsName "Length") (xpClean $ xpOption $ xpAttr ("Units") xpId) $ + xpContent xpHundredthInch) + (xpOption $ xpElem (nsName "Width") (xpClean $ xpOption $ xpAttr ("Units") xpId) $ + xpContent xpHundredthInch) + (xpOption $ + xpElem (nsName "Weight") (xpClean $ xpOption $ xpAttr (nsName "Units") xpId) $ + xpContent xpHundredthPound) + where rt = fmap (\(_, v) -> v) + at = fmap (\v -> (Nothing, v)) + +---- + +data ListPrice = ListPrice + { listAmount :: Int + , listCurrencyCode :: Text + , listFormattedPrice :: Text + } deriving (Eq, Show) + +xpListPrice :: PU [Node] ListPrice +xpListPrice = + xpWrap (\(a, b, c) -> ListPrice a b c) + (\(ListPrice a b c) -> (a, b, c)) $ + xp3Tuple + (xpElemNodes (nsName "Amount") $ xpContent xpPrim) + (xpElemText (nsName "CurrencyCode")) + (xpElemText (nsName "FormattedPrice")) + +---- + +data ImageSetType = ISPrimary | ISVariant deriving (Eq) + +instance Show ImageSetType where + show ISPrimary = "primary" + show ISVariant = "variant" + +parseImageSetType :: Text -> ImageSetType +parseImageSetType "primary" = ISPrimary +parseImageSetType "variant" = ISVariant + +xpImageSetType :: PU Text ImageSetType +xpImageSetType = PU { unpickleTree = return . parseImageSetType + , pickleTree = T.pack . show + } + +data ImageSet = ImageSet + { isetSwatchUrl :: Text + , isetThumbnailUrl :: Text + , isetTinyUrl :: Text + , isetSmallUrl :: Text + , isetMediumUrl :: Text + , isetLargeUrl :: Text + } deriving (Eq, Show) + +xpImageSet :: PU [Node] ImageSet +xpImageSet = + xpWrap (\(a, b, c, d, e, f) -> ImageSet a b c d e f) + (\(ImageSet a b c d e f) -> (a, b, c, d, e, f)) $ + xp6Tuple + (xpElemNodes (nsName "SwatchImage") $ xpClean $ xpElemText (nsName "URL")) + (xpElemNodes (nsName "ThumbnailImage") $ xpClean $ xpElemText (nsName "URL")) + (xpElemNodes (nsName "TinyImage") $ xpClean $ xpElemText (nsName "URL")) + (xpElemNodes (nsName "SmallImage") $ xpClean $ xpElemText (nsName "URL")) + (xpElemNodes (nsName "MediumImage") $ xpClean $ xpElemText (nsName "URL")) + (xpElemNodes (nsName "LargeImage") $ xpClean $ xpElemText (nsName "URL")) diff --git a/src/Amazon/Utils.hs b/src/Amazon/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Amazon/Utils.hs @@ -0,0 +1,12 @@ +module Amazon.Utils + ( isASIN + ) where + +import Data.Char +import Data.Text as T + +isASIN :: Text -> Bool +isASIN x = let l = T.length x == 10 + h = T.head x == 'B' + a = T.foldl (\b c -> b && isAlphaNum c) True x + in l && h && a