gitson 0.4.0 → 0.4.1

raw patch · 7 files changed

+60/−107 lines, 7 filesdep +monad-controldep −regex-compatdep ~processPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: monad-control

Dependencies removed: regex-compat

Dependency ranges changed: process

API changes (from Hackage documentation)

Files

• benchmark/Bench.hs +0/−2
• gitson.cabal +6/−17
• library/Gitson.hs +32/−44
• library/Gitson/Json.hs +13/−0
• library/Gitson/Util.hs +9/−6
• test-suite/Gitson/UtilSpec.hs +0/−8
• test-suite/Haddock.hs +0/−30

@@ -2,14 +2,12 @@  import           Criterion.Main (bgroup, defaultMain) import qualified GitsonBench--- HASKELETON: import qualified New.ModuleBench  main :: IO () main = sequence_     [ GitsonBench.setup     ] >> defaultMain     [ bgroup "Gitson" GitsonBench.benchmarks-    -- HASKELETON: , bgroup "New.Module" New.ModuleBench.benchmarks     ] >> sequence_     [ GitsonBench.cleanup     ]

@@ -1,7 +1,7 @@ name:            gitson-version:         0.4.0+version:         0.4.1 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!+description:     A simple document store library for Git + JSON, based on Aeson. Uses command line git. Transactions use flock, so it's safe even across completely separate programs! category:        Database, JSON, Git homepage:        https://github.com/myfreeweb/gitson author:          Greg V@@ -14,8 +14,7 @@ extra-source-files:     README.md tested-with:-    GHC == 7.6.3-  , GHC == 7.8.2+    GHC == 7.8.2  source-repository head     type: git@@ -25,6 +24,7 @@     build-depends:         base >= 4.0.0.0 && < 5       , transformers+      , monad-control       , process       , bytestring       , directory@@ -37,20 +37,11 @@     exposed-modules:         Gitson         Gitson.Util-        -- HASKELETON: New.Module+    other-modules:+        Gitson.Json     ghc-prof-options: -auto-all -prof     hs-source-dirs: library -test-suite documentation-    build-depends:-        base >= 4.0.0.0 && < 5-      , process == 1.*-      , regex-compat == 0.*-    default-language: Haskell2010-    hs-source-dirs: test-suite-    main-is: Haddock.hs-    type: exitcode-stdio-1.0- test-suite examples     build-depends:         base >= 4.0.0.0 && < 5@@ -79,8 +70,6 @@     main-is: Spec.hs     other-modules:         GitsonSpec-        Gitson.UtilSpec-        -- HASKELETON: New.ModuleSpec     type: exitcode-stdio-1.0  benchmark benchmarks

