made code less legible

backend/ICAFocus.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
-
+{- TODO: refactor code into multiple modules -}
 module ICAFocus where
 
 import qualified Network.HTTP.Client as H
@@ -11,7 +11,7 @@ import Data.Aeson.KeyMap
 import Data.Text
 import Text.Read
 import Data.ByteString.Lazy
-import GHC.Generics
+import Control.Monad.Except
 
 newtype ImageLink = ImageLink { getLink :: String }
   deriving (Show)
@@ -31,52 +31,46 @@ data ICAFocusItem a = ICAFocusItem
 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") :: Parser Object
+    productMap <- v .: "entities" .:: "product"
     product <- case elems productMap of
       [Object x] -> pure x
       [] -> fail "No products"
       _ -> fail "Too many products"
 
-    name <- product .: "name"
-    pricePerUnitStr <- product .: "price" >>= (.: "current") >>= (.: "amount") :: Parser String
-    pricePerUnit <- case readEither pricePerUnitStr of
-      Right x -> pure x
-      Left e -> fail e
-    pricePerKgStr <- product .: "price" >>= (.: "unit") >>= (.: "current") >>= (.: "amount") :: Parser String
-    pricePerKg <- case readEither pricePerKgStr of
-      Right x -> pure x
-      Left e -> fail e
-    imageLink <- product .: "image" >>= (.: "src")
+    ICAFocusItem
+      <$> product .: "name"
+      <*> (ImageLink <$> product .: "image" .:: "src")
+      <*> (unpackEither . readEither =<< product .: "price" .:: "unit" .:: "current" .:: "amount")
+      <*> (unpackEither . readEither =<< product .: "price"            .:: "current" .:: "amount")
 
-    pure $ ICAFocusItem name (ImageLink imageLink) pricePerUnit pricePerKg
-
-loadProductData :: Int -> IO (Either String ICAFocusData)
+loadProductData :: Int -> ExceptT String IO ICAFocusData
 loadProductData product_id = do
-  httpman <- H.newManager H.tlsManagerSettings
-  req <- H.parseRequest $ "https://handlaprivatkund.ica.se/stores/1004247/api/v4/products/bop?retailerProductId=" ++ show product_id
-  resp <- H.httpLbs req httpman
+  req <- H.parseRequest $ apiEndpoint product_id
+  resp <- liftIO $ H.httpLbs req =<< H.newManager H.tlsManagerSettings
 
-  if H.responseStatus resp == status200
-    then pure $ eitherDecode $ H.responseBody resp
-    else pure $ Left "Error status code"
+  unless (H.responseStatus resp == status200) (throwError "Error status code")
 
-loadProductImage :: ICAFocusData -> IO (Either String ICAFocusProduct)
+  liftEither . eitherDecode $ H.responseBody resp
+
+loadProductImage :: ICAFocusData -> ExceptT String IO ICAFocusProduct
 loadProductImage x = do
-  httpman <- H.newManager H.tlsManagerSettings
   req <- H.parseRequest $ (getLink . image) x
-  resp <- H.httpLbs req httpman
+  resp <- liftIO $ H.httpLbs req =<< H.newManager H.tlsManagerSettings
 
-  if H.responseStatus resp == status200
-    then do
-      let imageData = H.responseBody resp
-      pure $ Right $ (const (ImageData imageData)) <$> x
-    else pure $ Left "Error status code"
+  unless (H.responseStatus resp == status200) (throwError "Error status code")
+  pure $ const (ImageData (H.responseBody resp)) <$> x
 
-loadProduct :: Int -> IO (Either String ICAFocusProduct)
-loadProduct product_id = do
-  prod <- loadProductData product_id
-  case prod of
-    Right x -> loadProductImage x
-    Left e -> pure $ Left e
+loadProduct :: Int -> ExceptT String IO ICAFocusProduct
+loadProduct = loadProductData >=> loadProductImage