Created
January 22, 2018 23:02
-
-
Save DanBurton/38157cb54259b71c5af45c3e86fef2b6 to your computer and use it in GitHub Desktop.
Generating stack's setup-info
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
#!/usr/bin/env stack | |
{- stack | |
script | |
--resolver lts-10.2 | |
--package bytestring | |
--package http-conduit | |
-} | |
-- usage: ./Main.hs | |
-- modify the baseUrl and ghcDateVersion to taste | |
{-# LANGUAGE LambdaCase #-} | |
module Main where | |
import Data.Semigroup ((<>)) | |
import qualified Data.ByteString.Char8 as C8 | |
import qualified Data.Foldable as F | |
import qualified Network.HTTP.Simple as HTTP | |
import qualified System.IO as Sys | |
baseUrl :: String | |
baseUrl = "https://downloads.haskell.org/~ghc/8.4.1-alpha2/" | |
ghcDateVersion :: String | |
ghcDateVersion = "ghc-8.4.0.20180118" | |
shouldSkipFile :: String -> Bool | |
shouldSkipFile "src" = True | |
shouldSkipFile "testsuite" = True | |
shouldSkipFile "windows-extra-src" = True | |
shouldSkipFile _ = False | |
-- TODO: add more | |
systemNameMapping :: String -> Maybe String | |
systemNameMapping "i386-deb8-linux" = Just "linux32-nopie" | |
systemNameMapping "i386-unknown-mingw32" = Just "windows32" | |
systemNameMapping "i386-unknown-mingw32-win10" = Just "windows32" | |
systemNameMapping "x86_64-apple-darwin" = Just "macosx" | |
systemNameMapping "x86_64-deb8-linux" = Just "linux64-nopie" | |
systemNameMapping "x86_64-unknown-mingw32" = Just "windows64" | |
systemNameMapping "x86_64-unknown-mingw32-win10" = Just "windows64" | |
systemNameMapping "x86_64-fedora27-linux" = Just "linux64-tinfo-nopie" | |
systemNameMapping _ = Nothing | |
-- TODO: generalize | |
stripSurroundings :: String -> String | |
stripSurroundings = | |
reverse | |
. drop (length ".tar.xz") | |
. reverse | |
. drop (length $ "./" <> ghcDateVersion <> "-") | |
err :: String -> IO () | |
err s = Sys.hPutStrLn Sys.stderr ("***** " <> s) | |
printSection :: String -> String -> String -> IO () | |
printSection target path sha256 = do | |
putStrLn $ " " <> target <> ":" | |
putStrLn $ " " <> (drop (length "ghc-") ghcDateVersion) <> ":" | |
putStrLn $ " url: " <> baseUrl <> drop (length "./") path | |
putStrLn $ " sha256: " <> sha256 | |
main :: IO () | |
main = do | |
req <- HTTP.parseRequest (baseUrl <> "/SHA256SUMS") | |
res <- HTTP.httpBS req | |
putStrLn "ghc:" | |
let strBody = C8.unpack $ HTTP.getResponseBody $ res | |
F.for_ (lines strBody) $ \line -> case words line of | |
[sha256, path] -> do | |
let file = stripSurroundings path | |
if (not $ shouldSkipFile file) | |
then | |
case systemNameMapping file of | |
-- I don't really understand this special case | |
-- but it seems like these two fedora cases use the same tarball | |
Just "linux64-tinfo-nopie" -> do | |
printSection "linux64-tinfo" path sha256 | |
printSection "linux64-tinfo-nopie" path sha256 | |
Just target -> do | |
printSection target path sha256 | |
Nothing -> do | |
err $ "Failed system name lookup: " <> file | |
else return () | |
_ -> err $ "Unexpected line: " <> line |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment