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
|
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.ByteString.Lazy.Char8 as Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as LCBS
import Data.Time
import Data.Foldable
import Data.List
import Data.Monoid
import Data.Maybe
import Data.Either
import Control.Monad
import Control.Monad.Catch
import Control.DeepSeq
import Control.Concurrent (threadDelay)
import Text.Show.Pretty (dumpStr)
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Aeson (eitherDecode')
import System.IO
import Thermoprint.Printout.BBCode
import Thermoprint.Client
import Options
import Debug.Trace
main :: IO ()
main = withArgs (main' <=< dumpOpts)
where
dumpOpts c@(TPrint{..}) = c <$ when (dumpOptions) (hPutStrLn stderr $ dumpStr c)
main' config@(TPrint{..}) = withOutput config $ tprint config (mkClient' baseUrl)
withOutput :: TPrint -> (Handle -> IO a) -> IO a
withOutput TPrint{..}
| (_, WriteFile f) <- output = withFile f WriteMode
| otherwise = ($ stdout)
withInput :: Input -> (Handle -> IO a) -> IO a
withInput (_, Stdin) = ($ stdin)
withInput (_, ReadFile f) = withFile f ReadMode
humanJobStatus :: JobStatus -> Maybe PrinterId -> String
humanJobStatus (Queued (PrinterId n)) Nothing = "queued at printer #" ++ show n
humanJobStatus (Queued _) _ = "queued"
humanJobStatus (Printing (PrinterId n)) Nothing = "printing on printer #" ++ show n
humanJobStatus (Printing _) _ = "printing"
humanJobStatus (Done) _ = "finished successfully"
humanJobStatus (Failed err) _ = "failed: " ++ show err
tprint :: TPrint -> Client IO -> Handle -> IO ()
tprint TPrint{ operation = Printers, ..} Client{..} out = printers >>= format
where format ps
| (Human, _) <- output = mapM_ (\(PrinterId n, st) -> hPutStrLn out $ show n ++ "\t" ++ humanStatus st) $ Map.toAscList ps
| (JSON , _) <- output = LCBS.hPutStrLn out $ encodePretty ps
| otherwise = hPutStrLn out . dumpStr $ Map.toAscList ps
humanStatus (Busy (JobId n)) = "busy printing job #" ++ show n
humanStatus (Available) = "available"
tprint TPrint{ operation = Jobs{..}, ..} Client{..} out = jobs printer jobRange timeRange >>= format
where format js
| (Human, _) <- output = mapM_ (\((JobId n), created, status) -> hPutStrLn out $ show n ++ "\t" ++ formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S %Z" created ++ "\t" ++ humanJobStatus status printer) . sortBy jSort $ toList js
| (JSON, _) <- output = LCBS.hPutStrLn out $ encodePretty js
| otherwise = hPutStrLn out . dumpStr $ toList js
jSort (id, time, status) (id', time', status') = queueSort status status' <> compare time' time <> compare id id'
tprint TPrint{ operation = Drafts, ..} Client{..} out = drafts >>= format
where format ds
| (Human, _) <- output = mapM_ (\(DraftId n, fromMaybe "" . fmap T.unpack -> t) -> hPutStrLn out $ show n ++ "\t" ++ t) $ Map.toAscList ds
| (JSON, _) <- output = LCBS.hPutStrLn out $ encodePretty ds
| otherwise = hPutStrLn out . dumpStr $ Map.toAscList ds
tprint TPrint{ operation = JobStatus{..}, ..} Client{..} out = jobStatus jobId >>= format
where format s
| (Human, _) <- output = hPutStrLn out $ humanJobStatus s Nothing
| (JSON, _) <- output = LCBS.hPutStrLn out $ encodePretty s
| otherwise = hPutStrLn out $ dumpStr s
tprint TPrint{ operation = Job{..}, ..} Client{..} out = job jobId >>= format
where format p
| (JSON, _) <- output = LCBS.hPutStrLn out $ encodePretty p
| otherwise <- output = T.hPutStrLn out =<< either throwM return (cobbcode p)
tprint TPrint{ operation = JobCreate{..}, ..} Client{..} out = withInput input $ \inH -> do
let
p'
| (BBCode, _) <- input = either throwM return . bbcode =<< T.hGetContents inH
| otherwise = either (throwM . userError) return . eitherDecode' =<< LCBS.hGetContents inH
blockLoop =<< jobCreate printer . force =<< p'
where
blockLoop jId
| block = do
threadDelay (10^6)
status <- jobStatus jId
case status of
Done -> return ()
Failed err -> throwM err
_ -> blockLoop jId
| otherwise = return ()
tprint _ _ _ = undefined
|
