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/Types.hs b/Types.hs index 051c29e..951f0fe 100644 --- a/Types.hs +++ b/Types.hs @@ -1,11 +1,16 @@ module Types where import ClassyPrelude.Yesod +import Data.Aeson 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 +import qualified Data.Text.Lazy.Builder.Int as Builder +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Text.Lazy as LText +import qualified Data.Text.Read as Reader newtype PackageName = PackageName { unPackageName :: Text } deriving (Show, Read, Typeable, Eq, Ord, Hashable, PathPiece, ToMarkup, PersistField, IsString) @@ -118,7 +123,42 @@ instance PathPiece StackageExecutable where fromPathPiece "stackage-setup.exe" = Just StackageWindowsExecutable fromPathPiece _ = Nothing -type GhcMajorVersion = Text +data GhcMajorVersion = GhcMajorVersion !Int !Int + deriving (Eq) + +ghcMajorVersionToText :: GhcMajorVersion -> Text +ghcMajorVersionToText (GhcMajorVersion a b) + = LText.toStrict + $ Builder.toLazyText + $ Builder.decimal a <> "." <> Builder.decimal b + +ghcMajorVersionFromText :: MonadPlus m => Text -> m GhcMajorVersion +ghcMajorVersionFromText t = case Reader.decimal t of + Right (a, T.uncons -> Just ('.', t')) -> case Reader.decimal t' of + Right (b, t'') | T.null t'' -> return $ GhcMajorVersion a b + _ -> mzero + _ -> mzero + +instance PersistFieldSql GhcMajorVersion where + sqlType = sqlType . liftM ghcMajorVersionToText + +instance PersistField GhcMajorVersion where + toPersistValue = toPersistValue . ghcMajorVersionToText + fromPersistValue v = do + t <- fromPersistValueText v + case ghcMajorVersionFromText t of + Just ver -> return ver + Nothing -> Left $ "Cannot convert to GhcMajorVersion: " <> t + +instance Hashable GhcMajorVersion where + hashWithSalt = hashUsing ghcMajorVersionToText + +instance FromJSON GhcMajorVersion where + parseJSON = withText "GhcMajorVersion" ghcMajorVersionFromText + +instance ToJSON GhcMajorVersion where + toJSON = toJSON . ghcMajorVersionToText + data SupportedArch = Win32 diff --git a/config/models b/config/models index e4cc69b..acc4aab 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