From 8d3a2c05d0602ebecb7cad28c92ae3736d7ab25c Mon Sep 17 00:00:00 2001 From: towards-a-new-leftypol Date: Sat, 7 Oct 2023 01:12:30 -0400 Subject: [PATCH] Creating boards if they don't exist --- chan-delorean.cabal | 2 ++ sql/initialize.sql | 6 ++++-- src/Backfill.hs | 40 +++++++++++++++++++++++++++++++++++----- src/BoardsType.hs | 16 ++++++++++++++++ src/DataClient.hs | 40 +++++++++++++++++++++++++++------------- src/SitesType.hs | 15 +++++++++++++++ 6 files changed, 99 insertions(+), 20 deletions(-) create mode 100644 src/BoardsType.hs create mode 100644 src/SitesType.hs diff --git a/chan-delorean.cabal b/chan-delorean.cabal index 12886de..8a31bea 100644 --- a/chan-delorean.cabal +++ b/chan-delorean.cabal @@ -69,6 +69,8 @@ executable chan-delorean JSONParsing DataClient Types + SitesType + BoardsType -- LANGUAGE extensions used by modules in this package. -- other-extensions: diff --git a/sql/initialize.sql b/sql/initialize.sql index 7a4dc6d..c1e8f4c 100644 --- a/sql/initialize.sql +++ b/sql/initialize.sql @@ -39,7 +39,7 @@ CREATE TABLE IF NOT EXISTS sites CREATE TABLE IF NOT EXISTS boards ( board_id serial primary key - , name text NOT NULL + , name text , pathpart text NOT NULL -- if it's /a/ then the pathpart is a , site_id int NOT NULL , CONSTRAINT site_fk FOREIGN KEY (site_id) REFERENCES sites (site_id) ON DELETE CASCADE @@ -117,7 +117,8 @@ GRANT SELECT ON boards TO chan_archive_anon; GRANT SELECT ON threads TO chan_archive_anon; GRANT SELECT ON posts TO chan_archive_anon; GRANT SELECT ON attachments TO chan_archive_anon; -GRANT usage, select ON SEQUENCE sites_site_id_seq TO chan_archive_anon; +-- GRANT usage, select ON SEQUENCE sites_site_id_seq TO chan_archive_anon; +-- GRANT usage, select ON SEQUENCE boards_board_id_seq TO chan_archive_anon; GRANT chan_archive_anon TO admin; CREATE ROLE chan_archiver noinherit login password 'test_password'; @@ -130,6 +131,7 @@ GRANT ALL ON posts TO chan_archiver; GRANT ALL ON attachments TO chan_archiver; GRANT EXECUTE ON FUNCTION update_post_body_search_index TO chan_archiver; GRANT usage, select ON SEQUENCE sites_site_id_seq TO chan_archiver; +GRANT usage, select ON SEQUENCE boards_board_id_seq TO chan_archiver; GRANT chan_archiver TO admin; COMMIT; diff --git a/src/Backfill.hs b/src/Backfill.hs index 89b5f5b..ea3086d 100644 --- a/src/Backfill.hs +++ b/src/Backfill.hs @@ -12,10 +12,13 @@ import System.Console.CmdArgs import System.Directory (listDirectory, doesFileExist) import System.FilePath (()) import Data.List (find) +import qualified Data.Set as Set import JSONParsing import Types import qualified DataClient as Client +import qualified SitesType as Sites +import qualified BoardsType as Boards data SettingsCLI = SettingsCLI { jsonFile :: FilePath @@ -43,10 +46,10 @@ ensureSiteExists settings = do case sitesResult of Right siteList -> - case find (\site -> Client.name site == site_name settings) siteList of + case find (\site -> Sites.name site == site_name settings) siteList of Just site -> do putStrLn $ site_name settings ++ " already exists!" - return $ Client.site_id site + return $ Sites.site_id site Nothing -> do putStrLn $ site_name settings ++ " does not exist. Creating..." postResult <- Client.postSite settings @@ -54,7 +57,7 @@ ensureSiteExists settings = do case postResult of Right (site:_) -> do putStrLn $ "Successfully created " ++ site_name settings ++ ". " ++ show site - return $ Client.site_id site + return $ Sites.site_id site Right [] -> do putStrLn $ "Did not get new site id back from postgrest" exitFailure @@ -68,6 +71,29 @@ ensureSiteExists settings = do exitFailure +createArchivesForNewBoards :: JSONSettings -> [ String ] -> [ String ] -> Int -> IO [ Boards.Board ] +createArchivesForNewBoards settings dirs archived_boards siteid = do + let dirsSet = Set.fromList dirs + let archivedBoardsSet = Set.fromList archived_boards + + -- Find boards that are in dirs but not in archived_boards + let boardsToArchive = dirsSet `Set.difference` archivedBoardsSet + + putStrLn "Creating boards:" + mapM_ putStrLn boardsToArchive + + post_result <- Client.postBoards settings (Set.toList boardsToArchive) siteid + + case post_result of + Left err -> do + putStrLn $ "Error posting boards: " ++ show err + exitFailure + Right boards -> do + putStrLn "Created the following boards:" + mapM_ putStrLn (map Boards.pathpart boards) + return boards + + processBackupDirectory :: JSONSettings -> IO () processBackupDirectory settings = do putStrLn "JSON successfully read!" @@ -76,14 +102,17 @@ processBackupDirectory settings = do dirs <- listCatalogDirectories settings boards_result <- Client.getSiteBoards settings site_id_ putStrLn "Boards fetched!" + case boards_result of Left err -> do putStrLn $ "Error fetching boards: " ++ show err exitFailure Right archived_boards -> do - print archived_boards + let boardnames = map Boards.pathpart archived_boards + created_boards <- createArchivesForNewBoards settings dirs boardnames site_id_ + let boards :: [ Boards.Board ] = archived_boards ++ created_boards + return () - mapM_ putStrLn dirs mapM_ processDir dirs where backupDir :: FilePath @@ -102,6 +131,7 @@ processBackupDirectory settings = do putStrLn $ "Failed to parse the JSON file in directory: " ++ dir ++ ". Error: " ++ errMsg + main :: IO () main = do settingsValue <- cmdArgs settingsCLI diff --git a/src/BoardsType.hs b/src/BoardsType.hs new file mode 100644 index 0000000..420a69a --- /dev/null +++ b/src/BoardsType.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module BoardsType + ( Board (..) ) + where + +import GHC.Generics +import Data.Aeson (FromJSON) + +data Board = Board + { board_id :: Int + , name :: Maybe String + , pathpart :: String + , site_id :: Int + } deriving (Show, Generic, FromJSON) + diff --git a/src/DataClient.hs b/src/DataClient.hs index 3e78edf..9d26637 100644 --- a/src/DataClient.hs +++ b/src/DataClient.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} module DataClient @@ -8,7 +7,7 @@ module DataClient , getAllSites , postSite , post - , SiteResponse(..) + , postBoards ) where import Network.HTTP.Simple @@ -23,21 +22,18 @@ import Data.Aeson , (.=) , object , encode + , Value ) -import GHC.Generics + import qualified Types as T +import qualified SitesType as Sites +import qualified BoardsType as Boards data HttpError = HttpException SomeException | StatusCodeError Int LBS.ByteString deriving (Show) -data SiteResponse = SiteResponse - { site_id :: Int - , name :: String - , url :: String - } deriving (Show, Generic, FromJSON) - get :: T.JSONSettings -> String -> IO (Either HttpError LBS.ByteString) get settings path = do @@ -87,13 +83,13 @@ handleHttp action = do Left e -> return $ Left $ HttpException e -getSiteBoards :: T.JSONSettings -> Int -> IO (Either HttpError [ String ]) +getSiteBoards :: T.JSONSettings -> Int -> IO (Either HttpError [ Boards.Board ]) getSiteBoards settings site_id_ = get settings path >>= return . eitherDecodeResponse where - path = "/boards?select=name&site_id=eq." ++ show site_id_ + path = "/boards?select=*&site_id=eq." ++ show site_id_ -postSite :: T.JSONSettings -> IO (Either HttpError [SiteResponse]) +postSite :: T.JSONSettings -> IO (Either HttpError [ Sites.Site ]) postSite settings = post settings "/sites" payload True >>= return . eitherDecodeResponse @@ -103,10 +99,28 @@ postSite settings = , "url" .= T.site_url settings ] +postBoards + :: T.JSONSettings + -> [] String + -> Int + -> IO (Either HttpError [ Boards.Board ]) +postBoards settings boards siteid = + post settings "/boards" payload True >>= return . eitherDecodeResponse -getAllSites :: T.JSONSettings -> IO (Either HttpError [SiteResponse]) + where + payload = encode $ fmap mk_obj boards + + mk_obj :: String -> Value + mk_obj board = object + [ "pathpart" .= board + , "site_id" .= siteid + ] + + +getAllSites :: T.JSONSettings -> IO (Either HttpError [ Sites.Site ]) getAllSites settings = get settings "/sites" >>= return . eitherDecodeResponse + eitherDecodeResponse :: (FromJSON a) => Either HttpError LBS.ByteString -> Either HttpError a eitherDecodeResponse (Left err) = Left err eitherDecodeResponse (Right bs) = diff --git a/src/SitesType.hs b/src/SitesType.hs new file mode 100644 index 0000000..d83acb9 --- /dev/null +++ b/src/SitesType.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module SitesType + ( Site (..) ) + where + +import GHC.Generics +import Data.Aeson (FromJSON) + +data Site = Site + { site_id :: Int + , name :: String + , url :: String + } deriving (Show, Generic, FromJSON) +