1 files changed, 152 insertions, 0 deletions
diff --git a/Biz/Ibb/Server.hs b/Biz/Ibb/Server.hs
new file mode 100644
index 0000000..9f1ac5f
--- /dev/null
+++ b/Biz/Ibb/Server.hs
@@ -0,0 +1,152 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+
+-- | Server
+--
+-- : exe ibb
+--
+-- : dep clay
+-- : dep miso
+-- : dep protolude
+-- : dep servant
+-- : dep text
+-- : dep MonadRandom
+-- : dep acid-state
+-- : dep bytestring
+-- : dep ixset
+-- : dep random
+-- : dep safecopy
+-- : dep scotty
+-- : dep servant-server
+-- : dep text
+module Biz.Ibb.Server where
+
+import           Alpha
+import qualified Clay
+import           Biz.Ibb.Core
+import qualified Biz.Ibb.Keep    as Keep
+import qualified Biz.Ibb.Look    as Look
+import           Network.RemoteData
+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