From 8f20a226fe4fa0ceae3680a1a8ed18487009de7a Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Tue, 23 Jun 2015 11:01:28 +0300
Subject: [PATCH] Upload snapshots.json to S3 (commercialhaskell/stack#380)

---
 Handler/Download.hs       | 20 +-------------------
 Stackage/Database.hs      | 23 +++++++++++++++++++++++
 Stackage/Database/Cron.hs | 12 +++++++++++-
 3 files changed, 35 insertions(+), 20 deletions(-)

diff --git a/Handler/Download.hs b/Handler/Download.hs
index 67caf94..120708a 100644
--- a/Handler/Download.hs
+++ b/Handler/Download.hs
@@ -41,25 +41,7 @@ getDownloadSnapshotsJsonR :: Handler Value
 getDownloadSnapshotsJsonR = getDownloadLtsSnapshotsJsonR
 
 getDownloadLtsSnapshotsJsonR :: Handler Value
-getDownloadLtsSnapshotsJsonR = do
-    mlatestNightly <- newestNightly
-    ltses <- ltsMajorVersions
-    let lts = case ltses of
-            [] -> []
-            majorVersions@(latest:_) ->
-                   ("lts" .= printLts latest)
-                 : map toObj majorVersions
-        nightly = case mlatestNightly of
-            Nothing -> id
-            Just n -> (("nightly" .= printNightly n):)
-    return $ object $ nightly lts
-  where
-    toObj lts@(major, _) =
-        pack ("lts-" ++ show major) .= printLts lts
-    printLts (major, minor) =
-        "lts-" ++ show major ++ "." ++ show minor
-
-    printNightly day = "nightly-" ++ tshow day
+getDownloadLtsSnapshotsJsonR = snapshotsJSON
 
 -- Print the ghc major version for the given snapshot.
 ghcMajorVersionText :: Snapshot -> Text
diff --git a/Stackage/Database.hs b/Stackage/Database.hs
index d6f5b0d..c2832d7 100644
--- a/Stackage/Database.hs
+++ b/Stackage/Database.hs
@@ -31,6 +31,7 @@ module Stackage.Database
     , getSnapshots
     , currentSchema
     , last5Lts5Nightly
+    , snapshotsJSON
     ) where
 
 import Database.Sqlite (SqliteException)
@@ -61,6 +62,7 @@ import Control.Monad.Logger
 import System.IO.Temp
 import qualified Database.Esqueleto as E
 import Data.Yaml (decode)
+import qualified Data.Aeson as A
 
 currentSchema :: Int
 currentSchema = 1
@@ -652,3 +654,24 @@ last5Lts5Nightly = run $ do
   where
     l (Entity _ x) = SNLts (ltsMajor x) (ltsMinor x)
     n (Entity _ x) = SNNightly (nightlyDay x)
+
+snapshotsJSON :: GetStackageDatabase m => m A.Value
+snapshotsJSON = do
+    mlatestNightly <- newestNightly
+    ltses <- ltsMajorVersions
+    let lts = case ltses of
+            [] -> []
+            majorVersions@(latest:_) ->
+                   ("lts" A..= printLts latest)
+                 : map toObj majorVersions
+        nightly = case mlatestNightly of
+            Nothing -> id
+            Just n -> (("nightly" A..= printNightly n):)
+    return $ A.object $ nightly lts
+  where
+    toObj lts@(major, _) =
+        pack ("lts-" ++ show major) A..= printLts lts
+    printLts (major, minor) =
+        "lts-" ++ show major ++ "." ++ show minor
+
+    printNightly day = "nightly-" ++ tshow day
diff --git a/Stackage/Database/Cron.hs b/Stackage/Database/Cron.hs
index a0908d7..1b78c63 100644
--- a/Stackage/Database/Cron.hs
+++ b/Stackage/Database/Cron.hs
@@ -31,6 +31,9 @@ import qualified Data.Conduit.Binary as CB
 import           Data.Conduit.Zlib             (WindowBits (WindowBits),
                                                 compress, ungzip)
 import qualified Hoogle
+import System.IO.Temp (withSystemTempFile)
+import qualified Data.Aeson as A
+import qualified Data.ByteString.Lazy as L
 
 filename' :: Text
 filename' = concat
@@ -149,7 +152,7 @@ stackageServerCron = do
                         $$ compress 9 (WindowBits 31)
                         =$ CB.sinkFile fpgz
             body <- sourceFileIO fpgz
-            let po = 
+            let po =
                       set poACL (Just PublicRead)
                    $  putObject body "haddock.stackage.org" key
             putStrLn $ "Uploading: " ++ key
@@ -163,6 +166,13 @@ stackageServerCron = do
     upload dbfp keyName
 
     db <- openStackageDatabase dbfp
+
+    snapshots <- runReaderT snapshotsJSON db
+    withSystemTempFile "snapshots.json" $ \fp h -> do
+        L.hPut h $ A.encode snapshots
+        hClose h
+        upload (fpFromString fp) "snapshots.json"
+
     names <- runReaderT last5Lts5Nightly db
     let manager = view envManager env
     forM_ names $ \name -> do