From 025782be8d95f93e56607ce5d5d1cf06804cac8e Mon Sep 17 00:00:00 2001 From: Dan Burton Date: Fri, 1 May 2015 21:28:37 -0700 Subject: [PATCH 1/3] 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 From f37f112e8f29c0f4e874a29d5c3661e7fcdd8fe2 Mon Sep 17 00:00:00 2001 From: Dan Burton Date: Fri, 1 May 2015 22:08:09 -0700 Subject: [PATCH 2/3] GhcMajorVersion doesn't need a table. --- Model.hs | 28 ---------------------------- Types.hs | 35 +++++++++++++++++++++++++++++++++++ config/models | 5 ----- 3 files changed, 35 insertions(+), 33 deletions(-) diff --git a/Model.hs b/Model.hs index 693366b..8df0423 100644 --- a/Model.hs +++ b/Model.hs @@ -2,10 +2,7 @@ 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. @@ -14,28 +11,3 @@ 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 502baab..4035611 100644 --- a/Types.hs +++ b/Types.hs @@ -1,6 +1,7 @@ module Types where import ClassyPrelude.Yesod +import Data.Aeson import Data.BlobStore (ToPath (..), BackupToS3 (..)) import Data.Hashable (hashUsing) import Text.Blaze (ToMarkup) @@ -118,6 +119,40 @@ instance PathPiece StackageExecutable where fromPathPiece "stackage-setup.exe" = Just StackageWindowsExecutable fromPathPiece _ = Nothing +data GhcMajorVersion = GhcMajorVersion Int Int + deriving (Eq) + +ghcMajorVersionToText :: GhcMajorVersion -> Text +ghcMajorVersionToText (GhcMajorVersion a b) + = pack (show a) <> "." <> pack (show b) + +ghcMajorVersionFromText :: Text -> Maybe GhcMajorVersion +ghcMajorVersionFromText t = case T.splitOn "." t of + [readMay -> Just a, readMay -> Just b] -> + Just $ GhcMajorVersion a b + _ -> Nothing + +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" $ + maybe mzero return . ghcMajorVersionFromText + +instance ToJSON GhcMajorVersion where + toJSON = toJSON . ghcMajorVersionToText + data SupportedArch = Win32 diff --git a/config/models b/config/models index 3312cc7..acc4aab 100644 --- a/config/models +++ b/config/models @@ -132,8 +132,3 @@ Suggested UploadProgress message Text dest Text Maybe - -GhcMajorVersion - major Int - minor Int - UniqueGhcMajorVersion major minor From 04f649b5da5146a6f70868a14437450e155ca9a1 Mon Sep 17 00:00:00 2001 From: Dan Burton Date: Mon, 4 May 2015 10:07:57 -0700 Subject: [PATCH 3/3] Tweak GhcMajorVersion impl --- Types.hs | 24 +++++++++++++++--------- 1 file changed, 15 insertions(+), 9 deletions(-) diff --git a/Types.hs b/Types.hs index 4035611..951f0fe 100644 --- a/Types.hs +++ b/Types.hs @@ -7,6 +7,10 @@ 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) @@ -119,18 +123,21 @@ instance PathPiece StackageExecutable where fromPathPiece "stackage-setup.exe" = Just StackageWindowsExecutable fromPathPiece _ = Nothing -data GhcMajorVersion = GhcMajorVersion Int Int +data GhcMajorVersion = GhcMajorVersion !Int !Int deriving (Eq) ghcMajorVersionToText :: GhcMajorVersion -> Text ghcMajorVersionToText (GhcMajorVersion a b) - = pack (show a) <> "." <> pack (show b) + = LText.toStrict + $ Builder.toLazyText + $ Builder.decimal a <> "." <> Builder.decimal b -ghcMajorVersionFromText :: Text -> Maybe GhcMajorVersion -ghcMajorVersionFromText t = case T.splitOn "." t of - [readMay -> Just a, readMay -> Just b] -> - Just $ GhcMajorVersion a b - _ -> Nothing +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 @@ -147,8 +154,7 @@ instance Hashable GhcMajorVersion where hashWithSalt = hashUsing ghcMajorVersionToText instance FromJSON GhcMajorVersion where - parseJSON = withText "GhcMajorVersion" $ - maybe mzero return . ghcMajorVersionFromText + parseJSON = withText "GhcMajorVersion" ghcMajorVersionFromText instance ToJSON GhcMajorVersion where toJSON = toJSON . ghcMajorVersionToText