Implement contributor tracking (#94)

* Implement contributor tracking

* de-imperative-ize? the map build

* Move git contrib functions to new module

* Fix merge conflicts

spectrometer.cabal

@@ -184,6 +184,7 @@ library
     Strategy.Ruby.BundleShow
     Strategy.Ruby.GemfileLock
     Types
+    VCS.Git
 
   hs-source-dirs:  src
 

src/App/Fossa/Analyze.hs

@@ -12,14 +12,15 @@ import Control.Carrier.Output.IO
 import Control.Concurrent
 
 import App.Fossa.Analyze.Project (Project, mkProjects)
-import App.Fossa.FossaAPIV1 (ProjectMetadata, uploadAnalysis, UploadResponse(..))
+import App.Fossa.FossaAPIV1 (ProjectMetadata, uploadAnalysis, UploadResponse(..), uploadContributors)
 import App.Fossa.ProjectInference (mergeOverride, inferProject)
 import App.Types
 import Control.Carrier.Finally
 import Control.Carrier.TaskPool
 import Data.Text.Lazy.Encoding (decodeUtf8)
 import Data.Text.Prettyprint.Doc
 import Data.Text.Prettyprint.Doc.Render.Terminal
+import Effect.Exec
 import Effect.Logger
 import Network.HTTP.Types (urlEncode)
 import qualified Srclib.Converter as Srclib
@@ -59,6 +60,7 @@ import Text.URI (URI)
 import qualified Text.URI as URI
 import Types
 import qualified Data.Text.Encoding as TE
+import VCS.Git (fetchGitContributors)
 
 data ScanDestination
   = UploadScan URI ApiKey ProjectMetadata -- ^ upload to fossa with provided api key and base url
@@ -120,6 +122,26 @@ analyze basedir destination override unpackArchives = runFinally $ do
             ]
           traverse_ (\err -> logError $ "FOSSA error: " <> viaShow err) (uploadError resp)
 
+          contribResult <- Diag.runDiagnostics $ runExecIO $ tryUploadContributors (unBaseDir basedir) baseurl apiKey $ uploadLocator resp
+          case contribResult of
+            Left failure -> logDebug (Diag.renderFailureBundle failure)
+            Right _ -> pure ()
+
+tryUploadContributors ::
+  ( Has Diag.Diagnostics sig m,
+    Has Exec sig m,
+    MonadIO m
+  ) =>
+  Path x Dir ->
+  URI ->
+  ApiKey ->
+  -- | Locator
+  Text ->
+  m ()
+tryUploadContributors baseDir baseUrl apiKey locator = do
+  contributors <- fetchGitContributors baseDir
+  uploadContributors baseUrl apiKey locator contributors
+
 fossaProjectUrl :: URI -> Text -> Text -> Text
 fossaProjectUrl baseUrl rawLocator branch = URI.render baseUrl <> "projects/" <> encodedProject <> "/refs/branch/" <> branch <> "/" <> encodedRevision
   where

src/App/Fossa/FossaAPIV1.hs

@@ -1,9 +1,11 @@
 module App.Fossa.FossaAPIV1
   ( uploadAnalysis
+  , uploadContributors
   , UploadResponse(..)
   , ProjectMetadata(..)
   , FossaError(..)
   , FossaReq(..)
+  , Contributors(..)
   , fossaReq
 
   , getLatestBuild
@@ -27,6 +29,7 @@ import qualified App.Fossa.Report.Attribution as Attr
 import Control.Effect.Diagnostics
 import Data.Maybe (catMaybes, fromMaybe)
 import Data.List (isInfixOf, stripPrefix)
+import Data.Map (Map)
 import Data.Text (Text)
 import Data.Aeson
 import Prelude
@@ -395,3 +398,23 @@ instance FromJSON Organization where
 
 organizationEndpoint :: Url scheme -> Url scheme
 organizationEndpoint baseurl = baseurl /: "api" /: "cli" /: "organization"
+
+----------
+
+newtype Contributors = Contributors 
+  {unContributors :: Map Text Text}
+  deriving (Eq, Ord, Show, ToJSON)
+
+contributorsEndpoint :: Url scheme -> Url scheme
+contributorsEndpoint baseurl = baseurl /: "api" /: "organization"
+
+uploadContributors :: (Has Diagnostics sig m, MonadIO m) => URI -> ApiKey -> Text -> Contributors -> m ()
+uploadContributors baseUri apiKey locator contributors = fossaReq $ do
+  (baseUrl, baseOptions) <- parseUri baseUri
+
+  let opts = baseOptions
+        <> apiHeader apiKey
+        <> "locator" =: locator
+
+  _ <- req POST (contributorsEndpoint baseUrl) (ReqBodyJson contributors) ignoreResponse opts
+  pure ()

src/VCS/Git.hs

@@ -0,0 +1,59 @@
+module VCS.Git
+  ( gitLogCmd,
+    fetchGitContributors,
+  )
+where
+
+import App.Fossa.FossaAPIV1 (Contributors (..))
+import qualified Control.Carrier.Diagnostics as Diag
+import Data.ByteString.Lazy (toStrict)
+import qualified Data.Map as M
+import Data.Maybe (mapMaybe)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import Data.Time
+import Data.Time.Format.ISO8601 (iso8601Show)
+import Effect.Exec
+import Prologue
+
+gitLogCmd :: UTCTime -> Command
+gitLogCmd now =
+  Command
+    { cmdName = "git",
+      cmdArgs = ["log", "--since", sinceArg, "--date=short", "--format=%ae|%cd"],
+      cmdAllowErr = Never
+    }
+  where
+    sinceArg = iso8601Show $ utctDay wayBack
+    delta = nominalDay * (-90)
+    wayBack = addUTCTime delta now
+
+fetchGitContributors ::
+  ( Has Diag.Diagnostics sig m,
+    Has Exec sig m,
+    MonadIO m
+  ) =>
+  Path x Dir ->
+  m Contributors
+fetchGitContributors basedir = do
+  now <- liftIO getCurrentTime
+  rawContrib <- execThrow basedir $ gitLogCmd now
+  textContrib <- Diag.fromEitherShow . TE.decodeUtf8' $ toStrict rawContrib
+  pure . Contributors
+    . M.map (T.pack . iso8601Show)
+    . M.fromListWith max
+    . mapMaybe readLine
+    $ T.lines textContrib
+  where
+    readLine :: Text -> Maybe (Text, Day)
+    readLine entry = do
+      let (email, textDate) = splitOnceOn "|" entry
+      date <- parseTimeM True defaultTimeLocale "%Y-%-m-%-d" $ T.unpack textDate
+      Just (email, date)
+
+splitOnceOn :: Text -> Text -> (Text, Text)
+splitOnceOn needle haystack = (head, strippedTail)
+  where
+    len = T.length needle
+    (head, tail) = T.breakOn needle haystack
+    strippedTail = T.drop len tail