From cce500244a3779b5200a711abffdbf783bd34e53 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Thu, 17 Apr 2014 19:06:18 +0300
Subject: [PATCH] Create Stackage server bundles

---
 .gitignore                 |  3 +++
 Stackage/InstallInfo.hs    | 39 ++++++++++++++++++++++-------
 Stackage/ServerFiles.hs    | 51 ++++++++++++++++++++++++++++++++++++++
 create-stackage-tarball.sh |  3 +++
 stackage.cabal             |  1 +
 5 files changed, 88 insertions(+), 9 deletions(-)
 create mode 100644 Stackage/ServerFiles.hs
 create mode 100644 create-stackage-tarball.sh

diff --git a/.gitignore b/.gitignore
index 171539c9..f0f5070f 100644
--- a/.gitignore
+++ b/.gitignore
@@ -16,3 +16,6 @@ cabal-dev
 build-plan.txt
 hackage-map.txt
 module-name-conflicts.txt
+/hackage
+/desc
+*.stackage
diff --git a/Stackage/InstallInfo.hs b/Stackage/InstallInfo.hs
index b7befdb3..d4f5e78c 100644
--- a/Stackage/InstallInfo.hs
+++ b/Stackage/InstallInfo.hs
@@ -8,6 +8,7 @@ import           Control.Monad            (forM_, unless)
 import           Data.List                (foldl')
 import qualified Data.Map                 as Map
 import qualified Data.Set                 as Set
+import           Data.Time                (getCurrentTime, formatTime)
 import           Data.Version             (showVersion)
 import qualified Distribution.Text
 import           Distribution.Version     (simplifyVersionRange, withinRange)
@@ -15,9 +16,12 @@ import           Stackage.GhcPkg
 import           Stackage.HaskellPlatform
 import           Stackage.LoadDatabase
 import           Stackage.NarrowDatabase
+import           Stackage.ServerFiles
 import           Stackage.Types
 import           Stackage.Util
+import qualified System.IO                as IO
 import qualified System.IO.UTF8
+import           System.Locale            (defaultTimeLocale)
 import           System.Exit              (exitFailure)
 
 dropExcluded :: SelectSettings
@@ -87,15 +91,32 @@ getInstallInfo settings = do
 
                 error "Conflicting build plan, exiting"
 
-    return InstallInfo
-        { iiCore = totalCore
-        , iiPackages = Map.map biToSPI final
-        , iiOptionalCore = maybe
-            Map.empty
-            (Map.fromList . map (\(PackageIdentifier p v) -> (p, v)) . Set.toList . hplibs)
-            mhp
-        , iiPackageDB = pdb
-        }
+    let ii = InstallInfo
+            { iiCore = totalCore
+            , iiPackages = Map.map biToSPI final
+            , iiOptionalCore = maybe
+                Map.empty
+                (Map.fromList . map (\(PackageIdentifier p v) -> (p, v)) . Set.toList . hplibs)
+                mhp
+            , iiPackageDB = pdb
+            }
+
+    putStrLn "Creating hackage file (for publishing to Stackage server)"
+    IO.withBinaryFile "hackage" IO.WriteMode $ createHackageFile ii
+
+    putStrLn "Creating desc file (for publishing to Stackage server)"
+    now <- getCurrentTime
+    System.IO.UTF8.writeFile "desc" $ concat
+        [ "Stackage build for GHC "
+        , let GhcMajorVersion x y = selectGhcVersion settings
+           in show x ++ "." ++ show y
+        , ", "
+        , formatTime defaultTimeLocale "%Y-%m-%d\n" now
+        , "Generated on "
+        , show now
+        ]
+
+    return ii
 
 biToSPI :: BuildInfo -> SelectedPackageInfo
 biToSPI BuildInfo {..} = SelectedPackageInfo
diff --git a/Stackage/ServerFiles.hs b/Stackage/ServerFiles.hs
new file mode 100644
index 00000000..4282b72a
--- /dev/null
+++ b/Stackage/ServerFiles.hs
@@ -0,0 +1,51 @@
+-- | Create the files necessary for Stackage server.
+module Stackage.ServerFiles
+    ( createHackageFile
+    ) where
+
+import Stackage.Util
+import Stackage.Types
+import qualified Data.Map as Map
+import Control.Exception (throwIO)
+import qualified Codec.Archive.Tar as Tar
+import qualified Data.ByteString.Lazy as L
+import Control.Arrow (second)
+import Distribution.Text (display)
+import System.IO (Handle, hPutStrLn)
+
+createHackageFile :: InstallInfo -> Handle -> IO ()
+createHackageFile ii h = do
+    indextargz <- getTarballName
+    indexLBS <- L.readFile indextargz
+    loop $ Tar.read indexLBS
+  where
+    selected = Map.fromList . map toStrs . Map.toList $
+        fmap spiVersion (iiPackages ii)
+        `Map.union` iiOptionalCore ii
+
+    toStrs (PackageName name, version) = (name, display version)
+
+    loop Tar.Done = return ()
+    loop (Tar.Fail e) = throwIO e
+    loop (Tar.Next e es) = go e >> loop es
+
+    go e =
+        case parsePair $ Tar.entryPath e of
+            Nothing -> return ()
+            Just (name, version) ->
+                case Map.lookup name selected of
+                    Just version' | version /= version' -> return ()
+                    _ -> hPutStrLn h $ concat [name, "-", version]
+
+parsePair :: String -> Maybe (String, String)
+parsePair s =
+    case splitOn '/' s of
+        [name, version, cabal] | name ++ ".cabal" == cabal -> Just (name, version)
+        _ -> Nothing
+
+splitOn :: Eq a => a -> [a] -> [[a]]
+splitOn _ [] = []
+splitOn c x =
+    y : splitOn c z
+  where
+    (y, z) = second (drop 1) $ break (== c) x
diff --git a/create-stackage-tarball.sh b/create-stackage-tarball.sh
new file mode 100644
index 00000000..1ccb5642
--- /dev/null
+++ b/create-stackage-tarball.sh
@@ -0,0 +1,3 @@
+#!/bin/bash -ex
+
+tar czfv ghc-$(ghc --numeric-version)-$(date +%Y-%m-%d).stackage hackage desc patching/tarballs/
diff --git a/stackage.cabal b/stackage.cabal
index 7de4cfad..61e66fa5 100644
--- a/stackage.cabal
+++ b/stackage.cabal
@@ -29,6 +29,7 @@ library
                        Stackage.CheckCabalVersion
                        Stackage.Select
                        Stackage.GhcPkg
+                       Stackage.ServerFiles
   build-depends:       base >= 4 && < 5
                      , containers
                      , Cabal >= 1.14