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
|
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
module Main (main) where
import qualified Graphics.UI.Threepenny as UI
import qualified Graphics.UI.Threepenny.Core as TP (Config)
import Graphics.UI.Threepenny.Core hiding (Config)
import Thermoprint.Client
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 Control.Concurrent
import Control.Exception
import Control.Monad.Catch
import Control.Applicative
import Control.Monad
import Data.Maybe
import Data.Monoid
import Text.Read
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
return $ Config <$> ((\port addr -> defaultConfig { 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
return window # set UI.title "Thermoprint"
title <- UI.input
# set UI.id_ "title"
content <- UI.textarea
# set UI.id_ "content"
draftTable <- UI.table
saveBtn <- UI.button #+ [string "Save"]
discBtn <- UI.button #+ [string "Discard"]
prntBtn <- UI.button #+ [string "Print"]
getBody window #+ [ row [ column [ UI.h1 #+ [string "Current draft"]
, row [UI.label # set text "Title" # set UI.for "title", element title # set style [("width", "100%")]]
, element content # set style [("width", "100%")]
, row [ element saveBtn # set style [("width", "100%")]
, element prntBtn # set style [("width", "100%")]
, element discBtn # set style [("width", "100%")]
]
]
, column [ UI.h1 #+ [string "Saved drafts"]
, element draftTable
]
]
]
where
handleSocketErr InvalidMessage = debug "Received unparseable message from websocket"
handleSocketErr e@(UnknownException e') = void $ do
getBody window #+ [UI.p # set text (show e') # set UI.id_ "error"]
liftIO $ throwIO e
data WebSocketException = InvalidMessage | UnknownException 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 . parseURI . T.unpack <=< receiveData)
liftIO . forkIO $ rcvEvents `catchAll` (triggerData . Left . UnknownException)
void $ setup c w dataUpdate
|
