Move out the Curator to its own repo (#586)

f-f · web-flow · commit 8c87389f88b9 · 2020-03-04T01:15:13.000Z
diff --git a/Makefile b/Makefile
diff --git a/app/Curator.hs b/app/Curator.hs
diff --git a/app/Spago.hs b/app/Spago.hs
@@ -19,6 +19,7 @@ import qualified Spago.Build
 import qualified Spago.Config        as Config
 import           Spago.Dhall         (TemplateComments (..))
 import           Spago.DryRun        (DryRun (..))
+import           Spago.Env
 import qualified Spago.GitHub
 import           Spago.GlobalCache   (CacheFlag (..), getGlobalCacheDir)
 import           Spago.Messages      as Messages
diff --git a/package.yaml b/package.yaml
@@ -124,36 +124,6 @@ executables:
     - text < 1.3
     - turtle
 
-  spago-curator:
-    main:                Curator.hs
-    source-dirs:         app
-    other-modules:       []
-    ghc-options:
-    - -main-is Curator
-    - -threaded
-    - -rtsopts
-    - -with-rtsopts=-N
-    dependencies:
-    - aeson-pretty
-    - async-pool
-    - base >= 4.7 && < 5
-    - bytestring
-    - containers
-    - dhall
-    - filepath
-    - github
-    - lens-family-core
-    - megaparsec
-    - process
-    - retry
-    - spago
-    - stm
-    - temporary
-    - text < 1.3
-    - time
-    - turtle
-    - vector
-
 tests:
   spec:
     defaults: hspec/hspec@master
diff --git a/src/Spago/Bower.hs b/src/Spago/Bower.hs
@@ -143,4 +143,4 @@ mkDependencies config = do
       -- Windows sucks so lets make it slow for them!
       -- (just kidding, its a bug: https://github.com/bower/spec/issues/79)
       Windows -> pure 1
-      _       -> askEnv envJobs
+      _       -> view jobsL
diff --git a/src/Spago/Build.hs b/src/Spago/Build.hs
@@ -189,7 +189,7 @@ repl cacheFlag newPackages sourcePaths pursArgs depsOnly = do
       Purs.repl globs pursArgs
     Left (err :: SomeException) -> do
       logDebug $ display err
-      cacheDir <- askEnv envGlobalCache
+      cacheDir <- view globalCacheL
       Temp.withTempDirectory cacheDir "spago-repl-tmp" $ \dir -> do
         Turtle.cd (Turtle.decodeString dir)
 
@@ -385,7 +385,7 @@ getOutputPath
   :: BuildOptions
   -> Spago (Maybe Sys.FilePath)
 getOutputPath buildOpts = do
-  configPath <- askEnv envConfigPath
+  configPath <- view configPathL
   outputPath <- PackageSet.findRootOutputPath (Text.unpack configPath)
   case findOutputFlag (pursArgs buildOpts) of
     Just path -> pure (Just path)
diff --git a/src/Spago/Config.hs b/src/Spago/Config.hs
@@ -127,7 +127,7 @@ parseConfig = do
   -- Here we try to migrate any config that is not in the latest format
   withConfigAST $ pure . addSourcePaths
 
-  path <- askEnv envConfigPath
+  path <- view configPathL
   expr <- liftIO $ Dhall.inputExpr $ "./" <> path
   case expr of
     Dhall.RecordLit ks -> do
@@ -156,7 +156,7 @@ parseConfig = do
 -- | Checks that the Spago config is there and readable
 ensureConfig :: Spago (Either Utf8Builder Config)
 ensureConfig = do
-  path <- askEnv envConfigPath
+  path <- view configPathL
   exists <- testfile path
   if not exists
     then pure $ Left $ display Messages.cannotFindConfig
@@ -179,7 +179,7 @@ ensureConfigUnsafe = ensureConfig >>= \case
 --   Eventually ports an existing `psc-package.json` to the new config.
 makeConfig :: Bool -> Dhall.TemplateComments -> Spago ()
 makeConfig force comments = do
-  path <- askEnv envConfigPath
+  path <- view configPathL
   unless force $ do
     hasSpagoDhall <- testfile path
     when hasSpagoDhall $ die [ display $ Messages.foundExistingProject path ]
@@ -361,7 +361,7 @@ filterDependencies expr = expr
 --   still be in the tree). If you need the resolved one, use `ensureConfig`.
 withConfigAST :: (Expr -> Spago Expr) -> Spago Bool
 withConfigAST transform = do
-  path <- askEnv envConfigPath
+  path <- view configPathL
   rawConfig <- liftIO $ Dhall.readRawExpr path
   case rawConfig of
     Nothing -> die [ display $ Messages.cannotFindConfig ]
diff --git a/src/Spago/Env.hs b/src/Spago/Env.hs
@@ -0,0 +1,67 @@
+module Spago.Env
+  ( Env(..)
+  , HasEnv(..)
+  , HasGlobalCache(..)
+  , HasConfigPath(..)
+  , HasJobs(..)
+  , HasPsa(..)
+  , UsePsa(..)
+  ) where
+
+import RIO
+
+import qualified GHC.IO
+
+
+-- | Flag to disable the automatic use of `psa`
+data UsePsa = UsePsa | NoPsa
+
+-- | App configuration containing parameters and other common
+--   things it's useful to compute only once at startup.
+data Env = Env
+  { envUsePsa      :: UsePsa
+  , envJobs        :: Int
+  , envConfigPath  :: Text
+  , envGlobalCache :: GHC.IO.FilePath
+  , envLogFunc     :: !LogFunc
+  }
+
+
+class HasGlobalCache env where 
+  globalCacheL :: Lens' env GHC.IO.FilePath 
+
+class HasConfigPath env where 
+  configPathL :: Lens' env Text
+
+class HasJobs env where 
+  jobsL :: Lens' env Int
+
+class HasPsa env where
+  usePsaL :: Lens' env UsePsa
+
+class 
+  ( HasGlobalCache env
+  , HasLogFunc env
+  , HasConfigPath env
+  , HasJobs env
+  , HasPsa env
+  ) => HasEnv env where
+  envL :: Lens' env Env
+
+instance HasLogFunc Env where
+  logFuncL = lens envLogFunc (\x y -> x { envLogFunc = y })
+
+instance HasGlobalCache Env where
+  globalCacheL = lens envGlobalCache (\x y -> x { envGlobalCache = y })
+
+instance HasConfigPath Env where
+  configPathL = lens envConfigPath (\x y -> x { envConfigPath = y })
+
+instance HasJobs Env where
+  jobsL = lens envJobs (\x y -> x { envJobs = y })
+
+instance HasPsa Env where
+  usePsaL = lens envUsePsa (\x y -> x { envUsePsa = y })
+
+instance HasEnv Env where
+  envL = id
diff --git a/src/Spago/FetchPackage.hs b/src/Spago/FetchPackage.hs
@@ -46,7 +46,7 @@ fetchPackages globalCacheFlag allDeps minPursVersion = do
   PackageSet.checkPursIsUpToDate minPursVersion
 
   -- Ensure both local and global cache dirs are there
-  globalCache <- askEnv envGlobalCache
+  globalCache <- view globalCacheL
   assertDirectory globalCache
   assertDirectory localCacheDir
 
@@ -63,7 +63,7 @@ fetchPackages globalCacheFlag allDeps minPursVersion = do
     logInfo $ "Installing " <> display nOfDeps <> " dependencies."
     metadata <- GlobalCache.getMetadata globalCacheFlag
 
-    limit <- askEnv envJobs
+    limit <- view jobsL
     withTaskGroup' limit $ \taskGroup -> do
       asyncs <- for depsToFetch (async' taskGroup . fetchPackage metadata)
       handle (handler asyncs) (for_ asyncs wait')
@@ -98,7 +98,7 @@ fetchPackage _ (PackageName package, Package { location = Local{..}, .. }) =
   logInfo $ display $ Messages.foundLocalPackage package localPath
 fetchPackage metadata pair@(packageName'@PackageName{..}, Package{ location = Remote{..}, .. } ) = do
   logDebug $ "Fetching package " <> display packageName
-  globalCache <- askEnv envGlobalCache
+  globalCache <- view globalCacheL
   let packageDir = getPackageDir packageName' version
       packageGlobalCacheDir = globalCache </> packageDir
 
diff --git a/src/Spago/GitHub.hs b/src/Spago/GitHub.hs
@@ -21,10 +21,10 @@ tagCacheFile = "package-sets-tag.txt"
 tokenCacheFile = "github-token.txt"
 
 
-login :: Spago ()
+login :: HasEnv env => RIO env ()
 login = do
  maybeToken <- liftIO (System.Environment.lookupEnv githubTokenEnvVar)
- globalCacheDir <- askEnv envGlobalCache
+ globalCacheDir <- view globalCacheL
 
  case maybeToken of
    Nothing -> die [ display Messages.getNewGitHubToken ]
@@ -58,10 +58,10 @@ readToken = readFromEnv <|> readFromFile
 
 getLatestPackageSetsTag :: Spago (Either SomeException Text)
 getLatestPackageSetsTag = do
-  globalCacheDir <- askEnv envGlobalCache
+  globalCacheDir <- view globalCacheL
   assertDirectory globalCacheDir
   let globalPathToCachedTag = globalCacheDir </> tagCacheFile
-  let writeTagCache releaseTagName = writeTextFile (Text.pack globalPathToCachedTag) releaseTagName
+  let writeTagCache = writeTextFile (Text.pack globalPathToCachedTag)
   let readTagCache = try $ readTextFile $ pathFromText $ Text.pack globalPathToCachedTag
   let downloadTagToCache env = try
         $ Retry.recoverAll (Retry.fullJitterBackoff 50000 <> Retry.limitRetries 5)
diff --git a/src/Spago/GlobalCache.hs b/src/Spago/GlobalCache.hs
@@ -18,10 +18,10 @@ import Spago.Types
 
 
 newtype CommitHash = CommitHash Text
-  deriving (Eq, Show, Generic, ToJSON, FromJSON)
+  deriving (Ord, Eq, Show, Read, Generic, Data, ToJSON, FromJSON)
 
 newtype Tag = Tag Text
-  deriving (Ord, Eq, Show, Generic, ToJSONKey, FromJSONKey, FromJSON, ToJSON)
+  deriving (Ord, Eq, Show, Read, Generic, Data, ToJSONKey, FromJSONKey, FromJSON, ToJSON)
 
 data RepoMetadataV1 = RepoMetadataV1
   { commits :: [CommitHash]
diff --git a/src/Spago/Prelude.hs b/src/Spago/Prelude.hs
@@ -4,7 +4,12 @@ module Spago.Prelude
   , hush
   , pathFromText
   , assertDirectory
-  , Env (..)
+  , Env
+  , HasEnv(..)
+  , HasGlobalCache(..)
+  , HasConfigPath(..)
+  , HasJobs(..)
+  , HasPsa(..)
   , UsePsa(..)
   , Spago
   , module X
@@ -61,7 +66,6 @@ module Spago.Prelude
   , pretty
   , output
   , outputStr
-  , askEnv
   ) where
 
 
@@ -72,7 +76,6 @@ import qualified Data.Text.Prettyprint.Doc.Render.Text as PrettyText
 import qualified Data.Time                             as Time
 import           Dhall                                 (Text)
 import qualified Dhall.Core
-import qualified GHC.IO
 import qualified System.FilePath                       as FilePath
 import qualified System.IO
 import qualified Turtle
@@ -105,6 +108,8 @@ import           Turtle                                (ExitCode (..), FilePath,
 import           UnliftIO.Directory                    (getModificationTime, makeAbsolute)
 import           UnliftIO.Process                      (callCommand)
 
+import           Spago.Env
+
 
 -- | Generic Error that we throw on program exit.
 --   We have it so that errors are displayed nicely to the user
@@ -114,31 +119,8 @@ instance Show SpagoError where
   show (SpagoError err) = Text.unpack err
 
 
--- | Flag to disable the automatic use of `psa`
-data UsePsa = UsePsa | NoPsa
-
--- | App configuration containing parameters and other common
---   things it's useful to compute only once at startup.
-data Env = Env
-  { envUsePsa      :: UsePsa
-  , envJobs        :: Int
-  , envConfigPath  :: Text
-  , envGlobalCache :: GHC.IO.FilePath
-  , envLogFunc     :: !LogFunc
-  }
-
-instance HasLogFunc Env where
-  logFuncL = lens envLogFunc (\x y -> x { envLogFunc = y })
-
-
 type Spago = RIO Env
 
-
--- | Facility to easily get global parameters from the environment
-askEnv :: (Env -> a) -> Spago a
-askEnv = view . to
-
-
 output :: MonadIO m => Text -> m ()
 output = Turtle.printf (Turtle.s Turtle.% "\n")
 
diff --git a/src/Spago/Purs.hs b/src/Spago/Purs.hs
@@ -37,7 +37,7 @@ data WithSrcMap = WithSrcMap | WithoutSrcMap
 compile :: [SourcePath] -> [ExtraArg] -> Spago ()
 compile sourcePaths extraArgs = do
   -- first we decide if we _want_ to use psa, then if we _can_
-  usePsa <- askEnv envUsePsa
+  usePsa <- view usePsaL
   purs <- case usePsa of
     NoPsa -> pure "purs"
     UsePsa -> psaVersion >>= \case
diff --git a/src/Spago/Types.hs b/src/Spago/Types.hs
@@ -11,7 +11,7 @@ import qualified Spago.Messages as Messages
 
 
 newtype PackageName = PackageName { packageName :: Text }
-  deriving (Show)
+  deriving (Show, Read, Data)
   deriving newtype (Eq, Ord, ToJSON, FromJSON, ToJSONKey, FromJSONKey, Dhall.FromDhall)
 
 -- | A package-set package.
