Remove bounds for base

berlin-scraper/app/Main.hs

@@ -11,10 +11,12 @@ import Control.Exception
 import Control.Lens (view, (&), (.~))
 import Control.Monad (when)
 import Control.Monad.IO.Class
+import Control.Monad.Trans.Class (lift)
 import Data.Aeson hiding (Options)
 import Data.Aeson qualified as Aeson
 import Data.ByteString.Lazy qualified as LBS
 import Data.Maybe (fromJust, fromMaybe, listToMaybe)
+import Data.String (IsString (..))
 import Data.Text qualified as Text
 import Data.Text.Encoding qualified as Text
 import Database.SQLite.Simple
@@ -31,7 +33,6 @@ import Telegram.Bot.API
 import Telegram.Bot.Simple
 import Telegram.Bot.Simple.Debug
 import Text.HTML.Scalpel
-import Data.String (IsString(..))
 
 main :: IO ()
 main = withOpenSSL $ do
@@ -50,7 +51,7 @@ main = withOpenSSL $ do
     liftIO $
       startBot (traceBotDefault $ botApp env) clientEnv >>= \case
         Left err -> do
-          info env "main" $ "Bot failed with: " <> fromString (show err)
+          runKatipContextT env.logEnv () "main" $ info $ "Bot failed with: " <> fromString (show err)
           exitFailure
         _ -> pure ()
 
@@ -92,8 +93,11 @@ data Env = Env
 
 -- * Parsing
 
-queryIBW :: Wreq.Options -> IO IBWResponse
+queryIBW :: Wreq.Options -> WBS -> IO IBWResponse
-queryIBW wreqOpts = do
+queryIBW wreqOpts wbs = do
+  let wbsParam = case wbs of
+        WBS -> "all"
+        NoWBS -> "0"
   let reqBody =
         [ partText "q" "wf-save-srch",
           partText "save" "false",
@@ -112,21 +116,21 @@ queryIBW wreqOpts = do
           partText "etagen_dg" "false",
           partText "balkon_loggia_terrasse" "false",
           partText "garten" "false",
-          partText "wbs" "0",
+          partText "wbs" wbsParam,
           partText "barrierefrei" "false",
           partText "gaeste_wc" "false",
           partText "aufzug" "false",
           partText "stellplatz" "false",
           partText "keller" "false",
           partText "badewanne" "false",
-          partText "dusche" "false",
+          partText "dusche" "false"
-          partText "bez[]" "01_00",
+          -- , partText "bez[]" "01_00",
-          partText "bez[]" "02_00",
+          -- partText "bez[]" "02_00",
-          partText "bez[]" "04_00",
+          -- partText "bez[]" "04_00",
-          partText "bez[]" "07_00",
+          -- partText "bez[]" "07_00",
-          partText "bez[]" "08_00",
+          -- partText "bez[]" "08_00",
-          partText "bez[]" "09_00",
+          -- partText "bez[]" "09_00",
-          partText "bez[]" "11_00"
+          -- partText "bez[]" "11_00"
         ]
   let link = "https://inberlinwohnen.de/wp-content/themes/ibw/skript/wohnungsfinder.php"
   resBS <- view responseBody <$> postWith wreqOpts link reqBody
@@ -164,23 +168,30 @@ readEuropeanNumber x = do
 
 -- * SQLite
 
-insertOffer :: Connection -> Offer -> IO ()
+data WBS = WBS | NoWBS
-insertOffer conn =
-  execute conn "INSERT INTO offers (id, title, address, rooms, area, availableFrom, link) VALUES (?, ?, ?, ?, ?, ?, ?)"
 
-getOffer :: Connection -> Text -> IO (Maybe Offer)
+tableName :: WBS -> Text
-getOffer conn offerId =
+tableName WBS = "offers"
-  listToMaybe <$> query conn "SELECT * from offers where id = ?" (Only offerId)
+tableName NoWBS = "offers_without_wbs"
+
+insertOffer :: Connection -> WBS -> Offer -> IO ()
+insertOffer conn wbs =
+  execute conn $ "INSERT INTO " <> Query (tableName wbs) <> " (id, title, address, rooms, area, availableFrom, link) VALUES (?, ?, ?, ?, ?, ?, ?)"
+
+getOffer :: Connection -> WBS -> Text -> IO (Maybe Offer)
+getOffer conn wbs offerId =
+  listToMaybe <$> query conn ("SELECT * from " <> Query (tableName wbs) <> " where id = ?") (Only offerId)
 
 createTable :: Connection -> IO ()
