Hook up jumping to an earlier time with the slider on the catalog page

src/Action.hs

@@ -5,6 +5,7 @@ module Action where
 import Data.Text (Text)
 import Data.Aeson (FromJSON)
 import Data.Int (Int64)
+import Data.Time.Clock (UTCTime)
 import Miso (URI)
 
 import qualified Component.CatalogGrid as Grid
@@ -13,7 +14,6 @@ import Network.CatalogPostType (CatalogPost)
 import Network.Http (HttpResult)
 import Network.SiteType (Site)
 import qualified Component.ThreadView as Thread
-import qualified Component.ThreadView as Thread
 import qualified Component.TimeControl as TC
 
 data GetThreadArgs = GetThreadArgs
@@ -24,12 +24,12 @@ data GetThreadArgs = GetThreadArgs
 
 data Action
     = GridAction Grid.Action
-    | GetLatest
     | GetThread GetThreadArgs
     | HaveLatest (HttpResult [ CatalogPost ])
     | HaveThread (HttpResult [ Site ])
     | forall a. (FromJSON a) => ClientAction (HttpResult a -> Action) (C.Action a)
     | ThreadAction Thread.Action
     | TimeAction TC.Time
+    | GoToTime UTCTime
     | ChangeURI URI
     | NoAction

src/Component/TimeControl.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Component.TimeControl where
 
@@ -20,13 +21,18 @@ import Miso
     , onChange
     )
 
-import Miso.String (toMisoString)
+import Miso.String (toMisoString, fromMisoString)
-import Data.Time.Clock (UTCTime)
 import GHCJS.DOM.Types (JSString)
+import Data.Time.Clock
+  ( UTCTime (..)
+  , getCurrentTime
+  , diffUTCTime
+  , addUTCTime
+  )
+import Data.Time.Calendar (fromGregorian, Day)
 
 data Time
   = Now
-  | At UTCTime
   | NoAction
   | SlideInput JSString
   | SlideChange JSString
@@ -34,10 +40,18 @@ data Time
 
 data Interface a = Interface
     { passAction :: Time -> a
+    , goTo :: UTCTime -> a
     }
 
-view :: Interface a -> View a
+data Model = Model
-view iface =
+  { whereAt :: Integer
+  } deriving Eq
+
+initialModel :: Integer -> Model
+initialModel = Model
+
+view :: Interface a -> Model -> View a
+view iface m =
     div_
         [ class_ "time-control"
         ]
@@ -47,7 +61,7 @@ view iface =
             , min_ "-500"
             , max_ "0"
             , step_ "1"
-            , value_ "0"
+            , value_ $ toMisoString $ show (whereAt m)
             , onInput $ pass SlideInput
             , onChange $ pass SlideChange
             ]
@@ -59,21 +73,47 @@ view iface =
 update
     :: Interface a
     -> Time
-    -> ()
+    -> Model
-    -> Effect a ()
+    -> Effect a Model
-update iface (At time) m = m <# do
-  consoleLog $ toMisoString $ show time
-
-  return $ (passAction iface) NoAction
-
 update iface (SlideInput time) m = m <# do
   consoleLog $ "Input: " <> time
 
   return $ (passAction iface) NoAction
 
-update iface (SlideChange time) m = m <# do
+update iface (SlideChange nstr) m = m { whereAt = n } <# do
-  consoleLog $ "Change: " <> time
+  consoleLog $ "Change: " <> nstr
+
+  now <- getCurrentTime
+
+  return $ (goTo iface) $ interpolateTimeHours n now
+
+  where
+    n :: Integer
+    n = read $ fromMisoString nstr
 
-  return $ (passAction iface) NoAction
 
 update _ _ m = noEff m
+
+
+earliestDate :: Day
+earliestDate = fromGregorian 2020 12 1
+
+
+-- Linear interpolation function using hours
+interpolateTimeHours :: Integer -> UTCTime -> UTCTime
+interpolateTimeHours n currentTime
+  | n == 0 = currentTime
+  | otherwise = addUTCTime (fromIntegral hoursToAdjust * secondsInHour) currentTime
+
+  where
+    targetDate = UTCTime earliestDate 0
+
+    -- Calculate the total number of hours between the current time and the target date
+    totalHours = diffUTCTime currentTime targetDate / secondsInHour
+
+    -- Calculate the number of hours to adjust based on linear interpolation
+    hoursToAdjust :: Integer
+    hoursToAdjust = round $ totalHours * (fromIntegral n / 500.0)
+
+    -- One hour in seconds
+    secondsInHour = 3600

