78 lines
1.6 KiB
Haskell
78 lines
1.6 KiB
Haskell
|
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))]
|