diff options
Diffstat (limited to 'Devalloc/Host.hs')
-rw-r--r-- | Devalloc/Host.hs | 121 |
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 |