{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
module HMGit.Commands.Porcelain.Commit.Core (
    Commit (..)
  , CommitCfg (..)
  , commitDefault
) where

import           HMGit.Internal.Core            (storeObject, storeTree)
import qualified HMGit.Internal.Core            as OBJ (ObjectType (..))
import           HMGit.Internal.Core.Runner     (HMGitT)
import           HMGit.Internal.Core.Runner.API (hmGitBRName', hmGitBRPath',
                                                 hmGitLoadMasterHash)
import           HMGit.Internal.Utils           (hexStr)

import           Control.Exception.Safe         (MonadCatch)
import           Control.Monad.IO.Class         (MonadIO (..))
import qualified Data.ByteString.Lazy.Char8     as BLC
import qualified Data.ByteString.Lazy.UTF8      as BLU
import           Data.String                    (IsString (..))
import           Data.Time.Clock.POSIX          (getPOSIXTime)
import           Data.Time.LocalTime            (TimeZone (..),
                                                 getCurrentTimeZone)
import qualified Path                           as P
import           System.Environment             (getEnv)
import           Text.Printf                    (printf)

data CommitCfg = CommitCfg {
    CommitCfg -> String
commitMessage :: String
  , CommitCfg -> String
commitAuthor  :: String
  }
  deriving Int -> CommitCfg -> ShowS
[CommitCfg] -> ShowS
CommitCfg -> String
(Int -> CommitCfg -> ShowS)
-> (CommitCfg -> String)
-> ([CommitCfg] -> ShowS)
-> Show CommitCfg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CommitCfg] -> ShowS
$cshowList :: [CommitCfg] -> ShowS
show :: CommitCfg -> String
$cshow :: CommitCfg -> String
showsPrec :: Int -> CommitCfg -> ShowS
$cshowsPrec :: Int -> CommitCfg -> ShowS
Show

newtype Commit m = Commit { Commit m -> CommitCfg -> HMGitT m ()
commit :: CommitCfg -> HMGitT m () }

authorTime :: forall m. (MonadIO m) => m String
authorTime :: m String
authorTime = do
    Integer
timestamp <- POSIXTime -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Integer) -> m POSIXTime -> m Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO POSIXTime -> m POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime :: m Integer
    Int
utcOffsetSec <- (Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
60) (Int -> Int) -> (TimeZone -> Int) -> TimeZone -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TimeZone -> Int
timeZoneMinutes (TimeZone -> Int) -> m TimeZone -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO TimeZone -> m TimeZone
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO TimeZone
getCurrentTimeZone
    String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ String -> Integer -> Char -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%d %c%02d%02d"
        Integer
timestamp
        (if Int
utcOffsetSec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Char
'+' else Char
'-')
        (Int -> Int
forall a. Num a => a -> a
abs Int
utcOffsetSec Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3600)
        ((Int -> Int
forall a. Num a => a -> a
abs Int
utcOffsetSec Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
60) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
60)

commitDefault :: (MonadIO m, MonadCatch m) => Commit m
commitDefault :: Commit m
commitDefault = (CommitCfg -> HMGitT m ()) -> Commit m
forall (m :: * -> *). (CommitCfg -> HMGitT m ()) -> Commit m
Commit ((CommitCfg -> HMGitT m ()) -> Commit m)
-> (CommitCfg -> HMGitT m ()) -> Commit m
forall a b. (a -> b) -> a -> b
$ \CommitCfg
ccfg -> do
    ByteString
sha1 <- [ReaderT HMGitConfig m ByteString]
-> ReaderT HMGitConfig m [ByteString]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [
        String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString)
-> (ByteString -> String) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"tree " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>) ShowS -> (ByteString -> String) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
forall mono.
(MonoFoldable mono, PrintfArg (Element mono)) =>
mono -> String
hexStr (ByteString -> ByteString)
-> ReaderT HMGitConfig m ByteString
-> ReaderT HMGitConfig m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT HMGitConfig m ByteString
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
HMGitT m ByteString
storeTree
      , ByteString -> (String -> ByteString) -> Maybe String -> ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ByteString
forall a. Monoid a => a
mempty (String -> ByteString
BLC.pack (String -> ByteString) -> ShowS -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
forall r. PrintfType r => String -> r
printf String
"\nparent %s") (Maybe String -> ByteString)
-> ReaderT HMGitConfig m (Maybe String)
-> ReaderT HMGitConfig m ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT HMGitConfig m (Maybe String)
forall (m :: * -> *).
(MonadIO m, MonadThrow m) =>
HMGitT m (Maybe String)
hmGitLoadMasterHash
      , (String -> ByteString) -> ShowS -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) String -> ByteString
