-- | Facilities for inferring an application version
--
-- Various inputs are checked: files written during a docker build, git
-- information, or falling back to an unknown version. This is useful for
-- Bugsnag reports, client age comparison, etc.
--
module Freckle.App.Version
  ( AppVersion(..)
  , getAppVersion
  , tryGetAppVersion
  ) where

import Freckle.App.Prelude

import Control.Error.Util (hoistEither, note)
import Control.Monad.Trans.Except
import Data.Char (isSpace)
import Data.List (dropWhileEnd)
import qualified Data.Text as T
import Data.Time.Format (defaultTimeLocale, parseTimeM)
import System.Exit (ExitCode(..))
import System.FilePath ((</>))
import System.Process (readProcessWithExitCode)
import UnliftIO.Exception (tryIO)

data AppVersion = AppVersion
  { AppVersion -> Text
avName :: Text
  , AppVersion -> UTCTime
avCreatedAt :: UTCTime
  }
  deriving stock (AppVersion -> AppVersion -> Bool
(AppVersion -> AppVersion -> Bool)
-> (AppVersion -> AppVersion -> Bool) -> Eq AppVersion
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AppVersion -> AppVersion -> Bool
$c/= :: AppVersion -> AppVersion -> Bool
== :: AppVersion -> AppVersion -> Bool
$c== :: AppVersion -> AppVersion -> Bool
Eq, Int -> AppVersion -> ShowS
[AppVersion] -> ShowS
AppVersion -> String
(Int -> AppVersion -> ShowS)
-> (AppVersion -> String)
-> ([AppVersion] -> ShowS)
-> Show AppVersion
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AppVersion] -> ShowS
$cshowList :: [AppVersion] -> ShowS
show :: AppVersion -> String
$cshow :: AppVersion -> String
showsPrec :: Int -> AppVersion -> ShowS
$cshowsPrec :: Int -> AppVersion -> ShowS
Show)

-- | Attempt to infer an @'AppVersion'@
--
-- - If files exist under @\/app-version@ they ar read, otherwise
-- - If we're in a Git repository commit information is used, otherwise
-- - An /Unknown/ version as of the current time is returned
--
getAppVersion :: MonadUnliftIO m => m AppVersion
getAppVersion :: m AppVersion
getAppVersion =
  ([String] -> m AppVersion)
-> (AppVersion -> m AppVersion)
-> Either [String] AppVersion
-> m AppVersion
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m AppVersion -> [String] -> m AppVersion
forall a b. a -> b -> a
const m AppVersion
forall (m :: * -> *). MonadIO m => m AppVersion
getAppVersionUnknown) AppVersion -> m AppVersion
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [String] AppVersion -> m AppVersion)
-> m (Either [String] AppVersion) -> m AppVersion
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> m (Either [String] AppVersion)
forall (m :: * -> *).
MonadUnliftIO m =>
String -> m (Either [String] AppVersion)
tryGetAppVersion String
"/app-version"

-- | A more testable version of @'getAppVersion'@
--
-- - Reports what didn't work in @'Left'@
-- - Accepts a parent path, for file-system version information
--
tryGetAppVersion
  :: MonadUnliftIO m => FilePath -> m (Either [String] AppVersion)
tryGetAppVersion :: String -> m (Either [String] AppVersion)
tryGetAppVersion String
parent =
  ExceptT [String] m AppVersion -> m (Either [String] AppVersion)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
    (ExceptT [String] m AppVersion -> m (Either [String] AppVersion))
-> ExceptT [String] m AppVersion -> m (Either [String] AppVersion)
forall a b. (a -> b) -> a -> b
$ (String -> [String])
-> ExceptT String m AppVersion -> ExceptT [String] m AppVersion
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT String -> [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> ExceptT String m AppVersion
forall (m :: * -> *).
MonadIO m =>
String -> ExceptT String m AppVersion
getAppVersionFiles String
parent)
    ExceptT [String] m AppVersion
-> ExceptT [String] m AppVersion -> ExceptT [String] m AppVersion
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> [String])
-> ExceptT String m AppVersion -> ExceptT [String] m AppVersion
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT String -> [String]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExceptT String m AppVersion
forall (m :: * -> *). MonadIO m => ExceptT String m AppVersion
getAppVersionGit

getAppVersionFiles :: MonadIO m => FilePath -> ExceptT String m AppVersion
getAppVersionFiles :: String -> ExceptT String m AppVersion
getAppVersionFiles String
parent = do
  String
name <- String -> ExceptT String m String
forall (m :: * -> *).
MonadIO m =>
String -> ExceptT String m String
readFileExceptT (String -> ExceptT String m String)
-> String -> ExceptT String m String
forall a b. (a -> b) -> a -> b
$ String
parent String -> ShowS
</> String
"name"
  String
seconds <- String -> ExceptT String m String
forall (m :: * -> *).
MonadIO m =>
String -> ExceptT String m String
readFileExceptT (String -> ExceptT String m String)
-> String -> ExceptT String m String
forall a b. (a -> b) -> a -> b
$ String
parent String -> ShowS
</> String
"created-at"
  Either String AppVersion -> ExceptT String m AppVersion
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
hoistEither (Either String AppVersion -> ExceptT String m AppVersion)
-> Either String AppVersion -> ExceptT String m AppVersion
forall a b. (a -> b) -> a -> b
$ String -> String -> Either String AppVersion
toAppVersion String
name String
seconds

