Server.icl 15.8 KB
Newer Older
1
implementation module iTasks.Internal.Tonic.Server
2 3 4 5

import iTasks
from Text import class Text, instance Text String
import qualified Text as T
6
import qualified Data.Map as DM
7
import Data.Map.GenJSON
8 9
from Data.Map import :: Map
import qualified Data.IntMap.Strict as DIS
10
import qualified Data.List as DL
11
import Data.Error 
12
from Data.IntMap.Strict import :: IntMap
13
import iTasks.Internal.Tonic.Blueprints
14
import iTasks.Extensions.Admin.TonicAdmin
15
import iTasks.Extensions.SVG.SVGEditor
16
import iTasks.UI.JS.Encoding
17
import iTasks.Extensions.DateTime
18 19 20
import iTasks.Internal.Tonic.AbsSyn
import iTasks.Internal.Tonic.Types
import iTasks.Internal.Tonic.Images
21
from iTasks.Internal.IWorld import :: ConnectionId
22

23
:: ViewerSettings =
24
  { recording         :: Bool
25
  , selectedBlueprint :: Maybe TMNewTopLevel
26 27
  }

28
derive class iTask ViewerSettings
29

30
shViewerSettings :: SimpleSDSLens ViewerSettings
31
shViewerSettings = sharedStore "shViewerSettings" { recording = True
32 33
                                                  , selectedBlueprint = Nothing
                                                  }
34 35 36 37 38

foldT_ :: (a -> Task ()) [a] -> Task ()
foldT_ f []       = return ()
foldT_ f [x : xs] = f x >>| foldT_ f xs

39
liveRunStateShare :: SimpleSDSLens TonicGenRTMap
40 41
liveRunStateShare = sharedStore "liveRunStateShare" 'DM'.newMap

42
recordingsShare :: SimpleSDSLens (Map DateTime [TonicMessage])
43
recordingsShare = sharedStore "recordingsShare" 'DM'.newMap
44

45
recordingForDateTimeShare :: SDSLens DateTime [TonicMessage] ()
Haye Böhm's avatar
Haye Böhm committed
46
recordingForDateTimeShare = toReadOnly (mapLens "recordingForDateTimeShare" recordingsShare (Just []))
47

48
newRTMapFromMessages :: [TonicMessage] -> Task TonicGenRTMap
49 50
newRTMapFromMessages xs = updRTMapFromMessages xs 'DM'.newMap

51 52 53
updRTMapFromMessages :: [TonicMessage] TonicGenRTMap -> Task TonicGenRTMap
updRTMapFromMessages []         rtMap = return rtMap
updRTMapFromMessages [msg : xs] rtMap = processMessage msg rtMap >>= updRTMapFromMessages xs
54 55 56 57

// Partial function :(
mkParentId :: ComputationId -> ComputationId
mkParentId [x : xs] = xs
58

59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77
processMessage :: TonicMessage TonicGenRTMap -> Task TonicGenRTMap
processMessage (TMNewTopLevel tmn) rtMap
  =           getModule tmn.tmn_bpModuleName
  >>= \mod -> case getTonicFunc mod tmn.tmn_bpFunctionName of
                Just func
                  # bpinst = { GenBlueprintInstance
                             | gbpi_computationId    = tmn.tmn_computationId
                             , gbpi_activeNode       = ([], []) // TODO Better representation? Or better default?
                             , gbpi_previouslyActive = 'DM'.newMap
                             , gbpi_parentId         = mkParentId tmn.tmn_computationId
                             , gbpi_blueprint        = func
                             , gbpi_case_branches    = 'DM'.newMap
                             , gbpi_bpref            = { BlueprintIdent
                                                       | bpr_moduleName = tmn.tmn_bpModuleName
                                                       , bpr_taskName   = tmn.tmn_bpFunctionName
                                                       }
                             }
                  = return (insertIntoRTMap bpinst rtMap)
                _ = return rtMap
78
  where
