Add the source files

[?]

Jan 8, 2021, 1:00 PM

A4YPCXNG44HRKJZLXU5Q4JEBD73UETQCHVMBHVQR2UDCYZLLAFXAC

Dependencies

Change contents

file addition: src (dxwrx-rx-r)

[1.0]
file addition: Util.hs (-xw-x--x--)

[0.6]

module Frontend.Util where

import Prelude

import Data.Argonaut.Core (Json)
import Data.Argonaut.Decode (JsonDecodeError, decodeJson, (.:))
import Data.Array (filter, length, zip, (..))
import Data.DateTime (DateTime, Time(..), adjust, diff, modifyTime, setMillisecond, setMinute, setSecond)
import Data.DateTime.Instant (fromDateTime, instant, toDateTime, unInstant)
import Data.Either (Either, either, note)
import Data.Formatter.DateTime (formatDateTime)
import Data.Int (floor, toNumber)
import Data.Maybe (Maybe, fromMaybe)
import Data.Newtype (unwrap)
import Data.Time.Duration (Days(..), Hours(..), Milliseconds(..), Seconds(..))
import Data.Traversable (sequence, traverse)
import Data.Tuple (Tuple)
import Effect.Aff (Aff, error, makeAff)
import Graphics.Canvas (CanvasImageSource, tryLoadImage)
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP

classes :: forall r i. Array String -> HH.IProp (class :: String | r) i
classes = HP.classes <<< map HH.ClassName

formatDateTime' :: DateTime -> String
formatDateTime' = either identity identity <<< formatDateTime "YYYY-MM-DD HH:mm:ss.SS"

datetimeToSeconds :: DateTime -> Number
datetimeToSeconds = (_ / 1000.0) <<< unwrap <<< unInstant <<< fromDateTime

secondsToDateTime :: Number -> Maybe DateTime
secondsToDateTime = map toDateTime <<< instant <<< Milliseconds <<< (_ * 1000.0)

-- TODO: convert stuff to local time
-- getTimezoneOffset $ fromDateTime start

midnightBefore :: DateTime -> DateTime
midnightBefore = modifyTime (const $ Time bottom bottom bottom bottom)

hourBefore :: DateTime -> DateTime
hourBefore = modifyTime (setMinute bottom <<< setSecond bottom <<< setMillisecond bottom)

daysInInterval :: DateTime -> DateTime -> Array DateTime
daysInInterval start end = do
let
midnight = midnightBefore start
duration = diff end midnight :: Days
nDays = floor (unwrap duration)
fromMaybe [] <<< sequence $
0 .. nDays <#> \n ->
adjust (Days (toNumber n)) midnight

hoursInInterval :: DateTime -> DateTime -> DateTime -> Array DateTime
hoursInInterval current start end = do
let
midnight = midnightBefore current
hours = 0 .. 23 <#> Hours <<< toNumber
hoursDT = fromMaybe [] <<< sequence $ hours <#> \n -> adjust n midnight
filter (\a -> (unwrap (a `diff` start :: Hours) >= -1.0) && a <= end) hoursDT

decodeTimestamps :: Json -> Either JsonDecodeError (Array Number)
decodeTimestamps json = do
o <- decodeJson json
contents <- o .: "Ok"
decodeJson contents >>= traverse decodeJson

formatDuration :: Seconds -> String
formatDuration (Seconds t) = let
h = floor $ t / 3600.0
m = floor (t / 60.0) - h * 60
s = floor t - h * 3600 - m * 60
in show h <> "h " <> show m <> "m " <> show s <> "s"

loadImage :: String -> Aff CanvasImageSource
loadImage url = do
makeAff \cont -> do
tryLoadImage url \msource ->
note (error $ "Failed to load image from \"" <> url <> "\"") msource # cont
mempty

enumerate :: forall a. Array a -> Array (Tuple Int a)
enumerate a = zip (0 .. (length a - 1)) a
file addition: UPlot.js (-xw-x--x--)

[0.6]

"use strict";

var uPlot = require("/uPlot/dist/uPlot.cjs.js");

exports.setSizeImpl = uplot => width => height => () => {
uplot.setSize({width, height});
};

exports.setDataImpl = uplot => data => () => {
uplot.setData(data);
};

exports.destroyImpl = uplot => () => {
uplot.destroy();
uplot = null;
};

exports.initializeImpl = element => opts => () => {
console.log("opts", opts);
return new uPlot(opts, [], element);
};
file addition: UPlot.hs (-xw-x--x--)

[0.6]

module Frontend.UPlot where

import Prelude

import Data.Maybe (Maybe)
import Data.Nullable (Nullable, toNullable)
import Effect (Effect)
import Web.HTML (HTMLElement)

foreign import initializeImpl :: HTMLElement -> Opts -> Effect UPlot
foreign import setSizeImpl :: UPlot -> Number -> Number -> Effect Unit
foreign import setDataImpl :: UPlot -> Array (Array (Nullable Number)) -> Effect Unit
foreign import destroyImpl :: UPlot -> Effect Unit

data UPlot -- opaque uPlot handle

data Plot = Plot
{ uplot :: UPlot
}

-- Opts

type Series =
{ stroke :: String
, fill :: String
}

type Grid =
{ show :: Boolean
, stroke :: String
, width :: Int
}

defaultGrid :: Grid
defaultGrid =
{ show: true
, stroke: "rgba(0,0,0,0.07)"
, width: 2
}

noGrid :: Grid
noGrid = defaultGrid { show=false }

type Axis =
{ show :: Boolean
, scale :: String
, space :: Int
, gap :: Int
, size :: Int
, labelSize :: Int
-- , labelFont :: Font
, side :: Int
, grid :: Grid
-- , ticks :: Ticks
-- , font :: Font
-- , rotate: Int
}

defaultXAxis :: Axis
defaultXAxis =
{ show: true
, scale: "x"
, space: 50
, gap: 5
, size: 50
, labelSize: 30
-- , labelFont
, side: 2
--, class: "x-vals"
--, incrs: timeIncrs
--, values: timeVals
--, filter: retArg1
, grid: defaultGrid
-- , ticks
-- , font
-- , rotate: 0
}

defaultYAxis :: Axis
defaultYAxis =
{ show: true
, scale: "y"
, space: 30
, gap: 5
, size: 50
, labelSize: 30
-- , labelFont
, side: 3
--, class: "x-vals"
--, incrs: timeIncrs
--, values: timeVals
--, filter: retArg1
, grid: defaultGrid
-- , ticks
-- , font
-- , rotate: 0
}

noAxis :: Axis
noAxis = defaultXAxis { show=false }

type Opts =
{ width :: Number
, height :: Number
, axes :: Array Axis
, scales ::
{ x ::
{ time :: Boolean
, distr :: Int
}
}
, series :: Array Series
}

defaultSeries :: Series
defaultSeries =
{ stroke: "blue"
, fill: "rgba(0,0,255,0.1)"
}

defaultOpts :: Opts
defaultOpts =
{ width: 500.0
, height: 300.0
, axes: [defaultXAxis, defaultYAxis]
, scales:
{ x:
{ time: true
, distr: 1
}
}
, series: [defaultSeries, defaultSeries]
}

initialize :: HTMLElement -> Opts -> Effect Plot
initialize e opts = initializeImpl e opts <#> \uplot -> Plot { uplot: uplot }

setSize :: Plot -> Number -> Number -> Effect Unit
setSize (Plot p) w h = setSizeImpl p.uplot w h

setData :: Plot -> Array (Array (Maybe Number)) -> Effect Unit
setData (Plot p) = setDataImpl p.uplot <<< map (map toNullable)

destroy :: Plot -> Effect Unit
destroy (Plot p) = destroyImpl p.uplot
file addition: Types.hs (-xw-x--x--)

[0.6]

module Frontend.Types where

import Prelude

import Data.Argonaut.Core (Json)
import Data.Argonaut.Decode (class DecodeJson, JsonDecodeError(..), decodeJson, (.:))
import Data.Array (zipWith, (!!))
import Data.DateTime (DateTime)
import Data.DateTime.Instant (fromDateTime, unInstant)
import Data.Either (Either(..), note)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Data.Maybe (Maybe)
import Data.Newtype (class Newtype, unwrap)
import Data.Traversable (for)
import Data.Tuple (Tuple(..))
import Foreign.Object as FO
import Frontend.Util (secondsToDateTime)