@@ -1,3 +1,5 @@+{-# LANGUAGE Safe, FlexibleContexts #-}+ -- | Gitson is a simple document store library for Git + JSON. module Gitson (   TransactionWriter@@ -21,16 +23,17 @@ import           Control.Exception (try, IOException) import           Control.Error.Util (hush) import           Control.Monad.Trans.Writer-import           Data.Aeson (ToJSON, FromJSON, decode)-import           Data.Aeson.Encode.Pretty+import           Control.Monad.Trans.Control+import           Control.Monad.IO.Class import           Data.Maybe (fromMaybe, catMaybes) import           Data.List (find, isSuffixOf) import           Text.Printf (printf) import qualified Data.ByteString.Lazy as BL import           Gitson.Util+import           Gitson.Json  -- | A transaction monad.-type TransactionWriter = WriterT [IO ()] IO ()+type TransactionWriter = WriterT [IO ()]  type IdAndName = (Int, String) type FileName = String@@ -43,14 +46,14 @@   insideDirectory path $ shell "git" ["init"]  -- | Executes a blocking transaction on a repository, committing the results to git.-transaction :: FilePath -> TransactionWriter -> IO ()-transaction repoPath action = do+transaction :: (MonadIO i, MonadBaseControl IO i) => FilePath -> TransactionWriter i () -> i ()+transaction repoPath action =   insideDirectory repoPath $ do-    writeFile lockPath ""+    liftIO $ writeFile lockPath ""     withLock lockPath Exclusive Block $ do       writeActions <- execWriterT action       shell "git" ["stash"] -- it's totally ok to do this without changes-      sequence_ writeActions+      liftIO $ sequence_ writeActions       shell "git" ["add", "--all"]       shell "git" ["commit", "-m", "Gitson transaction"]       shell "git" ["stash", "pop"]@@ -60,21 +63,18 @@   where zeroPad :: Int -> String         zeroPad x = printf "%06d" x -prettyConfig :: Config-prettyConfig = Config { confIndent = 2, confCompare = compare }- writeDocument :: ToJSON a => FilePath -> FileName -> a -> IO ()-writeDocument collection key content = BL.writeFile (documentPath collection key) (encodePretty' prettyConfig content)+writeDocument collection key content = BL.writeFile (documentPath collection key) (encode content)  -- | Adds a write action to a transaction.-saveDocument :: ToJSON a => FilePath -> FileName -> a -> TransactionWriter+saveDocument :: (MonadIO i, ToJSON a) => FilePath -> FileName -> a -> TransactionWriter i () saveDocument collection key content = do   tell [createDirectoryIfMissing True collection,         writeDocument collection key content]  -- | Adds a write action to a transaction. -- The key will start with a numeric id, incremented from the last id in the collection.-saveNextDocument :: ToJSON a => FilePath -> FileName -> a -> TransactionWriter+saveNextDocument :: (MonadIO i, ToJSON a) => FilePath -> FileName -> a -> TransactionWriter i () saveNextDocument collection key content = do   tell [createDirectoryIfMissing True collection,         listDocumentKeys collection >>=@@ -82,49 +82,39 @@         \nextId -> writeDocument collection (combineKey (nextId, key)) content]  -- | Lists collections in the current repository.-listCollections :: IO [FilePath]-listCollections = do+listCollections :: (MonadIO i) => i [FilePath]+listCollections = liftIO $ do   contents <- try (getDirectoryContents =<< getCurrentDirectory) :: IO (Either IOException [FilePath])   filterDirs $ fromMaybe [] $ hush contents  -- | Lists document keys in a collection.-listDocumentKeys :: FilePath -> IO [FileName]-listDocumentKeys collection = do+listDocumentKeys :: (MonadIO i) => FilePath -> i [FileName]+listDocumentKeys collection = liftIO $ do   contents <- try (getDirectoryContents collection) :: IO (Either IOException [String])   return $ filterFilenamesAsKeys $ fromMaybe [] $ hush contents  -- | Lists entries in a collection.-listEntries :: FromJSON a => FilePath -> IO [a]-listEntries collection = do+listEntries :: (MonadIO i, FromJSON a) => FilePath -> i [a]+listEntries collection = liftIO $ do   ks <- listDocumentKeys collection   maybes <- mapM (readDocument collection) ks   return $ fromMaybe [] $ sequence maybes  -- | Reads a document from a collection by key.-readDocument :: FromJSON a => FilePath -> FileName -> IO (Maybe a)-readDocument collection key = do+readDocument :: (MonadIO i, FromJSON a) => FilePath -> FileName -> i (Maybe a)+readDocument collection key = liftIO $ do   jsonString <- try (BL.readFile $ documentPath collection key) :: IO (Either IOException BL.ByteString)   return $ decode =<< hush jsonString -readDocument' :: FromJSON a => FilePath -> Maybe FileName -> IO (Maybe a)-readDocument' collection key = case key of+readDocument' :: (MonadIO i, FromJSON a) => FilePath -> Maybe FileName -> i (Maybe a)+readDocument' collection key = liftIO $ case key of   Just key -> readDocument collection key   Nothing -> return Nothing -splitFindDocument :: FilePath -> Finder -> IO (Maybe (IdAndName, FileName))+splitFindDocument :: (MonadIO i) => FilePath -> Finder -> i (Maybe (IdAndName, FileName)) splitFindDocument collection finder = listDocumentKeys collection >>=   return . finder . catMaybes . map (\x -> intoFunctor (maybeReadIntString x) x) -extractIdAndName :: Maybe (IdAndName, FileName) -> IO (Maybe IdAndName)-extractIdAndName m = case m of-                       Just (ian, _) -> return $ Just ian-                       _ -> return Nothing--extractFilename :: Maybe (IdAndName, FileName) -> IO (Maybe FileName)-extractFilename m = case m of-                     Just (_, fname) -> return $ Just fname-                     _ -> return Nothing- findById :: Int -> Finder findById i = find $ (== i) . fst . fst @@ -132,31 +122,29 @@ findByName n = find $ (isSuffixOf n) . snd . fst  -- | Reads a document from a collection by numeric id (for example, key "00001-hello" has id 1).-readDocumentById :: FromJSON a => FilePath -> Int -> IO (Maybe a)+readDocumentById :: (MonadIO i, FromJSON a) => FilePath -> Int -> i (Maybe a) readDocumentById collection i =   splitFindDocument collection (findById i) >>=-  extractFilename >>=+  return . (snd <$>) >>=   readDocument' collection  -- | Reads a document from a collection by name (for example, key "00001-hello" has name "hello").-readDocumentByName :: FromJSON a => FilePath -> String -> IO (Maybe a)+readDocumentByName :: (MonadIO i, FromJSON a) => FilePath -> String -> i (Maybe a) readDocumentByName collection n =   splitFindDocument collection (findByName n) >>=-  extractFilename >>=+  return . (snd <$>) >>=   readDocument' collection  -- | Returns a document's id by name (for example, "hello" will return 23 when key "00023-hello" exists). -- Does not read the document!-documentIdFromName :: FilePath -> String -> IO (Maybe Int)+documentIdFromName :: (MonadIO i) => FilePath -> String -> i (Maybe Int) documentIdFromName collection n =   splitFindDocument collection (findByName n) >>=-  extractIdAndName >>=-  return . (fst <$>)+  return . (fst <$> fst <$>)  -- | Returns a document's name by id (for example, 23 will return "hello" when key "00023-hello" exists). -- Does not read the document!-documentNameFromId :: FilePath -> Int -> IO (Maybe String)+documentNameFromId :: (MonadIO i) => FilePath -> Int -> i (Maybe String) documentNameFromId collection i =   splitFindDocument collection (findById i) >>=-  extractIdAndName >>=-  return . (drop 1 . snd <$>)+  return . (drop 1 . snd <$> fst <$>)

@@ -0,0 +1,13 @@+{-# LANGUAGE Trustworthy #-}++-- | Trustworthy wrapper for aeson and aeson-pretty+module Gitson.Json (+  ToJSON, FromJSON, decode, encode+) where++import           Data.Aeson (ToJSON, FromJSON, decode)+import           Data.Aeson.Encode.Pretty+import           Data.ByteString.Lazy (ByteString)++encode :: ToJSON a => a -> ByteString+encode = encodePretty' $ Config { confIndent = 2, confCompare = compare }

@@ -1,7 +1,10 @@+{-# LANGUAGE Safe #-}+ -- | Various functions used inside Gitson. module Gitson.Util (module Gitson.Util) where  import           Control.Monad (void, filterM)+import           Control.Monad.IO.Class import           Control.Applicative import           Data.List (isSuffixOf, isPrefixOf) import           Data.Maybe@@ -37,12 +40,12 @@  -- | Returns an IO action that switches the current directory to a given path, -- executes the given IO action and switches the current directory back.-insideDirectory :: FilePath -> IO a -> IO a+insideDirectory :: (MonadIO i) => FilePath -> i a -> i a insideDirectory path action = do-  prevPath <- getCurrentDirectory-  setCurrentDirectory path+  prevPath <- liftIO $ getCurrentDirectory+  liftIO $ setCurrentDirectory path   result <- action-  setCurrentDirectory prevPath+  liftIO $ setCurrentDirectory prevPath   return result  -- | Returns the message of the last git commit in the repo where the current directory is located.@@ -50,8 +53,8 @@ lastCommitText = readProcess "git" ["log", "--max-count=1", "--pretty=format:%s"] []  -- | Runs a shell command with stdin, stdout and stderr set to /dev/null.-shell :: String -> [String] -> IO ()-shell cmd args = void $ do+shell :: (MonadIO i) => String -> [String] -> i ()+shell cmd args = liftIO $ void $ do   dnull <- openFile "/dev/null" ReadWriteMode   (_, _, _, pid) <- createProcess (proc cmd args){std_in = UseHandle dnull, std_out = UseHandle dnull, std_err = UseHandle dnull}   waitForProcess pid

@@ -1,8 +0,0 @@-module Gitson.UtilSpec (spec) where--import           Test.Hspec--- import           Gitson.Util--spec :: Spec-spec = do-  return ()

@@ -1,30 +0,0 @@-module Main (main) where--import           Data.List      (genericLength)-import           Data.Maybe     (catMaybes)-import           System.Exit    (exitFailure, exitSuccess)-import           System.Process (readProcess)-import           Text.Regex     (matchRegex, mkRegex)--arguments :: [String]-arguments =-    [ "haddock"-    ]--average :: (Fractional a, Real b) => [b] -> a-average xs = realToFrac (sum xs) / genericLength xs--expected :: Fractional a => a-expected = 90--main :: IO ()-main = do-    output <- readProcess "cabal" arguments ""-    if average (match output) >= expected-        then exitSuccess-        else putStr output >> exitFailure--match :: String -> [Int]-match = fmap read . concat . catMaybes . fmap (matchRegex pattern) . lines-  where-    pattern = mkRegex "^ *([0-9]*)% "