{-# 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 :: PlanOptions -> IO ()
runPlan PlanOptions
opts = do
  let storePath :: [Char]
storePath             = PlanOptions
opts PlanOptions -> Getting [Char] PlanOptions [Char] -> [Char]
forall s a. s -> Getting a s a -> a
^. forall k (sel :: k) s t a b. HasAny sel s t a b => Lens s t a b
forall s t a b. HasAny "storePath" s t a b => Lens s t a b
the @"storePath"
  let archiveUris :: [Location]
archiveUris           = [[Char] -> Location
Local [Char]
""]
  let storePathHash :: [Char]
storePathHash         = PlanOptions
opts PlanOptions
-> Getting (Maybe [Char]) PlanOptions (Maybe [Char])
-> Maybe [Char]
forall s a. s -> Getting a s a -> a
^. forall k (sel :: k) s t a b. HasAny sel s t a b => Lens s t a b
forall s t a b. HasAny "storePathHash" s t a b => Lens s t a b
the @"storePathHash" Maybe [Char] -> (Maybe [Char] -> [Char]) -> [Char]
forall a b. a -> (a -> b) -> b
& [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> [Char]
H.hashStorePath [Char]
storePath)
  let versionedArchiveUris :: [Location]
versionedArchiveUris  = [Location]
archiveUris [Location] -> ([Location] -> [Location]) -> [Location]
forall a b. a -> (a -> b) -> b
& (Location -> Identity Location)
-> [Location] -> Identity [Location]
forall s t a b. Each s t a b => Traversal s t a b
each ((Location -> Identity Location)
 -> [Location] -> Identity [Location])
-> (Location -> Location) -> [Location] -> [Location]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Location -> Text -> Location
forall a s. IsPath a s => a -> s -> a
</> Text
forall s. IsString s => s
archiveVersion)
  let outputFile :: [Char]
outputFile            = PlanOptions
opts PlanOptions -> Getting [Char] PlanOptions [Char] -> [Char]
forall s a. s -> Getting a s a -> a
^. forall k (sel :: k) s t a b. HasAny sel s t a b => Lens s t a b
forall s t a b. HasAny "outputFile" s t a b => Lens s t a b
the @"outputFile"

  Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
CIO.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Store path: "       Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
forall a. ToText a => a -> Text
toText [Char]
storePath
  Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
CIO.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Store path hash: "  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
storePathHash
  Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
CIO.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Archive URIs: "     Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Location] -> Text
forall a. Show a => a -> Text
tshow [Location]
archiveUris
  Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
CIO.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Archive version: "  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
forall s. IsString s => s
archiveVersion

  TVar Bool
tEarlyExit <- Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
STM.newTVarIO Bool
False

  Either AppError PlanJson
mbPlan <- [Char] -> IO (Either AppError PlanJson)
Z.loadPlan ([Char] -> IO (Either AppError PlanJson))
-> [Char] -> IO (Either AppError PlanJson)
forall a b. (a -> b) -> a -> b
$ PlanOptions
opts PlanOptions -> Getting [Char] PlanOptions [Char] -> [Char]
forall s a. s -> Getting a s a -> a
^. forall k (sel :: k) s t a b. HasAny sel s t a b => Lens s t a b
forall s t a b. HasAny "buildPath" s t a b => Lens s t a b
the @"buildPath"

  case Either AppError PlanJson
mbPlan of
    Right PlanJson
planJson -> do
      [PackageInfo]
packages <- [Char] -> PlanJson -> IO [PackageInfo]
Z.getPackages [Char]
storePath PlanJson
planJson

      [[Location]]
plan <- [PackageInfo] -> (PackageInfo -> IO [Location]) -> IO [[Location]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [PackageInfo]
packages ((PackageInfo -> IO [Location]) -> IO [[Location]])
-> (PackageInfo -> IO [Location]) -> IO [[Location]]
forall a b. (a -> b) -> a -> b
$ \PackageInfo
pInfo -> do
        let archiveFileBasename :: [Char]
archiveFileBasename = PackageInfo -> [Char]
Z.packageDir PackageInfo
pInfo [Char] -> [Char] -> [Char]
forall a s. IsPath a s => a -> s -> a
<.> [Char]
".tar.gz"
        let archiveFiles :: [Location]
archiveFiles         = [Location]
versionedArchiveUris [Location] -> (Location -> Location) -> [Location]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Location -> Text -> Location
forall a s. IsPath a s => a -> s -> a
</> [Char] -> Text
T.pack [Char]
archiveFileBasename)
        let scopedArchiveFiles :: [Location]
scopedArchiveFiles   = [Location]
versionedArchiveUris [Location] -> (Location -> Location) -> [Location]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Location -> Text -> Location
forall a s. IsPath a s => a -> s -> a
</> [Char] -> Text
T.pack [Char]
storePathHash Text -> Text -> Text
forall a s. IsPath a s => a -> s -> a
</> [Char] -> Text
T.pack [Char]
archiveFileBasename)

        [Location] -> IO [Location]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Location] -> IO [Location]) -> [Location] -> IO [Location]
