From bbe3b75bfd0767c61bcd436e843b9c785efd289f Mon Sep 17 00:00:00 2001
From: Alexander Foremny <aforemny@posteo.de>
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