module Gitson (
TransactionWriter
, createRepo
, transaction
, saveDocument
, saveNextDocument
, listCollections
, listDocumentKeys
, listEntries
, readDocument
, readDocumentById
, readDocumentByName
, documentIdFromName
, documentNameFromId
) where
import System.Directory
import System.Lock.FLock
import Control.Applicative ((<$>))
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 Data.Maybe (fromMaybe, catMaybes)
import Data.List (find, isSuffixOf)
import Text.Printf (printf)
import qualified Data.ByteString.Lazy as BL
import Gitson.Util
type TransactionWriter = WriterT [IO ()] IO ()
type IdAndName = (Int, String)
type FileName = String
type Finder = ([(IdAndName, FileName)] -> Maybe (IdAndName, FileName))
createRepo :: FilePath -> IO ()
createRepo path = do
createDirectoryIfMissing True path
insideDirectory path $ shell "git" ["init"]
transaction :: FilePath -> TransactionWriter -> IO ()
transaction repoPath action = do
insideDirectory repoPath $ do
writeFile lockPath ""
withLock lockPath Exclusive Block $ do
writeActions <- execWriterT action
shell "git" ["stash"]
sequence_ writeActions
shell "git" ["add", "--all"]
shell "git" ["commit", "-m", "Gitson transaction"]
shell "git" ["stash", "pop"]
combineKey :: IdAndName -> FileName
combineKey (n, s) = zeroPad n ++ "-" ++ s
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)
saveDocument :: ToJSON a => FilePath -> FileName -> a -> TransactionWriter
saveDocument collection key content = do
tell [createDirectoryIfMissing True collection,
writeDocument collection key content]
saveNextDocument :: ToJSON a => FilePath -> FileName -> a -> TransactionWriter
saveNextDocument collection key content = do
tell [createDirectoryIfMissing True collection,
listDocumentKeys collection >>=
return . nextKeyId >>=
\nextId -> writeDocument collection (combineKey (nextId, key)) content]
listCollections :: IO [FilePath]
listCollections = do
contents <- try (getDirectoryContents =<< getCurrentDirectory) :: IO (Either IOException [FilePath])
filterDirs $ fromMaybe [] $ hush contents
listDocumentKeys :: FilePath -> IO [FileName]
listDocumentKeys collection = do
contents <- try (getDirectoryContents collection) :: IO (Either IOException [String])
return $ filterFilenamesAsKeys $ fromMaybe [] $ hush contents
listEntries :: FromJSON a => FilePath -> IO [a]
listEntries collection = do
ks <- listDocumentKeys collection
maybes <- mapM (readDocument collection) ks
return $ fromMaybe [] $ sequence maybes
readDocument :: FromJSON a => FilePath -> FileName -> IO (Maybe a)
readDocument collection key = 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
Just key -> readDocument collection key
Nothing -> return Nothing
splitFindDocument :: FilePath -> Finder -> IO (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
findByName :: String -> Finder
findByName n = find $ (isSuffixOf n) . snd . fst
readDocumentById :: FromJSON a => FilePath -> Int -> IO (Maybe a)
readDocumentById collection i =
splitFindDocument collection (findById i) >>=
extractFilename >>=
readDocument' collection
readDocumentByName :: FromJSON a => FilePath -> String -> IO (Maybe a)
readDocumentByName collection n =
splitFindDocument collection (findByName n) >>=
extractFilename >>=
readDocument' collection
documentIdFromName :: FilePath -> String -> IO (Maybe Int)
documentIdFromName collection n =
splitFindDocument collection (findByName n) >>=
extractIdAndName >>=
return . (fst <$>)
documentNameFromId :: FilePath -> Int -> IO (Maybe String)
documentNameFromId collection i =
splitFindDocument collection (findById i) >>=
extractIdAndName >>=
return . (drop 1 . snd <$>)