summaryrefslogtreecommitdiff
path: root/Biz/Devalloc
diff options
context:
space:
mode:
authorBen Sima <ben@bsima.me>2020-12-06 10:04:08 -0500
committerBen Sima <ben@bsima.me>2020-12-06 10:04:08 -0500
commit83c473947589cd90fc74fb59e9c9c28a677583c3 (patch)
treecbe7ae61b5f6cf7a1be4b2c7d7fcb5c516c73234 /Biz/Devalloc
parented4778e3bc72d1995ae88c36486a546118f7aa2d (diff)
Finish Devalloc miso app prototype
After hours of trying to get a page abstraction working in a Miso app (both Devalloc and Hero) I had a revelation: Miso is an SPA - *single* page application - framework, and so trying to put multiple pages into it is fundamentally at odds with the rest of the architecture. Of course this is also a problem with Elm's pattern of nesting models in order to create a page abstraction. They can pull it off because they don't also try to do isomorphic rendering. In hindsight this should be obvious... if I actually do want some kind of page-like abstraction or separation, then I need a much more complex server that can embed different Miso apps based on some logic. But this is more like multi-tenancy, or something. Also I'm starting to think that I don't want Devalloc to be an SPA anyway, so I'll try an experimental branch where I rip it out and just use Servant, Lucid, and Turbolinks.
Diffstat (limited to 'Biz/Devalloc')
-rw-r--r--Biz/Devalloc/Core.hs (renamed from Biz/Devalloc/Page/Home.hs)45
-rw-r--r--Biz/Devalloc/Host.hs37
-rw-r--r--Biz/Devalloc/Node.hs32
-rw-r--r--Biz/Devalloc/Page/Signup.hs46
-rw-r--r--Biz/Devalloc/Path.hs27
5 files changed, 103 insertions, 84 deletions
diff --git a/Biz/Devalloc/Page/Home.hs b/Biz/Devalloc/Core.hs
index 9e90e70..a56c386 100644
--- a/Biz/Devalloc/Page/Home.hs
+++ b/Biz/Devalloc/Core.hs
@@ -1,41 +1,31 @@
{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DataKinds #-}
-module Biz.Devalloc.Page.Home
- ( Move (..),
- Path,
- Form (..),
- path,
+module Biz.Devalloc.Core
+ ( Form (..),
+ Move (..),
+ make,
+ signup,
view,
- host,
)
where
import Alpha
-import Biz.App (HtmlApp (..))
-import Miso
-import Miso.String
+import Miso hiding (view)
+import qualified Miso.String
import Servant.API
-import Servant.Links
-import Servant.Server (Handler)
+import Servant.Links (URI)
-data Move = NoMove
+data Move
+ = NoOp
+ | ChangeURI URI
-type Path = View Move
+newtype Form = Form {uri :: URI}
+ deriving (Eq)
-newtype Form = Form
- { uri :: URI
- }
-
-path :: URI
-path = linkURI <| safeLink (Proxy :: Proxy Path) (Proxy :: Proxy Path)
-
-host :: Handler (HtmlApp (View Move))
-host =
- Form {uri = path}
- |> view
- |> HtmlApp
- |> pure
+make :: URI -> Form
+make uri = Form uri
signup :: View Move
signup =
@@ -46,6 +36,7 @@ signup =
[text "Request access via email"]
]
+
view :: Form -> View Move
view _ =
div_
diff --git a/Biz/Devalloc/Host.hs b/Biz/Devalloc/Host.hs
index 5a9ff80..c6c6724 100644
--- a/Biz/Devalloc/Host.hs
+++ b/Biz/Devalloc/Host.hs
@@ -28,17 +28,19 @@ import Alpha
import Biz.App (CSS (..), HtmlApp (..))
-- import qualified CMark as Cmark
-import qualified Biz.Devalloc.Page.Home as Home
-import qualified Biz.Devalloc.Page.Signup as Signup
import qualified Biz.Look
+import qualified Biz.Devalloc.Core as Core
+import qualified Biz.Devalloc.Path as Path
import qualified Clay
import qualified Control.Exception as Exception
+import qualified Data.Text as Text
import qualified Lucid
import qualified Lucid.Base as Lucid
import Miso hiding (node)
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import Network.Wai.Middleware.RequestLogger (logStdout)
+import Network.Wai.Application.Static (defaultWebAppSettings)
import Servant
import qualified System.Envy as Envy
@@ -52,17 +54,17 @@ main = Exception.bracket startup shutdown run
putText "@"
putText "devalloc"
putText <| "port: " <> (show <| port cfg)
- return (cfg, serve (Proxy @AllRoutes) <| serverHandlers)
+ putText <| "node: " <> (Text.pack <| node cfg)
+ let static = serveDirectoryWith <| defaultWebAppSettings <| node cfg
+ return (cfg, serve (Proxy @AllPaths) <| serverHandlers static)
shutdown :: (Config, Application) -> IO ()
shutdown _ = pure ()
run :: (Config, Wai.Application) -> IO ()
run (cfg, app) = Warp.run (port cfg) (logStdout app)
-type HomeServer = ToServerRoutes Home.Path HtmlApp Home.Move
+type HostPaths = ToServerRoutes Path.Paths HtmlApp Core.Move
-type SignupServer = ToServerRoutes Signup.Path HtmlApp Signup.Move
-
-type AllRoutes = HomeServer :<|> SignupServer :<|> CssRoute
+type AllPaths = ("static" :> Raw) :<|> HostPaths :<|> CssRoute
type CssRoute = "css" :> "main.css" :> Get '[CSS] Text
@@ -76,7 +78,6 @@ instance Lucid.ToHtml a => Lucid.ToHtml (HtmlApp a) where
Lucid.head_ <| do
Lucid.meta_ [Lucid.charset_ "utf-8"]
jsRef "/static/all.js"
- jsRef "//unpkg.com/turbolinks@5.2.0/dist/turbolinks.js"
cssRef "/css/main.css"
Lucid.body_ (Lucid.toHtml x)
where
@@ -108,13 +109,27 @@ instance Envy.DefConfig Config where
Config
{ port = 3000,
pitches = "./Biz/Devalloc/pitch.md",
- node = "_/bild/dev/Devalloc.Node/static"
+ node = "_/bild/dev/static/devalloc.js"
}
instance Envy.FromEnv Config
-serverHandlers :: Server AllRoutes
-serverHandlers = Home.host :<|> Signup.host :<|> cssHandlers
+home :: Handler (HtmlApp (View Core.Move))
+home =
+ Core.Form {Core.uri = Path.home}
+ |> Core.view
+ |> HtmlApp
+ |> pure
+
+signup :: Handler (HtmlApp (View Core.Move))
+signup =
+ Core.Form {Core.uri = Path.signup}
+ |> Core.view
+ |> HtmlApp
+ |> pure
+
+serverHandlers :: Tagged Handler Application -> Server AllPaths
+serverHandlers static = static :<|> (home :<|> signup) :<|> cssHandlers
look :: Clay.Css
look = do
diff --git a/Biz/Devalloc/Node.hs b/Biz/Devalloc/Node.hs
new file mode 100644
index 0000000..51acbf1
--- /dev/null
+++ b/Biz/Devalloc/Node.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- : out devalloc.js
+--
+-- : dep clay
+-- : dep ghcjs-base
+-- : dep miso
+-- : dep potolude
+-- : dep servant
+-- : dep text
+module Biz.Devalloc.Node (main) where
+
+import Alpha
+import qualified Biz.Devalloc.Core as Core
+import Miso
+
+main :: IO ()
+main = miso <| \currentURI -> App {model = Core.make currentURI, ..}
+ where
+ update = move
+ view = view
+ subs = []
+ events = defaultEvents
+ initialAction = Core.NoOp
+ mountPoint = Nothing
+
+move :: Core.Move -> Core.Form -> Effect Core.Move Core.Form
+move mov form = case mov of
+ Core.NoOp -> noEff form
+ Core.ChangeURI u -> form <# (pushURI u >> pure Core.NoOp)
+
diff --git a/Biz/Devalloc/Page/Signup.hs b/Biz/Devalloc/Page/Signup.hs
deleted file mode 100644
index 8debf53..0000000
--- a/Biz/Devalloc/Page/Signup.hs
+++ /dev/null
@@ -1,46 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Biz.Devalloc.Page.Signup
- ( Move (..),
- Path,
- Form (..),
- path,
- view,
- host,
- )
-where
-
-import Alpha
-import Biz.App (HtmlApp (..))
-import Miso
-import Miso.String
-import Servant.API
-import Servant.Links
-import Servant.Server (Handler)
-
-data Move = NoMove
-
-type Path = View Move
-
-newtype Form = Form
- { uri :: URI
- }
-
-path :: URI
-path = linkURI <| safeLink (Proxy :: Proxy Path) (Proxy :: Proxy Path)
-
-host :: Handler (HtmlApp (View Move))
-host =
- Form {uri = path}
- |> view
- |> HtmlApp
- |> pure
-
-view :: Form -> View Move
-view _ =
- div_
- []
- [ h1_ [] [text "Signup coming soon"],
- p_ [] [a_ [href_ "/"] [text "Go back home"]]
- ]
diff --git a/Biz/Devalloc/Path.hs b/Biz/Devalloc/Path.hs
new file mode 100644
index 0000000..1463fc4
--- /dev/null
+++ b/Biz/Devalloc/Path.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Biz.Devalloc.Path
+ ( Paths,
+ home,
+ signup,
+ )
+where
+
+import Alpha
+import qualified Biz.Devalloc.Core as Core
+import Miso
+import Servant
+
+type Paths = Home :<|> Signup
+
+type Home = View Core.Move
+
+type Signup = "signup" :> View Core.Move
+
+home :: URI
+home = linkURI <| safeLink (Proxy :: Proxy Paths) (Proxy :: Proxy Home)
+
+signup :: URI
+signup = linkURI <| safeLink (Proxy :: Proxy Paths) (Proxy :: Proxy Signup)