Add ghc-major-version to Stackage table #88

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

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

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

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

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

Types.hs

@@ -118,7 +118,6 @@ instance PathPiece StackageExecutable where
     fromPathPiece "stackage-setup.exe" = Just StackageWindowsExecutable
     fromPathPiece _ = Nothing
 
-type GhcMajorVersion = Text
 
 data SupportedArch
     = Win32

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