1 files changed, 64 insertions, 0 deletions
diff --git a/app/Issue/Provenance.hs b/app/Issue/Provenance.hs
new file mode 100644
index 0000000..7cf4faa
--- /dev/null
+++ b/app/Issue/Provenance.hs
@@ -0,0 +1,64 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Issue.Provenance
+  ( Provenance (..),
+    provenanceFromHEAD,
+  )
+where
+
+import Data.Binary (Binary, Put, get, put)
+import Data.ByteString.Lazy.Char8 (toStrict)
+import Data.Fixed (Pico)
+import Data.Function ((&))
+import Data.Text (Text, lines, splitOn, unpack)
+import Data.Text.Encoding (decodeUtf8)
+import Data.Time.Calendar (Day (..), toModifiedJulianDay)
+import Data.Time.Clock (DiffTime, UTCTime (..), picosecondsToDiffTime)
+import GHC.Generics (Generic)
+import Process (sh)
+import System.Process.Typed (setWorkingDir)
+import Prelude hiding (lines)
+
+data Provenance = Provenance
+  { firstCommit :: Text,
+    date :: UTCTime,
+    authorEmail :: Text,
+    authorName :: Text
+  }
+  deriving (Show, Generic, Binary)
+
+-- XXX These are taken from `Data.Binary.Orphans` [1]. I cannot get importing
+-- the instance from the package to work.. so we use `-fno-warn-orphans` here.
+--
+-- [1] https://hackage.haskell.org/package/binary-orphans-0.1.5.1/docs/src/Data-Binary-Orphans.html#line-132
+instance Binary UTCTime where
+  get = UTCTime <$> get <*> get
+  put (UTCTime d dt) = put d >> put dt
+
+instance Binary Day where
+  get = fmap ModifiedJulianDay get
+  put = put . toModifiedJulianDay
+
+instance Binary DiffTime where
+  get = fmap picosecondsToDiffTime get
+  put = (put :: Pico -> Put) . realToFrac
+
+provenanceFromHEAD :: FilePath -> IO (Maybe Provenance)
+provenanceFromHEAD cwd = do
+  rawProvenance <-
+    fmap (splitOn "\NUL" . head . lines . decodeUtf8 . toStrict) $
+      sh $
+        "git show --quiet --format='%H%x00%ai%x00%ae%x00%an'"
+          & setWorkingDir cwd
+  pure $ case rawProvenance of
+    firstCommit' : rawDate : authorEmail : authorName : _ ->
+      let date = read (unpack rawDate)
+       in Just
+            Provenance
+              { firstCommit = firstCommit',
+                date = date,
+                authorEmail = authorEmail,
+                authorName = authorName
+              }
+    _ ->
+      Nothing