Implemented CLI telemetry.

waspc/cli/Command/Common.hs

@@ -4,17 +4,20 @@ module Command.Common
     , waspSaysC
     ) where
 
-import System.Directory (getCurrentDirectory, doesPathExist, doesFileExist)
-import qualified System.FilePath as FP
-import Data.Maybe (fromJust)
-import Control.Monad.Except (throwError)
-import Control.Monad.IO.Class (liftIO)
-import Control.Monad (when, unless)
+import           Control.Monad          (unless, when)
+import           Control.Monad.Except   (throwError)
+import           Control.Monad.IO.Class (liftIO)
+import           Data.Maybe             (fromJust)
+import           System.Directory       (doesFileExist, doesPathExist,
+                                         getCurrentDirectory)
+import qualified System.FilePath        as FP
 
-import StrongPath (Path, Abs, Dir)
-import qualified StrongPath as SP
-import Command (Command, CommandError(..))
-import Common (WaspProjectDir, dotWaspRootFileInWaspProjectDir, waspSays)
+import           Command                (Command, CommandError (..))
+import           Common                 (WaspProjectDir,
+                                         dotWaspRootFileInWaspProjectDir,
+                                         waspSays)
+import           StrongPath             (Abs, Dir, Path)
+import qualified StrongPath             as SP
 
 
 findWaspProjectRoot :: Path Abs (Dir ()) -> Command (Path Abs (Dir WaspProjectDir))

waspc/cli/Command/Telemetry.hs

@@ -0,0 +1,32 @@
+module Command.Telemetry
+    ( considerSendingData
+    ) where
+
+import           Control.Monad             (when)
+import           Control.Monad.Except      (catchError, throwError)
+import           Control.Monad.IO.Class    (liftIO)
+import           Data.Maybe                (isJust)
+import qualified System.Environment        as ENV
+
+import           Command                   (Command, CommandError (..))
+import           Command.Telemetry.Common  (ensureTelemetryCacheDirExists)
+import qualified Command.Telemetry.Project as TlmProject
+import qualified Command.Telemetry.User    as TlmUser
+
+-- | Sends telemetry data about the current Wasp project, if conditions are met.
+-- If we are not in the Wasp project at the moment, nothing happens.
+-- If telemetry data was already sent for this project in the last 12 hours, nothing happens.
+-- If env var WASP_TELEMETRY_DISABLE is set, nothing happens.
+considerSendingData :: Command ()
+considerSendingData = (`catchError` const (return ())) $ do
+    isTelemetryDisabled <- liftIO $ isJust <$> ENV.lookupEnv "WASP_TELEMETRY_DISABLE"
+    when isTelemetryDisabled $ throwError $ CommandError "Telemetry disabled by user."
+
+    telemetryCacheDirPath <- liftIO ensureTelemetryCacheDirExists
+
+    userSignature <- liftIO $ TlmUser.readOrCreateUserSignatureFile telemetryCacheDirPath
+
+    maybeProjectHash <- (Just <$> TlmProject.getWaspProjectPathHash) `catchError` const (return Nothing)
+    case maybeProjectHash of
+        Nothing -> return ()
+        Just projectHash -> liftIO $ TlmProject.considerSendingData telemetryCacheDirPath userSignature projectHash

waspc/cli/Command/Telemetry/Common.hs

@@ -0,0 +1,29 @@
+module Command.Telemetry.Common
+    ( TelemetryCacheDir
+    , ensureTelemetryCacheDirExists
+    ) where
+
+import           Path                      (reldir)
+import qualified System.Directory          as SD
+
+import           StrongPath                (Abs, Dir, Path)
+import qualified StrongPath                as SP
+
+
+data UserCacheDir
+
+getUserCacheDirPath :: IO (Path Abs (Dir UserCacheDir))
+getUserCacheDirPath = SD.getXdgDirectory SD.XdgCache "" >>= SP.parseAbsDir
+
+data TelemetryCacheDir
+
+ensureTelemetryCacheDirExists :: IO (Path Abs (Dir TelemetryCacheDir))
+ensureTelemetryCacheDirExists = do
+    userCacheDirPath <- getUserCacheDirPath
+    SD.createDirectoryIfMissing False $ SP.toFilePath userCacheDirPath
+    let telemetryCacheDirPath = getTelemetryCacheDirPath userCacheDirPath
+    SD.createDirectoryIfMissing True $ SP.toFilePath telemetryCacheDirPath
+    return telemetryCacheDirPath
+
+getTelemetryCacheDirPath :: Path Abs (Dir UserCacheDir) -> Path Abs (Dir TelemetryCacheDir)
+getTelemetryCacheDirPath userCacheDirPath = userCacheDirPath SP.</> SP.fromPathRelDir [reldir|wasp/telemetry|]

waspc/cli/Command/Telemetry/Project.hs

