diff options
| -rw-r--r-- | aero/Ibb.hs | 6 | ||||
| -rw-r--r-- | apex/Ibb.hs | 18 | ||||
| -rw-r--r-- | lore/Biz/Ibb/Core.hs | 24 | ||||
| -rw-r--r-- | lore/Biz/Ibb/Influencers.hs | 13 | ||||
| -rw-r--r-- | lore/Biz/Ibb/Move.hs | 36 |
5 files changed, 81 insertions, 16 deletions
diff --git a/aero/Ibb.hs b/aero/Ibb.hs index 8376060..f7ee2af 100644 --- a/aero/Ibb.hs +++ b/aero/Ibb.hs @@ -1,16 +1,18 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NoImplicitPrelude #-} -- | Front-end module Ibb where +import Alpha import Biz.Ibb.Move import Miso main :: IO () -main = miso $ \u -> App { model = Model u [], .. } +main = miso $ \u -> App { model = init u, .. } where - initialAction = Nop + initialAction = FetchPeople update = move view = see events = defaultEvents diff --git a/apex/Ibb.hs b/apex/Ibb.hs index ad9af38..dd26d96 100644 --- a/apex/Ibb.hs +++ b/apex/Ibb.hs @@ -16,6 +16,7 @@ import Lucid.Base import Miso 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 @@ -41,13 +42,14 @@ instance L.ToHtml a => L.ToHtml (HtmlPage a) where L.doctypehtml_ $ do L.head_ $ do L.meta_ [L.charset_ "utf-8"] - jsRef "ibb.jsexe/all.js" + jsRef "/static/app.js" L.body_ (L.toHtml x) where jsRef href = L.with (L.script_ mempty) [ makeAttribute "src" href - , makeAttribute "async" mempty - , makeAttribute "defer" mempty + , makeAttribute "type" "text/javascript" + -- , makeAttribute "async" mempty + -- , makeAttribute "defer" mempty ] type ServerRoutes = ToServerRoutes Routes HtmlPage Action @@ -60,15 +62,19 @@ handle404 _ respond = respond $ HtmlPage $ notfound -type Api = ServerRoutes :<|> Raw +type Api = "static" :> Raw + :<|> ServerRoutes + :<|> Raw app :: Application app = serve (Proxy @Api) - $ serverHandlers :<|> Tagged handle404 + $ static :<|> serverHandlers :<|> Tagged handle404 + where + static = serveDirectoryWith (defaultWebAppSettings "ibb.jsexe") serverHandlers :: Server ServerRoutes serverHandlers = homeHandler where send f u = - pure $ HtmlPage $ f Model { modelUri = u, people = [] } + pure $ HtmlPage $ f Model { uri = u, people = NotAsked } homeHandler = send home goHome diff --git a/lore/Biz/Ibb/Core.hs b/lore/Biz/Ibb/Core.hs index 8fd0068..4ec87e3 100644 --- a/lore/Biz/Ibb/Core.hs +++ b/lore/Biz/Ibb/Core.hs @@ -17,14 +17,28 @@ type Routes = Home type Home = View Action data Model = Model - { modelUri :: URI - , people :: [Person] + { uri :: URI + , people :: WebData [Person] } deriving (Show, Eq) +data RemoteData e a + = NotAsked + | Loading + | Failure e + | Success a + deriving (Show, Eq) + +type WebData a = RemoteData MisoString a + +init :: URI -> Model +init u = Model u Loading + data Action = Nop | ChangeRoute URI | HandleRoute URI + | FetchPeople + | SetPeople (WebData [Person]) deriving (Show, Eq) home :: Model -> View Action @@ -51,7 +65,11 @@ see m = div_ [ class_ "container mt-5" ] [ text "Get new book recommendations from the world's influencers in your email." ] ] ] - , div_ [ class_ "card-columns" ] $ seePerson /@ people m + , 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 diff --git a/lore/Biz/Ibb/Influencers.hs b/lore/Biz/Ibb/Influencers.hs index beeaf41..f00fe2e 100644 --- a/lore/Biz/Ibb/Influencers.hs +++ b/lore/Biz/Ibb/Influencers.hs @@ -1,7 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} module Biz.Ibb.Influencers where +import Data.Aeson import Data.Text.Lazy (Text) +import GHC.Generics (Generic) data Person = Person { _name :: Text @@ -10,13 +13,19 @@ data Person = Person , _website :: Text , _books :: [Book] , _blurb :: Text - } deriving (Show, Eq) + } deriving (Generic, Show, Eq) + +instance FromJSON Person +instance ToJSON Person data Book = Book { _title :: Text , _author :: Text , _amznref :: Text - } deriving (Show, Eq) + } deriving (Generic, Show, Eq) + +instance FromJSON Book +instance ToJSON Book allPeople :: [Person] allPeople = diff --git a/lore/Biz/Ibb/Move.hs b/lore/Biz/Ibb/Move.hs index 9ff9b34..291e015 100644 --- a/lore/Biz/Ibb/Move.hs +++ b/lore/Biz/Ibb/Move.hs @@ -1,12 +1,42 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} -- | App update logic module Biz.Ibb.Move ( - module X + module Core , move + -- * Server interactions + , fetchPeople ) where -import Biz.Ibb.Core as X +import Alpha +import Data.Aeson +import Biz.Ibb.Influencers (Person) +import Biz.Ibb.Core as Core +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 = undefined +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 <# do SetPeople /@ fetchPeople +move (SetPeople ps) m = noEff m { people = ps } + +fetchPeople :: IO (WebData [Person]) +fetchPeople = do + mjson <- contents /@ xhrByteString req + case mjson of + Nothing -> pure $ Failure "could not read from server" + Just json -> pure + $ either (Failure . ms) Core.Success + $ eitherDecodeStrict json + where + req = Request { reqMethod = GET + , reqURI = "/api/people" -- FIXME: can replace this hardcoding with a function? + , reqLogin = Nothing + , reqHeaders = [] + , reqWithCredentials = False + , reqData = NoData + } |