Add static analysis duration to analytics

marlowe-playground-client/src/StaticAnalysis/StaticTools.purs

@@ -9,25 +9,28 @@ module StaticAnalysis.StaticTools
   ) where
 
 import Prelude hiding (div)
+import Analytics (class IsEvent, analyticsTracking)
 import Control.Monad.Except (ExceptT, runExceptT)
 import Control.Monad.Reader (class MonadAsk, asks, runReaderT)
 import Data.Bifunctor (lmap)
+import Data.BigInteger (BigInteger, toNumber)
 import Data.Lens (assign, use)
 import Data.List (List(..), foldl, fromFoldable, length, snoc, toUnfoldable)
 import Data.List.Types (NonEmptyList(..))
 import Data.Maybe (Maybe(..))
 import Data.NonEmpty ((:|))
+import Data.Traversable (traverse)
 import Data.Tuple.Nested (type (/\), (/\))
 import Effect.Aff.Class (class MonadAff)
 import Env (Env)
-import Halogen (HalogenM)
+import Halogen (HalogenM, liftEffect)
 import Marlowe as Server
 import Marlowe.Extended (fillTemplate, toCore)
 import Marlowe.Extended as EM
 import Marlowe.Semantics (Case(..), Contract(..), Observation(..), emptyState)
 import Marlowe.Semantics as S
 import Marlowe.Symbolic.Types.Request as MSReq
-import Marlowe.Symbolic.Types.Response (Result(..))
+import Marlowe.Symbolic.Types.Response (Response(..), Result(..))
 import Network.RemoteData (RemoteData(..))
 import Network.RemoteData as RemoteData
 import Servant.PureScript.Ajax (AjaxError(..))
@@ -61,7 +64,7 @@ analyseContract extendedContract = do
   where
   emptySemanticState = emptyState zero
 
-  checkContractForWarnings settings state contract = runAjax $ (flip runReaderT) settings (Server.postMarloweanalysis (MSReq.Request { onlyAssertions: false, contract, state }))
+  checkContractForWarnings settings state contract = traverse logAndStripDuration =<< (runAjax $ (flip runReaderT) settings (Server.postMarloweanalysis (MSReq.Request { onlyAssertions: false, contract, state })))
 
 splitArray :: forall a. List a -> List (List a /\ a /\ List a)
 splitArray x = splitArrayAux Nil x
@@ -188,6 +191,26 @@ getNextSubproblem f (Cons (zipper /\ contract) rest) Nil =
 
 getNextSubproblem f acc newChildren = getNextSubproblem f (acc <> newChildren) Nil
 
+data StaticAnalysisEvent
+  = StaticAnalysisTimingEvent BigInteger
+
+instance isEventStaticAnalysisEvent :: IsEvent StaticAnalysisEvent where
+  toEvent (StaticAnalysisTimingEvent durationMs) =
+    Just
+      ( { action: "timing_complete"
+        , category: Just "Static Analysis"
+        , label: Just "Duration of analysis"
+        , value: Just $ toNumber durationMs
+        }
+      )
+
+logAndStripDuration ::
+  forall m state action slots.
+  MonadAff m => Response -> HalogenM state action slots Void m Result
+logAndStripDuration (Response { result, durationMs }) = do
+  liftEffect $ analyticsTracking (StaticAnalysisTimingEvent durationMs)
+  pure result
+
 checkContractForFailedAssertions ::
   forall m state action slots.
   MonadAff m =>
@@ -197,7 +220,7 @@ checkContractForFailedAssertions ::
   HalogenM state action slots Void m (WebData Result)
 checkContractForFailedAssertions contract state = do
   settings <- asks _.ajaxSettings
-  runAjax $ (flip runReaderT) settings (Server.postMarloweanalysis (MSReq.Request { onlyAssertions: true, contract: contract, state: state }))
+  traverse logAndStripDuration =<< (runAjax $ (flip runReaderT) settings (Server.postMarloweanalysis (MSReq.Request { onlyAssertions: true, contract: contract, state: state })))
 
 startMultiStageAnalysis ::
   forall m state action slots.

