1 files changed, 121 insertions, 0 deletions
diff --git a/Devalloc/Host.hs b/Devalloc/Host.hs
new file mode 100644
index 0000000..6d66f32
--- /dev/null
+++ b/Devalloc/Host.hs
@@ -0,0 +1,121 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+-- Developer allocation
+--
+-- : out devalloc-host
+-- : dep clay
+-- : dep cmark
+-- : sys cmark
+-- : dep envy
+-- : dep lucid
+-- : dep miso
+-- : dep protolude
+-- : dep servant
+-- : dep servant-server
+-- : dep warp
+module Devalloc.Host
+  ( main,
+  )
+where
+
+import Alpha
+import Biz.App (CSS (..), HtmlApp (..))
+import qualified Biz.Look
+-- import qualified CMark as Cmark
+import qualified Clay
+import qualified Control.Exception as Exception
+import qualified Devalloc.Page.Home as Home
+import qualified Devalloc.Page.Signup as Signup
+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 Servant
+import qualified System.Envy as Envy
+
+main :: IO ()
+main = Exception.bracket startup shutdown run
+  where
+    startup =
+      Envy.decodeWithDefaults Envy.defConfig >>= \cfg -> do
+        -- pitchText <- readFile <| pitches cfg
+        -- let pitch = Cmark.commonmarkToHtml [] pitchText
+        putText "@"
+        putText "devalloc"
+        putText <| "port: " <> (show <| port cfg)
+        return (cfg, serve (Proxy @AllRoutes) <| serverHandlers)
+    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 SignupServer = ToServerRoutes Signup.Path HtmlApp Signup.Move
+
+type AllRoutes = HomeServer :<|> SignupServer :<|> CssRoute
+
+type CssRoute = "css" :> "main.css" :> Get '[CSS] Text
+
+cssHandlers :: Server CssRoute
+cssHandlers = return . toStrict <| Clay.render look
+
+instance Lucid.ToHtml a => Lucid.ToHtml (HtmlApp a) where
+  toHtmlRaw = Lucid.toHtml
+  toHtml (HtmlApp x) =
+    Lucid.doctypehtml_ <| do
+      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
+      jsRef _href =
+        Lucid.with
+          (Lucid.script_ mempty)
+          [ Lucid.makeAttribute "src" _href,
+            Lucid.makeAttribute "async" mempty,
+            Lucid.makeAttribute "defer" mempty
+          ]
+      cssRef _href =
+        Lucid.with
+          (Lucid.link_ mempty)
+          [ Lucid.rel_ "stylesheet",
+            Lucid.type_ "text/css",
+            Lucid.href_ _href
+          ]
+
+data Config = Config
+  { port :: Warp.Port,
+    -- | A yaml file of pitches
+    pitches :: FilePath,
+    node :: FilePath
+  }
+  deriving (Generic, Show)
+
+instance Envy.DefConfig Config where
+  defConfig =
+    Config
+      { port = 3000,
+        pitches = "./Devalloc/pitch.md",
+        node = "_/bild/dev/Devalloc.Node/static"
+      }
+
+instance Envy.FromEnv Config
+
+serverHandlers :: Server AllRoutes
+serverHandlers = Home.host :<|> Signup.host :<|> cssHandlers
+
+look :: Clay.Css
+look = do
+  Biz.Look.fuckingStyle
+  "body" Clay.? Biz.Look.fontStack