9d065d8 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Add git tag time to psc-publish JSON

This is done in a backwards-compatible way by making the time in the Package time a Maybe UTCTime. Later we can change this to just a UTCTime. Prerequisite for addressing https://github.com/purescript/pursuit/issues/216

commit9d065d8f4db319af33d3b6feb2b3b91539921e3c authorHarry Garrood <harry@garrood.me> dateFri 6 Jan 2017, 22:18 (10 years ago) parent2e2b337

5 files changed+71−11

compare with golang

unifiedsplit

src/Language/PureScript/Docs/Types.hs+44−5 src/Language/PureScript/Publish.hs+13−2 src/Language/PureScript/Publish/ErrorsWarnings.hs+4 tests/TestDocs.hs+7−4 tests/TestPscPublish.hs+3

src/Language/PureScript/Docs/Types.hs+44−5

@@ -10,17 +10,19 @@ import Control.Arrow (first, (***))

1010import Control.Monad (when)

1111import Control.Monad.Error.Class (catchError)

1212

13−import Data.Monoid ((<>))

1413import Data.Aeson ((.=))

1514import Data.Aeson.BetterErrors

1615import Data.ByteString.Lazy (ByteString)

1716import Data.Either (isLeft, isRight)

18−import Data.Maybe (mapMaybe, fromMaybe)

17+import Data.Maybe (mapMaybe, fromMaybe, maybeToList)

18+import Data.Monoid ((<>))

1919import Data.Text (Text)

20+import Data.Time.Clock (UTCTime)

21+import qualified Data.Time.Format as TimeFormat

2022import Data.Version

21−import qualified Data.Vector as V

2223import qualified Data.Aeson as A

2324import qualified Data.Text as T

25+import qualified Data.Vector as V

2426

2527import qualified Language.PureScript as P

2628

@@ -40,6 +42,10 @@ data Package a = Package

4042 { pkgMeta :: PackageMeta

4143 , pkgVersion :: Version

4244 , pkgVersionTag :: Text

45+ -- TODO: When this field was introduced, it was given the Maybe type for the

46+ -- sake of backwards compatibility, as older JSON blobs will not include the

47+ -- field. It should eventually be changed to just UTCTime.

48+ , pkgTagTime :: Maybe UTCTime

4349 , pkgModules :: [Module]

4450 , pkgBookmarks :: [Bookmark]

4551 , pkgResolvedDependencies :: [(PackageName, Version)]

@@ -62,6 +68,7 @@ verifyPackage verifiedUser Package{..} =

6268 Package pkgMeta

6369 pkgVersion

6470 pkgVersionTag

71+ pkgTagTime

6572 pkgModules

6673 pkgBookmarks

6774 pkgResolvedDependencies

@@ -72,6 +79,29 @@ verifyPackage verifiedUser Package{..} =

7279packageName :: Package a -> PackageName

7380packageName = bowerName . pkgMeta

7481

82+-- |

83+-- The time format used for serializing package tag times in the JSON format.

84+-- This is the ISO 8601 date format which includes a time and a timezone.

85+--

86+jsonTimeFormat :: String

87+jsonTimeFormat = "%Y-%m-%dT%H:%M:%S%z"

88+

89+-- |

90+-- Convenience function for formatting a time in the format expected by this

91+-- module.

92+--

93+formatTime :: UTCTime -> String

94+formatTime =

95+ TimeFormat.formatTime TimeFormat.defaultTimeLocale jsonTimeFormat

96+

97+-- |

98+-- Convenience function for parsing a time in the format expected by this

99+-- module.

100+--

101+parseTime :: String -> Maybe UTCTime

102+parseTime =

103+ TimeFormat.parseTimeM False TimeFormat.defaultTimeLocale jsonTimeFormat

104+

75105data Module = Module

76106 { modName :: P.ModuleName

77107 , modComments :: Maybe Text

@@ -275,6 +305,7 @@ data PackageError

275305 | InvalidFixity

276306 | InvalidKind Text

277307 | InvalidDataDeclType Text

308+ | InvalidTime

278309 deriving (Show, Eq, Ord)

279310

280311type Bookmark = InPackage (P.ModuleName, Text)

@@ -320,6 +351,7 @@ asPackage minimumVersion uploader = do

320351 Package <$> key "packageMeta" asPackageMeta .! ErrorInPackageMeta

321352 <*> key "version" asVersion

322353 <*> key "versionTag" asText

354+ <*> keyMay "tagTime" (withString parseTimeEither)

323355 <*> key "modules" (eachInArray asModule)

324356 <*> key "bookmarks" asBookmarks .! ErrorInPackageMeta

325357 <*> key "resolvedDependencies" asResolvedDependencies

@@ -327,6 +359,10 @@ asPackage minimumVersion uploader = do

327359 <*> key "uploader" uploader

328360 <*> pure compilerVersion

329361

362+parseTimeEither :: String -> Either PackageError UTCTime

363+parseTimeEither =

364+ maybe (Left InvalidTime) Right . parseTime

365+

330366asUploadedPackage :: Version -> Parse PackageError UploadedPackage

331367asUploadedPackage minVersion = asPackage minVersion asNotYetKnown

332368

@@ -359,6 +395,8 @@ displayPackageError e = case e of

359395 "Invalid kind: \"" <> str <> "\""

360396 InvalidDataDeclType str ->

361397 "Invalid data declaration type: \"" <> str <> "\""

398+ InvalidTime ->

399+ "Invalid time"

362400

363401instance A.FromJSON a => A.FromJSON (Package a) where

364402 parseJSON = toAesonParser displayPackageError

@@ -550,7 +588,7 @@ asSourceSpan = P.SourceSpan <$> key "name" asString

550588

551589instance A.ToJSON a => A.ToJSON (Package a) where

552590 toJSON Package{..} =

553− A.object

591+ A.object $

554592 [ "packageMeta" .= pkgMeta

555593 , "version" .= showVersion pkgVersion

556594 , "versionTag" .= pkgVersionTag

@@ -562,7 +600,8 @@ instance A.ToJSON a => A.ToJSON (Package a) where

562600 , "github" .= pkgGithub

563601 , "uploader" .= pkgUploader

564602 , "compilerVersion" .= showVersion P.version

565− ]

603+ ] ++

604+ fmap (\t -> "tagTime" .= formatTime t) (maybeToList pkgTagTime)

566605

567606instance A.ToJSON NotYetKnown where

568607 toJSON _ = A.Null

src/Language/PureScript/Publish.hs+13−2

@@ -39,12 +39,13 @@ import Data.List (stripPrefix, (\\), nubBy)

3939import Data.List.NonEmpty (NonEmpty(..))

4040import Data.List.Split (splitOn)

4141import Data.Maybe

42−import Data.Version

43−import qualified Data.SPDX as SPDX

4442import Data.Text (Text)

4543import qualified Data.Text as T

4644import qualified Data.Text.Lazy as TL

4745import qualified Data.Text.Lazy.Encoding as TL

46+import Data.Time.Clock (UTCTime)

47+import Data.Version

48+import qualified Data.SPDX as SPDX

4849

4950import Safe (headMay)

5051

@@ -67,6 +68,7 @@ data PublishOptions = PublishOptions

6768 { -- | How to obtain the version tag and version that the data being

6869 -- generated will refer to.

6970 publishGetVersion :: PrepareM (Text, Version)

71+ , publishGetTagTime :: Text -> PrepareM UTCTime

7072 , -- | What to do when the working tree is dirty

7173 publishWorkingTreeDirty :: PrepareM ()

7274 }

@@ -74,6 +76,7 @@ data PublishOptions = PublishOptions

7476defaultPublishOptions :: PublishOptions

7577defaultPublishOptions = PublishOptions

7678 { publishGetVersion = getVersionFromGitTag

79+ , publishGetTagTime = getTagTime

7780 , publishWorkingTreeDirty = userError DirtyWorkingTree

7881 }

7982

@@ -139,6 +142,7 @@ preparePackage' opts = do

139142 checkLicense pkgMeta

140143

141144 (pkgVersionTag, pkgVersion) <- publishGetVersion opts

145+ pkgTagTime <- Just <$> publishGetTagTime opts pkgVersionTag

142146 pkgGithub <- getBowerRepositoryInfo pkgMeta

143147 (pkgBookmarks, pkgModules) <- getModulesAndBookmarks

144148

@@ -200,6 +204,13 @@ getVersionFromGitTag = do

200204 digits <- stripPrefix "v" str

201205 (str,) <$> D.parseVersion' digits

202206

207+-- | Given a git tag, get the time it was created.

208+getTagTime :: Text -> PrepareM UTCTime

209+getTagTime tag = do

210+ out <- readProcess' "git" ["show", T.unpack tag, "--no-patch", "--format=%aI"] ""

211+ let time = headMay (lines out) >>= D.parseTime

212+ maybe (internalError (CouldntParseGitTagDate tag)) pure time

213+

203214getBowerRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)

