82 lines
2.6 KiB
Haskell
82 lines
2.6 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module ICAFocus where
|
|
|
|
import qualified Network.HTTP.Client as H
|
|
import qualified Network.HTTP.Client.TLS as H
|
|
import Network.HTTP.Types.Status
|
|
import Data.Aeson
|
|
import Data.Aeson.Types
|
|
import Data.Aeson.KeyMap
|
|
import Data.Text
|
|
import Text.Read
|
|
import Data.ByteString.Lazy
|
|
import GHC.Generics
|
|
|
|
newtype ImageLink = ImageLink { getLink :: String }
|
|
deriving (Show)
|
|
|
|
newtype ImageData = ImageData { getData :: ByteString }
|
|
instance Show ImageData where
|
|
show _ = "ImageData { ... }"
|
|
|
|
data ICAFocusItem a = ICAFocusItem
|
|
{ name :: Text
|
|
, image :: a
|
|
, pricePerUnit :: Float
|
|
, pricePerKg :: Float
|
|
}
|
|
deriving (Show, Functor)
|
|
|
|
type ICAFocusData = ICAFocusItem ImageLink
|
|
type ICAFocusProduct = ICAFocusItem ImageData
|
|
|
|
instance FromJSON ICAFocusData where
|
|
parseJSON (Object v) = do
|
|
productMap <- (v .: "entities") >>= (.: "product") :: Parser Object
|
|
product <- case elems productMap of
|
|
[Object x] -> pure x
|
|
[] -> fail "No products"
|
|
_ -> fail "Too many products"
|
|
|
|
name <- product .: "name"
|
|
pricePerUnitStr <- product .: "price" >>= (.: "current") >>= (.: "amount") :: Parser String
|
|
pricePerUnit <- case readEither pricePerUnitStr of
|
|
Right x -> pure x
|
|
Left e -> fail e
|
|
pricePerKgStr <- product .: "price" >>= (.: "unit") >>= (.: "current") >>= (.: "amount") :: Parser String
|
|
pricePerKg <- case readEither pricePerKgStr of
|
|
Right x -> pure x
|
|
Left e -> fail e
|
|
imageLink <- product .: "image" >>= (.: "src")
|
|
|
|
pure $ ICAFocusItem name (ImageLink imageLink) pricePerUnit pricePerKg
|
|
|
|
loadProductData :: Int -> IO (Either String ICAFocusData)
|
|
loadProductData product_id = do
|
|
httpman <- H.newManager H.tlsManagerSettings
|
|
req <- H.parseRequest $ "https://handlaprivatkund.ica.se/stores/1004247/api/v4/products/bop?retailerProductId=" ++ show product_id
|
|
resp <- H.httpLbs req httpman
|
|
|
|
if H.responseStatus resp == status200
|
|
then pure $ eitherDecode $ H.responseBody resp
|
|
else pure $ Left "Error status code"
|
|
|
|
loadProductImage :: ICAFocusData -> IO (Either String ICAFocusProduct)
|
|
loadProductImage x = do
|
|
httpman <- H.newManager H.tlsManagerSettings
|
|
req <- H.parseRequest $ (getLink . image) x
|
|
resp <- H.httpLbs req httpman
|
|
|
|
if H.responseStatus resp == status200
|
|
then do
|
|
let imageData = H.responseBody resp
|
|
pure $ Right $ (const (ImageData imageData)) <$> x
|
|
else pure $ Left "Error status code"
|
|
|
|
loadProduct :: Int -> IO (Either String ICAFocusProduct)
|
|
loadProduct product_id = do
|
|
prod <- loadProductData product_id
|
|
case prod of
|
|
Right x -> loadProductImage x
|
|
Left e -> pure $ Left e |