almost working

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
+                  }