From c8375876092911faeeb145f3985f393515eeb1f1 Mon Sep 17 00:00:00 2001
From: Dan Burton <danburton.email@gmail.com>
Date: Wed, 15 Apr 2015 18:26:26 -0700
Subject: [PATCH] Add sketch of 'environment.json' and 'lts-snapshots.json'

---
 Handler/Alias.hs      |  2 ++
 Handler/Download.hs   | 59 ++++++++++++++++++++++++++++++++++++++-----
 Handler/Sitemap.hs    |  2 ++
 config/routes         |  2 ++
 stackage-server.cabal |  1 +
 5 files changed, 59 insertions(+), 7 deletions(-)

diff --git a/Handler/Alias.hs b/Handler/Alias.hs
index ad6179f..5829dd9 100644
--- a/Handler/Alias.hs
+++ b/Handler/Alias.hs
@@ -11,6 +11,7 @@ import Handler.StackageIndex (getStackageIndexR)
 import Handler.StackageSdist (getStackageSdistR)
 import Handler.Hoogle (getHoogleR, getHoogleDatabaseR)
 import Handler.BuildPlan (getBuildPlanR)
+import Handler.Download (getDownloadEnvironmentJsonR)
 
 handleAliasR :: Slug -> Slug -> [Text] -> Handler ()
 handleAliasR user name pieces = do
@@ -81,4 +82,5 @@ goSid sid pieces = do
                 HoogleR -> getHoogleR slug >>= sendResponse
                 HoogleDatabaseR -> getHoogleDatabaseR slug >>= sendResponse
                 BuildPlanR -> getBuildPlanR slug >>= sendResponse
+                DownloadEnvironmentJsonR arch -> getDownloadEnvironmentJsonR slug arch >>= sendResponse
         _ -> notFound
diff --git a/Handler/Download.hs b/Handler/Download.hs
index 323d66b..2b804dd 100644
--- a/Handler/Download.hs
+++ b/Handler/Download.hs
@@ -1,9 +1,12 @@
 module Handler.Download
   ( getDownloadR
   , getDownloadStackageExecutableR
+  , getDownloadLtsSnapshotsJsonR
+  , getDownloadEnvironmentJsonR
   ) where
 
 import Import
+import Data.Slug (SnapSlug)
 
 executableFor :: SupportedArch -> StackageExecutable
 executableFor Win32 = StackageWindowsExecutable
@@ -12,17 +15,59 @@ executableFor _ = StackageUnixExecutable
 
 downloadCandidates :: [(SupportedArch, StackageExecutable)]
 downloadCandidates =
-  map (\arch -> (arch, executableFor arch))
-      [minBound .. maxBound]
+    map (\arch -> (arch, executableFor arch))
+        [minBound .. maxBound]
 
 getDownloadR :: Handler Html
 getDownloadR = defaultLayout $ do
-  $(widgetFile "download")
+    $(widgetFile "download")
 
 getDownloadStackageExecutableR
   :: SupportedArch -> StackageExecutable -> Handler Html
 getDownloadStackageExecutableR arch exe = do
-  -- TODO: send exeutable file instead
-  when (executableFor arch /= exe) notFound
-  defaultLayout $ do
-    $(widgetFile "downloadExe")
+    -- TODO: send exeutable file instead
+    when (executableFor arch /= exe) notFound
+    defaultLayout $ do
+        $(widgetFile "downloadExe")
+
+ltsMajorVersions :: Handler [Lts]
+ltsMajorVersions = liftM (map entityVal) $ runDB $ do
+  mapWhileIsJustM [0..] $ \x -> do
+    selectFirst [LtsMajor ==. x] [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
+
+getDownloadLtsSnapshotsJsonR :: Handler Value
+getDownloadLtsSnapshotsJsonR = liftM reverse ltsMajorVersions >>= \case
+    [] -> return $ object []
+    majorVersions@(latest:_) -> return $ object
+         $ ["lts" .= printLts latest]
+        ++ map toObj majorVersions
+  where
+    toObj lts@(Lts major _ _) =
+        pack ("lts-" ++ show major) .= printLts lts
+    printLts (Lts major minor _) =
+        "lts-" ++ show major ++ "." ++ show minor
+
+getDownloadEnvironmentJsonR :: SnapSlug -> SupportedArch -> Handler Value
+getDownloadEnvironmentJsonR _slug Linux64 = do
+    -- TODO: dynamic generation based on db entries
+    let ghc = object
+            [ "version" .= asText "7.8.4"
+            , "url" .= asText "http://www.haskell.org/ghc/dist/7.8.4/ghc-7.8.4-x86_64-unknown-linux-deb7.tar.xz"
+            , "sha1" .= asText "11aec12d4bb27f6fa59dcc8535a7a3b3be8cb787"
+            ]
+        cabal = object
+            [ "version" .= asText "1.20.0.3"
+            , "url" .= asText "http://www.haskell.org/cabal/release/cabal-install-1.20.0.3/cabal-1.20.0.3-i386-unknown-linux.tar.gz"
+            , "sha1" .= asText "647ae3e561343a709b09ed70fa6bc7b1ce39e25b"
+            ]
+    return $ object
+        [ "ghc" .= ghc
+        , "cabal" .= cabal
+        ]
+getDownloadEnvironmentJsonR _slug _arch = notFound
diff --git a/Handler/Sitemap.hs b/Handler/Sitemap.hs
index 004dd56..effb727 100644
--- a/Handler/Sitemap.hs
+++ b/Handler/Sitemap.hs
@@ -13,6 +13,8 @@ getSitemapR = sitemap $ do
     priority 1.0 $ HomeR
 
     priority 0.9 $ LtsR []
+    -- TODO: uncomment when this is presentable
+    --priority 0.9 $ DownloadR
     priority 0.8 $ NightlyR []
 
     priority 0.7 $ AllSnapshotsR
diff --git a/config/routes b/config/routes
index b851e28..10bc9e7 100644
--- a/config/routes
+++ b/config/routes
@@ -28,6 +28,7 @@
     /hoogle HoogleR GET
     /db.hoo HoogleDatabaseR GET
     /build-plan BuildPlanR GET
+    /download/#SupportedArch/environment.json DownloadEnvironmentJsonR GET
 
 /aliases AliasesR PUT
 /alias/#Slug/#Slug/*Texts AliasR
@@ -60,3 +61,4 @@
 
 /download DownloadR GET
 /download/#SupportedArch/#StackageExecutable DownloadStackageExecutableR GET
+/download/lts-snapshots.json DownloadLtsSnapshotsJsonR GET
diff --git a/stackage-server.cabal b/stackage-server.cabal
index 7bfdda2..381e758 100644
--- a/stackage-server.cabal
+++ b/stackage-server.cabal
@@ -91,6 +91,7 @@ library
                 DeriveFunctor
                 DeriveFoldable
                 DeriveTraversable
+                LambdaCase
 
     build-depends:
                     base                          >= 4