204215getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract

205216 where

src/Language/PureScript/Publish/ErrorsWarnings.hs+4

@@ -73,6 +73,7 @@ data RepositoryFieldError

7373-- | An error that probably indicates a bug in this module.

7474data InternalError

7575 = JSONError JSONSource (ParseError BowerError)

76+ | CouldntParseGitTagDate Text

7677 deriving (Show)

7778

7879data JSONSource

@@ -289,6 +290,9 @@ displayInternalError e = case e of

289290 [ "Error in JSON " ++ displayJSONSource src ++ ":"

290291 , T.unpack (Bower.displayError r)

291292 ]

293+ CouldntParseGitTagDate tag ->

294+ [ "Unable to parse the date for a git tag: " ++ T.unpack tag

295+ ]

292296

293297displayJSONSource :: JSONSource -> String

294298displayJSONSource s = case s of

tests/TestDocs.hs+7−4

@@ -9,14 +9,16 @@ import Prelude ()

99import Prelude.Compat

1010

1111import Control.Arrow (first)

12+import Control.Monad.IO.Class (liftIO)

1213

13−import Data.Version (Version(..))

14−import Data.Monoid

15−import Data.Maybe (fromMaybe)

16−import Data.List ((\\))

1714import Data.Foldable

15+import Data.List ((\\))

16+import Data.Maybe (fromMaybe)

17+import Data.Monoid

1818import Data.Text (Text)

1919import qualified Data.Text as T

20+import Data.Time.Clock (getCurrentTime)

21+import Data.Version (Version(..))

2022import System.Exit

2123

2224import qualified Language.PureScript as P

@@ -32,6 +34,7 @@ import TestUtils

3234publishOpts :: Publish.PublishOptions

3335publishOpts = Publish.defaultPublishOptions

3436 { Publish.publishGetVersion = return testVersion

37+ , Publish.publishGetTagTime = const (liftIO getCurrentTime)

3538 , Publish.publishWorkingTreeDirty = return ()

3639 }

3740 where testVersion = ("v999.0.0", Version [999,0,0] [])

tests/TestPscPublish.hs+3

@@ -4,8 +4,10 @@

55module TestPscPublish where

7+import Control.Monad.IO.Class (liftIO)

78import System.Exit (exitFailure)

89import Data.ByteString.Lazy (ByteString)

10+import Data.Time.Clock (getCurrentTime)

911import qualified Data.Aeson as A

1012import Data.Version

1113

@@ -38,6 +40,7 @@ roundTrip pkg =

3840testRunOptions :: PublishOptions

3941testRunOptions = defaultPublishOptions

4042 { publishGetVersion = return testVersion

43+ , publishGetTagTime = const (liftIO getCurrentTime)

4144 , publishWorkingTreeDirty = return ()

4245 }

4346 where testVersion = ("v999.0.0", Version [999,0,0] [])