diff options
Diffstat (limited to 'src/Store/Store.hs')
| -rw-r--r-- | src/Store/Store.hs | 130 |
1 files changed, 102 insertions, 28 deletions
diff --git a/src/Store/Store.hs b/src/Store/Store.hs index 7917449..511d822 100644 --- a/src/Store/Store.hs +++ b/src/Store/Store.hs @@ -1,69 +1,90 @@ module Store.Store - ( withStore, - listDirectory, + ( StoreM, + withStore, + listFiles, readFile, + writeFile, + deleteFile, + commit, ) where +import Bindings.Libgit2 qualified as B import Control.Arrow (first) import Control.Exception (Exception, finally) -import Control.Monad.Catch (MonadCatch, MonadThrow, throwM) +import Control.Monad (when) +import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow, throwM) import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT) -import Control.Monad.State (MonadState, StateT, evalStateT, get) -import Control.Monad.Trans (MonadIO, MonadTrans, lift) +import Control.Monad.State (MonadState, StateT, evalStateT, get, modify) +import Control.Monad.Trans (MonadIO, MonadTrans, lift, liftIO) +import Control.Monad.Trans.Resource (MonadResource, runResourceT) import Data.ByteString qualified as B import Data.ByteString.Lazy qualified as LB import Data.ByteString.UTF8 qualified as B -import Data.List (isPrefixOf, sort) -import Data.Tagged (Tagged (Tagged)) +import Data.List (isPrefixOf, isSuffixOf, sort) +import Data.Tagged (Tagged (Tagged), untag) import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Time (getCurrentTimeZone, utcToZonedTime) +import Data.Time.Clock (getCurrentTime) +import Foreign import Git qualified as G import Git.Libgit2 qualified as GB import System.FilePath (addTrailingPathSeparator, hasDrive, joinDrive, makeRelative, normalise, splitPath) -import Prelude hiding (readFile) +import Text.Printf (printf) +import Prelude hiding (readFile, writeFile) newtype StoreT m a = StoreT - { runStoreT :: StateT GB.OidPtr (ReaderT GB.LgRepo m) a + { runStoreT :: StateT State (ReaderT Env m) a } deriving ( Applicative, Functor, Monad, - MonadReader GB.LgRepo, - MonadState GB.OidPtr, + MonadReader Env, + MonadState State, MonadCatch, MonadThrow, - MonadIO + MonadIO, + MonadMask, + MonadResource ) -instance MonadTrans StoreT where - lift = StoreT . lift . lift +data Env = Env + { repo :: GB.LgRepo, + ref :: G.RefName + } -class MonadStore m where - getCommitOid :: m (G.CommitOid GB.LgRepo) - getRepository :: m GB.LgRepo +data State = State + { cid :: G.CommitOid GB.LgRepo, + tid :: G.TreeOid GB.LgRepo + } -instance Monad m => MonadStore (StoreT m) where - getCommitOid = Tagged <$> get - getRepository = ask +instance MonadTrans StoreT where + lift = StoreT . lift . lift type StoreM = StoreT IO withStore :: FilePath -> G.RefName -> StoreM a -> IO a withStore repoPath ref action = do repo <- G.openRepository GB.lgFactory G.defaultRepositoryOptions {G.repoPath} - Just cid <- G.runRepository GB.lgFactory repo (G.resolveReference ref) - runReaderT (evalStateT (runStoreT action) cid) repo + (cid, tid) <- G.runRepository GB.lgFactory repo do + Just cid <- fmap Tagged <$> G.resolveReference ref + tid <- (.commitTree) <$> G.lookupCommit cid + pure (cid, tid) + runReaderT + (evalStateT (runStoreT action) (State {cid, tid})) + (Env {repo, ref}) `finally` G.runRepository GB.lgFactory repo G.closeRepository listDirectory :: FilePath -> StoreM [FilePath] listDirectory dir' = do - cid <- getCommitOid - repo <- getRepository + State {tid} <- get + Env {repo} <- ask lift $ G.runRepository GB.lgFactory repo $ do let dir = normalise $ if hasDrive dir' then dir' else joinDrive "/" dir' n = length (splitPath dir) - tree <- G.lookupTree =<< (.commitTree) <$> G.lookupCommit cid + tree <- G.lookupTree tid sort . map (makeRelative dir) . filter ((== n + 1) . length . splitPath) @@ -79,6 +100,10 @@ listDirectory dir' = do . map (first (("/" <>) . B.toString)) <$> G.listTreeEntries tree +listFiles :: FilePath -> StoreM [FilePath] +listFiles = + fmap (filter (not . (isSuffixOf "/"))) . listDirectory + data DoesNotExist = DoesNotExist String FilePath deriving (Show) @@ -106,10 +131,10 @@ readFile' :: FilePath -> StoreM a readFile' cat fp = do - cid <- getCommitOid - repo <- getRepository + State {tid} <- get + Env {repo} <- ask lift $ G.runRepository GB.lgFactory repo do - tree <- G.lookupTree =<< (.commitTree) <$> G.lookupCommit cid + tree <- G.lookupTree tid maybe (throwM (DoesNotExist "readFile" fp)) ( \e -> @@ -119,3 +144,52 @@ readFile' cat fp = do G.TreeEntry _ -> throwM (InappropriateType "readFile" fp) ) =<< G.treeEntry tree (B.fromString fp) + +writeFile :: FilePath -> LB.ByteString -> StoreM () +writeFile (B.fromString -> fp) v = do + State {tid} <- get + Env {repo} <- ask + tid' <- lift $ G.runRepository GB.lgFactory repo do + bid <- G.createBlobUtf8 (T.decodeUtf8 (LB.toStrict v)) + G.mutateTreeOid tid do + G.putBlob fp bid + modify $ \s -> s {tid = tid'} + +deleteFile :: FilePath -> StoreM () +deleteFile (B.fromString -> fp) = do + State {tid} <- get + Env {repo} <- ask + tid' <- lift $ G.runRepository GB.lgFactory repo do + G.mutateTreeOid tid do + G.dropEntry fp + G.currentTreeOid + modify $ \s -> s {tid = tid'} + +commit :: StoreM () +commit = do + State {cid, tid} <- get + Env {repo, ref} <- ask + now <- lift (utcToZonedTime <$> getCurrentTimeZone <*> getCurrentTime) + let sig = G.Signature "author" "email" now + cid' <- + lift $ runResourceT $ G.runRepository GB.lgFactory repo do + cid' <- + G.commitOid + <$> G.createCommit [cid] tid sig sig "auto-commit" (Just ref) + when (ref == "HEAD") $ reset cid' + pure cid' + modify $ \s -> s {cid = cid'} + +reset :: MonadIO m => GB.CommitOid -> ReaderT GB.LgRepo m () +reset cid = do + repo <- GB.getRepository + liftIO $ withForeignPtr (GB.repoObj repo) $ \repoPtr -> do + withForeignPtr (GB.getOid (untag cid)) $ \oidPtr -> do + alloca $ \cidPtr' -> do + exitCode <- B.c'git_object_lookup cidPtr' repoPtr oidPtr B.c'GIT_OBJ_COMMIT + when (exitCode /= 0) do + error (printf "unknown commit %s (%d)" (show cid) (fromIntegral exitCode :: Int)) + cidPtr <- peek cidPtr' + exitCode <- B.c'git_reset repoPtr cidPtr B.c'GIT_RESET_HARD + when (exitCode /= 0) do + error (printf "reset failed (%d)" (fromIntegral exitCode :: Int)) |