diff options
| -rw-r--r-- | Biz/Devalloc/Core.hs (renamed from Biz/Devalloc/Page/Home.hs) | 45 | ||||
| -rw-r--r-- | Biz/Devalloc/Host.hs | 37 | ||||
| -rw-r--r-- | Biz/Devalloc/Node.hs | 32 | ||||
| -rw-r--r-- | Biz/Devalloc/Page/Signup.hs | 46 | ||||
| -rw-r--r-- | Biz/Devalloc/Path.hs | 27 |
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) |