diff --git a/Application.hs b/Application.hs index 78fd8e8..dd07e0e 100644 --- a/Application.hs +++ b/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 diff --git a/Data/GhcLinks.hs b/Data/GhcLinks.hs new file mode 100644 index 0000000..99204aa --- /dev/null +++ b/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 diff --git a/Data/WebsiteContent.hs b/Data/WebsiteContent.hs index 43e64a4..ed877bd 100644 --- a/Data/WebsiteContent.hs +++ b/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) diff --git a/Handler/Alias.hs b/Handler/Alias.hs index ad6179f..235492c 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 (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 diff --git a/Handler/Download.hs b/Handler/Download.hs new file mode 100644 index 0000000..e9fe7c4 --- /dev/null +++ b/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" 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/Types.hs b/Types.hs index ed79874..051c29e 100644 --- a/Types.hs +++ b/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 diff --git a/config/routes b/config/routes index 9fc3c7a..64bb56f 100644 --- a/config/routes +++ b/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 diff --git a/stackage-server.cabal b/stackage-server.cabal index b07b75d..34495eb 100644 --- a/stackage-server.cabal +++ b/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 diff --git a/templates/download.hamlet b/templates/download.hamlet new file mode 100644 index 0000000..1d0e2c8 --- /dev/null +++ b/templates/download.hamlet @@ -0,0 +1,21 @@ +

Warning: pre-release + +

The following executable is considered experimental. +

More operating systems and architectures will be supported upon official release. + +

Download +$forall (arch, exe) <- downloadCandidates +