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.

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)