@@ -0,0 +1,128 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Command.Telemetry.Project
+    ( getWaspProjectPathHash
+    , considerSendingData
+    ) where
+
+import           Command.Common            (findWaspProjectRootDirFromCwd)
+import           Control.Monad             (void, when)
+import           Crypto.Hash               (SHA256 (..), hashWith)
+import           Data.Aeson                ((.=))
+import           Control.Monad.IO.Class    (liftIO)
+import qualified Data.Aeson                as Aeson
+import qualified Data.ByteString.Lazy.UTF8 as ByteStringLazyUTF8
+import qualified Data.ByteString.UTF8      as ByteStringUTF8
+import           Data.Maybe                (fromJust)
+import qualified Data.Time                 as T
+import           Data.Version              (showVersion)
+import           GHC.Generics
+import qualified Network.HTTP.Simple       as HTTP
+import           Paths_waspc               (version)
+import qualified System.Directory          as SD
+import qualified System.Info
+
+import           Command                   (Command)
+import           Command.Telemetry.Common  (TelemetryCacheDir)
+import           Command.Telemetry.User    (UserSignature (..))
+import           StrongPath                (Abs, Dir, File, Path)
+import qualified StrongPath                as SP
+
+
+considerSendingData :: Path Abs (Dir TelemetryCacheDir) -> UserSignature -> ProjectHash -> IO ()
+considerSendingData telemetryCacheDirPath userSignature projectHash = do
+    projectCache <- liftIO $ readOrCreateProjectTelemetryFile telemetryCacheDirPath projectHash
+    shouldSendData <- liftIO $ case _lastCheckIn projectCache of
+        Nothing -> return True
+        Just lastCheckIn -> do
+            now <- T.getCurrentTime
+            let secondsSinceLastCheckIn = T.nominalDiffTimeToSeconds (now `T.diffUTCTime` lastCheckIn)
+            return $ let numSecondsInHour = 3600
+                      in secondsSinceLastCheckIn > 12 * numSecondsInHour
+    when shouldSendData $ do
+        liftIO $ sendTelemetryData $ getProjectTelemetryData userSignature projectHash
+        now <- liftIO T.getCurrentTime
+        let projectCache' = projectCache { _lastCheckIn = Just now }
+        liftIO $ writeProjectTelemetryFile telemetryCacheDirPath projectHash projectCache'
+
+-- * Project hash.
+
+newtype ProjectHash = ProjectHash { _projectHashValue :: String } deriving (Show)
+
+getWaspProjectPathHash :: Command ProjectHash
+getWaspProjectPathHash = ProjectHash . take 16 . sha256 . SP.toFilePath <$> findWaspProjectRootDirFromCwd
+  where
+    sha256 :: String -> String
+    sha256 = show . hashWith SHA256 . ByteStringUTF8.fromString
+
+-- * Project telemetry cache.
+
+data ProjectTelemetryCache = ProjectTelemetryCache
+    { _lastCheckIn :: Maybe T.UTCTime }
+    deriving (Generic, Show)
+
+instance Aeson.ToJSON ProjectTelemetryCache
+instance Aeson.FromJSON ProjectTelemetryCache
+
+initialCache :: ProjectTelemetryCache
+initialCache = ProjectTelemetryCache { _lastCheckIn = Nothing }
+
+-- * Project telemetry cache file.
+
+readOrCreateProjectTelemetryFile :: Path Abs (Dir TelemetryCacheDir) -> ProjectHash -> IO ProjectTelemetryCache
+readOrCreateProjectTelemetryFile telemetryCacheDirPath projectHash = do
+    fileExists <- SD.doesFileExist filePathFP
+    maybeCache <- if fileExists then readCacheFile else return Nothing
+    case maybeCache of
+        Just cache -> return cache
+        Nothing -> writeProjectTelemetryFile telemetryCacheDirPath projectHash initialCache >> return initialCache
+  where
+      filePathFP = SP.toFilePath $ getProjectTelemetryFilePath telemetryCacheDirPath projectHash
+      readCacheFile = Aeson.decode . ByteStringLazyUTF8.fromString <$> readFile filePathFP
+
+writeProjectTelemetryFile :: Path Abs (Dir TelemetryCacheDir) -> ProjectHash -> ProjectTelemetryCache -> IO ()
+writeProjectTelemetryFile telemetryCacheDirPath projectHash cache = do
+    let filePathFP = SP.toFilePath $ getProjectTelemetryFilePath telemetryCacheDirPath projectHash
+    writeFile filePathFP (ByteStringLazyUTF8.toString $ Aeson.encode cache)
+
+getProjectTelemetryFilePath :: Path Abs (Dir TelemetryCacheDir) -> ProjectHash -> Path Abs File
+getProjectTelemetryFilePath telemetryCacheDir (ProjectHash projectHash) =
+    telemetryCacheDir SP.</> fromJust (SP.parseRelFile $ "project-" ++ projectHash)
+
+-- * Telemetry data.
+
+data ProjectTelemetryData = ProjectTelemetryData
+    { _userSignature :: UserSignature
+    , _projectHash   :: ProjectHash
+    , _waspVersion   :: String
+    , _os            :: String
+    } deriving (Show)
+
+getProjectTelemetryData :: UserSignature -> ProjectHash -> ProjectTelemetryData
+getProjectTelemetryData userSignature projectHash = ProjectTelemetryData
+    { _userSignature = userSignature
+    , _projectHash = projectHash
+    , _waspVersion = showVersion version
+    , _os = System.Info.os
+    }
+
+sendTelemetryData :: ProjectTelemetryData -> IO ()
+sendTelemetryData telemetryData = do
+    let reqBodyJson = Aeson.object
+            [ -- PostHog api_key is public so it is ok that we have it here.
+              "api_key" .= ("CdDd2A0jKTI2vFAsrI9JWm3MqpOcgHz1bMyogAcwsE4" :: String)
+            , "event" .= ("cli" :: String)
+            , "properties" .= Aeson.object
+                [ -- distinct_id is special PostHog value, used as user id.
+                  "distinct_id" .= _userSignatureValue (_userSignature telemetryData)
+                -- Following are our custom metrics:
+                , "project_hash" .= _projectHashValue (_projectHash telemetryData)
+                , "wasp_version" .= _waspVersion telemetryData
+                , "os" .= _os telemetryData
+                ]
+            ]
+        request = HTTP.setRequestBodyJSON reqBodyJson $
+                  HTTP.parseRequest_ "POST https://app.posthog.com/capture"
+    void $ HTTP.httpNoBody request
+
+

