Index.hs
module Frontend.Component.Index where
import Prelude
import Control.Monad.Rec.Class (forever)
import Data.Either (Either(..), hush, isLeft, note)
import Data.Maybe (Maybe(..), fromMaybe, isJust)
import Data.Monoid (guard)
import Data.Symbol (SProxy(..))
import Data.Traversable (for, sequence)
import Effect.Aff (Milliseconds(..), delay, error, forkAff, killFiber)
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Class.Console (log)
import Frontend.Api (fetchConfig, fetchInfo, fetchInfoImage)
import Frontend.Assets (certiconLogo)
import Frontend.Assets as Assets
import Frontend.Component.Cameras as Cameras
import Frontend.Component.Dashboard as Dashboard
import Frontend.Component.Filtering as Filtering
import Frontend.Component.Statistics as Statistics
import Frontend.Component.Zones as Zones
import Frontend.Route (Route(..), navigate, routeCodec)
import Frontend.Types (Config(..), Info)
import Frontend.Util (classes)
import Graphics.Canvas (CanvasImageSource)
import Halogen (SubscriptionId)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Query.EventSource (EventSource)
import Halogen.Query.EventSource as EventSource
import Routing.Duplex (parse, print)
import Routing.Hash (getHash)
import Web.Event.Event (preventDefault)
import Web.UIEvent.MouseEvent (MouseEvent, toEvent)
type State =
{ info :: Maybe Info
, config :: Maybe Config
, mapImage :: Maybe CanvasImageSource
, route :: Maybe Route
, infoUpdater :: Maybe SubscriptionId
, sidebar :: Boolean
}
data Action
= Initialize
| GoTo Route MouseEvent
| InfoTick
| AutoUpdate Boolean
| ToggleSidebar
data Query a = Navigate Route a
type Slots =
( dashboard :: forall query. H.Slot query Void Unit
, tracklets :: forall query. H.Slot query Void Unit
, statistics :: forall query. H.Slot query Void Unit
, filtering :: forall query. H.Slot query Void Unit
, zones :: forall query. H.Slot query Void Unit
, cameras :: forall query. H.Slot query Void Unit
)
-- _tracklets = SProxy :: SProxy "tracklets"
component :: forall i o m. MonadAff m => H.Component HH.HTML Query i o m
component =
H.mkComponent
{ initialState: \_ ->
{ info: Nothing
, config: Nothing
, mapImage: Nothing
, route: Nothing
, infoUpdater: Nothing
, sidebar: true
}
, render
, eval: H.mkEval $ H.defaultEval
{ handleAction = handleAction
, handleQuery = handleQuery
, initialize = Just Initialize
}
}
pageLink :: forall w i. Route -> String -> Boolean -> HH.HTML w i
pageLink route icon active =
HH.li [ classes $ ["nav-item"] <> if active then ["active"] else [] ]
[ HH.a [ HP.href ("/web/#" <> print routeCodec route), classes ["nav-link"] ]
[ HH.i [ classes ["fas", "fa-fw", icon] ] []
, HH.span_ [ HH.text $ show route ]
]
]
sidebar :: forall m. MonadAff m => Maybe Route -> Info -> H.ComponentHTML Action Slots m
sidebar route info =
HH.ul [ HP.id_ "accordionSidebar", classes ["navbar-nav", "bg-gradient-primary", "sidebar", "sidebar-dark", "accordion"] ]
[ HH.a
[ HP.href "/web/#/", classes ["sidebar-brand", "d-flex", "align-items-center", "justify-content-center"] ]
[ HH.img [ HP.src Assets.logoWhite, classes ["sidebar-brand-icon"] ]
, HH.div [ classes ["sidebar-brand-text", "mx-3"]]
[ HH.text "Retail Analytics" ]
]
, HH.hr [ classes ["sidebar-divider", "my-0"] ]
, Dashboard # \a -> pageLink a "fa-tachometer-alt" (route == Just a)
, HH.hr [ classes ["sidebar-divider"] ]
, HH.div [ classes ["sidebar-heading"] ]
[ HH.text "Analytics" ]
, Tracking # \a -> pageLink a "fa-map-marker" (route == Just a)
, Filtering # \a -> pageLink a "fa-filter" (route == Just a)
, Statistics # \a -> pageLink a "fa-table" (route == Just a)
, Zones # \a -> pageLink a "fa-shapes" (route == Just a)
, Cameras # \a -> pageLink a "fa-video" (route == Just a)
, HH.hr [ classes ["sidebar-divider"] ]
, HH.div [ classes ["sidebar-heading"] ]
[ HH.text "External Links" ]
, HH.li [ classes ["nav-item"] ]
[ HH.a [ HP.href "/", classes ["nav-link"] ]
[ HH.i [ classes ["fas", "fa-fw", "fa-wrench"] ] []
, HH.span_ [ HH.text "API Documentation" ]
]
]
, HH.li [ classes ["nav-item"] ]
[ HH.a [ HP.href "https://gitlab.certicon.cz/retail/server/issues", classes ["nav-link"] ]
[ HH.i [ classes ["fas", "fa-fw", "fa-bug"] ] []
, HH.span_ [ HH.text "Issue Tracker" ]
]
]
, HH.hr [ classes ["sidebar-divider", "d-none", "d-md-block"] ]
-- , HH.div [ classes ["text-center", "d-none", "d-md-inline"] ]
-- [ HH.button [ HP.id_ "sidebarToggle", classes ["rounded-circle", "border-0"] ]
-- [ ]
-- ]
]
navbar :: forall m. MonadAff m => Info -> Boolean -> H.ComponentHTML Action Slots m
navbar info updating =
HH.nav [ classes ["navbar", "navbar-expand", "navbar-light", "bg-white", "topbar", "mb-4", "static-top", "shadow"] ]
[ HH.button [ HE.onClick (const $ Just ToggleSidebar), HP.id_ "sidebarToggleTop", classes ["btn", "btn-link", "d-md-none", "rounded-circle", "mr-3"] ]
[ HH.i [ classes ["fa", "fa-bars"] ] []
]
, HH.div [ classes ["btn-group", "btn-group-sm", "mx-3", "my-1"] ]
[ HH.button
[ HE.onClick (const $ Just $ AutoUpdate (not updating) )
, classes $ ["btn", "btn-secondary"] <> guard updating ["active"]
] [ HH.text $ if updating then "Stop Live" else "Go Live" ]
]
, HH.div [ classes ["navbar-nav", "ml-auto"] ]
[ HH.img [ HP.src certiconLogo, classes ["certicon-logo", "mr-2"] ]
]
]
content :: forall m. MonadAff m => Maybe Route -> Info -> Config -> CanvasImageSource -> H.ComponentHTML Action Slots m
content route info config mapImage =
HH.div [ classes ["container-fluid", "mt-4"] ]
[ case route of
Just Dashboard ->
HH.slot (SProxy :: SProxy "dashboard") unit Dashboard.component {info, config, mapImage} (const Nothing)
Just Tracking -> HH.text "Tracklets: not upgraded to the new API yet"
Just Filtering ->
HH.slot (SProxy :: SProxy "filtering") unit Filtering.component {info, config, mapImage} (const Nothing)
Just Statistics ->
HH.slot (SProxy :: SProxy "statistics") unit Statistics.component {info, config} (const Nothing)
Just Zones ->
HH.slot (SProxy :: SProxy "zones") unit Zones.component {config} (const Nothing)
Just Cameras ->
HH.slot (SProxy :: SProxy "cameras") unit Cameras.component {config} (const Nothing)
Nothing -> HH.div_ [ HH.text "Oh no! That page wasn't found." ]
]
render :: forall m. MonadAff m => State -> H.ComponentHTML Action Slots m
render state = let
values = do
info <- note "Waiting for database information..." state.info
config <- note "Waiting for config..." state.config
mapImage <- note "Waiting for the map..." state.mapImage
pure {info, config, mapImage}
in case values of
Left err -> HH.text err
Right {info, config, mapImage} ->
HH.div [ HP.id_ "wrapper" ] $
guard state.sidebar [ sidebar state.route info ] <>
[ HH.div [ HP.id_ "content-wrapper", classes ["d-flex", "flex-column"] ]
[ HH.div [ HP.id_ "content" ]
[ navbar info (isJust state.infoUpdater)
, content state.route info config mapImage
]
]
]
handleAction :: forall cs o m. MonadAff m => Action → H.HalogenM State Action cs o m Unit
handleAction = case _ of
Initialize -> do
initialRoute <- hush <<< ( parse routeCodec ) <$> H.liftEffect getHash
navigate $ fromMaybe Dashboard initialRoute
info <- liftAff fetchInfo
config <- liftAff fetchConfig
when (isLeft info) $ log $ show info
when (isLeft config) $ log $ show config
mapImage <- join <$> for config \(Config c) ->
liftAff $ fetchInfoImage c.map
H.modify_ _ { info = hush info, config = hush config, mapImage = hush mapImage }
pure unit
GoTo route e -> do
liftEffect $ preventDefault ( toEvent e )
mRoute <- H.gets _.route
when ( mRoute /= Just route ) $ navigate route
AutoUpdate true -> do
id <- H.subscribe (infoTimer 2000.0)
H.modify_ _ { infoUpdater = Just id }
AutoUpdate false -> do
st <- H.get
void $ sequence $ H.unsubscribe <$> st.infoUpdater
H.modify_ _ { infoUpdater = Nothing }
InfoTick -> do
st <- H.get
res <- liftAff fetchInfo
case res of
Left err -> log $ "Error requesting info: " <> err
Right info ->
H.modify_ _ { info = Just info }
pure unit
ToggleSidebar -> do
H.modify_ \st -> st { sidebar = not st.sidebar }
handleQuery :: forall a o m. MonadEffect m => Query a -> H.HalogenM State Action Slots o m ( Maybe a )
handleQuery = case _ of
-- This is the case that runs every time the brower's hash route changes.
Navigate route a -> do
mRoute <- H.gets _.route
when ( mRoute /= Just route ) $
H.modify_ _ { route = Just route }
pure ( Just a )
infoTimer :: forall m. MonadAff m => Number -> EventSource m Action
infoTimer delayMs = EventSource.affEventSource \emitter -> do
fiber <- forkAff $ forever do
delay $ Milliseconds delayMs
EventSource.emit emitter InfoTick
pure $ EventSource.Finalizer do
killFiber (error "Event source finalized") fiber
pure unit