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
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
|
{-# LANGUAGE RecordWildCards, RankNTypes #-}
import Thermoprint
import Thermoprint.Api
import qualified BBCode (parse, make)
import Options.Applicative
import Data.Either
import Data.Maybe
import Control.Monad
import Control.Monad.Trans.Either
import System.IO
import qualified System.IO as IO
import System.Exit
import System.Environment
import Data.Proxy
import Servant.API
import Servant.Client
import Data.Int (Int64)
thermoprintApi :: Proxy ThermoprintApi
thermoprintApi = Proxy
data TPrint = TPrint TPrintMode TPrintOptions
data TPrintOptions = TPrintOptions
{ baseUrl :: BaseUrl
}
data TPrintMode = Print PrintOptions
| PrintDraft PrintDraftOptions
| Query QueryOptions
| Add AddOptions
| Get GetOptions
| Write WriteOptions
| Del DelOptions
data PrintOptions = PrintOptions
{ printerId :: Integer
, dryRun :: Bool
}
data PrintDraftOptions = PrintDraftOptions
{ printOptions :: PrintOptions
, pDraftId :: Int64
, deleteAfter :: Bool
}
data QueryOptions = QueryOptions
data AddOptions = AddOptions
{ title :: String
}
data GetOptions = GetOptions
{ gDraftId :: Int64
, getTitle :: Bool
}
data WriteOptions = WriteOptions
{ wDraftId :: Int64
, newTitle :: Maybe String
}
data DelOptions = DelOptions
{ dDraftId :: Int64
}
main :: IO ()
main = do
envUrl <- lookupEnv "TPRINT"
let
defaultUrl = fromMaybe (BaseUrl Http "localhost" 8080) (envUrl >>= either (const Nothing) Just . parseBaseUrl)
execParser (opts defaultUrl) >>= main'
where
opts url = info (helper <*> opts' url) (
fullDesc
<> header "tprint - A cli tool for interfacing with the REST api as provided by thermoprint-servant"
)
opts' url = TPrint
<$> modeSwitch
<*> commonOpts url
commonOpts url = TPrintOptions
<$> option baseUrlReader (
long "url"
<> short 'u'
<> metavar "URL"
<> help "The base url of the api. Also reads TPRINT from environment."
<> value url
<> showDefaultWith showBaseUrl
)
baseUrlReader = str >>= either readerError return . parseBaseUrl
modeSwitch = subparser $ mconcat $ map (\(n, f, h) -> command n $ info (helper <*> f) $ progDesc h)
[ ("print", print, "Read bbcode from stdin and send it to be printed")
, ("print-draft", printD, "Send a draft to be printed")
, ("query", query, "List drafts")
, ("add", add, "Read bbcode from stdin and add it as a draft")
, ("get", get, "Get a draft and print it as bbcode to stdout")
, ("write", write, "Read bbcode from stdin and overwrite an existing draft")
, ("del", del, "Delete a draft")
]
draftN s = option auto (
long "draft"
<> short 'n'
<> metavar "INT"
<> help s
)
print = Print <$> print'
print' = PrintOptions
<$> option auto (
long "printer"
<> short 'p'
<> metavar "INT"
<> help "The number of the printer to use"
<> value 0
<> showDefault
)
<*> flag False True (
long "dry-run"
<> short 'd'
<> help "Instead of sending data to printer output the parsed stream to stderr"
<> showDefault
)
printD = (PrintDraft <$>) $ PrintDraftOptions
<$> print'
<*> draftN "The number of the draft to print"
<*> flag False True (
long "delete"
<> help "Delete the draft after printing"
)
query = (Query <$>) $ pure QueryOptions
add = (Add <$>) $ AddOptions
<$> strArgument (
metavar "TITLE"
<> help "The human readable title for the new draft"
)
get = (Get <$>) $ GetOptions
<$> draftN "The number of the draft to retrieve"
<*> flag False True (
long "title"
<> short 't'
<> help "Get title instead of content"
)
write = (Write <$>) $ WriteOptions
<$> draftN "The number of the draft to overwrite"
<*> optional ( strArgument (
metavar "TITLE"
<> help "The human readable title for the updated draft (defaults to retrieving the old one before overwriting)"
)
)
del = (Del <$>) $ DelOptions
<$> draftN "The number of the draft to delete"
either' :: (a -> String) -> EitherT a IO b -> IO b
either' f a = either (die . f) return =<< runEitherT a
main' (TPrint mode TPrintOptions{..}) = do
let
-- print :: Integer -> Block String -> EitherT ServantError IO ()
-- queryDrafts :: EitherT ServantError IO [(Integer, String)]
-- addDraft :: (String, Block String) -> EitherT ServantError IO Int64
-- getDraft :: Int64 -> EitherT ServantError IO (String, Block String)
-- writeDraft :: Int64 -> (String, Block String) -> EitherT ServantError IO Int64
-- delDraft :: Int64 -> EitherT ServantError IO ()
(print :<|> queryDrafts :<|> addDraft :<|> getDraft :<|> writeDraft :<|> delDraft) = client thermoprintApi baseUrl
case mode of
Print PrintOptions{..} -> do
input <- BBCode.parse `liftM` getContents
input' <- either (die . ("Parse error: " ++)) return input
case dryRun of
False -> do
res <- runEitherT $ print printerId input'
case res of
Left err -> hPutStrLn stderr $ show err
Right _ -> exitSuccess
True -> do
hPutStrLn stderr $ show input'
PrintDraft PrintDraftOptions{..} -> do
let PrintOptions{..} = printOptions
(_, input) <- either' (\e -> "Error while retrieving draft: " ++ show e) $ getDraft pDraftId
case dryRun of
False -> do
res <- runEitherT $ print printerId input
case res of
Left err -> hPutStrLn stderr $ show err
Right _ -> when deleteAfter $ either' (\e -> "Error while deleting draft: " ++ show e) $ delDraft pDraftId
True -> do
hPutStrLn stderr $ show input
Query QueryOptions -> do
drafts <- either' (\e -> "Error while retrieving drafts: " ++ show e) queryDrafts
mapM_ (\(n, t) -> putStrLn $ "[" ++ show n ++ "]\n" ++ (unlines $ map (\s -> " " ++ s) $ lines t)) drafts
when (null drafts) $ hPutStrLn stderr "No drafts"
Add AddOptions{..} -> do
input <- BBCode.parse `liftM` getContents
input' <- either (die . ("Parse error: " ++)) return input
n <- either' (\e -> "Error while saving draft: " ++ show e) $ addDraft (title, input')
IO.print n
Get GetOptions{..} -> do
(title, draft) <- either' (\e -> "Error while retrieving draft: " ++ show e) $ getDraft gDraftId
case getTitle of
False -> putStr $ BBCode.make draft
True -> putStrLn title
Write WriteOptions{..} -> do
input <- BBCode.parse `liftM` getContents
input' <- either (die . ("Parse error: " ++)) return input
title <- case newTitle of
Just new -> return new
Nothing -> fst <$> (either' (\e -> "Error while retrieving draft: " ++ show e) $ getDraft wDraftId)
either' (\e -> "Error while overwriting draft: " ++ show e) $ writeDraft wDraftId (title, input')
Del DelOptions{..} -> either' (\e -> "Error while deleting draft: " ++ show e) $ delDraft dDraftId
_ -> undefined
|
