matabas/backend/ICAFocus.hs

{-# 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