+-- SPDX-FileCopyrightText: 2022 Frank Doepper
+--
+-- SPDX-License-Identifier: GPL-3.0-only
+
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
import Control.Concurrent
import qualified Control.Exception as X
import Control.Monad (forM_)
-import qualified Data.ByteString.Lazy.Char8 as BL
-import qualified RawFilePath.Directory as RD
import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Text as T
import Network.AMQP.Utils.Helpers
import Network.AMQP.Utils.Options
import Paths_amqp_utils (version)
-import System.Directory
+import qualified System.Directory.OsPath as DO
import System.Environment
import System.Exit
-import System.FilePath.Posix.ByteString
#if linux_HOST_OS
import System.INotify
#endif
-import qualified System.Posix.Files.ByteString as F
+import System.Posix.ByteString (RawFilePath)
+import qualified System.Posix.Files.ByteString as FB
+import qualified System.Posix.Files.PosixString as FP
+import qualified System.OsPath as OS
+import qualified System.File.OsPath as FOS
main :: IO ()
main = do
isDir <-
if inputFile' == "-"
then return False
- else F.getFileStatus inputFile' >>= return . F.isDirectory
+ else FB.getFileStatus inputFile' >>= return . FB.isDirectory
let publishOneMsg =
publishOneMsg' chan args {removeSentFile = removeSentFile args && isDir}
if isDir
- then printparam "initial scan" (initialScan args) >>
- if isNothing (moveSentFileTo args)
- then printparam "remove sent file" (removeSentFile args)
- else printparam "move sent file to" (moveSentFileTo args)
+ then do
+ printparam "hotfolder mode" True
+ printparam "initial scan" (initialScan args)
+ if isNothing (moveSentFileTo args)
+ then printparam "remove sent file" (removeSentFile args)
+ else printparam "move sent file to" (moveSentFileTo args)
else printparam
"input file"
[ inputFile'
X.catch
(if isDir
then do
+#if linux_HOST_OS
wds <- mapM (watchHotfolder args publishOneMsg) (inputFiles args)
- sleepingBeauty >>= printparam "exception"
- forM_ wds (\(wd,folder) -> do
- removeWatch wd
- hr $ "END watching " ++ folder
- )
+ sleepingBeauty >>= (\x -> do
+ forM_ wds (\(wd,folder) -> do
+ removeWatch wd
+ printparam "END watching" folder
+ )
+ X.throw x)
+#else
+ X.throw (X.ErrorCall "ERROR: watching a directory is only supported in Linux")
+#endif
else do
hr $ "BEGIN sending"
messageFile <-
if inputFile' == "-"
then BL.getContents
- else readFileRawLazy inputFile'
+ else OS.encodeUtf (BS.unpack inputFile') >>= FOS.readFile
if (lineMode args)
- then mapM_ (publishOneMsg (currentExchange args) (rKey args) Nothing Nothing) (BL.lines messageFile)
- else publishOneMsg (currentExchange args) (rKey args) Nothing (Just (inputFile')) messageFile
- hr "END sending")
+ then mapM_ (publishOneMsg (currentExchange args) (rKey args) Nothing) (BL.lines messageFile)
+ else publishOneMsg (currentExchange args) (rKey args) (Just (inputFile')) messageFile
+ hr "END sending"
+ if (confirm args)
+ then waitForConfirms chan >>= printparam "confirmed"
+ else return ()
+ X.catch (closeConnection conn) exceptionHandler
+ )
exceptionHandler
- -- all done. wait and close.
- if (confirm args)
- then waitForConfirms chan >>= printparam "confirmed"
- else return ()
- X.catch (closeConnection conn) exceptionHandler
+#if linux_HOST_OS
-- | watch a hotfolder
watchHotfolder ::
Args
- -> (String -> String -> Maybe FilePath -> Maybe RawFilePath -> BL.ByteString -> IO ())
- -> (FilePath, String, String)
- -> IO (WatchDescriptor,String)
+ -> (String -> String -> Maybe RawFilePath -> BL.ByteString -> IO ())
+ -> (RawFilePath, String, String)
+ -> IO (WatchDescriptor, RawFilePath)
watchHotfolder args publishOneMsg (folder, exchange, rkey) = do
printparam "hotfolder" folder
-#if linux_HOST_OS
- setCurrentDirectory folder
- if (initialScan args)
- then RD.listDirectory "." >>=
- mapM_ (\fn -> handleFile (publishOneMsg exchange rkey (Just folder)) (suffix args) (Just folder) fn)
- else return ()
inotify <- initINotify
wd <-
addWatch
inotify
[CloseWrite, MoveIn]
- (BS.pack folder)
- (handleEvent (publishOneMsg exchange rkey (Just folder)) (suffix args) (Just folder))
- hr $ "BEGIN watching " ++ folder
+ folder
+ (handleEvent (publishOneMsg exchange rkey) (suffix args) folder)
+ hr "BEGIN watching"
+ if (initialScan args)
+ then do
+ folder' <- OS.encodeUtf (BS.unpack folder)
+ DO.listDirectory folder' >>=
+ mapM_ (\fn -> handleFile (publishOneMsg exchange rkey) (suffix args) (folder' OS.</> fn))
+ else return ()
return (wd,folder)
-#else
- X.throw (X.ErrorCall "ERROR: watching a directory is only supported in Linux")
#endif
-- | A handler for clean exit
else "this"
, show ackType
]
+
#if linux_HOST_OS
-- | Hotfolder event handler
handleEvent ::
- (Maybe RawFilePath -> BL.ByteString -> IO ()) -> [BS.ByteString] -> Maybe FilePath -> Event -> IO ()
+ (Maybe RawFilePath -> BL.ByteString -> IO ()) -> [BS.ByteString] -> OS.OsPath -> Event -> IO ()
-- just handle closewrite and movedin events
handleEvent func suffixes folder (Closed False (Just fileName) True) =
- handleFile func suffixes folder fileName
+ handleFile func suffixes (folder OS.</> fileName)
handleEvent func suffixes folder (MovedIn False fileName _) =
- handleFile func suffixes folder fileName
+ handleFile func suffixes (folder OS.</> fileName)
handleEvent _ _ _ _ = return ()
-- | Hotfolder file handler
handleFile ::
- (Maybe RawFilePath -> BL.ByteString -> IO ()) -> [BS.ByteString] -> Maybe FilePath -> RawFilePath -> IO ()
-handleFile func suffixes@(_:_) folder fileName =
+ (Maybe RawFilePath -> BL.ByteString -> IO ()) -> [BS.ByteString] -> OS.OsPath -> IO ()
+handleFile func suffixes@(_:_) fileName =
if (any (flip BS.isSuffixOf fileName) suffixes) && not ("." `BS.isPrefixOf` fileName)
- then handleFile func [] folder fileName
+ then handleFile func [] fileName
else return ()
-handleFile func [] folder fileName =
+handleFile func [] fileName =
X.catch
- (mapM_ setCurrentDirectory folder >> readFileRawLazy fileName >>= func (Just fileName))
- (\e -> printparam "exception in handleFile" (e :: X.IOException))
+ (FOS.readFile fileName >>= func (Just fileName))
+ (\e -> printparam "exception while processing" fileName >> printparam "exception in handleFile" (e :: X.IOException))
#endif
-- | Publish one message with our settings
-> Args
-> String
-> String
- -> Maybe FilePath
-> Maybe RawFilePath
-> BL.ByteString
-> IO ()
-publishOneMsg' chan a exchange rkey folder fn content = do
- printparam "sending" [fmap BS.pack folder, fn]
+publishOneMsg' chan a exchange rkey fn content = do
+ printparam "sending" fn
(mtype, mencoding) <-
if (magic a)
then do
, msgPriority = prio a
, msgCorrelationID = corrid a
, msgExpiration = msgexp a
- , msgHeaders = substheader (fnheader a) fn $ msgheader a
+ , msgHeaders = substheader (fnheader a) (fmap OS.takeFileName fn) $ msgheader a
} >>=
printparam "sent"
- removeSentFileIfRequested (removeSentFile a) (fmap BS.pack (moveSentFileTo a)) fn
+ removeSentFileIfRequested (removeSentFile a) (moveSentFileTo a) fn
where
substheader ::
[String] -> Maybe BS.ByteString -> Maybe FieldTable -> Maybe FieldTable
removeSentFileIfRequested False _ _ = return ()
removeSentFileIfRequested True _ Nothing = return ()
removeSentFileIfRequested True Nothing (Just fname) =
- printparam "removing" fname >> RD.removeFile fname
+ printparam "removing" fname >> DO.removeFile fname
removeSentFileIfRequested True (Just path) (Just fname) =
printparam "moving" [fname,"to",path] >>
- F.rename fname (replaceDirectory fname path)
+ FP.rename fname (OS.replaceDirectory fname ((OS.takeDirectory fname) OS.</> path))
addheader' :: Maybe FieldTable -> String -> BS.ByteString -> Maybe FieldTable
addheader' Nothing k v =
Just $ FieldTable $ M.singleton (T.pack k) (FVString v)
projects / fd / haskell-amqp-utils.git / blobdiff