Fix revision read (#182)

* Add new functions

Signed-off-by: Wesley Van Melle <[email protected]>

* read from cached revision

Signed-off-by: Wesley Van Melle <[email protected]>

src/App/Fossa/ProjectInference.hs

@@ -1,10 +1,12 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module App.Fossa.ProjectInference
   ( inferProject,
     mergeOverride,
+    readCachedRevision,
     InferredProject (..),
   )
 where
@@ -33,6 +35,9 @@ import qualified System.FilePath.Posix as FP
 import Text.GitConfig.Parser (Section (..), parseConfig)
 import Text.Megaparsec (errorBundlePretty)
 
+revisionFileName :: Path Rel File
+revisionFileName = $(mkRelFile ".fossa.revision")
+
 mergeOverride :: OverrideProject -> InferredProject -> ProjectRevision
 mergeOverride OverrideProject {..} InferredProject {..} = ProjectRevision name revision branch
   where
@@ -94,6 +99,12 @@ inferSVN dir = do
           [key, val] -> Just (key, val)
           _ -> Nothing
 
+readCachedRevision :: (Has (Lift IO) sig m, Has ReadFS sig m, Has Diagnostics sig m) => m Text
+readCachedRevision = do
+  tmp <- sendIO getTempDir
+  readContentsText $ tmp </> revisionFileName
+
+
 -- | Infer a default project name from the directory, and a default
 -- revision from the current time. Writes `.fossa.revision` to the system
 -- temp directory for use by `fossa test`
@@ -103,7 +114,7 @@ inferDefault dir = sendIO $ do
   time <- floor <$> getPOSIXTime :: IO Int
 
   tmp <- getTempDir
-  writeFile (fromAbsDir tmp FP.</> ".fossa.revision") (show time)
+  writeFile (fromAbsFile $ tmp </> revisionFileName) (show time)
 
   pure (InferredProject (T.pack name) (T.pack (show time)) Nothing)
 

src/App/Fossa/Report.hs

@@ -17,6 +17,7 @@ import Data.Text (Text)
 import Data.Text.IO (hPutStrLn)
 import Data.Text.Lazy.Encoding (decodeUtf8)
 import Effect.Logger
+import Effect.ReadFS
 import Fossa.API.Types (ApiOpts)
 import System.Exit (exitFailure, exitSuccess)
 import System.IO (stderr)
@@ -50,8 +51,9 @@ reportMain basedir apiOpts logSeverity timeoutSeconds reportType override = do
   * CLI command refactoring as laid out in https://github.com/fossas/issues/issues/129
   -}
   void $ timeout timeoutSeconds $ withLogger logSeverity $ do
-    result <- runDiagnostics $ do
-      revision <- mergeOverride override <$> inferProject (unBaseDir basedir)
+    result <- runDiagnostics . runReadFSIO $ do
+      override' <- updateOverrideRevision override <$> readCachedRevision
+      revision <- mergeOverride override' <$> inferProject (unBaseDir basedir)
 
       logInfo ""
       logInfo ("Using project name: `" <> pretty (projectName revision) <> "`")

src/App/Fossa/Test.hs

@@ -13,6 +13,7 @@ import Data.Functor (void)
 import Data.Text.IO (hPutStrLn)
 import Data.Text.Lazy.Encoding (decodeUtf8)
 import Effect.Logger
+import Effect.ReadFS
 import Fossa.API.Types (ApiOpts, Issues(..))
 import System.Exit (exitFailure, exitSuccess)
 import System.IO (stderr)
@@ -31,8 +32,9 @@ testMain
   -> IO ()
 testMain basedir apiOpts logSeverity timeoutSeconds outputType override = do
   void $ timeout timeoutSeconds $ withLogger logSeverity $ do
-    result <- runDiagnostics $ do
-      revision <- mergeOverride override <$> inferProject (unBaseDir basedir)
+    result <- runDiagnostics . runReadFSIO $ do
+      override' <- updateOverrideRevision override <$> readCachedRevision
+      revision <- mergeOverride override' <$> inferProject (unBaseDir basedir)
 
       logInfo ""
       logInfo ("Using project name: `" <> pretty (projectName revision) <> "`")

src/App/Fossa/VPS/Report.hs

@@ -17,6 +17,7 @@ import Data.Text (Text)
 import Data.Text.IO (hPutStrLn)
 import Data.Text.Lazy.Encoding (decodeUtf8)
 import Effect.Logger
+import Effect.ReadFS
 import Fossa.API.Types (ApiOpts)
 import System.Exit (exitFailure, exitSuccess)
 import System.IO (stderr)
@@ -52,8 +53,9 @@ reportMain basedir apiOpts logSeverity timeoutSeconds reportType override = do
   * CLI command refactoring as laid out in https://github.com/fossas/issues/issues/129
   -}
   void $ timeout timeoutSeconds $ withLogger logSeverity $ do
-    result <- runDiagnostics $ do
-      revision <- mergeOverride override <$> inferProject (unBaseDir basedir)
+    result <- runDiagnostics . runReadFSIO $ do
+      override' <- updateOverrideRevision override <$> readCachedRevision 
+      revision <- mergeOverride override' <$> inferProject (unBaseDir basedir)
 
       logSticky "[ Getting latest scan ID ]"
 

src/App/Fossa/VPS/Test.hs

@@ -17,6 +17,7 @@ import Data.Text.IO (hPutStrLn)
 import Data.Text.Lazy.Encoding (decodeUtf8)
 import Effect.Exec
 import Effect.Logger
+import Effect.ReadFS
 import Fossa.API.Types (ApiOpts, Issues (..))
 import System.Exit (exitFailure, exitSuccess)
 import System.IO (stderr)
@@ -38,8 +39,9 @@ testMain ::
   IO ()
 testMain basedir apiOpts logSeverity timeoutSeconds outputType override = do
   _ <- timeout timeoutSeconds . withLogger logSeverity . runExecIO $ do
-    result <- runDiagnostics $ do
-      revision <- mergeOverride override <$> inferProject (unBaseDir basedir)
+    result <- runDiagnostics . runReadFSIO $ do
+      override' <- updateOverrideRevision override <$> readCachedRevision 
+      revision <- mergeOverride override' <$> inferProject (unBaseDir basedir)
 
       logInfo ""
       logInfo ("Using project name: `" <> pretty (projectName revision) <> "`")

src/App/Types.hs

@@ -4,6 +4,8 @@ module App.Types
     OverrideProject (..),
     ProjectMetadata (..),
     ProjectRevision (..),
+
+    updateOverrideRevision,
   )
 where
 
@@ -18,6 +20,9 @@ data OverrideProject = OverrideProject
     overrideBranch :: Maybe Text
   }
 
+updateOverrideRevision :: OverrideProject -> Text -> OverrideProject
+updateOverrideRevision o r = o { overrideRevision = Just r }
+
 data ProjectMetadata = ProjectMetadata
   { projectTitle :: Maybe Text
   , projectUrl :: Maybe Text