marlowe-playground-server/app/PSGenerator.hs

@@ -149,6 +149,7 @@ myTypes =
     , mkSumType (Proxy @InterpreterError)
     , mkSumType (Proxy @Warning)
     , mkSumType (Proxy @(InterpreterResult A))
+    , (genericShow <*> mkSumType) (Proxy @MSRes.Response)
     , (genericShow <*> mkSumType) (Proxy @MSRes.Result)
     , mkSumType (Proxy @MSReq.Request)
     , mkSumType (Proxy @CT.ContractTerms)

marlowe-symbolic/src/Marlowe/Symbolic/Server.hs

@@ -24,27 +24,27 @@ import           Language.Marlowe                      (Contract, Slot (Slot), S
                                                         TransactionWarning)
 import           Language.Marlowe.Analysis.FSSemantics (warningsTraceCustom)
 import           Marlowe.Symbolic.Types.Request        (Request (..))
-import           Marlowe.Symbolic.Types.Response       (Result (..))
+import           Marlowe.Symbolic.Types.Response       (Response (..), Result (..))
 import           Servant                               (Application, Handler (Handler), JSON, Post, ReqBody, Server,
                                                         ServerError, hoistServer, serve, (:<|>) ((:<|>)), (:>))
-import           System.Clock                          (Clock (Monotonic), getTime)
+import           System.Clock                          (Clock (Monotonic), diffTimeSpec, getTime, toNanoSecs)
 import           System.Process                        (system)
 import           Text.PrettyPrint.Leijen               (displayS, renderCompact)
 
-type API = "marlowe-analysis" :> ReqBody '[JSON] Request :> Post '[JSON] Result
+type API = "marlowe-analysis" :> ReqBody '[JSON] Request :> Post '[JSON] Response
 
-makeResponse ::
+makeResult ::
   Either String (Maybe (Slot, [TransactionInput], [TransactionWarning])) ->
   Result
-makeResponse (Left err) = Error (show err)
-makeResponse (Right res) =
+makeResult (Left err) = Error (show err)
+makeResult (Right res) =
   case res of
         Nothing -> Valid
         Just (Slot sn, ti, tw) ->
           CounterExample
-            { initialSlot = sn,
-              transactionList = ti,
-              transactionWarning = tw
+            { initialSlot = sn
+            , transactionList = ti
+            , transactionWarning = tw
             }
 
 handlers :: Server API
@@ -54,11 +54,12 @@ handlers Request {..} =
     evRes <- warningsTraceCustom onlyAssertions contract (Just state)
     evaluate evRes
     end <- getTime Monotonic
-    let resp = makeResponse (first show evRes)
-    putStrLn $ BSU.toString $ JSON.encode resp
+    let res = Response { result = makeResult (first show evRes)
+                       , durationMs = (toNanoSecs $ diffTimeSpec start end) `div` 1000000
+                       }
+    putStrLn $ BSU.toString $ JSON.encode res
     fprintLn ("Static analysis took " % timeSpecs) start end
-    pure resp
-
+    pure res
 
 app :: Application
 app = serve (Proxy @API) handlers

marlowe-symbolic/src/Marlowe/Symbolic/Types/Response.hs

@@ -17,3 +17,12 @@ data Result = Valid
 instance FromJSON Result
 instance ToJSON Result
 
+data Response = Response { result     :: Result
+                         , durationMs :: Integer
+                         }
+  deriving (Generic)
+
+instance FromJSON Response
+instance ToJSON Response
+
+

web-common/src/Analytics.purs

@@ -37,6 +37,13 @@ type SegmentEvent
     , payload :: Object Foreign
     }
 
+type TimingEvent
+  = { category :: String
+    , variable :: String
+    , miliseconds :: Number
+    , label :: String
+    }
+
 defaultEvent :: String -> Event
 defaultEvent action =
   { action