Main.hs

-- #!/usr/bin/env runhaskell
{-# LANGUAGE OverloadedStrings, NamedFieldPuns #-}

{-

This builds a relocatable ghc-$version.app in dist/build,
downloads stack from GitHub,
and builds cabal-install using stack.

TODO:

* Pre-install some packages?

-}
module Main (main) where

import Data.Char (toUpper)
import Control.Applicative ((<$>))
import System.Environment (getArgs, unsetEnv)
import System.Directory
  ( getCurrentDirectory, getDirectoryContents, doesDirectoryExist
  , setCurrentDirectory, createDirectoryIfMissing, doesFileExist
  , copyFile
  )
import System.FilePath ((</>), dropExtension, takeExtension, takeFileName)
import System.Process (callProcess, readProcess)
import Control.Monad (when, filterM, foldM)
import System.Posix.Files
  ( getSymbolicLinkStatus, getFileStatus, isSymbolicLink, fileSize )
import System.IO (stderr, hPutStrLn)
import System.Exit (exitFailure)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Encoding as T
import qualified Data.ByteString as B
import qualified Control.Exception as C
import System.Console.GetOpt
  ( ArgOrder(..)
  , OptDescr(..)
  , ArgDescr(..)
  , usageInfo
  , getOpt
  )

-- Layout:
--
--   dist/download/[ghc-$version-*.tar.bz2]
--   dist/unpack/ghc-$version
--   dist/build/ghc-$version.app/Contents/{lib,bin}/
--

data BuildState = BuildState
  { buildRel             :: Release
  , buildStackRel        :: Release
  , buildDistDir         :: String
  , buildDownloadDir     :: String
  , buildUnpackDir       :: String
  , buildUnpackDest      :: String
  , buildBuildDir        :: String
  , buildAppDir          :: String
  , buildPrefixDir       :: String
  , buildPkgRoot         :: String
  , buildGhcName         :: String
  , buildBinDir          :: String
  , buildConfDir         :: String
  , buildShareDir        :: String
  } deriving (Show, Eq)

data Releases = Releases
  { releasesStack :: Release
  , releasesGhc   :: Release
  }

data Release = Release
  { releaseVersion :: String
  , releaseUrl     :: String
  , releaseSha1    :: String
  , releaseSize    :: Int
  } deriving (Show, Eq)

data Rule = Rule
  { ruleName         :: String
  , ruleCheck        :: IO Bool
  , ruleRun          :: IO ()
  , ruleDependencies :: [Rule]
  }

releaseFileName :: Release -> FilePath
releaseFileName = takeFileName . releaseUrl

buildState :: Releases -> FilePath -> BuildState
buildState releases here = b
  where
    rel = releasesGhc releases
    stackRel = releasesStack releases
    distDir = here </> "dist"
    n = buildGhcName b
    b = BuildState
      { buildRel             = rel
      , buildStackRel        = stackRel
      , buildDistDir         = distDir
      , buildDownloadDir     = distDir </> "download"
      , buildUnpackDir       = distDir </> "unpack"
      , buildUnpackDest      = buildUnpackDir b </> n
      , buildBuildDir        = distDir </> "build"
      , buildAppDir          = buildBuildDir b </> n ++ ".app"
      , buildPrefixDir       = buildAppDir b </> "Contents"
      , buildPkgRoot         = buildPrefixDir b </> "lib" </> n
      , buildGhcName         = "ghc-" ++ releaseVersion rel
      , buildBinDir          = buildPrefixDir b </> "bin"
      , buildConfDir         = buildPkgRoot b </> "package.conf.d"
      , buildShareDir        = buildPrefixDir b </> "share"
      }

defRule :: Rule
defRule = Rule
  { ruleName         = "unnamed rule"
  , ruleCheck        = return False
  , ruleRun          = return ()
  , ruleDependencies = []
  }

latestGhc :: Release
latestGhc = Release
  { releaseVersion = "7.10.3"
  , releaseUrl     = "http://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-x86_64-apple-darwin.tar.xz"
  , releaseSha1    = "fe0d26e6c65e911fbc2897700c35f561d3b56710"
  , releaseSize    = 88133560
  }

latestStack :: Release
latestStack = Release
  { releaseVersion = "1.0.4"
  , releaseUrl     = "https://github.com/commercialhaskell/stack/releases/download/v1.0.4/stack-1.0.4-osx-x86_64.tar.gz"
  , releaseSha1    = "bc1f7a946b0664d29b3b7401f738b1ab6a907345"
  , releaseSize    = 9737246
  }

latestReleases :: Releases
latestReleases = Releases
  { releasesStack = latestStack
  , releasesGhc   = latestGhc
  }

shellPreamble :: T.Text
shellPreamble = T.unlines
  [ "#!/bin/bash"
  , "SOURCE=\"${BASH_SOURCE[0]}\""
  , "# resolve $SOURCE until the file is no longer a symlink"
  , "while [ -h \"$SOURCE\" ]; do"
  , "  DIR=\"$( cd -P \"$( dirname \"$SOURCE\" )\" && pwd )\""
  , "   SOURCE=\"$(readlink \"$SOURCE\")\""
  , "  # if $SOURCE was a relative symlink, we need to resolve it relative to"
  , "  # the path where the symlink file was located"
  , "  [[ $SOURCE != /* ]] && SOURCE=\"$DIR/$SOURCE\""
  , "done"
  , "DIR=\"$( cd -P \"$(dirname \"$( dirname \"$SOURCE\" )\")\" && pwd )\""
  ]

isScript :: FilePath -> IO Bool
isScript = (not . isSymbolicLink <$>) . getSymbolicLinkStatus

runRule :: Rule -> IO ()
runRule rule = do
  putStrLn (ruleName rule)
  shouldRun <- not <$> ruleCheck rule
  when shouldRun $ do
    mapM_ runRule (ruleDependencies rule)
    ruleRun rule

fixupBin :: BuildState -> IO ()
fixupBin (BuildState { buildBinDir, buildPrefixDir }) = do
  binFiles <- map (buildBinDir </>) . filter ((/='.') . head) <$>
                getDirectoryContents buildBinDir
  scripts <- filterM isScript binFiles
  mapM_ (fixupScript buildPrefixDir) scripts

fixupScript :: FilePath -> FilePath -> IO ()
fixupScript buildPrefixDir fileName =
  B.readFile fileName >>=
    either (const $ return ()) replaceText . T.decodeUtf8'
  where
    prefixDir = T.pack buildPrefixDir
    binsh = "#!/bin/sh\n"
    replaceText s = when (binsh `T.isPrefixOf` s) $ do
      putStrLn fileName
      T.writeFile fileName .
        T.append shellPreamble .
        T.drop (T.length binsh) .
        T.replace prefixDir "${DIR}" $
        s

sanityCheck :: BuildState -> Rule
sanityCheck (BuildState { buildConfDir, buildDistDir }) = defRule
  { ruleName = "sanityCheck " ++ buildConfDir
  , ruleRun = do
      files <- filter ((".conf"==) . takeExtension) <$> getDirectoryContents buildConfDir
      mapM_ (checkBuildDir distDir . (buildConfDir </>)) files
  }
  where
    distDir  = T.pack buildDistDir

checkBuildDir :: T.Text -> FilePath -> IO ()
checkBuildDir distDir fileName = do
  s <- T.readFile fileName
  when (distDir `T.isInfixOf` s) $ do
    putStrLn ("FAIL: " ++ fileName)
    fail fileName

fixupConf :: BuildState -> IO ()
fixupConf (BuildState { buildPkgRoot, buildConfDir, buildShareDir }) = do
  files <- filter ((".conf"==) . takeExtension) <$> getDirectoryContents buildConfDir
  mapM_ (fixPkgRoot pkgRoot shareDir . (buildConfDir </>)) files
  where
    pkgRoot  = T.pack buildPkgRoot
    shareDir = T.pack buildShareDir

fixPkgRoot :: T.Text -> T.Text -> FilePath -> IO ()
fixPkgRoot pkgRoot shareDir fileName = do
  s <- T.readFile fileName
  when (pkgRoot `T.isInfixOf` s) $ do
    putStrLn fileName
    T.writeFile fileName .
      T.replace pkgRoot "${pkgroot}" .
      T.replace shareDir (T.append pkgRoot "/../../share") $
      s

recachePkg :: BuildState -> IO ()
recachePkg bs =
  callProcess (buildBinDir bs </> "ghc-pkg") ["recache"]

ensureDir :: FilePath -> Rule
ensureDir s = defRule
  { ruleName = "ensureDir " ++ show s
  , ruleRun  = createDirectoryIfMissing True s
  }

withDir :: FilePath -> IO a -> IO a
withDir s =
  C.bracket saveDir setCurrentDirectory . const
  where
    saveDir = do
      dir <- getCurrentDirectory
      setCurrentDirectory s
      return dir

andM :: Monad m => [m Bool] -> m Bool
andM = foldr go (return True)
  where go m acc = m >>= \x -> if x then acc else return x

sha1 :: FilePath -> IO String
sha1 fileName = do
  output <- readProcess "openssl" ["sha1", fileName] ""
  case map (reverse . words) . lines $ output of
    ((hash:_):_) -> return hash
    _            -> return ""

downloadRelease :: (BuildState -> Release) -> BuildState -> Rule
downloadRelease getRel bs@(BuildState { buildDownloadDir }) = defRule
  { ruleName         = "download " ++ releaseFileName rel
  , ruleCheck        = checkDownload
  , ruleDependencies = [ ensureDir buildDownloadDir ]
  , ruleRun          = do
    callProcess "curl" [ "-L", "-s", "-o", tarFileName, releaseUrl rel ]
    didFail <- not <$> checkDownload
    when didFail . fail $ "release tarball did not match expected size or sha1"
  }
  where
    tarFileName = buildDownloadDir </> releaseFileName rel
    rel = getRel bs
    checkDownload = andM
      [ doesFileExist tarFileName
      , (releaseSize rel ==) . fromIntegral . fileSize <$> getFileStatus tarFileName
      , (releaseSha1 rel ==) <$> sha1 tarFileName
      ]

unpackRelease :: (BuildState -> Release)
              -> FilePath
              -> BuildState -> Rule
unpackRelease getRel unpackDest bs@(BuildState
    { buildUnpackDir, buildDownloadDir }) = defRule
  { ruleName         = "unpack " ++ releaseFileName rel
  , ruleCheck        = doesDirectoryExist unpackDest
  , ruleDependencies = [ downloadRelease getRel bs
                       , ensureDir buildUnpackDir ]
  , ruleRun          = withDir buildUnpackDir $
      callProcess "tar" [ "xf", tarFileName ]
  }
  where
    rel = getRel bs
    tarFileName = buildDownloadDir </> releaseFileName rel

buildRelease :: BuildState -> Rule
buildRelease bs@(BuildState
    { buildPrefixDir, buildGhcName, buildBinDir, buildUnpackDest }) = defRule
  { ruleName         = "build " ++ buildGhcName
  , ruleCheck        = doesFileExist (buildBinDir </> "ghc")
  , ruleDependencies = [ unpackRelease buildRel buildUnpackDest bs
                       , ensureDir buildPrefixDir ]
  , ruleRun          = withDir buildUnpackDest $ do
      callProcess "./configure" [ "--prefix=" ++ buildPrefixDir ]
      callProcess "make" ["install"]
      mapM_ ($ bs)
        [ fixupBin
        , fixupConf
        , recachePkg
        ]
  }

installCabal :: BuildState -> Rule
installCabal bs@(BuildState { buildUnpackDir, buildBinDir }) = defRule
  { ruleName         = "install cabal"
  , ruleCheck        = doesFileExist cabalDest
  , ruleDependencies = [ installStack bs ]
  , ruleRun          = callProcess (buildBinDir </> "stack") ["--local-bin-path", buildBinDir, "install", "cabal-install"]
  }
  where
    cabalDest = buildBinDir </> "cabal"

installStack :: BuildState -> Rule
installStack bs@(BuildState { buildUnpackDir, buildBinDir }) = defRule
  { ruleName         = "install stack " ++ releaseVersion (buildStackRel bs)
  , ruleCheck        = doesFileExist stackDest
  , ruleDependencies = [ unpackRelease buildStackRel stackSrc bs ]
  , ruleRun          = copyFile stackSrc stackDest
  }
  where
    stackSrc  = buildUnpackDir </> "stack-" ++ releaseVersion (buildStackRel bs) ++ "-osx-x86_64" </> "stack"
    stackDest = buildBinDir </> "stack"

buildApp :: BuildState -> Rule
buildApp bs = defRule
  { ruleName         = "building " ++ buildAppDir bs
  , ruleDependencies = map ($ bs) [ buildRelease
                                  , installStack
                                  , installCabal
                                  , sanityCheck ]
  }

die :: [String] -> IO a
die errs = do
  hPutStrLn stderr (concat errs ++ usageInfo header options)
  exitFailure
  where header = "Usage: runhaskell Main.hs [OPTION...]"

parseReleases :: Releases -> [String] -> IO Releases
parseReleases releases argv = case getOpt Permute options argv of
  (opts, [], []) -> foldM (flip id) releases opts
  (_, _, errs)   -> die (if showHelp then [] else errs)
  where
    showHelp = "--help" `elem` argv

options :: [OptDescr (Releases -> IO Releases)]
options = do
  (prodName, updateProd) <-
    [ ("ghc", \f x -> do
        release <- f (releasesGhc x)
        return x { releasesGhc = release })
    , ("stack", \f x -> do
        release <- f (releasesStack x)
        return x { releasesStack = release })
    ]
  (setterName, setter) <-
    [ ("url", \arg r -> return r { releaseUrl = arg })
    , ("version", \arg r -> return r { releaseVersion = arg })
    , ("sha1", \arg r -> return r { releaseSha1 = arg })
    , ("size", \arg r -> case reads arg of
        [(size, "")] -> return r { releaseSize = size }
        _            ->
          die [ "option --" ++ prodName ++
                "-size requires a number argument SIZE\n"])
    ]
  return $ Option [] [prodName ++ "-" ++ setterName]
             (ReqArg (updateProd . setter) (map toUpper setterName))
             (prodName ++ " " ++ setterName)

main :: IO ()
main = do
  -- this is necessary to allow `stack exec main` to do the right thing
  -- without --no-ghc-package-path
  unsetEnv "GHC_PACKAGE_PATH"
  releases <- getArgs >>= parseReleases latestReleases
  appRule <- buildApp . buildState releases <$> getCurrentDirectory
  runRule appRule