Split to library and executable parts

1 files changed, 0 insertions, 273 deletions

diff --git a/src/Storage/Internal.hs b/src/Storage/Internal.hs
deleted file mode 100644
index 7b29193..0000000
--- a/src/Storage/Internal.hs
+++ /dev/null
@@ -1,273 +0,0 @@
-module Storage.Internal where
-
-import Codec.Compression.Zlib
-
-import Control.Arrow
-import Control.Concurrent
-import Control.DeepSeq
-import Control.Exception
-import Control.Monad
-import Control.Monad.Identity
-
-import Crypto.Hash
-
-import Data.Bits
-import Data.ByteArray (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.Char
-import Data.Function
-import Data.Hashable
-import qualified Data.HashTable.IO as HT
-import Data.Kind
-import Data.List
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.UUID (UUID)
-
-import Foreign.Storable (peek)
-
-import System.Directory
-import System.FilePath
-import System.INotify (INotify)
-import System.IO
-import System.IO.Error
-import System.IO.Unsafe (unsafePerformIO)
-import System.Posix.Files
-import System.Posix.IO
-
-
-data Storage' c = Storage
-    { stBacking :: StorageBacking c
-    , stParent :: Maybe (Storage' Identity)
-    , stRefGeneration :: MVar (HT.BasicHashTable RefDigest Generation)
-    , stRefRoots :: MVar (HT.BasicHashTable RefDigest [RefDigest])
-    }
-
-instance Eq (Storage' c) where
-    (==) = (==) `on` (stBacking &&& stParent)
-
-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 ([(HeadTypeID, INotify)], WatchList c)
-                      }
-         | StorageMemory { memHeads :: MVar [((HeadTypeID, HeadID), Ref' c)]
-                         , memObjs :: MVar (Map RefDigest BL.ByteString)
-                         , memKeys :: MVar (Map RefDigest ScrubbedBytes)
-                         , memWatchers :: MVar (WatchList c)
-                         }
-    deriving (Eq)
-
-newtype WatchID = WatchID Int
-    deriving (Eq, Ord, Num)
-
-data WatchList c = WatchList
-    { wlNext :: WatchID
-    , wlList :: [WatchListItem c]
-    }
-
-data WatchListItem c = WatchListItem
-    { wlID :: WatchID
-    , wlHead :: (HeadTypeID, HeadID)
-    , wlFun :: Ref' c -> IO ()
-    }
-
-
-newtype RefDigest = RefDigest (Digest Blake2b_256)
-    deriving (Eq, Ord, NFData, ByteArrayAccess)
-
-instance Show RefDigest where
-    show = BC.unpack . showRefDigest
-
-data Ref' c = Ref (Storage' c) RefDigest
-
-instance Eq (Ref' c) where
-    Ref _ d1 == Ref _ d2  =  d1 == d2
-
-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
-
-instance Hashable RefDigest where
-    hashWithSalt salt ref = salt `xor` unsafePerformIO (BA.withByteArray ref peek)
-
-instance Hashable (Ref' c) where
-    hashWithSalt salt ref = salt `xor` unsafePerformIO (BA.withByteArray ref peek)
-
-refStorage :: Ref' c -> Storage' c
-refStorage (Ref st _) = st
-
-refDigest :: Ref' c -> RefDigest
-refDigest (Ref _ dgst) = dgst
-
-showRef :: Ref' c -> ByteString
-showRef = showRefDigest . refDigest
-
-showRefDigestParts :: RefDigest -> (ByteString, ByteString)
-showRefDigestParts x = (BC.pack "blake2", showHex x)
-
-showRefDigest :: RefDigest -> ByteString
-showRefDigest = showRefDigestParts >>> \(alg, hex) -> alg <> BC.pack "#" <> hex
-
-readRefDigest :: ByteString -> Maybe RefDigest
-readRefDigest x = case BC.split '#' x of
-                       [alg, dgst] | BA.convert alg == BC.pack "blake2" ->
-                           refDigestFromByteString =<< readHex @ByteString dgst
-                       _ -> Nothing
-
-refDigestFromByteString :: ByteArrayAccess ba => ba -> Maybe RefDigest
-refDigestFromByteString = fmap RefDigest . digestFromByteString
-
-hashToRefDigest :: BL.ByteString -> RefDigest
-hashToRefDigest = RefDigest . hashFinalize . hashUpdates hashInit . BL.toChunks
-
-showHex :: ByteArrayAccess ba => ba -> ByteString
-showHex = B.concat . map showHexByte . BA.unpack
-    where showHexChar x | x < 10    = x + o '0'
-                        | otherwise = x + o 'a' - 10
-          showHexByte x = B.pack [ showHexChar (x `div` 16), showHexChar (x `mod` 16) ]
-          o = fromIntegral . ord
-
-readHex :: ByteArray ba => ByteString -> Maybe ba
-readHex = return . BA.concat <=< readHex'
-    where readHex' bs | B.null bs = Just []
-          readHex' bs = do (bx, bs') <- B.uncons bs
-                           (by, bs'') <- B.uncons bs'
-                           x <- hexDigit bx
-                           y <- hexDigit by
-                           (B.singleton (x * 16 + y) :) <$> readHex' bs''
-          hexDigit x | x >= o '0' && x <= o '9' = Just $ x - o '0'
-                     | x >= o 'a' && x <= o 'z' = Just $ x - o 'a' + 10
-                     | otherwise                = Nothing
-          o = fromIntegral . ord
-
-
-newtype Generation = Generation Int
-    deriving (Eq, Show)
-
-data Head' c a = Head HeadID (Stored' c a)
-    deriving (Eq, Show)
-
-newtype HeadID = HeadID UUID
-    deriving (Eq, Ord, Show)
-
-newtype HeadTypeID = HeadTypeID UUID
-    deriving (Eq, Ord)
-
-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)
-
-storedStorage :: Stored' c a -> Storage' c
-storedStorage (Stored (Ref st _) _) = st
-
-
-type Complete = Identity
-type Partial = Either RefDigest
-
-class (Traversable compl, Monad compl) => StorageCompleteness compl where
-    type LoadResult compl a :: Type
-    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
-
-unsafeStoreRawBytes :: Storage' c -> BL.ByteString -> IO (Ref' c)
-unsafeStoreRawBytes st raw = do
-    let dgst = hashToRefDigest raw
-    case stBacking st of
-         StorageDir { dirPath = sdir } -> writeFileOnce (refPath sdir dgst) $ compress raw
-         StorageMemory { memObjs = tobjs } ->
-             dgst `deepseq` -- the TVar may be accessed when evaluating the data to be written
-                 modifyMVar_ tobjs (return . M.insert dgst raw)
-    return $ Ref 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 rdgst = intercalate "/" [spath, "objects", BC.unpack alg, pref, rest]
-    where (alg, dgst) = showRefDigestParts rdgst
-          (pref, rest) = splitAt 2 $ BC.unpack dgst
-
-
-openLockFile :: FilePath -> IO Handle
-openLockFile path = do
-    createDirectoryIfMissing True (takeDirectory path)
-    fd <- retry 10 $
-        openFd path WriteOnly (Just $ unionFileModes ownerReadMode ownerWriteMode) (defaultFileFlags { exclusive = True })
-    fdToHandle fd
-  where
-    retry :: Int -> IO a -> IO a
-    retry 0 act = act
-    retry n act = catchJust (\e -> if isAlreadyExistsError e then Just () else Nothing)
-                      act (\_ -> threadDelay (100 * 1000) >> retry (n - 1) act)
-
-writeFileOnce :: FilePath -> BL.ByteString -> IO ()
-writeFileOnce file content = bracket (openLockFile locked)
-    hClose $ \h -> do
-        fileExist file >>= \case
-            True  -> removeLink locked
-            False -> do BL.hPut h content
-                        hFlush h
-                        rename locked file
-    where locked = file ++ ".lock"
-
-writeFileChecked :: FilePath -> Maybe ByteString -> ByteString -> IO (Either (Maybe ByteString) ())
-writeFileChecked file prev content = bracket (openLockFile locked)
-    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
-                                   hFlush h
-                                   rename locked file
-                                   return $ Right ()
-            (Just expected, True) -> do
-                current <- B.readFile file
-                if current == expected then do B.hPut h content
-                                               hFlush h
-                                               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"