1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Main where
import Rebase.Prelude
import Options.Applicative (execParser, help, helper, info, long,
metavar, strOption)
import System.Directory (createDirectoryIfMissing, renameFile)
import System.FilePath (takeFileName, (</>))
import System.FSNotify (Event (..), watchDir, withManager)
import System.IO.Temp (withSystemTempDirectory)
import System.Posix.Files (fileMode, getFileStatus,
intersectFileModes, nullFileMode,
otherReadMode)
import System.Posix.Types (FileMode)
import System.Process.Typed (proc, runProcess)
pdfDirectory, seenDir, pdfPrinterExecutable :: FilePath
pdfDirectory = "."
seenDir = pdfDirectory </> "seen"
pdfPrinterExecutable = "PDFtoPrinter.exe"
verbose :: Bool
verbose = True
data Options = Options
{ sendTo :: Maybe String
}
main :: IO ()
main = execParser (info (options <**> helper) mempty) >>= chooseMain
where
options = fmap Options $ optional $ strOption $ long "send-to"
<> metavar "RSYNC-DEST"
<> help "Where to send the PDFs via rsync, in rsync target format (host:path)"
chooseMain :: Options -> IO ()
chooseMain (Options Nothing) = serverMain
chooseMain (Options (Just target)) = clientMain target
serverMain :: IO ()
serverMain = do
createDirectoryIfMissing False seenDir
handlePdfsForever pdfDirectory pdfPrinter
clientMain :: String -> IO ()
clientMain target = handlePdfsForever pdfDirectory (pdfSender target)
pdfPrinter :: FilePath -> IO ()
pdfPrinter f =
-- Note: there is no sense in checking the return result, as PDFtoPrinter.exe
-- returns success even when it fails to parse the PDF.
runProcessVerbose pdfPrinterExecutable [f] >>
moveFileIntoDir f seenDir
hasMode :: FileMode -> FileMode -> Bool
hasMode = ((.).(.)) (/= nullFileMode) intersectFileModes
newtype Milliseconds = Milliseconds Integer deriving (Num, Show, Eq, Ord)
waitUntil :: (IO Bool) -> Milliseconds -> IO ()
waitUntil cond maxWait = do
r <- cond
when (maxWait > 0 && not r) $ do
threadDelay $ 100 * 1000
waitUntil cond (maxWait - 100)
waitUntilReadable :: FilePath -> Milliseconds -> IO ()
waitUntilReadable f = waitUntil $ hasMode otherReadMode . fileMode <$> getFileStatus f
pdfSender :: String -> FilePath -> IO ()
pdfSender target f = do
withSystemTempDirectory "pdf-autoprint." $ \dir -> do
-- CUPS creates the file (with its final name) and then appends to it,
-- rather than atomically renaming a fully-written file into place. Luckily
-- we can still detect when the file is fully-written because CUPS will
-- change the permissions from 600 to 644 after it is. Thus we poll until
-- the permissions change. This isn't really the best approach; we could use
-- fs notifications here too. We currently do get a 'Modified' event on the
-- file, with which we do nothing. However, I am not sure that this event is
-- not triggered too early.
waitUntilReadable f (100*1000)
-- `PDFToPrinter.exe` will render text on (at least) the IRS tax forms as
-- horrible pixelated smudgy blobs. This `convert` command will render the
-- text into a rasterized PDF that `PDFToPrinter.exe` can handle well.
let converted = dir </> takeFileName f
void $ runProcessVerbose "convert" ["-density", "300", f, converted]
void $ runProcessVerbose "rsync" ["--remove-source-files", converted, target]
handlePdfsForever :: FilePath -> (FilePath -> IO ()) -> IO ()
handlePdfsForever dir h = handleEventsForever dir (handleAdds (".pdf" `isSuffixOf`) h)
handleAdds :: (String -> Bool) -> (FilePath -> IO ()) -> Event -> IO ()
handleAdds predicate handleFile (Added f _) | predicate f = handleFile f
handleAdds _ _ x = when verbose $ print x
handleEventsForever :: FilePath -> (Event -> IO ()) -> IO ()
handleEventsForever dir eventHandler = do
withManager $ \mgr -> do
void $ watchDir mgr dir (const True) eventHandler
forever $ threadDelay 1000000
runProcessVerbose :: FilePath -> [String] -> IO ExitCode
runProcessVerbose exe args = do
when verbose $ putStrLn $ "+ " ++ exe ++ " " ++ unwords args
runProcess (proc exe args)
moveFileIntoDir :: FilePath -> FilePath -> IO ()
moveFileIntoDir f d = renameFile f $ d </> takeFileName f
|