BLC.pack (ShowS -> String -> ByteString)
-> (String -> ShowS) -> String -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"\nauthor %s %s" (String -> String -> ByteString)
-> ReaderT HMGitConfig m String
-> ReaderT HMGitConfig m (String -> ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CommitCfg -> ReaderT HMGitConfig m String
forall (m :: * -> *). MonadIO m => CommitCfg -> m String
cAuthor CommitCfg
ccfg ReaderT HMGitConfig m (String -> ByteString)
-> ReaderT HMGitConfig m String -> ReaderT HMGitConfig m ByteString
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT HMGitConfig m String
forall (m :: * -> *). MonadIO m => m String
authorTime
      , (String -> ByteString) -> ShowS -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) String -> ByteString
BLC.pack (ShowS -> String -> ByteString)
-> (String -> ShowS) -> String -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"\ncommitter %s %s\n\n" (String -> String -> ByteString)
-> ReaderT HMGitConfig m String
-> ReaderT HMGitConfig m (String -> ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CommitCfg -> ReaderT HMGitConfig m String
forall (m :: * -> *). MonadIO m => CommitCfg -> m String
cAuthor CommitCfg
ccfg ReaderT HMGitConfig m (String -> ByteString)
-> ReaderT HMGitConfig m String -> ReaderT HMGitConfig m ByteString
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT HMGitConfig m String
forall (m :: * -> *). MonadIO m => m String
authorTime
      , ByteString -> ReaderT HMGitConfig m ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> ReaderT HMGitConfig m ByteString)
-> ByteString -> ReaderT HMGitConfig m ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
BLU.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ CommitCfg -> String
commitMessage CommitCfg
ccfg
      , ByteString -> ReaderT HMGitConfig m ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
"\n"
      ]
        ReaderT HMGitConfig m [ByteString]
-> ([ByteString] -> ReaderT HMGitConfig m ByteString)
-> ReaderT HMGitConfig m ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ObjectType -> ByteString -> ReaderT HMGitConfig m ByteString
forall (m :: * -> *).
(MonadIO m, MonadCatch m) =>
ObjectType -> ByteString -> HMGitT m ByteString
storeObject ObjectType
OBJ.Commit (ByteString -> ReaderT HMGitConfig m ByteString)
-> ([ByteString] -> ByteString)
-> [ByteString]
-> ReaderT HMGitConfig m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
    HMGitT m (Path Abs File)
forall (m :: * -> *). MonadIO m => HMGitT m (Path Abs File)
hmGitBRPath'
        HMGitT m (Path Abs File)
-> (Path Abs File -> HMGitT m ()) -> HMGitT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> HMGitT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> HMGitT m ())
-> (Path Abs File -> IO ()) -> Path Abs File -> HMGitT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> IO ()) -> String -> String -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> String -> IO ()
writeFile (ByteString -> String
forall mono.
(MonoFoldable mono, PrintfArg (Element mono)) =>
mono -> String
hexStr ByteString
sha1 String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"\n") (String -> IO ())
-> (Path Abs File -> String) -> Path Abs File -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> String
forall b t. Path b t -> String
P.toFilePath
        HMGitT m ()
-> ReaderT HMGitConfig m String -> ReaderT HMGitConfig m String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"[%s (commit) %.7s] %s"
            (String -> String -> ShowS)
-> ReaderT HMGitConfig m String
-> ReaderT HMGitConfig m (String -> ShowS)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT HMGitConfig m String
forall (m :: * -> *). MonadIO m => HMGitT m String
hmGitBRName'
            ReaderT HMGitConfig m (String -> ShowS)
-> ReaderT HMGitConfig m String -> ReaderT HMGitConfig m ShowS
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> ReaderT HMGitConfig m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> String
forall mono.
(MonoFoldable mono, PrintfArg (Element mono)) =>
mono -> String
hexStr ByteString
sha1)
            ReaderT HMGitConfig m ShowS
-> ReaderT HMGitConfig m String -> ReaderT HMGitConfig m String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> ReaderT HMGitConfig m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommitCfg -> String
commitMessage CommitCfg
ccfg)
        ReaderT HMGitConfig m String
-> (String -> HMGitT m ()) -> HMGitT m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> HMGitT m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> HMGitT m ())
-> (String -> IO ()) -> String -> HMGitT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn
    where
        cAuthor :: CommitCfg -> m String
cAuthor CommitCfg
ccfg
            | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CommitCfg -> String
commitAuthor CommitCfg
ccfg) =
                IO String -> m String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"%s <%s>" (String -> ShowS) -> IO String -> IO ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
getEnv String
"HMGIT_AUTHOR_NAME" IO ShowS -> IO String -> IO String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO String
getEnv String
"HMGIT_AUTHOR_EMAIL")
            | Bool
otherwise = String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> m String) -> String -> m String
forall a b. (a -> b) -> a -> b
$ CommitCfg -> String
commitAuthor CommitCfg
ccfg