module Gitson (
TransactionWriter
, createRepo
, transaction
, saveDocument
, saveNextDocument
, saveDocumentById
, saveDocumentByName
, 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 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
type TransactionWriter = WriterT [IO ()]
type IdAndName = (Int, String)
type FileName = String
type Finder = ([(IdAndName, FileName)] -> 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)
documentFullKey :: (MonadIO i) => FilePath -> Finder -> i (Maybe FileName)
documentFullKey collection finder = splitFindDocument collection finder >>= return . (snd <$>)
findById :: Int -> Finder
findById i = find $ (== i) . fst . fst
findByName :: String -> Finder
findByName n = find $ (isSuffixOf n) . snd . fst
createRepo :: FilePath -> IO ()
createRepo path = do
createDirectoryIfMissing True path
insideDirectory path $ shell "git" ["init"]
transaction :: (MonadIO i, MonadBaseControl IO i) => FilePath -> TransactionWriter i () -> i ()
transaction repoPath action =
insideDirectory repoPath $ do
liftIO $ writeFile lockPath ""
withLock lockPath Exclusive Block $ do
writeActions <- execWriterT action
shell "git" ["stash"]
liftIO $ 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
writeDocument :: ToJSON a => FilePath -> FileName -> a -> IO ()
writeDocument collection key content = BL.writeFile (documentPath collection key) (encode content)
saveDocument :: (MonadIO i, ToJSON a) => FilePath -> FileName -> a -> TransactionWriter i ()
saveDocument collection key content = do
tell [createDirectoryIfMissing True collection,
writeDocument collection key content]
saveNextDocument :: (MonadIO i, ToJSON a) => FilePath -> FileName -> a -> TransactionWriter i ()
saveNextDocument collection key content = do
tell [createDirectoryIfMissing True collection,
listDocumentKeys collection >>=
return . nextKeyId >>=
\nextId -> writeDocument collection (combineKey (nextId, key)) content]
saveDocumentById :: (MonadIO i, ToJSON a) => FilePath -> Int -> a -> TransactionWriter i ()
saveDocumentById collection i content = do
tell [documentFullKey collection (findById i) >>=
\k -> case k of
Just key -> writeDocument collection key content
Nothing -> return ()]
saveDocumentByName :: (MonadIO i, ToJSON a) => FilePath -> String -> a -> TransactionWriter i ()
saveDocumentByName collection n content = do
tell [documentFullKey collection (findByName n) >>=
\k -> case k of
Just key -> writeDocument collection key content
Nothing -> return ()]
listCollections :: (MonadIO i) => i [FilePath]
listCollections = liftIO $ do
contents <- try (getDirectoryContents =<< getCurrentDirectory) :: IO (Either IOException [FilePath])
filterDirs $ fromMaybe [] $ hush contents
listDocumentKeys :: (MonadIO i) => FilePath -> i [FileName]
listDocumentKeys collection = liftIO $ do
contents <- try (getDirectoryContents collection) :: IO (Either IOException [String])
return $ filterFilenamesAsKeys $ fromMaybe [] $ hush contents
listEntries :: (MonadIO i, FromJSON a) => FilePath -> i [a]
listEntries collection = liftIO $ do
ks <- listDocumentKeys collection
maybes <- mapM (readDocument collection) ks
return $ fromMaybe [] $ sequence maybes
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' :: (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
readDocumentById :: (MonadIO i, FromJSON a) => FilePath -> Int -> i (Maybe a)
readDocumentById collection i =
documentFullKey collection (findById i) >>=
readDocument' collection
readDocumentByName :: (MonadIO i, FromJSON a) => FilePath -> String -> i (Maybe a)
readDocumentByName collection n =
documentFullKey collection (findByName n) >>=
readDocument' collection
documentIdFromName :: (MonadIO i) => FilePath -> String -> i (Maybe Int)
documentIdFromName collection n =
splitFindDocument collection (findByName n) >>=
return . (fst <$> fst <$>)
documentNameFromId :: (MonadIO i) => FilePath -> Int -> i (Maybe String)
documentNameFromId collection i =
splitFindDocument collection (findById i) >>=
return . (drop 1 . snd <$> fst <$>)