blob: d1bb89ef4eda7c3fb8def9a02b4143c50e7cf2c9 (
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
|
module Main where
#ifndef ghcjs_HOST_OS
import Language.Javascript.JSaddle.Warp as JSaddle
#endif
import Data.ByteString.UTF8 qualified as B
import Data.Maybe
import Miso
import Miso.String
#ifndef ghcjs_HOST_OS
import Network.HTTP.Simple
import Data.String
#else
import JavaScript.Web.XMLHttpRequest
#endif
type Model = Maybe Schema
type Schema = String
data Action
= FetchSchema
| SetSchema Schema
deriving (Show, Eq)
#ifndef ghcjs_HOST_OS
runApp :: JSM () -> IO ()
runApp f = JSaddle.debugOr 8080 (f >> syncPoint) JSaddle.jsaddleApp
#else
runApp :: IO () -> IO ()
runApp app = app
#endif
main :: IO ()
main = runApp $ startApp App {..}
where
initialAction = FetchSchema
model = Nothing
update = updateModel
view = viewModel
events = defaultEvents
subs = []
mountPoint = Nothing
logLevel = Off
updateModel :: Action -> Model -> Effect Action Model
updateModel action m =
case action of
FetchSchema -> m <# do SetSchema <$> fetchSchema
SetSchema schema -> noEff (Just schema)
fetchSchema :: JSM String
fetchSchema = fetch "http://localhost:8081/posts.schema.json"
#ifndef ghcjs_HOST_OS
fetch :: String -> JSM String
fetch url = B.toString . getResponseBody <$> httpBS (fromString url)
#else
fetch :: String -> JSM String
fetch url = maybe "" B.toString . contents <$> xhrByteString req
where
req =
Request
{ reqMethod = GET,
reqURI = pack url,
reqLogin = Nothing,
reqHeaders = [],
reqWithCredentials = False,
reqData = NoData
}
#endif
viewModel :: Model -> View Action
viewModel schema =
div_ [] [text (toMisoString (fromMaybe ".." schema))]
|
