Skip to content
Permalink
Browse files

add MVar local lock

because flock doesn't work across Haskell threads *facepalm*
  • Loading branch information...
myfreeweb committed Sep 4, 2015
1 parent 3b00179 commit 71f2b14037058d1656cf4447e944c4e8a2330f80
Showing with 32 additions and 29 deletions.
  1. +5 −5 gitson.cabal
  2. +27 −8 library/Gitson.hs
  3. +0 −16 library/Gitson/Json.hs
@@ -22,7 +22,9 @@ source-repository head

library
build-depends:
base >= 4.0.0.0 && < 5
base >= 4.3.0.0 && < 5
, base-compat >= 0.8.0
, lifted-base
, transformers
, monad-control
, process
@@ -39,13 +41,11 @@ library
exposed-modules:
Gitson
Gitson.Util
other-modules:
Gitson.Json
hs-source-dirs: library

test-suite examples
build-depends:
base >= 4.0.0.0 && < 5
base >= 4.3.0.0 && < 5
, Glob
, doctest
default-language: Haskell2010
@@ -56,7 +56,7 @@ test-suite examples

test-suite tests
build-depends:
base >= 4.0.0.0 && < 5
base >= 4.3.0.0 && < 5
, gitson
, transformers
, process
@@ -1,8 +1,10 @@
{-# LANGUAGE Safe, CPP, FlexibleContexts, UnicodeSyntax #-}
{-# LANGUAGE NoImplicitPrelude, CPP, FlexibleContexts, UnicodeSyntax #-}

-- | Gitson is a simple document store library for Git + JSON.
module Gitson (
TransactionWriter
, HasGitsonLock
, getGitsonLock
, createRepo
, transaction
, saveDocument
@@ -19,22 +21,29 @@ module Gitson (
, documentNameFromId
) where

import Prelude.Compat
import System.Directory
import System.Lock.FLock
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import System.IO.Unsafe
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 Control.Concurrent.MVar.Lifted
import Data.Maybe (fromMaybe, mapMaybe)
import Data.List (find, isSuffixOf)
import qualified Data.ByteString.Lazy as BL
import Data.Aeson (ToJSON, FromJSON, fromJSON, json, Result(..), Value)
import Data.Aeson.Encode.Pretty
import Data.ByteString.Lazy (ByteString)
import Data.Conduit.Attoparsec (sinkParserEither, ParseError)
import Conduit (sourceFile, ($$), runResourceT)
import Text.Printf (printf)
import Gitson.Util
import Gitson.Json

encode ToJSON a a ByteString
encode = encodePretty' $ Config { confIndent = 2, confCompare = compare }

-- | A transaction monad.
type TransactionWriter = WriterT [IO ()]
@@ -62,10 +71,20 @@ createRepo path = do
createDirectoryIfMissing True path
insideDirectory path $ shell "git" ["init"]

class HasGitsonLock m where
getGitsonLock m (MVar ())

globalGitsonLock MVar ()
globalGitsonLock = unsafePerformIO $ newMVar ()

instance HasGitsonLock IO where
getGitsonLock = return globalGitsonLock

-- | Executes a blocking transaction on a repository, committing the results to git.
transaction (MonadIO i, Functor i, MonadBaseControl IO i) FilePath TransactionWriter i () i ()
transaction repoPath action =
insideDirectory repoPath $ do
transaction (MonadIO i, Functor i, MonadBaseControl IO i, HasGitsonLock i) FilePath TransactionWriter i () i ()
transaction repoPath action = do
mlock getGitsonLock
withMVar mlock $ const $ insideDirectory repoPath $ do
liftIO $ writeFile lockPath ""
withLock lockPath Exclusive Block $ do
writeActions execWriterT action

This file was deleted.

Oops, something went wrong.

0 comments on commit 71f2b14

Please sign in to comment.
You can’t perform that action at this time.