97 lines
3.5 KiB
Haskell
97 lines
3.5 KiB
Haskell
|
{-# 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
|