aboutsummaryrefslogtreecommitdiff
path: root/tprint/src/Main.hs
blob: aed0388b5676c2f8e5b45e4fdd6dcd5be9e46cf7 (plain)
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
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TupleSections #-}

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.Text.Encoding as T
import qualified Data.ByteString.Lazy.Char8 as Lazy (ByteString)
import qualified Data.ByteString.Lazy as LBS
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 Data.Bool

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', eitherDecodeStrict')

import Text.Editor (runUserEditorDWIM, jsonTemplate, plainTemplate)

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

withPrintout :: Input -> (Printout -> IO a) -> IO a
withPrintout input a = withInput input $ \inH -> do
  let
    p'
      | (BBCode, _) <- input = either throwM return . bbcode =<< T.hGetContents inH
      | otherwise = either (throwM . userError) return . eitherDecode' =<< LCBS.hGetContents inH
  a =<< (force <$> p')

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

blockLoop :: Client IO -> Handle -> JobId -> IO ()  
blockLoop client@Client{..} out jId@(JobId n) = do
  threadDelay (10^6)
  status <- jobStatus jId
  case status of
    Done -> hPutStrLn out $ show n
    Failed err -> throwM err
    _ -> blockLoop client out jId

tprint :: TPrint -> Client IO -> Handle -> IO ()

-- Query
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           = T.hPutStrLn out =<< either throwM return (cobbcode p)

tprint TPrint{ operation = Draft{..}, ..} Client{..} out = draft draftId >>= format
  where format d@(fromMaybe "" . fmap T.unpack -> t, p)
          | (JSON, _) <- output = LCBS.hPutStrLn out $ encodePretty d
          | otherwise           = do
              hPutStrLn out t
              hPutStrLn out ""
              T.hPutStrLn out =<< either throwM return (cobbcode p)

-- Mutate
tprint TPrint{ operation = JobCreate{..}, ..} client@Client{..} out = withPrintout input $ \p -> do
  let
    block'
      | block = blockLoop client out
      | otherwise = hPutStrLn out . show
  unless dryRun $ block' =<< jobCreate printer p

tprint TPrint{ operation = JobDelete{..}, ..} Client{..} _ = unless dryRun $ jobDelete jobId

tprint TPrint{ operation = DraftCreate{..}, ..} Client{..} out = withPrintout input $ \p -> do
  unless dryRun $ hPutStrLn out . show =<< draftCreate draftTitle p

tprint TPrint{ operation = DraftReplace{..}, ..} Client{..} _ = withPrintout input $ \p -> do
  unless dryRun $ draftReplace draftId draftTitle p

tprint TPrint{ operation = DraftEdit{..}, ..} Client{..} out = do
  (dTitle, dContent) <- editDraft (fst output) =<< maybe (return mempty) draft mDraftId
  unless dryRun $ maybe (\t c -> hPutStrLn out . show =<< draftCreate t c) draftReplace mDraftId dTitle dContent

tprint TPrint{ operation = DraftDelete{..}, ..} Client{..} _ = unless dryRun $ draftDelete draftId

tprint TPrint{ operation = DraftPrint{..}, ..} client@Client{..} out = do
  let block'
        | block = blockLoop client out
        | otherwise = hPutStrLn out . show
  unless dryRun $ block' =<< draftPrint draftId printer


tprint _ _ _ = undefined


editDraft :: Format -> (Maybe DraftTitle, Printout) -> IO (Maybe DraftTitle, Printout)
editDraft fmt d@(fromMaybe T.empty -> dTitle, dContent) = do
  let
    content
      | JSON <- fmt = return . LBS.toStrict $ encodePretty d
      | otherwise   = do
          c <- either throwM return (cobbcode dContent)
          return . T.encodeUtf8 $ dTitle <> T.pack "\n--- ^ Title ---\n" <> c
    tmpl
      | JSON <- fmt = jsonTemplate
      | otherwise   = plainTemplate
    parse
      | JSON <- fmt = either (throwM . userError) return . eitherDecodeStrict'
      | otherwise   = (\(t:_:(T.unlines -> c)) -> (massage t, ) <$> either throwM return (bbcode c)) . T.lines . T.decodeUtf8
    massage (T.strip -> t)
      | T.null t = Nothing
      | otherwise = Just t
  parse =<< runUserEditorDWIM tmpl =<< content