dateTimeToSeconds :: DateTime -> Number
dateTimeToSeconds = (_ / 1000.0) <<< unwrap <<< unInstant <<< fromDateTime

data Vec2 = V2 Number Number
newtype Box = Box { x0 :: Number, y0 :: Number, x1 :: Number, y1 :: Number }

newtype Object = Object
{ id :: Int
, pos :: Vec2
, gap :: Int
, heading :: Vec2
}

newtype Instant = Instant
{ timestamp :: DateTime
, objects :: Array Object
}

newtype MaybeInstant = MaybeInstant
{ timestamp :: DateTime
, objects :: Maybe (Array Object)
}

type Tracklet = Array
{ t :: DateTime
, p :: Vec2
}

newtype Tracklets = Tracklets (Array Tracklet)

newtype Info = Info
{ n_entries :: Int
, first_dt :: DateTime
, last_dt :: DateTime
}

type Zone =
{ name :: String
, box :: Box
}

newtype Config = Config
{ bbox :: Box
, grid_px_size :: Number
, n_objects :: Int
, model_path :: String
, min_tracklet_len :: Int
, predict_stride :: Number
, toss_first :: Int
, gpu :: Int
, map :: String
, zones :: Array Zone
, cameras :: Array
{ name :: String
, width :: Int
, height :: Int
, calib :: String
, image :: String
}
}

derive instance genericVec2 :: Generic Vec2 _

instance showBox :: Show Box where
show (Box {x0, y0, x1, y1}) = "x: " <> show [x0, x1] <> " m, y: " <> show [y0, y1] <> " m"

instance showVec2 :: Show Vec2 where
show = genericShow

derive instance genericObject :: Generic Object _
derive instance newtypeObject :: Newtype Object _

instance showObject :: Show Object where
show = genericShow

derive instance genericInstant :: Generic Instant _
derive instance newtypeInstant :: Newtype Instant _

instance showInstant :: Show Instant where
show = genericShow

derive instance genericMaybeInstant :: Generic MaybeInstant _
derive instance newtypeMaybeInstant :: Newtype MaybeInstant _

instance showMaybeInstant :: Show MaybeInstant where
show = genericShow

derive instance genericTracklets :: Generic Tracklets _
derive instance newtypeTracklets :: Newtype Tracklets _

instance showTracklets :: Show Tracklets where
show = genericShow

derive instance genericInfo :: Generic Info _
derive instance newtypeInfo :: Newtype Info _

instance showInfo :: Show Info where
show = genericShow

derive instance genericConfig :: Generic Config _
derive instance newtypeConfig :: Newtype Config _

instance showConfig :: Show Config where
show = genericShow

instance decodeJsonVec2 :: DecodeJson Vec2 where
decodeJson json = case decodeJson json of
Left err -> Left err
Right (Tuple a b) -> Right (V2 a b)

instance decodeJsonObject :: DecodeJson Object where
decodeJson json = Object <$> decodeJson json

instance decodeBox :: DecodeJson Box where
decodeJson :: Json -> Either JsonDecodeError Box
decodeJson json = do
o <- decodeJson json
case o of
[x0, y0, x1, y1] -> pure $ Box { x0, y0, x1, y1 }
_ -> Left $ TypeMismatch "Bounding box must have 4 elements."

instance decodeJsonInstant :: DecodeJson Instant where
decodeJson :: Json -> Either JsonDecodeError Instant
decodeJson json = do
o <- decodeJson json
ts <- o .: "timestamp"
objects <- o .: "objects"
timestamp <- note (TypeMismatch "Invalid Timestamp") $ secondsToDateTime ts
pure $ Instant { timestamp: timestamp, objects }

instance decodeJsonMaybeInstant :: DecodeJson MaybeInstant where
decodeJson :: Json -> Either JsonDecodeError MaybeInstant
decodeJson json = do
o <- decodeJson json
ts <- o .: "timestamp"
objects <- o .: "objects"
timestamp <- note (TypeMismatch "Invalid Timestamp") $ secondsToDateTime ts
pure $ MaybeInstant { timestamp: timestamp, objects }

instance decodeJsonInfo :: DecodeJson Info where
decodeJson :: Json -> Either JsonDecodeError Info
decodeJson json = do
o <- decodeJson json
n_entries <- o .: "entries"
first_ts <- o .: "first_ts"
last_ts <- o .: "last_ts"

first_dt <- note (TypeMismatch "Invalid Timestamp") $ secondsToDateTime first_ts
last_dt <- note (TypeMismatch "Invalid Timestamp") $ secondsToDateTime last_ts

pure $ Info { n_entries, first_dt, last_dt }

instance decodeJsonConfig :: DecodeJson Config where
decodeJson :: Json -> Either JsonDecodeError Config
decodeJson json = do
o <- decodeJson json
bbox <- o .: "bbox"
grid_px_size <- o .: "grid_px_size"
n_objects <- o .: "n_objects"
model_path <- o .: "model_path"
min_tracklet_len <- o .: "min_tracklet_len"
predict_stride <- o .: "predict_stride"
toss_first <- o .: "toss_first"
gpu <- o .: "gpu"
map <- o .: "map"

zones' <- o .: "zones" :: Either JsonDecodeError (Array Json)
zones <- for zones' \zone -> do
z <- decodeJson zone
name <- z .: "name"
box <- z .: "box"
pure { name, box: Box box }

cs <- o .: "cameras" :: Either JsonDecodeError (Array Json)
cameras <- for cs \cj -> do
c <- decodeJson cj
name <- c .: "name"
width <- c .: "w"
height <- c .: "h"
calib <- c .: "calib"
image <- c .: "image"
pure { name: name, width, height, calib, image }

pure $ Config
{ bbox, grid_px_size, n_objects, model_path
, min_tracklet_len, predict_stride, toss_first
, gpu, map, zones, cameras }

instance decodeJsonTracklets :: DecodeJson Tracklets where
decodeJson :: Json -> Either JsonDecodeError Tracklets
decodeJson json = do
let arrayErr = TypeMismatch "Invalid array length."
tracklets <- decodeJson json :: Either JsonDecodeError (Array (FO.Object Json))
res <- for tracklets \tracklet -> do
tt <- tracklet .: "t"
px <- tracklet .: "x"
py <- tracklet .: "y"
dt <- note (TypeMismatch "Invalid timestamp.") $ for tt secondsToDateTime
Right $ zipWith (\t p -> {t, p}) dt (zipWith V2 px py)
let r = res
pure $ Tracklets res
file addition: Tracklets.hs (-xw-x--x--)

[0.6]

module Frontend.Tracklets
( TrackletSOA
, trackletSOA
, unTrackletSOA
) where

import Prelude

import Data.Argonaut.Core (Json)
import Data.Argonaut.Decode (class DecodeJson, JsonDecodeError(..), decodeJson, (.:))
import Data.Array (length, (!!))
import Data.DateTime (DateTime)
import Data.Either (Either, note)
import Data.Maybe (Maybe(..))
import Frontend.Util (secondsToDateTime)

type TrackletSOAData =
{ id :: Int
, t :: Array Number
, x :: Array Number
, y :: Array Number
, t0 :: DateTime
}

newtype TrackletSOA = TrackletSOA TrackletSOAData

trackletSOA :: TrackletSOAData -> Maybe TrackletSOA
trackletSOA {id, t, x, y, t0}
| length t == length x && length x == length y = Just $ TrackletSOA {id, t, x, y, t0}
| otherwise = Nothing

unTrackletSOA :: TrackletSOA -> TrackletSOAData
unTrackletSOA (TrackletSOA d) = d

instance showTrackletSOA :: Show TrackletSOA where
show (TrackletSOA {t0, t, x, y}) = "Tracklet with " <> show (length t) <> " points starting at " <> show t0

