diff --git a/src/Action.hs b/src/Action.hs index bba52fd..6b46da3 100644 --- a/src/Action.hs +++ b/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 diff --git a/src/Component/TimeControl.hs b/src/Component/TimeControl.hs index 66a2526..f858a38 100644 --- a/src/Component/TimeControl.hs +++ b/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 Data.Time.Clock (UTCTime) +import Miso.String (toMisoString, fromMisoString) 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 -view iface = +data Model = Model + { 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 - -> () - -> Effect a () -update iface (At time) m = m <# do - consoleLog $ toMisoString $ show time - - return $ (passAction iface) NoAction - + -> Model + -> Effect a Model update iface (SlideInput time) m = m <# do consoleLog $ "Input: " <> time return $ (passAction iface) NoAction -update iface (SlideChange time) m = m <# do - consoleLog $ "Change: " <> time +update iface (SlideChange nstr) m = m { whereAt = n } <# do + 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 diff --git a/src/Main.hs b/src/Main.hs index d802233..93e7908 100644 --- a/src/Main.hs +++ b/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 () - >> noEff m - + TC.update iTime ta (tc_model 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: diff --git a/src/Network/Client.hs b/src/Network/Client.hs index b206923..c573c4f 100644 --- a/src/Network/Client.hs +++ b/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 m iface = do - now <- getCurrentTime - +fetchLatest :: Model -> UTCTime -> Interface a [ CatalogPost ] -> IO a +fetchLatest m t iface = do let payload = Just $ FetchCatalogArgs - { max_time = now + { max_time = t , max_row_read = fetchCount m }