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

"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);
};

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

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

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}

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)

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

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

"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 };
}

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

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
      ]
    ]

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" ]
      ]
    ]

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 }

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

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

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

-- | 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)

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

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 ]
        ]
      ]

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

"use strict";
exports.logoWhite = require("../../static/logo-white.svg");
exports.certiconLogo = require("../../static/certicon-logo.svg");

module Frontend.Assets where
foreign import logoWhite :: String
foreign import certiconLogo :: String

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