instance decodeJsonTracklets :: DecodeJson TrackletSOA where
decodeJson :: Json -> Either JsonDecodeError TrackletSOA
decodeJson json = do
tracklet <- decodeJson json
id <- tracklet .: "id"
t <- tracklet .: "t"
x <- tracklet .: "x"
y <- tracklet .: "y"
t0s <- note (TypeMismatch "Empty tracklet.") $ t !! 0
t0 <- note (TypeMismatch "Invalid timestamp.") $ secondsToDateTime t0s
note (TypeMismatch "Lengths of {t, x, y} arrays are not equal.") $ trackletSOA
{id, t: (_ - t0s) <$> t, x, y, t0}
file addition: Tracklet (dxwrx-rx-r)

[0.6]
file addition: Filter.hs (-xw-x--x--)

[0.14263]

module Frontend.Tracklet.Filter where

import Prelude

import Data.Array (dropWhile, head, init, last, tail, zipWith)
import Data.DateTime (DateTime, diff)
import Data.Foldable (sum)
import Data.Maybe (Maybe(..), fromMaybe, isJust)
import Data.Time.Duration (class Duration, Seconds(..), convertDuration)
import Frontend.Types (Box(..), Vec2(..), Tracklet)
import Math (sqrt)

type TrackletFilter = Tracklet -> Boolean

-- Boolean algebra for tracklet filters is automatically implemented.
-- (true, false, and, or, not, implies) are for free

distanceAtLeast :: Number -> TrackletFilter
distanceAtLeast n t = (_ >= n) $ sum $ fromMaybe [0.0] $ (zipWith dist <$> init t <*> tail t) where
dist {p: V2 x1 y1} {p: V2 x2 y2} = sqrt $ (x1 - x2) * (x1 - x2) + (y1 - y2) * (y1 - y2)

durationAtLeast :: forall d. Duration d => d -> TrackletFilter
durationAtLeast d t = fromMaybe false do
h <- head t
l <- last t
let d' = diff l.t h.t :: Seconds
pure $ d' >= (convertDuration d)

insideBox :: Box -> PointFilter
insideBox (Box {x0, y0, x1, y1}) {p: (V2 x y)} =
x0 <= x && x <= x1 && y0 <= y && y <= y1

first :: PointFilter -> Tracklet -> Boolean
first = runParser <<< one

type PointFilter = { t :: DateTime, p :: Vec2 } -> Boolean

-- LL(0) parser
type Parser = Tracklet -> Maybe Tracklet

runParser :: Parser -> Tracklet -> Boolean
runParser p = isJust <<< p

any :: PointFilter -> Parser
any f = until f `andThen` one f

until :: PointFilter -> Parser
until f = many (not <$> f)

many :: PointFilter -> Parser
many f = Just <<< dropWhile f

one :: PointFilter -> Parser
one f t = case f <$> head t of
Just true -> tail t
_ -> Nothing

andThen :: Parser -> Parser -> Parser
andThen p q t = p t >>= q

type HLine = {x0 :: Number, x1 :: Number, y :: Number}
data Direction = Up | Dn

duration :: forall d. Duration d => d -> Parser
duration d t = do
h <- head t
let pred = dropWhile (\x -> (diff x.t h.t :: Seconds) < convertDuration d) t
case pred of
[] -> Nothing
l -> Just l

hLine :: HLine -> Direction -> Parser
hLine {x0, x1, y} dir = let
rt = Box {x0, x1, y0: y + 0.5, y1: y + 2.0}
rb = Box {x0, x1, y0: y - 2.0, y1: y - 0.5}
{r1, r2} = case dir of
Dn -> {r1: rt, r2: rb}
Up -> {r1: rb, r2: rt}
in until (insideBox r1) `andThen` one (insideBox r1) `andThen` until (insideBox r2) `andThen` one (insideBox r2)
file addition: Route.hs (-xw-x--x--)

[0.6]

module Frontend.Route where

import Prelude hiding ((/))

