summaryrefslogtreecommitdiff
path: root/Com/InfluencedByBooks
diff options
context:
space:
mode:
Diffstat (limited to 'Com/InfluencedByBooks')
-rw-r--r--Com/InfluencedByBooks/Client.hs28
-rw-r--r--Com/InfluencedByBooks/Core.hs102
-rw-r--r--Com/InfluencedByBooks/Look.hs34
-rw-r--r--Com/InfluencedByBooks/Move.hs57
-rw-r--r--Com/InfluencedByBooks/Server.hs147
5 files changed, 197 insertions, 171 deletions
diff --git a/Com/InfluencedByBooks/Client.hs b/Com/InfluencedByBooks/Client.hs
index a7da344..8c70a04 100644
--- a/Com/InfluencedByBooks/Client.hs
+++ b/Com/InfluencedByBooks/Client.hs
@@ -16,17 +16,23 @@
-- : dep ghcjs-base
module Com.InfluencedByBooks.Client where
-import Com.InfluencedByBooks.Core (Action(..), see, init)
-import Com.InfluencedByBooks.Move (move)
-import Com.Simatime.Alpha
-import Miso (App(..), defaultEvents, miso)
+import Alpha
+import Com.InfluencedByBooks.Core ( Action(..)
+ , see
+ , init
+ )
+import Com.InfluencedByBooks.Move ( move )
+import Miso ( App(..)
+ , defaultEvents
+ , miso
+ )
main :: IO ()
main = miso $ \u -> App { model = init u, .. }
- where
- initialAction = FetchPeople
- update = move
- view = see
- events = defaultEvents
- subs = []
- mountPoint = Nothing
+ where
+ initialAction = FetchPeople
+ update = move
+ view = see
+ events = defaultEvents
+ subs = []
+ mountPoint = Nothing
diff --git a/Com/InfluencedByBooks/Core.hs b/Com/InfluencedByBooks/Core.hs
index 6984004..2b98914 100644
--- a/Com/InfluencedByBooks/Core.hs
+++ b/Com/InfluencedByBooks/Core.hs
@@ -7,16 +7,18 @@
-- | Main app logic
module Com.InfluencedByBooks.Core where
-import Com.Simatime.Alpha
-import Com.Simatime.Network
-import Data.Aeson hiding (Success)
-import Data.Data (Data, Typeable)
-import Data.Text (Text)
-import GHC.Generics (Generic)
-import Miso
-import Miso.String
-import Servant.API
-import Servant.Links
+import Alpha
+import Com.Simatime.Network
+import Data.Aeson hiding ( Success )
+import Data.Data ( Data
+ , Typeable
+ )
+import Data.Text ( Text )
+import GHC.Generics ( Generic )
+import Miso
+import Miso.String
+import Servant.API
+import Servant.Links
-- * entity data types
@@ -79,51 +81,63 @@ handlers :: Model -> View Action
handlers = home
notfound :: View Action
-notfound = div_ [] [ text "404" ]
+notfound = div_ [] [text "404"]
goHome :: URI
-goHome = linkURI $ safeLink
- (Proxy :: Proxy AppRoutes)
- (Proxy :: Proxy Home)
+goHome = linkURI $ safeLink (Proxy :: Proxy AppRoutes) (Proxy :: Proxy Home)
see :: Model -> View Action
-see m = div_ [ class_ "container mt-5" ]
- [ div_ [ class_ "jumbotron" ]
- [ h1_ [ class_ "display-4" ] [ text "Influenced by books" ]
- , p_ [ class_ "lead" ] [ text "Influential people and the books that made them." ]
- , p_ [ class_ "lead" ]
- [ a_ [ href_ "http://eepurl.com/ghBFjv" ]
- [ text "Get new book recommendations from the world's influencers in your email." ]
- ]
+see m = div_
+ [class_ "container mt-5"]
+ [ div_
+ [class_ "jumbotron"]
+ [ h1_ [class_ "display-4"] [text "Influenced by books"]
+ , p_ [class_ "lead"]
+ [text "Influential people and the books that made them."]
+ , p_
+ [class_ "lead"]
+ [ a_
+ [href_ "http://eepurl.com/ghBFjv"]
+ [ text
+ "Get new book recommendations from the world's influencers in your email."
+ ]
]
- , div_ [ class_ "card-columns" ] $ case people m of
- NotAsked -> [ text "Initializing..." ]
- Loading -> [ text "Loading..." ]
- Failure err -> [ text err ]
- Success ps -> seePerson </ ps
+ ]
+ , div_ [class_ "card-columns"] $ case people m of
+ NotAsked -> [text "Initializing..."]
+ Loading -> [text "Loading..."]
+ Failure err -> [text err]
+ Success ps -> seePerson </ ps
]
seePerson :: Person -> View Action
-seePerson person = div_ [ class_ "card" ]
- [ div_ [ class_ "card-img" ]
- [ img_ [ class_ "card-img img-fluid", src_ $ ms $ _pic person ]]
- , div_ [ class_ "card-body" ]
- [ h4_ [ class_ "card-title" ] [ text $ ms $ _name person ]
- , h6_ [] [ a_ [ class_ "fab fa-twitter"
- , href_ $ "https://twitter.com/" <> (ms $ _twitter person) ] []
- , a_ [ class_ "fas fa-globe", href_ $ ms $ _website person ] []
- ]
- , p_ [ class_ "card-text" ]
- [ text $ ms $ _blurb person
- , ul_ [] $ seeBook </ _books person
+seePerson person = div_
+ [class_ "card"]
+ [ div_ [class_ "card-img"]
+ [img_ [class_ "card-img img-fluid", src_ $ ms $ _pic person]]
+ , div_
+ [class_ "card-body"]
+ [ h4_ [class_ "card-title"] [text $ ms $ _name person]
+ , h6_
+ []
+ [ a_
+ [ class_ "fab fa-twitter"
+ , href_ $ "https://twitter.com/" <> (ms $ _twitter person)
+ ]
+ []
+ , a_ [class_ "fas fa-globe", href_ $ ms $ _website person] []
]
+ , p_ [class_ "card-text"]
+ [text $ ms $ _blurb person, ul_ [] $ seeBook </ _books person]
]
]
seeBook :: Book -> View Action
-seeBook book = li_ []
- [ a_ [ class_ "text-dark"
- , href_ $ "https://www.amazon.com/dp/" <> (ms $ _amznref book)
- ]
- [ text $ ms $ _title book ]
+seeBook book = li_
+ []
+ [ a_
+ [ class_ "text-dark"
+ , href_ $ "https://www.amazon.com/dp/" <> (ms $ _amznref book)
+ ]
+ [text $ ms $ _title book]
]
diff --git a/Com/InfluencedByBooks/Look.hs b/Com/InfluencedByBooks/Look.hs
index acc9e34..d904d3a 100644
--- a/Com/InfluencedByBooks/Look.hs
+++ b/Com/InfluencedByBooks/Look.hs
@@ -2,14 +2,14 @@
{-# LANGUAGE NoImplicitPrelude #-}
-- | The look and feel of Ibb
-module Com.InfluencedByBooks.Look where
+module Com.InfluencedByBooks.Look where
+import Alpha hiding ( Selector )
import Clay
-import qualified Clay.Flexbox as Flexbox
-import qualified Clay.Media as Media
-import qualified Clay.Render as Clay
-import qualified Clay.Stylesheet as Stylesheet
-import Com.Simatime.Alpha hiding (Selector)
+import qualified Clay.Flexbox as Flexbox
+import qualified Clay.Media as Media
+import qualified Clay.Render as Clay
+import qualified Clay.Stylesheet as Stylesheet
main :: Css
main = do
@@ -25,18 +25,16 @@ main = do
display flex
justifyContent center
flexDirection column
- fontFamily [ "GillSans"
- , "Calibri"
- , "Trebuchet"
- ] [sansSerif]
+ fontFamily ["GillSans", "Calibri", "Trebuchet"] [sansSerif]
headings ? do
- fontFamily [ "Palatino"
- , "Palatino Linotype"
- , "Hoefler Text"
- , "Times New Roman"
- , "Times"
- ] [serif]
+ fontFamily
+ [ "Palatino"
+ , "Palatino Linotype"
+ , "Hoefler Text"
+ , "Times New Roman"
+ , "Times"
+ ]
+ [serif]
headings :: Selector
-headings =
- h1 <> h2 <> h3 <> h4 <> h5 <> h6
+headings = h1 <> h2 <> h3 <> h4 <> h5 <> h6
diff --git a/Com/InfluencedByBooks/Move.hs b/Com/InfluencedByBooks/Move.hs
index d6cb12e..5d6f0c4 100644
--- a/Com/InfluencedByBooks/Move.hs
+++ b/Com/InfluencedByBooks/Move.hs
@@ -2,25 +2,32 @@
{-# LANGUAGE OverloadedStrings #-}
-- | App update logic
-module Com.InfluencedByBooks.Move (
- move
+module Com.InfluencedByBooks.Move
+ ( move
-- * Server interactions
, fetchPeople
- ) where
+ )
+where
-import Com.InfluencedByBooks.Core as Core
-import Com.Simatime.Alpha
-import Com.Simatime.Network
-import Data.Aeson
-import JavaScript.Web.XMLHttpRequest (Request(..), Method(GET), RequestData(NoData), contents, xhrByteString)
-import Miso
-import Miso.String
+import Alpha
+import Com.InfluencedByBooks.Core as Core
+import Com.Simatime.Network
+import Data.Aeson
+import JavaScript.Web.XMLHttpRequest ( Request(..)
+ , Method(GET)
+ , RequestData(NoData)
+ , contents
+ , xhrByteString
+ )
+import Miso
+import Miso.String
move :: Action -> Model -> Effect Action Model
-move Nop m = noEff m
+move Nop m = noEff m
move (HandleRoute u) m = m { uri = u } <# pure Nop
-move (ChangeRoute u) m = m <# do pushURI u >> pure Nop
-move FetchPeople m = m <# (SetPeople </ fetchPeople)
+move (ChangeRoute u) m = m <# do
+ pushURI u >> pure Nop
+move FetchPeople m = m <# (SetPeople </ fetchPeople)
move (SetPeople ps) m = noEff m { people = ps }
fetchPeople :: IO (WebData [Core.Person])
@@ -28,16 +35,14 @@ fetchPeople = do
mjson <- contents </ xhrByteString req
case mjson of
Nothing -> pure $ Failure "could not read from server"
- Just a -> pure
- $ fromEither
- $ either (Left . ms) pure
- $ eitherDecodeStrict a
- where
- req = Request { reqMethod = GET
- -- FIXME: can replace this hardcoding with a function?
- , reqURI = "/api/people"
- , reqLogin = Nothing
- , reqHeaders = []
- , reqWithCredentials = False
- , reqData = NoData
- }
+ Just a ->
+ pure $ fromEither $ either (Left . ms) pure $ eitherDecodeStrict a
+ where
+ req = Request { reqMethod = GET
+ -- FIXME: can replace this hardcoding with a function?
+ , reqURI = "/api/people"
+ , reqLogin = Nothing
+ , reqHeaders = []
+ , reqWithCredentials = False
+ , reqData = NoData
+ }
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 19:34:19 +0000