aboutsummaryrefslogtreecommitdiff
path: root/webgui/src/Main.hs
blob: a295fd92802b268c2fd5fa061a1a517890079f0c (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
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
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
{-# 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 qualified Data.ByteString.Lazy.Char8 as CLBS

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.Set        (Set)
import qualified Data.Set as Set

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"

fatal :: String -> UI a
fatal str = do
  window <- askWindow
  (getBody window #) . set children =<< sequence [UI.p # set TP.text str # set UI.class_ "fatal"]
  liftIO (throwIO $ ErrorCall str)
  return undefined

setup :: Config -> Window -> Event (Either WebSocketException URI) -> UI ()
setup Config{..} window (split -> (socketErr, dataUpdate)) = void $ do
  onEvent socketErr handleSocketErr

  getElementById window "javascriptError" >>= maybeM delete

  (focusedJobs, changeFocusedJobs) <- stepper' Set.empty
  let modifyFocusedJobs f = changeFocusedJobs . f =<< currentValue focusedJobs
      fJobs = (focusedJobs, liftIO . modifyFocusedJobs)
  
  selectedPrinter <- handleJobTable fJobs

  changeEditorStatus <- handleEditor selectedPrinter fJobs

  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"

    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 (hoistNat $ Nat liftIO) server
    withFatal :: EitherT ServantError UI a -> UI a
    withFatal a = either (fatal . ("Error while communicating to Thermoprint.Server: " ++) . show) return =<< runEitherT a

    handleEditor selectedPrinter (_, modifyFocusedJobs) = 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 -> withFatal $ draftCreate (T.pack <$> eTitle) p
                Just i -> i <$ when (different s) (withFatal $ 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
          let
            reFocusJob jId = modifyFocusedJobs (const $ Set.singleton jId)
          case ePrintout of
            Right po -> case associatedDraft of
              Just dId -> do
                saved <- saveAction False
                when saved $ reFocusJob =<< withFatal . draftPrint dId =<< currentValue selectedPrinter
              Nothing -> do
                reFocusJob =<< withFatal . 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
      (marking, (liftIO .) -> updateMarking) <- stepper' $ Set.empty

      
      enactDeletion <- fatal' "Could not find deletion button" =<< getElementById window "enactDeletion"
      on UI.click enactDeletion . const $ currentValue marking >>= mapM_ (runEitherT . draftDelete) >> updateMarking Set.empty
      -- deletion' <- allowDeletion # get UI.checked
      let
        updateMarking' = callFunction (mangle <$> ffi getChecked) >>= updateMarking
          where mangle = Set.fromList . map DraftId . fromMaybe [] . parse
                getChecked = "$.makeArray($('input[name=draftMark]:checked').map(function() {return $(this).val()}))"
                parse str
                  | [(i, rs)] <- [ (i, rs) | (i, ',' : rs) <- reads str ] = (:) <$> Just i <*> parse rs
                  | r@([_]) <- [ i | (i, "") <- reads str ] = Just r
                  | otherwise = Nothing

        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
          mark <- UI.input
            # set UI.type_ "checkbox"
            # set UI.name "draftMark"
            # set UI.id_ ("draftMark" ++ tId)
            # set UI.value tId
            # sink UI.checked (Set.member id <$> marking)
          on UI.checkedChange mark . const $ updateMarking'
          mark' <- UI.span #+ [ return mark
                              , UI.label # set UI.for ("draftMark" ++ tId) # set UI.text "Mark"
                              ] # set UI.class_ "mark"
          -- 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 [mark', load]
          UI.tr # set children [id', title', actions]
        loadDraft id = do
          (title, po) <- withFatal $ 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 =<< withFatal 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 $ withFatal 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
      | p == "jobs" = True
      | otherwise = False

    handleJobTable (focusedJobs, _) = do
      -- allowAbortion <- do
      --   allowAbortion <- fatal' "Could not find abortion switch" =<< getElementById window "allowAbortion"
      --   flip stepper (UI.checkedChange allowAbortion) =<< (allowAbortion # get UI.checked)
      (marking, (liftIO .) -> updateMarking) <- stepper' $ Set.empty
      
      enactAbortion <- fatal' "Could not find deletion button" =<< getElementById window "enactAbortion"
      on UI.click enactAbortion . const $ currentValue marking >>= mapM_ (runEitherT . jobDelete) >> updateMarking Set.empty
        
      (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
        updateMarking' = callFunction (mangle <$> ffi getChecked) >>= updateMarking
          where mangle = Set.fromList . map JobId . fromMaybe [] . parse
                getChecked = "$.makeArray($('input[name=jobMark]:checked').map(function() {return $(this).val()}))"
                parse str
                  | [(i, rs)] <- [ (i, rs) | (i, ',' : rs) <- reads str ] = (:) <$> Just i <*> parse rs
                  | r@([_]) <- [ i | (i, "") <- reads str ] = Just r
                  | otherwise = Nothing

        -- getServerState :: UI [(PrinterId, PrinterStatus, [(JobId, UTCTime, JobStatus)])]
        getServerState = map mangleTuple . Map.toList <$> (Map.traverseWithKey (\pId status -> (,) status <$> getJobState pId) =<< withFatal printers)
        -- getJobState :: PrinterId -> UI [(JobId, UTCTime, JobStatus)]
        getJobState pId = toList <$> withFatal (jobs (Just pId) Nothing Nothing)
        mangleTuple (a, (b, c)) = (a, b, c)

        -- jobSort :: (JobId, UTCTime, JobStatus) -> (JobId, UTCTime, JobStatus) -> Ordering
        jobSort (id, time, status) (id', time', status') = queueSort status status' <> compare time' time <> compare id id'
          where
            compare' :: Ord a => a -> a -> Ordering
            compare'
              | (Queued _) <- status = compare
              | otherwise = flip compare

        -- 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 jobSort -> 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 (rJId@(JobId jId), time, status) = do
              jPId <- UI.td
              jId' <- UI.td # set UI.text (show jId)
              jStatus' <- UI.td # set UI.text (show status)
              time' <- UI.td # set UI.text (formatTime defaultTimeLocale "%F %X" time)
              mark <- UI.input
                # set UI.type_ "checkbox"
                # set UI.name "jobMark"
                # set UI.id_ ("jobMark" ++ show jId)
                # set UI.value (show jId)
                # sink UI.checked (Set.member rJId <$> marking)
              on UI.checkedChange mark . const $ updateMarking'
              mark' <- UI.span #+ [ return mark
                                  , UI.label # set UI.for ("jobMark" ++ show jId) # set UI.text "Mark"
                                  ] # set UI.class_ "mark"
              -- abortButton <- UI.button # sink UI.enabled allowAbortion # set UI.text "Abort"
              -- on UI.click abortButton . const $ jobDelete rJId
              let mark'' = case status of
                    (Queued _) -> [mark']
                    _ -> []
                  viewJob = do
                    tabLinkList <- fatal' "Could not find tab link list" =<< getElementById window "tabLinks"
                    tabContainer <- fatal' "Could not find tab container" =<< getElementById window "tabContent"
                    content <- withFatal $ job rJId
                    let
                      text = cobbcode content
                    case text of
                      Left err -> emitError $ "Could not decode content of job #" ++ show jId ++ ": " ++ show err
                      Right (T.unpack -> text) -> void $ do
                        tabLink <- UI.a # set UI.href ("#viewJob" ++ show jId) # set UI.text ("Job #" ++ show jId)
                        tabLinkItem <- UI.li # set children [tabLink]
                        return tabLinkList #+ [ return tabLinkItem ]
                        closeLink <- UI.a # set UI.text "Close Tab" # set UI.class_ "close" # set UI.href "#printers"
                        tabContent <- UI.pre # set UI.text text
                        tab <- UI.new # set children [closeLink, tabContent] # set UI.id_ ("viewJob" ++ show jId) # set UI.class_ "tab"
                        return tabContainer #+ [ return tab ]
                        on UI.click closeLink . const $ mapM_ delete [tabLink, tabLinkItem, closeLink, tabContent, tab] >> runFunction (switchTab "printers")
                        runFunction . switchTab $ "viewJob" ++ show jId
              viewButton <- UI.button # set UI.text "View"
              on UI.click viewButton . const $ viewJob
              actions <- UI.td # set children (mark'' ++ [viewButton])
              UI.tr # set UI.id_ ("job" ++ show jId) # set children [jPId, jId', time', jStatus', actions] # sink UI.class_ (bool "" "focused" . Set.member rJId <$> focusedJobs)
          (:) <$> UI.tr # set children [pId', pFiller, pStatus', pSelect'] # set UI.class_ "printer" <*> 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

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