Merge pull request #100 from fpco/ghc-major-version

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 verText = ghcMajorVersionToText ver
-        let path = dir
+            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
+-- Print the ghc major version for the given snapshot.
-ltsGhcMajorVersion :: Stackage -> Text
+-- Assumes 7.8 if unspecified
-ltsGhcMajorVersion _ = "7.8"
+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

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

config/models

@@ -23,6 +23,7 @@ Stackage
     title Text
     desc Text
     hasHaddocks Bool default=false
+    ghcMajorVersion GhcMajorVersion Maybe
     UniqueStackage ident
     UniqueSnapshot slug