77 lines
2.4 KiB
Haskell
77 lines
2.4 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{- TODO: refactor code into multiple modules -}
|
|
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 Control.Monad.Except
|
|
|
|
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
|
|
|
|
unpackEither :: MonadFail m => Either String a -> m a
|
|
unpackEither (Left s) = fail s
|
|
unpackEither (Right a) = pure a
|
|
|
|
apiEndpoint :: Int -> String
|
|
apiEndpoint i = "https://handlaprivatkund.ica.se/stores/1004247/api/v4/products/bop?retailerProductId=" ++ show i
|
|
|
|
(.::) :: FromJSON a => Parser Object -> Key -> Parser a
|
|
v .:: k = v >>= (.: k)
|
|
|
|
instance FromJSON ICAFocusData where
|
|
parseJSON (Object v) = do
|
|
productMap <- v .: "entities" .:: "product"
|
|
product <- case elems productMap of
|
|
[Object x] -> pure x
|
|
[] -> fail "No products"
|
|
_ -> fail "Too many products"
|
|
|
|
ICAFocusItem
|
|
<$> product .: "name"
|
|
<*> (ImageLink <$> product .: "image" .:: "src")
|
|
<*> (unpackEither . readEither =<< product .: "price" .:: "unit" .:: "current" .:: "amount")
|
|
<*> (unpackEither . readEither =<< product .: "price" .:: "current" .:: "amount")
|
|
|
|
loadProductData :: Int -> ExceptT String IO ICAFocusData
|
|
loadProductData product_id = do
|
|
req <- H.parseRequest $ apiEndpoint product_id
|
|
resp <- liftIO $ H.httpLbs req =<< H.newManager H.tlsManagerSettings
|
|
|
|
unless (H.responseStatus resp == status200) (throwError "Error status code")
|
|
|
|
liftEither . eitherDecode $ H.responseBody resp
|
|
|
|
loadProductImage :: ICAFocusData -> ExceptT String IO ICAFocusProduct
|
|
loadProductImage x = do
|
|
req <- H.parseRequest $ (getLink . image) x
|
|
resp <- liftIO $ H.httpLbs req =<< H.newManager H.tlsManagerSettings
|
|
|
|
unless (H.responseStatus resp == status200) (throwError "Error status code")
|
|
pure $ const (ImageData (H.responseBody resp)) <$> x
|
|
|
|
loadProduct :: Int -> ExceptT String IO ICAFocusProduct
|
|
loadProduct = loadProductData >=> loadProductImage
|