finish up APIs

Author: SchrodingerZhu

config/routes

@@ -7,5 +7,7 @@
 /heartbeat HeartbeatR GET
 /traces  TraceR GET
 /trace  PutTraceR PUT
-/start-trace StartTraceR POST
-/remove-trace RemoveTraceR POST
+/trace/start StartTraceR POST
+/trace/remove RemoveTraceR POST
+/trace/running RunningTraceR GET
+/traces/running/all RunningTracesR GET

src/Handler/Lambda.hs

@@ -5,14 +5,22 @@
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE TypeFamilies          #-}
 
-module Handler.Lambda (getHeartbeatR, getTraceR, putPutTraceR, postStartTraceR, postRemoveTraceR) where
+module Handler.Lambda (
+  getHeartbeatR, 
+  getTraceR, 
+  putPutTraceR, 
+  postStartTraceR, 
+  postRemoveTraceR,
+  getRunningTracesR,
+  getRunningTraceR
+) where
 import           Lambda.Endpoint
 import           Data.Aeson
 import qualified Data.Text          as T 
 import           Import
 import           Lambda.Trace 
 import           Database.Persist.Sql
-
+import           Lambda.Trace.Unsafe
 data RemoveTrace = 
   RemoveTrace {
     removeType :: Text,
@@ -46,6 +54,12 @@ data InfoWithId =
     traceNo :: Int64
   } deriving (Generic, Show)
 
+data InfoWithPath =
+    InfoWithPath {
+      info' :: TraceInfo,
+      path :: String
+  } deriving (Generic, Show)
+
 instance ToJSON HeartbeatReply where
   toEncoding = genericToEncoding defaultOptions
 instance FromJSON HeartbeatReply
@@ -67,6 +81,10 @@ instance ToJSON RemoveTrace where
   toEncoding = genericToEncoding defaultOptions
 instance FromJSON RemoveTrace
 
+instance ToJSON InfoWithPath where
+  toEncoding = genericToEncoding defaultOptions
+instance FromJSON InfoWithPath
+
 getHeartbeatR :: Handler Value
 getHeartbeatR = withVerification $ do
   t <- liftIO getCurrentTime
@@ -135,6 +153,24 @@ postRemoveTraceR = withVerification $ do
       return "deleted"
     _ -> do
       invalidArgs ["removeType"]
+
+getRunningTracesR :: Handler Value
+getRunningTracesR = withVerification $ do
+  xs <- liftIO getAllRunning
+  return $ toJSONList (map (\(x, y)-> InfoWithPath y x) xs)
+
+getRunningTraceR :: Handler Value
+getRunningTraceR = withVerification $ do
+  parm <- lookupGetParam "path"
+  liftIO $ print parm
+  case parm of 
+    Just a -> do
+      i <- liftIO $ getRunningTrace (T.unpack a)
+      case i of
+        Nothing -> return (toJSON ())
+        Just x -> return (toJSON x)
+    Nothing ->
+      invalidArgs ["path"]
 
 
 

src/Lambda/Communication.hs

@@ -41,21 +41,19 @@ submitStart :: String -> IO ()
 submitStart x = do
   request <- parseRequest $ "PUT " <> platformUrl-- <> "/submit"
   hash <- hashedSecret
-  res <- httpLBS 
+  _ <- httpLBS 
     $ setRequestBodyJSON (Info x "start") 
     $ setRequestHeader "Authorization" [BSS.append (BSS.pack endpointUUID) hash] request
-  BS8.putStrLn $ getResponseBody res
   return ()
 
 submitFinished :: String -> Handle -> ProcessHandle -> IO ()
 submitFinished x herr process = do
   body <- buildFinishedBody x herr process
   request <- parseRequest $ "PUT " <> platformUrl-- <> "/submit"
   hash <- hashedSecret
-  res <- httpLBS 
+  _ <- httpLBS 
     $ setRequestBodyLBS body $ setRequestHeader "Content-Type" ["application/json"] 
     $ setRequestHeader "Authorization" [BSS.append (BSS.pack endpointUUID) hash] request
-  BS8.putStrLn $ getResponseBody res <> "\nfinished"
   delRunningTrace x
   return ()
 
@@ -72,12 +70,11 @@ runSubmit identity hout herr process chunkNo = do
       jsonData <- buildProgressBody identity field chunkNo
       request <- parseRequest $ "PUT " <> platformUrl-- <> "/submit"
       hash <- hashedSecret
-      res <-
+      _ <-
         httpLBS $
         setRequestBodyLBS jsonData $
         setRequestHeader "Content-Type" ["application/json"] $
         setRequestHeader "Authorization" [BSS.append (BSS.pack endpointUUID) hash] request
-      BS8.putStrLn $ getResponseBody res
       runSubmit identity hout herr process (chunkNo + 1)
 
 buildProgressBody :: String -> BS.ByteString -> Int -> IO (BS.ByteString)

src/Lambda/Trace.hs

@@ -19,7 +19,7 @@ generateFile :: Trace a => a -> Int -> IO String
 generateFile x t = do
   text <- return $ generate x t
   uuid <- nextRandom
-  let filePath = "/tmp/lambda-" <> show uuid <> ".stap"
+  let filePath = "/tmp/lambda-" <> show uuid <> ".trace"
   withFile filePath WriteMode (`TIO.hPutStr` text)
   return filePath
 

src/Lambda/Trace/Unsafe.hs

@@ -16,4 +16,8 @@ delRunningTrace :: String -> IO ()
 delRunningTrace path = H.delete runningTraces path
 
 getRunningTrace :: String -> IO (Maybe TraceInfo)
-getRunningTrace path = H.lookup runningTraces path
+getRunningTrace path = H.lookup runningTraces path
+
+getAllRunning :: IO [(String, TraceInfo)]
+getAllRunning = H.toList runningTraces
+