79 80 81 82 83 84 85
  insertIntoRTMap bpinst rtMap
    # comps = case 'DM'.get tmn.tmn_computationId rtMap of
                Just xs -> xs
                _       -> []
    # comps = comps ++ [((tmn.tmn_bpModuleName, tmn.tmn_bpFunctionName), bpinst)]
    = 'DM'.put tmn.tmn_computationId comps rtMap
processMessage (TMApply tma) rtMap
86 87 88 89 90
  # mParentBP = readRTMap (mkParentId tma.tma_computationId) tma.tma_bpModuleName tma.tma_bpFunctionName rtMap
  = case mParentBP of
      Just parentBPInst
        = return (updateRTMap tma parentBPInst rtMap)
      _ = return rtMap
91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109
  where
  readRTMap :: ComputationId ModuleName FuncName TonicGenRTMap -> Maybe GenBlueprintInstance
  readRTMap bpId mn tn rtMap
    = case 'DM'.get bpId rtMap of
        Just xs -> case [bp \\ ((mn`, fn), bp) <- xs | mn == mn` && tn == fn] of
                     [x : _] -> Just x
                     _       -> Nothing
        _ -> Nothing
  updateRTMap :: TMApply GenBlueprintInstance TonicGenRTMap -> TonicGenRTMap
  updateRTMap tma parentBPInst rtMap
    # oldActiveNodes = 'DM'.put (snd parentBPInst.gbpi_activeNode) (fst parentBPInst.gbpi_activeNode) parentBPInst.gbpi_previouslyActive
    # newParent      = { parentBPInst
                       & gbpi_activeNode       = (tma.tma_computationId, tma.tma_nodeId)
                       , gbpi_previouslyActive = oldActiveNodes}
    = case 'DM'.get tma.tma_computationId rtMap of
        Just [(x, _) : xs] // TODO Really? How do we determine which one to write to?
          = 'DM'.put tma.tma_computationId [(x, newParent) : xs] rtMap
        _ = rtMap

110
import StdMisc
111 112
showGenBlueprintInstance :: ![TaskAppRenderer] !GenBlueprintInstance
                            !(Maybe (Either ClickMeta (ModuleName, FuncName, ComputationId, Int)))
113
                            !Bool !Int
114 115 116
                         -> Task (ActionState (TClickAction, ClickMeta) TonicImageState)
showGenBlueprintInstance rs bpi selDetail compact depth
  = updateInformation ()
117
      [abort "huehue" /*imageUpdate id (\_ -> mkGenInstanceImage rs bpi selDetail compact) (const id) (const id)  (\_ _ -> Nothing) (const id) */]
118 119 120 121
      { ActionState
      | state  = { tis_task    = bpi.gbpi_blueprint
                 , tis_depth   = depth
                 , tis_compact = compact }
122 123
      , action = Nothing
      }
124

Jurriën Stutterheim's avatar
WIP  
Jurriën Stutterheim committed
125 126 127
// TODO FIXME:
// - Indices might be calculated incorrectly
// - Flatten the list of instances
128 129
archivedStandAloneViewer :: Task ()
archivedStandAloneViewer
Jurriën Stutterheim's avatar
WIP  
Jurriën Stutterheim committed
130
  = archivedStandAloneViewer` 0
131
  where
132 133 134 135 136 137
  archivedStandAloneViewer` curIdx
    =            enterChoiceWithShared "Select recording" [] (mapRead 'DM'.keys recordingsShare)
    >&>          withSelection noSel1
    (\dt ->      get (sdsFocus dt recordingForDateTimeShare)
    >>~ \recs -> showRecs curIdx recs)
  showRecs curIdx recs
Jurriën Stutterheim's avatar
WIP  
Jurriën Stutterheim committed
138 139 140 141 142
    # numMsgs  = length recs
    # lastIdx  = numMsgs - 1
    # notFirst = curIdx > 0
    # notLast  = curIdx < numMsgs - 1
    =                newRTMapFromMessages (take (curIdx + 1) recs)
143
    >>~ \newRTMap -> archivedStandAloneViewer`` curIdx newRTMap
144 145 146 147
    >>* [ OnAction (Action "First")    (ifCond notFirst (showRecs 0 recs))
        , OnAction (Action "Previous") (ifCond notFirst (showRecs (curIdx - 1) recs))
        , OnAction (Action "Next")     (ifCond notLast  (showRecs (curIdx + 1) recs))
        , OnAction (Action "Last")     (ifCond notLast  (showRecs lastIdx recs))
148 149
        ]
  archivedStandAloneViewer`` curIdx newRTMap
Bas Lijnse's avatar
Bas Lijnse committed
150
    =   enterChoice "Select blueprint" [ChooseFromGrid (\(x, y, z, _) -> (x, y, z))] (flattenRTMap newRTMap)
151 152 153
    >&> withSelection noSel2 viewBP
  noSel1 = viewInformation "Notice" [] "No recording selected"
  noSel2 = viewInformation "Notice" [] "No blueprint"
Jurriën Stutterheim's avatar
WIP  
Jurriën Stutterheim committed
154
  viewBP :: (ComputationId, ModuleName, FuncName, GenBlueprintInstance) -> Task ()
155
  viewBP (cid, _, _, gbpi) = showGenBlueprintInstance [] gbpi Nothing False 0 @! () // TODO Enable controls
Jurriën Stutterheim's avatar
WIP  
Jurriën Stutterheim committed
156 157 158 159 160 161

flattenRTMap :: TonicGenRTMap -> [(ComputationId, ModuleName, FuncName, GenBlueprintInstance)]
flattenRTMap m = flatten (flattenRTMap` ('DM'.toList m))
  where
  flattenRTMap` [] = []
  flattenRTMap` [(cid, ys) : xs] = [map (\((mn, fn), gbpi) -> (cid, mn, fn, gbpi)) ys : flattenRTMap` xs]
162 163 164

:: TonicGenRTMap :== Map ComputationId [((ModuleName, FuncName), GenBlueprintInstance)]

165
saSelectedBlueprint :: SimpleSDSLens (Maybe (ComputationId, BlueprintIdent))
166 167 168
saSelectedBlueprint = sharedStore "saSelectedBlueprint" Nothing

liveStandAloneViewer :: Task ()
169
liveStandAloneViewer = allTasks [ updateSharedInformation "Viewer settings" [] shViewerSettings @! ()
170
             , startViewer @! ()
171
             ] @! ()
172
where
173 174 175
  startViewer
    =   enterChoiceWithShared "Select blueprint" [] (mapRead (\ts -> 'DL'.concatMap f ts.ts_allMsgs) tonicServerShare)
    >&> withSelection noSel (
Haye Böhm's avatar
Haye Böhm committed
176
    (\bp -> whileUnchanged (tonicServerShare |*| shViewerSettings)
177 178 179 180 181
    (\x=:(tms, _) -> (runViewer x -|| forever (viewInformation () [] () >>* [ startAction tms
                                                                            , pauseAction tms
                                                                            , continueAction tms
                                                                            , stopAction tms
                                                                            ])))))
182
  where
183
    startAction :: TMessageStore -> TaskCont a (Task ())
184
    startAction {ts_recording} = OnAction (Action "Start new recording") (ifCond (not ts_recording) startTask)
185
    where
186 187
      startTask
        =   upd (\ts -> {ts & ts_recording = True, ts_recordingBuffer = []}) tonicServerShare @! ()
188
    
189
    pauseAction :: TMessageStore -> TaskCont a (Task ())
190
    pauseAction {ts_recording} = OnAction (Action "Pause recording") (ifCond ts_recording stopTask)
191
    where
192 193
      stopTask
        =   upd (\ts -> {ts & ts_recording = False}) tonicServerShare @! ()
194
    
195
    continueAction :: TMessageStore -> TaskCont a (Task ())
196
    continueAction {ts_recording} = OnAction (Action "Continue recording") (ifCond (not ts_recording) stopTask)
197
    where
198 199
      stopTask
        =   upd (\ts -> {ts & ts_recording = True}) tonicServerShare @! ()
200
    
201
    stopAction :: TMessageStore -> TaskCont a (Task ())
202
    stopAction {ts_recording} = OnAction (Action "Pause and save recording") (ifCond ts_recording stopTask)
203
    where
204 205 206 207 208
      stopTask
        =           get tonicServerShare
        >>- \ts  -> get currentDateTime
        >>- \cdt -> upd ('DM'.put cdt ts.ts_recordingBuffer) recordingsShare
        >>- \_   -> upd (\ts -> {ts & ts_recording = False}) tonicServerShare @! ()
209
    
210
    refreshAction :: TaskCont a (Task ())
211
    refreshAction = OnAction (Action "Refresh") (always startViewer)
212

213 214 215 216 217 218 219 220 221
    noSel :: Task ()
    noSel = viewInformation "Notice" [] "No blueprint selected" @! ()
    f (TMNewTopLevel tl) = [tl]
    f _                  = []
  runViewer :: (TMessageStore, ViewerSettings) -> Task ()
  runViewer ({ts_allMsgs}, {selectedBlueprint = Just tmn})
    =                newRTMapFromMessages ts_allMsgs
    >>~ \newRTMap -> case 'DM'.get tmn.tmn_computationId newRTMap of
                       Just [(_, selBPI) : _]
222
                         = showGenBlueprintInstance [] selBPI Nothing False 0 @! () // TODO Enable controls
223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241
                       _ = startViewer
  runViewer x = viewInformation "Notice" [] "No blueprint selected" >>| runViewer x

viewMessage :: TonicMessage [TonicMessage] -> Task ()
viewMessage (TMNewTopLevel msg) prevMsgs
  = viewInformation () [] "Not implemented!" @! ()
viewMessage (TMApply msg) prevMsgs
  =           getModule msg.tma_bpModuleName
  >>= \mod -> case getTonicFunc mod msg.tma_bpFunctionName of
                Just func
                  # numPrev                     = length prevMsgs
                  # inst                        = mkInstance msg.tma_nodeId func
                  # inst & bpi_previouslyActive = 'DM'.fromList [(msg.tma_nodeId, TaskId 1 i) \\ TMApply msg <- prevMsgs & i <- reverse [0..numPrev]]
                  # currActive                  = [(eid, tid) \\ (_, m) <- 'DM'.toList inst.bpi_activeNodes, (_, (tid, eid)) <- 'DIS'.toList m]
                  # inst & bpi_previouslyActive = 'DM'.union ('DM'.fromList currActive) inst.bpi_previouslyActive
                  # inst & bpi_activeNodes      = case currActive of
                                                    [(_, TaskId ino tid) : _] -> 'DM'.put (TaskId 1 0) ('DIS'.singleton 0 (TaskId ino numPrev, msg.tma_nodeId)) inst.bpi_activeNodes
                  = viewInstance inst
                _ = viewInformation () [] "No blueprint found!" @! ()
242 243

viewInstance :: !BlueprintInstance -> Task ()
244 245
viewInstance bpi=:{bpi_blueprint, bpi_bpref = {bpr_moduleName, bpr_taskName}} = return ()
/*
246
  = updateInformation ()
247
      [imageUpdate id (\_ -> mkTaskInstanceImage [] bpi 'DM'.newMap 'DM'.newMap Nothing False) (const id) (const id) (\_ _ -> Nothing) (const id)]
248 249
      { ActionState
      | state  = { tis_task    = bpi.bpi_blueprint
250
                 , tis_depth   = 0
251
                 , tis_compact = False }
Jurriën Stutterheim's avatar
Jurriën Stutterheim committed
252 253
      , action = Nothing}
      @! ()
254
*/
255

Bas Lijnse's avatar
Bas Lijnse committed
256
nulDT = toDateTime { Date | day = 0, mon = 0, year = 0 } { Time | hour = 0, min = 0, sec = 0 }
257 258 259 260

mkInstance :: NodeId TonicFunc -> BlueprintInstance
mkInstance nid tf =
  { BlueprintInstance
261
  | bpi_taskId           = TaskId 1 0
262 263 264
  , bpi_startTime        = nulDT
  , bpi_lastUpdated      = nulDT
  , bpi_endTime          = Nothing
265
  , bpi_activeNodes      = 'DM'.singleton (TaskId 1 0) ('DIS'.singleton 0 (TaskId 1 1, nid))
266 267 268 269 270 271 272 273 274 275 276
  , bpi_previouslyActive = 'DM'.newMap
  , bpi_parentTaskId     = TaskId 0 0
  , bpi_currentUser      = Nothing
  , bpi_blueprint        = tf
  , bpi_case_branches    = 'DM'.newMap
  , bpi_index            = 0
  , bpi_bpref            = { BlueprintIdent
                           | bpr_moduleName = tf.tf_module
                           , bpr_taskName   = tf.tf_name }
  }

277
messageArchive :: SimpleSDSLens [TonicMessage]
278 279
messageArchive = sharedStore "messageArchive" []

280

281 282 283 284 285 286 287 288
:: TMessageStore =
  { ts_recording       :: !Bool
  , ts_allMsgs         :: ![TonicMessage]
  , ts_recordingBuffer :: ![TonicMessage]
  }

derive class iTask TMessageStore

289
tonicServerShare :: SimpleSDSLens TMessageStore
290 291 292 293 294 295 296 297 298 299 300 301
tonicServerShare = sharedStore "tonicServerShare" { TMessageStore
                                                  | ts_recording       = True
                                                  , ts_allMsgs         = []
                                                  , ts_recordingBuffer = []
                                                  }

:: ServerState =
  { oldData  :: String
  , clientIp :: String
  }

derive class iTask ServerState
302

303
acceptAndViewTonicTraces :: Task ()
304
acceptAndViewTonicTraces
305 306
  = acceptTonicTraces tonicServerShare
      ||-
307
    viewSharedInformation "Logged traces" [] tonicServerShare @! ()
308

309
acceptTonicTraces :: !(Shared sds TMessageStore) -> Task [ServerState] | RWShared sds
310 311
acceptTonicTraces tonicShare
  = tcplisten 9000 True tonicShare { ConnectionHandlers
312
                                   | onConnect     = onConnect
313 314
                                   , onData        = onData
                                   , onShareChange = onShareChange
315
                                   , onDisconnect  = onDisconnect
316
                                   }
317
  where
318
    onConnect :: ConnectionId String TMessageStore
319
              -> (MaybeErrorString ServerState, Maybe TMessageStore, [String], Bool)
320
    onConnect connId host olderMessages
321 322
    = ( Ok { oldData = ""
           , clientIp = host}
323
      , Just olderMessages
324 325
      , ["Welcome!"]
      , False)
326

327 328 329 330 331 332 333 334 335 336 337
    onData :: String ServerState TMessageStore
           -> (MaybeErrorString ServerState, Maybe TMessageStore, [String], Bool)
    onData newData st=:{oldData} tstate
        # collectedData       = oldData +++ 'T'.trim newData
        # (strmsgs, leftover) = partitionMessages ('T'.split "TONIC_EOL" collectedData)
        # tmsgs               = [msg \\ Just msg <- map strToMessage strmsgs]
        # tstate & ts_allMsgs = tmsgs ++ tstate.ts_allMsgs
        # tstate              = if tstate.ts_recording
                                  {tstate & ts_recordingBuffer = tmsgs ++ tstate.ts_recordingBuffer}
                                  tstate
        = (Ok {st & oldData = leftover}, Just tstate, [], False)
338
    where
339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354
        strToMessage :: !String -> Maybe TonicMessage
        strToMessage str = fromJSON (fromString str)

        partitionMessages :: [String] -> ([String], String)
        partitionMessages []  = ([], "")
        partitionMessages [x] = ([], x)
        partitionMessages [x:y:xs]
            # (msgs, leftover) = partitionMessages [y:xs]
            = ([x:msgs], leftover)

    onShareChange st _  = (Ok st, Nothing, [], False)

    onDisconnect :: ServerState TMessageStore
                 -> (MaybeErrorString ServerState, Maybe TMessageStore)
    onDisconnect st lines
        = (Ok st, Just lines)
355