summaryrefslogtreecommitdiff
path: root/lore/Biz
diff options
context:
space:
mode:
Diffstat (limited to 'lore/Biz')
-rw-r--r--lore/Biz/Ibb/Core.hs24
-rw-r--r--lore/Biz/Ibb/Influencers.hs13
-rw-r--r--lore/Biz/Ibb/Move.hs36
3 files changed, 65 insertions, 8 deletions
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
+ }