diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -32,7 +32,7 @@ -- Also, transactions are thread-safe transaction "./content" $ do -- order: (collection) (key ) (data) - saveEntry "content" "first-thing" Thing {val = 1} + saveEntry "things" "first-thing" Thing {val = 1} -- Collections are created automatically, like in MongoDB liftIO $ putStrLn "Written first-thing" -- You have to use liftIO to do IO actions inside of a transaction! @@ -41,7 +41,9 @@ -- Reading data -- (These are normal IO actions, so if you want -- to read inside of a transaction, liftIO. - -- Note: transaction already includes insideDirectory!) + -- Note: transaction already includes insideDirectory! + -- Warning: you can't read what you're writing in a transaction!!! + -- You can only read what's been written before the transaction began.) insideDirectory "./content" $ do colls <- listCollections -- ["things"] @@ -56,6 +58,17 @@ -- the current directory, executes an action and changes it back. -- You can use reading actions without it, like this: keys <- listEntryKeys "./content/things" + + + -- And now, some bells and whistles: + -- Numeric id support + transaction "./content" $ do + saveNextEntry "things" "hello-world" Thing {val = 1} + -- will save to things/000001-hello-world.json + insideDirectory "./content" $ do + thing <- readEntryById "things" 1 + same-thing <- readEntryByName "thing" "hello-world" + -- both will read from things/000001-hello-world.json ``` ## Development diff --git a/gitson.cabal b/gitson.cabal --- a/gitson.cabal +++ b/gitson.cabal @@ -1,5 +1,5 @@ name: gitson -version: 0.2.1 +version: 0.3.0 synopsis: A document store library for Git + JSON. description: A simple document store library for Git + JSON, based on Aeson. Uses command line git, at least for now. No fancy indexes and stuff, but it does what I need right now. Transactions use flock, so it's safe even across completely separate programs! category: Database, JSON, Git diff --git a/library/Gitson.hs b/library/Gitson.hs --- a/library/Gitson.hs +++ b/library/Gitson.hs @@ -4,22 +4,25 @@ createRepo, transaction, saveEntry, - readEntry, + saveNextEntry, + listCollections, listEntryKeys, listEntries, - listCollections + readEntry, + readEntryById, + readEntryByName ) where import System.Directory import System.Lock.FLock -import Control.Exception -import Control.Applicative -import Control.Error.Util +import Control.Exception (try, IOException) +import Control.Error.Util (hush) import Control.Monad.Trans.Writer -import Control.Monad.IO.Class (liftIO) import Data.Aeson (ToJSON, FromJSON, decode) import Data.Aeson.Encode.Pretty -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, catMaybes) +import Data.List (find, isSuffixOf) +import Text.Printf (printf) import qualified Data.ByteString.Lazy as BL import Gitson.Util @@ -38,31 +41,49 @@ transaction :: FilePath -> TransactionWriter -> IO () transaction repoPath action = do insideDirectory repoPath $ withLock lockPath Exclusive Block $ do - shell "git" ["reset", "--hard", "HEAD"] -- Reset working tree just in case writeActions <- execWriterT action + shell "git" ["stash"] -- it's totally ok to do this without changes sequence_ writeActions shell "git" ["add", "--all"] shell "git" ["commit", "-m", "Gitson transaction"] + shell "git" ["stash", "pop"] +combineKey :: (Int, String) -> String +combineKey (n, s) = zeroPad n ++ "-" ++ s + where zeroPad :: Int -> String + zeroPad x = printf "%06d" x + prettyConfig :: Config prettyConfig = Config { confIndent = 2, confCompare = compare } +writeEntry :: ToJSON a => FilePath -> String -> a -> IO () +writeEntry collection key content = BL.writeFile (entryPath collection key) (encodePretty' prettyConfig content) + -- | Adds a write action to a transaction. -saveEntry :: ToJSON a => FilePath -> FilePath -> a -> TransactionWriter +saveEntry :: ToJSON a => FilePath -> String -> a -> TransactionWriter saveEntry collection key content = do - liftIO $ createDirectoryIfMissing True collection - tell [BL.writeFile (entryPath collection key) (encodePretty' prettyConfig content)] + tell [createDirectoryIfMissing True collection, + writeEntry collection key content] --- | Reads an entry from a collection by key. -readEntry :: FromJSON a => FilePath -> FilePath -> IO (Maybe a) -readEntry collection key = do - jsonString <- try (BL.readFile $ entryPath collection key) :: IO (Either IOException BL.ByteString) - return $ decode =<< hush jsonString +-- | Adds a write action to a transaction. +-- The key will start with a numeric id, incremented from the last id in the collection. +saveNextEntry :: ToJSON a => FilePath -> String -> a -> TransactionWriter +saveNextEntry collection key content = do + tell [createDirectoryIfMissing True collection, + listEntryKeys collection >>= + return . nextKeyId >>= + \nextId -> writeEntry collection (combineKey (nextId, key)) content] +-- | Lists collections in the current repository. +listCollections :: IO [FilePath] +listCollections = do + contents <- try (getDirectoryContents =<< getCurrentDirectory) :: IO (Either IOException [FilePath]) + filterDirs $ fromMaybe [] $ hush contents + -- | Lists entry keys in a collection. -listEntryKeys :: FilePath -> IO [FilePath] +listEntryKeys :: FilePath -> IO [String] listEntryKeys collection = do - contents <- try (getDirectoryContents collection) :: IO (Either IOException [FilePath]) + contents <- try (getDirectoryContents collection) :: IO (Either IOException [String]) return $ filterFilenamesAsKeys $ fromMaybe [] $ hush contents -- | Lists entries in a collection. @@ -72,8 +93,22 @@ maybes <- mapM (readEntry collection) ks return $ fromMaybe [] $ sequence maybes --- | Lists collections in the current repository. -listCollections :: IO [FilePath] -listCollections = do - contents <- try (getDirectoryContents =<< getCurrentDirectory) :: IO (Either IOException [FilePath]) - filterDirs $ fromMaybe [] $ hush contents +-- | Reads an entry from a collection by key. +readEntry :: FromJSON a => FilePath -> String -> IO (Maybe a) +readEntry collection key = do + jsonString <- try (BL.readFile $ entryPath collection key) :: IO (Either IOException BL.ByteString) + return $ decode =<< hush jsonString + +splitFindAndReadEntry :: FromJSON a => FilePath -> ([((Int, String), String)] -> Maybe ((Int, String), String)) -> IO (Maybe a) +splitFindAndReadEntry collection finder = listEntryKeys collection >>= + maybeReadEntry . finder . catMaybes . (map $ \x -> intoMaybe (maybeReadIntString x) x) + where maybeReadEntry (Just x) = readEntry collection $ snd x + maybeReadEntry Nothing = return Nothing + +-- | Reads an entry from a collection by numeric id (for example, key "00001-hello" has id 1).. +readEntryById :: FromJSON a => FilePath -> Int -> IO (Maybe a) +readEntryById collection n = splitFindAndReadEntry collection $ find ((== n) . fst . fst) + +-- | Reads an entry from a collection by name (for example, key "00001-hello" has name "hello"). +readEntryByName :: FromJSON a => FilePath -> String -> IO (Maybe a) +readEntryByName collection n = splitFindAndReadEntry collection $ find ((isSuffixOf n) . snd . fst) diff --git a/library/Gitson/Util.hs b/library/Gitson/Util.hs --- a/library/Gitson/Util.hs +++ b/library/Gitson/Util.hs @@ -2,7 +2,9 @@ module Gitson.Util (module Gitson.Util) where import Control.Monad (void, filterM) +import Control.Applicative import Data.List (isSuffixOf, isPrefixOf) +import Data.Maybe import System.FilePath import System.Directory import System.Process @@ -15,7 +17,7 @@ -- -- >>> entryPath "things/" "entry" -- "things/entry.json" -entryPath :: FilePath -> FilePath -> FilePath +entryPath :: FilePath -> String -> FilePath entryPath collection key = collection key <.> "json" -- | Path to the transaction lock file, relative to the repo root. @@ -26,7 +28,7 @@ -- -- >>> filterFilenamesAsKeys [".", "..", "k1.json", "unrelated.file"] -- ["k1"] -filterFilenamesAsKeys :: [String] -> [String] +filterFilenamesAsKeys :: [FilePath] -> [String] filterFilenamesAsKeys = map dropExtension . filter (isSuffixOf ".json") -- | Filters a list of file paths, leaving only paths to existing non-hidden directories. @@ -47,13 +49,44 @@ lastCommitText :: IO String lastCommitText = readProcess "git" ["log", "--max-count=1", "--pretty=format:%s"] [] --- | A \/dev/null handle. -devNull :: IO Handle -devNull = openFile "/dev/null" ReadWriteMode - -- | Runs a shell command with stdin, stdout and stderr set to /dev/null. shell :: String -> [String] -> IO () shell cmd args = void $ do - dnull <- devNull + dnull <- openFile "/dev/null" ReadWriteMode (_, _, _, pid) <- createProcess (proc cmd args){std_in = UseHandle dnull, std_out = UseHandle dnull, std_err = UseHandle dnull} waitForProcess pid + +-- I can't believe there's nothing like this in Data.Maybe +-- | Adds a value to a Maybe. +intoMaybe :: Maybe a -> b -> Maybe (a, b) +intoMaybe (Just x) y = Just (x, y) +intoMaybe Nothing y = Nothing + +-- | Tries to extract the first int out of a string. +-- +-- >>> maybeReadIntString "0123-hell0w0rld" +-- Just (123,"-hell0w0rld") +-- +-- >>> maybeReadIntString "1" +-- Just (1,"") +-- +-- >>> maybeReadIntString "hello" +-- Nothing +maybeReadIntString :: String -> Maybe (Int, String) +maybeReadIntString x = listToMaybe (reads x :: [(Int, String)]) + +-- | Returns the next numeric id in a sequence of keys. +-- +-- >>> nextKeyId [] +-- 1 +-- +-- >>> nextKeyId ["aaaaarrrrrrrrrrr"] +-- 1 +-- +-- >>> nextKeyId ["1-hell0-w0rld-123456.json", "002-my-second-post.json"] +-- 3 +nextKeyId :: [String] -> Int +nextKeyId = (+1) . maxOrZero . catMaybes . map maybeReadInt + where maybeReadInt x = fst <$> maybeReadIntString x + maxOrZero [] = 0 + maxOrZero xs = maximum xs diff --git a/test-suite/GitsonSpec.hs b/test-suite/GitsonSpec.hs --- a/test-suite/GitsonSpec.hs +++ b/test-suite/GitsonSpec.hs @@ -17,21 +17,33 @@ spec :: Spec spec = before setup $ after cleanup $ do - describe "transaction" $ do - it "saves entries only after it's done" $ do - transaction "tmp/repo" $ do - saveEntry "things" "first-thing" Thing {val = 1} - saveEntry "things" "second-thing" Thing {val = 2} - liftIO $ (readFile "things/first-thing.json") `shouldThrow` anyIOException - liftIO $ (readFile "things/second-thing.json") `shouldThrow` anyIOException - insideDirectory "tmp/repo" $ do - first <- readFile "things/first-thing.json" - first `shouldBe` "{\n \"val\": 1\n}" - second <- readFile "things/second-thing.json" - second `shouldBe` "{\n \"val\": 2\n}" - commitMsg <- lastCommitText - commitMsg `shouldBe` "Gitson transaction" + context "transaction" $ do + describe "saveEntry" $ do + it "saves entries only after it's done" $ do + transaction "tmp/repo" $ do + saveEntry "things" "first-thing" Thing {val = 1} + saveEntry "things" "second-thing" Thing {val = 2} + liftIO $ (readFile "things/first-thing.json") `shouldThrow` anyIOException + liftIO $ (readFile "things/second-thing.json") `shouldThrow` anyIOException + insideDirectory "tmp/repo" $ do + first <- readFile "things/first-thing.json" + first `shouldBe` "{\n \"val\": 1\n}" + second <- readFile "things/second-thing.json" + second `shouldBe` "{\n \"val\": 2\n}" + commitMsg <- lastCommitText + commitMsg `shouldBe` "Gitson transaction" + describe "saveNextEntry" $ do + it "saves entries with next numeric ids" $ do + transaction "tmp/repo" $ do + saveNextEntry "things" "hello" Thing {val = 1} + saveNextEntry "things" "world" Thing {val = 2} + insideDirectory "tmp/repo" $ do + first <- readFile "things/000001-hello.json" + first `shouldBe` "{\n \"val\": 1\n}" + second <- readFile "things/000002-world.json" + second `shouldBe` "{\n \"val\": 2\n}" + describe "readEntry" $ do it "returns Just the entry when reading an entry by key" $ do createDirectoryIfMissing True "tmp/repo/things" @@ -41,6 +53,28 @@ it "returns Nothing when reading by a nonexistent key" $ do content <- readEntry "tmp/repo/things" "totally-not-a-thing" :: IO (Maybe Thing) + content `shouldBe` Nothing + + describe "readEntryById" $ do + it "returns Just the entry when reading an entry by id" $ do + createDirectoryIfMissing True "tmp/repo/things" + _ <- writeFile "tmp/repo/things/000004-second-thing.json" "{\"val\":1}" + content <- readEntryById "tmp/repo/things" 4 :: IO (Maybe Thing) + content `shouldBe` Just Thing {val = 1} + + it "returns Nothing when reading by a nonexistent id" $ do + content <- readEntryById "tmp/repo/things" 1 :: IO (Maybe Thing) + content `shouldBe` Nothing + + describe "readEntryByName" $ do + it "returns Just the entry when reading an entry by name" $ do + createDirectoryIfMissing True "tmp/repo/things" + _ <- writeFile "tmp/repo/things/000098-second-thing.json" "{\"val\":1}" + content <- readEntryByName "tmp/repo/things" "second-thing" :: IO (Maybe Thing) + content `shouldBe` Just Thing {val = 1} + + it "returns Nothing when reading by a nonexistent name" $ do + content <- readEntryByName "tmp/repo/things" "yolo" :: IO (Maybe Thing) content `shouldBe` Nothing describe "listEntryKeys" $ do