src/Main.hs

@@ -11,6 +11,7 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Network.URI (uriPath)
 import System.FilePath ((</>))
+import Data.Time.Clock (UTCTime, getCurrentTime)
 
 import Data.Aeson (FromJSON)
 import Data.JSString (pack, append)
@@ -55,6 +56,8 @@ data Model = Model
     , thread_model :: Maybe Thread.Model
     , current_uri :: URI
     , media_root_ :: JSString
+    , current_time :: UTCTime
+    , tc_model :: TC.Model
     } deriving Eq
 
 
@@ -66,7 +69,7 @@ initialActionFromRoute model uri = either (const NoAction) id routing_result
         handlers = h_latest :<|> h_thread
 
         h_latest :: Model -> Action
-        h_latest = const GetLatest
+        h_latest = const $ GoToTime $ current_time model
 
         h_thread :: Text -> Text -> BoardThreadId -> Model -> Action
         h_thread website board_pathpart board_thread_id _ = GetThread GetThreadArgs {..}
@@ -77,8 +80,9 @@ initialModel
     -> Int
     -> JSString
     -> URI
+    -> UTCTime
     -> Model
-initialModel pgroot client_fetch_count media_root u = Model
+initialModel pgroot client_fetch_count media_root u t = Model
     { grid_model = Grid.initialModel media_root
     , client_model = Client.Model
         { Client.pgApiRoot = pgroot
@@ -87,6 +91,8 @@ initialModel pgroot client_fetch_count media_root u = Model
     , thread_model = Nothing
     , current_uri = u
     , media_root_ = media_root
+    , current_time = t
+    , tc_model = TC.initialModel 0
     }
 
 getMetadata :: String -> IO (Maybe JSString)
@@ -119,7 +125,13 @@ main = do
     media_root <- getMetadata "media-root" >>=
         return . maybe "undefined" id
 
-    let initial_model = initialModel pg_api_root pg_fetch_count media_root uri
+    now <- getCurrentTime
+
+    let initial_model = initialModel
+          pg_api_root
+          pg_fetch_count
+          media_root uri
+          now
 
     startApp App
         { model         = initial_model
@@ -143,9 +155,9 @@ mainView model = view
         handlers = catalog_view :<|> thread_view
 
         catalog_view :: Model -> View Action
-        catalog_view _ = div_ []
+        catalog_view m = div_ []
             [ h1_ [] [ text "Overboard Catalog" ]
-            , TC.view iTime
+            , TC.view iTime (tc_model m)
             , Grid.view iGrid (grid_model model)
             ]
 
@@ -188,7 +200,8 @@ mainUpdate (HaveThread (Client.HttpResponse {..})) m = new_model <# do
                 body >>= Just . (Thread.initialModel $ media_root_ m) . head
             }
 
-mainUpdate GetLatest m = m <# Client.fetchLatest (client_model m) (iClient HaveLatest)
+mainUpdate (GoToTime t) m = m { current_time = t } <# do
+  Client.fetchLatest (client_model m) t (iClient HaveLatest)
 
 -- mainUpdate GetThread {..} m = noEff m
 
@@ -225,9 +238,8 @@ mainUpdate (ThreadAction ta) model = do
     noEff model { thread_model = tm }
 
 mainUpdate (TimeAction ta) m =
-  TC.update iTime ta ()
+  TC.update iTime ta (tc_model m)
-  >> noEff m
+  >>= \tm -> noEff m { tc_model = tm }
-
 
 iGrid :: Grid.Interface Action
 iGrid = Grid.Interface
@@ -253,7 +265,10 @@ iThread :: Thread.Interface Action
 iThread = Thread.Interface { Thread.passAction = ThreadAction }
 
 iTime :: TC.Interface Action
-iTime = TC.Interface { TC.passAction = TimeAction }
+iTime = TC.Interface
+  { TC.passAction = TimeAction
+  , TC.goTo = GoToTime
+  }
 
 {-
  - TODO:

src/Network/Client.hs

@@ -68,12 +68,10 @@ http_ m iface api_path method payload =
     >>= return . (passAction iface) . Connect
 
 
-fetchLatest :: Model -> Interface a [ CatalogPost ] -> IO a
+fetchLatest :: Model -> UTCTime -> Interface a [ CatalogPost ] -> IO a
-fetchLatest m iface = do
+fetchLatest m t iface = do
-    now <- getCurrentTime
-
     let payload = Just $ FetchCatalogArgs
-            { max_time = now
+            { max_time = t
             , max_row_read = fetchCount m
             }