-createTable conn =
+createTable conn = do
   execute_ conn "CREATE TABLE IF NOT EXISTS offers (id TEXT PRIMARY KEY, title TEXT, address TEXT, rooms REAL, area REAL, availableFrom TEXT, link TEXT)"
+  execute_ conn "CREATE TABLE IF NOT EXISTS offers_without_wbs (id TEXT PRIMARY KEY, title TEXT, address TEXT, rooms REAL, area REAL, availableFrom TEXT, link TEXT)"
 
-saveOffer :: Connection -> Offer -> IO Bool
+saveOffer :: Connection -> WBS -> Offer -> IO Bool
-saveOffer conn offer = do
+saveOffer conn wbs offer = do
-  getOffer conn offer.id_ >>= \case
+  getOffer conn wbs offer.id_ >>= \case
     Nothing -> do
-      insertOffer conn offer
+      insertOffer conn wbs offer
       pure True
     _ -> pure False
 
@@ -211,36 +222,48 @@ action update _ = do
 handler :: Env -> Action -> Model -> Eff Action Model
 handler env (StartChat chat) model =
   model <# do
-    info env "telegram.handler" $ "Chat started! " <> fromString (ppAsJSON chat)
+    runKatipContextT env.logEnv () "telegram.handler" $ info $ "Chat started! " <> fromString (ppAsJSON chat)
 
 scrapeJob :: Env -> BotJob Model Action
 scrapeJob env =
   BotJob
     { botJobSchedule = "* * * * *",
-      botJobTask = scrapeJobTask env
+      botJobTask = \m -> do
+        scrapeJobTask env m WBS
+        scrapeJobTask env m NoWBS
     }
 
