module Stackage.Install
( install
, download
, Settings
, defaultSettings
) where
import Control.Applicative ((*>))
import Control.Concurrent.Async (Concurrently (..))
import Control.Concurrent.STM (atomically, newTVarIO, readTVar,
writeTVar)
import Control.Monad (join, unless)
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.Foldable as F
import Data.Function (fix)
import Data.List (isPrefixOf)
import Network.HTTP.Client (Manager, brRead, newManager,
parseUrl, responseBody, withResponse)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import System.Directory (createDirectoryIfMissing,
doesFileExist,
getAppUserDataDirectory, renameFile)
import System.Exit (ExitCode)
import System.FilePath (takeDirectory, (<.>), (</>))
import System.IO (IOMode (WriteMode), stdout,
withBinaryFile)
import System.Process (rawSystem, readProcess)
install :: Settings -> [String] -> IO ExitCode
install s args = do
out <- readProcess (_cabalCommand s) ("install":"--dry-run":args) ""
let pkgs = map toPair $ filter (not . toIgnore) $ lines out
download s pkgs
rawSystem (_cabalCommand s) ("install":args)
where
toIgnore str = ' ' `elem` str || '-' `notElem` str
toPair :: String -> (String, String)
toPair orig =
(pkg, ver)
where
(ver', pkg') = break (== '-') $ reverse orig
ver = reverse ver'
pkg = reverse $ drop 1 pkg'
data Settings = Settings
{ _getManager :: !(IO Manager)
, _cabalCommand :: !FilePath
, _downloadPrefix :: !String
, _onDownload :: !(String -> IO ())
, _connections :: !Int
}
defaultSettings :: Settings
defaultSettings = Settings
{ _getManager = newManager tlsManagerSettings
, _cabalCommand = "cabal"
, _downloadPrefix = "https://s3.amazonaws.com/hackage.fpcomplete.com/package/"
, _onDownload = \s -> S8.hPut stdout $ S8.pack $ concat
[ "Downloading "
, s
, "\n"
]
, _connections = 8
}
download :: F.Foldable f => Settings -> f (String, String) -> IO ()
download s pkgs = do
man <- _getManager s
cabalDir <- getAppUserDataDirectory "cabal"
parMapM_ (_connections s) (go cabalDir man) pkgs
where
unlessM p f = do
p' <- p
unless p' f
go cabalDir man (name, version) = do
unlessM (doesFileExist fp) $ do
_onDownload s pkg
createDirectoryIfMissing True $ takeDirectory fp
req <- parseUrl url
withResponse req man $ \res -> do
let tmp = fp <.> "tmp"
withBinaryFile tmp WriteMode $ \h -> fix $ \loop -> do
bs <- brRead $ responseBody res
unless (S.null bs) $ do
S.hPut h bs
loop
renameFile tmp fp
where
pkg = concat [name, "-", version]
targz = pkg ++ ".tar.gz"
url = _downloadPrefix s ++ targz
fp = cabalDir </>
"packages" </>
"hackage.haskell.org" </>
name </>
version </>
targz
parMapM_ :: F.Foldable f
=> Int
-> (a -> IO ())
-> f a
-> IO ()
parMapM_ (max 1 -> 1) f xs = F.mapM_ f xs
parMapM_ cnt f xs0 = do
var <- newTVarIO $ F.toList xs0
let worker :: IO ()
worker = fix $ \loop -> join $ atomically $ do
xs <- readTVar var
case xs of
[] -> return $ return ()
x:xs' -> do
writeTVar var xs'
return $ do
f x
loop
workers 1 = Concurrently worker
workers i = Concurrently worker *> workers (i 1)
runConcurrently $ workers cnt