Merge pull request #156 from haskell-works/new-plan-command

New plan command

cabal-cache.cabal

@@ -106,6 +106,7 @@ library
       App.Commands
       App.Commands.Options.Parser
       App.Commands.Options.Types
+      App.Commands.Plan
       App.Commands.SyncFromArchive
       App.Commands.SyncToArchive
       App.Commands.Version

src/App/Commands.hs

@@ -1,6 +1,7 @@
 module App.Commands where
 
 import App.Commands.SyncFromArchive
+import App.Commands.Plan
 import App.Commands.SyncToArchive
 import App.Commands.Version
 import Options.Applicative
@@ -13,6 +14,7 @@ commands = commandsGeneral
 commandsGeneral :: Parser (IO ())
 commandsGeneral = subparser $ mempty
   <>  commandGroup "Commands:"
+  <>  cmdPlan
   <>  cmdSyncFromArchive
   <>  cmdSyncToArchive
   <>  cmdVersion

src/App/Commands/Options/Types.hs

@@ -19,6 +19,13 @@ data SyncToArchiveOptions = SyncToArchiveOptions
   , awsLogLevel   :: Maybe AWS.LogLevel
   } deriving (Eq, Show, Generic)
 
+data PlanOptions = PlanOptions
+  { buildPath     :: FilePath
+  , storePath     :: FilePath
+  , storePathHash :: Maybe String
+  , outputFile    :: FilePath
+  } deriving (Eq, Show, Generic)
+
 data SyncFromArchiveOptions = SyncFromArchiveOptions
   { region        :: Region
   , archiveUris   :: [Location]

src/App/Commands/Plan.hs

@@ -0,0 +1,107 @@
+{-# LANGUAGE BlockArguments      #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+
+module App.Commands.Plan
+  ( cmdPlan
+  ) where
+
+import Antiope.Core                     (toText)
+import App.Commands.Options.Types       (PlanOptions (PlanOptions))
+import Control.Applicative
+import Control.Lens                     hiding ((<.>))
+import Control.Monad.Except
+import Data.Generics.Product.Any        (the)
+import Data.Maybe
+import HaskellWorks.CabalCache.AppError
+import HaskellWorks.CabalCache.Location (Location (..), (<.>), (</>))
+import HaskellWorks.CabalCache.Show
+import HaskellWorks.CabalCache.Version  (archiveVersion)
+import Options.Applicative              hiding (columns)
+
+import qualified App.Commands.Options.Types         as Z
+import qualified App.Static                         as AS
+import qualified Control.Concurrent.STM             as STM
+import qualified Data.ByteString.Lazy               as LBS
+import qualified Data.Text                          as T
+import qualified HaskellWorks.CabalCache.Core       as Z
+import qualified HaskellWorks.CabalCache.Hash       as H
+import qualified HaskellWorks.CabalCache.IO.Console as CIO
+import qualified System.IO                          as IO
+import qualified Data.Aeson as J
+
+{- HLINT ignore "Monoid law, left identity" -}
+{- HLINT ignore "Redundant do"              -}
+{- HLINT ignore "Reduce duplication"        -}
+
+runPlan :: Z.PlanOptions -> IO ()
+runPlan opts = do
+  let storePath             = opts ^. the @"storePath"
+  let archiveUris           = [Local ""]
+  let storePathHash         = opts ^. the @"storePathHash" & fromMaybe (H.hashStorePath storePath)
+  let versionedArchiveUris  = archiveUris & each %~ (</> archiveVersion)
+  let outputFile            = opts ^. the @"outputFile"
+
+  CIO.putStrLn $ "Store path: "       <> toText storePath
+  CIO.putStrLn $ "Store path hash: "  <> T.pack storePathHash
+  CIO.putStrLn $ "Archive URIs: "     <> tshow archiveUris
+  CIO.putStrLn $ "Archive version: "  <> archiveVersion
+
+  tEarlyExit <- STM.newTVarIO False
+
+  mbPlan <- Z.loadPlan $ opts ^. the @"buildPath"
+
+  case mbPlan of
+    Right planJson -> do
+      packages <- Z.getPackages storePath planJson
+
+      plan <- forM packages $ \pInfo -> do
+        let archiveFileBasename = Z.packageDir pInfo <.> ".tar.gz"
+        let archiveFiles         = versionedArchiveUris <&> (</> T.pack archiveFileBasename)
+        let scopedArchiveFiles   = versionedArchiveUris <&> (</> T.pack storePathHash </> T.pack archiveFileBasename)
+
+        return $ archiveFiles <> scopedArchiveFiles
+
+      if outputFile == "-"
+        then LBS.putStr $ J.encode (fmap (fmap toText) plan)
+        else LBS.writeFile outputFile $ J.encode (fmap (fmap toText) plan)
+
+    Left (appError :: AppError) -> do
+      CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> displayAppError appError
+
+  earlyExit <- STM.readTVarIO tEarlyExit
+
+  when earlyExit $ CIO.hPutStrLn IO.stderr "Early exit due to error"
+
+optsPlan :: Parser PlanOptions
+optsPlan = PlanOptions
+  <$> strOption
+      (   long "build-path"
+      <>  help ("Path to cabal build directory.  Defaults to " <> show AS.buildPath)
+      <>  metavar "DIRECTORY"
+      <>  value AS.buildPath
+      )
+  <*> strOption
+      (   long "store-path"
+      <>  help "Path to cabal store"
+      <>  metavar "DIRECTORY"
+      <>  value (AS.cabalDirectory </> "store")
+      )
+  <*> optional
+      ( strOption
+        (   long "store-path-hash"
+        <>  help "Store path hash (do not use)"
+        <>  metavar "HASH"
+        )
+      )
+  <*> strOption
+      (   long "output-file"
+      <>  help "Output file"
+      <>  metavar "FILE"
+      <>  value "-"
+      )
+
+cmdPlan :: Mod CommandFields (IO ())
+cmdPlan = command "plan"  $ flip info idm $ runPlan <$> optsPlan

src/App/Commands/SyncFromArchive.hs

@@ -132,8 +132,9 @@ runSyncFromArchive opts = do
                 let archiveFiles        = versionedArchiveUris & each %~ (</> T.pack archiveBaseName)
                 let scopedArchiveFiles  = scopedArchiveUris & each %~ (</> T.pack archiveBaseName)
                 let packageStorePath    = storePath </> Z.packageDir pInfo
+                let maybePackage        = M.lookup packageId planPackages
+
                 storeDirectoryExists <- doesDirectoryExist packageStorePath
-                let maybePackage = M.lookup packageId planPackages
 
                 case maybePackage of
                   Nothing -> do