From 025782be8d95f93e56607ce5d5d1cf06804cac8e Mon Sep 17 00:00:00 2001 From: Dan Burton Date: Fri, 1 May 2015 21:28:37 -0700 Subject: [PATCH] Add ghc-major-version to Stackage table #88 --- Data/GhcLinks.hs | 6 ++++-- Handler/Download.hs | 16 +++++++++++----- Handler/UploadStackage.hs | 1 + Handler/UploadV2.hs | 13 ++++++++++--- Model.hs | 28 ++++++++++++++++++++++++++++ Types.hs | 1 - config/models | 6 ++++++ 7 files changed, 60 insertions(+), 11 deletions(-) diff --git a/Data/GhcLinks.hs b/Data/GhcLinks.hs index 97859a9..02533dc 100644 --- a/Data/GhcLinks.hs +++ b/Data/GhcLinks.hs @@ -10,6 +10,7 @@ import qualified Data.Yaml as Yaml import Filesystem (readTextFile, isFile) import Types +import Model newtype GhcLinks = GhcLinks @@ -32,8 +33,9 @@ readGhcLinks dir = do ] hashMap <- flip execStateT HashMap.empty $ forM_ opts $ \(arch, ver) -> do - let fileName = "ghc-" <> ver <> "-links.yaml" - let path = dir + let verText = ghcMajorVersionToText ver + fileName = "ghc-" <> verText <> "-links.yaml" + path = dir fpFromText (toPathPiece arch) fpFromText fileName whenM (liftIO $ isFile path) $ do diff --git a/Handler/Download.hs b/Handler/Download.hs index 3098cc6..1f341cc 100644 --- a/Handler/Download.hs +++ b/Handler/Download.hs @@ -75,19 +75,25 @@ getDownloadLtsSnapshotsJsonR = do "nightly-" ++ tshow day getLatestNightly = selectFirst [] [Desc NightlyDay] --- TODO: add this to db -ltsGhcMajorVersion :: Stackage -> Text -ltsGhcMajorVersion _ = "7.8" +-- Print the ghc major version for the given snapshot. +-- Assumes 7.8 if unspecified +ghcMajorVersionText :: Stackage -> Text +ghcMajorVersionText snapshot + = ghcMajorVersionToText + $ fromMaybe (GhcMajorVersion 7 8) + $ stackageGhcMajorVersion snapshot getGhcMajorVersionR :: SnapSlug -> Handler Text getGhcMajorVersionR slug = do snapshot <- runDB $ getBy404 $ UniqueSnapshot slug - return $ ltsGhcMajorVersion $ entityVal snapshot + return $ ghcMajorVersionText $ entityVal snapshot getDownloadGhcLinksR :: SupportedArch -> Text -> Handler TypedContent getDownloadGhcLinksR arch fileName = do ver <- maybe notFound return - $ stripPrefix "ghc-" >=> stripSuffix "-links.yaml" + $ stripPrefix "ghc-" + >=> stripSuffix "-links.yaml" + >=> ghcMajorVersionFromText $ fileName ghcLinks <- getYesod >>= fmap wcGhcLinks . liftIO . grContent . websiteContent case lookup (arch, ver) (ghcLinksMap ghcLinks) of diff --git a/Handler/UploadStackage.hs b/Handler/UploadStackage.hs index f1a8328..3ee8fa0 100644 --- a/Handler/UploadStackage.hs +++ b/Handler/UploadStackage.hs @@ -139,6 +139,7 @@ putUploadStackageR = do , stackageDesc = "No description provided" , stackageHasHaddocks = False , stackageSlug = baseSlug + , stackageGhcMajorVersion = Nothing -- Assumption: this file is deprecated } -- Evil lazy I/O thanks to tar package diff --git a/Handler/UploadV2.hs b/Handler/UploadV2.hs index 9ab9064..a04a37d 100644 --- a/Handler/UploadV2.hs +++ b/Handler/UploadV2.hs @@ -21,6 +21,7 @@ import Filesystem (createTree) import Filesystem.Path (parent) import Data.Conduit.Process import Data.Yaml (decodeEither') +import Distribution.Version (versionBranch) putUploadV2R :: Handler TypedContent putUploadV2R = do @@ -116,7 +117,11 @@ doUpload status uid ident bundleFP = do now <- liftIO getCurrentTime let day = tshow $ utctDay now - let ghcVersion = display $ siGhcVersion $ bpSystemInfo siPlan + let theSiGhcVersion = siGhcVersion $ bpSystemInfo siPlan + ghcVersion = display theSiGhcVersion + ghcMajorVersionMay = case versionBranch theSiGhcVersion of + (a:b:_) -> Just (GhcMajorVersion a b) + _ -> Nothing slug' = case siType of STNightly -> "nightly-" ++ day @@ -154,7 +159,7 @@ doUpload status uid ident bundleFP = do say "Snapshot already exists" return $ SnapshotR slug StackageHomeR Nothing -> finishUpload - title ident ghcVersion slug now siType siPlan siDocMap + title ident ghcVersion ghcMajorVersionMay slug now siType siPlan siDocMap uid say render <- getUrlRender return $ render route @@ -165,6 +170,7 @@ finishUpload :: Text -> PackageSetIdent -> Text + -> Maybe GhcMajorVersion -> SnapSlug -> UTCTime -> SnapshotType @@ -174,7 +180,7 @@ finishUpload -> (Text -> Handler ()) -> Handler (Route App) finishUpload - title ident ghcVersion slug now siType siPlan siDocMap + title ident ghcVersion ghcMajorVersionMay slug now siType siPlan siDocMap uid say = do say "Creating index tarball" withSystemTempDirectory "buildindex.v2" $ \(fpFromString -> dir) -> do @@ -228,6 +234,7 @@ finishUpload , stackageTitle = title , stackageDesc = "" , stackageHasHaddocks = True + , stackageGhcMajorVersion = ghcMajorVersionMay } case siType of STNightly -> insert_ Nightly diff --git a/Model.hs b/Model.hs index 8df0423..693366b 100644 --- a/Model.hs +++ b/Model.hs @@ -2,7 +2,10 @@ module Model where import ClassyPrelude.Yesod import Database.Persist.Quasi +import Data.Aeson +import Data.Hashable (hashUsing) import Data.Slug (Slug, SnapSlug) +import qualified Data.Text as Text import Types -- You can define all of your database entities in the entities file. @@ -11,3 +14,28 @@ import Types -- http://www.yesodweb.com/book/persistent/ share [mkPersist sqlSettings, mkMigrate "migrateAll"] $(persistFileWith lowerCaseSettings "config/models") + + +ghcMajorVersionToText :: GhcMajorVersion -> Text +ghcMajorVersionToText (GhcMajorVersion major minor) + = pack (show major) <> "." <> pack (show minor) + +ghcMajorVersionFromText :: Text -> Maybe GhcMajorVersion +ghcMajorVersionFromText t = case Text.splitOn "." t of + [readMay -> Just major, readMay -> Just minor] -> + Just $ GhcMajorVersion major minor + _ -> Nothing + +instance Hashable GhcMajorVersion where + hashWithSalt = hashUsing ghcMajorVersionToText + +instance Eq GhcMajorVersion where + (GhcMajorVersion a b) == (GhcMajorVersion a' b') = + a == a' && b == b' + +instance FromJSON GhcMajorVersion where + parseJSON = withText "GhcMajorVersion" $ + maybe mzero return . ghcMajorVersionFromText + +instance ToJSON GhcMajorVersion where + toJSON = toJSON . ghcMajorVersionToText diff --git a/Types.hs b/Types.hs index 051c29e..502baab 100644 --- a/Types.hs +++ b/Types.hs @@ -118,7 +118,6 @@ instance PathPiece StackageExecutable where fromPathPiece "stackage-setup.exe" = Just StackageWindowsExecutable fromPathPiece _ = Nothing -type GhcMajorVersion = Text data SupportedArch = Win32 diff --git a/config/models b/config/models index e4cc69b..3312cc7 100644 --- a/config/models +++ b/config/models @@ -23,6 +23,7 @@ Stackage title Text desc Text hasHaddocks Bool default=false + ghcMajorVersion GhcMajorVersion Maybe UniqueStackage ident UniqueSnapshot slug @@ -131,3 +132,8 @@ Suggested UploadProgress message Text dest Text Maybe + +GhcMajorVersion + major Int + minor Int + UniqueGhcMajorVersion major minor