From d480cce48d04d5e4353281f014f66fd61301c393 Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Sat, 15 Feb 2020 23:03:40 -0800 Subject: Split buildHaskellApp into buildGhc and buildGhcjs Two functions makes it simpler to reason about what is being built and when, even if it is a bit more explicit. I also removed the dumb Apex/Aero naming thing because Server/Client is just easier to remember. --- Com/InfluencedByBooks/Aero.hs | 21 ------- Com/InfluencedByBooks/Apex.hs | 132 ---------------------------------------- Com/InfluencedByBooks/Client.hs | 21 +++++++ Com/InfluencedByBooks/Server.hs | 132 ++++++++++++++++++++++++++++++++++++++++ 4 files changed, 153 insertions(+), 153 deletions(-) delete mode 100644 Com/InfluencedByBooks/Aero.hs delete mode 100644 Com/InfluencedByBooks/Apex.hs create mode 100644 Com/InfluencedByBooks/Client.hs create mode 100644 Com/InfluencedByBooks/Server.hs (limited to 'Com/InfluencedByBooks') diff --git a/Com/InfluencedByBooks/Aero.hs b/Com/InfluencedByBooks/Aero.hs deleted file mode 100644 index bd996c6..0000000 --- a/Com/InfluencedByBooks/Aero.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NoImplicitPrelude #-} - --- | Front-end -module Com.InfluencedByBooks.Aero where - -import Com.InfluencedByBooks.Core (Action(..), see, init) -import Com.InfluencedByBooks.Move (move) -import Com.Simatime.Alpha -import Miso (App(..), defaultEvents, miso) - -main :: IO () -main = miso $ \u -> App { model = init u, .. } - where - initialAction = FetchPeople - update = move - view = see - events = defaultEvents - subs = [] - mountPoint = Nothing diff --git a/Com/InfluencedByBooks/Apex.hs b/Com/InfluencedByBooks/Apex.hs deleted file mode 100644 index 0328a6d..0000000 --- a/Com/InfluencedByBooks/Apex.hs +++ /dev/null @@ -1,132 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - --- | Server -module Com.InfluencedByBooks.Apex where - -import qualified Clay -import Com.InfluencedByBooks.Core -import qualified Com.InfluencedByBooks.Keep as Keep -import qualified Com.InfluencedByBooks.Look as Look -import Com.Simatime.Alpha -import Com.Simatime.Network -import Data.Acid (AcidState) -import qualified Data.Acid.Abstract as Acid -import Data.Maybe (fromMaybe) -import qualified Data.Text.Lazy as Lazy -import qualified Data.Text.Lazy.Encoding as Lazy -import qualified Lucid as L -import Lucid.Base -import Miso -import Network.HTTP.Media ((//), (/:)) -import Network.HTTP.Types -import Network.Wai -import Network.Wai.Application.Static -import Network.Wai.Handler.Warp -import Network.Wai.Middleware.Gzip -import Network.Wai.Middleware.RequestLogger -import Servant -import System.Environment (lookupEnv) - -main :: IO () -main = do - say "rise: ibb" - staticDir <- fromMaybe "static" - <$> lookupEnv "STATIC_DIR" :: IO [Char] - port <- read - <$> fromMaybe "3000" - <$> lookupEnv "PORT" :: IO Int - keep <- Keep.openLocal "_keep/" - say "port: 3000" - run port $ logStdout $ compress $ app staticDir $ keep - where - compress = gzip def { gzipFiles = GzipCompress } - -newtype HtmlPage a = HtmlPage a - deriving (Show, Eq) - -instance L.ToHtml a => L.ToHtml (HtmlPage a) where - toHtmlRaw = L.toHtml - toHtml (HtmlPage x) = - L.doctypehtml_ $ do - L.head_ $ do - L.meta_ [L.charset_ "utf-8"] - jsRef "/static/ibb.js" - cssRef "/css/main.css" - L.body_ $ do - page - where - page = L.toHtml x - jsRef href = L.with (L.script_ mempty) - [ makeAttribute "src" href - , makeAttribute "type" "text/javascript" - , makeAttribute "async" mempty - , makeAttribute "defer" mempty - ] - cssRef href = L.with - (L.link_ mempty) - [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href] - -type ServerRoutes = ToServerRoutes AppRoutes HtmlPage Action - -handle404 :: Application -handle404 _ respond = respond - $ responseLBS status404 [("Content-Type", "text/html")] - $ renderBS - $ toHtml - $ HtmlPage - $ notfound - -newtype CSS = CSS { unCSS :: Text } - -instance MimeRender CSS Text where - mimeRender _ = Lazy.encodeUtf8 . Lazy.fromStrict - -instance Accept CSS where - contentType _ = "text" // "css" /: ("charset", "utf-8") - -type CssRoute = "css" :> "main.css" :> Get '[CSS] Text - -type Routes - = "static" :> Raw - :<|> CssRoute - :<|> ServerRoutes - :<|> "api" :> ApiRoutes - :<|> Raw - -cssHandlers :: Server CssRoute -cssHandlers = return . Lazy.toStrict . Clay.render - $ Look.main - -app :: [Char] -> AcidState Keep.IbbKeep -> Application -app staticDir keep = serve - (Proxy @Routes) - $ static - :<|> cssHandlers - :<|> serverHandlers - :<|> apiHandlers keep - :<|> Tagged handle404 - where - static = serveDirectoryWith - (defaultWebAppSettings $ staticDir) - -type ApiRoutes = - "people" :> Get '[JSON] [Person] - -serverHandlers :: Server ServerRoutes -serverHandlers = homeHandler - where - send f u = - pure $ HtmlPage $ f Model { uri = u, people = NotAsked } - homeHandler = send home goHome - --- | for now we just have one api endpoint, which returns all the people -apiHandlers :: AcidState Keep.IbbKeep -> Server ApiRoutes -apiHandlers keep = - Acid.query' keep $ Keep.GetPeople 20 diff --git a/Com/InfluencedByBooks/Client.hs b/Com/InfluencedByBooks/Client.hs new file mode 100644 index 0000000..cf45511 --- /dev/null +++ b/Com/InfluencedByBooks/Client.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Front-end +module Com.InfluencedByBooks.Client where + +import Com.InfluencedByBooks.Core (Action(..), see, init) +import Com.InfluencedByBooks.Move (move) +import Com.Simatime.Alpha +import Miso (App(..), defaultEvents, miso) + +main :: IO () +main = miso $ \u -> App { model = init u, .. } + where + initialAction = FetchPeople + update = move + view = see + events = defaultEvents + subs = [] + mountPoint = Nothing diff --git a/Com/InfluencedByBooks/Server.hs b/Com/InfluencedByBooks/Server.hs new file mode 100644 index 0000000..dae17ef --- /dev/null +++ b/Com/InfluencedByBooks/Server.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +-- | Server +module Com.InfluencedByBooks.Server where + +import qualified Clay +import Com.InfluencedByBooks.Core +import qualified Com.InfluencedByBooks.Keep as Keep +import qualified Com.InfluencedByBooks.Look as Look +import Com.Simatime.Alpha +import Com.Simatime.Network +import Data.Acid (AcidState) +import qualified Data.Acid.Abstract as Acid +import Data.Maybe (fromMaybe) +import qualified Data.Text.Lazy as Lazy +import qualified Data.Text.Lazy.Encoding as Lazy +import qualified Lucid as L +import Lucid.Base +import Miso +import Network.HTTP.Media ((//), (/:)) +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Application.Static +import Network.Wai.Handler.Warp +import Network.Wai.Middleware.Gzip +import Network.Wai.Middleware.RequestLogger +import Servant +import System.Environment (lookupEnv) + +main :: IO () +main = do + say "rise: ibb" + staticDir <- fromMaybe "static" + <$> lookupEnv "STATIC_DIR" :: IO [Char] + port <- read + <$> fromMaybe "3000" + <$> lookupEnv "PORT" :: IO Int + keep <- Keep.openLocal "_keep/" + say "port: 3000" + run port $ logStdout $ compress $ app staticDir $ keep + where + compress = gzip def { gzipFiles = GzipCompress } + +newtype HtmlPage a = HtmlPage a + deriving (Show, Eq) + +instance L.ToHtml a => L.ToHtml (HtmlPage a) where + toHtmlRaw = L.toHtml + toHtml (HtmlPage x) = + L.doctypehtml_ $ do + L.head_ $ do + L.meta_ [L.charset_ "utf-8"] + jsRef "/static/ibb.js" + cssRef "/css/main.css" + L.body_ $ do + page + where + page = L.toHtml x + jsRef href = L.with (L.script_ mempty) + [ makeAttribute "src" href + , makeAttribute "type" "text/javascript" + , makeAttribute "async" mempty + , makeAttribute "defer" mempty + ] + cssRef href = L.with + (L.link_ mempty) + [L.rel_ "stylesheet", L.type_ "text/css", L.href_ href] + +type ServerRoutes = ToServerRoutes AppRoutes HtmlPage Action + +handle404 :: Application +handle404 _ respond = respond + $ responseLBS status404 [("Content-Type", "text/html")] + $ renderBS + $ toHtml + $ HtmlPage + $ notfound + +newtype CSS = CSS { unCSS :: Text } + +instance MimeRender CSS Text where + mimeRender _ = Lazy.encodeUtf8 . Lazy.fromStrict + +instance Accept CSS where + contentType _ = "text" // "css" /: ("charset", "utf-8") + +type CssRoute = "css" :> "main.css" :> Get '[CSS] Text + +type Routes + = "static" :> Raw + :<|> CssRoute + :<|> ServerRoutes + :<|> "api" :> ApiRoutes + :<|> Raw + +cssHandlers :: Server CssRoute +cssHandlers = return . Lazy.toStrict . Clay.render + $ Look.main + +app :: [Char] -> AcidState Keep.IbbKeep -> Application +app staticDir keep = serve + (Proxy @Routes) + $ static + :<|> cssHandlers + :<|> serverHandlers + :<|> apiHandlers keep + :<|> Tagged handle404 + where + static = serveDirectoryWith + (defaultWebAppSettings $ staticDir) + +type ApiRoutes = + "people" :> Get '[JSON] [Person] + +serverHandlers :: Server ServerRoutes +serverHandlers = homeHandler + where + send f u = + pure $ HtmlPage $ f Model { uri = u, people = NotAsked } + homeHandler = send home goHome + +-- | for now we just have one api endpoint, which returns all the people +apiHandlers :: AcidState Keep.IbbKeep -> Server ApiRoutes +apiHandlers keep = + Acid.query' keep $ Keep.GetPeople 20 -- cgit v1.2.3