import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Show (genericShow)
import Effect.Class (class MonadEffect, liftEffect)
import Routing.Duplex (RouteDuplex', print, root)
import Routing.Duplex.Generic (noArgs, sum)
import Routing.Duplex.Generic.Syntax ((/))
import Routing.Hash (setHash)

-- All possible routes in the application
data Route
= Dashboard
| Tracking
| Filtering
| Statistics
| Zones
| Cameras

derive instance genericRoute :: Generic Route _
derive instance eqRoute :: Eq Route
derive instance ordRoute :: Ord Route

instance showRoute :: Show Route where
show = genericShow

routeCodec :: RouteDuplex' Route
routeCodec = root $ sum
{ "Dashboard": noArgs
, "Tracking": "tracking" / noArgs
, "Filtering": "filtering" / noArgs
, "Statistics": "statistics" / noArgs
, "Zones": "zones" / noArgs
, "Cameras": "cameras" / noArgs
}

navigate :: forall m. MonadEffect m => Route -> m Unit
navigate = liftEffect <<< setHash <<< print routeCodec
file addition: Main.hs (-xw-x--x--)

[0.6]

module Main where

import Prelude

import Data.Maybe (Maybe(..))
import Effect (Effect)
import Effect.Aff (launchAff_)
import Halogen (liftEffect)
import Halogen as H
import Halogen.Aff as HA
import Halogen.VDom.Driver (runUI)
import Routing.Duplex (parse)
import Routing.Hash (matchesWith)
import Frontend.Component.Index as Index
import Frontend.Route (routeCodec)

main :: Effect Unit
main = HA.runHalogenAff do
body <- HA.awaitBody
halogenIO <- runUI Index.component unit body
void $ liftEffect $ matchesWith ( parse routeCodec ) \mOld new ->
when ( mOld /= Just new ) do
launchAff_$ halogenIO.query $ H.tell $ Index.Navigate new
pure unit
file addition: Draw.js (-xw-x--x--)

[0.6]

"use strict";

exports.imgElementToImageSourceImpl = function(id, Just, Nothing) {
return function() {
var el = document.getElementById(id);
if (el && el instanceof HTMLImageElement) {
return Just(el);
} else {
return Nothing;
}
};
};

exports.imageShape = image => {
return { width: image.width, height: image.height };
}
file addition: Draw.hs (-xw-x--x--)

[0.6]

module Frontend.Draw where

import Prelude

import CSS.Color as CSS
import Color (Color, hsl, rgb, toHSLA, toHexString)
import Control.Safely (for_)
import Data.Array ((!!))
import Data.Function.Uncurried (Fn3, runFn3)
import Data.Int (toNumber)
import Data.Maybe (Maybe(..))
import Effect (Effect)
import Frontend.Types (Box(..), Object(..), Tracklet, Vec2(..))
import Graphics.Canvas (CanvasElement, CanvasImageSource, getCanvasHeight, getCanvasWidth, getContext2D)
import Graphics.Canvas as Canvas
import Math (atan2, cos, pi, sin)

foreign import imgElementToImageSourceImpl :: forall r. Fn3 String (CanvasImageSource -> r) r (Effect r)

foreign import imageShape :: CanvasImageSource -> { width :: Int, height :: Int }

-- | Get a img element by ID, or `Nothing` if the element does not exist.
getImgElementById :: String -> Effect (Maybe CanvasImageSource)
getImgElementById elId = runFn3 imgElementToImageSourceImpl elId Just Nothing

metersToPixels :: Vec2 -> Box -> Vec2 -> Vec2
metersToPixels (V2 canvasW canvasH) (Box {x0, y0, x1, y1}) (V2 x y) = let
w = x1 - x0
h = y1 - y0
px = (x - x0) / w * canvasW
py = (1.0 - (y - y0) / h) * canvasH
in V2 px py

canvasShape :: CanvasElement -> Effect Vec2
canvasShape elem = do
w <- getCanvasWidth elem
h <- getCanvasHeight elem
pure $ V2 w h

drawTracklet :: CanvasElement -> Box -> Number -> Tracklet -> Effect Unit
drawTracklet elem box alpha tracklet = do
shape <- canvasShape elem
ctx <- getContext2D elem

let
color = rgb 100 100 200
Canvas.setLineJoin ctx Canvas.BevelJoin
Canvas.setLineWidth ctx 5.0
Canvas.setGlobalAlpha ctx alpha
Canvas.setStrokeStyle ctx (toHexString color)
Canvas.beginPath ctx

for_ tracklet \pt -> do
let V2 px py = metersToPixels shape box pt.p
Canvas.lineTo ctx px py
Canvas.stroke ctx

-- start circle
case tracklet !! 0 of
Nothing -> pure unit
Just pt -> do
let V2 px py = metersToPixels shape box pt.p
Canvas.setGlobalAlpha ctx 0.2
Canvas.setFillStyle ctx (toHexString $ rgb 200 100 100)
Canvas.beginPath ctx
Canvas.arc ctx
{ x: px
, y: py
, radius: 5.0, start: 0.0, end: 6.3
}
Canvas.fill ctx

hashedColor :: Int -> Color
hashedColor h = hsl (toNumber $ h * 15_485_867 `mod` 255) 1.0 0.3

colorToCss :: Color -> CSS.Color
colorToCss col = let
{h, s, l, a} = toHSLA col
in CSS.hsla h s l a

drawObject :: CanvasElement -> Box -> Object -> Effect Unit
drawObject elem box (Object obj) = do
ctx <- getContext2D elem
shape <- canvasShape elem

let V2 hx hy' = obj.heading
hy = -hy'
angle = atan2 hy hx
V2 px py = metersToPixels shape box $ obj.pos

let color = toHexString (hashedColor obj.id)
alpha = clamp 0.0 1.0 $ toNumber (10 - obj.gap) / 10.0
Canvas.setLineWidth ctx 5.0
Canvas.setGlobalAlpha ctx alpha
Canvas.setStrokeStyle ctx color
Canvas.setFillStyle ctx color

Canvas.beginPath ctx
Canvas.arc ctx
{ x: px
, y: py
, radius: 10.0, start: angle + 3.15 / 3.0, end: angle - 3.15 / 3.0
}
Canvas.moveTo ctx (px + cos (angle - pi / 3.0) * 10.0) (py + sin (angle - pi / 3.0) * 10.0)
Canvas.lineTo ctx (px + hx * 20.0) (py + hy * 20.0)
Canvas.lineTo ctx (px + cos (angle + pi / 3.0) * 10.0) (py + sin (angle + pi / 3.0) * 10.0)
Canvas.stroke ctx
Canvas.setGlobalAlpha ctx (alpha / 3.0)
Canvas.fill ctx
file addition: Dom.hs (-xw-x--x--)

[0.6]

module Frontend.Dom where

-- import Prelude

import Halogen.HTML as HH
import Frontend.Util (classes)

card :: forall w i. Array String -> Array (HH.HTML w i) -> Array (HH.HTML w i) -> HH.HTML w i
card classes' header body =
HH.div [ classes classes' ]
[ HH.div [ classes ["card", "shadow", "mb-4"] ]
[ HH.div [ classes ["card-header", "card-header", "py-3", "d-flex", "flex-row", "align-items-center", "justify-content-between"] ]
[ HH.h6 [ classes ["m-0", "font-weight-bold", "text-primary"] ]
header
]
, HH.div [ classes ["card-body"] ]
body
]
]
file addition: Component (dxwrx-rx-r)

[0.6]
file addition: Zones.hs (-xw-x--x--)

[0.22809]

module Frontend.Component.Zones where

import Prelude

import Data.Maybe (Maybe(..))
import Effect.Aff.Class (class MonadAff)
import Frontend.Dom (card)
import Frontend.Types (Config(..))
import Frontend.Util (classes)
import Halogen as H
import Halogen.HTML as HH

type State =
{ config :: Config
}

data Action
= Initialize

type Input = { config :: Config }

component :: forall query output m. MonadAff m => H.Component HH.HTML query Input output m
component = H.mkComponent
{ initialState: identity
, render
, eval: H.mkEval H.defaultEval
{ initialize = Just Initialize
}
}

render :: forall s m. MonadAff m => State -> H.ComponentHTML Action s m
render { config: Config config } =
HH.div [ classes ["row"] ]
[ card ["col-lg-12"]
[ HH.text "Zones" ]
[ HH.span_ [ HH.text $ "ToDo" ]
]
]
file addition: Statistics.hs (-xw-x--x--)

[0.22809]

module Frontend.Component.Statistics where

import Prelude

import Data.Array (elemIndex, filter, head, last, length, sortWith, take, zip, (!!))
import Data.DateTime (DateTime)
import Data.Either (Either, hush)
import Data.Foldable (and, or)
import Data.Int (round, toNumber)
import Data.JSDate (getTimezoneOffset, now)
import Data.List (fromFoldable)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Tuple (Tuple(..))
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class.Console (log)
import Frontend.Api (fetchTrackletsSOA)
import Frontend.Dom (card)
import Frontend.Tracklet.Filter (insideBox)
import Frontend.Tracklets (TrackletSOA, unTrackletSOA)
import Frontend.Types (Config(..), Info(..), Vec2(..))
import Frontend.Util (classes, formatDateTime')
import Global (encodeURIComponent)
import Halogen (liftEffect)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Record.CSV.Printer (printCSVWithOrder)
import Record.CSV.Printer.SList (SLProxy(..))
import Record.CSV.Printer.SList (type (:), type (!), SLProxy(..))

type Props =
{ len :: Int
, id :: Int
, startTime :: DateTime
, duration :: Number
, durationInShop :: Number
, startZones :: Array Boolean
, endZones :: Array Boolean
, throughZones :: Array Boolean
, throughShop :: Boolean
}

type Slots =
()

-- _plot = (SProxy :: SProxy "plot")

type State =
{ info :: Info
, config :: Config
, fetching :: Boolean
, tracklets :: Maybe (Array TrackletSOA)
, props :: Maybe (Array Props)
}

data Action
= Initialize
| SetInput Input
| FetchData

type Input = { info :: Info, config :: Config }

component :: forall query output m. MonadAff m => H.Component HH.HTML query Input output m
component = H.mkComponent
{ initialState: \{info, config} ->
{ info
, config
, fetching: false
, tracklets: Nothing
, props: Nothing
}
, render
, eval: H.mkEval H.defaultEval
{ handleAction = handleAction
, initialize = Just Initialize
, receive = Just <<< SetInput
}
}

render :: forall m. MonadAff m => State -> H.ComponentHTML Action Slots m
render state =
HH.div [ classes ["row"] ]
[ HH.div [ classes ["col-lg-12"] ]
[ card []
[ HH.text "Statistics" ]
[ statistics state
]
]
]

type Order
= "id"
: "startTime"
: "duration"
: "durationInShop"
: "startZone"
: "endZone"
! "throughShop"

toCsv :: Array String -> Array Props -> String
toCsv zoneNames props = fromMaybe "Error" $ encodeURIComponent =<< (hush csv) where
csv = printCSVWithOrder (SLProxy :: SLProxy Order) (fromFoldable (map csvTransform props))

csvTransform
{ len
, id
, startTime
, duration
, durationInShop
, startZones
, endZones
, throughZones
, throughShop
} =
{ id
, startTime: formatDateTime' startTime
, duration: round duration
, durationInShop: round durationInShop
, startZone: fromMaybe "-" $ (zoneNames !! _) =<< elemIndex true startZones
, endZone: fromMaybe "-" $ (zoneNames !! _) =<< elemIndex true endZones
, throughShop
}

statistics :: forall m. MonadAff m => State -> H.ComponentHTML Action Slots m
statistics {info: Info info, config: Config config, tracklets: mtracklets, fetching, props} = let
zoneNames = take 4 (_.name <$> config.zones)
in HH.div_
[ HH.button
[ HE.onClick $ const $ Just FetchData
, classes ["btn", "btn-primary", "btn-outline"]
] [HH.text "Fetch Data"]
, if fetching
then HH.span [ classes ["spinner-border", "spinner-border-sm", "mx-4"] ]
[ HH.span [ classes ["sr-only"] ] [ HH.text "Loading..." ]
]
else HH.text ""
, HH.div [ classes ["m-2"] ] case mtracklets of
Just tracklets ->
[ HH.text $ "Number of tracklets: " <> show (length tracklets)
]
Nothing ->
[ HH.text "No data." ]
, HH.div [ classes ["m-2"] ] case props of
Nothing -> []
Just props' ->
[ HH.a [HP.href $ "data:text/plain;charset=UTF-8," <> toCsv zoneNames props', HP.download "data.csv"] [HH.text "csv"]
]
]

cmpProps :: Config -> TrackletSOA -> Props
cmpProps (Config config) tr = let
{id, t0, t, x, y} = unTrackletSOA tr
shopZones = config.zones -- FIXME: checkout is inside the shop.
inShop p = and ((\{box} -> not $ insideBox box p) <$> shopZones)
in
{ len: length t
, id
, startTime: t0
, duration: fromMaybe 0.0 $ last t
, durationInShop: let
lenInShop = length $ filter identity $ zip x y <#> \(Tuple x' y') ->
inShop { p: V2 x' y', t: t0 }
in toNumber lenInShop / toNumber (length t) * (fromMaybe 0.0 $ last t)
, startZones: fromMaybe (config.zones $> false) do
x0 <- head x
y0 <- head y
pure $ config.zones <#> \zone ->
insideBox zone.box { p: V2 x0 y0, t: t0 }
, endZones: fromMaybe (config.zones $> false) do
x0 <- last x
y0 <- last y
pure $ config.zones <#> \zone ->
insideBox zone.box { p: V2 x0 y0, t: t0 }
, throughZones: config.zones <#> \zone ->
or $ zip x y <#> \(Tuple x' y') ->
insideBox zone.box { p: V2 x' y', t: t0 }
, throughShop: or $ zip x y <#> \(Tuple x' y') ->
inShop { p: V2 x' y', t: t0 }
}

handleAction :: forall output m. MonadAff m => Action -> H.HalogenM State Action Slots output m Unit
handleAction = case _ of
Initialize -> do
{info: Info info, config: Config config} <- H.get
pure unit

SetInput { info, config } -> H.modify_ _ { info = info, config = config }

FetchData -> do
{info: Info info, config: Config config} <- H.get
H.modify_ _ { fetching = true }

-- Get data
tracklets <- liftAff $ fetchTrackletsSOA info.first_dt info.last_dt 10

-- FIXME: Get offset from data, not from now
tzOffset <- liftEffect $ now >>= getTimezoneOffset

-- Compute statistics
let
props :: Either String (Array Props)
props = sortWith _.id <<< map (cmpProps (Config config)) <$> tracklets

log $ show props
H.modify_ _ { fetching = false, tracklets = hush tracklets, props = hush props }
file addition: Plot.hs (-xw-x--x--)

[0.22809]

module Frontend.Component.Plot where

import Prelude

import Data.Foldable (sequence_, traverse_)
import Data.Maybe (Maybe(..))
import Data.Traversable (for_)
import Effect.Aff.Class (class MonadAff)
import Effect.Class (class MonadEffect)
import Effect.Class.Console (log)
import Frontend.UPlot as UPlot
import Halogen (liftEffect)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Query.EventSource (eventListenerEventSource)
import Web.Event.Event (EventType(..))
import Web.HTML (window)
import Web.HTML.HTMLElement (getBoundingClientRect)
import Web.HTML.Window (document, toEventTarget)

type State =
{ plot :: Maybe UPlot.Plot
, opts :: UPlot.Opts
}

type Data = Array (Array (Maybe Number))

data Query a =
SetData Data a

data Action
= Initialize
| Finalize
| Resize
-- | SetOpts UPlot.Opts

component :: forall o m. MonadAff m => H.Component HH.HTML Query UPlot.Opts o m
component =
H.mkComponent
{ initialState: \opts -> { plot: Nothing, opts }
, render
, eval: H.mkEval $ H.defaultEval
{ handleAction = handleAction
, handleQuery = handleQuery
, initialize = Just Initialize
, finalize = Just Finalize
, receive = const Nothing -- Just <<< SetOpts
}
}

render :: forall m. State -> H.ComponentHTML Action () m
render state = HH.div [ HP.ref (H.RefLabel "plot") ] []

handleQuery :: forall a o m. MonadEffect m => Query a -> H.HalogenM State Action () o m (Maybe a)
handleQuery = case _ of
SetData d a -> do
plot' <- H.get <#> _.plot
for_ plot' \plot -> do
liftEffect $ UPlot.setData plot d
pure (Just a)

handleAction ∷ forall o m. MonadAff m => Action → H.HalogenM State Action () o m Unit
handleAction = case _ of
Initialize -> do
log "Initializing"
div <- H.getHTMLElementRef (H.RefLabel "plot")
opts <- H.get <#> _.opts
for_ div \element -> do
plot <- liftEffect $ UPlot.initialize element opts
-- liftEffect $ setData plot [[1.0, 2.0, 3.0], [10.0, 12.0, 11.0], [20.0, 12.0, 11.0], [30.0, 12.0, 11.0]]
H.modify_ _ { plot = Just plot }

-- Register resize handler
document <- H.liftEffect $ document =<< window
window <- liftEffect window
H.subscribe' \sid ->
eventListenerEventSource
(EventType "resize")
(toEventTarget window)
\ev -> Just Resize
handleAction Resize

-- log $ show element
Finalize -> do
plot <- H.get <#> _.plot
liftEffect $ traverse_ UPlot.destroy plot

Resize -> do
div <- H.getHTMLElementRef (H.RefLabel "plot")
state <- H.get

sequence_ do
div' <- div
plot <- state.plot :: Maybe UPlot.Plot
pure $ do
rect <- liftEffect $ getBoundingClientRect div'
liftEffect $ UPlot.setSize plot rect.width state.opts.height

-- SetOpts opts -> do
-- H.modify_ _ { opts = opts }
-- log "Setting opts"
-- handleAction Initialize
file addition: Index.hs (-xw-x--x--)

[0.22809]

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
file addition: Filtering.hs (-xw-x--x--)

[0.22809]

module Frontend.Component.Filtering where

import Prelude

import Data.Array (length)
import Data.Array as A
import Data.Array.NonEmpty (NonEmptyArray, fromNonEmpty, head, toArray)
import Data.DateTime (DateTime, adjust, diff)
import Data.Either (Either(..), hush)
import Data.Foldable (for_)
import Data.HeytingAlgebra (tt, ff)
import Data.Int (round, toNumber)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (unwrap)
import Data.NonEmpty ((:|))
import Data.Number (fromString)
import Data.Symbol (SProxy(..))
import Data.Time.Duration (class Duration, Hours(..), convertDuration, negateDuration)
import Effect (Effect)
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class.Console (log)
import Frontend.Api (fetchInstantInterval, fetchTracklets)
import Frontend.Component.Plot as Plot
import Frontend.Dom (card)
import Frontend.Draw (drawTracklet, imageShape)
import Frontend.Tracklet.Filter (HLine, TrackletFilter)
import Frontend.Tracklet.Filter as F
import Frontend.Types (Box, Config(..), Info(..), MaybeInstant, Tracklet, Tracklets(..), Zone, dateTimeToSeconds)
import Frontend.UPlot (Opts, defaultOpts, defaultSeries)
import Frontend.Util (classes, datetimeToSeconds, secondsToDateTime)
import Graphics.Canvas (CanvasImageSource, drawImage, getCanvasElementById, getContext2D, setGlobalAlpha)
import Halogen (liftEffect)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP

type State =
{ info :: Info
, config :: Config
, mapImage :: CanvasImageSource
, instants :: Maybe (Array MaybeInstant)
, tracklets :: Maybe (Array Tracklet)
, filtered :: Maybe (Array Tracklet)
, filter :: FilterRecord
, seekPos :: DateTime
, seekLen :: Hours
, fetching :: Boolean
, trackletAlpha :: Number
}

type Slots =
( plot :: H.Slot Plot.Query Void Unit
)

data Action
= Initialize
| SetInput Input
| Seek DateTime
| SetSeekLen Hours
| FetchData
| SetTrackletAlpha Number
| SetFilter FilterRecord

type Input = { info :: Info, config :: Config, mapImage :: CanvasImageSource }

type FilterRecord = { name :: String, filter :: TrackletFilter }

line = {x0: 12.0, x1: 14.0, y: 11.0} :: HLine

preparedFilters :: Array Zone -> NonEmptyArray FilterRecord
preparedFilters zones = let
originateAtZone {name, box} =
{ name: "Tracklets which originate at " <> name
, filter: F.first (F.insideBox box)
}
passThroughZone {name, box} =
{ name: "Tracklets which pass through " <> name
, filter: F.runParser $ F.any (F.insideBox box)
}
in fromNonEmpty $ {name: "Everything", filter: tt} :|
[ {name: "Nothing", filter: ff
}
]
<> (originateAtZone <$> zones)
<> (passThroughZone <$> zones)

seekLenChoices :: NonEmptyArray Hours
seekLenChoices = Hours <$> fromNonEmpty (1.0 :| [6.0, 12.0, 24.0])

_plot = (SProxy :: SProxy "plot")

component :: forall query output m. MonadAff m => H.Component HH.HTML query Input output m
component = H.mkComponent
{ initialState: \{info, config, mapImage} ->
{ info
, config
, mapImage
, instants: Nothing
, tracklets: Nothing
, filtered: Nothing
, filter: head $ preparedFilters (unwrap config).zones
, seekPos: (unwrap info).first_dt
, seekLen: head seekLenChoices
, fetching: false
, trackletAlpha: 0.8
}
, render
, eval: H.mkEval H.defaultEval
{ handleAction = handleAction
, initialize = Just Initialize
, receive = Just <<< SetInput
}
}

filteringOptions :: forall m. MonadAff m => State -> H.ComponentHTML Action Slots m
filteringOptions {info: Info info, config: Config config, seekPos, seekLen, fetching, trackletAlpha, tracklets, filtered, filter} = let
maxSeek = fromMaybe info.last_dt $ adjust (negateDuration seekLen) info.last_dt
in HH.div_
[ HH.text $ "Total tracklets: " <> fromMaybe "N/A" (show <<< length <$> tracklets)
, HH.br_
, HH.text $ "Filtered tracklets: " <> fromMaybe "N/A" (show <<< length <$> filtered)

, HH.hr_

, HH.div [ classes ["by-2"] ]
[ HH.text "Tracklet Alpha:"
, HH.input
[ HP.type_ HP.InputRange
, classes ["slider", "custom-range"]
, HP.min 0.0
, HP.max 255.0
, HE.onValueInput (map (SetTrackletAlpha <<< (_ / 255.0)) <<< fromString)
, HP.value $ show $ trackletAlpha * 255.0
]
]
, HH.div [ classes ["by-2"] ] $
[ HH.text "Show:"
, HH.br_
, HH.div [ classes ["container"] ]
[ HH.div [ classes ["row"] ]
(toArray (preparedFilters config.zones) <#> \f -> HH.div [ classes ["col-6"] ]
[ HH.input
[ HP.type_ HP.InputRadio
, HP.value "Hello!"
, HP.checked (f.name == filter.name)
, HE.onClick $ const $ Just $ SetFilter f
, classes ["mx-2"] ]
, HH.text f.name
])
]
]
]

seekingOptions :: forall m. MonadAff m => State -> H.ComponentHTML Action Slots m
seekingOptions {info: Info info, seekPos, seekLen, fetching, trackletAlpha, tracklets, filtered, filter} = let
maxSeek = fromMaybe info.last_dt $ adjust (negateDuration seekLen) info.last_dt
in HH.div_
[ HH.div [ classes ["my-2"] ] [ HH.text "Seek:" ]
, HH.div [ classes ["my-2"] ]
[ HH.input
[ HP.type_ HP.InputRange
, classes ["slider", "custom-range"]
, HP.min $ datetimeToSeconds info.first_dt
, HP.max $ datetimeToSeconds maxSeek
, HE.onValueInput (map Seek <<< secondsToDateTime <=< fromString)
, HP.value $ show $ dateTimeToSeconds $ seekPos `min` maxSeek
]
]
, HH.div [ classes ["my-2"] ] $ toArray seekLenChoices <#> \d ->
HH.button
[ HE.onClick $ const $ Just (SetSeekLen d)
, classes ["btn", if seekLen == d then "btn-primary" else "btn-primary-outline"]
] [HH.text $ show (round $ unwrap d) <> " h"]
, HH.div [ classes ["my-2"] ]
[ HH.button
[ HE.onClick $ const $ Just FetchData
, classes ["btn", "btn-primary", "btn-outline"]
] [HH.text "Fetch Data"]
, HH.i [classes $ ["m-2"] <> if fetching then ["fas", "fa-fw", "fa-hourglass"] else []] []
]
, HH.slot _plot unit Plot.component seekPlotOpts (const Nothing)
]

seekPlotOpts :: Opts
seekPlotOpts = defaultOpts
{ series = [defaultSeries, {stroke: "white", fill: "rgba(0, 0, 0, 0.1)"}, defaultSeries ]
}

render :: forall m. MonadAff m => State -> H.ComponentHTML Action Slots m
render state = let
{width, height} = imageShape state.mapImage
in
HH.div [ classes ["row"] ]
[ HH.div [ classes ["col-lg-7"] ]
[ card []
[ HH.text "Filtering" ]
[ filteringOptions state
]
, card []
[ HH.text "Seeking" ]
[ seekingOptions state
]
]
, card ["col-lg-5"]
[ HH.text "Tracklets" ]
[ HH.canvas [ HP.id_ "heatmap-canvas", HP.width width, HP.height height ]
]
]

drawTracklets :: CanvasImageSource -> Box -> Array Tracklet -> Number -> Effect Unit
drawTracklets mapImage box tracklets alpha = do
mCanvas <- liftEffect $ getCanvasElementById "heatmap-canvas"
liftEffect case mCanvas of
Nothing -> log "Can't locate canvas."
Just canvas -> do
ctx <- getContext2D canvas
setGlobalAlpha ctx 1.0
drawImage ctx mapImage 0.0 0.0
log $ "Drawing " <> show (length tracklets) <> " tracklets..."
for_ tracklets (drawTracklet canvas box alpha)

drawInstants :: forall s a output m d. Duration d =>
Array MaybeInstant -> DateTime -> d -> H.HalogenM s a Slots output m Unit
drawInstants instants seek window = do
let
inWindow t = let d = t `diff` seek in
Hours 0.0 <= d && d < convertDuration window
x = instants <#> (unwrap >>> _.timestamp >>> datetimeToSeconds >>> Just)
y = instants <#> (unwrap >>> _.objects >>> map (A.length >>> toNumber))
w = instants <#> \i ->
if inWindow (unwrap i).timestamp then Just 20.0 else Nothing
void $ H.query _plot unit $ H.tell (\a -> Plot.SetData [x, w, y] a)

handleAction :: forall output m. MonadAff m => Action -> H.HalogenM State Action Slots output m Unit
handleAction = case _ of
Initialize -> do
{info: Info info, config: Config config, seekPos, seekLen} <- H.get

-- Number of tracklets over time
instantRange <- liftAff $ fetchInstantInterval info.first_dt info.last_dt (Hours 0.2)
for_ instantRange \instants -> do -- Either
H.modify_ $ _ { instants = Just instants }
drawInstants instants seekPos seekLen

-- Tracklet heatmap
handleAction FetchData

pure unit

SetInput { info, config } -> H.modify_ _ { info = info, config = config }

Seek time -> do
{instants, seekPos, seekLen} <- H.get
H.modify_ _ { seekPos = time }
for_ instants \i -> do
drawInstants i time seekLen
pure unit

SetSeekLen hours -> do
{info: Info info, instants, seekPos} <- H.get
let maxPos = fromMaybe info.last_dt $ adjust (negateDuration hours) info.last_dt
newPos = seekPos `min` maxPos
H.modify_ _ { seekLen = hours, seekPos = newPos }
for_ instants \i -> do
drawInstants i newPos hours

FetchData -> do
{info: Info info, config: Config config, mapImage, seekPos, seekLen, trackletAlpha, filter} <- H.get
H.modify_ _ { fetching = true }
let
t1 = seekPos
t2 = fromMaybe seekPos $ adjust seekLen seekPos

tracklets' <- liftAff $ fetchTracklets t1 t2 10
case tracklets' of
Left err -> log $ "Tracklets weren't fetched:" <> show err
Right (Tracklets tracklets) -> do
let filtered = A.filter filter.filter tracklets
liftEffect $ drawTracklets mapImage config.bbox filtered trackletAlpha
H.modify_ _ { filtered = Just filtered }

H.modify_ _ { fetching = false, tracklets = unwrap <$> hush tracklets' }

SetTrackletAlpha a -> do
{ config: Config config, mapImage, filtered } <- H.get
H.modify_ _ { trackletAlpha = a }
liftEffect $ drawTracklets mapImage config.bbox (fromMaybe [] filtered) a

SetFilter f -> do
{ config: Config config, mapImage, tracklets, trackletAlpha } <- H.get
let filtered = A.filter f.filter $ fromMaybe [] tracklets
log $ "Setting filter to " <> f.name
H.modify_ _ { filter = f, filtered = Just filtered }
liftEffect $ drawTracklets mapImage config.bbox filtered trackletAlpha
file addition: Debounce.hs (-xw-x--x--)

[0.22809]

-- | Take incoming Aff requests, and perform them sequentially.
-- | In case a request is received while another is being performed,
-- | queue the new request instead. The queued request will be performed once the
-- | one before finishes. The request queue contains at most a single request;
-- | in case multiple ones are added, only the newest one stays.
-- |
-- | This ensures optimal semantics in the following sense: At every point in time,
-- | the freshest possible result is returned to the caller.

module Frontend.Component.Debounce where

import Prelude

import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype)
import Effect.Aff (Aff)
import Effect.Aff.Class (class MonadAff, liftAff)
import Halogen as H
import Halogen.HTML as HH

newtype Output t = Output t
derive instance newtypeOutput :: Newtype (Output t) _

data Query t a = Query (Aff t) a

type State t = { seeking :: Boolean, seekQueue :: Maybe (Aff t) }

debounce :: forall input t m. MonadAff m => H.Component HH.HTML (Query t) input (Output t) m
debounce =
H.mkComponent
{ initialState: \_ -> { seeking: false, seekQueue: Nothing }
, render: const $ HH.text ""
, eval: H.mkEval $ H.defaultEval { handleQuery = handleQuery }
}
where

handleQuery :: forall action a. Query t a -> H.HalogenM (State t) action () (Output t) m (Maybe a)
handleQuery = case _ of
Query computation a -> do
H.modify_ _ { seekQueue = Just computation }
seeking <- H.gets _.seeking
case seeking of
true -> pure (Just a)
false -> do
H.modify_ _ { seeking = true, seekQueue=Nothing }
res <- liftAff computation
H.modify_ _ { seeking = false }
H.raise $ Output res
q <- H.gets _.seekQueue
case q of
Nothing -> pure (Just a)
Just v -> handleQuery (Query v a)
file addition: Dashboard.hs (-xw-x--x--)

[0.22809]

module Frontend.Component.Dashboard where

import Prelude

import CSS (color)
import Color (toHexString)
import Data.Array (length)
import Data.DateTime (diff)
import Data.Foldable (for_)
import Data.Formatter.Number (formatOrShowNumber)
import Data.Int (floor, toNumber)
import Data.Maybe (Maybe(..))
import Data.Monoid (guard)
import Data.Newtype (unwrap)
import Data.Symbol (SProxy(..))
import Data.Time.Duration (class Duration, Days(..), Hours(..), Minutes(..), Seconds(..), convertDuration)
import Data.Tuple (Tuple(..))
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class.Console (log)
import Frontend.Api (fetchInstantInterval)
import Frontend.Component.Plot as Plot
import Frontend.Dom (card)
import Frontend.Draw (canvasShape, colorToCss, hashedColor, imageShape, metersToPixels)
import Frontend.Route (Route(..), routeCodec)
import Frontend.Types (Box(..), Config(..), Info(..), Vec2(..))
import Frontend.UPlot (defaultOpts, defaultSeries, defaultXAxis, noAxis)
import Frontend.Util (classes, datetimeToSeconds, enumerate, formatDateTime')
import Graphics.Canvas (CanvasImageSource)
import Graphics.Canvas as Canvas
import Halogen (liftEffect)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.CSS as CSS
import Halogen.HTML.Properties as HP
import Routing.Duplex (print)

type State =
{ info :: Info
, config :: Config
, mapImage :: CanvasImageSource
}

type Slots =
( plot :: H.Slot Plot.Query Void Unit
)

data Action
= Initialize
| SetInput Input

type Input = { info :: Info, config :: Config, mapImage :: CanvasImageSource }

_plot = (SProxy :: SProxy "plot")

component :: forall query output m. MonadAff m => H.Component HH.HTML query Input output m
component = H.mkComponent
{ initialState: \{info, config, mapImage} ->
{ info
, config
, mapImage
}
, render
, eval: H.mkEval H.defaultEval
{ handleAction = handleAction
, initialize = Just Initialize
, receive = Just <<< SetInput
}
}

tableRow :: forall a s m. String -> String -> H.ComponentHTML a s m
tableRow label value = HH.tr_
[ HH.td_ [ HH.text label ]
, HH.td_ [ HH.text value ]
]

formatDuration :: forall d. Duration d => d -> String
formatDuration duration = let
Days d = convertDuration duration
Hours h = convertDuration duration
ds = show $ floor d
hs = show $ floor h - (floor d * 24)
in guard (floor d > 0) (ds <> " days ") <> hs <> " hours"

basicInformation :: forall a s m. MonadAff m => String -> Info -> Config -> H.ComponentHTML a s m
basicInformation cls (Info info) (Config config) =
card [cls]
[ HH.text "Basic Information" ]
[ HH.table [ classes ["info-table"] ]
[ tableRow "Recording Start" $
formatDateTime' info.first_dt
, tableRow "Recording End" $
formatDateTime' info.last_dt
, tableRow "Time Span" $
formatDuration (info.last_dt `diff` info.first_dt :: Days)
, tableRow "Number of Data Points" $
formatOrShowNumber "0,0" (toNumber info.n_entries)
, tableRow "Recording Length" $
formatDuration (Seconds $ toNumber info.n_entries * config.predict_stride)
]
]

sceneConfiguration :: forall a s m. MonadAff m => String -> Config -> H.ComponentHTML a s m
sceneConfiguration cls (Config config) =
card [cls]
[ HH.text "Scene Configuration" ]
[ HH.table [ classes ["info-table"] ]
[ tableRow "Number of Cameras" $
show (length config.cameras)
, tableRow "Frames per Second" $
formatOrShowNumber "0.0" (1.0 / config.predict_stride)
, tableRow "Maximum Number of Objects" $
show config.n_objects
, tableRow "Minimum Tracklet Length" $
show config.min_tracklet_len <> " frames"
, tableRow "Warmup Period" $
show config.toss_first <> " frames"
, tableRow "Quantization" $
show config.grid_px_size <> " m"
, tableRow "Bounding Box" $
show config.bbox
, tableRow "GPU ID" $
show config.gpu
]
, HH.div [ classes [] ]
[ HH.text "Zones:"
, HH.br_
, HH.ul [] $ enumerate config.zones <#> \(Tuple i zone) ->
HH.li [CSS.style (color $ colorToCss (hashedColor i))] [HH.text zone.name]
]
, HH.div [ classes ["mt-4"] ]
[ HH.i_ [ HH.a [ HP.href ("/web/#" <> print routeCodec Cameras) ] [ HH.text "show cameras" ] ]
, HH.br_
, HH.i_
[ HH.text "show raw config:"
, HH.a [ classes ["mx-1"], HP.href "/info/tracker.yaml" ] [ HH.text "yaml" ]
, HH.text "|"
, HH.a [ classes ["mx-1"], HP.href "/config" ] [ HH.text "json" ]
]
]
]

sceneMap :: forall a s m. MonadAff m => CanvasImageSource -> H.ComponentHTML a s m
sceneMap mapImage = let
{width, height} = imageShape mapImage
in card []
[ HH.text "Scene Map" ]
[ HH.canvas [ HP.id_ "map-canvas", HP.width width, HP.height height ]
]

render :: forall a m. MonadAff m => State -> H.ComponentHTML a Slots m
render state = let
plotOpts = defaultOpts
{ height = 100.0
, axes = [defaultXAxis, noAxis]
, series = [defaultSeries, defaultSeries { fill="#4e73df" }]
}
in
HH.div [ classes ["row"] ]
[ HH.div [ classes ["col-lg-8"]]
[ card []
[ HH.text "Recording History" ]
[ HH.slot _plot unit Plot.component plotOpts (const Nothing)
]
, HH.div [ classes ["row"] ]
[ basicInformation "col-xl-6" state.info state.config
, sceneConfiguration "col-xl-6" state.config
]
]
, HH.div [ classes ["col-lg-4"] ]
[ sceneMap state.mapImage
]
]

handleAction :: forall output m. MonadAff m => Action -> H.HalogenM State Action Slots output m Unit
handleAction = case _ of
Initialize -> do
{info: Info info, config: Config config, mapImage} <- H.get

-- Draw recording timeline
instantRange <- liftAff $ fetchInstantInterval info.first_dt info.last_dt (Minutes 10.0)
for_ instantRange \instants -> do
let x = instants <#> (unwrap >>> _.timestamp >>> datetimeToSeconds >>> Just)
y = instants <#> (unwrap >>> _.objects >>> map (const 1.0))
void $ H.query _plot unit $ H.tell (\a -> Plot.SetData [x, y] a)

-- draw the map
mCanvas <- liftEffect $ Canvas.getCanvasElementById "map-canvas"
liftEffect case mCanvas of
Nothing -> log "Can't locate canvas."
Just canvas -> do
ctx <- Canvas.getContext2D canvas
Canvas.setGlobalAlpha ctx 1.0
Canvas.drawImage ctx mapImage 0.0 0.0
Canvas.setGlobalAlpha ctx 0.1
cshape <- canvasShape canvas
for_ (enumerate config.zones) \(Tuple i zone) -> do
let Box {x0, x1, y0, y1} = zone.box
V2 x y = metersToPixels cshape config.bbox (V2 x0 y0)
V2 xx yy = metersToPixels cshape config.bbox (V2 x1 y1)
Canvas.setFillStyle ctx (toHexString $ hashedColor i)
Canvas.beginPath ctx
Canvas.rect ctx {x, y, width: xx - x, height: yy - y}
Canvas.fill ctx

SetInput { info, config } -> do
H.modify_ _ { info = info, config = config }
handleAction Initialize
file addition: Cameras.hs (-xw-x--x--)

[0.22809]

module Frontend.Component.Cameras where

import Prelude

import Data.Maybe (Maybe(..))
import Effect.Aff.Class (class MonadAff)
import Frontend.Dom (card)
import Frontend.Types (Config(..))
import Frontend.Util (classes)
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP

type State =
{ config :: Config
}

data Action
= Initialize

type Input = { config :: Config }

component :: forall query output m. MonadAff m => H.Component HH.HTML query Input output m
component = H.mkComponent
{ initialState: identity
, render
, eval: H.mkEval H.defaultEval
{ initialize = Just Initialize
}
}

render :: forall s m. MonadAff m => State -> H.ComponentHTML Action s m
render { config: Config config } =
HH.div [ classes ["row"] ] $
config.cameras <#> \info ->
card ["col-lg-6"]
[ HH.text "Camera View" ]
[ HH.b_ [ HH.text $ "Name: " <> info.name ]
, HH.br_
, HH.text $ "Resolution: " <> show info.width <> "×" <> show info.height
, HH.br_
, HH.a [ HP.href $ "/info/" <> info.image ]
[ HH.img [ classes ["camera-preview"], HP.src $ "/info/" <> info.image ]
]
]
file addition: Cache.hs (-xw-x--x--)

[0.6]

module Frontend.Cache where

import Prelude

import Data.Foldable (class Foldable)
import Data.Map as M
import Data.Maybe (Maybe)
import Data.Tuple (Tuple(..), snd)

-- TODO: limit capacity

data Cache a = Cache
{ cache :: M.Map Int (Tuple Int a)
, i :: Int
}

empty :: forall a. Cache a
empty = Cache { cache: M.empty, i: 0 }

insert :: forall a. Int -> a -> Cache a -> Cache a
insert k v (Cache c) = Cache
{ cache: M.insert k (Tuple c.i v) c.cache
, i: c.i + 1
}

insertFoldable :: forall a f. Foldable f => Functor f => f (Tuple Int a) -> Cache a -> Cache a
insertFoldable f (Cache c) = Cache
{ cache: M.fromFoldable (map (\(Tuple k v) -> Tuple k (Tuple c.i v)) f) `M.union` c.cache
, i: c.i + 1
}

size :: forall a. Cache a -> Int
size (Cache c) = M.size c.cache

lookup :: forall v. Int -> Cache v -> Maybe v
lookup v (Cache c) = snd <$> M.lookup v c.cache
file addition: Assets.js (-xw-x--x--)

[0.6]

"use strict";

exports.logoWhite = require("../../static/logo-white.svg");
exports.certiconLogo = require("../../static/certicon-logo.svg");
file addition: Assets.hs (-xw-x--x--)

[0.6]

module Frontend.Assets where

foreign import logoWhite :: String
foreign import certiconLogo :: String
file addition: Api.hs (-xw-x--x--)

[0.6]

module Frontend.Api where

import Prelude

import Affjax as AX
import Affjax.ResponseFormat as ResponseFormat
import Data.Argonaut.Decode (class DecodeJson, decodeJson, (.:))
import Data.Bifunctor (lmap)
import Data.DateTime (DateTime)
import Data.Either (Either(..))
import Data.Newtype (unwrap)
import Data.Time.Duration (class Duration, Seconds, convertDuration)
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Frontend.Tracklets (TrackletSOA)
import Frontend.Types (Config, Info, Instant, MaybeInstant, Tracklets)
import Frontend.Util (datetimeToSeconds, loadImage)
import Graphics.Canvas (CanvasImageSource)
import Web.File.Url (createObjectURL)

fetchInfo :: Aff (Either String Info)
fetchInfo = getJson "/info"

fetchConfig :: Aff (Either String Config)
fetchConfig = getJson "/config"

fetchInfoImage :: String -> Aff (Either String CanvasImageSource)
fetchInfoImage url = do
result <- lmap AX.printError <$> AX.get ResponseFormat.blob ("/info/" <> url)
case result of
Left err -> pure $ Left err
Right response -> do
blobUrl <- liftEffect $ createObjectURL response.body
image <- loadImage blobUrl
pure (Right image)

fetchTracklets :: DateTime -> DateTime -> Int -> Aff (Either String Tracklets)
fetchTracklets from to stride = let
from' = show $ datetimeToSeconds from
to' = show $ datetimeToSeconds to
stride' = show stride
in getJson $ "/tracklet_pos?from=" <> from' <> "&to=" <> to' <> "&stride=" <> stride'

fetchTrackletsSOA :: DateTime -> DateTime -> Int -> Aff (Either String (Array TrackletSOA))
fetchTrackletsSOA from to stride = let
from' = show $ datetimeToSeconds from
to' = show $ datetimeToSeconds to
stride' = show stride
in getJson $ "/tracklet_pos?from=" <> from' <> "&to=" <> to' <> "&stride=" <> stride'

fetchInstantInterval :: forall d. Duration d => DateTime -> DateTime -> d -> Aff (Either String (Array MaybeInstant))
fetchInstantInterval from to stride = let
from' = show $ datetimeToSeconds from
to' = show $ datetimeToSeconds to
stride' = show $ unwrap (convertDuration stride :: Seconds)
in getJson $ "/time_range_t?from=" <> from' <> "&to=" <> to' <> "&stride=" <> stride'

fetchInstantRange :: DateTime -> DateTime -> Number -> Aff (Either String (Array Instant))
fetchInstantRange from to stride = let
from' = show $ datetimeToSeconds from
to' = show $ datetimeToSeconds to
stride' = show stride
in getJson $ "/time_range_n?from=" <> from' <> "&to=" <> to' <> "&stride=" <> stride'

getJson :: forall a. DecodeJson a => String -> Aff (Either String a)
getJson url = do
result <- lmap AX.printError <$> AX.get ResponseFormat.json url
pure $ do
response <- result
o <- lmap show $ decodeJson response.body
ok <- lmap show $ o .: "Ok"
lmap show $ decodeJson ok