From d480cce48d04d5e4353281f014f66fd61301c393 Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
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/Server.hs | 132 ++++++++++++++++++++++++++++++++++++++++
 1 file changed, 132 insertions(+)
 create mode 100644 Com/InfluencedByBooks/Server.hs

(limited to 'Com/InfluencedByBooks/Server.hs')

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