diff options
| author | Ben Sima <ben@bsima.me> | 2019-03-27 09:25:12 -0700 |
|---|---|---|
| committer | Ben Sima <ben@bsima.me> | 2019-03-27 09:25:35 -0700 |
| commit | 77ff3088b9c8ff217c6ed6fb9093a5aabb2ea3ca (patch) | |
| tree | 2ce318b75ed5b1d01827fca8a7a373f7888f0417 /apex/Ibb.hs | |
| parent | cfd213917c766c91f4c5fc7fdc91c2ca0ea13c26 (diff) | |
working miso app
structure is in place, need to add styles and logic
Diffstat (limited to 'apex/Ibb.hs')
| -rw-r--r-- | apex/Ibb.hs | 158 |
1 files changed, 57 insertions, 101 deletions
diff --git a/apex/Ibb.hs b/apex/Ibb.hs index 21c1043..ad9af38 100644 --- a/apex/Ibb.hs +++ b/apex/Ibb.hs @@ -1,118 +1,74 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +-- | Server module Ibb where -import Biz.Ibb (Person(..), Book(..), allPeople) -import Control.Monad.IO.Class (liftIO) -import Data.ByteString.Lazy (ByteString) +import Alpha +import Biz.Ibb import Data.Maybe (fromMaybe) -import Data.Text.Lazy (Text) -import Data.Text.Lazy.Encoding (encodeUtf8) +import Data.Proxy +import qualified Lucid as L +import Lucid.Base +import Miso +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Handler.Warp +import Network.Wai.Middleware.Gzip +import Network.Wai.Middleware.RequestLogger +import Servant import System.Environment (lookupEnv) -import System.Random (newStdGen) -import System.Random.Shuffle (shuffle') -import Text.Blaze (Markup) -import Text.Blaze.Html (Html) -import Text.Blaze.Html.Renderer.Text (renderHtml) -import Text.Hamlet (shamlet) -import Text.Lucius (lucius, renderCss) -import Web.Scotty (ActionM, ScottyM, scotty, get, html, raw, setHeader) - -render :: Html -> ActionM () -render = html . renderHtml - -css :: ByteString -> ActionM () -css src = setHeader "content-type" "text/css" >> raw src main :: IO () main = do - port <- read <$> fromMaybe "3000" <$> lookupEnv "PORT" :: IO Int - scotty port routes + say "running" + port <- read + <$> fromMaybe "3000" + <$> lookupEnv "PORT" :: IO Int + run port $ logStdout $ compress $ app + where + compress = gzip def { gzipFiles = GzipCompress } -routes :: ScottyM () -routes = do - get "/" $ do - r <- liftIO newStdGen - let peopleList = shuffle' allPeople (length allPeople) r - render (homepage peopleList) - get "/custom.css" $ css stylesheet +newtype HtmlPage a = HtmlPage a + deriving (Show, Eq) -displayPerson :: Person -> Markup -displayPerson person = [shamlet| -<div .card> - <img .card-img .img-fluid src=#{_pic person}> - <div .card-body> - <h4 .card-title> - #{_name person} - <h6> - <a target=_blank href="https://twitter.com/#{_twitter person}" class="fab fa-twitter"> - <a target=_blank href=#{_website person} class="fas fa-globe"> - <p .card-text> - #{_blurb person} - <ul> - $forall book <- (_books person) - <li> - <a target=_blank .text-dark href="https://www.amazon.com/dp/#{_amznref book}"> - #{_title book} -|] +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 "ibb.jsexe/all.js" + L.body_ (L.toHtml x) + where + jsRef href = L.with (L.script_ mempty) + [ makeAttribute "src" href + , makeAttribute "async" mempty + , makeAttribute "defer" mempty + ] -title, subtitle :: Text -title = "Influenced By Books" -subtitle = "Influential people and the books that made them." +type ServerRoutes = ToServerRoutes Routes HtmlPage Action -homepage :: [Person] -> Markup -homepage peopleList = [shamlet| -<!doctype html> -<head> - <meta charset="utf-8"> - <meta name="viewport" content="width=device-width, initial-scale=1, shrink-to-fit=no"> - <link href="https://stackpath.bootstrapcdn.com/bootstrap/4.2.1/css/bootstrap.min.css" - rel="stylesheet" - integrity="sha384-GJzZqFGwb1QTTN6wy59ffF1BuGJpLSa9DkKMp0DgiMDm4iYMj70gZWKYbI706tWS" - crossorigin="anonymous"> - <link rel="stylesheet" - href="https://use.fontawesome.com/releases/v5.7.1/css/all.css" - integrity="sha384-fnmOCqbTlWIlj8LyTjo7mOUStjsKC4pOpQbqyi7RrhN7udi9RwhKkMHpvLbHG9Sr" - crossorigin="anonymous"> - <link href="/custom.css" rel="stylesheet"> - <title>#{title} | #{subtitle} - <script> - (function(f, a, t, h, o, m){ - a[h]=a[h]||function(){ - (a[h].q=a[h].q||[]).push(arguments) - }; - o=f.createElement('script'), - m=f.getElementsByTagName('script')[0]; - o.async=1; o.src=t; o.id='fathom-script'; - m.parentNode.insertBefore(o,m) - })(document, window, '//stats.simatime.com/tracker.js', 'fathom'); - fathom('set', 'siteId', 'IJATN'); - fathom('trackPageview'); -<body> - <div .container.mt-5> - <div .jumbotron> - <h1 .display-4> - #{title} - <p .lead> - #{subtitle} +handle404 :: Application +handle404 _ respond = respond + $ responseLBS status404 [("Content-Type", "text/html")] + $ renderBS + $ toHtml + $ HtmlPage + $ notfound - <p .lead> - <a href="http://eepurl.com/ghBFjv"> - Get new book recommendations from the world's influencers in your email. +type Api = ServerRoutes :<|> Raw - <div .card-columns> - $forall person <- peopleList - #{displayPerson person} -|] +app :: Application +app = serve (Proxy @Api) + $ serverHandlers :<|> Tagged handle404 -stylesheet :: ByteString -stylesheet = encodeUtf8 . renderCss $ [lucius| -.jumbotron -{ background: #fff -; text-align: center -} -h1.display-4 -{ font-family: 'Times New Roman', times, serif -} -|] undefined +serverHandlers :: Server ServerRoutes +serverHandlers = homeHandler + where + send f u = + pure $ HtmlPage $ f Model { modelUri = u, people = [] } + homeHandler = send home goHome |