diff options
author | Ben Sima <ben@bsima.me> | 2019-11-02 15:33:13 -0700 |
---|---|---|
committer | Ben Sima <ben@bsima.me> | 2019-11-02 15:33:13 -0700 |
commit | 9d114cfc773171b0a95bd4d2c39f1bb0eb783c8d (patch) | |
tree | 20766a760ed0141cf39153565e8552f6739c632d /com/influencedbybooks/apex.hs | |
parent | d2a37f5de160160eadbacd7b8dc2567f78a0543d (diff) |
rename everything back to caps to appease ghc
Diffstat (limited to 'com/influencedbybooks/apex.hs')
-rw-r--r-- | com/influencedbybooks/apex.hs | 129 |
1 files changed, 0 insertions, 129 deletions
diff --git a/com/influencedbybooks/apex.hs b/com/influencedbybooks/apex.hs deleted file mode 100644 index 32e6403..0000000 --- a/com/influencedbybooks/apex.hs +++ /dev/null @@ -1,129 +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 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 |