diff options
Diffstat (limited to 'Com/InfluencedByBooks/Server.hs')
| -rw-r--r-- | Com/InfluencedByBooks/Server.hs | 147 |
1 files changed, 75 insertions, 72 deletions
diff --git a/Com/InfluencedByBooks/Server.hs b/Com/InfluencedByBooks/Server.hs index 28a7471..244a7ca 100644 --- a/Com/InfluencedByBooks/Server.hs +++ b/Com/InfluencedByBooks/Server.hs @@ -27,21 +27,23 @@ -- : dep text module Com.InfluencedByBooks.Server where +import Alpha 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 qualified Com.InfluencedByBooks.Keep as Keep +import qualified Com.InfluencedByBooks.Look as Look 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 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.Media ( (//) + , (/:) + ) import Network.HTTP.Types import Network.Wai import Network.Wai.Application.Static @@ -49,58 +51,57 @@ import Network.Wai.Handler.Warp import Network.Wai.Middleware.Gzip import Network.Wai.Middleware.RequestLogger import Servant -import System.Environment (lookupEnv) +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/" + 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 } + 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] + 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 } +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 @@ -111,39 +112,41 @@ instance Accept CSS where type CssRoute = "css" :> "main.css" :> Get '[CSS] Text type Routes - = "static" :> Raw - :<|> CssRoute - :<|> ServerRoutes - :<|> "api" :> ApiRoutes - :<|> Raw + = "static" + :> + Raw + :<|> + CssRoute + :<|> + ServerRoutes + :<|> + "api" + :> + ApiRoutes + :<|> + Raw cssHandlers :: Server CssRoute -cssHandlers = return . Lazy.toStrict . Clay.render - $ Look.main +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] +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 + 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 +apiHandlers keep = Acid.query' keep $ Keep.GetPeople 20 |