From f03ada0f81f6dc31420716b71cc6c9c6fced1e17 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Fri, 1 May 2015 10:15:43 +0300
Subject: [PATCH] Add nightly to the list of snapshots

I also cleaned up the LTS code. It currently had the assumption that LTS
major versions would be monotonically increasing from 0 without gaps.
While likely to be true, that's slightly brittle, and did in fact break
in my testing (where I only had an lts-2.4 in the database).
---
 Handler/Download.hs | 41 +++++++++++++++++++++++++++--------------
 1 file changed, 27 insertions(+), 14 deletions(-)

diff --git a/Handler/Download.hs b/Handler/Download.hs
index 57108f5..e264fe6 100644
--- a/Handler/Download.hs
+++ b/Handler/Download.hs
@@ -35,29 +35,42 @@ getDownloadR = defaultLayout $ do
     setTitle "Download"
     $(widgetFile "download")
 
-ltsMajorVersions :: Handler [Lts]
-ltsMajorVersions = liftM (map entityVal) $ runDB $ do
-  mapWhileIsJustM [0..] $ \x -> do
-    selectFirst [LtsMajor ==. x] [Desc LtsMinor]
+ltsMajorVersions :: YesodDB App [Lts]
+ltsMajorVersions =
+        (dropOldMinors . map entityVal)
+    <$> selectList [] [Desc LtsMajor, Desc LtsMinor]
 
-mapWhileIsJustM :: Monad m => [a] -> (a -> m (Maybe b)) -> m [b]
-mapWhileIsJustM [] _f = return []
-mapWhileIsJustM (x:xs) f = f x >>= \case
-    Nothing -> return []
-    Just y -> (y:) `liftM` mapWhileIsJustM xs f
+dropOldMinors :: [Lts] -> [Lts]
+dropOldMinors [] = []
+dropOldMinors (l@(Lts x _ _):rest) =
+    l : dropOldMinors (dropWhile sameMinor rest)
+  where
+    sameMinor (Lts y _ _) = x == y
 
 getDownloadLtsSnapshotsJsonR :: Handler Value
-getDownloadLtsSnapshotsJsonR = liftM reverse ltsMajorVersions >>= \case
-    [] -> return $ object []
-    majorVersions@(latest:_) -> return $ object
-         $ ["lts" .= printLts latest]
-        ++ map toObj majorVersions
+getDownloadLtsSnapshotsJsonR = do
+    (mlatestNightly, ltses) <- runDB $ (,)
+        <$> getLatestNightly
+        <*> 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@(Lts major _ _) =
         pack ("lts-" ++ show major) .= printLts lts
     printLts (Lts major minor _) =
         "lts-" ++ show major ++ "." ++ show minor
 
+    printNightly (Entity _ (Nightly day _ _)) =
+        "nightly-" ++ tshow day
+    getLatestNightly = selectFirst [] [Desc NightlyDay]
+
 -- TODO: add this to db
 ltsGhcMajorVersion :: Stackage -> Text
 ltsGhcMajorVersion _ = "7.8"