Merge pull request #92 from fpco/download-handler

Download handler

Application.hs

@@ -74,6 +74,7 @@ import           Handler.BuildVersion
 import           Handler.PackageCounts
 import           Handler.Sitemap
 import           Handler.BuildPlan
+import           Handler.Download
 
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the

Data/GhcLinks.hs

@@ -0,0 +1,41 @@
+module Data.GhcLinks
+  ( GhcLinks(..)
+  , readGhcLinks
+  ) where
+
+import ClassyPrelude.Yesod
+import Control.Monad.State.Strict (modify, execStateT)
+import qualified Data.HashMap.Strict as HashMap
+import Filesystem (readTextFile, isFile)
+
+import Types
+
+
+newtype GhcLinks = GhcLinks
+  { ghcLinksMap :: HashMap (SupportedArch, GhcMajorVersion) Text }
+  -- ^ a map from (arch, ver) to yaml
+
+supportedArches :: [SupportedArch]
+supportedArches = [minBound .. maxBound]
+
+supportedGhcMajorVersions :: [GhcMajorVersion]
+supportedGhcMajorVersions = ["7.8"]
+
+
+readGhcLinks :: FilePath -> IO GhcLinks
+readGhcLinks dir = do
+  let opts =
+        [ (arch, ver)
+        | arch <- supportedArches
+        , ver <- supportedGhcMajorVersions
+        ]
+  hashMap <- flip execStateT HashMap.empty
+           $ forM_ opts $ \(arch, ver) -> do
+    let fileName = "ghc-" <> ver <> "-links.yaml"
+    let path = dir
+          </> fpFromText (toPathPiece arch)
+          </> fpFromText fileName
+    whenM (liftIO $ isFile path) $ do
+      text <- liftIO $ readTextFile path
+      modify (HashMap.insert (arch, ver) text)
+  return $ GhcLinks hashMap

Data/WebsiteContent.hs

@@ -5,12 +5,14 @@ module Data.WebsiteContent
 
 import ClassyPrelude.Yesod
 import Text.Markdown (markdown, msXssProtect, msAddHeadingId)
+import Data.GhcLinks
 
 data WebsiteContent = WebsiteContent
     { wcHomepage :: !Html
     , wcAuthors  :: !Html
     , wcInstall  :: !Html
     , wcOlderReleases :: !Html
+    , wcGhcLinks :: !GhcLinks
     }
 
 loadWebsiteContent :: FilePath -> IO WebsiteContent
@@ -20,6 +22,7 @@ loadWebsiteContent dir = do
     wcInstall <- readMarkdown "install.md"
     wcOlderReleases <- readHtml "older-releases.html" `catchIO`
                     \_ -> readMarkdown "older-releases.md"
+    wcGhcLinks <- readGhcLinks $ dir </> "stackage-cli"
     return WebsiteContent {..}
   where
     readHtml fp = fmap (preEscapedToMarkup . decodeUtf8 :: ByteString -> Html)

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 (getGhcMajorVersionR)
 
 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
+                GhcMajorVersionR -> getGhcMajorVersionR slug >>= sendResponse
         _ -> notFound

Handler/Download.hs

@@ -0,0 +1,79 @@
+module Handler.Download
+  ( getDownloadR
+  , getDownloadLtsSnapshotsJsonR
+  , getGhcMajorVersionR
+  , getDownloadGhcLinksR
+  ) where
+
+import Import
+import Data.Slug (SnapSlug)
+import Data.GhcLinks
+import Yesod.GitRepo (grContent)
+
+executableFor :: SupportedArch -> StackageExecutable
+executableFor Win32 = StackageWindowsExecutable
+executableFor Win64 = StackageWindowsExecutable
+executableFor _ = StackageUnixExecutable
+
+-- TODO: link to s3
+executableLink :: SupportedArch -> StackageExecutable -> Text
+executableLink arch exe =
+    "https://s3.amazonaws.com/download.fpcomplete.com/stackage-cli/"
+    <> toPathPiece arch <> "/" <> toPathPiece exe
+
+downloadCandidates :: [(SupportedArch, StackageExecutable)]
+downloadCandidates =
+    map (\arch -> (arch, executableFor arch))
+        [minBound .. maxBound]
+
+currentlySupported :: SupportedArch -> Bool
+currentlySupported Linux64 = True
+currentlySupported _ = False
+
+getDownloadR :: Handler Html
+getDownloadR = defaultLayout $ do
+    $(widgetFile "download")
+
+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
+
+-- TODO: add this to db
+ltsGhcMajorVersion :: Stackage -> Text
+ltsGhcMajorVersion _ = "7.8"
+
+getGhcMajorVersionR :: SnapSlug -> Handler Text
+getGhcMajorVersionR slug = do
+  snapshot <- runDB $ getBy404 $ UniqueSnapshot slug
+  return $ ltsGhcMajorVersion $ entityVal snapshot
+
+getDownloadGhcLinksR :: SupportedArch -> Text -> Handler TypedContent
+getDownloadGhcLinksR arch fileName = do
+  ver <- maybe notFound return
+       $ stripPrefix "ghc-" >=> stripSuffix "-links.yaml"
+       $ fileName
+  ghcLinks <- getYesod >>= fmap wcGhcLinks . liftIO . grContent . websiteContent
+  case lookup (arch, ver) (ghcLinksMap ghcLinks) of
+    Just text -> return $ TypedContent yamlMimeType $ toContent text
+    Nothing -> notFound
+  where
+    yamlMimeType = "text/yaml"

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

