1 files changed, 129 insertions, 0 deletions
diff --git a/Com/InfluencedByBooks/Apex.hs b/Com/InfluencedByBooks/Apex.hs
new file mode 100644
index 0000000..c154f95
--- /dev/null
+++ b/Com/InfluencedByBooks/Apex.hs
@@ -0,0 +1,129 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- | Server
+module Com.InfluencedByBooks.Apex where
+
+import Com.Simatime.Alpha
+import Com.InfluencedByBooks.Core
+import qualified Com.InfluencedByBooks.Keep as Keep
+import qualified Com.InfluencedByBooks.Look as Look
+import qualified Clay
+import qualified Data.Text.Lazy                as Lazy
+import qualified Data.Text.Lazy.Encoding       as Lazy
+import Data.Maybe (fromMaybe)
+import Data.Acid (AcidState)
+import qualified Data.Acid.Abstract as Acid
+import qualified Lucid as L
+import Lucid.Base
+import Miso
+import           Network.HTTP.Media             ((//), (/:))
+import Network.HTTP.Types
+import Com.Simatime.Network
+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"
+  port <- read
+          <$> fromMaybe "3000"
+          <$> lookupEnv "PORT" :: IO Int
+  keep <- Keep.openLocal "keep/"
+  say "port: 3000"
+  run port $ logStdout $ compress $ app $ 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/all.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 :: AcidState Keep.IbbKeep -> Application
+app keep = serve
+  (Proxy @Routes)
+  $ static
+  :<|> cssHandlers
+  :<|> serverHandlers
+  :<|> apiHandlers keep
+  :<|> Tagged handle404
+  where
+    static = serveDirectoryWith (defaultWebAppSettings "ibb.jsexe")
+
+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