Merge pull request purescript#2544 from purescript/include-tag-date

hdgarrood · web-flow · commit 307b71dfd263 · 2017-01-06T22:25:28.000Z
Add git tag time to psc-publish JSON
diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs
@@ -10,17 +10,19 @@ import Control.Arrow (first, (***))
 import Control.Monad (when)
 import Control.Monad.Error.Class (catchError)
 
-import Data.Monoid ((<>))
 import Data.Aeson ((.=))
 import Data.Aeson.BetterErrors
 import Data.ByteString.Lazy (ByteString)
 import Data.Either (isLeft, isRight)
-import Data.Maybe (mapMaybe, fromMaybe)
+import Data.Maybe (mapMaybe, fromMaybe, maybeToList)
+import Data.Monoid ((<>))
 import Data.Text (Text)
+import Data.Time.Clock (UTCTime)
+import qualified Data.Time.Format as TimeFormat
 import Data.Version
-import qualified Data.Vector as V
 import qualified Data.Aeson as A
 import qualified Data.Text as T
+import qualified Data.Vector as V
 
 import qualified Language.PureScript as P
 
@@ -40,6 +42,10 @@ data Package a = Package
   { pkgMeta                 :: PackageMeta
   , pkgVersion              :: Version
   , pkgVersionTag           :: Text
+  -- TODO: When this field was introduced, it was given the Maybe type for the
+  -- sake of backwards compatibility, as older JSON blobs will not include the
+  -- field. It should eventually be changed to just UTCTime.
+  , pkgTagTime              :: Maybe UTCTime
   , pkgModules              :: [Module]
   , pkgBookmarks            :: [Bookmark]
   , pkgResolvedDependencies :: [(PackageName, Version)]
@@ -62,6 +68,7 @@ verifyPackage verifiedUser Package{..} =
   Package pkgMeta
           pkgVersion
           pkgVersionTag
+          pkgTagTime
           pkgModules
           pkgBookmarks
           pkgResolvedDependencies
@@ -72,6 +79,29 @@ verifyPackage verifiedUser Package{..} =
 packageName :: Package a -> PackageName
 packageName = bowerName . pkgMeta
 
+-- |
+-- The time format used for serializing package tag times in the JSON format.
+-- This is the ISO 8601 date format which includes a time and a timezone.
+--
+jsonTimeFormat :: String
+jsonTimeFormat = "%Y-%m-%dT%H:%M:%S%z"
+
+-- |
+-- Convenience function for formatting a time in the format expected by this
+-- module.
+--
+formatTime :: UTCTime -> String
+formatTime =
+  TimeFormat.formatTime TimeFormat.defaultTimeLocale jsonTimeFormat
+
+-- |
+-- Convenience function for parsing a time in the format expected by this
+-- module.
+--
+parseTime :: String -> Maybe UTCTime
+parseTime =
+  TimeFormat.parseTimeM False TimeFormat.defaultTimeLocale jsonTimeFormat
+
 data Module = Module
   { modName         :: P.ModuleName
   , modComments     :: Maybe Text
@@ -275,6 +305,7 @@ data PackageError
   | InvalidFixity
   | InvalidKind Text
   | InvalidDataDeclType Text
+  | InvalidTime
   deriving (Show, Eq, Ord)
 
 type Bookmark = InPackage (P.ModuleName, Text)
@@ -320,13 +351,18 @@ asPackage minimumVersion uploader = do
   Package <$> key "packageMeta" asPackageMeta .! ErrorInPackageMeta
           <*> key "version" asVersion
           <*> key "versionTag" asText
+          <*> keyMay "tagTime" (withString parseTimeEither)
           <*> key "modules" (eachInArray asModule)
           <*> key "bookmarks" asBookmarks .! ErrorInPackageMeta
           <*> key "resolvedDependencies" asResolvedDependencies
           <*> key "github" asGithub
           <*> key "uploader" uploader
           <*> pure compilerVersion
 
+parseTimeEither :: String -> Either PackageError UTCTime
+parseTimeEither =
+  maybe (Left InvalidTime) Right . parseTime
+
 asUploadedPackage :: Version -> Parse PackageError UploadedPackage
 asUploadedPackage minVersion = asPackage minVersion asNotYetKnown
 
@@ -359,6 +395,8 @@ displayPackageError e = case e of
     "Invalid kind: \"" <> str <> "\""
   InvalidDataDeclType str ->
     "Invalid data declaration type: \"" <> str <> "\""
+  InvalidTime ->
+    "Invalid time"
 
 instance A.FromJSON a => A.FromJSON (Package a) where
   parseJSON = toAesonParser displayPackageError
@@ -550,7 +588,7 @@ asSourceSpan = P.SourceSpan <$> key "name" asString
 
 instance A.ToJSON a => A.ToJSON (Package a) where
   toJSON Package{..} =
-    A.object
+    A.object $
       [ "packageMeta"          .= pkgMeta
       , "version"              .= showVersion pkgVersion
       , "versionTag"           .= pkgVersionTag
@@ -562,7 +600,8 @@ instance A.ToJSON a => A.ToJSON (Package a) where
       , "github"               .= pkgGithub
       , "uploader"             .= pkgUploader
       , "compilerVersion"      .= showVersion P.version
-      ]
+      ] ++
+      fmap (\t -> "tagTime" .= formatTime t) (maybeToList pkgTagTime)
 
 instance A.ToJSON NotYetKnown where
   toJSON _ = A.Null
diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs
@@ -39,12 +39,13 @@ import Data.List (stripPrefix, (\\), nubBy)
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.List.Split (splitOn)
 import Data.Maybe
-import Data.Version
-import qualified Data.SPDX as SPDX
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Encoding as TL
+import Data.Time.Clock (UTCTime)
+import Data.Version
+import qualified Data.SPDX as SPDX
 
 import Safe (headMay)
 
@@ -67,13 +68,15 @@ data PublishOptions = PublishOptions
   { -- | How to obtain the version tag and version that the data being
     -- generated will refer to.
     publishGetVersion :: PrepareM (Text, Version)
+  , publishGetTagTime :: Text -> PrepareM UTCTime
   , -- | What to do when the working tree is dirty
     publishWorkingTreeDirty :: PrepareM ()
   }
 
 defaultPublishOptions :: PublishOptions
 defaultPublishOptions = PublishOptions
   { publishGetVersion = getVersionFromGitTag
+  , publishGetTagTime = getTagTime
   , publishWorkingTreeDirty = userError DirtyWorkingTree
   }
 
@@ -139,6 +142,7 @@ preparePackage' opts = do
   checkLicense pkgMeta
 
   (pkgVersionTag, pkgVersion) <- publishGetVersion opts
+  pkgTagTime                  <- Just <$> publishGetTagTime opts pkgVersionTag
   pkgGithub                   <- getBowerRepositoryInfo pkgMeta
   (pkgBookmarks, pkgModules)  <- getModulesAndBookmarks
 
@@ -200,6 +204,13 @@ getVersionFromGitTag = do
     digits <- stripPrefix "v" str
     (str,) <$> D.parseVersion' digits
 
+-- | Given a git tag, get the time it was created.
+getTagTime :: Text -> PrepareM UTCTime
+getTagTime tag = do
+  out <- readProcess' "git" ["show", T.unpack tag, "--no-patch", "--format=%aI"] ""
+  let time = headMay (lines out) >>= D.parseTime
+  maybe (internalError (CouldntParseGitTagDate tag)) pure time
+
 getBowerRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)
 getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract
   where
diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs
@@ -73,6 +73,7 @@ data RepositoryFieldError
 -- | An error that probably indicates a bug in this module.
 data InternalError
   = JSONError JSONSource (ParseError BowerError)
+  | CouldntParseGitTagDate Text
   deriving (Show)
 
 data JSONSource
@@ -289,6 +290,9 @@ displayInternalError e = case e of
     [ "Error in JSON " ++ displayJSONSource src ++ ":"
     , T.unpack (Bower.displayError r)
     ]
+  CouldntParseGitTagDate tag ->
+    [ "Unable to parse the date for a git tag: " ++ T.unpack tag
+    ]
 
 displayJSONSource :: JSONSource -> String
 displayJSONSource s = case s of
diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs
@@ -9,14 +9,16 @@ import Prelude ()
 import Prelude.Compat
 
 import Control.Arrow (first)
+import Control.Monad.IO.Class (liftIO)
 
-import Data.Version (Version(..))
-import Data.Monoid
-import Data.Maybe (fromMaybe)
-import Data.List ((\\))
 import Data.Foldable
+import Data.List ((\\))
+import Data.Maybe (fromMaybe)
+import Data.Monoid
 import Data.Text (Text)
 import qualified Data.Text as T
+import Data.Time.Clock (getCurrentTime)
+import Data.Version (Version(..))
 import System.Exit
 
 import qualified Language.PureScript as P
@@ -32,6 +34,7 @@ import TestUtils
 publishOpts :: Publish.PublishOptions
 publishOpts = Publish.defaultPublishOptions
   { Publish.publishGetVersion = return testVersion
+  , Publish.publishGetTagTime = const (liftIO getCurrentTime)
   , Publish.publishWorkingTreeDirty = return ()
   }
   where testVersion = ("v999.0.0", Version [999,0,0] [])
diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs
@@ -4,8 +4,10 @@
 
 module TestPscPublish where
 
+import Control.Monad.IO.Class (liftIO)
 import System.Exit (exitFailure)
 import Data.ByteString.Lazy (ByteString)
+import Data.Time.Clock (getCurrentTime)
 import qualified Data.Aeson as A
 import Data.Version
 
@@ -38,6 +40,7 @@ roundTrip pkg =
 testRunOptions :: PublishOptions
 testRunOptions = defaultPublishOptions
   { publishGetVersion = return testVersion
+  , publishGetTagTime = const (liftIO getCurrentTime)
   , publishWorkingTreeDirty = return ()
   }
   where testVersion = ("v999.0.0", Version [999,0,0] [])
