summaryrefslogtreecommitdiff
path: root/Devalloc/Host.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Devalloc/Host.hs')
-rw-r--r--Devalloc/Host.hs121
1 files changed, 0 insertions, 121 deletions
diff --git a/Devalloc/Host.hs b/Devalloc/Host.hs
deleted file mode 100644
index 6d66f32..0000000
--- a/Devalloc/Host.hs
+++ /dev/null
@@ -1,121 +0,0 @@
-{-# 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