refactor pages
This commit is contained in:
Alexander Foremny
@@ -1,81 +1,31 @@
|
||||
module Main where
|
||||
|
||||
#ifndef ghcjs_HOST_OS
|
||||
import Data.Maybe
|
||||
import Data.String
|
||||
import Language.Javascript.JSaddle.Warp as JSaddle
|
||||
import Network.HTTP.Simple
|
||||
#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
|
||||
|
||||
import Data.Aeson qualified as A
|
||||
import Data.Aeson.Key qualified as AK
|
||||
import Data.Aeson.KeyMap qualified as AM
|
||||
import Data.ByteString.Lazy.Char8 qualified as LB
|
||||
import Data.Bifunctor
|
||||
import Data.Default
|
||||
import Data.Function
|
||||
import Data.List
|
||||
import Data.Map qualified as M
|
||||
import Data.Text qualified as T
|
||||
import Form qualified as F
|
||||
import GHC.Generics (Generic)
|
||||
import Miso
|
||||
import Miso.String (toMisoString)
|
||||
import NeatInterpolation qualified as Q
|
||||
import Page (Page, initialPage, updatePage, viewPage)
|
||||
import Page qualified as Page
|
||||
import Route (parseURI)
|
||||
|
||||
data Model = Model
|
||||
{ schema :: Maybe (Either String Schema),
|
||||
posts :: Maybe (Either String [A.Value]),
|
||||
input :: Maybe A.Value
|
||||
{ page :: Maybe (Either String Page)
|
||||
}
|
||||
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)
|
||||
)
|
||||
|
||||
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
|
||||
= NoOp
|
||||
| Init
|
||||
| FetchSchema
|
||||
| SetSchema (Either String Schema)
|
||||
| FetchPosts
|
||||
| SetPosts (Either String [A.Value])
|
||||
| FormChanged A.Value
|
||||
| FormSubmitted A.Value
|
||||
| Init URI
|
||||
| HandleURI URI
|
||||
| HandlePage Page.Action
|
||||
| SetPage (Either String Page)
|
||||
deriving (Show, Eq)
|
||||
|
||||
#ifndef ghcjs_HOST_OS
|
||||
@@ -87,92 +37,49 @@ runApp app = app
|
||||
#endif
|
||||
|
||||
main :: IO ()
|
||||
main = runApp $ startApp App {..}
|
||||
main = runApp $ do
|
||||
uri <- getCurrentURI
|
||||
startApp App {initialAction = Init uri, ..}
|
||||
where
|
||||
initialAction = Init
|
||||
model = def
|
||||
update = updateModel
|
||||
view = viewModel
|
||||
events = defaultEvents
|
||||
subs = []
|
||||
subs = [uriSub HandleURI]
|
||||
mountPoint = Nothing
|
||||
logLevel = Off
|
||||
|
||||
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 ->
|
||||
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)
|
||||
FormChanged (Just -> input) -> noEff m {input}
|
||||
FormSubmitted output ->
|
||||
m <# do
|
||||
const NoOp <$> consoleLog (toMisoString (A.encode output))
|
||||
|
||||
fetchSchema :: JSM (Either String Schema)
|
||||
fetchSchema =
|
||||
A.eitherDecode <$> fetch (fromString "http://localhost:8081/posts.schema.json")
|
||||
|
||||
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
|
||||
updateModel NoOp m = noEff m
|
||||
updateModel (Init uri) m =
|
||||
m <# do
|
||||
SetPage <$> initialPage (parseURI uri)
|
||||
updateModel (HandleURI uri) m =
|
||||
m <# do
|
||||
let route = parseURI uri
|
||||
SetPage <$> initialPage route
|
||||
updateModel (SetPage page) m = noEff m {page = Just page}
|
||||
updateModel (HandlePage action) m =
|
||||
case m.page of
|
||||
Just (Right page) ->
|
||||
updatePage action page
|
||||
& bimap HandlePage (\page -> m {page = Just (Right page)})
|
||||
_ -> noEff m
|
||||
|
||||
viewModel :: Model -> View Action
|
||||
viewModel model =
|
||||
let input = fromMaybe (A.Object AM.empty) model.input
|
||||
in div_ [] $
|
||||
[ viewCss,
|
||||
viewHeader,
|
||||
nav_ [] [viewCollections],
|
||||
main_ [] $
|
||||
[ maybe (text "..") (either err viewSchema) model.schema,
|
||||
maybe (text "..") (either err viewPosts) model.posts,
|
||||
maybe (text "..") (either err (viewForm input)) model.schema,
|
||||
viewInput input
|
||||
]
|
||||
div_ [] $
|
||||
[ viewCss,
|
||||
viewHeader,
|
||||
nav_ [] [viewCollections],
|
||||
main_ [] $
|
||||
[ HandlePage
|
||||
<$> maybe
|
||||
(text "..")
|
||||
(either err viewPage)
|
||||
model.page
|
||||
]
|
||||
]
|
||||
|
||||
viewCss :: View Action
|
||||
viewCss =
|
||||
@@ -244,13 +151,13 @@ header section:first-child {
|
||||
)
|
||||
]
|
||||
|
||||
err :: String -> View Action
|
||||
err :: String -> View action
|
||||
err = text . toMisoString . ("err! " <>)
|
||||
|
||||
viewHeader :: View Action
|
||||
viewHeader =
|
||||
header_ [] $
|
||||
[ section_ [] [h1_ [] [text "acms"]],
|
||||
[ section_ [] [h1_ [] [a_ [href_ "#"] [text "acms"]]],
|
||||
section_ [] [viewBranch]
|
||||
]
|
||||
|
||||
@@ -262,69 +169,8 @@ viewCollections :: View Action
|
||||
viewCollections =
|
||||
section_ [] $
|
||||
[ span_ [] [text "collections"],
|
||||
ol_ [] [li_ [] [a_ [href_ "#"] [text "posts"]]]
|
||||
]
|
||||
|
||||
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)
|
||||
|
||||
viewForm :: A.Value -> Schema -> View Action
|
||||
viewForm input =
|
||||
fmap (either FormChanged FormSubmitted)
|
||||
. flip F.runForm input
|
||||
. schemaForm
|
||||
|
||||
viewInput :: A.Value -> View Action
|
||||
viewInput input =
|
||||
pre_ [] [text (toMisoString (A.encode input))]
|
||||
|
||||
schemaForm :: Schema -> F.Form A.Value A.Value
|
||||
schemaForm schema =
|
||||
fmap mergeJson . sequence $
|
||||
case schema.type_ of
|
||||
Object properties ->
|
||||
( \(AK.fromString -> k, "string") ->
|
||||
A.Object . AM.singleton k
|
||||
<$> ( F.mapValues (getO k) (setO k) $
|
||||
jsonString (AK.toString k)
|
||||
)
|
||||
)
|
||||
<$> (M.toList properties)
|
||||
|
||||
mergeJson :: [A.Value] -> A.Value
|
||||
mergeJson = foldl' mergeObject (A.Object AM.empty)
|
||||
|
||||
mergeObject :: A.Value -> A.Value -> A.Value
|
||||
mergeObject (A.Object kvs) (A.Object kvs') = A.Object (AM.union kvs kvs')
|
||||
|
||||
fromJson :: A.Value -> T.Text
|
||||
fromJson (A.String x) = x
|
||||
fromJson _ = ""
|
||||
|
||||
toJson :: T.Text -> A.Value -> A.Value
|
||||
toJson x _ = A.String x
|
||||
|
||||
getO :: AK.Key -> A.Value -> A.Value
|
||||
getO k (A.Object kvs) = fromMaybe A.Null (AM.lookup k kvs)
|
||||
|
||||
setO :: AK.Key -> A.Value -> A.Value -> A.Value
|
||||
setO k v (A.Object kvs) = A.Object (AM.insert k v kvs)
|
||||
|
||||
jsonString :: String -> F.Form A.Value A.Value
|
||||
jsonString = fmap A.String . F.mapValues fromJson toJson . F.string
|
||||
|
||||
viewPosts :: [A.Value] -> View Action
|
||||
viewPosts posts = ol_ [] (viewPost <$> posts)
|
||||
where
|
||||
viewPost post = pre_ [] [text (toMisoString (A.encode post))]
|
||||
[ li_ [] [a_ [href_ "#collection/posts"] [text "posts"]],
|
||||
li_ [] [a_ [href_ "#collection/posts1"] [text "posts1"]]
|
||||
]
|
||||
]
|
||||
|
||||
Reference in New Issue
Block a user