matabas/backend/ICAFocus/Get.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE LambdaCase #-}
module ICAFocus.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