Move more things into Lib from Main

This commit is contained in:
towards-a-new-leftypol 2024-04-17 07:44:34 -04:00
parent d3495a9d2d
commit 34753c176a
4 changed files with 74 additions and 62 deletions

View File

@ -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:

View File

@ -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
}

View File

@ -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

View File

@ -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