Reflection.hs

{-# LANGUAGE RebindableSyntax, OverloadedStrings #-}
module Chronos.Foreign.Reflection where

import Fay.Text (Text, fromString)
import JQuery
import Prelude
import HTML
import qualified Fay.Text as T
import FFI
import qualified CodeMirror as CM
import           Atlas.Fay.Video (FayVideo)
import           Atlas.Fay.Channel (FayChannel)
import qualified Atlas.Fay.Video as V
import qualified Atlas.Fay.Channel as C
import Bootstrap
import Foreign.RuleEditor.Fay
import Chronos.Foreign.Commons


--------------------------------------------------------------------------------
reflectionTable :: Text
reflectionTable = "#reflections-table"

--------------------------------------------------------------------------------
videoTable :: Text
videoTable = "#videos-table"

--------------------------------------------------------------------------------
reflExpander :: Text
reflExpander = "reflection-expander"

--------------------------------------------------------------------------------
videoExpander :: Text
videoExpander = "video-expander"

--------------------------------------------------------------------------------
reflectionGoToLink :: Text
reflectionGoToLink = "#reflections-goto-link"


--------------------------------------------------------------------------------
reflectionsTbody :: Text
reflectionsTbody = "#reflections-table-body"


--------------------------------------------------------------------------------
-- | Build a new table.
dataTable :: JQuery -> Fay ()
dataTable = ffi "%1.dataTable(dataTablesOptions)"


--------------------------------------------------------------------------------
-- | Retrieve an existing table.
getTable :: Text -> Fay JQuery
getTable tbl = do
  t <- select tbl
  go t
  where
    go :: JQuery -> Fay JQuery
    go = ffi "%1.DataTable()"


--------------------------------------------------------------------------------
-- | Redraw an existing table.
refreshTable :: JQuery -> Fay ()
refreshTable = ffi "%1.draw()"


--------------------------------------------------------------------------------
-- | Add a new row to the table. Returns the created table.
addRow :: JQuery -> [Text] -> Fay JQuery
addRow = ffi "%1.row.add(%2).node()"

--------------------------------------------------------------------------------
addRow' :: JQuery -> HTML -> Fay JQuery
addRow' = ffi "%1.row.add(%2).node()"

--------------------------------------------------------------------------------
addChild :: [Text] -> JQuery -> Fay JQuery
addChild = ffi "%2.child(%1)"

--------------------------------------------------------------------------------
addChild' :: HTML -> JQuery -> Fay JQuery
addChild' = ffi "%2.child(%1)"

--------------------------------------------------------------------------------
showNode :: JQuery -> Fay ()
showNode = ffi "%1.show()"


--------------------------------------------------------------------------------
getRow :: JQuery -> Fay JQuery
getRow row = do
  t <- getTable reflectionTable
  go t row
  where
    go :: JQuery -> JQuery -> Fay JQuery
    go = ffi "%1.row(%2)"


--------------------------------------------------------------------------------
-- | Retrieve the Reflection ID from a JSON blob.
getReflId :: Automatic g -> Fay Integer
getReflId = ffi "%1['id']"


--------------------------------------------------------------------------------
getReflVideos :: Automatic g -> Fay [FayVideo]
getReflVideos = ffi "getReflVideos(%1)"


--------------------------------------------------------------------------------
-- | Retrieve the owner for this reflection from a JSON blob.
getReflOwnedBy :: Automatic g -> Fay Text
getReflOwnedBy = ffi "%1.user.first_name + ' ' + %1.user.last_name"


--------------------------------------------------------------------------------
-- | Retrieve the organization owner for this reflection from a JSON blob.
getReflCreatedBy :: Automatic g -> Fay Text
getReflCreatedBy = ffi "%1.organization.name"


--------------------------------------------------------------------------------
-- | Retrieve the preparation state for this reflection from a JSON blob.
getReflPrepState :: Automatic g -> Fay Text
getReflPrepState = ffi "%1.prep_state"


--------------------------------------------------------------------------------
-- | Generates a hyperlink given a reflection ID.
mkExpandableRLink :: Integer -> Text
mkExpandableRLink rid = "<a href=# class='" `T.append` reflExpander `T.append`
                   "'>" `T.append`
                   "<i class='fa fa-plus-square-o'></i></a> " `T.append`
                   (T.pack $ show rid)

--------------------------------------------------------------------------------
-- | Generates a hyperlink given a reflection ID.
mkExpandableVLink :: Integer -> Text
mkExpandableVLink rid = "<a href=# class='" `T.append` videoExpander `T.append`
                   "'>" `T.append`
                   "<i class='fa fa-plus-square-o'></i></a> " `T.append`
                   (T.pack $ show rid)


--------------------------------------------------------------------------------
-- | Converts the prep_state enumeration into a Twitter Bootstrap label colour.
toLabelColour :: Text -> LabelColour
toLabelColour "ready" = LabelSuccess
toLabelColour "unsupported" = LabelDanger
toLabelColour "error" = LabelDanger
toLabelColour "waiting" = LabelWarning
toLabelColour "someready" = LabelInfo
toLabelColour "transcoding" = LabelPrimary
toLabelColour "uploading" = LabelInfo


--------------------------------------------------------------------------------
-- | Converts the prep_state enumeration into a human readable description.
toStatus :: Text -> Text
toStatus "ready" = "Ready to be watched"
toStatus "unsupported" = "Video corrupted or unsupported"
toStatus "error" = "Transcoding Error"
toStatus "waiting" = "Waiting for upload"
toStatus "someready" = "Some products are ready"
toStatus "transcoding" = "Video are transcoding"
toStatus "uploading" = "Video are preparing (queued)"


--------------------------------------------------------------------------------
appendReflection :: [Automatic g] -> Fay ()
appendReflection blob = do
  t <- getTable reflectionTable
  _ <- forM blob $ \r -> do
    rId <- getReflId r
    oBy <- getReflOwnedBy r
    cBy  <- getReflCreatedBy r
    pState <- getReflPrepState r
    lbl <- newLabel (toStatus pState) (toLabelColour pState)
    newRow <- addRow t [mkExpandableRLink rId, lbl, oBy, cBy]
    select newRow >>= \row -> do
      setAttr "id" ("reflection-" `T.append` (T.pack $ show rId)) row
      addClass "reflection-row" row
    appendVideoParts newRow r
  refreshTable t


--------------------------------------------------------------------------------
videoTableTOC =     "<tr>"
                <+> "<th>Video ID</th>"
                <+> "<th>Status</th>"
                <+> "<th>Media accessible</th>"
                <+> "<th>Video Type</th>"
                <+> "<th>Video Mode</th>"
                <+> "</tr>"


--------------------------------------------------------------------------------
toVideoType :: Text -> LabelColour
toVideoType "single" = LabelInfo
toVideoType "dual"   = LabelPrimary


--------------------------------------------------------------------------------
toVideoMode :: Text -> LabelColour
toVideoMode "normal" = LabelPrimary
toVideoMode "legacy" = LabelInfo
toVideoMode _        = LabelWarning


--------------------------------------------------------------------------------
videoTableHeader :: TableHeader
videoTableHeader = thead videoTableTOC


--------------------------------------------------------------------------------
emptyVideoTable :: HTML
emptyVideoTable = table "videos-table" videoTableHeader noHtml noHtml


--------------------------------------------------------------------------------
appendVideoParts :: Selectable a => a -> Automatic g -> Fay ()
appendVideoParts newRow r = do
  vids <- getReflVideos r
  t <- getTable reflectionTable
  -- Inject the videoTable inside the reflection table as a child.
  newTable <- select newRow >>= getRow >>= addChild' emptyVideoTable
  consoleLog "alive"
  select newTable >>= dataTable
  consoleLog "dead"
  t' <- getTable videoTable
  let noVideoParts = tr $ td "No video part associated to this reflection"
  case vids of
    [] -> void $ addRow' t' noVideoParts
    _  -> void $ forM vids $ \v -> do
     part <- videoTr v
     newRow <- addRow' t' part
     appendChannels newRow v
  return ()

--------------------------------------------------------------------------------
videoTr :: FayVideo -> Fay HTML
videoTr vp = do
  let vid = V.id vp
  let vidTxt = T.pack $ show $ V.id vp
  let cidId = "media-accessible-vid-" <+> vidTxt
  let pState = V.prep_state vp
  let vt = V.dual_view vp
  let vm = V.mode vp
  status <- newLabel (toStatus pState) (toLabelColour pState)
  vType <- newLabel vt (toVideoType vt)
  vMode <- newLabel vm (toVideoMode vm)
  let chBox = newCheckbox (V.is_media_accessible vp) cidId
  return $ trWithClass "video-row" $
             td (textCenter (mkExpandableVLink vid)) <+>
             td (textCenter status) <+>
             td (textCenter chBox) <+>
             td (textCenter vType) <+>
             td (textCenter vMode)


--------------------------------------------------------------------------------
appendChannels :: Selectable a => a -> FayVideo -> Fay ()
appendChannels newRow v = do
  t <- getTable videoTable
  let noChannels = tr $ td "No channels associated to this video"
  case (V.channels v) of
    [] -> void $ select newRow >>= getRow >>= addChild' noChannels
    _  -> do
      parts <- mapM channelTr (V.channels v)
      void $ select newRow >>= getRow >>= addChild' (tbody parts)
  return ()


--------------------------------------------------------------------------------
channelTr :: FayChannel -> Fay HTML
channelTr _ = return $ tr $ td $ "TODO"


--------------------------------------------------------------------------------
populateReflectionTable :: Fay ()
populateReflectionTable = do
  ajaxGet "/chronos/reflections"
          appendReflection
          (\_ _ _ -> consoleLog "err")


--------------------------------------------------------------------------------
main :: Fay ()
main = ready $ do
  select reflectionTable >>= dataTable
  select reflectionGoToLink >>= on "click" (const populateReflectionTable)