{-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
module HMGit.Internal.Core.Runner.API (
HMGitT
, hmGitDBPath
, hmGitDBName
, hmGitLoadMasterHash
, hmGitRoot
, hmGitTreeLim
, hmGitIndexPath
, hmGitBRPath
, hmGitBRPath'
, hmGitBRName
, hmGitBRName'
, getCurrentDirFromHMGit
, runHMGit
) where
import HMGit.Internal.Core.Runner.HMGitConfig (HMGitConfig (..))
import HMGit.Internal.Parser.Core.ByteString (ParseException (..))
import qualified Codec.Binary.UTF8.String as BUS
import Control.Arrow ((|||))
import Control.Exception.Safe (MonadThrow, throw,
throwString)
import Control.Monad.Extra (ifM, replicateM)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Reader (ReaderT (..), asks)
import qualified Data.Binary.Get as BG
import qualified Data.ByteString.Lazy as BL
import Data.Functor ((<&>))
import Data.List (isPrefixOf)
import Data.List.Extra (dropPrefix)
import Data.Tuple.Extra (thd3, third3)
import Path (File, Rel)
import qualified Path as P
import qualified Path.IO as P
import System.FilePath (takeFileName)
import Text.Printf (printf)
type HMGitT = ReaderT HMGitConfig
hmGitDBPath :: Monad m => HMGitT m (P.Path P.Abs P.Dir)
hmGitDBPath :: HMGitT m (Path Abs Dir)
hmGitDBPath = (HMGitConfig -> Path Abs Dir) -> HMGitT m (Path Abs Dir)
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks HMGitConfig -> Path Abs Dir
hmGitDir
hmGitDBName :: Monad m => HMGitT m String
hmGitDBName :: HMGitT m String
hmGitDBName = String -> String
takeFileName (String -> String)
-> (Path Abs Dir -> String) -> Path Abs Dir -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
init (String -> String)
-> (Path Abs Dir -> String) -> Path Abs Dir -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> String
forall b t. Path b t -> String
P.toFilePath (Path Abs Dir -> String)
-> ReaderT HMGitConfig m (Path Abs Dir) -> HMGitT m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT HMGitConfig m (Path Abs Dir)
forall (m :: * -> *). Monad m => HMGitT m (Path Abs Dir)
hmGitDBPath
hmGitRoot :: Monad m => HMGitT m (P.Path P.Abs P.Dir)
hmGitRoot :: HMGitT m (Path Abs Dir)
hmGitRoot = Path Abs Dir -> Path Abs Dir
forall b t. Path b t -> Path b Dir
P.parent (Path Abs Dir -> Path Abs Dir)
-> HMGitT m (Path Abs Dir) -> HMGitT m (Path Abs Dir)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HMGitT m (Path Abs Dir)
forall (m :: * -> *). Monad m => HMGitT m (Path Abs Dir)
hmGitDBPath
hmGitTreeLim :: Monad m => HMGitT m Int
hmGitTreeLim :: HMGitT m Int
hmGitTreeLim = (HMGitConfig -> Int) -> HMGitT m Int
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks HMGitConfig -> Int
hmGitTreeLimit
hmGitIndexPath :: Monad m => HMGitT m (P.Path P.Abs P.File)
hmGitIndexPath :: HMGitT m (Path Abs File)
hmGitIndexPath = (Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
P.</> $(P.mkRelFile "index")) (Path Abs Dir -> Path Abs File)
-> ReaderT HMGitConfig m (Path Abs Dir) -> HMGitT m (Path Abs File)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT HMGitConfig m (Path Abs Dir)
forall (m :: * -> *). Monad m => HMGitT m (Path Abs Dir)
hmGitDBPath
getCurrentDirFromHMGit :: (MonadThrow m, MonadIO m)
=> HMGitT m (P.Path P.Rel P.Dir)
getCurrentDirFromHMGit :: HMGitT m (Path Rel Dir)
getCurrentDirFromHMGit = do
String
currentDir <- Path Abs Dir -> String
forall b t. Path b t -> String
P.toFilePath (Path Abs Dir -> String)
-> ReaderT HMGitConfig m (Path Abs Dir)
-> ReaderT HMGitConfig m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT HMGitConfig m (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
P.getCurrentDir
String
rootPath <- Path Abs Dir -> String
forall b t. Path b t -> String
P.toFilePath (Path Abs Dir -> String)
-> ReaderT HMGitConfig m (Path Abs Dir)
-> ReaderT HMGitConfig m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT HMGitConfig m (Path Abs Dir)
forall (m :: * -> *). Monad m => HMGitT m (Path Abs Dir)
hmGitRoot
if String
rootPath String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
currentDir then
let path :: String
path = String -> String -> String
forall a. Eq a => [a] -> [a] -> [a]
dropPrefix String
rootPath String
currentDir in
String -> HMGitT m (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
P.parseRelDir (String -> HMGitT m (Path Rel Dir))
-> String -> HMGitT m (Path Rel Dir)
forall a b. (a -> b) -> a -> b
$ if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
path then String
"./" else String
path
else
ReaderT HMGitConfig m String
forall (m :: * -> *). Monad m => HMGitT m String
hmGitDBName
ReaderT HMGitConfig m String
-> (String -> HMGitT m (Path Rel Dir)) -> HMGitT m (Path Rel Dir)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> HMGitT m (Path Rel Dir)
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
String -> m a
throwString
(String -> HMGitT m (Path Rel Dir))
-> (String -> String) -> String -> HMGitT m (Path Rel Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
forall r. PrintfType r => String -> r
printf String
"The current working directory is not in %s repository"
hmGitBRPath :: MonadIO m => HMGitT m (Either (P.Path P.Abs P.File) (P.Path P.Abs P.File))
hmGitBRPath :: HMGitT m (Either (Path Abs File) (Path Abs File))
hmGitBRPath = do
Path Abs File
m <- HMGitT m (Path Abs Dir)
forall (m :: * -> *). Monad m => HMGitT m (Path Abs Dir)
hmGitDBPath HMGitT m (Path Abs Dir)
-> (Path Abs Dir -> Path Abs File)
-> ReaderT HMGitConfig m (Path Abs File)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
P.</> $(P.mkRelFile "refs/heads/master"))
ReaderT HMGitConfig m Bool
-> HMGitT m (Either (Path Abs File) (Path Abs File))
-> HMGitT m (Either (Path Abs File) (Path Abs File))
-> HMGitT m (Either (Path Abs File) (Path Abs File))
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Path Abs File -> ReaderT HMGitConfig m Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
P.doesFileExist Path Abs File
m) (m (Either (Path Abs File) (Path Abs File))
-> HMGitT m (Either (Path Abs File) (Path Abs File))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either (Path Abs File) (Path Abs File))
-> HMGitT m (Either (Path Abs File) (Path Abs File)))
-> m (Either (Path Abs File) (Path Abs File))
-> HMGitT m (Either (Path Abs File) (Path Abs File))
forall a b. (a -> b) -> a -> b
$ Either (Path Abs File) (Path Abs File)
-> m (Either (Path Abs File) (Path Abs File))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Path Abs File) (Path Abs File)
-> m (Either (Path Abs File) (Path Abs File)))
-> Either (Path Abs File) (Path Abs File)
-> m (Either (Path Abs File) (Path Abs File))
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Either (Path Abs File) (Path Abs File)
forall a b. b -> Either a b
Right Path Abs File
m) (HMGitT m (Either (Path Abs File) (Path Abs File))
-> HMGitT m (Either (Path Abs File) (Path Abs File)))
-> HMGitT m (Either (Path Abs File) (Path Abs File))
-> HMGitT m (Either (Path Abs File) (Path Abs File))
forall a b. (a -> b) -> a -> b
$ do
Path Abs File
m' <- HMGitT m (Path Abs Dir)
forall (m :: * -> *). Monad m => HMGitT m (Path Abs Dir)
hmGitDBPath HMGitT m (Path Abs Dir)
-> (Path Abs Dir -> Path Abs File)
-> ReaderT HMGitConfig m (Path Abs File)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
P.</> $(P.mkRelFile "refs/heads/main"))
ReaderT HMGitConfig m Bool
-> HMGitT m (Either (Path Abs File) (Path Abs File))
-> HMGitT m (Either (Path Abs File) (Path Abs File))
-> HMGitT m (Either (Path Abs File) (Path Abs File))
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Path Abs File -> ReaderT HMGitConfig m Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
P.doesFileExist Path Abs File
m') (m (Either (Path Abs File) (Path Abs File))
-> HMGitT m (Either (Path Abs File) (Path Abs File))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either (Path Abs File) (Path Abs File))
-> HMGitT m (Either (Path Abs File) (Path Abs File)))
-> m (Either (Path Abs File) (Path Abs File))
-> HMGitT m (Either (Path Abs File) (Path Abs File))
forall a b. (a -> b) -> a -> b
$ Either (Path Abs File) (Path Abs File)
-> m (Either (Path Abs File) (Path Abs File))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Path Abs File) (Path Abs File)
-> m (Either (Path Abs File) (Path Abs File)))
-> Either (Path Abs File) (Path Abs File)
-> m (Either (Path Abs File) (Path Abs File))
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Either (Path Abs File) (Path Abs File)
forall a b. b -> Either a b
Right Path Abs File
m') (HMGitT m (Either (Path Abs File) (Path Abs File))
-> HMGitT m (Either (Path Abs File) (Path Abs File)))
-> HMGitT m (Either (Path Abs File) (Path Abs File))
-> HMGitT m (Either (Path Abs File) (Path Abs File))
forall a b. (a -> b) -> a -> b
$
m (Either (Path Abs File) (Path Abs File))
-> HMGitT m (Either (Path Abs File) (Path Abs File))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either (Path Abs File) (Path Abs File))
-> HMGitT m (Either (Path Abs File) (Path Abs File)))
-> m (Either (Path Abs File) (Path Abs File))
-> HMGitT m (Either (Path Abs File) (Path Abs File))
forall a b. (a -> b) -> a -> b
$ Either (Path Abs File) (Path Abs File)
-> m (Either (Path Abs File) (Path Abs File))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Path Abs File) (Path Abs File)
-> m (Either (Path Abs File) (Path Abs File)))
-> Either (Path Abs File) (Path Abs File)
-> m (Either (Path Abs File) (Path Abs File))
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Either (Path Abs File) (Path Abs File)
forall a b. a -> Either a b
Left Path Abs File
m'
hmGitBRPath' :: MonadIO m => HMGitT m (P.Path P.Abs P.File)
hmGitBRPath' :: HMGitT m (Path Abs File)
hmGitBRPath' = HMGitT m (Either (Path Abs File) (Path Abs File))
forall (m :: * -> *).
MonadIO m =>
HMGitT m (Either (Path Abs File) (Path Abs File))
hmGitBRPath HMGitT m (Either (Path Abs File) (Path Abs File))
-> (Either (Path Abs File) (Path Abs File)
-> HMGitT m (Path Abs File))
-> HMGitT m (Path Abs File)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Path Abs File -> HMGitT m (Path Abs File)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs File -> HMGitT m (Path Abs File))
-> (Path Abs File -> HMGitT m (Path Abs File))
-> Either (Path Abs File) (Path Abs File)
-> HMGitT m (Path Abs File)
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| Path Abs File -> HMGitT m (Path Abs File)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
hmGitBRName :: MonadIO m => HMGitT m (Either String String)
hmGitBRName :: HMGitT m (Either String String)
hmGitBRName = HMGitT m (Either (Path Abs File) (Path Abs File))
forall (m :: * -> *).
MonadIO m =>
HMGitT m (Either (Path Abs File) (Path Abs File))
hmGitBRPath
HMGitT m (Either (Path Abs File) (Path Abs File))
-> (Either (Path Abs File) (Path Abs File) -> Either String String)
-> HMGitT m (Either String String)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Path Abs File -> Either String String)
-> (Path Abs File -> Either String String)
-> Either (Path Abs File) (Path Abs File)
-> Either String String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String String
forall a b. a -> Either a b
Left (String -> Either String String)
-> (Path Abs File -> String)
-> Path Abs File
-> Either String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Rel File -> String
forall b t. Path b t -> String
P.toFilePath (Path Rel File -> String)
-> (Path Abs File -> Path Rel File) -> Path Abs File -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
P.filename) (String -> Either String String
forall a b. b -> Either a b
Right (String -> Either String String)
-> (Path Abs File -> String)
-> Path Abs File
-> Either String String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Rel File -> String
forall b t. Path b t -> String
P.toFilePath (Path Rel File -> String)
-> (Path Abs File -> Path Rel File) -> Path Abs File -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs File -> Path Rel File
forall b. Path b File -> Path Rel File
P.filename)
hmGitBRName' :: MonadIO m => HMGitT m String
hmGitBRName' :: HMGitT m String
hmGitBRName' = HMGitT m (Either String String)
forall (m :: * -> *). MonadIO m => HMGitT m (Either String String)
hmGitBRName HMGitT m (Either String String)
-> (Either String String -> HMGitT m String) -> HMGitT m String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> HMGitT m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> HMGitT m String)
-> (String -> HMGitT m String)
-> Either String String
-> HMGitT m String
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| String -> HMGitT m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure
hmGitLoadMasterHash :: (MonadIO m, MonadThrow m) => HMGitT m (Maybe String)
hmGitLoadMasterHash :: HMGitT m (Maybe String)
hmGitLoadMasterHash = HMGitT m (Either (Path Abs File) (Path Abs File))
forall (m :: * -> *).
MonadIO m =>
HMGitT m (Either (Path Abs File) (Path Abs File))
hmGitBRPath
HMGitT m (Either (Path Abs File) (Path Abs File))
-> (Either (Path Abs File) (Path Abs File)
-> HMGitT m (Maybe String))
-> HMGitT m (Maybe String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Path Abs File -> HMGitT m (Maybe String))
-> (Path Abs File -> HMGitT m (Maybe String))
-> Either (Path Abs File) (Path Abs File)
-> HMGitT m (Maybe String)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (HMGitT m (Maybe String) -> Path Abs File -> HMGitT m (Maybe String)
forall a b. a -> b -> a
const (HMGitT m (Maybe String)
-> Path Abs File -> HMGitT m (Maybe String))
-> HMGitT m (Maybe String)
-> Path Abs File
-> HMGitT m (Maybe String)
forall a b. (a -> b) -> a -> b
$ Maybe String -> HMGitT m (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing) Path Abs File -> HMGitT m (Maybe String)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) b t.
(MonadIO (t m), MonadTrans t, MonadThrow m, MonadThrow (t m)) =>
Path b t -> t m (Maybe String)
readHash
where
readHash :: Path b t -> t m (Maybe String)
readHash Path b t
fpath = do
(ByteString
uc, ByteOffset
_, String
fp) <- IO ByteString -> t m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ByteString
BL.readFile (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ Path b t -> String
forall b t. Path b t -> String
P.toFilePath Path b t
fpath)
t m ByteString
-> (ByteString -> t m (ByteString, ByteOffset, [Word8]))
-> t m (ByteString, ByteOffset, [Word8])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((ByteString, ByteOffset, String)
-> t m (ByteString, ByteOffset, [Word8]))
-> ((ByteString, ByteOffset, [Word8])
-> t m (ByteString, ByteOffset, [Word8]))
-> Either
(ByteString, ByteOffset, String) (ByteString, ByteOffset, [Word8])
-> t m (ByteString, ByteOffset, [Word8])
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ParseException -> t m (ByteString, ByteOffset, [Word8])
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw (ParseException -> t m (ByteString, ByteOffset, [Word8]))
-> ((ByteString, ByteOffset, String) -> ParseException)
-> (ByteString, ByteOffset, String)
-> t m (ByteString, ByteOffset, [Word8])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ParseException
MasterHashParser (String -> ParseException)
-> ((ByteString, ByteOffset, String) -> String)
-> (ByteString, ByteOffset, String)
-> ParseException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString, ByteOffset, String) -> String
forall a b c. (a, b, c) -> c
thd3) (ByteString, ByteOffset, [Word8])
-> t m (ByteString, ByteOffset, [Word8])
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Either
(ByteString, ByteOffset, String) (ByteString, ByteOffset, [Word8])
-> t m (ByteString, ByteOffset, [Word8]))
-> (ByteString
-> Either
(ByteString, ByteOffset, String) (ByteString, ByteOffset, [Word8]))
-> ByteString
-> t m (ByteString, ByteOffset, [Word8])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Get [Word8]
-> ByteString
-> Either
(ByteString, ByteOffset, String) (ByteString, ByteOffset, [Word8])
forall a.
Get a
-> ByteString
-> Either
(ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
BG.runGetOrFail (Int -> Get Word8 -> Get [Word8]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
40 Get Word8
BG.getWord8)
t m (ByteString, ByteOffset, [Word8])
-> ((ByteString, ByteOffset, [Word8])
-> (ByteString, ByteOffset, String))
-> t m (ByteString, ByteOffset, String)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ([Word8] -> String)
-> (ByteString, ByteOffset, [Word8])
-> (ByteString, ByteOffset, String)
forall c c' a b. (c -> c') -> (a, b, c) -> (a, b, c')
third3 [Word8] -> String
BUS.decode
if ByteString -> Bool
BL.null ByteString
uc Bool -> Bool -> Bool
|| ByteString
uc ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"\n" then Maybe String -> t m (Maybe String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> t m (Maybe String))
-> Maybe String -> t m (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
fp else
m (Maybe String) -> t m (Maybe String)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Maybe String) -> t m (Maybe String))
-> m (Maybe String) -> t m (Maybe String)
forall a b. (a -> b) -> a -> b
$ ParseException -> m (Maybe String)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw (ParseException -> m (Maybe String))
-> ParseException -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> ParseException
MasterHashParser String
"invalid master/main hash"
runHMGit :: HMGitT m a -> HMGitConfig -> m a
runHMGit :: HMGitT m a -> HMGitConfig -> m a
runHMGit = HMGitT m a -> HMGitConfig -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT