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
|
{-# 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
import Data.Maybe
import Data.Monoid
import Text.Read hiding (get)
import Data.Either
import Data.List (isPrefixOf)
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
changeEditorStatus <- handleEditor
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")]
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 = 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
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
when (not $ maybe True null eTitle && null eText) $ case ePrintout of
Left err -> when (not automatic) . emitError $ "Could not save draft due to error parsing bbcode: " ++ show err
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) })
where
different s
| Just (_, s') <- lastSaved s = not $ and [ eTitle s == eTitle s'
, eText s == eText s'
]
| otherwise = True
discardAction = do
-- maybe (return ()) draftDelete . associatedDraft =<< currentValue editorStatus
saveAction False
modifyStatus $ const def
printAction = do
emitError "Printing not implemented"
onEvent (tick autoSaveTimer) (const $ saveAction True)
return saveButton # sink UI.enabled (saveable <$> editorStatus)
return printButton # sink UI.enabled (printable <$> editorStatus)
return discardButton # sink UI.enabled (discardable <$> editorStatus)
on UI.click saveButton . const $ saveAction False
on UI.click printButton $ const printAction
on UI.click discardButton $ const discardAction
return changeEditorStatus
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
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
time <- liftIO $ getCurrentTime
let newState = def
{ eTitle = fmap T.unpack title
, eText = "unimplemented" -- TODO: implement -- drops data as it is
, ePrintout = Right po
, associatedDraft = Just id
, lastSaved = Just (time, newState)
}
changeEditorState newState
table <- fatal' "Could not find draft table" =<< getElementById window "draftListBody"
initialContent <- toTable =<< drafts
return table # set children initialContent
recheckTimer <- timer
return recheckTimer # set interval 5000
start recheckTimer
onEvent (unionWith const (() <$ filterE concernsDrafts dataUpdate) (tick recheckTimer)) . const $ drafts >>= toTable >>= (\c -> return table # set children c)
where
concernsDrafts :: URI -> Bool
concernsDrafts (uriPath -> p)
| p == "drafts" = True
| "draft/" `isPrefixOf` p = True
| otherwise = False
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
|