Merge pull request commercialhaskell#3730 from commercialhaskell/use-…

…typed-process

Kick off the rio subpackage

.travis.yml

@@ -121,9 +121,15 @@ script:
        hlint test/ --cpp-simple
        ;;
      stack)
+       echo Build stack package first, so that it generates output to stdout.
+       echo Otherwise Travis thinks we stalled.
+       stack --no-terminal test --haddock --no-haddock-deps --ghc-options="$GHC_OPTIONS" stack
+
+       echo Build the other, smaller subpackages.
        stack --no-terminal test --haddock --no-haddock-deps --ghc-options="$GHC_OPTIONS"
        ;;
      pedantic)
+       stack --system-ghc --no-terminal build --pedantic stack
        stack --system-ghc --no-terminal build --pedantic
        ;;
      cabal)

package.yaml

@@ -46,7 +46,7 @@ dependencies:
 - bytestring
 - clock
 - conduit
-- conduit-extra
+- conduit-extra >= 1.2.3.1
 - containers
 - cryptonite
 - cryptonite-conduit
@@ -55,7 +55,6 @@ dependencies:
 - echo
 - exceptions
 - extra
-- fast-logger
 - file-embed
 - filelock
 - filepath
@@ -74,7 +73,7 @@ dependencies:
 - microlens
 - microlens-mtl
 - mintty
-- monad-logger
+- monad-logger # TODO remove dep when persistent drops monad-logger
 - mono-traversable
 - mtl
 - neat-interpolation
@@ -108,6 +107,7 @@ dependencies:
 - time
 - tls
 - transformers
+- typed-process >= 0.2.1.0
 - unicode-transforms
 - unix-compat
 - unliftio
@@ -130,7 +130,9 @@ when:
     - pid1
     - unix
 library:
-  source-dirs: src/
+  source-dirs:
+  - src/
+  - subs/rio/src/
   ghc-options:
   - -fwarn-identities
   exposed-modules:
@@ -151,6 +153,9 @@ library:
   - Path.Extra
   - Path.Find
   - Paths_stack
+  - RIO
+  - RIO.Logger
+  - RIO.Process
   - Stack.Build
   - Stack.Build.Cache
   - Stack.Build.ConstructPlan
@@ -173,7 +178,6 @@ library:
   - Stack.Docker
   - Stack.Docker.GlobalDB
   - Stack.Dot
-  - Stack.Exec
   - Stack.Fetch
   - Stack.FileWatch
   - Stack.GhcPkg
@@ -241,6 +245,7 @@ library:
   - Stack.Types.FlagName
   - Stack.Types.GhcPkgId
   - Stack.Types.Image
+  - Stack.Types.NamedComponent
   - Stack.Types.Nix
   - Stack.Types.Package
   - Stack.Types.PackageDump
@@ -256,13 +261,11 @@ library:
   - Stack.Upgrade
   - Stack.Upload
   - Text.PrettyPrint.Leijen.Extended
-  - System.Process.Log
   - System.Process.PagerEditor
-  - System.Process.Read
-  - System.Process.Run
   - System.Terminal
   other-modules:
   - Hackage.Security.Client.Repository.HttpLib.HttpClient
+  - RIO.Prelude
   when:
   - condition: 'os(windows)'
     then:

src/Data/Aeson/Extended.hs

@@ -100,7 +100,7 @@ unWarningParser wp = do
 
 -- | Log JSON warnings.
 logJSONWarnings
-    :: MonadLogger m
+    :: (MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m)
     => FilePath -> [JSONWarning] -> m ()
 logJSONWarnings fp =
     mapM_ (\w -> logWarn ("Warning: " <> T.pack fp <> ": " <> T.pack (show w)))

src/Data/Store/VersionTagged.hs

@@ -37,7 +37,7 @@ versionedDecodeFile :: Data a => VersionConfig a -> Q Exp
 versionedDecodeFile vc = [e| versionedDecodeFileImpl $(decodeWithVersionQ vc) |]
 
 -- | Write to the given file.
-storeEncodeFile :: (Store a, MonadIO m, MonadLogger m, Eq a)
+storeEncodeFile :: (Store a, MonadIO m, MonadReader env m, HasCallStack, HasLogFunc env, Eq a)
                 => (a -> (Int, Poke ()))
                 -> Peek a
                 -> Path Abs File
@@ -55,7 +55,7 @@ storeEncodeFile pokeFunc peekFunc fp x = do
 -- | Read from the given file. If the read fails, run the given action and
 -- write that back to the file. Always starts the file off with the
 -- version tag.
-versionedDecodeOrLoadImpl :: (Store a, Eq a, MonadUnliftIO m, MonadLogger m)
+versionedDecodeOrLoadImpl :: (Store a, Eq a, MonadUnliftIO m, MonadReader env m, HasCallStack, HasLogFunc env)
                           => (a -> (Int, Poke ()))
                           -> Peek a
                           -> Path Abs File
