diff --git a/chan-delorean.cabal b/chan-delorean.cabal index 2396872..9cf2f4f 100644 --- a/chan-delorean.cabal +++ b/chan-delorean.cabal @@ -81,6 +81,7 @@ executable chan-delorean Network.DataClient Network.DataClientTypes Common.Server.JSONSettings + Common.Server.ConsumerSettings -- LANGUAGE extensions used by modules in this package. -- other-extensions: diff --git a/src/Lib.hs b/src/Lib.hs index 840c79b..a792cbf 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -9,12 +9,13 @@ module Lib where import System.Exit import Data.Int (Int64) import Control.Monad (filterM) -import System.Console.CmdArgs +import System.Console.CmdArgs hiding (name) import System.Directory ( listDirectory , doesFileExist , copyFile , createDirectoryIfMissing + , removeFile ) import System.FilePath ((), (<.>), takeExtension) import Data.List (find, isSuffixOf, foldl', sortBy) @@ -31,6 +32,8 @@ import Data.Text.Encoding (decodeUtf8) import Network.Mime (defaultMimeLookup) import PerceptualHash (fileHash) import Control.Exception.Safe (tryAny, tryAsync, SomeException, displayException) +import qualified Data.ByteString.Lazy as B +import Data.Aeson (FromJSON) import JSONParsing import Common.Server.JSONSettings @@ -44,12 +47,20 @@ import qualified Common.AttachmentType as At import qualified Common.PostsType as Posts import qualified Hash as Hash import qualified Data.WordUtil as Words +import Common.Server.JSONSettings as J +import qualified Common.Server.ConsumerSettings as CS newtype SettingsCLI = SettingsCLI { jsonFile :: FilePath } deriving (Show, Data, Typeable) +-- Move a file by reading, writing, and then deleting the original +moveFile :: FilePath -> FilePath -> IO () +moveFile src dst = + B.readFile src >>= B.writeFile dst >> removeFile src + + listCatalogDirectories :: JSONSettings -> IO [ FilePath ] listCatalogDirectories settings = do allDirs <- listDirectory (backup_read_root settings) @@ -715,3 +726,52 @@ processBackupDirectory settings = do print settings -- print the decoded JSON settings boards <- listCatalogDirectories settings processBoards settings (localFileGetters settings) boards + + +toClientSettings :: CS.ConsumerJSONSettings -> CS.JSONSiteSettings -> J.JSONSettings +toClientSettings CS.ConsumerJSONSettings {..} CS.JSONSiteSettings {..} = + J.JSONSettings + { J.postgrest_url = postgrest_url + , J.jwt = jwt + , J.backup_read_root = undefined + , J.media_root_path = media_root_path + , J.site_name = name + , J.site_url = root_url + } + + +httpGetJSON :: (FromJSON a) => Sites.Site -> String -> IO (Either String a) +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 + +httpFileGetters :: J.JSONSettings -> FileGetters +httpFileGetters settings = FileGetters + { getJSONCatalog = httpGetJSON + , getJSONPosts = httpGetJSON + , addPathPrefix = ((++) $ J.site_url settings) + -- attachmentPaths here actually doesn't get the paths of the attachment, + -- it downloads them into a temporary file and gets that path of that. + , attachmentPaths = \paths -> do + filepath <- Client.getFile (At.file_path paths) + m_thumbpath <- case At.thumbnail_path paths of + Nothing -> return Nothing + Just thumbpath -> Client.getFile thumbpath + + return $ filepath >>= \fp -> + case m_thumbpath of + Nothing -> return (At.Paths fp Nothing) + tp -> return (At.Paths fp tp) + + , copyOrMove = \common_dest (src, dest) (m_thumb_src, thumb_dest) -> do + putStrLn $ "Copy Or Move (Move) src: " ++ src ++ " dest: " ++ dest + createDirectoryIfMissing True common_dest + moveFile src dest + + case m_thumb_src of + Nothing -> return () + Just thumb_src -> moveFile thumb_src thumb_dest + } diff --git a/src/Main.hs b/src/Main.hs index fbf9b42..3073f00 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -6,37 +6,20 @@ 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 Data.Aeson (FromJSON) -import System.Directory (createDirectoryIfMissing, removeFile) -import qualified SitesType as Sites import Common.Server.ConsumerSettings -import Common.Server.JSONSettings as J import Lib ( processBoards - , FileGetters (..) + , toClientSettings + , httpFileGetters ) -import qualified Network.DataClient as Client -import qualified Common.AttachmentType as At import Sync newtype CliArgs = CliArgs { settingsFile :: String } deriving (Show, Data, Typeable) -toClientSettings :: ConsumerJSONSettings -> JSONSiteSettings -> J.JSONSettings -toClientSettings ConsumerJSONSettings {..} JSONSiteSettings {..} = - J.JSONSettings - { J.postgrest_url = postgrest_url - , J.jwt = jwt - , J.backup_read_root = undefined - , J.media_root_path = media_root_path - , J.site_name = name - , J.site_url = root_url - } - getSettings :: IO ConsumerJSONSettings getSettings = do cliArgs <- cmdArgs $ CliArgs "consumer_settings.json" @@ -56,48 +39,6 @@ getSettings = do Just settings -> return settings --- Move a file by reading, writing, and then deleting the original -moveFile :: FilePath -> FilePath -> IO () -moveFile src dst = - B.readFile src >>= B.writeFile dst >> removeFile src - - -httpFileGetters :: JSONSettings -> FileGetters -httpFileGetters settings = FileGetters - { getJSONCatalog = httpGetJSON - , getJSONPosts = httpGetJSON - , addPathPrefix = ((++) $ site_url settings) - -- attachmentPaths here actually doesn't get the paths of the attachment, - -- it downloads them into a temporary file and gets that path of that. - , attachmentPaths = \paths -> do - filepath <- Client.getFile (At.file_path paths) - m_thumbpath <- case At.thumbnail_path paths of - Nothing -> return Nothing - Just thumbpath -> Client.getFile thumbpath - - return $ filepath >>= \fp -> - case m_thumbpath of - Nothing -> return (At.Paths fp Nothing) - tp -> return (At.Paths fp tp) - - , copyOrMove = \common_dest (src, dest) (m_thumb_src, thumb_dest) -> do - putStrLn $ "Copy Or Move (Move) src: " ++ src ++ " dest: " ++ dest - createDirectoryIfMissing True common_dest - moveFile src dest - - case m_thumb_src of - Nothing -> return () - Just thumb_src -> moveFile thumb_src thumb_dest - } - -httpGetJSON :: (FromJSON a) => Sites.Site -> String -> IO (Either String a) -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 diff --git a/src/Sync.hs b/src/Sync.hs index bd5d904..34f02e6 100644 --- a/src/Sync.hs +++ b/src/Sync.hs @@ -1,6 +1,16 @@ module Sync where import Common.Server.ConsumerSettings +import Lib (getBoards, toClientSettings) +import SitesType (Site) +import BoardsType (Board) + +getSiteBoards :: ConsumerJSONSettings -> JSONSiteSettings -> IO (Site, [ Board ]) +getSiteBoards settings site_settings = + let client_settings = toClientSettings settings site_settings + in getBoards + client_settings + (boards site_settings) syncWebsites :: ConsumerJSONSettings -> IO () syncWebsites _ = do