diff --git a/app/Main.hs b/app/Main.hs index 4f2f681..3ee28a5 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -10,14 +10,18 @@ module Main (main) where +import Control.Concurrent (forkIO) +import Control.Monad (forM, forM_) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except (ExceptT (..), catchE, runExceptT) +import Data.Bifunctor (Bifunctor (..)) import Data.Proxy (Proxy (..)) import Data.Text (Text) -import Data.Time (Day, addDays, toGregorian) +import Data.Time (Day, LocalTime (..), TimeOfDay (..), ZonedTime (..), addDays, toGregorian) import GHC.Generics (Generic) import Network.HTTP.Media ((//), (/:)) import Network.HTTP.Types (Status (..), mkStatus, status200) +import Network.Wai (Application, Request (..), Response, responseFile, responseLBS) import Servant ( Accept (..) , Capture @@ -48,25 +52,21 @@ import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as Text import qualified Data.Text.Encoding as Encoding import qualified Database.PostgreSQL.Opium as Opium -import Network.Wai (Application, Request (..), Response, responseFile, responseLBS) import qualified Network.Wai.Handler.Warp as Warp import qualified Text.Blaze.Html5 as H import qualified Text.Blaze.Html5.Attributes as A import Envy (type (=@!), type (=@@), type (?)) import Yore.DB (DB, DayFile (..)) +import Yore.Download (downloadInto) import Yore.Error (Error (..)) import Yore.Schedule (schedule) +import Yore.Scrape (Issue (..), getIssuesByDay) import Yore.Time (addYears, getCurrentDay, getSecondsUntilMidnight) -import Control.Concurrent (forkIO) -import Control.Monad (forM, forM_) -import Data.Bifunctor (Bifunctor (..)) import qualified Envy import qualified Yore.DB as DB -import Yore.Download (downloadInto) import qualified Yore.Log as Log -import Yore.Scrape (Issue (..), getIssuesByDay) newtype ConnectionString = ConnectionString String deriving (Show) @@ -109,7 +109,7 @@ main = do runServer cfg db runIndexer :: Config -> DB -> IO () -runIndexer cfg db = schedule (const True) $ do +runIndexer cfg db = schedule shouldRunAt $ do _ <- runExceptT $ catchE @@ -121,6 +121,10 @@ runIndexer cfg db = schedule (const True) $ do ) (Log.error . show) pure () + where + shouldRunAt zt = case localTimeOfDay $ zonedTimeToLocalTime zt of + TimeOfDay 3 0 _ -> True + _ -> False runServer :: Config -> DB -> IO () runServer cfg db = @@ -198,13 +202,13 @@ server cfg db = rootR :<|> todayR :<|> apiTodayR todayR issue = do dateThen <- ExceptT get100YearsAgo - count <- DB.withConn db $ DB.lift . DB.getNumberOfIssues dateThen - dayFile <- DB.withConn db $ DB.lift . DB.getDayFileByIssue dateThen issue + count <- DB.withConn db $ DB.getNumberOfIssues dateThen + dayFile <- DB.withConn db $ DB.getDayFileByIssue dateThen issue pure $ RootModel dateThen dayFile issue count apiTodayR issue = handlerToRaw $ do dateThen <- ExceptT get100YearsAgo - dayFile <- DB.withConn db $ DB.lift . DB.getDayFileByIssue dateThen issue + dayFile <- DB.withConn db $ DB.getDayFileByIssue dateThen issue let fullPath = cfg.yoreDownloadDir dayFile.relative_path secondsUntilMidnight <- liftIO getSecondsUntilMidnight pure $ @@ -267,7 +271,7 @@ indexDay :: Config -> Day -> Opium.Connection -> ExceptT Error IO () indexDay cfg dayThen conn = do -- Transaction-level lock released automatically after transaction DB.lift $ Opium.execute_ "SELECT pg_advisory_xact_lock(42);" conn - mbDi <- DB.lift $ DB.readDayIndex dayThen conn + mbDi <- DB.readDayIndex dayThen conn case mbDi of Just _ -> Log.info $ printf "index for %s already exists." (show dayThen) @@ -279,7 +283,7 @@ indexDay cfg dayThen conn = do path <- liftIO $ downloadInto cfg.yoreDownloadDir issue.url pure (issue.label, path) Log.info "creating DB entries" - dayIndex <- DB.lift $ DB.createDayIndex dayThen conn + dayIndex <- DB.createDayIndex dayThen conn forM_ paths $ \(text, url) -> - DB.lift $ DB.createDayFile dayIndex.day_index_id text url conn + DB.createDayFile dayIndex.day_index_id text url conn Log.info "done." diff --git a/src/Yore/DB.hs b/src/Yore/DB.hs index a20a9a0..4363219 100644 --- a/src/Yore/DB.hs +++ b/src/Yore/DB.hs @@ -98,44 +98,47 @@ newtype CountResult = CountResult } deriving (Show, Generic, Opium.FromRow) -createDayIndex :: Day -> Opium.Connection -> IO (Either Opium.Error DayIndex) +createDayIndex :: Day -> Opium.Connection -> ExceptT Error IO DayIndex createDayIndex date = ex runIdentity . Opium.fetch "INSERT INTO yore.day_index (day) VALUES ($1) RETURNING *" (Identity date) -createDayFile :: Int -> Text -> FilePath -> Opium.Connection -> IO (Either Opium.Error ()) +createDayFile :: Int -> Text -> FilePath -> Opium.Connection -> ExceptT Error IO () createDayFile dayId label path = - Opium.execute - "INSERT INTO yore.day_file (day_index_id, label, relative_path) VALUES ($1, $2, $3)" - (dayId, label, path) + lift + . Opium.execute + "INSERT INTO yore.day_file (day_index_id, label, relative_path) VALUES ($1, $2, $3)" + (dayId, label, path) -readDayIndex :: Day -> Opium.Connection -> IO (Either Opium.Error (Maybe DayIndex)) +readDayIndex :: Day -> Opium.Connection -> ExceptT Error IO (Maybe DayIndex) readDayIndex date = - Opium.fetch - "SELECT * FROM yore.day_index WHERE day = $1" - (Identity date) + lift + . Opium.fetch + "SELECT * FROM yore.day_index WHERE day = $1" + (Identity date) -readDayPaths :: Day -> Opium.Connection -> IO (Either Opium.Error [(DayIndex, DayFile)]) +readDayPaths :: Day -> Opium.Connection -> ExceptT Error IO [(DayIndex, DayFile)] readDayPaths date = - Opium.fetch - "SELECT * FROM yore.day_index LEFT JOIN yore.day_file USING (day_index_id) WHERE day = $1" - (Identity date) + lift + . Opium.fetch + "SELECT * FROM yore.day_index LEFT JOIN yore.day_file USING (day_index_id) WHERE day = $1" + (Identity date) -getDayFileByIssue :: Day -> Int -> Opium.Connection -> IO (Either Opium.Error DayFile) +getDayFileByIssue :: Day -> Int -> Opium.Connection -> ExceptT Error IO DayFile getDayFileByIssue date issue = ex runIdentity . Opium.fetch "SELECT yore.day_file.* FROM yore.day_index LEFT JOIN yore.day_file USING (day_index_id) WHERE day = $1 ORDER BY day_file_id LIMIT 1 OFFSET $2" (date, issue) -getNumberOfIssues :: Day -> Opium.Connection -> IO (Either Opium.Error Int) +getNumberOfIssues :: Day -> Opium.Connection -> ExceptT Error IO Int getNumberOfIssues date = ex (count . runIdentity) . Opium.fetch "SELECT count(*) FROM yore.day_index LEFT JOIN yore.day_file USING (day_index_id) WHERE day = $1" (Identity date) -ex :: (a -> b) -> IO (Either e a) -> IO (Either e b) -ex = fmap . fmap +ex :: (a -> b) -> IO (Either Opium.Error a) -> ExceptT Error IO b +ex f = fmap f . lift diff --git a/src/Yore/Index.hs b/src/Yore/Index.hs deleted file mode 100644 index 9bdde37..0000000 --- a/src/Yore/Index.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE OverloadedRecordDot #-} - -module Yore.Index (createEntries) where - -import Control.Exception (Exception, throwIO) -import Control.Monad (forM_) -import Data.Text (Text) -import Data.Time (Day) - -import qualified Database.PostgreSQL.Opium as Opium - -import qualified Yore.DB as DB - -createEntries :: Day -> [(Text, FilePath)] -> Opium.Connection -> IO () -createEntries date urls conn = do - dayIndex <- confidently $ DB.createDayIndex date conn - forM_ urls $ \(text, url) -> - confidently $ DB.createDayFile dayIndex.day_index_id text url conn - -confidently :: (Exception e) => IO (Either e a) -> IO a -confidently action = action >>= either throwIO pure diff --git a/src/Yore/Repl.hs b/src/Yore/Repl.hs deleted file mode 100644 index 8fb126c..0000000 --- a/src/Yore/Repl.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedRecordDot #-} -{-# LANGUAGE OverloadedStrings #-} - -module Yore.Repl (connect, exec, getToday, indexDay, addYears) where - -import Control.Exception (bracket, throwIO) -import Control.Monad (forM) -import Data.Time (Day, getZonedTime, localDay, zonedTimeToLocalTime) -import Text.Printf (printf) - -import qualified Database.PostgreSQL.Opium as Opium - -import Yore.DB (DayIndex) -import Yore.Download (downloadInto) -import Yore.Index (createEntries) -import Yore.Scrape (Issue (..), getIssuesByDay) -import Yore.Time (addYears) - -import qualified Yore.DB as DB - -connect :: IO Opium.Connection -connect = - Opium.connect "host=localhost port=5433 user=yore-test" >>= \case - Left e -> error $ show e - Right c -> pure c - -exec :: (Opium.Connection -> IO a) -> IO a -exec = bracket connect Opium.close - -getToday :: IO [Issue] -getToday = do - now <- getZonedTime - print now - let currentDay = localDay $ zonedTimeToLocalTime now - case addYears (-100) currentDay of - Right then_ -> - getIssuesByDay then_ - Left _ -> - pure [] - -indexDay :: Day -> IO () -indexDay date = exec $ \conn -> do - either throwIO pure =<< Opium.execute_ "SELECT pg_advisory_lock(42);" conn - printf "Checking whether %s already exists...\n" (show date) - mbDi <- either throwIO pure =<< DB.readDayIndex date conn - case mbDi of - Just (_ :: DayIndex) -> - putStrLn "Nothing to do." - Nothing -> do - putStrLn "Retrieving URLs..." - issues <- getIssuesByDay date - paths <- forM issues $ \issue -> do - printf "Downloading %s...\n" issue.url - path <- downloadInto "./download" issue.url - pure (issue.label, path) - putStrLn "Creating DB entries..." - createEntries date paths conn - putStrLn "Done." diff --git a/src/Yore/Schedule.hs b/src/Yore/Schedule.hs index db4fe89..a812c37 100644 --- a/src/Yore/Schedule.hs +++ b/src/Yore/Schedule.hs @@ -1,18 +1,19 @@ module Yore.Schedule (schedule) where +import Control.Concurrent (forkIO, threadDelay) import Control.Monad (when) -import Data.Time (ZonedTime, getZonedTime, secondsToNominalDiffTime, nominalDiffTimeToSeconds) -import Control.Concurrent (threadDelay, forkIO) +import Data.Functor (($>)) +import Data.Time (ZonedTime, getZonedTime, nominalDiffTimeToSeconds, secondsToNominalDiffTime) import Data.Time.Clock.POSIX (getPOSIXTime) -schedule :: (ZonedTime -> Bool) -> IO () -> IO () -schedule shouldRunAt f = everyMinute $ \now -> when (shouldRunAt now) f +schedule :: (ZonedTime -> Bool) -> IO a -> IO () +schedule shouldRunAt f = everyMinute $ \now -> when (shouldRunAt now) (f $> ()) everyMinute :: (ZonedTime -> IO ()) -> IO () everyMinute f = do -- Use POSIX time to avoid having to handle leap seconds now <- getPOSIXTime - let posixSeconds :: Int + let posixSeconds :: Int posixSeconds = floor $ nominalDiffTimeToSeconds now lastFullMinute = secondsToNominalDiffTime $ fromIntegral $ posixSeconds - posixSeconds `mod` 60 secondsSinceLastFullMinute = now - lastFullMinute diff --git a/yore.cabal b/yore.cabal index d04a64a..26c5c4a 100644 --- a/yore.cabal +++ b/yore.cabal @@ -37,9 +37,7 @@ library , Yore.DB , Yore.Download , Yore.Error - , Yore.Index , Yore.Log - , Yore.Repl , Yore.Schedule , Yore.Scrape , Yore.Time