acms/frontend/app/Main.hs

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.Default
import Data.Function
import Data.List
import Data.Map qualified as M
import Data.Text qualified as T
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)
      )

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
  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 = Init
    model = def
    update = updateModel
    view = viewModel
    events = defaultEvents
    subs = []
    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 _ -> noEff m
    FormSubmitted _ -> noEff m

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

viewModel :: Model -> View Action
viewModel model =
  div_ [] $
    [ maybe (text "..") (either err viewSchema) model.schema,
      maybe (text "..") (either err viewPosts) model.posts,
      maybe
        (text "..")
        ( either
            err
            ( fmap (either FormChanged FormSubmitted)
                . flip viewForm (A.Object AM.empty)
                . schemaForm
            )
        )
        model.schema
    ]

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)

schemaForm :: Schema -> Form A.Value A.Value
schemaForm schema =
  mapOutput mergeJson . sequence $
    case schema.type_ of
      Object properties ->
        ( \(AK.fromString -> k, "string") ->
            mapOutput (A.Object . AM.singleton k) $
              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)

data Form i o = Form
  { view :: i -> [View i],
    fill :: i -> Either String o
  }

instance Functor (Form i) where
  fmap f (Form {view, fill}) =
    Form
      { fill = fmap f . fill,
        ..
      }

instance Applicative (Form i) where
  pure x =
    Form
      { view = const [],
        fill = const (Right x)
      }
  Form {view = viewF, fill = fillF} <*> Form {view = viewX, fill = fillX} =
    Form
      { view = \i ->
          let f = viewF i
              x = viewX i
           in f <> x,
        fill = \i ->
          let f = fillF i
              x = fillX i
           in ($) <$> f <*> x
      }

instance Monad (Form i) where
  (Form {view = viewM, fill = fillM}) >>= mkF =
    Form
      { view = \i ->
          viewM i
            <> case fillM i of
              Right x -> (mkF x).view i
              Left _ -> [],
        fill = \i -> case fillM i of
          Right x -> (mkF x).fill i
          Left e -> Left e
      }

mapValues :: (i' -> i) -> (i -> i' -> i') -> Form i o -> Form i' o
mapValues get set (Form {view, fill}) =
  Form
    { view = \i -> fmap (flip set i) <$> view (get i),
      fill = fill . get
    }

mapOutput :: (o -> o') -> Form i o -> Form i o'
mapOutput = fmap

viewForm :: Form i o -> i -> View (Either i o)
viewForm (Form {view}) i =
  div_ [] $
    (fmap Left <$> view i)
      <> [ button_ [type_ "submit"] [text "submit"]
         ]

jsonString :: String -> Form A.Value A.Value
jsonString = mapOutput A.String . mapValues fromJson toJson . string

string :: String -> Form T.Text T.Text
string label =
  Form
    { view = \i ->
        [ div_ [] $
            [ label_ [] $
                [ text (toMisoString label),
                  input_
                    [ type_ "text",
                      value_ (toMisoString i)
                    ]
                ]
            ]
        ],
      fill = \i -> Right i
    }

viewPosts :: [A.Value] -> View Action
viewPosts posts = ol_ [] (viewPost <$> posts)
  where
    viewPost post = pre_ [] [text (toMisoString (A.encode post))]