1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
module Storage.Internal where
import Codec.Compression.Zlib
import Control.Concurrent
import Control.Exception
import Control.Monad
import Control.Monad.Identity
import Crypto.Hash
import Data.ByteArray (ByteArrayAccess, ScrubbedBytes)
import qualified Data.ByteArray as BA
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as BL
import Data.List
import Data.Map (Map)
import qualified Data.Map as M
import System.Directory
import System.FilePath
import System.INotify (INotify)
import System.IO
import System.IO.Error
import System.Posix.Files
import System.Posix.IO
import System.Posix.Types
data Storage' c = Storage
{ stBacking :: StorageBacking c
, stParent :: Maybe (Storage' Identity)
}
deriving (Eq)
instance Show (Storage' c) where
show st@(Storage { stBacking = StorageDir { dirPath = path }}) = "dir" ++ showParentStorage st ++ ":" ++ path
show st@(Storage { stBacking = StorageMemory {} }) = "mem" ++ showParentStorage st
showParentStorage :: Storage' c -> String
showParentStorage Storage { stParent = Nothing } = ""
showParentStorage Storage { stParent = Just st } = "@" ++ show st
data StorageBacking c
= StorageDir { dirPath :: FilePath
, dirWatchers :: MVar (Maybe INotify, [(String, Head' c -> IO ())])
}
| StorageMemory { memHeads :: MVar [Head' c]
, memObjs :: MVar (Map RefDigest BL.ByteString)
, memKeys :: MVar (Map RefDigest ScrubbedBytes)
, memWatchers :: MVar [(String, Head' c -> IO ())]
}
deriving (Eq)
type RefDigest = Digest Blake2b_256
data Ref' c = Ref (Storage' c) RefDigest
deriving (Eq)
instance Show (Ref' c) where
show ref@(Ref st _) = show st ++ ":" ++ BC.unpack (showRef ref)
instance ByteArrayAccess (Ref' c) where
length (Ref _ dgst) = BA.length dgst
withByteArray (Ref _ dgst) = BA.withByteArray dgst
refStorage :: Ref' c -> Storage' c
refStorage (Ref st _) = st
refDigest :: Ref' c -> RefDigest
refDigest (Ref _ dgst) = dgst
showRef :: Ref' c -> ByteString
showRef = showRefDigest . refDigest
showRefDigest :: RefDigest -> ByteString
showRefDigest = B.concat . map showHexByte . BA.unpack
where showHex x | x < 10 = x + 48
| otherwise = x + 87
showHexByte x = B.pack [ showHex (x `div` 16), showHex (x `mod` 16) ]
data Head' c = Head String (Ref' c)
deriving (Show)
data Stored' c a = Stored (Ref' c) a
deriving (Show)
instance Eq (Stored' c a) where
Stored r1 _ == Stored r2 _ = refDigest r1 == refDigest r2
instance Ord (Stored' c a) where
compare (Stored r1 _) (Stored r2 _) = compare (refDigest r1) (refDigest r2)
type Complete = Identity
type Partial = Either RefDigest
class (Traversable compl, Monad compl) => StorageCompleteness compl where
type LoadResult compl a :: *
returnLoadResult :: compl a -> LoadResult compl a
ioLoadBytes :: Ref' compl -> IO (compl BL.ByteString)
instance StorageCompleteness Complete where
type LoadResult Complete a = a
returnLoadResult = runIdentity
ioLoadBytes ref@(Ref st dgst) = maybe (error $ "Ref not found in complete storage: "++show ref) Identity
<$> ioLoadBytesFromStorage st dgst
instance StorageCompleteness Partial where
type LoadResult Partial a = Either RefDigest a
returnLoadResult = id
ioLoadBytes (Ref st dgst) = maybe (Left dgst) Right <$> ioLoadBytesFromStorage st dgst
ioLoadBytesFromStorage :: Storage' c -> RefDigest -> IO (Maybe BL.ByteString)
ioLoadBytesFromStorage st dgst = loadCurrent st >>=
\case Just bytes -> return $ Just bytes
Nothing | Just parent <- stParent st -> ioLoadBytesFromStorage parent dgst
| otherwise -> return Nothing
where loadCurrent Storage { stBacking = StorageDir { dirPath = spath } } = handleJust (guard . isDoesNotExistError) (const $ return Nothing) $
Just . decompress . BL.fromChunks . (:[]) <$> (B.readFile $ refPath spath dgst)
loadCurrent Storage { stBacking = StorageMemory { memObjs = tobjs } } = M.lookup dgst <$> readMVar tobjs
refPath :: FilePath -> RefDigest -> FilePath
refPath spath dgst = intercalate "/" [spath, "objects", pref, rest]
where (pref, rest) = splitAt 2 $ BC.unpack $ showRefDigest dgst
openFdParents :: FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
openFdParents path omode fmode flags = do
createDirectoryIfMissing True (takeDirectory path)
openFd path omode fmode flags
writeFileOnce :: FilePath -> BL.ByteString -> IO ()
writeFileOnce file content = bracket
(fdToHandle =<< openFdParents locked WriteOnly (Just $ unionFileModes ownerReadMode ownerWriteMode) (defaultFileFlags { exclusive = True }))
hClose $ \h -> do
fileExist file >>= \case
True -> removeLink locked
False -> do BL.hPut h content
rename locked file
where locked = file ++ ".lock"
writeFileChecked :: FilePath -> Maybe ByteString -> ByteString -> IO (Either (Maybe ByteString) ())
writeFileChecked file prev content = bracket
(fdToHandle =<< openFdParents locked WriteOnly (Just $ unionFileModes ownerReadMode ownerWriteMode) (defaultFileFlags { exclusive = True }))
hClose $ \h -> do
(prev,) <$> fileExist file >>= \case
(Nothing, True) -> do
current <- B.readFile file
removeLink locked
return $ Left $ Just current
(Nothing, False) -> do B.hPut h content
rename locked file
return $ Right ()
(Just expected, True) -> do
current <- B.readFile file
if current == expected then do B.hPut h content
rename locked file
return $ return ()
else do removeLink locked
return $ Left $ Just current
(Just _, False) -> do
removeLink locked
return $ Left Nothing
where locked = file ++ ".lock"
|