{- |
For German Post customers:
Generate a sheet of stamps in an arbitrary format
using a PDF generated by the order formular at http://www.internetmarke.de/ .
-}
module Main (main) where
import Graphics.PDF
import qualified Text.ParserCombinators.Parsec as Parser
import qualified Text.ParserCombinators.Parsec.Pos as SourcePos
import qualified Data.Traversable as Traversable
import qualified Control.Monad.HT as MonadHT
import Data.List (isSuffixOf, )
import Data.List.HT (maybePrefixOf, sliceVertical, padLeft, )
import Data.Char (isSpace, )
import Data.Maybe (mapMaybe, )
import System.Process (runInteractiveProcess, waitForProcess, rawSystem, )
import System.IO (withFile, hGetContents, hGetChar, IOMode(ReadMode), )
import System.IO.Error (ioeGetFileName, isDoesNotExistError, )
import Control.Exception (try, )
import Paths_internetmarke (getDataDir, )
import System.Console.GetOpt (getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo, )
import System.Environment (getArgs, getProgName, )
import System.Exit (exitWith, ExitCode(..), )
import qualified Control.Monad.Exception.Synchronous as Exc
import Control.Monad.Trans.State (StateT, evalStateT, gets, modify, )
import Control.Monad.Trans.Class (lift, )
import Control.Monad (liftM, liftM2, liftM3, when, )
import Control.Functor.HT (void, )
data Picture = Picture {
picPath :: FilePath,
picWidth, picHeight :: PDFFloat,
picJPEG :: PDFReference PDFJpeg
}
instance Show Picture where
show pic = "Picture " ++ picPath pic
makePicture :: String -> JpegFile -> PDF Picture
makePicture name jpeg =
do ref <- createPDFJpeg jpeg
let (width, height) = jpegBounds jpeg
return $ Picture name (fromIntegral width) (fromIntegral height) ref
data Drawing = Drawing {
drawPath :: FilePath,
drawObject :: Draw ()
}
instance Show Drawing where
show d = "Drawing " ++ drawPath d
data Stamp = Stamp {
price :: String,
date :: String,
code :: String,
domain :: String,
logo :: Drawing,
picture :: Maybe Picture,
barCode, matrixCode :: Picture
}
deriving Show
-- * generate PDF graphics
stampToTextDraw :: Stamp -> Draw ()
stampToTextDraw stamp =
let setText leftLower sp size font t =
drawText $
do let f = PDFFont font size
setFont f
let (x:+y) = leftLower
textStart x y
charSpace sp
-- textScale $ 100*stretch
-- rise 10
leading $ getHeight f
renderMode FillText
displayText (toPDFString t)
(codeA, ' ':codeB) = splitAt 12 $ code stamp
in do setText (430 :+ 175) 0 25 Helvetica_BoldOblique (price stamp)
setText (430 :+ 150) 0 22 Helvetica (date stamp)
setText (430 :+ 120) 2 25 Helvetica codeA
setText (430 :+ 90) 2 25 Helvetica codeB
setText (250 :+ 0) 0 25 Helvetica_Bold (domain stamp)
stampToPictureDraw :: Stamp -> Draw ()
stampToPictureDraw stamp =
(case picture stamp of
Nothing -> return ()
Just pic ->
withNewContext $
let templateWidth = 200
templateHeight = 260
kx = templateWidth / picWidth pic
ky = templateHeight / picHeight pic
k = min kx ky
width = k * picWidth pic
height = k * picHeight pic
posX = (templateWidth-width)/2
posY = (templateHeight-height)/2
in do applyMatrix $ translate (posX :+ posY)
applyMatrix $ scale k k
drawXObject (picJPEG pic)) >>
(withNewContext $
do let k = 0.84
applyMatrix $ translate (250:+60)
withNewContext $ applyMatrix (scale k k) >>
drawXObject (picJPEG (barCode stamp))
applyMatrix $ translate (25:+0)
withNewContext $ applyMatrix (scale k k) >>
drawXObject (picJPEG (matrixCode stamp))) >>
(withNewContext $
do applyMatrix $ translate (250:+230)
drawObject (logo stamp))
stampToDraw :: Point -> Stamp -> Draw ()
stampToDraw pos stamp =
withNewContext $
do applyMatrix $ translate pos
stampToTextDraw stamp
stampToPictureDraw stamp
stampsToPDF :: [Point] -> [Stamp] -> PDF ()
stampsToPDF positions =
mapM_
(\stamps ->
do page <- addPage Nothing
drawWithPage page $
applyMatrix (scale pdfUnit pdfUnit) >>
(sequence_ $ zipWith stampToDraw positions stamps)) .
sliceVertical (length positions)
makeLayout :: (Int,PDFFloat,PDFFloat) -> (Int,PDFFloat,PDFFloat) -> [Point]
makeLayout (ny,sy,dy) (nx,sx,dx) =
do y <- take ny $ iterate (subtract dy) sy
x <- take nx $ iterate (dx+) sx
return (10*(x:+y))
layouts :: [(String, [Point])]
layouts =
("Geha-Z54", makeLayout (7,252,38.1) (3,8,66)) :
("Zweckform-4737", makeLayout (9,252,29.6) (3,8,66)) :
[]
-- * parse PDF text
parseSatisfyLine :: (Show tok) =>
(tok -> Bool) -> Parser.GenParser tok st tok
parseSatisfyLine p =
Parser.tokenPrim
(\ln -> show ln)
(\pos _ln _lns -> SourcePos.incSourceLine pos 1)
(\ln -> if p ln then Just ln else Nothing)
parseStamps ::
Parser.GenParser String st [Stamp]
parseStamps =
fmap concat $
Parser.many1 $
do textsA <-
Parser.many1 $
do sprice <- parseSatisfyLine (isSuffixOf "EUR")
sdate <- parseSatisfyLine (const True)
void $ parseSatisfyLine null
return (sprice, sdate)
textsB <-
Parser.count (length textsA) $
do scode <- parseSatisfyLine (const True)
void $ parseSatisfyLine null
return scode
textsC <-
Parser.count (length textsA) $
do sdomain <- parseSatisfyLine (const True)
void $ parseSatisfyLine null
return sdomain
return $ zipWith3
(\(sprice, sdate) scode sdomain ->
Stamp
{price=sprice, date=sdate, code=scode, domain=sdomain,
picture=error "picture: not initialized",
barCode=error "bar: not initialized",
matrixCode=error "matrix: not initialized",
logo=error "logo: not initialized"})
textsA textsB textsC
-- * parse SVG logo
{-
logo =
(\(p:ps) -> beginPath p >> addPolygonToPath ps >> fillPath) $
map (10*) $
map (subtract $ 187.091:+41.9979) $
map (uncurry (:+)) $
(187.091,41.9979) : (192.655,41.9979) : (187.036,47.6823) : (181.474,47.6823) : (187.091,41.9979) : []
-}
parseFixedPoint :: Parser.CharParser st Double
parseFixedPoint =
do integer <- Parser.many1 Parser.digit
void $ Parser.char '.'
fraction <- Parser.many1 Parser.digit
return $ read $ integer ++ "." ++ fraction
parsePoint :: Parser.CharParser st Point
parsePoint =
do x <- parseFixedPoint
void $ Parser.char ','
y <- parseFixedPoint
Parser.spaces
return $ x:+(-y)
parsePolygon :: Parser.CharParser st (Draw ())
parsePolygon =
do void $ Parser.string "points=\""
(p:ps) <- Parser.many1 $
do p <- parsePoint
return (2.562571*p + (86.77773:+(-644.0665)))
void $ Parser.string "\""
return $ beginPath p >> addPolygonToPath ps >> fillPath
parsePath :: Parser.CharParser st (Draw ())
parsePath =
do void $ Parser.string "d=\""
path <- Parser.many1 $
Parser.choice $
(do void $ Parser.char 'M'
Parser.spaces
liftM beginPath parsePoint) :
(do void $ Parser.char 'z'
Parser.spaces
return closePath) :
(do void $ Parser.char 'L'
Parser.spaces
liftM addLineToPath parsePoint) :
(do void $ Parser.char 'C'
Parser.spaces
liftM3 addBezierCubic parsePoint parsePoint parsePoint) :
[]
void $ Parser.string "\""
return $ sequence_ path >> fillPath
makeLogo :: String -> Drawing
makeLogo =
Drawing logoFileName .
(applyMatrix (scale 0.7 0.65) >>) .
(applyMatrix (translate ((-150.20595) :+ (748.88257))) >>) .
sequence_ .
mapMaybe (either (const Nothing) Just) .
map (Parser.parse (parsePolygon Parser.<|> parsePath) logoFileName) .
map (dropWhile isSpace) .
drop 92 .
lines
-- * load matrix codes
showInt3 :: Int -> String
showInt3 n = padLeft '0' 3 (show n)
exitCodeToException :: IO ExitCode -> Exc.ExceptionalT String IO ()
exitCodeToException act =
Exc.ExceptionalT $
fmap (\exit ->
case exit of
ExitFailure n -> Exc.Exception $ "command failed with code " ++ show n
ExitSuccess -> Exc.Success ()) act
{- |
It would be better to load those images as PNG,
but HPDF currently does not support this.
-}
loadPPMasJPEG :: FilePath -> Exc.ExceptionalT String IO JpegFile
loadPPMasJPEG path =
do let jpegPath = path++".jpeg"
{-
exitCodeToException $ system $
"pnmtojpeg -quality=100 -greyscale "
++ path++".ppm >" ++ jpegPath
-}
(_inp,jpegHandle,_err,pid) <-
lift $ runInteractiveProcess "pnmtojpeg"
["-quality=100", "-greyscale", path++".ppm"]
Nothing Nothing
lift $ hGetContents jpegHandle >>= writeFile jpegPath
exitCodeToException $ waitForProcess pid
Exc.fromEitherT $ readJpegFile jpegPath
elaborateOnNotFound :: [String] -> IO a -> Exc.ExceptionalT String IO a
elaborateOnNotFound msg action =
Exc.catchT
(Exc.fromEitherT $ try $ action)
(\ioe ->
when (isDoesNotExistError ioe)
(Exc.throwT $ unlines $
("file " ++
maybe "with unknown filename" show (ioeGetFileName ioe) ++
" not found for opening.") :
[] :
msg) >>
Exc.throwT (show ioe))
{- lazy hGetContents fails badly here, because the stream is closed before we can check its content
checkFilePrefix :: String -> FilePath -> IO Bool
checkFilePrefix prefix path =
withFile path ReadMode (fmap (isPrefixOf prefix) . hGetContents)
-}
checkFilePrefix :: String -> FilePath -> IO Bool
checkFilePrefix prefix path =
withFile path ReadMode $ \h ->
fmap and $ mapM (\c -> fmap (c==) (hGetChar h)) prefix
{- |
We identify the matrix code according to its size.
If the Post changes the sizes this will fail.
-}
loadMatrixCode :: StateT Int (Exc.ExceptionalT String IO) (JpegFile,JpegFile)
loadMatrixCode =
do fn0 <- gets makeMatrixCodePath
modify succ
fn1 <- gets makeMatrixCodePath
let notFoundMsg =
"This may indicate that there are no images with the expected sizes," :
"which in turn may mean, that the Post company changed the sizes of the Data Code Matrix." :
[]
checkFile prefix fn =
elaborateOnNotFound notFoundMsg (checkFilePrefix prefix fn)
b <- lift $
checkFile "P6\n30 156\n" (fn0++".ppm")
`MonadHT.andLazy`
checkFile "P6\n156 156\n" (fn1++".ppm")
if b
then
do modify succ
lift $ liftM2 (,)
(loadPPMasJPEG fn0)
(loadPPMasJPEG fn1)
else
loadMatrixCode
-- * process shell arguments
matrixCodePathPrefix :: FilePath
matrixCodePathPrefix = "/tmp/internetmarke"
makeMatrixCodePath :: Int -> FilePath
makeMatrixCodePath n = matrixCodePathPrefix ++ "-" ++ showInt3 n
logoFileName :: FilePath
logoFileName = "Deutsche-Post-Logo.svg"
logoURL :: String
logoURL =
"http://upload.wikimedia.org/wikipedia/de/4/42/Deutsche_Post-Logo.svg"
-- factor from 1/10 millimeters to PDF unit
-- we need such a small unit, because Font sizes can only be set as integers
pdfUnit :: Double
pdfUnit = 0.283
-- 1/10 millimeters
a4width, a4height :: Double
a4width = 10000/4/sqrt(sqrt 2)
a4height = 10000/4*sqrt(sqrt 2)
data Flags =
Flags {
optHelp :: Bool,
optPicture :: Maybe FilePath,
optLayout :: String
}
options :: [OptDescr (Flags -> Flags)]
options =
Option ['h'] ["help"] (NoArg (\ flags -> flags{optHelp = True})) "show options" :
Option ['p'] ["picture"] (ReqArg (\str flags -> flags{optPicture = Just str}) "PICTURE") "jpeg file for a custom PICTURE on the stamp" :
Option ['l'] ["layout"] (ReqArg (\str flags -> flags{optLayout = str}) "LAYOUT") "one of the predefined LAYOUTs" :
[]
-- * main
main :: IO ()
main = Exc.resolveT (\e -> putStr $ "Aborted: " ++ e ++ "\n") $ do
argv <- lift getArgs
let (opts, files, errors) = getOpt RequireOrder options argv
when (not (null errors)) $ Exc.throwT $ concat $ errors
let flags = foldr ($)
(Flags {optHelp = False,
optPicture = Nothing,
optLayout = "Geha-7x3"}) opts
programName <- lift getProgName
when (optHelp flags)
(lift $
putStrLn
(usageInfo ("Usage: " ++ programName ++ " [OPTIONS] PDF-INPUT PDF-OUTPUT") options ++
"\nAvailable layouts:\n" ++
unlines (map fst layouts ++ ["custom-(numberY,startYmm,distanceYmm),(numberX,startXmm,distanceXmm)"])) >>
exitWith ExitSuccess)
positions <-
case maybePrefixOf "custom-" (optLayout flags) of
Just customLayout ->
case reads $ "("++customLayout++")" of
[(desc,"")] -> return $ uncurry makeLayout desc
_ -> Exc.throwT $
"custom layouts must be formatted like " ++
"custom-(7,252,38),(3,8,66)"
Nothing ->
case lookup (optLayout flags) layouts of
Nothing ->
Exc.throwT $
"unknown layout " ++ show (optLayout flags) ++
", choose one of " ++ show (map fst layouts)
Just layout -> return layout
(pdfInput, pdfOutput) <-
case files of
[fileIn,fileOut] -> return (fileIn,fileOut)
_ -> Exc.throwT $ "two file names expected, but got: " ++ show files
(_inp, pdfTextHandle, _err, pdfTextPID) <-
lift $ runInteractiveProcess "pdftotext" [pdfInput, "-"] Nothing Nothing
stamps <-
Exc.mapExceptionT show $
Exc.fromEitherT $
liftM (Parser.parse parseStamps ("output of pdftotext " ++ show pdfInput) . lines) $
hGetContents pdfTextHandle
exitCodeToException $
rawSystem "pdfimages" [pdfInput, matrixCodePathPrefix]
codeFiles <- evalStateT (mapM (const loadMatrixCode) stamps) 0
imageFile <- Traversable.mapM (Exc.fromEitherT . readJpegFile) $ optPicture flags
dataDir <- lift getDataDir
let logoPath = dataDir ++ "/data/" ++ logoFileName
logoDrawing <-
liftM makeLogo $
do content <-
elaborateOnNotFound
("Download Deutsche Post logo with" :
unwords ("wget" : "-O" : logoPath : logoURL : []) :
[])
(readFile logoPath)
when (null content) (Exc.throwT "Deutsche Post logo uninitialized")
return content
let rect = PDFRect 0 0 (round $ a4width*pdfUnit) (round $ a4height*pdfUnit)
lift $ runPdf pdfOutput
(standardDocInfo {
author = toPDFString "Haskell Intermarke Creator",
compressed = False}) rect $
do pic <- Traversable.sequence $
liftM2 makePicture (optPicture flags) imageFile
codes <- sequence $
zipWith
(\n (bar,matrix) ->
liftM2 (,)
(makePicture ("bar"++showInt3 n) bar)
(makePicture ("matrix"++showInt3 n) matrix))
[0..] codeFiles
stampsToPDF positions $ zipWith
(\(bar,matrix) stamp ->
stamp{picture = pic,
barCode = bar,
matrixCode = matrix,
logo = logoDrawing})
codes stamps
exitCodeToException $ waitForProcess pdfTextPID