Begin generalizing backfill code to use either local or http functions

chan-delorean.cabal

@@ -66,6 +66,7 @@ executable chan-delorean
 
     -- Modules included in this executable, other than Main.
     other-modules:
+                      Lib
                       JSONParsing
                       SitesType
                       BoardsType
@@ -118,6 +119,7 @@ executable chan-delorean-consoomer
 
     -- Modules included in this executable, other than Main.
     other-modules:
+                      Lib
                       JSONParsing
                       SitesType
                       BoardsType
@@ -154,7 +156,8 @@ executable chan-delorean-consoomer
                       cryptonite,
                       memory,
                       mime-types,
-                      perceptual-hash
+                      perceptual-hash,
+                      async
 
     -- Directories containing source files.
     hs-source-dirs:   src

src/Common

@@ -1 +1 @@
-Subproject commit 202f0eb9616b6675e3fa011c69d8fda9028e5e59
+Subproject commit 390165edf85e26c53f2fd53353270ee2ad4c4a38

src/Lib.hs

@@ -2,6 +2,7 @@
 {-# HLINT ignore "Redundant bracket" #-}
 {-# HLINT ignore "Use fromMaybe" #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module Lib where
 
@@ -105,9 +106,12 @@ createArchivesForNewBoards settings dirsSet archived_boards siteid = do
     -- Find boards that are in dirs but not in archived_boards
     let boardsToArchive = dirsSet `Set.difference` archivedBoardsSet
 
-    putStrLn "Creating boards:"
+    putStrLn $ "Creating " ++ (show $ length boardsToArchive) ++ " boards:"
     mapM_ putStrLn boardsToArchive
 
+    if Set.null boardsToArchive
+    then return []
+    else do
         post_result <- Client.postBoards settings (Set.toList boardsToArchive) siteid
 
         case post_result of
@@ -179,10 +183,12 @@ ensureThreads settings board all_threads = do
 
 readPosts
     :: JSONSettings
+    -> FileGetters
     -> Boards.Board
     -> Threads.Thread
     -> IO (Threads.Thread, [ JSONPosts.Post ])
-readPosts settings board thread = do
+readPosts settings fgs board thread = do
+-- parsePosts :: FilePath -> IO (Either String Post.PostWrapper)
     result <- parsePosts thread_filename
 
     case result of
@@ -588,20 +594,32 @@ createNewPosts settings tuples = do
 
                 thread_id = Client.thread_id c
 
-processBoard :: JSONSettings -> Sites.Site -> Boards.Board -> IO ()
-processBoard settings site board = do
-    let catalogPath = backupDir </> "catalog.json"
+
+data FileGetters = FileGetters
+    { getJSONCatalog :: Sites.Site -> String -> IO (Either String [ Catalog ])
+    }
+
+
+localFileGetters :: JSONSettings -> FileGetters
+localFileGetters settings = FileGetters
+    { getJSONCatalog = const $ parseJSONCatalog . (backup_read_root settings </>)
+    }
+
+
+processBoard :: JSONSettings -> FileGetters -> Sites.Site -> Boards.Board -> IO ()
+processBoard settings fgs@FileGetters {..} site board = do
+    let catalogPath = Boards.pathpart board </> "catalog.json"
     putStrLn $ "catalog file path: " ++ catalogPath
 
-    result <- parseJSONCatalog catalogPath
+    result <- getJSONCatalog site catalogPath
 
     case result of
-        Right catalogs -> do
+        Right (catalogs :: [ Catalog ]) -> do
             let threads_on_board = concatMap ((maybe [] id) . threads) catalogs
 
             all_threads_for_board :: [ Threads.Thread ] <- ensureThreads settings board threads_on_board
 
-            all_posts_on_board :: [(Threads.Thread, [ JSONPosts.Post ])] <- mapM (readPosts settings board) all_threads_for_board
+            all_posts_on_board :: [(Threads.Thread, [ JSONPosts.Post ])] <- mapM (readPosts settings fgs board) all_threads_for_board
 
 
             let tuples :: [(Sites.Site, Boards.Board, Threads.Thread, JSONPosts.Post)] = concatMap
@@ -623,18 +641,11 @@ processBoard settings site board = do
             putStrLn $ "Failed to parse the JSON file in directory: "
                 ++ (Boards.pathpart board) ++ ". Error: " ++ errMsg
 
-    where
-        backupDir :: FilePath
-        backupDir = backup_read_root settings </> (Boards.pathpart board)
 
-
-processBackupDirectory :: JSONSettings -> IO ()
-processBackupDirectory settings = do
-    putStrLn "JSON successfully read!"
-    print settings  -- print the decoded JSON settings
+processBoards :: JSONSettings -> FileGetters -> [ FilePath ] -> IO ()
+processBoards settings fgs board_names = do
     site :: Sites.Site <- ensureSiteExists settings
-    dirs <- listCatalogDirectories settings
-    let dirsSet = Set.fromList dirs
+    let boardsSet = Set.fromList board_names
     let site_id_ = Sites.site_id site
     boards_result <- Client.getSiteBoards settings site_id_
     putStrLn "Boards fetched!"
@@ -645,7 +656,16 @@ processBackupDirectory settings = do
             exitFailure
         Right archived_boards -> do
             let boardnames = map Boards.pathpart archived_boards
-            created_boards <- createArchivesForNewBoards settings dirsSet boardnames site_id_
+            created_boards <- createArchivesForNewBoards settings boardsSet boardnames site_id_
             let boards :: [ Boards.Board ] = archived_boards ++ created_boards
-            let boards_we_have_data_for = filter (\board -> Set.member (Boards.pathpart board) dirsSet) boards
-            mapM_ (processBoard settings site) boards_we_have_data_for
+            let boards_we_have_data_for = filter (\board -> Set.member (Boards.pathpart board) boardsSet) boards
+            mapM_ (processBoard settings fgs site) boards_we_have_data_for
+
+
+
+processBackupDirectory :: JSONSettings -> IO ()
+processBackupDirectory settings = do
+    putStrLn "JSON successfully read!"
+    print settings  -- print the decoded JSON settings
+    boards <- listCatalogDirectories settings
+    processBoards settings (localFileGetters settings) boards

src/Main.hs

@@ -6,12 +6,18 @@ import System.Exit (exitFailure)
 import qualified Data.ByteString.Lazy as B
 import System.Console.CmdArgs (cmdArgs, Data, Typeable)
 import Data.Aeson (decode)
+import System.FilePath ((</>))
+import Control.Concurrent.Async (mapConcurrently)
 
+import qualified SitesType as Sites
 import Common.Server.ConsumerSettings
 import Common.Server.JSONSettings as J
 import Lib
-    ( ensureSiteExists
+    ( processBoards
+    , FileGetters (..)
     )
+import JSONParsing (Catalog)
+import qualified Network.DataClient as Client
 
 newtype CliArgs = CliArgs
   { settingsFile :: String
@@ -46,11 +52,23 @@ getSettings = do
                 exitFailure
             Just settings -> return settings
 
+httpFileGetters :: JSONSettings -> FileGetters
+httpFileGetters _ = FileGetters
+    { getJSONCatalog = httpGetJSON
+    }
+
+httpGetJSON :: Sites.Site -> String -> IO (Either String [Catalog])
+httpGetJSON site path = (Client.getJSON $ Sites.url site </> path)
+    >>= getErrMsg
+    where
+        getErrMsg :: Either Client.HttpError a -> IO (Either String a)
+        getErrMsg (Left err) = return $ Left $ show err
+        getErrMsg (Right x) = return $ Right x
 
 processWebsite :: ConsumerJSONSettings -> JSONSiteSettings -> IO ()
 processWebsite settings site_settings = do
     let client_settings = toClientSettings settings site_settings
-    site <- ensureSiteExists client_settings
+    processBoards client_settings (httpFileGetters client_settings) (boards site_settings)
     return ()
 
 main :: IO ()
@@ -60,4 +78,6 @@ main = do
     settings <- getSettings
     print settings
 
-    mapM_ (processWebsite settings) (websites settings)
+    _ <- mapConcurrently (processWebsite settings) (websites settings)
+
+    putStrLn "Done."

src/Network/DataClient.hs

@@ -17,6 +17,7 @@ module Network.DataClient
   , postPosts
   , getAttachments
   , postAttachments
+  , getJSON
   ) where
 
 import Control.Monad (forM)
@@ -215,3 +216,7 @@ eitherDecodeResponse (Right bs) =
     case eitherDecode bs of
         Right val -> Right val
         Left err -> Left $ StatusCodeError 500 $ LC8.pack $ "Failed to decode JSON: " ++ err ++ " " ++ (show bs)
+
+
+getJSON :: (FromJSON a) => String -> IO (Either HttpError a)
+getJSON url = get_ url [] >>= return . eitherDecodeResponse