diff options
Diffstat (limited to 'frontend/app/Main.hs')
| -rw-r--r-- | frontend/app/Main.hs | 170 |
1 files changed, 134 insertions, 36 deletions
diff --git a/frontend/app/Main.hs b/frontend/app/Main.hs index d1bb89e..fc26e69 100644 --- a/frontend/app/Main.hs +++ b/frontend/app/Main.hs @@ -1,28 +1,71 @@ module Main where #ifndef ghcjs_HOST_OS +import Data.String 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 Data.ByteString.Char8 qualified as B +import Data.Maybe +import Data.String import JavaScript.Web.XMLHttpRequest +import Miso.String qualified as J #endif -type Model = Maybe Schema +import Data.Aeson qualified as A +import Data.ByteString.Lazy.Char8 qualified as LB +import Data.Default +import Data.Function +import Data.Map qualified as M +import GHC.Generics (Generic) +import Miso +import Miso.String (toMisoString) + +data Model = Model + { schema :: Maybe (Either String Schema), + posts :: Maybe (Either String [A.Value]) + } + deriving (Show, Eq, Generic, Default) + +data Schema = Schema + { id :: String, + schema :: String, + title :: String, + type_ :: SchemaType + } + deriving (Show, Eq) + +instance A.FromJSON Schema where + parseJSON = + A.withObject + "Schema" + ( \v -> + Schema + <$> v A..: "$id" + <*> v A..: "$schema" + <*> v A..: "title" + <*> A.parseJSON (A.Object v) + ) -type Schema = String +data SchemaType = Object (M.Map String String) + deriving (Show, Eq) + +instance A.FromJSON SchemaType where + parseJSON = + A.withObject + "SchemaType" + ( \v -> + v A..: "type" >>= \case + ("object" :: String) -> Object <$> v A..: "properties" + ) data Action - = FetchSchema - | SetSchema Schema + = NoOp + | Init + | FetchSchema + | SetSchema (Either String Schema) + | FetchPosts + | SetPosts (Either String [A.Value]) deriving (Show, Eq) #ifndef ghcjs_HOST_OS @@ -36,8 +79,8 @@ runApp app = app main :: IO () main = runApp $ startApp App {..} where - initialAction = FetchSchema - model = Nothing + initialAction = Init + model = def update = updateModel view = viewModel events = defaultEvents @@ -48,30 +91,85 @@ main = runApp $ startApp App {..} updateModel :: Action -> Model -> Effect Action Model updateModel action m = case action of + NoOp -> noEff m + Init -> batchEff m [pure FetchSchema, pure FetchPosts] FetchSchema -> m <# do SetSchema <$> fetchSchema - SetSchema schema -> noEff (Just schema) + SetSchema schema -> + let setSchema :: Either String Schema -> Model -> Model + setSchema schema m = m {schema = Just schema} + in noEff (setSchema schema m) + FetchPosts -> m <# do SetPosts <$> fetchPosts + SetPosts posts -> + let setPosts :: Either String [A.Value] -> Model -> Model + setPosts posts m = m {posts = Just posts} + in noEff (setPosts posts m) -fetchSchema :: JSM String -fetchSchema = fetch "http://localhost:8081/posts.schema.json" +fetchSchema :: JSM (Either String Schema) +fetchSchema = + A.eitherDecode <$> fetch (fromString "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 - } +fetchPosts :: JSM (Either String [A.Value]) +fetchPosts = + A.eitherDecode + <$> fetch + ( fromString "http://localhost:8081" + & setRequestMethod "POST" + & setRequestBodyLBS "SELECT posts FROM posts" + ) + +fetch :: Request -> JSM LB.ByteString +fetch req = LB.fromStrict . getResponseBody <$> httpBS req + +#ifdef ghcjs_HOST_OS +httpBS :: Request -> JSM (Response B.ByteString) +httpBS req = xhrByteString req + +instance IsString Request where + fromString uri = + Request + { reqMethod = GET, + reqURI = J.pack uri, + reqLogin = Nothing, + reqHeaders = [], + reqWithCredentials = False, + reqData = NoData + } + +setRequestMethod :: B.ByteString -> Request -> Request +setRequestMethod "POST" req = req {reqMethod = POST} + +setRequestBodyLBS :: LB.ByteString -> Request -> Request +setRequestBodyLBS body req = req {reqData = StringData (J.pack (LB.unpack body))} + +getResponseBody :: Response B.ByteString -> B.ByteString +getResponseBody = fromMaybe "" . contents #endif viewModel :: Model -> View Action -viewModel schema = - div_ [] [text (toMisoString (fromMaybe ".." schema))] +viewModel model = + div_ [] $ + [ maybe (text "..") (either err viewSchema) model.schema, + maybe (text "..") (either err viewPosts) model.posts + ] + +err :: String -> View Action +err = text . toMisoString . ("err! " <>) + +viewSchema :: Schema -> View Action +viewSchema schema = + case schema.type_ of + Object properties -> + ol_ [] $ + ( \(k, v) -> + li_ [] $ + [ text (toMisoString k), + text ":", + text (toMisoString v) + ] + ) + <$> (M.toList properties) + +viewPosts :: [A.Value] -> View Action +viewPosts posts = ol_ [] (viewPost <$> posts) + where + viewPost post = pre_ [] [text (toMisoString (A.encode post))] |