Creating boards if they don't exist

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:

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;

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

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

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

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