-scrapeJobTask :: Env -> Model -> Eff Action Model
+wbsText :: WBS -> Text
-scrapeJobTask env m =
+wbsText WBS = "WBS"
-  m <# do
+wbsText NoWBS = "NoWBS"
-    info env "scrapeJobTask" "Starting scrape job"
+
-    res <- liftIO $ queryIBW env.wreqOpts
+scrapeJobTask :: Env -> Model -> WBS -> Eff Action Model
-    let offers = fromJust $ scrapeStringLike res.searchresults scrapeOffers
+scrapeJobTask env m wbs =
-    info env "scrapeJobTask" "Fetched offers"
+  m
-    mapM_
+    <# runKatipContextT
-      ( \offer -> do
+      env.logEnv
-          isNewOffer <- liftIO $ saveOffer env.dbConn offer
+      (sl "wbs" (wbsText wbs))
-          when isNewOffer $ do
+      "scrapeJobTask"
-            info env "scrapeJobTask" "Found a new offer"
+      ( do
-            notify env offer
+          info "Starting scrape job"
+          res <- liftIO $ queryIBW env.wreqOpts wbs
+          let offers = fromJust $ scrapeStringLike res.searchresults scrapeOffers
+          info "Fetched offers"
+          mapM_
+            ( \offer -> do
+                isNewOffer <- liftIO $ saveOffer env.dbConn wbs offer
+                when isNewOffer $ do
+                  info "Found a new offer"
+                  katipAddNamespace "notify" $ notify wbs offer
+            )
+            offers
       )
-      offers
 
-info :: MonadIO m => Env -> Namespace -> LogStr -> m ()
+info :: (Katip m) => LogStr -> m ()
-info env ns l = liftIO $ runKatipT env.logEnv $ logMsg ns InfoS l
+info = logMsg mempty InfoS
 
-notify :: Env -> Offer -> BotM ()
+notify :: WBS -> Offer -> KatipContextT BotM ()
-notify env offer = do
+notify wbs offer = do
   let offerTitle = "<b><u>" <> offer.title <> "</u></b>"
       offerAddress = "<b>Address:</b> " <> fromMaybe "N/A" offer.address
       offerRooms = "<b>Rooms:</b> " <> maybe "N/A" (Text.pack . show) offer.rooms
@@ -248,19 +271,20 @@ notify env offer = do
       offerLink = "<a href=\"https://inberlinwohnen.de" <> offer.link <> "\" >Apply Here</a>"
       offerBody = offerAddress <> "\n" <> offerRooms <> "\n" <> offerArea <> "\n" <> offerLink
       offerText = offerTitle <> "\n\n" <> offerBody
-      sendMsgReq1 = (defSendMessage (SomeChatId $ ChatId 952512153) offerText) {sendMessageParseMode = Just HTML}
+      -- sendMsgReq1 = (defSendMessage (SomeChatId $ ChatId 952512153) offerText) {sendMessageParseMode = Just HTML}
-      sendMsgReq2 = (defSendMessage (SomeChatId $ ChatId 116981707) offerText) {sendMessageParseMode = Just HTML}
+      -- sendMsgReq2 = (defSendMessage (SomeChatId $ ChatId 116981707) offerText) {sendMessageParseMode = Just HTML}
-  res1 <- runTG sendMsgReq1
+      sendMsgReq3 = (defSendMessage (SomeChatId $ ChatId 5781922807) offerText) {sendMessageParseMode = Just HTML}
-  liftIO $
+      sendMsgReq4 = (defSendMessage (SomeChatId $ ChatId 7008484163) offerText) {sendMessageParseMode = Just HTML}
-    if res1.responseOk
+      msgReq = case wbs of
-      then info env "notify" "Notified successfully"
+        WBS -> sendMsgReq3
-      else do
+        NoWBS -> sendMsgReq4
-        info env "notify" $ "Failed to notify the offer: " <> fromString (show offer)
+  sendMessageWithLogs offer msgReq
-        info env "notify" $ "Response: " <> fromString (Text.unpack $ Text.decodeUtf8 (LBS.toStrict $ Aeson.encode res1))
+
-  res2 <- runTG sendMsgReq2
+sendMessageWithLogs :: Offer -> SendMessageRequest -> KatipContextT BotM ()
-  liftIO $
+sendMessageWithLogs offer sendMsgReq = do
-    if res2.responseOk
+  res <- lift $ runTG sendMsgReq
-      then info env "notify" "Notified successfully"
+  if res.responseOk
-      else do
+    then info "Notified successfully"
-        info env "notify" $ "Failed to notify the offer: " <> fromString (show offer)
+    else do
-        info env "notify" $ "Response: " <> fromString (Text.unpack $ Text.decodeUtf8 (LBS.toStrict $ Aeson.encode res2))
+      info $ "Failed to notify the offer: " <> fromString (show offer)
+      info $ "Response: " <> fromString (Text.unpack $ Text.decodeUtf8 (LBS.toStrict $ Aeson.encode res))

berlin-scraper/berlin-scraper.cabal

@@ -15,7 +15,7 @@ common warnings
 executable berlin-scraper
     import:           warnings
     main-is:          Main.hs
-    build-depends:    base ^>=4.17.1.0
+    build-depends:    base
                     , scalpel
                     , aeson
                     , wreq
@@ -29,6 +29,7 @@ executable berlin-scraper
                     , http-client-openssl
                     , bytestring
                     , katip
+                    , transformers
     hs-source-dirs:   app
     default-language: GHC2021
     ghc-options:    -threaded -with-rtsopts=-N

berlin-scraper/default.nix

@@ -1,6 +1,7 @@
 { mkDerivation, aeson, base, bytestring, http-client-openssl, katip
 , lens, lib, optparse-generic, scalpel, servant-client
-, sqlite-simple, telegram-bot-api, telegram-bot-simple, text, wreq
+, sqlite-simple, telegram-bot-api, telegram-bot-simple, text
+, transformers, wreq
 }:
 mkDerivation {
   pname = "berlin-scraper";
@@ -11,7 +12,7 @@ mkDerivation {
   executableHaskellDepends = [
     aeson base bytestring http-client-openssl katip lens
     optparse-generic scalpel servant-client sqlite-simple
-    telegram-bot-api telegram-bot-simple text wreq
+    telegram-bot-api telegram-bot-simple text transformers wreq
   ];
   license = lib.licenses.agpl3Plus;
   mainProgram = "berlin-scraper";