Types.hs

@@ -2,6 +2,7 @@ module Types where
 
 import ClassyPrelude.Yesod
 import Data.BlobStore (ToPath (..), BackupToS3 (..))
+import Data.Hashable (hashUsing)
 import Text.Blaze (ToMarkup)
 import Database.Persist.Sql (PersistFieldSql (sqlType))
 import qualified Data.Text as T
@@ -102,3 +103,47 @@ instance HasHackageRoot HackageRoot where
 data UnpackStatus = USReady
                   | USBusy
                   | USFailed !Text
+
+data StackageExecutable
+    = StackageWindowsExecutable
+    | StackageUnixExecutable
+    deriving (Show, Read, Eq)
+
+instance PathPiece StackageExecutable where
+    -- TODO: distribute stackage, not just stackage-setup
+    toPathPiece StackageWindowsExecutable = "stackage-setup.exe"
+    toPathPiece StackageUnixExecutable = "stackage-setup"
+
+    fromPathPiece "stackage-setup" = Just StackageUnixExecutable
+    fromPathPiece "stackage-setup.exe" = Just StackageWindowsExecutable
+    fromPathPiece _ = Nothing
+
+type GhcMajorVersion = Text
+
+data SupportedArch
+    = Win32
+    | Win64
+    | Linux32
+    | Linux64
+    | Mac32
+    | Mac64
+    deriving (Enum, Bounded, Show, Read, Eq)
+
+instance Hashable SupportedArch where
+    hashWithSalt = hashUsing fromEnum
+
+instance PathPiece SupportedArch where
+    toPathPiece Win32 = "win32"
+    toPathPiece Win64 = "win64"
+    toPathPiece Linux32 = "linux32"
+    toPathPiece Linux64 = "linux64"
+    toPathPiece Mac32 = "mac32"
+    toPathPiece Mac64 = "mac64"
+
+    fromPathPiece "win32" = Just Win32
+    fromPathPiece "win64" = Just Win64
+    fromPathPiece "linux32" = Just Linux32
+    fromPathPiece "linux64" = Just Linux64
+    fromPathPiece "mac32" = Just Mac32
+    fromPathPiece "mac64" = Just Mac64
+    fromPathPiece _ = Nothing

config/routes

@@ -28,6 +28,7 @@
     /hoogle HoogleR GET
     /db.hoo HoogleDatabaseR GET
     /build-plan BuildPlanR GET
+    /ghc-major-version GhcMajorVersionR GET
 
 /aliases AliasesR PUT
 /alias/#Slug/#Slug/*Texts AliasR
@@ -57,3 +58,7 @@
 /upload2 UploadV2R PUT
 /build-version BuildVersionR GET
 /package-counts PackageCountsR GET
+
+/download DownloadR GET
+/download/lts-snapshots.json DownloadLtsSnapshotsJsonR GET
+/download/#SupportedArch/#Text DownloadGhcLinksR GET

stackage-server.cabal

@@ -23,6 +23,7 @@ library
                      Data.Slug
                      Data.Tag
                      Data.BlobStore
+                     Data.GhcLinks
                      Data.Hackage
                      Data.Hackage.DeprecationInfo
                      Data.WebsiteContent
@@ -54,6 +55,7 @@ library
                      Handler.PackageCounts
                      Handler.Sitemap
                      Handler.BuildPlan
+                     Handler.Download
 
     if flag(dev) || flag(library-only)
         cpp-options:   -DDEVELOPMENT
@@ -90,6 +92,7 @@ library
                 DeriveFunctor
                 DeriveFoldable
                 DeriveTraversable
+                LambdaCase
 
     build-depends:
                     base                          >= 4
@@ -143,6 +146,7 @@ library
                   , yesod-static                  >= 1.2
                   , zlib
                   , unordered-containers
+                  , hashable
                  -- Avoid https://github.com/haskell/cabal/issues/1202
                  , Cabal >= 1.18
                  , lifted-base

templates/download.hamlet

@@ -0,0 +1,21 @@
+<h1>Warning: pre-release
+
+<p>The following executable is considered experimental.
+<p>More operating systems and architectures will be supported upon official release.
+
+<h1>Download
+$forall (arch, exe) <- downloadCandidates
+  <ul .downloads>
+    $if currentlySupported arch
+      <li>
+        #{toPathPiece arch}:
+        <a href=#{executableLink arch exe}>
+          #{toPathPiece exe}
+
+<h1>What is stackage-setup?
+
+<p>The stackage-setup executable is an easy way to download and set up the basic executables needed for developing Haskell.
+<p>After running stackage-setup, You can find these executables in:
+<code>~/.stackage/environment/$group/$group-$version/bin/
+<p>For example, ghc, ghc-pkg, haddock, etc for ghc-7.8.4 are installed here:
+<code>~/.stackage/environment/ghc/ghc-7.8.4/bin/