From 83c473947589cd90fc74fb59e9c9c28a677583c3 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Sun, 6 Dec 2020 10:04:08 -0500 Subject: 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. --- Biz/Devalloc/Core.hs | 86 ++++++++++++++++++++++++++++++++++++++++ Biz/Devalloc/Host.hs | 37 ++++++++++++------ Biz/Devalloc/Node.hs | 32 +++++++++++++++ Biz/Devalloc/Page/Home.hs | 95 --------------------------------------------- Biz/Devalloc/Page/Signup.hs | 46 ---------------------- Biz/Devalloc/Path.hs | 27 +++++++++++++ 6 files changed, 171 insertions(+), 152 deletions(-) create mode 100644 Biz/Devalloc/Core.hs create mode 100644 Biz/Devalloc/Node.hs delete mode 100644 Biz/Devalloc/Page/Home.hs delete mode 100644 Biz/Devalloc/Page/Signup.hs create mode 100644 Biz/Devalloc/Path.hs (limited to 'Biz/Devalloc') diff --git a/Biz/Devalloc/Core.hs b/Biz/Devalloc/Core.hs new file mode 100644 index 0000000..a56c386 --- /dev/null +++ b/Biz/Devalloc/Core.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} + +module Biz.Devalloc.Core + ( Form (..), + Move (..), + make, + signup, + view, + ) +where + +import Alpha +import Miso hiding (view) +import qualified Miso.String +import Servant.API +import Servant.Links (URI) + +data Move + = NoOp + | ChangeURI URI + +newtype Form = Form {uri :: URI} + deriving (Eq) + +make :: URI -> Form +make uri = Form uri + +signup :: View Move +signup = + p_ + [] + [ a_ + [href_ "mailto:ben@bsima.me?subject=Devalloc+signup"] + [text "Request access via email"] + ] + + +view :: Form -> View Move +view _ = + div_ + [] + [ h1_ [] [text "Devalloc"], + p_ + [] + [ text + "Devalloc analyzes your codebase trends, finds patterns \ + \ in how your developers work, and protects against tech debt." + ], + p_ [] [text "Just hook it up to your CI system - it will warn you when it finds a problem."], + signup, + h2_ [] [text "Identify blackholes in your codebase"], + p_ + [] + [ text + <| Miso.String.intercalate + " " + [ "What if none of your active employees have touched some part of the codebase?", + "This happens too often with legacy code, and then it turns into a huge source of tech debt.", + "Devalloc finds these \"blackholes\" and warns you about them so you can be proactive in eliminating tech debt." + ] + ], + h2_ + [] + [text "Protect against lost knowledge"], + p_ + [] + [text "Not everyone can know every part of a codebase. By finding pieces of code that only 1 or 2 people have touched, devalloc identifes siloed knowledge. This allows you to protect against the risk of this knowledge leaving the company if an employee leaves."], + h2_ + [] + [text "Don't just measure code coverage - also know your dev coverage"], + p_ + [] + [text "No matter how smart your employees are, if you are under- or over-utilizing your developers then you will never get optimal performance from your team."], + ul_ + [] + [ li_ [] [text "Find developer hot spots in your code: which pieces of code get continually rewritten, taking up valuable dev time?"], + li_ [] [text "Know how your devs work best: which ones have depth of knowledge, and which ones have breadth?"] + ], + p_ [] [text "(Paid only)"], + h2_ [] [text "See how your teams *actually* organize themselves with cluster analysis"], + p_ [] [text "Does your team feel splintered or not cohesive? Which developers work best together? Devalloc analyzes the collaboration patterns between devs and helps you form optimal pairings and teams based on shared code and mindspace."], + p_ [] [text "(Paid only)"], + signup + ] 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/Home.hs b/Biz/Devalloc/Page/Home.hs deleted file mode 100644 index 9e90e70..0000000 --- a/Biz/Devalloc/Page/Home.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Biz.Devalloc.Page.Home - ( 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 - -signup :: View Move -signup = - p_ - [] - [ a_ - [href_ "mailto:ben@bsima.me?subject=Devalloc+signup"] - [text "Request access via email"] - ] - -view :: Form -> View Move -view _ = - div_ - [] - [ h1_ [] [text "Devalloc"], - p_ - [] - [ text - "Devalloc analyzes your codebase trends, finds patterns \ - \ in how your developers work, and protects against tech debt." - ], - p_ [] [text "Just hook it up to your CI system - it will warn you when it finds a problem."], - signup, - h2_ [] [text "Identify blackholes in your codebase"], - p_ - [] - [ text - <| Miso.String.intercalate - " " - [ "What if none of your active employees have touched some part of the codebase?", - "This happens too often with legacy code, and then it turns into a huge source of tech debt.", - "Devalloc finds these \"blackholes\" and warns you about them so you can be proactive in eliminating tech debt." - ] - ], - h2_ - [] - [text "Protect against lost knowledge"], - p_ - [] - [text "Not everyone can know every part of a codebase. By finding pieces of code that only 1 or 2 people have touched, devalloc identifes siloed knowledge. This allows you to protect against the risk of this knowledge leaving the company if an employee leaves."], - h2_ - [] - [text "Don't just measure code coverage - also know your dev coverage"], - p_ - [] - [text "No matter how smart your employees are, if you are under- or over-utilizing your developers then you will never get optimal performance from your team."], - ul_ - [] - [ li_ [] [text "Find developer hot spots in your code: which pieces of code get continually rewritten, taking up valuable dev time?"], - li_ [] [text "Know how your devs work best: which ones have depth of knowledge, and which ones have breadth?"] - ], - p_ [] [text "(Paid only)"], - h2_ [] [text "See how your teams *actually* organize themselves with cluster analysis"], - p_ [] [text "Does your team feel splintered or not cohesive? Which developers work best together? Devalloc analyzes the collaboration patterns between devs and helps you form optimal pairings and teams based on shared code and mindspace."], - p_ [] [text "(Paid only)"], - signup - ] 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) -- cgit v1.2.3