Commit e3b0a54b authored by julien dehos's avatar julien dehos

simplify app

parent 9738d924
......@@ -17,6 +17,7 @@ executable server
binary,
lucid,
miso,
network-uri,
servant,
servant-server,
wai,
......@@ -35,5 +36,6 @@ executable client
base,
ghcjs-base,
miso,
network-uri,
servant
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
module Common where
import Miso
import Data.Aeson (FromJSON, ToJSON)
import GHC.Generics (Generic)
import Miso
import qualified Network.URI as Network
import Servant.API
import Servant.Links
data Hero = Hero
{ heroName :: String
, heroImage :: String
} deriving (Eq, Show)
-- TODO Hero
} deriving (Eq, Generic, Show)
type Path = [(Double, Double)]
instance FromJSON Hero
instance ToJSON Hero
newtype Model = Model
{ paths_ :: [Path]
{ heroes_ :: [Hero]
} deriving (Eq, Show)
initialModel :: Model
......@@ -21,24 +29,18 @@ initialModel = Model []
data Action
= NoOp
| SendPath Path
| RecvPath (Maybe Path)
deriving (Eq, Show)
type HeroesApi = "heroes" :> Get '[JSON] [Hero]
type ClientRoutes = HomeRoute
type HomeRoute = View Action
handlers :: Model -> View Action
handlers = homeRoute
homeRoute :: Model -> View Action
homeRoute (Model paths) = div_
homeRoute _ = div_
[]
[ text "miso-xhr"
, p_ [] [ a_ [href_ "/api" ] [ text "api" ] ]
, button_ [ onClick (SendPath [(10,20),(100, 200)]) ] [ text "add path" ]
, img_ [ src_ "/static/spongebob.png" ]
, img_ [ src_ "/static/scoobydoo.png" ]
[ h1_ [] [ text "miso-xhr" ]
, p_ [] [ a_ [href_ "heroes" ] [ text "JSON data" ] ]
]
{-# LANGUAGE OverloadedStrings #-}
import Data.Aeson (encode)
import Common
import Control.Monad (void)
import JavaScript.Web.XMLHttpRequest
import Miso
import Miso.String
......@@ -14,22 +12,10 @@ main = miso $ const App
, update = updateModel
, view = homeRoute
, events = defaultEvents
, subs = [ sseSub "/ssePath" ssePath ]
, subs = []
, mountPoint = Nothing
}
updateModel :: Action -> Model -> Effect Action Model
updateModel (SendPath path) m = m <# (xhrPath path >> pure NoOp)
updateModel (RecvPath Nothing) m = noEff m
updateModel (RecvPath (Just path)) (Model paths) = noEff (Model (path:paths))
updateModel NoOp m = noEff m
xhrPath :: Path -> IO ()
xhrPath path = void $ xhrByteString $ Request POST "/xhrPath" Nothing hdr False dat
where hdr = [("Content-type", "application/json")]
dat = StringData $ toMisoString $ encode path
ssePath :: SSE Path -> Action
ssePath (SSEMessage path) = RecvPath (Just path)
ssePath _ = RecvPath Nothing
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
import Common
import Control.Concurrent (Chan, newChan, writeChan)
import Control.Monad.IO.Class (liftIO)
import Data.Binary.Builder (putStringUtf8)
import Data.IORef (newIORef, readIORef, atomicModifyIORef, IORef)
import Data.Proxy (Proxy(..))
import qualified Lucid as L
import Miso
import Network.Wai (Application)
import Network.Wai.EventSource (eventSourceAppChan, ServerEvent(..))
import Network.Wai.Handler.Warp (run)
import Network.Wai.Middleware.RequestLogger (logStdout)
import Servant
main :: IO ()
main = do
pathsRef <- newIORef []
chan <- newChan
run 3000 $ logStdout (serverApp chan pathsRef)
main = run 3000 $ logStdout $ serve (Proxy @ServerApi) server
type ServerApi
= "static" :> Raw
:<|> HeroesApi
:<|> ToServerRoutes ClientRoutes HtmlPage Action
server :: Server ServerApi
server
= serveDirectoryFileServer "static"
:<|> pure heroes
:<|> (pure $ HtmlPage $ homeRoute initialModel)
heroes :: [Hero]
heroes =
[ Hero "Scooby Doo" "scoobydoo.png"
, Hero "Sponge Bob" "spongebob.png"
]
newtype HtmlPage a = HtmlPage a
deriving (Show, Eq)
......@@ -37,34 +45,3 @@ instance L.ToHtml a => L.ToHtml (HtmlPage a) where
[L.src_ "static/all.js", L.async_ mempty, L.defer_ mempty]
L.body_ (L.toHtml x)
type ServerRoutes = ToServerRoutes ClientRoutes HtmlPage Action
type ServerAPI
= "static" :> Raw
:<|> "ssePath" :> Raw
:<|> "xhrPath" :> ReqBody '[JSON] Path :> Post '[JSON] NoContent
:<|> "api" :> Get '[JSON] [Path]
:<|> ServerRoutes
serverApp :: Chan ServerEvent -> IORef [Path] -> Application
serverApp chan pathsRef = serve (Proxy @ServerAPI)
( serveDirectoryFileServer "static"
:<|> Tagged (eventSourceAppChan chan)
:<|> handleXhrPath chan pathsRef
:<|> handleApi pathsRef
:<|> handleRoutes
)
handleXhrPath :: Chan ServerEvent -> IORef [Path] -> Path -> Handler NoContent
handleXhrPath chan pathsRef path = do
paths' <- liftIO $ atomicModifyIORef pathsRef
(\ paths -> let paths' = path:paths in (paths', paths'))
liftIO $ writeChan chan (ServerEvent Nothing Nothing [putStringUtf8 $ show paths'])
pure NoContent
handleApi :: IORef [Path] -> Handler [Path]
handleApi pathsRef = liftIO (readIORef pathsRef)
handleRoutes :: Server ServerRoutes
handleRoutes = pure $ HtmlPage $ homeRoute initialModel
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment