pijul nest
guest [sign in]

Fork channel

Create a new channel as a copy of main.

Rename channel

Rename main to:

Delete channel

Delete main? This cannot be undone.

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