diff --git a/backend/ICAFocus.hs b/backend/ICAFocus.hs index 10b6a10..cef9a7f 100644 --- a/backend/ICAFocus.hs +++ b/backend/ICAFocus.hs @@ -1,46 +1,40 @@ {-# 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.Int (Int32) import Data.ByteString.Lazy -import Control.Monad.Except + +import Misc newtype ImageLink = ImageLink { getLink :: String } deriving (Show) newtype ImageData = ImageData { getData :: ByteString } + +type ProductID = Int32 + instance Show ImageData where show _ = "ImageData { ... }" data ICAFocusItem a = ICAFocusItem { name :: Text + , costPerKg :: Float + , costPerUnit :: Float , 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 :: ProductID -> 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" @@ -51,26 +45,7 @@ instance FromJSON ICAFocusData where ICAFocusItem <$> product .: "name" - <*> (ImageLink <$> product .: "image" .:: "src") - <*> (unpackEither . readEither =<< product .: "price" .:: "unit" .:: "current" .:: "amount") <*> (unpackEither . readEither =<< product .: "price" .:: "current" .:: "amount") + <*> (unpackEither . readEither =<< product .: "price" .:: "unit" .:: "current" .:: "amount") + <*> (ImageLink <$> product .: "image" .:: "src") -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 diff --git a/backend/ICAFocus/Get.hs b/backend/ICAFocus/Get.hs new file mode 100644 index 0000000..70dd519 --- /dev/null +++ b/backend/ICAFocus/Get.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE LambdaCase #-} +module Get where + +import qualified Network.HTTP.Client as H +import qualified Network.HTTP.Client.TLS as H +import Network.HTTP.Types.Status +import Control.Monad.Except +import qualified Database.PostgreSQL.Typed as PG +import Data.Aeson +import Data.Text +import Text.Read +import Data.Int (Int32) +import Data.ByteString.Lazy +import Data.Bifunctor + +import ICAFocus + +import DBConfig + +PG.useTPGDatabase myPGDatabase + +data GetError + = ICAFocusAPIError (H.Response ByteString) + | DecodeError String + | ProductNotCached + | OutdatedEntry + | UniqueKeyViolation -- ^ should never happen + +instance Show GetError where + show (ICAFocusAPIError r) = "ICAFocusAPIError { responseStatus = " ++ show (H.responseStatus r) ++ " }" + show (DecodeError e) = "DecodeError: " ++ e + show ProductNotCached = "ProductNotCached" + show OutdatedEntry = "OutdatedEntry" + show UniqueKeyViolation = "UniqueKeyViolation (should not be possible (what is postgres bro doing))" + +type GetM = ExceptT GetError IO + +loadProductData :: ProductID -> GetM ICAFocusData +loadProductData productId = do + req <- H.parseRequest $ apiEndpoint productId + resp <- liftIO $ H.httpLbs req =<< H.newManager H.tlsManagerSettings + + unless (H.responseStatus resp == status200) (throwError $ ICAFocusAPIError resp) + + liftEither . first DecodeError . eitherDecode $ H.responseBody resp + +-- Fetches the image of a product, returning the product with the image data +finalizeProductImage :: ICAFocusData -> GetM ICAFocusProduct +finalizeProductImage x = do + req <- H.parseRequest $ (getLink . image) x + resp <- liftIO $ H.httpLbs req =<< H.newManager H.tlsManagerSettings + + unless (H.responseStatus resp == status200) (throwError $ ICAFocusAPIError resp) + pure $ const (ImageData (H.responseBody resp)) <$> x + +loadProduct :: ProductID -> GetM ICAFocusProduct +loadProduct = loadProductData >=> finalizeProductImage + +fetchProduct :: PG.PGConnection -> ProductID -> GetM ICAFocusProduct +fetchProduct pg productId = do + datas <- liftIO $ PG.pgQuery pg [PG.pgSQL| + SELECT name, costPerKg, costPerUnit, image, fetchedAt + '24h' < now() + FROM ingredient_data + WHERE productId = ${productId}|] + + case datas of + [] -> throwError ProductNotCached + _ : _ : _ -> throwError UniqueKeyViolation + [(_, _, _, _, Just True)] -> throwError OutdatedEntry + [(name, costPerKg, costPerUnit, image, _)] -> + pure $ ICAFocusItem name costPerKg costPerUnit (ImageData image) + +cacheProduct :: PG.PGConnection -> ProductID -> ICAFocusProduct -> IO () +cacheProduct pg productId product = + void $ PG.pgExecute pg [PG.pgSQL| + INSERT INTO ingredient_data (productId, name, costPerKg, costPerUnit, image, fetchedAt) + VALUES (${productId}, ${name product}, ${costPerKg product}, ${costPerUnit product}, ${getData (image product)}, now()) + ON CONFLICT (productId) + DO UPDATE SET name = excluded.name, costPerKg = excluded.costPerKg, costPerUnit = excluded.costPerUnit, image = excluded.image, fetchedAt = excluded.fetchedAt|] + +getProduct :: PG.PGConnection -> ProductID -> GetM ICAFocusProduct +getProduct pg productId = do + liftIO (runExceptT (fetchProduct pg productId)) >>= \case + Right product -> pure product + Left ProductNotCached -> refresh + Left OutdatedEntry -> refresh + Left e -> throwError e + where + refresh = do + product <- loadProduct productId + liftIO $ cacheProduct pg productId product + pure product diff --git a/backend/Misc.hs b/backend/Misc.hs new file mode 100644 index 0000000..50d9162 --- /dev/null +++ b/backend/Misc.hs @@ -0,0 +1,12 @@ +module Misc where + +import Data.Aeson +import Data.Aeson.Types + +unpackEither :: MonadFail m => Either String a -> m a +unpackEither (Left s) = fail s +unpackEither (Right a) = pure a + +(.::) :: FromJSON a => Parser Object -> Key -> Parser a +v .:: k = v >>= (.: k) + diff --git a/schema.sql b/schema.sql index 6a7feba..05017d4 100644 --- a/schema.sql +++ b/schema.sql @@ -1,11 +1,8 @@ -CREATE TABLE IF NOT EXISTS ingredient - ( product_id INTEGER NOT NULL PRIMARY KEY -- https://handlaprivatkund.ica.se/stores/1004247/api/v4/products/bop?retailerProductId=... - ); - CREATE TABLE IF NOT EXISTS ingredient_data - ( product_id INTEGER REFERENCES ingredient(product_id) + ( productId INTEGER NOT NULL PRIMARY KEY -- https://handlaprivatkund.ica.se/stores/1004247/api/v4/products/bop?retailerProductId=... , name TEXT NOT NULL - , cost_per_kg REAL NOT NULL - , cost_per_unit REAL NOT NULL + , costPerKg REAL NOT NULL + , costPerUnit REAL NOT NULL , image BYTEA NOT NULL + , fetchedAt TIMESTAMP NOT NULL );