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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
|
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Main where
import Control.Arrow (second)
import Control.Concurrent.ParallelIO.Local (parallel, withPool)
import Control.Exception (Exception, throw, throwIO)
import Control.Monad (join, when)
import Data.Aeson qualified as J
import Data.Attoparsec.Text qualified as A
import Data.ByteString.Lazy qualified as LB
import Data.List
import Data.Map qualified as M
import Data.Maybe (fromMaybe)
import Data.String (IsString (fromString))
import Data.Text qualified as T
import Data.Text.Encoding qualified as T
import Debug.Trace
import GHC.Conc (getNumProcessors)
import GHC.Generics (Generic)
import System.Directory
import System.FilePath
import System.IO.Temp (withSystemTempDirectory)
import System.Process.Typed
import Text.Printf (printf)
import Text.Read (readMaybe)
main :: IO ()
main =
parMapM_ ocr
=<< sort
. map ("originals" </>)
. filter (not . (".attrs" `isSuffixOf`))
. filter (not . (".bak" `isSuffixOf`))
<$> listDirectory "originals"
debug :: Show a => String -> a -> a
debug s x =
trace (printf "%s: %s\n" s (show x)) x
ocr :: FilePath -> IO ()
ocr input = withSystemTempDirectory (takeBaseName input) $ \tmp -> do
originalText <-
T.decodeUtf8 . LB.toStrict
<$> sh (printf "pdftotext '%s' -" input)
let hasText = (not . T.null) . T.strip $ originalText
when (not hasText) do
let fn suffix = tmp </> takeBaseName input <> suffix
pdfInfo <- parsePdfInfo <$> sh (printf "pdfinfo '%s'" input)
pdfImages <- parsePdfImages <$> sh (printf "pdfimages -list '%s'" input)
let isScan =
length pdfImages == pdfInfo.numPages
&& all ((pdfInfo.pageSize ==) . imageSize) pdfImages
if isScan
then sh_ (printf "pdfimages '%s' '%s' -tiff" input (fn ""))
else sh_ (printf "pdftoppm '%s' '%s' -r 300 -tiff" input (fn "-%d.pdf"))
imageFiles <- sort <$> listDirectory tmp
-- XXX add DPI information to image so that resulting pdf preserves DPI
mapM_
( \(pdfImage, imageFile) ->
sh_
( printf
"convert -density %dx%d -units PixelsPerInch '%s' '%s'"
pdfImage.xPpi
pdfImage.yPpi
(tmp </> imageFile)
(tmp </> imageFile)
)
)
(zip pdfImages imageFiles)
pdfFiles <- mapM (ocr1 tmp . (tmp </>)) imageFiles
sh_ ("pdfunite " ++ intercalate " " (map (printf "'%s'" . (tmp </>)) pdfFiles ++ [printf "'%s'" (fn ".pdf")]))
printf "~ copyFile %s %s\n" input (input <.> "bak")
copyFile input (input <.> "bak")
printf "~ copyFile %s %s\n" (fn ".pdf") (takeDirectory input </> "." <> takeBaseName input <.> "pdf")
copyFile (fn ".pdf") (takeDirectory input </> "." <> takeBaseName input <.> "pdf")
printf "~ renameFile %s %s\n" (takeDirectory input </> "." <> takeBaseName input <.> "pdf") input
renameFile (takeDirectory input </> "." <> takeBaseName input <.> "pdf") input
let attrsFile = takeDirectory input </> takeBaseName input <.> "attrs"
doesAttrsFileExist <- doesFileExist attrsFile
when (not doesAttrsFileExist) $
J.encodeFile attrsFile Attrs {..}
Just attrs <- J.decodeFileStrict attrsFile
print (attrs :: Attrs)
ocr1 :: FilePath -> FilePath -> IO FilePath
ocr1 tmp input = do
sh_
( printf
"tesseract '%s' '%s' pdf"
(tmp </> input)
(tmp </> takeBaseName input)
)
pure (takeBaseName input <.> "pdf")
data Attrs = Attrs
{ originalText :: T.Text
}
deriving (Show, Generic, Eq)
instance J.ToJSON Attrs
instance J.FromJSON Attrs
data PdfInfo = PdfInfo
{ numPages :: Int,
pageSize :: (Double, Double)
}
deriving (Show)
data PdfInfoException = PdfInfoException
deriving (Show)
instance Exception PdfInfoException
parsePdfInfo :: LB.ByteString -> PdfInfo
parsePdfInfo out' =
fromMaybe (throw PdfInfoException) $ do
numPages <- readMaybe . T.unpack =<< M.lookup "Pages" kvs
pageSize <-
rightToMaybe . A.parseOnly pageSizeParser
=<< M.lookup "Page size" kvs
pure PdfInfo {..}
where
out = T.decodeUtf8 (LB.toStrict out')
kvs =
M.fromList
. map (second T.stripStart)
. map (second T.tail . T.break (== ':'))
. filter (not . T.null)
. T.lines
$ out
pageSizeParser =
(,)
<$> (A.double <* A.string " x ")
<*> (A.double <* A.string " pts (A4)")
<* A.endOfInput
type PdfImages = [PdfImage]
data PdfImage = PdfImage
{ page :: Int,
num :: Int,
type_ :: String,
width :: Int,
height :: Int,
color :: String,
comp :: Int,
bpc :: Int,
enc :: String,
interp :: String,
object :: Int,
id :: Int,
xPpi :: Int,
yPpi :: Int,
size :: String,
ratio :: String
}
deriving (Show)
imageSize :: PdfImage -> (Double, Double)
imageSize (PdfImage {..}) =
let f ppi p = 72 * fromIntegral p / fromIntegral ppi
in (f xPpi width, f yPpi height)
data PdfImagesException = PdfImagesException
deriving (Show)
instance Exception PdfImagesException
data ProcessException = ProcessException Int LB.ByteString
deriving (Show)
instance Exception ProcessException
parsePdfImages :: LB.ByteString -> PdfImages
parsePdfImages out' =
map
( \(page' : num' : type_ : width' : height' : color : comp' : bpc' : enc : interp : object' : id' : xPpi' : yPpi' : size : ratio : []) ->
PdfImage
{ page = read page',
num = read num',
width = read width',
height = read height',
comp = read comp',
bpc = read bpc',
object = read object',
id = read id',
xPpi = read xPpi',
yPpi = read yPpi',
..
}
)
. map (map T.unpack)
. map T.words
. drop 2
. filter (not . T.null)
. T.lines
$ out
where
out = T.decodeUtf8 (LB.toStrict out')
sh :: String -> IO LB.ByteString
sh cmd = do
(exitCode, out, err) <- readProcess (fromString cmd)
case exitCode of
ExitSuccess -> return out
ExitFailure exitCode' -> throwIO $ ProcessException exitCode' err
sh_ :: String -> IO ()
sh_ = fmap (\_ -> ()) . sh
rightToMaybe :: Either e a -> Maybe a
rightToMaybe = either (const Nothing) Just
parMapM :: (a -> IO b) -> [a] -> IO [b]
parMapM f xs = do
n <- getNumProcessors
withPool n $ \pool -> parallel pool (map f xs)
parMapM_ :: (a -> IO b) -> [a] -> IO ()
parMapM_ f = fmap (const ()) . parMapM f
|
