Factor ICAFocus into modules, change schema to include fetchedAt

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

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

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)
+

buildScripts/setupEnv.sh

@@ -1,3 +1,9 @@
+cd "$(git rev-parse --show-toplevel)"
+
+# Check for lock
+[ -f matabas-db/dev-lock ]
+IS_OWNER=$? # non-zero is owner
+
 set -e
 
 export PGPORT=2137
@@ -8,43 +14,58 @@ log() {
     printf "\e[1m\e[38;5;87m==>\e[0m\e[1m %s%s\e[0m\n" "$1" "${2:-.}"
 }
 
+# Only trapped if owner
 exitHook() {
+  cd "$(git rev-parse --show-toplevel)"
   log "Stoppar brevekorren"
   pg_ctl stop --pgdata=./matabas-db
+  rm -f matabas-db/dev-lock
 }
 
-log "Letar efter existerande brevekorresmapp"
-[ -d ./matabas-db ] || {
-  log "Finns ej, skapar brevekorresmapp (./matabas-db)"
-  pg_ctl initdb --pgdata=./matabas-db -o "--username=$PGUSER"
+setupDb() {
+  log "Letar efter existerande brevekorresmapp"
+  [ -d ./matabas-db ] || {
+    log "Finns ej, skapar brevekorresmapp (./matabas-db)"
+    pg_ctl initdb --pgdata=./matabas-db -o "--username=$PGUSER"
+  }
+
+  [ -f matabas-db/matabas.log ] && {
+    log "Flyttar journalen från senaste sittningen till journalarkivet (./matabas-db/matabas.log.old)"
+    cat matabas-db/matabas.log >> matabas-db/matabas.log.old
+    rm -f matabas-db/matabas.log
+  }
+
+  log "Startar brevekorren"
+  pg_ctl start --pgdata=./matabas-db --log=./matabas-db/matabas.log --options="-p $PGPORT -k /tmp"
+  log "Låser databasen"
+  :> matabas-db/dev-lock
+  trap exitHook EXIT
+
+  log "Skapar matabas"
+  createdb -h localhost -p "$PGPORT" matabas 2>>./matabas-db/matabas.log || log "Matabasen finns, skriver ej över"
+
+  log "Ställer in schema.sql"
+  psql -h localhost -p "$PGPORT" "$PBDATABASE" < schema.sql
 }
 
-[ -f matabas-db/matabas.log ] && {
-  log "Flyttar journalen från senaste sittningen till journalarkivet (./matabas-db/matabas.log.old)"
-  cat matabas-db/matabas.log >> matabas-db/matabas.log.old
-  rm -f matabas-db/matabas.log
-}
-
-log "Startar brevekorren"
-pg_ctl start --pgdata=./matabas-db --log=./matabas-db/matabas.log --options="-p $PGPORT -k /tmp"
-trap exitHook EXIT
-
-log "Skapar matabas"
-createdb -h localhost -p "$PGPORT" matabas 2>>./matabas-db/matabas.log || log "Matabasen finns, skriver ej över"
-
-log "Ställer in schema.sql"
-psql -h localhost -p "$PGPORT" "$PBDATABASE" < schema.sql
-
 P="$PWD"
 clean() {
-    log "Rensar byggnad"
-    rm -rf artifacts
+  log "Rensar byggnad"
+  rm -rf artifacts
 }
 
 build() {
-    source "$P/buildScripts/build.sh"
+  source "$P/buildScripts/build.sh"
 }
 
+if [ "$IS_OWNER" -ne 0 ] ; then
+  setupDb
+else
+  log "Startar som icke-ägare, startar ej databasen"
+fi
+
 log "Redo" "!"
 
 set +e
+
+cd - >/dev/null 2>&1

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
   );