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 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))
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]
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
splitFindDocument :: (MonadIO i) => FilePath -> Finder -> i (Maybe (IdAndName, FileName))
splitFindDocument collection finder = listDocumentKeys collection >>=
return . finder . catMaybes . map (\x -> intoFunctor (maybeReadIntString x) x)
findById :: Int -> Finder
findById i = find $ (== i) . fst . fst
findByName :: String -> Finder
findByName n = find $ (isSuffixOf n) . snd . fst
readDocumentById :: (MonadIO i, FromJSON a) => FilePath -> Int -> i (Maybe a)
readDocumentById collection i =
splitFindDocument collection (findById i) >>=
return . (snd <$>) >>=
readDocument' collection
readDocumentByName :: (MonadIO i, FromJSON a) => FilePath -> String -> i (Maybe a)
readDocumentByName collection n =
splitFindDocument collection (findByName n) >>=
return . (snd <$>) >>=
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 <$>)