forall a b. (a -> b) -> a -> b
$ [Location]
archiveFiles [Location] -> [Location] -> [Location]
forall a. Semigroup a => a -> a -> a
<> [Location]
scopedArchiveFiles

      if [Char]
outputFile [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"-"
        then ByteString -> IO ()
LBS.putStr (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [[Text]] -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode (([Location] -> [Text]) -> [[Location]] -> [[Text]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Location -> Text) -> [Location] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Location -> Text
forall a. ToText a => a -> Text
toText) [[Location]]
plan)
        else [Char] -> ByteString -> IO ()
LBS.writeFile [Char]
outputFile (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ [[Text]] -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode (([Location] -> [Text]) -> [[Location]] -> [[Text]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Location -> Text) -> [Location] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Location -> Text
forall a. ToText a => a -> Text
toText) [[Location]]
plan)

    Left (AppError
appError :: AppError) -> do
      Handle -> Text -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> Text -> m ()
CIO.hPutStrLn Handle
IO.stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"ERROR: Unable to parse plan.json file: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AppError -> Text
displayAppError AppError
appError

  Bool
earlyExit <- TVar Bool -> IO Bool
forall a. TVar a -> IO a
STM.readTVarIO TVar Bool
tEarlyExit

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
earlyExit (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
forall (m :: * -> *). MonadIO m => Handle -> Text -> m ()
CIO.hPutStrLn Handle
IO.stderr Text
"Early exit due to error"

optsPlan :: Parser PlanOptions
optsPlan :: Parser PlanOptions
optsPlan = [Char] -> [Char] -> Maybe [Char] -> [Char] -> PlanOptions
PlanOptions
  ([Char] -> [Char] -> Maybe [Char] -> [Char] -> PlanOptions)
-> Parser [Char]
-> Parser ([Char] -> Maybe [Char] -> [Char] -> PlanOptions)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod OptionFields [Char] -> Parser [Char]
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
      (   [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"build-path"
      Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. [Char] -> Mod f a
help ([Char]
"Path to cabal build directory.  Defaults to " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
AS.buildPath)
      Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"DIRECTORY"
      Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value [Char]
AS.buildPath
      )
  Parser ([Char] -> Maybe [Char] -> [Char] -> PlanOptions)
-> Parser [Char] -> Parser (Maybe [Char] -> [Char] -> PlanOptions)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod OptionFields [Char] -> Parser [Char]
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
      (   [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"store-path"
      Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Path to cabal store"
      Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"DIRECTORY"
      Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value ([Char]
AS.cabalDirectory [Char] -> [Char] -> [Char]
forall a s. IsPath a s => a -> s -> a
</> [Char]
"store")
      )
  Parser (Maybe [Char] -> [Char] -> PlanOptions)
-> Parser (Maybe [Char]) -> Parser ([Char] -> PlanOptions)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [Char] -> Parser (Maybe [Char])
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional
      ( Mod OptionFields [Char] -> Parser [Char]
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
        (   [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"store-path-hash"
        Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Store path hash (do not use)"
        Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"HASH"
        )
      )
  Parser ([Char] -> PlanOptions)
-> Parser [Char] -> Parser PlanOptions
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod OptionFields [Char] -> Parser [Char]
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
      (   [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasName f => [Char] -> Mod f a
long [Char]
"output-file"
      Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. [Char] -> Mod f a
help [Char]
"Output file"
      Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasMetavar f => [Char] -> Mod f a
metavar [Char]
"FILE"
      Mod OptionFields [Char]
-> Mod OptionFields [Char] -> Mod OptionFields [Char]
forall a. Semigroup a => a -> a -> a
<>  [Char] -> Mod OptionFields [Char]
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value [Char]
"-"
      )

cmdPlan :: Mod CommandFields (IO ())
cmdPlan :: Mod CommandFields (IO ())
cmdPlan = [Char] -> ParserInfo (IO ()) -> Mod CommandFields (IO ())
forall a. [Char] -> ParserInfo a -> Mod CommandFields a
command [Char]
"plan"  (ParserInfo (IO ()) -> Mod CommandFields (IO ()))
-> ParserInfo (IO ()) -> Mod CommandFields (IO ())
forall a b. (a -> b) -> a -> b
$ (Parser (IO ()) -> InfoMod (IO ()) -> ParserInfo (IO ()))
-> InfoMod (IO ()) -> Parser (IO ()) -> ParserInfo (IO ())
forall a b c. (a -> b -> c) -> b -> a -> c
flip Parser (IO ()) -> InfoMod (IO ()) -> ParserInfo (IO ())
forall a. Parser a -> InfoMod a -> ParserInfo a
info InfoMod (IO ())
forall m. Monoid m => m
idm (Parser (IO ()) -> ParserInfo (IO ()))
-> Parser (IO ()) -> ParserInfo (IO ())
forall a b. (a -> b) -> a -> b
$ PlanOptions -> IO ()
runPlan (PlanOptions -> IO ()) -> Parser PlanOptions -> Parser (IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser PlanOptions
optsPlan