From bbe3b75bfd0767c61bcd436e843b9c785efd289f Mon Sep 17 00:00:00 2001 From: Alexander Foremny Date: Mon, 19 Feb 2024 04:55:36 +0100 Subject: support `INSERT`, `DELETE`, `UPDATE` --- app/Main.hs | 14 ++-- astore.cabal | 3 + src/Store.hs | 2 + src/Store/Exception.hs | 7 ++ src/Store/Query.hs | 73 ++++++++++++++++----- src/Store/Query/Parser.hs | 115 +++++++++++++++++++++++++++++---- src/Store/Query/Printer.hs | 157 ++++++++++++++++++++++++++++++++------------- src/Store/Query/Record.hs | 6 ++ src/Store/Query/Type.hs | 6 +- src/Store/Store.hs | 130 +++++++++++++++++++++++++++++-------- 10 files changed, 406 insertions(+), 107 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 8622317..945bfc9 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -49,6 +49,8 @@ serveCmd = main :: IO () main = do setCurrentDirectory "./data" + let root = "." + ref = "HEAD" A.execParser (A.info (args <**> A.helper) A.idm) >>= \case Args {cmd = Repl} -> do -- TODO Catch `ParseError` exception @@ -60,7 +62,12 @@ main = do -- @topic repl R.evalRepl (const . pure $ ">>> ") - (liftIO . query' . fromString) + ( liftIO + . (mapM_ (LB.putStrLn . J.encode) =<<) + . Q.withStore root ref + . Q.query + . fromString + ) ([]) (Just ':') (Just "paste") @@ -74,11 +81,8 @@ main = do q <- fromString @Q.Query . LB.toString <$> W.lazyRequestBody req - r <- Q.query q + r <- liftIO $ Q.withStore root ref (Q.query q) respond . W.responseLBS W.status200 [] $ J.encode r | otherwise -> respond $ W.responseLBS W.status200 [] "OK" - -query' :: Q.Query -> IO () -query' q = mapM_ (LB.putStrLn . J.encode) =<< Q.query q diff --git a/astore.cabal b/astore.cabal index 232b01f..2aa0f73 100644 --- a/astore.cabal +++ b/astore.cabal @@ -40,11 +40,14 @@ library filepath, gitlib, gitlib-libgit2, + hlibgit2, megaparsec, mtl, parser-combinators, + resourcet, tagged, text, + time, unliftio, unliftio-core, unordered-containers, diff --git a/src/Store.hs b/src/Store.hs index f7562f5..1cb9392 100644 --- a/src/Store.hs +++ b/src/Store.hs @@ -1,6 +1,8 @@ module Store ( module Store.Query, + module Store.Store, ) where import Store.Query +import Store.Store diff --git a/src/Store/Exception.hs b/src/Store/Exception.hs index 245780c..94beaab 100644 --- a/src/Store/Exception.hs +++ b/src/Store/Exception.hs @@ -2,10 +2,12 @@ module Store.Exception ( DecodeException (DecodeException), DuplicateField (DuplicateField), ParseError (ParseError), + MissingFileName (MissingFileName), ) where import Control.Exception (Exception) +import Data.Aeson qualified as J data DecodeException = DecodeException deriving (Show) @@ -21,3 +23,8 @@ data ParseError = ParseError String deriving (Show) instance Exception ParseError + +data MissingFileName = MissingFileName J.Value + deriving (Show) + +instance Exception MissingFileName diff --git a/src/Store/Query.hs b/src/Store/Query.hs index f8575af..ccca93f 100644 --- a/src/Store/Query.hs +++ b/src/Store/Query.hs @@ -4,15 +4,18 @@ module Store.Query ) where +import Control.Arrow (second) import Control.Exception (throw) +import Control.Monad.Trans (lift) import Data.Aeson qualified as J import Data.Aeson.Key qualified as JK import Data.Aeson.KeyMap qualified as JM -import Data.List (foldl', isSuffixOf) +import Data.List (foldl', foldl1') import Data.Map qualified as M import Data.Maybe (fromMaybe) +import Data.Text qualified as T import Data.Vector qualified as V -import Store.Exception (DecodeException (DecodeException)) +import Store.Exception (DecodeException (DecodeException), MissingFileName (MissingFileName)) import Store.Query.Parser () import Store.Query.Printer () import Store.Query.Record @@ -20,30 +23,61 @@ import Store.Query.Type import Store.Store qualified as S import System.FilePath (()) -query :: Query -> IO [J.Value] +query :: Query -> S.StoreM [J.Value] +query (Delete c w) = do + c' <- + mapM (\fn -> fmap ((fn,) . fromValue c) . decodeFile $ fn) + . map (c ) + =<< S.listFiles c + let fps = map fst $ whereBy snd w (map (second (: [])) c') + lift $ print fps + mapM_ S.deleteFile fps + S.commit + pure [] +query (Insert vs c) = do + let vs' = map (\v -> (fileName v, v)) vs + + fileName v@(J.Object kvs) = + case JM.lookup "$fileName" kvs of + Just (J.String fileName) -> c T.unpack fileName + _ -> throw (MissingFileName v) + mapM_ (\(fp, v) -> encodeFile fp v) vs' + S.commit + pure [] query (Select fs c js es w) = do c' <- - mapM (fmap (fromValue c) . decodeFile . (c )) =<< ls c + mapM (fmap (fromValue c) . decodeFile . (c )) + =<< S.listFiles c js' <- mapM ( \(JoinClause t c w) -> - fmap (\j' -> JoinClause t (map (fromValue c) j') w) . mapM (decodeFile . (c )) - =<< ls c + fmap (\j' -> JoinClause t (map (fromValue c) j') w) + . mapM (decodeFile . (c )) + =<< S.listFiles c ) js es' <- mapM ( \(EmbedClause c w) -> - fmap (\e' -> EmbedClause (fromValue c e') w) . mapM (decodeFile . (c )) - =<< ls c + fmap (\e' -> EmbedClause (fromValue c e') w) + . mapM (decodeFile . (c )) + =<< S.listFiles c ) es pure $ map (Store.Query.select fs) $ where_ w $ embeds es' $ joins js' c' - where - ls c = - filter (not . (isSuffixOf "/")) - <$> S.withStore "." "HEAD" do - S.listDirectory c +query (Update c v w) = do + c' <- + mapM (\fn -> fmap ((fn,) . fromValue c) . decodeFile $ fn) + . map (c ) + =<< S.listFiles c + let c'' = whereBy snd w (map (second (: [])) c') + mapM_ + ( \(fp, v') -> + encodeFile fp (foldl1' union (map toValue v') `union` v) + ) + c'' + S.commit + pure [] embeds :: EmbedClauses (Record [J.Value]) -> @@ -121,7 +155,10 @@ select (SelectObject kvs) vs = select (SelectField f) vs = fromMaybe J.Null (lookups f vs) where_ :: Maybe WhereClause -> [Records J.Value] -> [Records J.Value] -where_ w = filter (satisfies w) +where_ = whereBy id + +whereBy :: (a -> [Record J.Value]) -> Maybe WhereClause -> [a] -> [a] +whereBy f w = filter (satisfies w . f) satisfies :: Maybe WhereClause -> Records J.Value -> Bool satisfies Nothing _ = True @@ -129,6 +166,10 @@ satisfies (Just (And ws)) vs = all (\w -> satisfies (Just w) vs) ws satisfies (Just (Or ws)) vs = any (\w -> satisfies (Just w) vs) ws satisfies (Just (Where (Eq f g))) vs = lookups f vs == lookups g vs -decodeFile :: J.FromJSON a => Collection -> IO a -decodeFile fp = S.withStore "." "HEAD" do +decodeFile :: J.FromJSON a => Collection -> S.StoreM a +decodeFile fp = fromMaybe (throw DecodeException) . J.decode <$> S.readFile fp + +encodeFile :: Collection -> J.Value -> S.StoreM () +encodeFile fp v = + S.writeFile fp (J.encode v) diff --git a/src/Store/Query/Parser.hs b/src/Store/Query/Parser.hs index cb02f32..e16c926 100644 --- a/src/Store/Query/Parser.hs +++ b/src/Store/Query/Parser.hs @@ -4,10 +4,14 @@ module Store.Query.Parser () where import Control.Exception (throw) import Control.Monad (void) +import Data.Aeson qualified as J +import Data.Aeson.Key qualified as JK +import Data.Aeson.KeyMap qualified as JM import Data.Char (isSpace) import Data.Map qualified as M import Data.String (IsString (fromString)) import Data.Text qualified as T +import Data.Vector qualified as V import Data.Void (Void) import Store.Exception (ParseError (ParseError)) import Store.Query.Type @@ -22,21 +26,53 @@ instance IsString Query where where parser = do void $ P.many P.space1 - select - fs <- fieldSelector - from - c <- collection - js <- joinClauses - es <- embedClauses - w <- P.optional do - where_ - whereClause - P.eof - pure $ Select fs c js es w + P.choice + [ do + delete + from + c <- collection + w <- P.optional do + where_ + whereClause + pure $ Delete c w, + do + insert + vs <- objects + into + c <- collection + pure $ Insert vs c, + do + select + fs <- fieldSelector + from + c <- collection + js <- joinClauses + es <- embedClauses + w <- P.optional do + where_ + whereClause + pure $ Select fs c js es w, + do + update + c <- collection + set + v <- object + w <- + P.optional do + where_ + whereClause + pure $ Update c v w + ] + <* P.eof lexeme :: P.Parsec Void String a -> P.Parsec Void String a lexeme = P.lexeme $ void $ P.takeWhileP Nothing isSpace + set = void $ lexeme (P.string "SET") + update = void $ lexeme (P.string "UPDATE") + into = void $ lexeme (P.string "INTO") + insert = void $ lexeme (P.string "INSERT") + delete = void $ lexeme (P.string "DELETE") and = void $ lexeme (P.string "AND") colon = void $ lexeme (P.string ":") comma = void $ lexeme (P.string ",") @@ -120,6 +156,63 @@ instance IsString Query where SelectField <$> field ] + objects = P.sepBy object comma + + object = lexeme do + void $ lexeme $ P.string "{" + kvs <- + P.sepBy + ( do + k <- + lexeme $ do + void $ lexeme $ P.string "\"" + P.takeWhile1P + Nothing + (/= '\"') + <* (void $ lexeme $ P.string "\"") + lexeme $ colon + v <- value + pure (JK.fromString k, v) + ) + comma + void $ lexeme $ P.string "}" + pure $ J.Object (JM.fromList kvs) + + value = + P.choice + [ object, + array, + string, + number, + bool, + null_ + ] + + array = lexeme do + void $ lexeme $ P.string "[" + vs <- P.sepBy value comma + void $ lexeme $ P.string "]" + pure $ J.Array (V.fromList vs) + + string = lexeme do + void $ lexeme $ P.string "\"" + s <- P.takeWhileP Nothing (\c -> c /= '\"') + void $ lexeme $ P.string "\"" + pure $ J.String (T.pack s) + + number = lexeme do + J.Number <$> P.scientific + + bool = lexeme do + J.Bool + <$> P.choice + [ const True <$> P.string "true", + const False <$> P.string "false" + ] + + null_ = lexeme do + const J.Null <$> P.string "null" + field :: P.Parsec Void String Field field = lexeme do diff --git a/src/Store/Query/Printer.hs b/src/Store/Query/Printer.hs index 7861bc9..26f4e8b 100644 --- a/src/Store/Query/Printer.hs +++ b/src/Store/Query/Printer.hs @@ -2,56 +2,121 @@ module Store.Query.Printer () where +import Data.Aeson qualified as J +import Data.Aeson.Key qualified as JK +import Data.Aeson.KeyMap qualified as JM import Data.List (intercalate) import Data.Maybe (catMaybes, mapMaybe) +import Data.Text qualified as T +import Data.Vector qualified as V import Store.Query.Field import Store.Query.Type instance Show Query where + show (Delete c w) = + intercalate " " . catMaybes $ + [ Just "DELETE FROM ", + Just (showCollection c), + showWhereClause w + ] + show (Insert vs c) = + intercalate " " . catMaybes $ + [ Just "INSERT", + showValues vs, + Just "INTO", + Just (showCollection c) + ] show (Select fs c js es w) = - intercalate " " $ - catMaybes $ - [ Just "SELECT", - Just (showFieldSelector fs), - Just "FROM", - Just (showCollection c), - showJoinClauses js, - showEmbedClauses es, - showWhereClause w - ] - where - showFieldSelector = error "showFieldSelector" - showField = Store.Query.Field.toString - showCollection c = c - showJoinClauses js = case map showJoinClause js of - [] -> Nothing - xs -> Just (intercalate " " xs) - showJoinClause (JoinClause t c w) = - intercalate " " $ - catMaybes $ - [ Just (showJoinType t), - Just (showCollection c), - Just "ON", - showWhereClause w - ] - showJoinType JoinLeft = "LEFT JOIN" - showJoinType JoinRight = "RIGHT JOIN" - showJoinType JoinFull = "FULL JOIN" - showEmbedClauses js = case map showEmbedClause js of - [] -> Nothing - xs -> Just (intercalate " " xs) - showEmbedClause (EmbedClause c w) = - intercalate " " $ - catMaybes $ - [ Just "EMBED", - Just (showCollection c), - Just "ON", - showWhereClause w - ] - showWhereClause = showWhereClauseWith id - showWhereClause' = showWhereClauseWith (\x -> "(" <> x <> ")") - showWhereClauseWith _ Nothing = Nothing - showWhereClauseWith wrap (Just (And ws)) = Just (wrap (intercalate "AND" (mapMaybe (showWhereClause' . Just) ws))) - showWhereClauseWith wrap (Just (Or ws)) = Just (wrap (intercalate "OR" (mapMaybe (showWhereClause' . Just) ws))) - showWhereClauseWith _ (Just (Where p)) = Just (showComparison p) - showComparison (Eq a b) = intercalate " " [showField a, "==", showField b] + intercalate " " . catMaybes $ + [ Just "SELECT", + Just (showFieldSelector fs), + Just "FROM", + Just (showCollection c), + showJoinClauses js, + showEmbedClauses es, + showWhereClause w + ] + show (Update c v w) = + intercalate " " . catMaybes $ + [ Just "UPDATE", + Just (showCollection c), + Just "SET", + Just (showValue v), + showWhereClause w + ] + +showFieldSelector :: FieldSelector -> String +showFieldSelector = error "showFieldSelector" + +showField :: Field -> String +showField = Store.Query.Field.toString + +showCollection :: Collection -> String +showCollection c = c + +showJoinClauses :: [JoinClause String] -> Maybe String +showJoinClauses js = case map showJoinClause js of + [] -> Nothing + xs -> Just (intercalate " " xs) + +showJoinClause :: JoinClause String -> String +showJoinClause (JoinClause t c w) = + intercalate " " $ + catMaybes $ + [ Just (showJoinType t), + Just (showCollection c), + Just "ON", + showWhereClause w + ] + +showJoinType :: JoinType -> String +showJoinType JoinLeft = "LEFT JOIN" +showJoinType JoinRight = "RIGHT JOIN" +showJoinType JoinFull = "FULL JOIN" + +showEmbedClauses :: [EmbedClause String] -> Maybe String +showEmbedClauses js = case map showEmbedClause js of + [] -> Nothing + xs -> Just (intercalate " " xs) + +showEmbedClause :: EmbedClause String -> String +showEmbedClause (EmbedClause c w) = + intercalate " " $ + catMaybes $ + [ Just "EMBED", + Just (showCollection c), + Just "ON", + showWhereClause w + ] + +showWhereClause :: Maybe WhereClause -> Maybe String +showWhereClause = showWhereClauseWith id + +showWhereClause' :: Maybe WhereClause -> Maybe String +showWhereClause' = showWhereClauseWith (\x -> "(" <> x <> ")") + +showWhereClauseWith :: (String -> String) -> Maybe WhereClause -> Maybe String +showWhereClauseWith _ Nothing = Nothing +showWhereClauseWith wrap (Just (And ws)) = Just (wrap (intercalate "AND" (mapMaybe (showWhereClause' . Just) ws))) +showWhereClauseWith wrap (Just (Or ws)) = Just (wrap (intercalate "OR" (mapMaybe (showWhereClause' . Just) ws))) +showWhereClauseWith _ (Just (Where p)) = Just (showComparison p) + +showComparison :: Comparison -> String +showComparison (Eq a b) = intercalate " " [showField a, "==", showField b] + +showValues :: [J.Value] -> Maybe String +showValues [] = Nothing +showValues vs = Just (intercalate ", " (map showValue vs)) + +showValue :: J.Value -> String +showValue (J.Object kvs) = + intercalate + ",\n" + (map (\(k, v) -> "\"" <> JK.toString k <> "\" : " <> showValue v) (JM.toList kvs)) +showValue (J.Array (V.toList -> vs)) = + "[" <> intercalate ", " (map showValue vs) <> "]" +showValue (J.String c) = "\"" <> T.unpack c <> "\"" +showValue (J.Number c) = show c +showValue (J.Bool True) = "true" +showValue (J.Bool False) = "false" +showValue J.Null = "null" diff --git a/src/Store/Query/Record.hs b/src/Store/Query/Record.hs index b00be27..d663716 100644 --- a/src/Store/Query/Record.hs +++ b/src/Store/Query/Record.hs @@ -5,6 +5,7 @@ module Store.Query.Record lookup, Records, lookups, + union, disjointUnion, disjointUnions, ) @@ -52,6 +53,11 @@ lookups f rs = [v] -> Just v (_ : _) -> throw (DuplicateField (toString f)) +union :: J.Value -> J.Value -> J.Value +union (J.Object r) (J.Object s) = + J.Object (JM.unionWith union r s) +union _ s = s + disjointUnion :: J.Value -> J.Value -> J.Value disjointUnion (J.Object r) (J.Object s) = J.Object (JM.unionWithKey disjointUnion' r s) diff --git a/src/Store/Query/Type.hs b/src/Store/Query/Type.hs index abf2c77..7065267 100644 --- a/src/Store/Query/Type.hs +++ b/src/Store/Query/Type.hs @@ -14,17 +14,21 @@ module Store.Query.Type ) where +import Data.Aeson qualified as J import Data.Map qualified as M import Store.Query.Field import Store.Query.Record data Query - = Select + = Delete Collection (Maybe WhereClause) + | Insert [J.Value] Collection + | Select FieldSelector Collection (JoinClauses FilePath) (EmbedClauses FilePath) (Maybe WhereClause) + | Update Collection J.Value (Maybe WhereClause) data FieldSelector = SelectObject (M.Map String FieldSelector) 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)) -- cgit v1.2.3