getAppVersionGit :: MonadIO m => ExceptT String m AppVersion
getAppVersionGit :: ExceptT String m AppVersion
getAppVersionGit = do
  String
name <- [String] -> ExceptT String m String
forall (m :: * -> *).
MonadIO m =>
[String] -> ExceptT String m String
git [String
"rev-parse", String
"HEAD"]
  String
seconds <- [String] -> ExceptT String m String
forall (m :: * -> *).
MonadIO m =>
[String] -> ExceptT String m String
git [String
"show", String
"--no-patch", String
"--no-notes", String
"--pretty=%at"]
  Either String AppVersion -> ExceptT String m AppVersion
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
hoistEither (Either String AppVersion -> ExceptT String m AppVersion)
-> Either String AppVersion -> ExceptT String m AppVersion
forall a b. (a -> b) -> a -> b
$ String -> String -> Either String AppVersion
toAppVersion String
name String
seconds

toAppVersion :: String -> String -> Either String AppVersion
toAppVersion :: String -> String -> Either String AppVersion
toAppVersion String
name String
seconds = do
  UTCTime
createdAt <- String -> Either String UTCTime
parseUnixSeconds (String -> Either String UTCTime)
-> String -> Either String UTCTime
forall a b. (a -> b) -> a -> b
$ ShowS
strip String
seconds
  AppVersion -> Either String AppVersion
forall (f :: * -> *) a. Applicative f => a -> f a
pure AppVersion :: Text -> UTCTime -> AppVersion
AppVersion { avName :: Text
avName = Text -> Text
T.strip (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
name, avCreatedAt :: UTCTime
avCreatedAt = UTCTime
createdAt }

parseUnixSeconds :: String -> Either String UTCTime
parseUnixSeconds :: String -> Either String UTCTime
parseUnixSeconds String
x = String -> Maybe UTCTime -> Either String UTCTime
forall a b. a -> Maybe b -> Either a b
note String
err (Maybe UTCTime -> Either String UTCTime)
-> Maybe UTCTime -> Either String UTCTime
forall a b. (a -> b) -> a -> b
$ Bool -> TimeLocale -> String -> String -> Maybe UTCTime
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
"%s" String
x
  where err :: String
err = String
x String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" does not parse as UTCTime with format %s"

getAppVersionUnknown :: MonadIO m => m AppVersion
getAppVersionUnknown :: m AppVersion
getAppVersionUnknown = Text -> UTCTime -> AppVersion
AppVersion Text
"Unknown" (UTCTime -> AppVersion) -> m UTCTime -> m AppVersion
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime

readFileExceptT :: MonadIO m => FilePath -> ExceptT String m String
readFileExceptT :: String -> ExceptT String m String
readFileExceptT String
path = m (Either String String) -> ExceptT String m String
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either String String) -> ExceptT String m String)
-> m (Either String String) -> ExceptT String m String
forall a b. (a -> b) -> a -> b
$ IO (Either String String) -> m (Either String String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String String) -> m (Either String String))
-> IO (Either String String) -> m (Either String String)
forall a b. (a -> b) -> a -> b
$ (IOException -> String)
-> Either IOException String -> Either String String
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first IOException -> String
forall a. Show a => a -> String
err (Either IOException String -> Either String String)
-> IO (Either IOException String) -> IO (Either String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String -> IO (Either IOException String)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
tryIO (String -> IO String
readFile String
path)
  where err :: a -> String
err a
ex = String
"readFile: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
ex

git :: MonadIO m => [String] -> ExceptT String m String
git :: [String] -> ExceptT String m String
git [String]
args = do
  (ExitCode
ec, String
stdout, String
stderr) <- IO (ExitCode, String, String)
-> ExceptT String m (ExitCode, String, String)
forall (m :: * -> *) a. MonadIO m => IO a -> ExceptT String m a
exceptIO (IO (ExitCode, String, String)
 -> ExceptT String m (ExitCode, String, String))
-> IO (ExitCode, String, String)
-> ExceptT String m (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
"git" [String]
args []

  case ExitCode
ec of
    ExitCode
ExitSuccess -> String -> ExceptT String m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
stdout
    ExitFailure Int
n ->
      String -> ExceptT String m String
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (String -> ExceptT String m String)
-> String -> ExceptT String m String
forall a b. (a -> b) -> a -> b
$ String
"[" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"] git " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords [String]
args String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
stderr

exceptIO :: MonadIO m => IO a -> ExceptT String m a
exceptIO :: IO a -> ExceptT String m a
exceptIO = (IOException -> String)
-> ExceptT IOException m a -> ExceptT String m a
forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT IOException -> String
forall a. Show a => a -> String
show (ExceptT IOException m a -> ExceptT String m a)
-> (IO a -> ExceptT IOException m a) -> IO a -> ExceptT String m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (Either IOException a) -> ExceptT IOException m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either IOException a) -> ExceptT IOException m a)
-> (IO a -> m (Either IOException a))
-> IO a
-> ExceptT IOException m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Either IOException a) -> m (Either IOException a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either IOException a) -> m (Either IOException a))
-> (IO a -> IO (Either IOException a))
-> IO a
-> m (Either IOException a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> IO (Either IOException a)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either IOException a)
tryIO

strip :: String -> String
strip :: ShowS
strip = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd Char -> Bool
isSpace