summaryrefslogtreecommitdiff
path: root/src/Storage/Internal.hs
blob: 400af8fe985a4aac39d5d05ffc6dc5cffc9f41b7 (plain)
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
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.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 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 FilePath
         | StorageMemory { memHeads :: MVar [Head' c]
                         , memObjs :: MVar (Map RefDigest BL.ByteString)
                         , memKeys :: MVar (Map RefDigest ScrubbedBytes)
                         }
    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

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)


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 Identity where
    type LoadResult Identity 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 Maybe where
    type LoadResult Maybe a = Maybe a
    returnLoadResult = id
    ioLoadBytes (Ref st dgst) = 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 spath } = handleJust (guard . isDoesNotExistError) (const $ return Nothing) $
              Just . decompress <$> (BL.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"