Move more things into Lib from Main
This commit is contained in:
parent
d3495a9d2d
commit
34753c176a
|
@ -81,6 +81,7 @@ executable chan-delorean
|
||||||
Network.DataClient
|
Network.DataClient
|
||||||
Network.DataClientTypes
|
Network.DataClientTypes
|
||||||
Common.Server.JSONSettings
|
Common.Server.JSONSettings
|
||||||
|
Common.Server.ConsumerSettings
|
||||||
|
|
||||||
-- LANGUAGE extensions used by modules in this package.
|
-- LANGUAGE extensions used by modules in this package.
|
||||||
-- other-extensions:
|
-- other-extensions:
|
||||||
|
|
62
src/Lib.hs
62
src/Lib.hs
|
@ -9,12 +9,13 @@ module Lib where
|
||||||
import System.Exit
|
import System.Exit
|
||||||
import Data.Int (Int64)
|
import Data.Int (Int64)
|
||||||
import Control.Monad (filterM)
|
import Control.Monad (filterM)
|
||||||
import System.Console.CmdArgs
|
import System.Console.CmdArgs hiding (name)
|
||||||
import System.Directory
|
import System.Directory
|
||||||
( listDirectory
|
( listDirectory
|
||||||
, doesFileExist
|
, doesFileExist
|
||||||
, copyFile
|
, copyFile
|
||||||
, createDirectoryIfMissing
|
, createDirectoryIfMissing
|
||||||
|
, removeFile
|
||||||
)
|
)
|
||||||
import System.FilePath ((</>), (<.>), takeExtension)
|
import System.FilePath ((</>), (<.>), takeExtension)
|
||||||
import Data.List (find, isSuffixOf, foldl', sortBy)
|
import Data.List (find, isSuffixOf, foldl', sortBy)
|
||||||
|
@ -31,6 +32,8 @@ import Data.Text.Encoding (decodeUtf8)
|
||||||
import Network.Mime (defaultMimeLookup)
|
import Network.Mime (defaultMimeLookup)
|
||||||
import PerceptualHash (fileHash)
|
import PerceptualHash (fileHash)
|
||||||
import Control.Exception.Safe (tryAny, tryAsync, SomeException, displayException)
|
import Control.Exception.Safe (tryAny, tryAsync, SomeException, displayException)
|
||||||
|
import qualified Data.ByteString.Lazy as B
|
||||||
|
import Data.Aeson (FromJSON)
|
||||||
|
|
||||||
import JSONParsing
|
import JSONParsing
|
||||||
import Common.Server.JSONSettings
|
import Common.Server.JSONSettings
|
||||||
|
@ -44,12 +47,20 @@ import qualified Common.AttachmentType as At
|
||||||
import qualified Common.PostsType as Posts
|
import qualified Common.PostsType as Posts
|
||||||
import qualified Hash as Hash
|
import qualified Hash as Hash
|
||||||
import qualified Data.WordUtil as Words
|
import qualified Data.WordUtil as Words
|
||||||
|
import Common.Server.JSONSettings as J
|
||||||
|
import qualified Common.Server.ConsumerSettings as CS
|
||||||
|
|
||||||
newtype SettingsCLI = SettingsCLI
|
newtype SettingsCLI = SettingsCLI
|
||||||
{ jsonFile :: FilePath
|
{ jsonFile :: FilePath
|
||||||
} deriving (Show, Data, Typeable)
|
} 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 :: JSONSettings -> IO [ FilePath ]
|
||||||
listCatalogDirectories settings = do
|
listCatalogDirectories settings = do
|
||||||
allDirs <- listDirectory (backup_read_root settings)
|
allDirs <- listDirectory (backup_read_root settings)
|
||||||
|
@ -715,3 +726,52 @@ processBackupDirectory settings = do
|
||||||
print settings -- print the decoded JSON settings
|
print settings -- print the decoded JSON settings
|
||||||
boards <- listCatalogDirectories settings
|
boards <- listCatalogDirectories settings
|
||||||
processBoards settings (localFileGetters settings) boards
|
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
|
||||||
|
}
|
||||||
|
|
63
src/Main.hs
63
src/Main.hs
|
@ -6,37 +6,20 @@ import System.Exit (exitFailure)
|
||||||
import qualified Data.ByteString.Lazy as B
|
import qualified Data.ByteString.Lazy as B
|
||||||
import System.Console.CmdArgs (cmdArgs, Data, Typeable)
|
import System.Console.CmdArgs (cmdArgs, Data, Typeable)
|
||||||
import Data.Aeson (decode)
|
import Data.Aeson (decode)
|
||||||
import System.FilePath ((</>))
|
|
||||||
import Control.Concurrent.Async (mapConcurrently)
|
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.ConsumerSettings
|
||||||
import Common.Server.JSONSettings as J
|
|
||||||
import Lib
|
import Lib
|
||||||
( processBoards
|
( processBoards
|
||||||
, FileGetters (..)
|
, toClientSettings
|
||||||
|
, httpFileGetters
|
||||||
)
|
)
|
||||||
import qualified Network.DataClient as Client
|
|
||||||
import qualified Common.AttachmentType as At
|
|
||||||
import Sync
|
import Sync
|
||||||
|
|
||||||
newtype CliArgs = CliArgs
|
newtype CliArgs = CliArgs
|
||||||
{ settingsFile :: String
|
{ settingsFile :: String
|
||||||
} deriving (Show, Data, Typeable)
|
} 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 :: IO ConsumerJSONSettings
|
||||||
getSettings = do
|
getSettings = do
|
||||||
cliArgs <- cmdArgs $ CliArgs "consumer_settings.json"
|
cliArgs <- cmdArgs $ CliArgs "consumer_settings.json"
|
||||||
|
@ -56,48 +39,6 @@ getSettings = do
|
||||||
Just settings -> return settings
|
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 :: ConsumerJSONSettings -> JSONSiteSettings -> IO ()
|
||||||
processWebsite settings site_settings = do
|
processWebsite settings site_settings = do
|
||||||
let client_settings = toClientSettings settings site_settings
|
let client_settings = toClientSettings settings site_settings
|
||||||
|
|
10
src/Sync.hs
10
src/Sync.hs
|
@ -1,6 +1,16 @@
|
||||||
module Sync where
|
module Sync where
|
||||||
|
|
||||||
import Common.Server.ConsumerSettings
|
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 :: ConsumerJSONSettings -> IO ()
|
||||||
syncWebsites _ = do
|
syncWebsites _ = do
|
||||||
|
|
Loading…
Reference in New Issue