{- | 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.Cmd (rawSystem, ) import System.Process (runInteractiveProcess, waitForProcess, ) import System.IO (withFile, hGetContents, hGetChar, IOMode(ReadMode), ) import System.IO.Error (ioeGetFileName, isDoesNotExistError, 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, ) 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 width 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) parseSatisfyLine null return (sprice, sdate) textsB <- Parser.count (length textsA) $ do scode <- parseSatisfyLine (const True) parseSatisfyLine null return scode textsC <- Parser.count (length textsA) $ do sdomain <- parseSatisfyLine (const True) 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 Parser.char '.' fraction <- Parser.many1 Parser.digit return $ read $ integer ++ "." ++ fraction parsePoint :: Parser.CharParser st Point parsePoint = do x <- parseFixedPoint Parser.char ',' y <- parseFixedPoint Parser.spaces return $ x:+(-y) parsePolygon :: Parser.CharParser st (Draw ()) parsePolygon = do Parser.string "points=\"" (p:ps) <- Parser.many1 $ do p <- parsePoint return (2.562571*p + (86.77773:+(-644.0665))) Parser.string "\"" return $ beginPath p >> addPolygonToPath ps >> fillPath parsePath :: Parser.CharParser st (Draw ()) parsePath = do Parser.string "d=\"" path <- Parser.many1 $ Parser.choice $ (do Parser.char 'M' Parser.spaces liftM beginPath parsePoint) : (do Parser.char 'z' Parser.spaces return closePath) : (do Parser.char 'L' Parser.spaces liftM addLineToPath parsePoint) : (do Parser.char 'C' Parser.spaces liftM3 addBezierCubic parsePoint parsePoint parsePoint) : [] 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