From 950eea3ba04e94cf3d5797f9b5d32b2621c89b55 Mon Sep 17 00:00:00 2001
From: Alexander Foremny <aforemny@posteo.de>
Date: Tue, 13 Feb 2024 02:07:20 +0100
Subject: refactor library
---
app/Debug.hs | 10 ----
app/Exception.hs | 23 --------
app/Main.hs | 2 +-
app/Query.hs | 134 ---------------------------------------------
app/Query/Field.hs | 32 -----------
app/Query/Parser.hs | 126 ------------------------------------------
app/Query/Printer.hs | 60 --------------------
app/Query/Record.hs | 80 ---------------------------
app/Query/Type.hs | 62 ---------------------
app/Store.hs | 121 ----------------------------------------
astore.cabal | 64 ++++++++++++++++++++++
json2sql.cabal | 60 --------------------
src/Store.hs | 6 ++
src/Store/Debug.hs | 10 ++++
src/Store/Exception.hs | 23 ++++++++
src/Store/Query.hs | 134 +++++++++++++++++++++++++++++++++++++++++++++
src/Store/Query/Field.hs | 32 +++++++++++
src/Store/Query/Parser.hs | 126 ++++++++++++++++++++++++++++++++++++++++++
src/Store/Query/Printer.hs | 60 ++++++++++++++++++++
src/Store/Query/Record.hs | 80 +++++++++++++++++++++++++++
src/Store/Query/Type.hs | 62 +++++++++++++++++++++
src/Store/Store.hs | 121 ++++++++++++++++++++++++++++++++++++++++
22 files changed, 719 insertions(+), 709 deletions(-)
delete mode 100644 app/Debug.hs
delete mode 100644 app/Exception.hs
delete mode 100644 app/Query.hs
delete mode 100644 app/Query/Field.hs
delete mode 100644 app/Query/Parser.hs
delete mode 100644 app/Query/Printer.hs
delete mode 100644 app/Query/Record.hs
delete mode 100644 app/Query/Type.hs
delete mode 100644 app/Store.hs
create mode 100644 astore.cabal
delete mode 100644 json2sql.cabal
create mode 100644 src/Store.hs
create mode 100644 src/Store/Debug.hs
create mode 100644 src/Store/Exception.hs
create mode 100644 src/Store/Query.hs
create mode 100644 src/Store/Query/Field.hs
create mode 100644 src/Store/Query/Parser.hs
create mode 100644 src/Store/Query/Printer.hs
create mode 100644 src/Store/Query/Record.hs
create mode 100644 src/Store/Query/Type.hs
create mode 100644 src/Store/Store.hs
diff --git a/app/Debug.hs b/app/Debug.hs
deleted file mode 100644
index 3499e02..0000000
--- a/app/Debug.hs
+++ /dev/null
@@ -1,10 +0,0 @@
-module Debug
- ( debug,
- )
-where
-
-import Debug.Trace (trace)
-import Text.Printf (printf)
-
-debug :: Show a => String -> a -> a
-debug s x = trace (printf "%s: %s" s (show x)) x
diff --git a/app/Exception.hs b/app/Exception.hs
deleted file mode 100644
index 0cccf5b..0000000
--- a/app/Exception.hs
+++ /dev/null
@@ -1,23 +0,0 @@
-module Exception
- ( DecodeException (DecodeException),
- DuplicateField (DuplicateField),
- ParseError (ParseError),
- )
-where
-
-import Control.Exception (Exception)
-
-data DecodeException = DecodeException
- deriving (Show)
-
-instance Exception DecodeException
-
-data DuplicateField = DuplicateField String
- deriving (Show)
-
-instance Exception DuplicateField
-
-data ParseError = ParseError String
- deriving (Show)
-
-instance Exception ParseError
diff --git a/app/Main.hs b/app/Main.hs
index 7bf67ba..5574afa 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -5,7 +5,7 @@ where
import Data.Aeson qualified as J
import Data.ByteString.Lazy.Char8 qualified as LB
-import Query qualified as Q
+import Store qualified as Q
import System.Directory (setCurrentDirectory)
import Text.Printf (printf)
diff --git a/app/Query.hs b/app/Query.hs
deleted file mode 100644
index 140d0f1..0000000
--- a/app/Query.hs
+++ /dev/null
@@ -1,134 +0,0 @@
-module Query
- ( module Query.Type,
- query,
- )
-where
-
-import Control.Exception (throw)
-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.NonEmpty qualified as N
-import Data.Maybe (fromMaybe)
-import Data.Vector qualified as V
-import Exception (DecodeException (DecodeException))
-import Query.Parser ()
-import Query.Printer ()
-import Query.Record
-import Query.Type
-import Store qualified as S
-import System.FilePath ((</>))
-
-query :: Query -> IO [J.Value]
-query (Select fs c js es w) = do
- c' <-
- mapM (fmap (fromValue c) . decodeFile . (c </>)) =<< ls c
- js' <-
- mapM
- ( \(JoinClause t c w) ->
- fmap (\j' -> JoinClause t (map (fromValue c) j') w) . mapM (decodeFile . (c </>))
- =<< ls c
- )
- js
- es' <-
- mapM
- ( \(EmbedClause c w) ->
- fmap (\e' -> EmbedClause (fromValue c e') w) . mapM (decodeFile . (c </>))
- =<< ls c
- )
- es
- pure $ map (Query.select fs) $ where_ w $ embeds es' $ joins js' c'
- where
- ls c =
- filter (not . (isSuffixOf "/"))
- <$> S.withStore "." "HEAD" do
- S.listDirectory c
-
-embeds ::
- EmbedClauses (Record [J.Value]) ->
- [Records J.Value] ->
- [Records J.Value]
-embeds = flip (foldl' embed)
-
-embed ::
- [Records J.Value] ->
- EmbedClause (Record [J.Value]) ->
- [Records J.Value]
-embed vss (EmbedClause (Record c es) w) =
- map
- ( \vs ->
- vs
- ++ [ fromValue
- c
- ( J.Object
- ( JM.singleton
- (JK.fromString c)
- ( J.Array
- ( V.fromList
- [ e
- | e <- es,
- satisfies w (vs ++ [Record c e])
- ]
- )
- )
- )
- )
- ]
- )
- vss
-
-joins ::
- JoinClauses (Records J.Value) ->
- [Record J.Value] ->
- [Records J.Value]
-joins js (map (: []) -> vss) = foldl' join vss js
-
-join ::
- [Records J.Value] ->
- JoinClause (Records J.Value) ->
- [Records J.Value]
-join vss (JoinClause JoinLeft js w) =
- concatMap
- ( \vs -> case filter (satisfies w) $ map (\j -> vs ++ [j]) js of
- [] -> [vs]
- vs' -> vs'
- )
- vss
-join vss (JoinClause JoinRight js w) =
- concatMap
- ( \j -> case filter (satisfies w) $ map (\vs -> vs ++ [j]) vss of
- [] -> [[j]]
- vs' -> vs'
- )
- js
-join vss (JoinClause JoinFull js w) =
- concatMap
- ( \vs -> case filter (satisfies w) $ map (\j -> vs ++ [j]) js of
- [] -> [vs]
- vs' -> vs'
- )
- vss
- ++ concatMap
- ( \j -> case filter (satisfies w) $ map (\vs -> vs ++ [j]) vss of
- [] -> [[j]]
- _ -> []
- )
- js
-
-select :: FieldSelector -> Records J.Value -> J.Value
-select All vs = disjointUnions (map toValue vs)
-select (Only fs) vs = Query.Record.select (N.toList fs) vs
-
-where_ :: Maybe WhereClause -> [Records J.Value] -> [Records J.Value]
-where_ w = filter (satisfies w)
-
-satisfies :: Maybe WhereClause -> Records J.Value -> Bool
-satisfies Nothing _ = True
-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
- fromMaybe (throw DecodeException) . J.decode <$> S.readFile fp
diff --git a/app/Query/Field.hs b/app/Query/Field.hs
deleted file mode 100644
index cdb977a..0000000
--- a/app/Query/Field.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-module Query.Field
- ( Field (..),
- toString,
- prefix,
- )
-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.List.NonEmpty qualified as N
-import Data.Text qualified as T
-
-data Field
- = Qualified Collection (N.NonEmpty T.Text)
- | Unqualified (N.NonEmpty T.Text)
- deriving (Show)
-
-toString :: Field -> String
-toString (Qualified c ks) = intercalate "." (c : map T.unpack (N.toList ks))
-toString (Unqualified ks) = intercalate "." (map T.unpack (N.toList ks))
-
-type Collection = FilePath
-
-prefix :: Field -> J.Value -> J.Value
-prefix (Qualified c ks) = prefix' (T.pack c : N.toList ks)
-prefix (Unqualified ks) = prefix' (N.toList ks)
-
-prefix' :: [T.Text] -> J.Value -> J.Value
-prefix' ks v =
- foldr ((J.Object .) . JM.singleton) v (map JK.fromText ks)
diff --git a/app/Query/Parser.hs b/app/Query/Parser.hs
deleted file mode 100644
index f2012e2..0000000
--- a/app/Query/Parser.hs
+++ /dev/null
@@ -1,126 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Query.Parser () where
-
-import Control.Exception (throw)
-import Control.Monad (void)
-import Control.Monad.Combinators.NonEmpty qualified as PN
-import Data.Char (isSpace)
-import Data.List.NonEmpty qualified as N
-import Data.String (IsString (fromString))
-import Data.Text qualified as T
-import Data.Void (Void)
-import Exception (ParseError (ParseError))
-import Query.Type
-import Text.Megaparsec qualified as P
-import Text.Megaparsec.Char qualified as P
-import Text.Megaparsec.Char.Lexer qualified as P
-
-instance IsString Query where
- fromString =
- either (throw . ParseError . P.errorBundlePretty @String @Void) id
- . P.parse parser ""
- 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
-
- lexeme :: P.Parsec Void String a -> P.Parsec Void String a
- lexeme = P.lexeme $ void $ P.takeWhileP Nothing isSpace
-
- and = void $ lexeme (P.string "AND")
- comma = void $ lexeme (P.string ",")
- embed = void $ lexeme (P.string "EMBED")
- eq = void $ lexeme (P.string "==")
- from = void $ lexeme (P.string "FROM")
- on = void $ lexeme (P.string "ON")
- or = void $ lexeme (P.string "OR")
- select = void $ lexeme (P.string "SELECT")
- where_ = void $ lexeme (P.string "WHERE")
-
- collection = lexeme $ P.takeWhile1P (Just "collection") (not . isSpace)
-
- joinClauses = P.many joinClause
-
- joinClause = do
- t <- joinType
- c <- collection
- w <- P.optional do
- on
- whereClause
- pure $ JoinClause t c w
-
- embedClauses = P.many embedClause
-
- embedClause = do
- embed
- c <- collection
- w <- P.optional do
- on
- whereClause
- pure $ EmbedClause c w
-
- whereClause =
- P.choice
- [ P.try (And . map Where <$> P.sepBy1 comparison and),
- P.try (Or . map Where <$> P.sepBy1 comparison or),
- Where <$> comparison
- ]
-
- comparison = do
- a <- field
- eq
- b <- field
- pure $ Eq a b
-
- fieldSelector =
- P.choice
- [ do
- void $ lexeme $ P.string "*"
- pure All,
- do
- Only <$> PN.sepBy1 field comma
- ]
-
- field :: P.Parsec Void String Field
- field =
- lexeme . P.choice $
- [ P.try
- do
- Qualified
- <$> (fieldPart <* P.string ".")
- <*> (N.map T.pack <$> PN.sepBy1 fieldPart (P.string ".")),
- do
- Unqualified
- <$> (N.map T.pack <$> PN.sepBy1 fieldPart (P.string "."))
- ]
-
- fieldPart :: P.Parsec Void String String
- fieldPart = P.takeWhile1P Nothing (\c -> not (isSpace c) && c /= ',' && c /= '.')
-
- joinType :: P.Parsec Void String JoinType
- joinType =
- P.choice
- [ do
- void $ lexeme (P.string "LEFT")
- void $ lexeme (P.string "JOIN")
- pure JoinLeft,
- do
- void $ lexeme (P.string "RIGHT")
- void $ lexeme (P.string "JOIN")
- pure JoinRight,
- do
- void $ lexeme (P.string "FULL")
- void $ lexeme (P.string "JOIN")
- pure JoinFull
- ]
diff --git a/app/Query/Printer.hs b/app/Query/Printer.hs
deleted file mode 100644
index e43b7d0..0000000
--- a/app/Query/Printer.hs
+++ /dev/null
@@ -1,60 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module Query.Printer () where
-
-import Data.List (intercalate)
-import Data.List.NonEmpty qualified as N
-import Data.Maybe (catMaybes, mapMaybe)
-import Query.Field
-import Query.Type
-
-instance Show Query where
- 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 All = "*"
- showFieldSelector (Only (N.toList -> fs)) =
- intercalate ", " (map showField fs)
- showField = 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]
diff --git a/app/Query/Record.hs b/app/Query/Record.hs
deleted file mode 100644
index b1b3329..0000000
--- a/app/Query/Record.hs
+++ /dev/null
@@ -1,80 +0,0 @@
-module Query.Record
- ( Record (..),
- fromValue,
- toValue,
- lookup,
- Records,
- lookups,
- select,
- disjointUnion,
- disjointUnions,
- )
-where
-
-import Control.Exception (throw)
-import Data.Aeson qualified as J
-import Data.Aeson.Key qualified as JK
-import Data.Aeson.KeyMap qualified as JM
-import Data.List (foldl')
-import Data.List.NonEmpty qualified as N
-import Data.Maybe (fromMaybe, mapMaybe)
-import Data.Text qualified as T
-import Exception (DuplicateField (DuplicateField))
-import Query.Field
-import Prelude hiding (lookup)
-
-data Record a
- = Record Collection a
- deriving (Show, Eq)
-
-type Collection = FilePath
-
-fromValue :: Collection -> a -> Record a
-fromValue = Record
-
-toValue :: Record a -> a
-toValue (Record _ v) = v
-
-lookup :: Field -> Record J.Value -> Maybe J.Value
-lookup (Unqualified ks) (Record _ v) =
- lookup' (N.toList ks) v
-lookup (Qualified c' ks) (Record c v)
- | c' == c = lookup' (N.toList ks) v
- | otherwise = Nothing
-
-lookup' :: [T.Text] -> J.Value -> Maybe J.Value
-lookup' [] v = Just v
-lookup' (k : ks) (J.Object kvs) =
- lookup' ks =<< JM.lookup (JK.fromText k) kvs
-
-type Records a = [Record a]
-
-lookups :: Field -> Records J.Value -> Maybe J.Value
-lookups f rs =
- case mapMaybe (lookup f) rs of
- [] -> Nothing
- [v] -> Just v
- (_ : _) -> throw (DuplicateField (toString f))
-
-select :: [Field] -> Records J.Value -> J.Value
-select fs rs =
- foldl'
- union
- (J.Object JM.empty)
- (map (\f -> prefix f ((fromMaybe J.Null (lookups f rs)))) fs)
-
-union :: J.Value -> J.Value -> J.Value
-union (J.Object r) (J.Object s) = J.Object (JM.unionWith union r s)
-
-disjointUnion :: J.Value -> J.Value -> J.Value
-disjointUnion (J.Object r) (J.Object s) =
- J.Object (JM.unionWithKey disjointUnion' r s)
-
-disjointUnion' :: JK.Key -> J.Value -> J.Value -> J.Value
-disjointUnion' _ (J.Object r) (J.Object s) =
- J.Object (JM.unionWithKey disjointUnion' r s)
-disjointUnion' k _ _ =
- throw (DuplicateField (JK.toString k))
-
-disjointUnions :: [J.Value] -> J.Value
-disjointUnions = foldl' disjointUnion (J.Object JM.empty)
diff --git a/app/Query/Type.hs b/app/Query/Type.hs
deleted file mode 100644
index d27106f..0000000
--- a/app/Query/Type.hs
+++ /dev/null
@@ -1,62 +0,0 @@
-module Query.Type
- ( module Query.Field,
- module Query.Record,
- Collection,
- Comparison (..),
- EmbedClause (..),
- EmbedClauses,
- FieldSelector (..),
- JoinClause (..),
- JoinClauses,
- JoinType (..),
- Query (..),
- WhereClause (..),
- )
-where
-
-import Data.List.NonEmpty qualified as N
-import Query.Field
-import Query.Record
-
-data Query
- = Select
- FieldSelector
- Collection
- (JoinClauses FilePath)
- (EmbedClauses FilePath)
- (Maybe WhereClause)
-
-data FieldSelector
- = All
- | Only (N.NonEmpty Field)
- deriving (Show)
-
-type Collection = FilePath
-
-type JoinClauses a = [JoinClause a]
-
-data JoinClause a
- = JoinClause JoinType a (Maybe WhereClause)
- deriving (Show)
-
-data JoinType
- = JoinLeft
- | JoinRight
- | JoinFull
- deriving (Show)
-
-type EmbedClauses a = [EmbedClause a]
-
-data EmbedClause a
- = EmbedClause a (Maybe WhereClause)
- deriving (Show)
-
-data WhereClause
- = And [WhereClause]
- | Or [WhereClause]
- | Where Comparison
- deriving (Show)
-
-data Comparison
- = Eq Field Field
- deriving (Show)
diff --git a/app/Store.hs b/app/Store.hs
deleted file mode 100644
index 3a899b6..0000000
--- a/app/Store.hs
+++ /dev/null
@@ -1,121 +0,0 @@
-module Store
- ( withStore,
- listDirectory,
- readFile,
- )
-where
-
-import Control.Arrow (first)
-import Control.Exception (Exception, finally)
-import Control.Monad.Catch (MonadCatch, 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 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.Text qualified as T
-import Git qualified as G
-import Git.Libgit2 qualified as GB
-import System.FilePath (addTrailingPathSeparator, hasDrive, joinDrive, makeRelative, normalise, splitPath)
-import Prelude hiding (readFile)
-
-newtype StoreT m a = StoreT
- { runStoreT :: StateT GB.OidPtr (ReaderT GB.LgRepo m) a
- }
- deriving
- ( Applicative,
- Functor,
- Monad,
- MonadReader GB.LgRepo,
- MonadState GB.OidPtr,
- MonadCatch,
- MonadThrow,
- MonadIO
- )
-
-instance MonadTrans StoreT where
- lift = StoreT . lift . lift
-
-class MonadStore m where
- getCommitOid :: m (G.CommitOid GB.LgRepo)
- getRepository :: m GB.LgRepo
-
-instance Monad m => MonadStore (StoreT m) where
- getCommitOid = Tagged <$> get
- getRepository = ask
-
-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
- `finally` G.runRepository GB.lgFactory repo G.closeRepository
-
-listDirectory :: FilePath -> StoreM [FilePath]
-listDirectory dir' = do
- cid <- getCommitOid
- repo <- getRepository
- 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
- sort
- . map (makeRelative dir)
- . filter ((== n + 1) . length . splitPath)
- . filter (isPrefixOf (addTrailingPathSeparator dir))
- . map fst
- . map
- ( \e ->
- case snd e of
- G.BlobEntry _ _ -> e
- G.CommitEntry _ -> error "XXX commit entry"
- G.TreeEntry _ -> first addTrailingPathSeparator e
- )
- . map (first (("/" <>) . B.toString))
- <$> G.listTreeEntries tree
-
-data DoesNotExist = DoesNotExist String FilePath
- deriving (Show)
-
-instance Exception DoesNotExist
-
-data InappropriateType = InappropriateType String FilePath
- deriving (Show)
-
-instance Exception InappropriateType
-
-class Readable a where
- readFile :: FilePath -> StoreM a
-
-instance Readable T.Text where
- readFile = readFile' G.catBlobUtf8
-
-instance Readable B.ByteString where
- readFile = readFile' G.catBlob
-
-instance Readable LB.ByteString where
- readFile = readFile' G.catBlobLazy
-
-readFile' ::
- (G.BlobOid GB.LgRepo -> ReaderT GB.LgRepo IO a) ->
- FilePath ->
- StoreM a
-readFile' cat fp = do
- cid <- getCommitOid
- repo <- getRepository
- lift $ G.runRepository GB.lgFactory repo do
- tree <- G.lookupTree =<< (.commitTree) <$> G.lookupCommit cid
- maybe
- (throwM (DoesNotExist "readFile" fp))
- ( \e ->
- case e of
- G.BlobEntry bid _ -> cat bid
- G.CommitEntry _ -> error "XXX commit entry"
- G.TreeEntry _ -> throwM (InappropriateType "readFile" fp)
- )
- =<< G.treeEntry tree (B.fromString fp)
diff --git a/astore.cabal b/astore.cabal
new file mode 100644
index 0000000..fa9b4ea
--- /dev/null
+++ b/astore.cabal
@@ -0,0 +1,64 @@
+cabal-version: 3.4
+name: astore
+version: 0.1.0.0
+license: Apache-2.0
+license-file: LICENSE
+maintainer: aforemny@posteo.de
+author: Alexander Foremny
+build-type: Simple
+extra-doc-files: CHANGELOG.md
+
+library
+ exposed-modules:
+ Store
+
+ hs-source-dirs: src
+ other-modules: Store.Debug
+ Store.Exception
+ Store.Query
+ Store.Query.Field
+ Store.Query.Parser
+ Store.Query.Printer
+ Store.Query.Record
+ Store.Query.Type
+ Store.Store
+ default-language: GHC2021
+ default-extensions:
+ AllowAmbiguousTypes BlockArguments GeneralizedNewtypeDeriving
+ OverloadedRecordDot OverloadedStrings ViewPatterns
+
+ ghc-options:
+ -Wall -fno-warn-incomplete-patterns -fno-warn-name-shadowing
+
+ build-depends:
+ aeson,
+ base,
+ bytestring,
+ containers,
+ directory,
+ exceptions,
+ filepath,
+ gitlib,
+ gitlib-libgit2,
+ megaparsec,
+ mtl,
+ parser-combinators,
+ tagged,
+ text,
+ unliftio,
+ unliftio-core,
+ unordered-containers,
+ utf8-string,
+ vector
+
+executable astore
+ main-is: Main.hs
+ hs-source-dirs: app
+ default-language: GHC2021
+ default-extensions: OverloadedStrings
+ build-depends:
+ aeson,
+ astore,
+ base,
+ bytestring,
+ directory
diff --git a/json2sql.cabal b/json2sql.cabal
deleted file mode 100644
index 1cfd4da..0000000
--- a/json2sql.cabal
+++ /dev/null
@@ -1,60 +0,0 @@
-cabal-version: 3.4
-name: json2sql
-version: 0.1.0.0
--- synopsis:
--- description:
-license: Apache-2.0
-license-file: LICENSE
-author: Alexander Foremny
-maintainer: aforemny@posteo.de
--- copyright:
-build-type: Simple
-extra-doc-files: CHANGELOG.md
--- extra-source-files:
-
-executable json2sql
- ghc-options:
- -Wall
- -fno-warn-incomplete-patterns
- -fno-warn-name-shadowing
- main-is: Main.hs
- other-modules:
- Debug
- Exception
- Query
- Query.Field
- Query.Parser
- Query.Printer
- Query.Record
- Query.Type
- Store
- -- other-extensions:
- build-depends: base ^>=4.16.4.0,
- aeson,
- bytestring,
- containers,
- directory,
- exceptions,
- filepath,
- gitlib,
- gitlib-libgit2,
- megaparsec,
- mtl,
- parser-combinators,
- tagged,
- text,
- unliftio,
- unliftio-core,
- unordered-containers,
- utf8-string,
- vector
- hs-source-dirs: app
- default-language: GHC2021
- default-extensions:
- AllowAmbiguousTypes
- BlockArguments
- GeneralizedNewtypeDeriving
- OverloadedRecordDot
- OverloadedStrings
- ViewPatterns
-
diff --git a/src/Store.hs b/src/Store.hs
new file mode 100644
index 0000000..f7562f5
--- /dev/null
+++ b/src/Store.hs
@@ -0,0 +1,6 @@
+module Store
+ ( module Store.Query,
+ )
+where
+
+import Store.Query
diff --git a/src/Store/Debug.hs b/src/Store/Debug.hs
new file mode 100644
index 0000000..5e0b704
--- /dev/null
+++ b/src/Store/Debug.hs
@@ -0,0 +1,10 @@
+module Store.Debug
+ ( debug,
+ )
+where
+
+import Debug.Trace (trace)
+import Text.Printf (printf)
+
+debug :: Show a => String -> a -> a
+debug s x = trace (printf "%s: %s" s (show x)) x
diff --git a/src/Store/Exception.hs b/src/Store/Exception.hs
new file mode 100644
index 0000000..245780c
--- /dev/null
+++ b/src/Store/Exception.hs
@@ -0,0 +1,23 @@
+module Store.Exception
+ ( DecodeException (DecodeException),
+ DuplicateField (DuplicateField),
+ ParseError (ParseError),
+ )
+where
+
+import Control.Exception (Exception)
+
+data DecodeException = DecodeException
+ deriving (Show)
+
+instance Exception DecodeException
+
+data DuplicateField = DuplicateField String
+ deriving (Show)
+
+instance Exception DuplicateField
+
+data ParseError = ParseError String
+ deriving (Show)
+
+instance Exception ParseError
diff --git a/src/Store/Query.hs b/src/Store/Query.hs
new file mode 100644
index 0000000..b63b176
--- /dev/null
+++ b/src/Store/Query.hs
@@ -0,0 +1,134 @@
+module Store.Query
+ ( module Store.Query.Type,
+ query,
+ )
+where
+
+import Control.Exception (throw)
+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.NonEmpty qualified as N
+import Data.Maybe (fromMaybe)
+import Data.Vector qualified as V
+import Store.Exception (DecodeException (DecodeException))
+import Store.Query.Parser ()
+import Store.Query.Printer ()
+import Store.Query.Record
+import Store.Query.Type
+import Store.Store qualified as S
+import System.FilePath ((</>))
+
+query :: Query -> IO [J.Value]
+query (Select fs c js es w) = do
+ c' <-
+ mapM (fmap (fromValue c) . decodeFile . (c </>)) =<< ls c
+ js' <-
+ mapM
+ ( \(JoinClause t c w) ->
+ fmap (\j' -> JoinClause t (map (fromValue c) j') w) . mapM (decodeFile . (c </>))
+ =<< ls c
+ )
+ js
+ es' <-
+ mapM
+ ( \(EmbedClause c w) ->
+ fmap (\e' -> EmbedClause (fromValue c e') w) . mapM (decodeFile . (c </>))
+ =<< ls 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
+
+embeds ::
+ EmbedClauses (Record [J.Value]) ->
+ [Records J.Value] ->
+ [Records J.Value]
+embeds = flip (foldl' embed)
+
+embed ::
+ [Records J.Value] ->
+ EmbedClause (Record [J.Value]) ->
+ [Records J.Value]
+embed vss (EmbedClause (Record c es) w) =
+ map
+ ( \vs ->
+ vs
+ ++ [ fromValue
+ c
+ ( J.Object
+ ( JM.singleton
+ (JK.fromString c)
+ ( J.Array
+ ( V.fromList
+ [ e
+ | e <- es,
+ satisfies w (vs ++ [Record c e])
+ ]
+ )
+ )
+ )
+ )
+ ]
+ )
+ vss
+
+joins ::
+ JoinClauses (Records J.Value) ->
+ [Record J.Value] ->
+ [Records J.Value]
+joins js (map (: []) -> vss) = foldl' join vss js
+
+join ::
+ [Records J.Value] ->
+ JoinClause (Records J.Value) ->
+ [Records J.Value]
+join vss (JoinClause JoinLeft js w) =
+ concatMap
+ ( \vs -> case filter (satisfies w) $ map (\j -> vs ++ [j]) js of
+ [] -> [vs]
+ vs' -> vs'
+ )
+ vss
+join vss (JoinClause JoinRight js w) =
+ concatMap
+ ( \j -> case filter (satisfies w) $ map (\vs -> vs ++ [j]) vss of
+ [] -> [[j]]
+ vs' -> vs'
+ )
+ js
+join vss (JoinClause JoinFull js w) =
+ concatMap
+ ( \vs -> case filter (satisfies w) $ map (\j -> vs ++ [j]) js of
+ [] -> [vs]
+ vs' -> vs'
+ )
+ vss
+ ++ concatMap
+ ( \j -> case filter (satisfies w) $ map (\vs -> vs ++ [j]) vss of
+ [] -> [[j]]
+ _ -> []
+ )
+ js
+
+select :: FieldSelector -> Records J.Value -> J.Value
+select All vs = disjointUnions (map toValue vs)
+select (Only fs) vs = Store.Query.Record.select (N.toList fs) vs
+
+where_ :: Maybe WhereClause -> [Records J.Value] -> [Records J.Value]
+where_ w = filter (satisfies w)
+
+satisfies :: Maybe WhereClause -> Records J.Value -> Bool
+satisfies Nothing _ = True
+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
+ fromMaybe (throw DecodeException) . J.decode <$> S.readFile fp
diff --git a/src/Store/Query/Field.hs b/src/Store/Query/Field.hs
new file mode 100644
index 0000000..69a0983
--- /dev/null
+++ b/src/Store/Query/Field.hs
@@ -0,0 +1,32 @@
+module Store.Query.Field
+ ( Field (..),
+ toString,
+ prefix,
+ )
+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.List.NonEmpty qualified as N
+import Data.Text qualified as T
+
+data Field
+ = Qualified Collection (N.NonEmpty T.Text)
+ | Unqualified (N.NonEmpty T.Text)
+ deriving (Show)
+
+toString :: Field -> String
+toString (Qualified c ks) = intercalate "." (c : map T.unpack (N.toList ks))
+toString (Unqualified ks) = intercalate "." (map T.unpack (N.toList ks))
+
+type Collection = FilePath
+
+prefix :: Field -> J.Value -> J.Value
+prefix (Qualified c ks) = prefix' (T.pack c : N.toList ks)
+prefix (Unqualified ks) = prefix' (N.toList ks)
+
+prefix' :: [T.Text] -> J.Value -> J.Value
+prefix' ks v =
+ foldr ((J.Object .) . JM.singleton) v (map JK.fromText ks)
diff --git a/src/Store/Query/Parser.hs b/src/Store/Query/Parser.hs
new file mode 100644
index 0000000..93e408c
--- /dev/null
+++ b/src/Store/Query/Parser.hs
@@ -0,0 +1,126 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Store.Query.Parser () where
+
+import Control.Exception (throw)
+import Control.Monad (void)
+import Control.Monad.Combinators.NonEmpty qualified as PN
+import Data.Char (isSpace)
+import Data.List.NonEmpty qualified as N
+import Data.String (IsString (fromString))
+import Data.Text qualified as T
+import Data.Void (Void)
+import Store.Exception (ParseError (ParseError))
+import Store.Query.Type
+import Text.Megaparsec qualified as P
+import Text.Megaparsec.Char qualified as P
+import Text.Megaparsec.Char.Lexer qualified as P
+
+instance IsString Query where
+ fromString =
+ either (throw . ParseError . P.errorBundlePretty @String @Void) id
+ . P.parse parser ""
+ 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
+
+ lexeme :: P.Parsec Void String a -> P.Parsec Void String a
+ lexeme = P.lexeme $ void $ P.takeWhileP Nothing isSpace
+
+ and = void $ lexeme (P.string "AND")
+ comma = void $ lexeme (P.string ",")
+ embed = void $ lexeme (P.string "EMBED")
+ eq = void $ lexeme (P.string "==")
+ from = void $ lexeme (P.string "FROM")
+ on = void $ lexeme (P.string "ON")
+ or = void $ lexeme (P.string "OR")
+ select = void $ lexeme (P.string "SELECT")
+ where_ = void $ lexeme (P.string "WHERE")
+
+ collection = lexeme $ P.takeWhile1P (Just "collection") (not . isSpace)
+
+ joinClauses = P.many joinClause
+
+ joinClause = do
+ t <- joinType
+ c <- collection
+ w <- P.optional do
+ on
+ whereClause
+ pure $ JoinClause t c w
+
+ embedClauses = P.many embedClause
+
+ embedClause = do
+ embed
+ c <- collection
+ w <- P.optional do
+ on
+ whereClause
+ pure $ EmbedClause c w
+
+ whereClause =
+ P.choice
+ [ P.try (And . map Where <$> P.sepBy1 comparison and),
+ P.try (Or . map Where <$> P.sepBy1 comparison or),
+ Where <$> comparison
+ ]
+
+ comparison = do
+ a <- field
+ eq
+ b <- field
+ pure $ Eq a b
+
+ fieldSelector =
+ P.choice
+ [ do
+ void $ lexeme $ P.string "*"
+ pure All,
+ do
+ Only <$> PN.sepBy1 field comma
+ ]
+
+ field :: P.Parsec Void String Field
+ field =
+ lexeme . P.choice $
+ [ P.try
+ do
+ Qualified
+ <$> (fieldPart <* P.string ".")
+ <*> (N.map T.pack <$> PN.sepBy1 fieldPart (P.string ".")),
+ do
+ Unqualified
+ <$> (N.map T.pack <$> PN.sepBy1 fieldPart (P.string "."))
+ ]
+
+ fieldPart :: P.Parsec Void String String
+ fieldPart = P.takeWhile1P Nothing (\c -> not (isSpace c) && c /= ',' && c /= '.')
+
+ joinType :: P.Parsec Void String JoinType
+ joinType =
+ P.choice
+ [ do
+ void $ lexeme (P.string "LEFT")
+ void $ lexeme (P.string "JOIN")
+ pure JoinLeft,
+ do
+ void $ lexeme (P.string "RIGHT")
+ void $ lexeme (P.string "JOIN")
+ pure JoinRight,
+ do
+ void $ lexeme (P.string "FULL")
+ void $ lexeme (P.string "JOIN")
+ pure JoinFull
+ ]
diff --git a/src/Store/Query/Printer.hs b/src/Store/Query/Printer.hs
new file mode 100644
index 0000000..5692ba8
--- /dev/null
+++ b/src/Store/Query/Printer.hs
@@ -0,0 +1,60 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Store.Query.Printer () where
+
+import Data.List (intercalate)
+import Data.List.NonEmpty qualified as N
+import Data.Maybe (catMaybes, mapMaybe)
+import Store.Query.Field
+import Store.Query.Type
+
+instance Show Query where
+ 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 All = "*"
+ showFieldSelector (Only (N.toList -> fs)) =
+ intercalate ", " (map showField fs)
+ 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]
diff --git a/src/Store/Query/Record.hs b/src/Store/Query/Record.hs
new file mode 100644
index 0000000..71461d5
--- /dev/null
+++ b/src/Store/Query/Record.hs
@@ -0,0 +1,80 @@
+module Store.Query.Record
+ ( Record (..),
+ fromValue,
+ toValue,
+ lookup,
+ Records,
+ lookups,
+ select,
+ disjointUnion,
+ disjointUnions,
+ )
+where
+
+import Control.Exception (throw)
+import Data.Aeson qualified as J
+import Data.Aeson.Key qualified as JK
+import Data.Aeson.KeyMap qualified as JM
+import Data.List (foldl')
+import Data.List.NonEmpty qualified as N
+import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Text qualified as T
+import Store.Exception (DuplicateField (DuplicateField))
+import Store.Query.Field
+import Prelude hiding (lookup)
+
+data Record a
+ = Record Collection a
+ deriving (Show, Eq)
+
+type Collection = FilePath
+
+fromValue :: Collection -> a -> Record a
+fromValue = Record
+
+toValue :: Record a -> a
+toValue (Record _ v) = v
+
+lookup :: Field -> Record J.Value -> Maybe J.Value
+lookup (Unqualified ks) (Record _ v) =
+ lookup' (N.toList ks) v
+lookup (Qualified c' ks) (Record c v)
+ | c' == c = lookup' (N.toList ks) v
+ | otherwise = Nothing
+
+lookup' :: [T.Text] -> J.Value -> Maybe J.Value
+lookup' [] v = Just v
+lookup' (k : ks) (J.Object kvs) =
+ lookup' ks =<< JM.lookup (JK.fromText k) kvs
+
+type Records a = [Record a]
+
+lookups :: Field -> Records J.Value -> Maybe J.Value
+lookups f rs =
+ case mapMaybe (lookup f) rs of
+ [] -> Nothing
+ [v] -> Just v
+ (_ : _) -> throw (DuplicateField (toString f))
+
+select :: [Field] -> Records J.Value -> J.Value
+select fs rs =
+ foldl'
+ union
+ (J.Object JM.empty)
+ (map (\f -> prefix f ((fromMaybe J.Null (lookups f rs)))) fs)
+
+union :: J.Value -> J.Value -> J.Value
+union (J.Object r) (J.Object s) = J.Object (JM.unionWith union r s)
+
+disjointUnion :: J.Value -> J.Value -> J.Value
+disjointUnion (J.Object r) (J.Object s) =
+ J.Object (JM.unionWithKey disjointUnion' r s)
+
+disjointUnion' :: JK.Key -> J.Value -> J.Value -> J.Value
+disjointUnion' _ (J.Object r) (J.Object s) =
+ J.Object (JM.unionWithKey disjointUnion' r s)
+disjointUnion' k _ _ =
+ throw (DuplicateField (JK.toString k))
+
+disjointUnions :: [J.Value] -> J.Value
+disjointUnions = foldl' disjointUnion (J.Object JM.empty)
diff --git a/src/Store/Query/Type.hs b/src/Store/Query/Type.hs
new file mode 100644
index 0000000..5aa0e36
--- /dev/null
+++ b/src/Store/Query/Type.hs
@@ -0,0 +1,62 @@
+module Store.Query.Type
+ ( module Store.Query.Field,
+ module Store.Query.Record,
+ Collection,
+ Comparison (..),
+ EmbedClause (..),
+ EmbedClauses,
+ FieldSelector (..),
+ JoinClause (..),
+ JoinClauses,
+ JoinType (..),
+ Query (..),
+ WhereClause (..),
+ )
+where
+
+import Data.List.NonEmpty qualified as N
+import Store.Query.Field
+import Store.Query.Record
+
+data Query
+ = Select
+ FieldSelector
+ Collection
+ (JoinClauses FilePath)
+ (EmbedClauses FilePath)
+ (Maybe WhereClause)
+
+data FieldSelector
+ = All
+ | Only (N.NonEmpty Field)
+ deriving (Show)
+
+type Collection = FilePath
+
+type JoinClauses a = [JoinClause a]
+
+data JoinClause a
+ = JoinClause JoinType a (Maybe WhereClause)
+ deriving (Show)
+
+data JoinType
+ = JoinLeft
+ | JoinRight
+ | JoinFull
+ deriving (Show)
+
+type EmbedClauses a = [EmbedClause a]
+
+data EmbedClause a
+ = EmbedClause a (Maybe WhereClause)
+ deriving (Show)
+
+data WhereClause
+ = And [WhereClause]
+ | Or [WhereClause]
+ | Where Comparison
+ deriving (Show)
+
+data Comparison
+ = Eq Field Field
+ deriving (Show)
diff --git a/src/Store/Store.hs b/src/Store/Store.hs
new file mode 100644
index 0000000..7917449
--- /dev/null
+++ b/src/Store/Store.hs
@@ -0,0 +1,121 @@
+module Store.Store
+ ( withStore,
+ listDirectory,
+ readFile,
+ )
+where
+
+import Control.Arrow (first)
+import Control.Exception (Exception, finally)
+import Control.Monad.Catch (MonadCatch, 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 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.Text qualified as T
+import Git qualified as G
+import Git.Libgit2 qualified as GB
+import System.FilePath (addTrailingPathSeparator, hasDrive, joinDrive, makeRelative, normalise, splitPath)
+import Prelude hiding (readFile)
+
+newtype StoreT m a = StoreT
+ { runStoreT :: StateT GB.OidPtr (ReaderT GB.LgRepo m) a
+ }
+ deriving
+ ( Applicative,
+ Functor,
+ Monad,
+ MonadReader GB.LgRepo,
+ MonadState GB.OidPtr,
+ MonadCatch,
+ MonadThrow,
+ MonadIO
+ )
+
+instance MonadTrans StoreT where
+ lift = StoreT . lift . lift
+
+class MonadStore m where
+ getCommitOid :: m (G.CommitOid GB.LgRepo)
+ getRepository :: m GB.LgRepo
+
+instance Monad m => MonadStore (StoreT m) where
+ getCommitOid = Tagged <$> get
+ getRepository = ask
+
+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
+ `finally` G.runRepository GB.lgFactory repo G.closeRepository
+
+listDirectory :: FilePath -> StoreM [FilePath]
+listDirectory dir' = do
+ cid <- getCommitOid
+ repo <- getRepository
+ 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
+ sort
+ . map (makeRelative dir)
+ . filter ((== n + 1) . length . splitPath)
+ . filter (isPrefixOf (addTrailingPathSeparator dir))
+ . map fst
+ . map
+ ( \e ->
+ case snd e of
+ G.BlobEntry _ _ -> e
+ G.CommitEntry _ -> error "XXX commit entry"
+ G.TreeEntry _ -> first addTrailingPathSeparator e
+ )
+ . map (first (("/" <>) . B.toString))
+ <$> G.listTreeEntries tree
+
+data DoesNotExist = DoesNotExist String FilePath
+ deriving (Show)
+
+instance Exception DoesNotExist
+
+data InappropriateType = InappropriateType String FilePath
+ deriving (Show)
+
+instance Exception InappropriateType
+
+class Readable a where
+ readFile :: FilePath -> StoreM a
+
+instance Readable T.Text where
+ readFile = readFile' G.catBlobUtf8
+
+instance Readable B.ByteString where
+ readFile = readFile' G.catBlob
+
+instance Readable LB.ByteString where
+ readFile = readFile' G.catBlobLazy
+
+readFile' ::
+ (G.BlobOid GB.LgRepo -> ReaderT GB.LgRepo IO a) ->
+ FilePath ->
+ StoreM a
+readFile' cat fp = do
+ cid <- getCommitOid
+ repo <- getRepository
+ lift $ G.runRepository GB.lgFactory repo do
+ tree <- G.lookupTree =<< (.commitTree) <$> G.lookupCommit cid
+ maybe
+ (throwM (DoesNotExist "readFile" fp))
+ ( \e ->
+ case e of
+ G.BlobEntry bid _ -> cat bid
+ G.CommitEntry _ -> error "XXX commit entry"
+ G.TreeEntry _ -> throwM (InappropriateType "readFile" fp)
+ )
+ =<< G.treeEntry tree (B.fromString fp)
--
cgit v1.2.3