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
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
|
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Main (main) where
import qualified Graphics.UI.Threepenny as UI
import Graphics.UI.Threepenny.Timer
import qualified Graphics.UI.Threepenny.Core as TP (Config, text)
import Graphics.UI.Threepenny.Core hiding (Config, text)
import Thermoprint.Client
import Thermoprint.Printout.BBCode
import Network.WebSockets
import Network.Socket (withSocketsDo)
import Network.URI
import qualified Options.Applicative as Opt
import System.Environment
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as CBS
import Data.Text (Text)
import qualified Data.Text as T
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Default.Class
import Data.Time
import Control.Concurrent
import Control.Exception
import Control.Monad.Catch
import Control.Applicative
import Control.Monad hiding (sequence)
import Data.Maybe
import Data.Monoid
import Text.Read hiding (get)
import Data.Either
import Data.List (isPrefixOf, sortBy)
import Data.Ord
import qualified Data.Function as F
import Data.Bool
import Data.Traversable (sequence)
import Data.Foldable
import Paths_thermoprint_webgui
import Debug.Trace
data Config = Config
{ tpConfig :: TP.Config
, server :: BaseUrl
}
main :: IO ()
main = withSocketsDo $ config >>= Opt.execParser . opts >>= (\c -> startGUI (tpConfig c) $ (withWebSocket setup) c)
where
opts config = Opt.info (Opt.helper <*> config)
( Opt.fullDesc
<> Opt.progDesc "Run a webgui to Thermoprint.Client"
)
config :: IO (Opt.Parser Config)
config = do
p <- fromMaybe 8023 . (readMaybe =<<) <$> lookupEnv portEnv
a <- fromMaybe "localhost" <$> lookupEnv hostEnv
static <- getDataDir
let
config = defaultConfig
{ jsCustomHTML = Just "index.html"
, jsStatic = Just static
}
return $ Config <$> ((\port addr -> config { jsPort = port, jsAddr = addr }) <$> optional (Opt.option Opt.auto $ port p) <*> optional (fmap CBS.pack $ Opt.strOption $ addr a))
<*> (BaseUrl Http
<$> Opt.strOption (Opt.long "target-addr" <> Opt.short 'A' <> Opt.metavar "HOST" <> Opt.help "Host to connect to" <> Opt.value "localhost" <> Opt.showDefault)
<*> Opt.option Opt.auto (Opt.long "target-port" <> Opt.short 'P' <> Opt.metavar "PORT" <> Opt.help "Port to connect to" <> Opt.value 3000 <> Opt.showDefault)
)
where
port def = Opt.long "port"
<> Opt.short 'p'
<> Opt.metavar "PORT"
<> Opt.help ("Port to bind to; default read from $" <> portEnv)
<> Opt.value def
<> Opt.showDefault
addr def = Opt.long "addr"
<> Opt.short 'a'
<> Opt.metavar "HOST"
<> Opt.help ("Host to listen on; default read from $" <> hostEnv)
<> Opt.value def
<> Opt.showDefault
hostEnv = "ADDR"
portEnv = "PORT"
setup :: Config -> Window -> Event (Either WebSocketException URI) -> UI ()
setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do
onEvent socketErr handleSocketErr
getElementById window "javascriptError" >>= maybeM delete
selectedPrinter <- handleJobTable
changeEditorStatus <- handleEditor selectedPrinter
handleDraftTable changeEditorStatus
where
handleSocketErr InvalidMessage = emitError "Received unparseable message from server-side websocket"
handleSocketErr ProcessDied = fatal "Thread handling server-side websocket died"
handleSocketErr (Unhandled e') = fatal $ "Unhandled error from server-side websocket: " ++ show e'
emitError str = void $ do
debug str
let
errors = maybe (fatal "No container for nonfatal errors found") return =<< getElementById window "errors"
errorsTab = maybe (fatal "Could not make nonfatal errors visible") return =<< getElementById window "errors-tab"
errors #+ [UI.li # set TP.text str]
errorsTab # set style [("display", "inline-block")]
runFunction $ switchTab "errors"
fatal :: String -> UI a
fatal str = do
(getBody window #) . set children =<< sequence [UI.p # set TP.text str # set UI.class_ "fatal"]
liftIO (throwIO $ ErrorCall str)
return undefined
maybeM = maybe $ return ()
fatal' :: String -> Maybe a -> UI a
fatal' str = maybe (fatal str) return
stepper' :: a -> UI (Behavior a, a -> IO ())
stepper' init = do
(statusEvent, triggerStatusChange) <- liftIO newEvent
status <- stepper init statusEvent
return (status, triggerStatusChange)
Client{..} = mkClient (Nat $ either (fatal . ("Error while communicating to Thermoprint.Server: " ++) . show) return <=< liftIO . runEitherT) server
handleEditor selectedPrinter = do
title <- fatal' "Could not find editor title field" =<< getElementById window "editorTitle"
text <- fatal' "Could not find editor text field" =<< getElementById window "editorText"
status <- fatal' "Could not find editor status field" =<< getElementById window "editorStatus"
bbcodeStatus <- fatal' "Could not find editor bbcode status field" =<< getElementById window "bbcodeStatus"
saveButton <- fatal' "Could not find editor save button" =<< getElementById window "saveButton"
printButton <- fatal' "Could not find editor print button" =<< getElementById window "printButton"
discardButton <- fatal' "Could not find editor discard button" =<< getElementById window "discardButton"
(editorStatus, fmap liftIO -> changeEditorStatus) <- stepper' def
saveDraft <- do
saveDraft <- fatal' "Could not find save switch" =<< getElementById window "saveDraft"
flip stepper (UI.checkedChange saveDraft) =<< saveDraft # get UI.checked
let
modifyStatus f = changeEditorStatus . f =<< currentValue editorStatus
on UI.valueChange title $ \str -> modifyStatus (\x -> x { eTitle = if null str then Nothing else Just str })
on UI.valueChange text $ \str -> modifyStatus (\x -> x { eText = str })
on UI.valueChange text $ \str -> modifyStatus (\x -> x { ePrintout = bbcode $ T.pack str })
return title # sink UI.value (fromMaybe "" . eTitle <$> editorStatus)
return text # sink UI.value (eText <$> editorStatus)
return status # sink TP.text (toStatusString <$> editorStatus)
return bbcodeStatus # sink TP.text (toStatusString' . ePrintout <$> editorStatus)
autoSaveTimer <- timer # set interval 5000
start autoSaveTimer
let
saveAction automatic = do
s@(EditorState{..}) <- currentValue editorStatus
r <- when' (not $ maybe True null eTitle && null eText) $ case ePrintout of
Left err -> do
when (not automatic) . emitError $ "Could not save draft due to error parsing bbcode: " ++ show err
return False
Right p -> do
draftId <- case associatedDraft of
Nothing -> draftCreate (T.pack <$> eTitle) p
Just i -> i <$ when (different s) (draftReplace i (T.pack <$> eTitle) p)
time <- liftIO getCurrentTime
modifyStatus (\x -> x { associatedDraft = Just draftId, lastSaved = Just (time, s) })
return True
return $ fromMaybe False r
where
different s
| Just (_, s') <- lastSaved s = not $ and [ eTitle s == eTitle s'
, eText s == eText s'
]
| otherwise = True
when' :: Applicative m => Bool -> m a -> m (Maybe a)
when' True = fmap Just
when' False = const $ pure Nothing
clearAction = do
-- maybe (return ()) draftDelete . associatedDraft =<< currentValue editorStatus
saved <- saveAction False
when saved $ discardAction
discardAction = modifyStatus $ const def
printAction = do
EditorState{..} <- currentValue editorStatus
case ePrintout of
Right po -> case associatedDraft of
Just dId -> do
saved <- saveAction False
when saved $ runFunction . focusJob =<< draftPrint dId =<< currentValue selectedPrinter
Nothing -> do
runFunction . focusJob =<< flip jobCreate po =<< currentValue selectedPrinter
Left err -> emitError $ "Could not print draft due to error parsing bbcode: " ++ show err
onEvent (whenE saveDraft $ tick autoSaveTimer) (const . void $ saveAction True)
return saveButton # sink UI.enabled ((&&) <$> (saveable <$> editorStatus) <*> saveDraft)
return printButton # sink UI.enabled (printable <$> editorStatus)
return discardButton # sink UI.enabled (discardable <$> editorStatus)
return discardButton # sink UI.text (bool "Discard" "Save & Clear" <$> saveDraft)
return printButton # sink UI.text (maybe "Print" (\(PrinterId i) -> "Print on " ++ show i) <$> selectedPrinter)
on (whenE saveDraft . UI.click) saveButton . const . void $ saveAction False
on UI.click printButton $ const printAction
on (whenE (not <$> saveDraft) . UI.click) discardButton $ const discardAction
on (whenE saveDraft . UI.click) discardButton $ const clearAction
return modifyStatus
saveable s@EditorState{..} = isRight ePrintout && discardable s
printable EditorState{..} = isRight ePrintout && not (null eText)
discardable EditorState{..} = not (maybe True null eTitle && null eText)
handleDraftTable changeEditorState = do
allowDeletion <- fatal' "Could not find deletion switch" =<< getElementById window "allowDeletion"
deletion' <- allowDeletion # get UI.checked
deletion <- stepper deletion' $ UI.checkedChange allowDeletion
let
toTable :: Map DraftId (Maybe DraftTitle) -> UI [Element]
toTable = mapM toLine . Map.toList
toLine (id@(DraftId (show -> tId)), fromMaybe "" . fmap T.unpack -> title) = do
id' <- UI.td # set TP.text tId
title' <- UI.td # set TP.text title
delete <- UI.button
# set TP.text "Delete"
# sink UI.enabled deletion
on UI.click delete . const $ draftDelete id >> changeEditorState (\s@(EditorState{..}) -> if associatedDraft == Just id then def else s)
load <- UI.button
# set TP.text "Load"
on UI.click load . const $ loadDraft id
actions <- UI.td # set children [load, delete]
UI.tr # set children [id', title', actions]
loadDraft id = do
(title, po) <- draft id
let
t = cobbcode po
case t of
Left (show -> errStr) -> emitError $ "Could not load draft: " ++ errStr
Right text -> do
time <- liftIO $ getCurrentTime
let newState = def
{ eTitle = fmap T.unpack title
, eText = T.unpack text
, ePrintout = Right po
, associatedDraft = Just id
, lastSaved = Just (time, newState)
}
changeEditorState (const newState)
runFunction $ switchTab "editor"
table <- fatal' "Could not find draft table" =<< getElementById window "draftListBody"
initialContent <- toTable =<< drafts
return table # set children initialContent
update <- do
-- recheckTimer <- timer
-- return recheckTimer # set interval 5000
-- start recheckTimer
-- return $ unionWith const (() <$ filterE concernsDrafts dataUpdate) (tick recheckTimer)
return $ filterE concernsDrafts dataUpdate
onEvent update . const $ drafts >>= toTable >>= (\c -> return table # set children c)
concernsDrafts :: URI -> Bool
concernsDrafts (uriPath -> p)
| p == "drafts" = True
| "draft/" `isPrefixOf` p = True
| otherwise = False
concernsPrinters :: URI -> Bool
concernsPrinters (uriPath -> p)
| p == "printers" = True
| "jobs/" `isPrefixOf` p = True
| otherwise = False
handleJobTable = do
allowAbortion <- do
allowAbortion <- fatal' "Could not find abortion switch" =<< getElementById window "allowAbortion"
flip stepper (UI.checkedChange allowAbortion) =<< (allowAbortion # get UI.checked)
(selectedPrinter, updatePrinter) <- do
autoselectPrinter <- fatal' "Could not find printer autoselect switch" =<< getElementById window "autoselectPrinter"
(selectedPrinter, printerSelect) <- stepper' Nothing
return autoselectPrinter # sink UI.checked (isNothing <$> selectedPrinter)
let
-- getSelectedPrinter :: UI (Maybe PrinterId)
getSelectedPrinter = (fmap PrinterId . join . readMaybe) <$> callFunction (ffi "$('input[name=printer]:checked', '#printers').val()")
updatePrinterSelect = getSelectedPrinter >>= liftIO . printerSelect
on (domEvent "change") autoselectPrinter $ const updatePrinterSelect
return (selectedPrinter, updatePrinterSelect)
let
-- getServerState :: UI [(PrinterId, PrinterStatus, [(JobId, UTCTime, JobStatus)])]
getServerState = map mangleTuple . Map.toList <$> (Map.traverseWithKey (\pId status -> (,) status <$> getJobState pId) =<< printers)
-- getJobState :: PrinterId -> UI [(JobId, UTCTime, JobStatus)]
getJobState pId = toList <$> jobs (Just pId) Nothing Nothing
mangleTuple (a, (b, c)) = (a, b, c)
thrd (_, _, c) = c
-- toTable :: [(PrinterId, PrinterStatus, [(JobId, UTCTime, JobStatus)])] -> UI [Element]
toTable = fmap concat . mapM toSubTable
-- toSubTable :: (PrinterId, PrinterStatus, [(JobId, UTCTime, JobStatus)]) -> UI [Element]
toSubTable (rPId@(PrinterId pId), pStatus, (sortBy (queueSort `F.on` thrd) -> jobs)) = do
pId' <- UI.td # set UI.text (show pId)
pStatus' <- UI.td # set UI.text (show pStatus)
let selectId = "printer" ++ show pId
checked <- (== Just rPId) <$> currentValue selectedPrinter
pSelect <- UI.input # set UI.type_ "radio" # set UI.name "printer" # set UI.value (show $ Just pId) # set UI.id_ selectId # set UI.checked checked
on (domEvent "change") pSelect $ const updatePrinter
pSelectL <- UI.label # set UI.for selectId # set UI.text "Use for new jobs"
pSelect' <- UI.td # set children [pSelect, pSelectL]
pFiller <- UI.td # set UI.colspan 2
let
toLine ((JobId jId), time, status) = do
jPId <- UI.td
jId' <- UI.td # set UI.text (show jId)
jStatus' <- UI.td # set UI.text (show status)
abortButton <- UI.button # sink UI.enabled allowAbortion # set UI.text "Abort"
actions <- UI.td # set children [abortButton]
UI.tr # set UI.id_ ("job" ++ show jId) # set children [jPId, jId', jStatus', actions]
(:) <$> UI.tr # set children [pId', pFiller, pStatus', pSelect'] <*> mapM toLine jobs
update <- do
-- recheckTimer <- timer
-- return recheckTimer # set interval 5000
-- start recheckTimer
-- return $ unionWith const (() <$ filterE concernsPrinters dataUpdate) (tick recheckTimer)
return $ filterE concernsPrinters dataUpdate
table <- fatal' "Could not find printer table" =<< getElementById window "printerListBody"
initialContent <- toTable =<< getServerState
return table # set children initialContent
onEvent update . const $ getServerState >>= toTable >>= (\c -> return table # set children c) >> updatePrinter
return selectedPrinter
focusJob :: JobId -> JSFunction ()
focusJob (JobId (fromInteger -> i)) = ffi "alert(%1)" (i :: Int) -- FIXME
switchTab :: String -> JSFunction ()
switchTab = ffi "$(%1).first().trigger(\"click\")" . (\p -> "a[href='#" ++ p ++ "']")
data EditorState = EditorState
{ eTitle :: Maybe String
, eText :: String
, ePrintout :: Either BBCodeError Printout
, lastSaved :: Maybe (UTCTime, EditorState)
, associatedDraft :: Maybe DraftId
}
deriving (Show)
instance Default EditorState where
def = EditorState
{ eTitle = Nothing
, eText = ""
, ePrintout = Right mempty
, lastSaved = Nothing
, associatedDraft = Nothing
}
toStatusString :: EditorState -> String
toStatusString EditorState{..}
| null eTitle
, null eText = "Draft is empty"
| Just (DraftId (show -> id)) <- associatedDraft
, Just (t, _) <- lastSaved = "Last saved: " ++ formatTime defaultTimeLocale "%F %X" t ++ " as #" ++ id
| otherwise = "Draft was never saved successfully"
toStatusString' :: Either BBCodeError a -> String
toStatusString' (Right _) = ""
toStatusString' (Left e) = show e
data WebSocketException = ProcessDied | InvalidMessage | Unhandled SomeException
deriving (Show)
instance Exception WebSocketException
withWebSocket :: (Config -> Window -> Event (Either WebSocketException URI) -> UI void) -> Config -> Window -> UI ()
withWebSocket setup c@(Config{..}) w = do
(dataUpdate, triggerData) <- liftIO newEvent
let
rcvEvents = runClient (baseUrlHost server) (baseUrlPort server) "/" $ forever . (triggerData . maybe (Left InvalidMessage) Right . parseURIReference . T.unpack <=< receiveData)
liftIOLater . void $ forkFinally rcvEvents (triggerData . Left . either Unhandled (const ProcessDied))
void $ setup c w dataUpdate
|