@@ -75,7 +75,7 @@ versionedDecodeOrLoadImpl pokeFunc peekFunc fp mx = do
             storeEncodeFile pokeFunc peekFunc fp x
             return x
 
-versionedDecodeFileImpl :: (Store a, MonadUnliftIO m, MonadLogger m)
+versionedDecodeFileImpl :: (Store a, MonadUnliftIO m, MonadReader env m, HasCallStack, HasLogFunc env)
                         => Peek a
                         -> Path loc File
                         -> m (Maybe a)

src/Network/HTTP/Download.hs

@@ -47,10 +47,10 @@ import           System.FilePath             (takeDirectory, (<.>))
 -- appropriate destination.
 --
 -- Throws an exception if things go wrong
-download :: (MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m)
+download :: HasRunner env
          => Request
          -> Path Abs File -- ^ destination
-         -> m Bool -- ^ Was a downloaded performed (True) or did the file already exist (False)?
+         -> RIO env Bool -- ^ Was a downloaded performed (True) or did the file already exist (False)?
 download req destpath = do
     let downloadReq = DownloadRequest
             { drRequest = req
@@ -64,10 +64,10 @@ download req destpath = do
 -- | Same as 'download', but will download a file a second time if it is already present.
 --
 -- Returns 'True' if the file was downloaded, 'False' otherwise
-redownload :: (MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m)
+redownload :: HasRunner env
            => Request
            -> Path Abs File -- ^ destination
-           -> m Bool
+           -> RIO env Bool
 redownload req0 dest = do
     logDebug $ "Downloading " <> decodeUtf8With lenientDecode (path req0)
     let destFilePath = toFilePath dest

src/Network/HTTP/Download/Verified.hs

@@ -143,7 +143,7 @@ displayCheckHexDigest (CheckHexDigestHeader h) =
 sinkCheckHash :: MonadThrow m
     => Request
     -> HashCheck
-    -> Consumer ByteString m ()
+    -> ConduitM ByteString o m ()
 sinkCheckHash req HashCheck{..} = do
     digest <- sinkHashUsing hashCheckAlgorithm
     let actualDigestString = show digest
@@ -173,32 +173,31 @@ assertLengthSink req expectedStreamLength = ZipSink $ do
     throwM $ WrongStreamLength req expectedStreamLength actualStreamLength
 
 -- | A more explicitly type-guided sinkHash.
-sinkHashUsing :: (Monad m, HashAlgorithm a) => a -> Consumer ByteString m (Digest a)
+sinkHashUsing :: (Monad m, HashAlgorithm a) => a -> ConduitM ByteString o m (Digest a)
 sinkHashUsing _ = sinkHash
 
 -- | Turns a list of hash checks into a ZipSink that checks all of them.
 hashChecksToZipSink :: MonadThrow m => Request -> [HashCheck] -> ZipSink ByteString m ()
 hashChecksToZipSink req = traverse_ (ZipSink . sinkCheckHash req)
 
 -- 'Control.Retry.recovering' customized for HTTP failures
-recoveringHttp :: (MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m)
-               => RetryPolicy -> m a -> m a
+recoveringHttp :: forall env a. HasRunner env => RetryPolicy -> RIO env a -> RIO env a
 recoveringHttp retryPolicy =
 #if MIN_VERSION_retry(0,7,0)
     helper $ \run -> recovering retryPolicy (handlers run) . const
 #else
     helper $ \run -> recovering retryPolicy (handlers run)
 #endif
   where
-    helper :: (MonadUnliftIO m, HasRunner env, MonadReader env m) => (UnliftIO m -> IO a -> IO a) -> m a -> m a
+    helper :: (UnliftIO (RIO env) -> IO a -> IO a) -> RIO env a -> RIO env a
     helper wrapper action = withUnliftIO $ \run -> wrapper run (unliftIO run action)
 
-    handlers :: (MonadLogger m, HasRunner env, MonadReader env m) => UnliftIO m -> [RetryStatus -> Handler IO Bool]
-    handlers run = [Handler . alwaysRetryHttp (unliftIO run),const $ Handler retrySomeIO]
+    handlers :: UnliftIO (RIO env) -> [RetryStatus -> Handler IO Bool]
+    handlers u = [Handler . alwaysRetryHttp u,const $ Handler retrySomeIO]
 
-    alwaysRetryHttp :: (MonadLogger m', Monad m, HasRunner env, MonadReader env m') => (m' () -> m ()) -> RetryStatus -> HttpException -> m Bool
-    alwaysRetryHttp run rs _ = do
-      run $
+    alwaysRetryHttp :: UnliftIO (RIO env) -> RetryStatus -> HttpException -> IO Bool
+    alwaysRetryHttp u rs _ = do
+      unliftIO u $
         prettyWarn $ vcat
           [ flow $ unwords
             [ "Retry number"
@@ -235,17 +234,18 @@ recoveringHttp retryPolicy =
 -- Throws VerifiedDownloadException.
 -- Throws IOExceptions related to file system operations.
 -- Throws HttpException.
-verifiedDownload :: (MonadUnliftIO m, MonadLogger m, HasRunner env, MonadReader env m)
+verifiedDownload
+         :: HasRunner env
          => DownloadRequest
          -> Path Abs File -- ^ destination
-         -> (Maybe Integer -> Sink ByteString IO ()) -- ^ custom hook to observe progress
-         -> m Bool -- ^ Whether a download was performed
+         -> (Maybe Integer -> ConduitM ByteString Void (RIO env) ()) -- ^ custom hook to observe progress
+         -> RIO env Bool -- ^ Whether a download was performed
 verifiedDownload DownloadRequest{..} destpath progressSink = do
     let req = drRequest
     whenM' (liftIO getShouldDownload) $ do
         logDebug $ "Downloading " <> decodeUtf8With lenientDecode (path req)
         liftIO $ createDirectoryIfMissing True dir
-        recoveringHttp drRetryPolicy $ liftIO $
+        recoveringHttp drRetryPolicy $
             withSinkFile fptmp $ httpSink req . go
         liftIO $ renameFile fptmp fp
   where
@@ -274,7 +274,9 @@ verifiedDownload DownloadRequest{..} destpath progressSink = do
 
     checkExpectations = withBinaryFile fp ReadMode $ \h -> do
         for_ drLengthCheck $ checkFileSizeExpectations h
-        sourceHandle h $$ getZipSink (hashChecksToZipSink drRequest drHashChecks)
+        runConduit
+            $ sourceHandle h
+           .| getZipSink (hashChecksToZipSink drRequest drHashChecks)
 
     -- doesn't move the handle
     checkFileSizeExpectations h expectedFileSize = do
@@ -310,7 +312,7 @@ verifiedDownload DownloadRequest{..} destpath progressSink = do
                 Nothing -> []
                 ) ++ drHashChecks
 
-        maybe id (\len -> (CB.isolate len =$=)) drLengthCheck
+        maybe id (\len -> (CB.isolate len .|)) drLengthCheck
             $ getZipSink
                 ( hashChecksToZipSink drRequest hashChecks
                   *> maybe (pure ()) (assertLengthSink drRequest) drLengthCheck

src/Network/HTTP/StackClient.hs

@@ -15,16 +15,16 @@ module Network.HTTP.StackClient
   , withResponseByManager
   ) where
 
-import           Control.Monad.Catch (MonadMask)
 import           Data.Aeson (FromJSON)
 import qualified Data.ByteString as Strict
 import           Data.ByteString.Lazy (ByteString)
-import           Data.Conduit (ConduitM, Sink)
+import           Data.Conduit (ConduitM, transPipe)
+import           Data.Void (Void)
 import qualified Network.HTTP.Client
 import           Network.HTTP.Client (BodyReader, Manager, Request, Response)
 import           Network.HTTP.Simple (setRequestHeader)
 import qualified Network.HTTP.Simple
-import           UnliftIO (MonadIO)
+import           UnliftIO (MonadIO, MonadUnliftIO, withRunInIO, withUnliftIO, unliftIO)
 
 
 setUserAgent :: Request -> Request
@@ -47,15 +47,22 @@ httpNoBody :: MonadIO m => Request -> m (Response ())
 httpNoBody = Network.HTTP.Simple.httpNoBody . setUserAgent
 
 
-httpSink :: (MonadIO m, MonadMask m) => Request -> (Response () -> Sink Strict.ByteString m a) -> m a
-httpSink = Network.HTTP.Simple.httpSink . setUserAgent
+httpSink
+  :: MonadUnliftIO m
+  => Request
+  -> (Response () -> ConduitM Strict.ByteString Void m a)
+  -> m a
+httpSink req inner = withUnliftIO $ \u ->
+  Network.HTTP.Simple.httpSink (setUserAgent req) (transPipe (unliftIO u) . inner)
 
 
 withResponse
-  :: (MonadIO m, MonadMask m, MonadIO n)
+  :: (MonadUnliftIO m, MonadIO n)
   => Request -> (Response (ConduitM i Strict.ByteString n ()) -> m a) -> m a
-withResponse = Network.HTTP.Simple.withResponse . setUserAgent
+withResponse req inner = withRunInIO $ \run ->
+  Network.HTTP.Simple.withResponse (setUserAgent req) (run . inner)
 
 
-withResponseByManager :: Request -> Manager -> (Response BodyReader -> IO a) -> IO a
-withResponseByManager = Network.HTTP.Client.withResponse . setUserAgent
+withResponseByManager :: MonadUnliftIO m => Request -> Manager -> (Response BodyReader -> m a) -> m a
+withResponseByManager req man inner = withRunInIO $ \run ->
+  Network.HTTP.Client.withResponse (setUserAgent req) man (run . inner)