waspc/cli/Command/Telemetry/User.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Command.Telemetry.User
+    ( UserSignature(..)
+    , readOrCreateUserSignatureFile
+    ) where
+
+import qualified Data.UUID.V4             as UUID
+import           Path                     (relfile)
+import qualified System.Directory         as SD
+
+import           Command.Telemetry.Common (TelemetryCacheDir)
+import           StrongPath               (Abs, Dir, File, Path)
+import qualified StrongPath               as SP
+
+
+
+-- Random, non-identifyable UUID used to represent user in analytics.
+newtype UserSignature = UserSignature { _userSignatureValue :: String } deriving (Show)
+
+readOrCreateUserSignatureFile :: Path Abs (Dir TelemetryCacheDir) -> IO UserSignature
+readOrCreateUserSignatureFile telemetryCacheDirPath = do
+    let filePath = getUserSignatureFilePath telemetryCacheDirPath
+    let filePathFP = SP.toFilePath filePath
+    fileExists <- SD.doesFileExist filePathFP
+    UserSignature <$> if fileExists
+        then readFile filePathFP
+        else do userSignature <- show <$> UUID.nextRandom
+                writeFile filePathFP userSignature
+                return userSignature
+
+getUserSignatureFilePath :: Path Abs (Dir TelemetryCacheDir) -> Path Abs File
+getUserSignatureFilePath telemetryCacheDir = telemetryCacheDir SP.</> SP.fromPathRelFile [relfile|signature|]
+

waspc/cli/Main.hs

@@ -1,29 +1,42 @@
 module Main where
 
-import System.Environment
-import Paths_waspc (version)
-import Data.Version (showVersion)
+import           Control.Concurrent       (threadDelay)
+import qualified Control.Concurrent.Async as Async
+import           Control.Monad            (void)
+import           Data.Version             (showVersion)
+import           Paths_waspc              (version)
+import           System.Environment
 
-import Command (runCommand)
-import Command.Db (runDbCommand, studio)
-import Command.CreateNewProject (createNewProject)
-import Command.Start (start)
-import Command.Clean (clean)
-import Command.Compile (compile)
-import Command.Db.Migrate (migrateSave, migrateUp)
+import           Command                  (runCommand)
+import           Command.Clean            (clean)
+import           Command.Compile          (compile)
+import           Command.CreateNewProject (createNewProject)
+import           Command.Db               (runDbCommand, studio)
+import           Command.Db.Migrate       (migrateSave, migrateUp)
+import           Command.Start            (start)
+import qualified Command.Telemetry        as Telemetry
 
 
 main :: IO ()
 main = do
+    telemetryThread <- Async.async $ runCommand Telemetry.considerSendingData
+
     args <- getArgs
     case args of
         ["new", projectName] -> runCommand $ createNewProject projectName
-        ["start"] -> runCommand start
-        ["clean"] -> runCommand clean
-        ["compile"] -> runCommand compile
-        ("db":dbArgs) -> dbCli dbArgs
-        ["version"] -> printVersion
-        _ -> printUsage
+        ["start"]            -> runCommand start
+        ["clean"]            -> runCommand clean
+        ["compile"]          -> runCommand compile
+        ("db":dbArgs)        -> dbCli dbArgs
+        ["version"]          -> printVersion
+        _                    -> printUsage
+
+    -- If sending of telemetry data is still not done 1 second since commmand finished, abort it.
+    -- We also make sure here to catch all errors that might get thrown and silence them.
+    void $ Async.race (threadDelaySeconds 1) (Async.waitCatch telemetryThread)
+  where
+      threadDelaySeconds = let microsecondsInASecond = 1000000
+                           in threadDelay . (* microsecondsInASecond)
 
 printUsage :: IO ()
 printUsage = putStrLn $ unlines

waspc/package.yaml

@@ -80,6 +80,11 @@ executables:
       - async
       - time
       - path-io
+      - uuid
+      - cryptonite
+      - aeson
+      - utf8-string
+      - http-conduit
 
 benchmarks:
   waspc-benchmarks: