module Hack.Manager.Collector where
import Hack.Manager.Types
import Control.Exception
import Control.Monad.Except
import System.Directory
import System.Exit
import System.Process
import qualified Data.List as L
import qualified Data.Text as T
import qualified Distribution.Compiler as Comp
import qualified Distribution.Package as Pkg
import qualified Distribution.PackageDescription as PD
import qualified Distribution.PackageDescription.Parse as PD
import qualified Distribution.Text as DT
import qualified Distribution.Version as Vers
import qualified Network.HTTP.Client as C
import qualified Network.HTTP.Client.TLS as C
import qualified Network.HTTP.Types.Status as Http
import qualified System.FilePath.Glob as G
getProjectInfo :: IO (Either String ProjectInfo)
getProjectInfo =
runExceptT $
do cabalFiles <- liftIO $ G.glob "*.cabal"
case cabalFiles of
[] -> throwError "No cabal file in working directory!"
(f1:_) ->
do cabalData <- liftIO $ readFile f1
case PD.parsePackageDescription cabalData of
PD.ParseFailed err -> throwError (show err)
PD.ParseOk _ val -> compileProjectInfo val
onStackageCheck :: T.Text -> IO Bool
onStackageCheck projectName =
do mgr <- C.newManager C.tlsManagerSettings
initReq <- C.parseUrl ("https://www.stackage.org/package/" ++ T.unpack projectName)
let tryGet =
do resp <- C.httpNoBody initReq mgr
return $ C.responseStatus resp == Http.ok200
tryGet `catch` \(_ :: SomeException) -> return False
onHackageCheck :: T.Text -> IO Bool
onHackageCheck projectName =
do mgr <- C.newManager C.tlsManagerSettings
initReq <- C.parseUrl ("https://hackage.haskell.org/package/" ++ T.unpack projectName)
let tryGet =
do resp <- C.httpNoBody initReq mgr
return $ C.responseStatus resp == Http.ok200
tryGet `catch` \(_ :: SomeException) -> return False
findGhcVersions :: [(Comp.CompilerFlavor, Vers.VersionRange)] -> ExceptT String IO [T.Text]
findGhcVersions origVersions =
forM versions $ \vers ->
let loop [] = throwError ("Unknown ghc version: " ++ show vers)
loop (x:xs) =
if Vers.withinRange x vers then return x else loop xs
in liftM (T.pack . DT.display) $ loop ghcLatest
where
versions = map snd $ filter (\(flavor, _) -> flavor == Comp.GHC) origVersions
ghcLatest =
[ Vers.Version [7, 4, 2] []
, Vers.Version [7, 6, 3] []
, Vers.Version [7, 8, 4] []
, Vers.Version [7, 10, 2] []
]
getCliUsage :: Bool -> [String] -> ExceptT String IO [CliExecutable]
getCliUsage hasStack exec =
forM exec $ \program ->
do (ec, stdOut, stdErr) <-
liftIO $
if hasStack
then readProcessWithExitCode "/bin/bash" ["-c", "stack exec -- " ++ program ++ " --help"] ""
else readProcessWithExitCode "/bin/bash" ["-c", "cabal run -- " ++ program ++ " --help"] ""
when (ec /= ExitSuccess) $
throwError $ "Failed to run " ++ program ++ " --help to retrieve cli usage. StdOut was: " ++ stdOut ++ " \n StdErr was: " ++ stdErr
return
CliExecutable
{ ce_name = T.pack program
, ce_help = T.pack stdOut
}
moreFile :: ExceptT String IO (Maybe T.Text)
moreFile =
liftIO $
do more <- doesFileExist "MORE.md"
if more
then do ct <- readFile "MORE.md"
return (Just $ T.pack ct)
else return Nothing
compileProjectInfo :: PD.GenericPackageDescription -> ExceptT String IO ProjectInfo
compileProjectInfo gpd =
do let pkgName = T.pack $ Pkg.unPackageName $ Pkg.pkgName $ PD.package pd
ghInfo <-
case filter repoFilter $ PD.sourceRepos pd of
[] -> throwError "No head github source-repository given in cabal file!"
(repo:_) ->
case PD.repoLocation repo of
Nothing ->
throwError "Missing source-repository location"
Just loc -> extractGithub loc
hasStack <- liftM (not . L.null) $ liftIO $ G.glob "stack*.yaml"
(example, hasMoreEx) <-
do files <- liftIO $ G.glob "examples/*.hs"
forM_ files $ \file ->
do res <-
liftIO $
if hasStack
then system $ "stack exec -- ghc -fno-code " ++ file
else system $ "cabal exec -- ghc -fno-code " ++ file
when (res /= ExitSuccess) $ throwError $ "Failed to compile " ++ file
case files of
[] -> return (Nothing, False)
(file:xs) ->
do ex <- liftIO $ readFile file
return (Just $ T.pack ex, not $ L.null xs)
onStackage <- liftIO $ onStackageCheck pkgName
onHackage <- liftIO $ onHackageCheck pkgName
ghcVers <- findGhcVersions (PD.testedWith pd)
cliUsage <- getCliUsage hasStack (map fst $ PD.condExecutables gpd)
moreFile <- moreFile
return
ProjectInfo
{ pi_name = pkgName
, pi_pkgName = pkgName
, pi_pkgDesc = T.pack $ PD.synopsis pd
, pi_stackFile = hasStack
, pi_onStackage = onStackage
, pi_onHackage = onHackage
, pi_example = example
, pi_moreExamples = hasMoreEx
, pi_github = ghInfo
, pi_license =
LicenseInfo
{ li_copyright = T.pack $ PD.copyright pd
, li_type = T.pack $ DT.display $ PD.license pd
}
, pi_ghcVersions = ghcVers
, pi_cliUsage = cliUsage
, pi_moreInfo = moreFile
}
where
pd = PD.packageDescription gpd
repoFilter rep =
PD.repoKind rep == PD.RepoHead
&& PD.repoType rep == Just PD.Git
&& checkGithub (PD.repoLocation rep)
checkGithub r =
case r of
Nothing -> False
Just str -> "github.com" `L.isInfixOf` str
extractGithub loc =
case L.stripPrefix "https://github.com/" loc of
Nothing ->
throwError "source-repository location must start with https://github.com/"
Just rest ->
let (usr, slashedRepo) = L.break (=='/') rest
in return
GithubInfo
{ gi_user = T.pack usr
, gi_project = T.pack $ L.drop 1 slashedRepo
}