showing time in header

Author: functora

ghcjs/delivery-calculator/src/App/Types.hs

@@ -74,12 +74,14 @@ data Model = Model
     modelDonateViewer :: [FieldPair DynamicField Unique],
     modelCurrencies :: NonEmpty CurrencyInfo,
     modelWebOpts :: Web.Opts,
-    modelMarket :: MVar Rates.Market
+    modelMarket :: MVar Rates.Market,
+    modelTime :: UTCTime
   }
   deriving stock (Eq, Generic)
 
 data Action
   = Noop
+  | Tick (Model -> Model)
   | InitUpdate (Maybe (St Unique))
   | SyncInputs
   | LinkUpdate (Model -> Model)
@@ -90,7 +92,6 @@ data St f = St
   { stAssets :: [Asset f],
     stAssetCurrency :: Currency f,
     stExchangeRate :: Field Rational f,
-    stExchangeRateAt :: UTCTime,
     stMerchantCurrency :: Currency f,
     stMerchantTele :: Field Unicode f,
     stMerchantWhats :: Field Unicode f,
@@ -121,7 +122,6 @@ newSt :: (MonadIO m) => m (St Unique)
 newSt = do
   assetCur <- newCurrency cny
   rate <- newRatioField 1
-  ct <- getCurrentTime
   merchantCur <- newCurrency rub
   tele <- newTextField "Functora"
   whats <- newTextField "TODO"
@@ -132,7 +132,6 @@ newSt = do
       { stAssets = mempty,
         stAssetCurrency = assetCur,
         stExchangeRate = rate,
-        stExchangeRateAt = ct,
         stMerchantCurrency = merchantCur,
         stMerchantTele = tele,
         stMerchantWhats = whats,

ghcjs/delivery-calculator/src/App/Widgets/Menu.hs

@@ -6,6 +6,8 @@ module App.Widgets.Menu
 where
 
 import App.Types
+import qualified Data.Time.Format as TF
+import qualified Data.Time.LocalTime as LT
 import qualified Functora.Miso.Jsm as Jsm
 import Functora.Miso.Prelude
 import qualified Functora.Miso.Widgets.BrowserLink as BrowserLink
@@ -22,11 +24,10 @@ menu st =
   [ keyed "menu"
       $ nav_
         [ style_
-            [ ("grid-template-columns", "1fr auto")
+            [ ("grid-template-columns", "auto 1fr")
             ]
         ]
-        [ div_ mempty mempty,
-          button_
+        [ button_
             [ role_ "button",
               style_
                 [ ("min-width", "0")
@@ -38,6 +39,13 @@ menu st =
                 .~ Opened
             ]
             [ icon Icon.IconMenu
+            ],
+          label_
+            mempty
+            [ text
+                . from @String @Unicode
+                $ TF.formatTime TF.defaultTimeLocale "%H:%M" chinaTime
+                <> " in China"
             ]
         ]
   ]
@@ -203,6 +211,10 @@ menu st =
                  ]
         }
   where
+    chinaTime =
+      LT.utcToLocalTime chinaTimeZone $ modelTime st
+    chinaTimeZone =
+      LT.hoursToTimeZone 8
     shareOnClick :: Attribute Action
     shareOnClick =
       onClick

ghcjs/delivery-calculator/src/App/Widgets/Templates.hs

@@ -22,6 +22,7 @@ newModel webOpts sink mSt uri = do
   mApp <- unShareUri uri
   donate <- newDonateViewer
   market <- maybe Rates.newMarket pure $ mSt ^? _Just . #modelMarket
+  ct <- getCurrentTime
   pure
     Model
       { modelSink = sink,
@@ -37,7 +38,8 @@ newModel webOpts sink mSt uri = do
         modelCurrencies =
           fromMaybe [btc, usd, rub, cny] (mSt ^? _Just . #modelCurrencies),
         modelWebOpts = webOpts,
-        modelMarket = market
+        modelMarket = market,
+        modelTime = ct
       }
 
 newDonateViewer :: (MonadIO m) => m [FieldPair DynamicField Unique]

ghcjs/delivery-calculator/src/Main.hs

@@ -120,8 +120,14 @@ runApp = JSaddle.Wasm.run
 
 updateModel :: Action -> Model -> Effect Action Model
 updateModel Noop st = noEff st
+updateModel (Tick f) st =
+  f st <# do
+    sleepSeconds 1
+    ct <- getCurrentTime
+    pure . Tick $ #modelTime .~ ct
 updateModel (InitUpdate ext) prevSt = do
   effectSub prevSt $ \sink -> do
+    liftIO . sink $ Tick id
     mvSink <- newMVar sink
     let nextSt = prevSt {modelSink = mvSink}
     if isJust ext
@@ -383,28 +389,27 @@ evalModel prev = do
                 . #stAssetCurrency
                 . #currencyOutput
                 . #currencyInfoCode
-        let prevQuote =
-              Rates.QuoteAt
-                { Rates.quoteMoneyAmount =
-                    Tagged $ prev ^. #modelState . #stExchangeRate . #fieldOutput,
-                  Rates.quoteCreatedAt =
-                    prev ^. #modelState . #stExchangeRateAt,
-                  Rates.quoteUpdatedAt =
-                    prev ^. #modelState . #stExchangeRateAt
-                }
-        nextQuote <-
-          fmap (fromRight prevQuote)
+        rateValue <-
+          fmap
+            ( either
+                ( const
+                    $ prev
+                    ^. #modelState
+                    . #stExchangeRate
+                    . #fieldOutput
+                )
+                ( ^.
+                    #quoteMoneyAmount
+                      . to unTagged
+                )
+            )
             . Rates.tryMarket
             . Rates.getQuote web base
             $ prev
             ^. #modelState
             . #stMerchantCurrency
             . #currencyOutput
             . #currencyInfoCode
-        let rateValue =
-              unTagged $ nextQuote ^. #quoteMoneyAmount
-        let rateUpdated =
-              nextQuote ^. #quoteCreatedAt
         pure
           $ ( #modelState
                 %~ Syb.everywhere
@@ -427,10 +432,6 @@ evalModel prev = do
                 . #fieldOutput
                 .~ rateValue
             )
-          . ( #modelState
-                . #stExchangeRateAt
-                .~ rateUpdated
-            )
 
 syncUri :: URI -> JSM ()
 syncUri uri = do