diff --git a/internetmarke.cabal b/internetmarke.cabal --- a/internetmarke.cabal +++ b/internetmarke.cabal @@ -1,10 +1,10 @@ Name: internetmarke -Version: 0.0.2 +Version: 0.0.3 License: GPL License-File: LICENSE Author: Henning Thielemann Maintainer: Henning Thielemann -Homepage: http://code.haskell.org/~thielema/internetmarke +Homepage: http://code.haskell.org/~thielema/internetmarke/ Category: Console, Graphics Synopsis: Shell command for constructing custom stamps for German Post Description: @@ -47,18 +47,19 @@ Executable internetmarke Build-Depends: - explicit-exception >= 0.0.2 && < 0.1, - mtl >= 1.1 && < 1.2, - process >= 1.0 && < 1.1, - parsec >= 2.1 && < 2.2, - HPDF >= 1.4 && < 1.5 + explicit-exception >=0.1 && <0.2, + transformers >=0.2 && <0.4, + utility-ht >=0.0.1 && <0.1, + process >=1.0 && <1.2, + parsec >=2.1 && <3.2, + HPDF >=1.4 && <1.5 If flag(splitBase) Build-Depends: - base >= 3 + base >=3 && <5 Else Build-Depends: - base >= 1.0 && < 2 + base >=1.0 && <2 GHC-Options: -Wall Hs-source-dirs: src diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -9,25 +9,26 @@ 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, ) +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 Control.Monad (liftM, liftM2, liftM3, when, guard, ) -import Control.Monad.Trans (lift, ) -import Control.Monad.State (StateT, evalStateT, gets, modify, ) import qualified Control.Monad.Exception.Synchronous as Exc -import Control.Exception (try, ioErrors, ) +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 { @@ -138,12 +139,7 @@ drawWithPage page $ applyMatrix (scale pdfUnit pdfUnit) >> (sequence_ $ zipWith stampToDraw positions stamps)) . - sliceVert (length positions) - --- Utility -sliceVert :: Int -> [a] -> [[a]] -sliceVert n = - map (take n) . takeWhile (not . null) . iterate (drop n) + sliceVertical (length positions) makeLayout :: (Int,PDFFloat,PDFFloat) -> (Int,PDFFloat,PDFFloat) -> [Point] makeLayout (ny,sy,dy) (nx,sx,dx) = @@ -157,13 +153,7 @@ ("Zweckform-4737", makeLayout (9,252,29.6) (3,8,66)) : [] --- Utility -maybePrefixOf :: Eq a => [a] -> [a] -> Maybe [a] -maybePrefixOf (x:xs) (y:ys) = guard (x==y) >> maybePrefixOf xs ys -maybePrefixOf [] ys = Just ys -maybePrefixOf _ [] = Nothing - -- * parse PDF text parseSatisfyLine :: (Show tok) => @@ -277,9 +267,7 @@ -- * load matrix codes showInt3 :: Int -> String -showInt3 n = - let str = show n - in replicate (3 - length str) '0' ++ str +showInt3 n = padLeft '0' 3 (show n) exitCodeToException :: IO ExitCode -> Exc.ExceptionalT String IO () @@ -311,35 +299,31 @@ 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 -> Exc.ExceptionalT String IO Bool +checkFilePrefix :: String -> FilePath -> IO Bool checkFilePrefix prefix path = - Exc.catchT - (Exc.fromEitherT $ try $ - withFile path ReadMode $ \h -> - fmap and $ mapM (\c -> fmap (c==) (hGetChar h)) prefix) - (\e -> - (case ioErrors e of - Just ioe -> - when (isDoesNotExistError ioe) - (Exc.throwT $ - "file " ++ show (maybe "" id (ioeGetFileName ioe)) ++ " not found for opening.\n" ++ - "This may indicate that there are no images with the expected sizes,\n" ++ - "which in turn may mean, that the Post company changed the sizes of the Data Code Matrix.") - _ -> return ()) >> - Exc.throwT (show e)) - -lazyMonadicAnd :: (Monad m) => m Bool -> m Bool -> m Bool -lazyMonadicAnd m0 m1 = - m0 >>= \b -> - if b - then m1 - else return False + withFile path ReadMode $ \h -> + fmap and $ mapM (\c -> fmap (c==) (hGetChar h)) prefix {- | We identify the matrix code according to its size. @@ -350,10 +334,17 @@ 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 $ - checkFilePrefix "P6\n30 156\n" (fn0++".ppm") `lazyMonadicAnd` - checkFilePrefix "P6\n156 156\n" (fn1++".ppm") + checkFile "P6\n30 156\n" (fn0++".ppm") + `MonadHT.andLazy` + checkFile "P6\n156 156\n" (fn1++".ppm") if b then do modify succ @@ -375,6 +366,10 @@ 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 @@ -461,17 +456,14 @@ let logoPath = dataDir ++ "/data/" ++ logoFileName logoDrawing <- liftM makeLogo $ - Exc.catchT - (do content <- Exc.mapExceptionT show $ - Exc.fromEitherT (try (readFile logoPath)) - when (null content) (Exc.throwT "Deutsche Post logo uninitialized") - return content) - (\msg -> - Exc.throwT $ - msg ++ - "\n\nDownload Deutsche Post Logo with\n" ++ - "wget -O " ++ logoPath ++ - " http://upload.wikimedia.org/wikipedia/de/4/42/Deutsche_Post-Logo.svg") + 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