{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | Hash addressed store in file system.
--
-- Associates a key ('Data.CAS.ContentHashable.ContentHash')
-- with an item in the store. An item can either be
-- 'Data.CAS.ContentStore.Missing',
-- 'Data.CAS.ContentStore.Pending', or
-- 'Data.CAS.ContentStore.Complete'.
-- The state is persisted in the file system.
--
-- Items are stored under a path derived from their hash. Therefore,
-- there can be no two copies of the same item in the store.
-- If two keys are associated with the same item, then there will be
-- only one copy of that item in the store.
--
-- The store is thread-safe and multi-process safe.
--
-- It is assumed that the user that the process is running under is the owner
-- of the store root, or has permission to create it if missing.
--
-- It is assumed that the store root and its immediate contents are not modified
-- externally. The contents of pending items may be modified externally.
--
-- __Implementation notes:__
--
-- The hash of an item can only be determined once it is completed.
-- If that hash already exists in the store, then the new item is discarded.
--
-- Store state is persisted in the file-system:
--
-- * Pending items are stored writable under the path @pending-\<key>@.
-- * Complete items are stored read-only under the path @item-\<hash>@,
--   with a link under @complete-\<key>@ pointing to that directory.
module Data.CAS.ContentStore
  ( -- * Open/Close
    withStore,
    open,
    close,

    -- * High-level API
    CacherM (..),
    Cacher,
    defaultCacherWithIdent,
    defaultIOCacherWithIdent,
    cacheKleisliIO,
    putInStore,
    contentPath,

    -- * List Contents
    listAll,
    listPending,
    listComplete,
    listItems,

    -- * Query/Lookup
    query,
    isMissing,
    isPending,
    isComplete,
    lookup,
    lookupOrWait,
    waitUntilComplete,

    -- * Construct Items
    cacheComputation,
    constructIfMissing,
    withConstructIfMissing,
    markPending,
    markComplete,

    -- * Remove Contents
    removeFailed,
    removeForcibly,
    removeItemForcibly,

    -- * Aliases
    assignAlias,
    lookupAlias,
    removeAlias,
    listAliases,

    -- * Metadata
    getBackReferences,
    setInputs,
    getInputs,
    setMetadata,
    getMetadata,
    createMetadataFile,
    getMetadataFile,

    -- * Accessors
    itemHash,
    itemPath,
    itemRelPath,
    contentItem,
    contentFilename,
    root,

    -- * Types
    ContentStore,
    Item,
    Content (..),
    (^</>),
    Alias (..),
    Status (..),
    Status_,
    Update (..),
    StoreError (..),
  )
where

import Control.Arrow (second)
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
import Control.Concurrent.MVar
import Control.Exception.Safe
import Control.Lens
import Control.Monad
  ( forM_,
    forever,
    mzero,
    unless,
    void,
    when,
    (<=<),
    (>=>),
  )
import Control.Monad.IO.Class (MonadIO, liftIO)
import Crypto.Hash (hashUpdate)
import Data.Aeson (FromJSON, ToJSON)
import Data.Bits (complement)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8
import Data.CAS.ContentHashable
  ( ContentHash,
    ContentHashable (..),
    DirectoryContent (..),
    contentHashUpdate_fingerprint,
    decodeHash,
    encodeHash,
    pathToHash,
    toBytes,
  )
import Data.CAS.ContentStore.Notify
import Data.CAS.Lock
import qualified Data.CAS.RemoteCache as Remote
import Data.CAS.StoreOrphans ()
import Data.Foldable (asum)
import qualified Data.Hashable
import Data.List (foldl', stripPrefix)
import Data.Maybe (fromMaybe, listToMaybe)
import qualified Data.Store
import Data.String (IsString (..))
import qualified Data.Text as T
import Data.Void
import qualified Database.SQLite.Simple as SQL
import qualified Database.SQLite.Simple.FromField as SQL
import qualified Database.SQLite.Simple.ToField as SQL
import GHC.Generics (Generic)
import Path
import Path.IO hiding (removePathForcibly)
import System.Directory (removePathForcibly)
import System.FilePath (dropTrailingPathSeparator)
import System.IO
  ( Handle,
    IOMode (..),
    openFile,
  )
import System.Posix.Files
import System.Posix.Types
import UnliftIO (MonadUnliftIO)
import Prelude hiding (lookup)

-- | Status of an item in the store.
data Status missing pending complete
  = -- | The item does not exist, yet.
    Missing missing
  | -- | The item is under construction and not ready for consumption.
    Pending pending
  | -- | The item is complete and ready for consumption.
    Complete complete
  deriving (Status missing pending complete
-> Status missing pending complete -> Bool
(Status missing pending complete
 -> Status missing pending complete -> Bool)
-> (Status missing pending complete
    -> Status missing pending complete -> Bool)
-> Eq (Status missing pending complete)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall missing pending complete.
(Eq missing, Eq pending, Eq complete) =>
Status missing pending complete
-> Status missing pending complete -> Bool
/= :: Status missing pending complete
-> Status missing pending complete -> Bool
$c/= :: forall missing pending complete.
(Eq missing, Eq pending, Eq complete) =>
Status missing pending complete
-> Status missing pending complete -> Bool
== :: Status missing pending complete
-> Status missing pending complete -> Bool
$c== :: forall missing pending complete.
(Eq missing, Eq pending, Eq complete) =>
Status missing pending complete
-> Status missing pending complete -> Bool
Eq, Int -> Status missing pending complete -> ShowS
[Status missing pending complete] -> ShowS
Status missing pending complete -> String
(Int -> Status missing pending complete -> ShowS)
-> (Status missing pending complete -> String)
-> ([Status missing pending complete] -> ShowS)
-> Show (Status missing pending complete)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall missing pending complete.
(Show missing, Show pending, Show complete) =>
Int -> Status missing pending complete -> ShowS
forall missing pending complete.
(Show missing, Show pending, Show complete) =>
[Status missing pending complete] -> ShowS
forall missing pending complete.
(Show missing, Show pending, Show complete) =>
Status missing pending complete -> String
showList :: [Status missing pending complete] -> ShowS
$cshowList :: forall missing pending complete.
(Show missing, Show pending, Show complete) =>
[Status missing pending complete] -> ShowS
show :: Status missing pending complete -> String
$cshow :: forall missing pending complete.
(Show missing, Show pending, Show complete) =>
Status missing pending complete -> String
showsPrec :: Int -> Status missing pending complete -> ShowS
$cshowsPrec :: forall missing pending complete.
(Show missing, Show pending, Show complete) =>
Int -> Status missing pending complete -> ShowS
Show)

type Status_ = Status () () ()

-- | Update about the status of a pending item.
data Update
  = -- | The item is now completed and ready for consumption.
    Completed Item
  | -- | Constructing the item failed.
    Failed
  deriving (Update -> Update -> Bool
(Update -> Update -> Bool)
-> (Update -> Update -> Bool) -> Eq Update
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Update -> Update -> Bool
$c/= :: Update -> Update -> Bool
== :: Update -> Update -> Bool
$c== :: Update -> Update -> Bool
Eq, Int -> Update -> ShowS
[Update] -> ShowS
Update -> String
(Int -> Update -> ShowS)
-> (Update -> String) -> ([Update] -> ShowS) -> Show Update
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Update] -> ShowS
$cshowList :: [Update] -> ShowS
show :: Update -> String
$cshow :: Update -> String
showsPrec :: Int -> Update -> ShowS
$cshowsPrec :: Int -> Update -> ShowS
Show)

-- | Errors that can occur when interacting with the store.
data StoreError
  = -- | An item is not under construction when it should be.
    NotPending ContentHash
  | -- | An item is already under construction when it should be missing.
    AlreadyPending ContentHash
  | -- | An item is already complete when it shouldn't be.
    AlreadyComplete ContentHash
  | -- | The link under the given hash points to an invalid path.
    CorruptedLink ContentHash FilePath
  | -- | A failure occurred while waiting for the item to be constructed.
    FailedToConstruct ContentHash
  | -- | @IncompatibleStoreVersion storeDir actual expected@
    --   The given store has a version number that is incompatible.
    IncompatibleStoreVersion (Path Abs Dir) Int Int
  | -- | @MalformedMetadataEntry hash key@
    --   The metadata entry for the give @hash@, @key@ pair is malformed.
    MalformedMetadataEntry ContentHash SQL.SQLData
  deriving (Int -> StoreError -> ShowS
[StoreError] -> ShowS
StoreError -> String
(Int -> StoreError -> ShowS)
-> (StoreError -> String)
-> ([StoreError] -> ShowS)
-> Show StoreError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [StoreError] -> ShowS
$cshowList :: [StoreError] -> ShowS
show :: StoreError -> String
$cshow :: StoreError -> String
showsPrec :: Int -> StoreError -> ShowS
$cshowsPrec :: Int -> StoreError -> ShowS
Show, Typeable)

instance Exception StoreError where
  displayException :: StoreError -> String
displayException = \case
    NotPending ContentHash
hash ->
      String
"The following input hash is not pending '"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
C8.unpack (ContentHash -> ByteString
encodeHash ContentHash
hash)
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'."
    AlreadyPending ContentHash
hash ->
      String
"The following input hash is already pending '"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
C8.unpack (ContentHash -> ByteString
encodeHash ContentHash
hash)
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'."
    AlreadyComplete ContentHash
hash ->
      String
"The following input hash is already completed '"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
C8.unpack (ContentHash -> ByteString
encodeHash ContentHash
hash)
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'."
    CorruptedLink ContentHash
hash String
fp ->
      String
"The completed input hash '"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
C8.unpack (ContentHash -> ByteString
encodeHash ContentHash
hash)
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' points to an invalid store item '"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fp
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'."
    FailedToConstruct ContentHash
hash ->
      String
"Failed to construct the input hash '"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
C8.unpack (ContentHash -> ByteString
encodeHash ContentHash
hash)
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'."
    IncompatibleStoreVersion Path Abs Dir
storeDir Int
actual Int
expected ->
      String
"The store in '"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ Path Abs Dir -> String
fromAbsDir Path Abs Dir
storeDir
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' has version "
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
actual
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
". This software expects version "
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
expected
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
". No automatic migration is available, \
           \please use a fresh store location."
    MalformedMetadataEntry ContentHash
hash SQLData
key ->
      String
"The metadata entry for hash '"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
C8.unpack (ContentHash -> ByteString
encodeHash ContentHash
hash)
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' under key '"
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ SQLData -> String
forall a. Show a => a -> String
show SQLData
key
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' is malformed."

-- | A hash addressed store on the file system.
data ContentStore = ContentStore
  { -- | Root directory of the content store.
    -- The process must be able to create this directory if missing,
    -- change permissions, and create files and directories within.
    ContentStore -> Path Abs Dir
storeRoot :: !(Path Abs Dir),
    -- | Write lock on store metadata to ensure multi thread and process safety.
    -- The lock is taken when item state is changed or queried.
    ContentStore -> Lock
storeLock :: !Lock,
    -- | Used to watch for updates on store items.
    ContentStore -> Notifier
storeNotifier :: !Notifier,
    -- | Connection to the metadata SQLite database.
    ContentStore -> Connection
storeDb :: !SQL.Connection
  }

-- | A completed item in the 'ContentStore'.
newtype Item = Item {Item -> ContentHash
itemHash :: ContentHash}
  deriving (Item -> Item -> Bool
(Item -> Item -> Bool) -> (Item -> Item -> Bool) -> Eq Item
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Item -> Item -> Bool
$c/= :: Item -> Item -> Bool
== :: Item -> Item -> Bool
$c== :: Item -> Item -> Bool
Eq, Eq Item
Eq Item
-> (Item -> Item -> Ordering)
-> (Item -> Item -> Bool)
-> (Item -> Item -> Bool)
-> (Item -> Item -> Bool)
-> (Item -> Item -> Bool)
-> (Item -> Item -> Item)
-> (Item -> Item -> Item)
-> Ord Item
Item -> Item -> Bool
Item -> Item -> Ordering
Item -> Item -> Item
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Item -> Item -> Item
$cmin :: Item -> Item -> Item
max :: Item -> Item -> Item
$cmax :: Item -> Item -> Item
>= :: Item -> Item -> Bool
$c>= :: Item -> Item -> Bool
> :: Item -> Item -> Bool
$c> :: Item -> Item -> Bool
<= :: Item -> Item -> Bool
$c<= :: Item -> Item -> Bool
< :: Item -> Item -> Bool
$c< :: Item -> Item -> Bool
compare :: Item -> Item -> Ordering
$ccompare :: Item -> Item -> Ordering
$cp1Ord :: Eq Item
Ord, Int -> Item -> ShowS
[Item] -> ShowS
Item -> String
(Int -> Item -> ShowS)
-> (Item -> String) -> ([Item] -> ShowS) -> Show Item
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Item] -> ShowS
$cshowList :: [Item] -> ShowS
show :: Item -> String
$cshow :: Item -> String
showsPrec :: Int -> Item -> ShowS
$cshowsPrec :: Int -> Item -> ShowS
Show, (forall x. Item -> Rep Item x)
-> (forall x. Rep Item x -> Item) -> Generic Item
forall x. Rep Item x -> Item
forall x. Item -> Rep Item x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Item x -> Item
$cfrom :: forall x. Item -> Rep Item x
Generic)

instance Monad m => ContentHashable m Item where
  contentHashUpdate :: Context SHA256 -> Item -> m (Context SHA256)
contentHashUpdate Context SHA256
ctx Item
item =
    (Context SHA256 -> Item -> m (Context SHA256))
-> Item -> Context SHA256 -> m (Context SHA256)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context SHA256 -> Item -> m (Context SHA256)
forall (m :: * -> *) a.
(Monad m, Typeable a) =>
Context SHA256 -> a -> m (Context SHA256)
contentHashUpdate_fingerprint Item
item
      (Context SHA256 -> m (Context SHA256))
-> (Context SHA256 -> m (Context SHA256))
-> Context SHA256
-> m (Context SHA256)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Context SHA256 -> m (Context SHA256)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Context SHA256 -> m (Context SHA256))
-> (Context SHA256 -> Context SHA256)
-> Context SHA256
-> m (Context SHA256)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Context SHA256 -> ByteString -> Context SHA256)
-> ByteString -> Context SHA256 -> Context SHA256
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context SHA256 -> ByteString -> Context SHA256
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
Context a -> ba -> Context a
hashUpdate (ContentHash -> ByteString
toBytes (ContentHash -> ByteString) -> ContentHash -> ByteString
forall a b. (a -> b) -> a -> b
$ Item -> ContentHash
itemHash Item
item)
      (Context SHA256 -> m (Context SHA256))
-> Context SHA256 -> m (Context SHA256)
forall a b. (a -> b) -> a -> b
$ Context SHA256
ctx

instance FromJSON Item

instance ToJSON Item

instance Data.Hashable.Hashable Item

instance Data.Store.Store Item

-- | File or directory within a content store 'Item'.
data Content t where
  All :: Item -> Content Dir
  (:</>) :: Item -> Path Rel t -> Content t

infixr 5 :</>

deriving instance Eq (Content t)

deriving instance Show (Content t)

instance Monad m => ContentHashable m (Content Dir) where
  contentHashUpdate :: Context SHA256 -> Content Dir -> m (Context SHA256)
contentHashUpdate Context SHA256
ctx Content Dir
x = case Content Dir
x of
    All Item
i ->
      (Context SHA256 -> Content Dir -> m (Context SHA256))
-> Content Dir -> Context SHA256 -> m (Context SHA256)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context SHA256 -> Content Dir -> m (Context SHA256)
forall (m :: * -> *) a.
(Monad m, Typeable a) =>
Context SHA256 -> a -> m (Context SHA256)
contentHashUpdate_fingerprint Content Dir
x
        (Context SHA256 -> m (Context SHA256))
-> (Context SHA256 -> m (Context SHA256))
-> Context SHA256
-> m (Context SHA256)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Context SHA256 -> Item -> m (Context SHA256))
-> Item -> Context SHA256 -> m (Context SHA256)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context SHA256 -> Item -> m (Context SHA256)
forall (m :: * -> *) a.
ContentHashable m a =>
Context SHA256 -> a -> m (Context SHA256)
contentHashUpdate Item
i
        (Context SHA256 -> m (Context SHA256))
-> Context SHA256 -> m (Context SHA256)
forall a b. (a -> b) -> a -> b
$ Context SHA256
ctx
    Item
i :</> Path Rel Dir
p ->
      (Context SHA256 -> Content Dir -> m (Context SHA256))
-> Content Dir -> Context SHA256 -> m (Context SHA256)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context SHA256 -> Content Dir -> m (Context SHA256)
forall (m :: * -> *) a.
(Monad m, Typeable a) =>
Context SHA256 -> a -> m (Context SHA256)
contentHashUpdate_fingerprint Content Dir
x
        (Context SHA256 -> m (Context SHA256))
-> (Context SHA256 -> m (Context SHA256))
-> Context SHA256
-> m (Context SHA256)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Context SHA256 -> Item -> m (Context SHA256))
-> Item -> Context SHA256 -> m (Context SHA256)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context SHA256 -> Item -> m (Context SHA256)
forall (m :: * -> *) a.
ContentHashable m a =>
Context SHA256 -> a -> m (Context SHA256)
contentHashUpdate Item
i
        (Context SHA256 -> m (Context SHA256))
-> (Context SHA256 -> m (Context SHA256))
-> Context SHA256
-> m (Context SHA256)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Context SHA256 -> Path Rel Dir -> m (Context SHA256))
-> Path Rel Dir -> Context SHA256 -> m (Context SHA256)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context SHA256 -> Path Rel Dir -> m (Context SHA256)
forall (m :: * -> *) a.
ContentHashable m a =>
Context SHA256 -> a -> m (Context SHA256)
contentHashUpdate Path Rel Dir
p
        (Context SHA256 -> m (Context SHA256))
-> Context SHA256 -> m (Context SHA256)
forall a b. (a -> b) -> a -> b
$ Context SHA256
ctx

instance Monad m => ContentHashable m (Content File) where
  contentHashUpdate :: Context SHA256 -> Content File -> m (Context SHA256)
contentHashUpdate Context SHA256
ctx Content File
x = case Content File
x of
    Item
i :</> Path Rel File
p ->
      (Context SHA256 -> Content File -> m (Context SHA256))
-> Content File -> Context SHA256 -> m (Context SHA256)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context SHA256 -> Content File -> m (Context SHA256)
forall (m :: * -> *) a.
(Monad m, Typeable a) =>
Context SHA256 -> a -> m (Context SHA256)
contentHashUpdate_fingerprint Content File
x
        (Context SHA256 -> m (Context SHA256))
-> (Context SHA256 -> m (Context SHA256))
-> Context SHA256
-> m (Context SHA256)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Context SHA256 -> Item -> m (Context SHA256))
-> Item -> Context SHA256 -> m (Context SHA256)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context SHA256 -> Item -> m (Context SHA256)
forall (m :: * -> *) a.
ContentHashable m a =>
Context SHA256 -> a -> m (Context SHA256)
contentHashUpdate Item
i
        (Context SHA256 -> m (Context SHA256))
-> (Context SHA256 -> m (Context SHA256))
-> Context SHA256
-> m (Context SHA256)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (Context SHA256 -> Path Rel File -> m (Context SHA256))
-> Path Rel File -> Context SHA256 -> m (Context SHA256)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Context SHA256 -> Path Rel File -> m (Context SHA256)
forall (m :: * -> *) a.
ContentHashable m a =>
Context SHA256 -> a -> m (Context SHA256)
contentHashUpdate Path Rel File
p
        (Context SHA256 -> m (Context SHA256))
-> Context SHA256 -> m (Context SHA256)
forall a b. (a -> b) -> a -> b
$ Context SHA256
ctx

-- | Append to the path within a store item.
(^</>) :: Content Dir -> Path Rel t -> Content t
All Item
item ^</> :: Content Dir -> Path Rel t -> Content t
^</> Path Rel t
path = Item
item Item -> Path Rel t -> Content t
forall t. Item -> Path Rel t -> Content t
:</> Path Rel t
path
(Item
item :</> Path Rel Dir
dir) ^</> Path Rel t
path = Item
item Item -> Path Rel t -> Content t
forall t. Item -> Path Rel t -> Content t
:</> Path Rel Dir
dir Path Rel Dir -> Path Rel t -> Path Rel t
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel t
path

infixl 4 ^</>

newtype Alias = Alias {Alias -> Text
unAlias :: T.Text}
  deriving (ContentHashable IO, Alias -> Alias -> Bool
(Alias -> Alias -> Bool) -> (Alias -> Alias -> Bool) -> Eq Alias
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Alias -> Alias -> Bool
$c/= :: Alias -> Alias -> Bool
== :: Alias -> Alias -> Bool
$c== :: Alias -> Alias -> Bool
Eq, Eq Alias
Eq Alias
-> (Alias -> Alias -> Ordering)
-> (Alias -> Alias -> Bool)
-> (Alias -> Alias -> Bool)
-> (Alias -> Alias -> Bool)
-> (Alias -> Alias -> Bool)
-> (Alias -> Alias -> Alias)
-> (Alias -> Alias -> Alias)
-> Ord Alias
Alias -> Alias -> Bool
Alias -> Alias -> Ordering
Alias -> Alias -> Alias
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Alias -> Alias -> Alias
$cmin :: Alias -> Alias -> Alias
max :: Alias -> Alias -> Alias
$cmax :: Alias -> Alias -> Alias
>= :: Alias -> Alias -> Bool
$c>= :: Alias -> Alias -> Bool
> :: Alias -> Alias -> Bool
$c> :: Alias -> Alias -> Bool
<= :: Alias -> Alias -> Bool
$c<= :: Alias -> Alias -> Bool
< :: Alias -> Alias -> Bool
$c< :: Alias -> Alias -> Bool
compare :: Alias -> Alias -> Ordering
$ccompare :: Alias -> Alias -> Ordering
$cp1Ord :: Eq Alias
Ord, Int -> Alias -> ShowS
[Alias] -> ShowS
Alias -> String
(Int -> Alias -> ShowS)
-> (Alias -> String) -> ([Alias] -> ShowS) -> Show Alias
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Alias] -> ShowS
$cshowList :: [Alias] -> ShowS
show :: Alias -> String
$cshow :: Alias -> String
showsPrec :: Int -> Alias -> ShowS
$cshowsPrec :: Int -> Alias -> ShowS
Show, FieldParser Alias
FieldParser Alias -> FromField Alias
forall a. FieldParser a -> FromField a
fromField :: FieldParser Alias
$cfromField :: FieldParser Alias
SQL.FromField, Alias -> SQLData
(Alias -> SQLData) -> ToField Alias
forall a. (a -> SQLData) -> ToField a
toField :: Alias -> SQLData
$ctoField :: Alias -> SQLData
SQL.ToField, Size Alias
Peek Alias
Size Alias -> (Alias -> Poke ()) -> Peek Alias -> Store Alias
Alias -> Poke ()
forall a. Size a -> (a -> Poke ()) -> Peek a -> Store a
peek :: Peek Alias
$cpeek :: Peek Alias
poke :: Alias -> Poke ()
$cpoke :: Alias -> Poke ()
size :: Size Alias
$csize :: Size Alias
Data.Store.Store)

-- | The root directory of the store.
root :: ContentStore -> Path Abs Dir
root :: ContentStore -> Path Abs Dir
root = ContentStore -> Path Abs Dir
storeRoot

-- | The scoped path to a content item within the store.
itemRelPath :: Item -> Path Rel Dir
itemRelPath :: Item -> Path Rel Dir
itemRelPath (Item ContentHash
x) = ByteString -> ContentHash -> Path Rel Dir
prefixHashPath ByteString
forall s. IsString s => s
itemPrefix ContentHash
x

-- | The store path of a completed item.
itemPath :: ContentStore -> Item -> Path Abs Dir
itemPath :: ContentStore -> Item -> Path Abs Dir
itemPath ContentStore
store = ContentStore -> ContentHash -> Path Abs Dir
mkItemPath ContentStore
store (ContentHash -> Path Abs Dir)
-> (Item -> ContentHash) -> Item -> Path Abs Dir
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Item -> ContentHash
itemHash

-- | Store item containing the given content.
contentItem :: Content t -> Item
contentItem :: Content t -> Item
contentItem (All Item
i) = Item
i
contentItem (Item
i :</> Path Rel t
_) = Item
i

contentFilename :: Content File -> Path Rel File
contentFilename :: Content File -> Path Rel File
contentFilename (Item
_ :</> Path Rel File
relPath) = Path Rel File -> Path Rel File
forall b. Path b File -> Path Rel File
filename Path Rel File
relPath

-- | The absolute path to content within the store.
contentPath :: ContentStore -> Content t -> Path Abs t
contentPath :: ContentStore -> Content t -> Path Abs t
contentPath ContentStore
store (All Item
item) = ContentStore -> Item -> Path Abs Dir
itemPath ContentStore
store Item
item
contentPath ContentStore
store (Item
item :</> Path Rel t
dir) = ContentStore -> Item -> Path Abs Dir
itemPath ContentStore
store Item
item Path Abs Dir -> Path Rel t -> Path Abs t
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel t
dir

-- | @open root@ opens a store under the given root directory.
--
-- The root directory is created if necessary.
--
-- It is not safe to have multiple store objects
-- refer to the same root directory.
open :: Path Abs Dir -> IO ContentStore
open :: Path Abs Dir -> IO ContentStore
open Path Abs Dir
storeRoot = do
  Bool -> Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Bool -> Path b Dir -> m ()
createDirIfMissing Bool
True Path Abs Dir
storeRoot
  Lock
storeLock <- Path Abs Dir -> IO Lock
openLock (Path Abs Dir -> Path Abs Dir
lockPath Path Abs Dir
storeRoot)
  Lock -> IO ContentStore -> IO ContentStore
forall (m :: * -> *) a. MonadUnliftIO m => Lock -> m a -> m a
withLock Lock
storeLock (IO ContentStore -> IO ContentStore)
-> IO ContentStore -> IO ContentStore
forall a b. (a -> b) -> a -> b
$
    Path Abs Dir -> IO ContentStore -> IO ContentStore
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
Path Abs Dir -> m a -> m a
withWritableStoreRoot Path Abs Dir
storeRoot (IO ContentStore -> IO ContentStore)
-> IO ContentStore -> IO ContentStore
forall a b. (a -> b) -> a -> b
$ do
      Connection
storeDb <- String -> IO Connection
SQL.open (Path Abs File -> String
fromAbsFile (Path Abs File -> String) -> Path Abs File -> String
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> Path Abs File
dbPath Path Abs Dir
storeRoot)
      Path Abs Dir -> Connection -> IO ()
initDb Path Abs Dir
storeRoot Connection
storeDb
      Bool -> Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Bool -> Path b Dir -> m ()
createDirIfMissing Bool
True (Path Abs Dir -> Path Abs Dir
metadataPath Path Abs Dir
storeRoot)
      Notifier
storeNotifier <- IO Notifier
initNotifier
      ContentStore -> IO ContentStore
forall (m :: * -> *) a. Monad m => a -> m a
return ContentStore :: Path Abs Dir -> Lock -> Notifier -> Connection -> ContentStore
ContentStore {Notifier
Path Abs Dir
Connection
Lock
storeNotifier :: Notifier
storeDb :: Connection
storeLock :: Lock
storeRoot :: Path Abs Dir
storeDb :: Connection
storeNotifier :: Notifier
storeLock :: Lock
storeRoot :: Path Abs Dir
..}

-- | Free the resources associated with the given store object.
--
-- The store object may not be used afterwards.
close :: ContentStore -> IO ()
close :: ContentStore -> IO ()
close ContentStore
store = do
  Lock -> IO ()
closeLock (ContentStore -> Lock
storeLock ContentStore
store)
  Notifier -> IO ()
killNotifier (ContentStore -> Notifier
storeNotifier ContentStore
store)
  Connection -> IO ()
SQL.close (ContentStore -> Connection
storeDb ContentStore
store)

-- | Open the store under the given root and perform the given action.
-- Closes the store once the action is complete
--
-- See also: 'Data.CAS.ContentStore.open'
withStore ::
  (MonadIO m, MonadMask m) =>
  Path Abs Dir ->
  (ContentStore -> m a) ->
  m a
withStore :: Path Abs Dir -> (ContentStore -> m a) -> m a
withStore Path Abs Dir
root' = m ContentStore
-> (ContentStore -> m ()) -> (ContentStore -> m a) -> m a
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (IO ContentStore -> m ContentStore
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ContentStore -> m ContentStore)
-> IO ContentStore -> m ContentStore
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> IO ContentStore
open Path Abs Dir
root') (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (ContentStore -> IO ()) -> ContentStore -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentStore -> IO ()
close)

-- | List all elements in the store
-- @(pending keys, completed keys, completed items)@.
listAll :: MonadIO m => ContentStore -> m ([ContentHash], [ContentHash], [Item])
listAll :: ContentStore -> m ([ContentHash], [ContentHash], [Item])
listAll ContentStore {Path Abs Dir
storeRoot :: Path Abs Dir
storeRoot :: ContentStore -> Path Abs Dir
storeRoot} =
  IO ([ContentHash], [ContentHash], [Item])
-> m ([ContentHash], [ContentHash], [Item])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([ContentHash], [ContentHash], [Item])
 -> m ([ContentHash], [ContentHash], [Item]))
-> IO ([ContentHash], [ContentHash], [Item])
-> m ([ContentHash], [ContentHash], [Item])
forall a b. (a -> b) -> a -> b
$
    (Path Abs Dir
 -> ([ContentHash], [ContentHash], [Item])
 -> ([ContentHash], [ContentHash], [Item]))
-> ([ContentHash], [ContentHash], [Item])
-> [Path Abs Dir]
-> ([ContentHash], [ContentHash], [Item])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Path Abs Dir
-> ([ContentHash], [ContentHash], [Item])
-> ([ContentHash], [ContentHash], [Item])
go ([], [], []) ([Path Abs Dir] -> ([ContentHash], [ContentHash], [Item]))
-> (([Path Abs Dir], [Path Abs File]) -> [Path Abs Dir])
-> ([Path Abs Dir], [Path Abs File])
-> ([ContentHash], [ContentHash], [Item])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Path Abs Dir], [Path Abs File]) -> [Path Abs Dir]
forall a b. (a, b) -> a
fst (([Path Abs Dir], [Path Abs File])
 -> ([ContentHash], [ContentHash], [Item]))
-> IO ([Path Abs Dir], [Path Abs File])
-> IO ([ContentHash], [ContentHash], [Item])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path Abs Dir -> IO ([Path Abs Dir], [Path Abs File])
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> m ([Path Abs Dir], [Path Abs File])
listDir Path Abs Dir
storeRoot
  where
    go :: Path Abs Dir
-> ([ContentHash], [ContentHash], [Item])
-> ([ContentHash], [ContentHash], [Item])
go Path Abs Dir
d prev :: ([ContentHash], [ContentHash], [Item])
prev@([ContentHash]
builds, [ContentHash]
outs, [Item]
items) =
      ([ContentHash], [ContentHash], [Item])
-> Maybe ([ContentHash], [ContentHash], [Item])
-> ([ContentHash], [ContentHash], [Item])
forall a. a -> Maybe a -> a
fromMaybe ([ContentHash], [ContentHash], [Item])
prev (Maybe ([ContentHash], [ContentHash], [Item])
 -> ([ContentHash], [ContentHash], [Item]))
-> Maybe ([ContentHash], [ContentHash], [Item])
-> ([ContentHash], [ContentHash], [Item])
forall a b. (a -> b) -> a -> b
$
        [Maybe ([ContentHash], [ContentHash], [Item])]
-> Maybe ([ContentHash], [ContentHash], [Item])
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
          [ Path Abs Dir -> Maybe ContentHash
parsePending Path Abs Dir
d Maybe ContentHash
-> (ContentHash -> Maybe ([ContentHash], [ContentHash], [Item]))
-> Maybe ([ContentHash], [ContentHash], [Item])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ContentHash
x -> ([ContentHash], [ContentHash], [Item])
-> Maybe ([ContentHash], [ContentHash], [Item])
forall a. a -> Maybe a
Just (ContentHash
x ContentHash -> [ContentHash] -> [ContentHash]
forall a. a -> [a] -> [a]
: [ContentHash]
builds, [ContentHash]
outs, [Item]
items),
            Path Abs Dir -> Maybe ContentHash
parseComplete Path Abs Dir
d Maybe ContentHash
-> (ContentHash -> Maybe ([ContentHash], [ContentHash], [Item]))
-> Maybe ([ContentHash], [ContentHash], [Item])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ContentHash
x -> ([ContentHash], [ContentHash], [Item])
-> Maybe ([ContentHash], [ContentHash], [Item])
forall a. a -> Maybe a
Just ([ContentHash]
builds, ContentHash
x ContentHash -> [ContentHash] -> [ContentHash]
forall a. a -> [a] -> [a]
: [ContentHash]
outs, [Item]
items),
            Path Abs Dir -> Maybe Item
parseItem Path Abs Dir
d Maybe Item
-> (Item -> Maybe ([ContentHash], [ContentHash], [Item]))
-> Maybe ([ContentHash], [ContentHash], [Item])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Item
x -> ([ContentHash], [ContentHash], [Item])
-> Maybe ([ContentHash], [ContentHash], [Item])
forall a. a -> Maybe a
Just ([ContentHash]
builds, [ContentHash]
outs, Item
x Item -> [Item] -> [Item]
forall a. a -> [a] -> [a]
: [Item]
items)
          ]
    parsePending :: Path Abs Dir -> Maybe ContentHash
    parsePending :: Path Abs Dir -> Maybe ContentHash
parsePending = String -> Maybe ContentHash
pathToHash (String -> Maybe ContentHash)
-> (Path Abs Dir -> Maybe String)
-> Path Abs Dir
-> Maybe ContentHash
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
forall s. IsString s => s
pendingPrefix (String -> Maybe String)
-> (Path Abs Dir -> String) -> Path Abs Dir -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> String
extractDir
    parseComplete :: Path Abs Dir -> Maybe ContentHash
    parseComplete :: Path Abs Dir -> Maybe ContentHash
parseComplete = String -> Maybe ContentHash
pathToHash (String -> Maybe ContentHash)
-> (Path Abs Dir -> Maybe String)
-> Path Abs Dir
-> Maybe ContentHash
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
forall s. IsString s => s
completePrefix (String -> Maybe String)
-> (Path Abs Dir -> String) -> Path Abs Dir -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> String
extractDir
    parseItem :: Path Abs Dir -> Maybe Item
    parseItem :: Path Abs Dir -> Maybe Item
parseItem = (ContentHash -> Item) -> Maybe ContentHash -> Maybe Item
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ContentHash -> Item
Item (Maybe ContentHash -> Maybe Item)
-> (String -> Maybe ContentHash) -> String -> Maybe Item
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe ContentHash
pathToHash (String -> Maybe Item)
-> (Path Abs Dir -> Maybe String) -> Path Abs Dir -> Maybe Item
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
forall s. IsString s => s
itemPrefix (String -> Maybe String)
-> (Path Abs Dir -> String) -> Path Abs Dir -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> String
extractDir
    extractDir :: Path Abs Dir -> FilePath
    extractDir :: Path Abs Dir -> String
extractDir = ShowS
dropTrailingPathSeparator ShowS -> (Path Abs Dir -> String) -> Path Abs Dir -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Rel Dir -> String
fromRelDir (Path Rel Dir -> String)
-> (Path Abs Dir -> Path Rel Dir) -> Path Abs Dir -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> Path Rel Dir
forall b. Path b Dir -> Path Rel Dir
dirname

-- | List all pending keys in the store.
listPending :: MonadIO m => ContentStore -> m [ContentHash]
listPending :: ContentStore -> m [ContentHash]
listPending = (([ContentHash], [ContentHash], [Item]) -> [ContentHash])
-> m ([ContentHash], [ContentHash], [Item]) -> m [ContentHash]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([ContentHash], [ContentHash], [Item])
-> Getting
     [ContentHash] ([ContentHash], [ContentHash], [Item]) [ContentHash]
-> [ContentHash]
forall s a. s -> Getting a s a -> a
^. Getting
  [ContentHash] ([ContentHash], [ContentHash], [Item]) [ContentHash]
forall s t a b. Field1 s t a b => Lens s t a b
_1) (m ([ContentHash], [ContentHash], [Item]) -> m [ContentHash])
-> (ContentStore -> m ([ContentHash], [ContentHash], [Item]))
-> ContentStore
-> m [ContentHash]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentStore -> m ([ContentHash], [ContentHash], [Item])
forall (m :: * -> *).
MonadIO m =>
ContentStore -> m ([ContentHash], [ContentHash], [Item])
listAll

-- | List all completed keys in the store.
listComplete :: MonadIO m => ContentStore -> m [ContentHash]
listComplete :: ContentStore -> m [ContentHash]
listComplete = (([ContentHash], [ContentHash], [Item]) -> [ContentHash])
-> m ([ContentHash], [ContentHash], [Item]) -> m [ContentHash]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([ContentHash], [ContentHash], [Item])
-> Getting
     [ContentHash] ([ContentHash], [ContentHash], [Item]) [ContentHash]
-> [ContentHash]
forall s a. s -> Getting a s a -> a
^. Getting
  [ContentHash] ([ContentHash], [ContentHash], [Item]) [ContentHash]
forall s t a b. Field2 s t a b => Lens s t a b
_2) (m ([ContentHash], [ContentHash], [Item]) -> m [ContentHash])
-> (ContentStore -> m ([ContentHash], [ContentHash], [Item]))
-> ContentStore
-> m [ContentHash]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentStore -> m ([ContentHash], [ContentHash], [Item])
forall (m :: * -> *).
MonadIO m =>
ContentStore -> m ([ContentHash], [ContentHash], [Item])
listAll

-- | List all completed items in the store.
listItems :: MonadIO m => ContentStore -> m [Item]
listItems :: ContentStore -> m [Item]
listItems = (([ContentHash], [ContentHash], [Item]) -> [Item])
-> m ([ContentHash], [ContentHash], [Item]) -> m [Item]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([ContentHash], [ContentHash], [Item])
-> Getting [Item] ([ContentHash], [ContentHash], [Item]) [Item]
-> [Item]
forall s a. s -> Getting a s a -> a
^. Getting [Item] ([ContentHash], [ContentHash], [Item]) [Item]
forall s t a b. Field3 s t a b => Lens s t a b
_3) (m ([ContentHash], [ContentHash], [Item]) -> m [Item])
-> (ContentStore -> m ([ContentHash], [ContentHash], [Item]))
-> ContentStore
-> m [Item]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentStore -> m ([ContentHash], [ContentHash], [Item])
forall (m :: * -> *).
MonadIO m =>
ContentStore -> m ([ContentHash], [ContentHash], [Item])
listAll

-- | Query the state of the item under the given key.
query :: MonadIO m => ContentStore -> ContentHash -> m (Status () () ())
query :: ContentStore -> ContentHash -> m (Status () () ())
query ContentStore
store ContentHash
hash =
  IO (Status () () ()) -> m (Status () () ())
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Status () () ()) -> m (Status () () ()))
-> (IO (Status () () ()) -> IO (Status () () ()))
-> IO (Status () () ())
-> m (Status () () ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentStore -> IO (Status () () ()) -> IO (Status () () ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
ContentStore -> m a -> m a
withStoreLock ContentStore
store (IO (Status () () ()) -> m (Status () () ()))
-> IO (Status () () ()) -> m (Status () () ())
forall a b. (a -> b) -> a -> b
$
    ContentStore -> ContentHash -> IO (Status () (Path Abs Dir) Item)
forall (m :: * -> *).
MonadIO m =>
ContentStore -> ContentHash -> m (Status () (Path Abs Dir) Item)
internalQuery ContentStore
store ContentHash
hash
      IO (Status () (Path Abs Dir) Item)
-> (Status () (Path Abs Dir) Item -> IO (Status () () ()))
-> IO (Status () () ())
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Status () () () -> IO (Status () () ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Status () () () -> IO (Status () () ()))
-> (Status () (Path Abs Dir) Item -> Status () () ())
-> Status () (Path Abs Dir) Item
-> IO (Status () () ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
        Missing ()
_ -> () -> Status () () ()
forall missing pending complete.
missing -> Status missing pending complete
Missing ()
        Pending Path Abs Dir
_ -> () -> Status () () ()
forall missing pending complete.
pending -> Status missing pending complete
Pending ()
        Complete Item
_ -> () -> Status () () ()
forall missing pending complete.
complete -> Status missing pending complete
Complete ()

-- | Check if there is no complete or pending item under the given key.
isMissing :: MonadIO m => ContentStore -> ContentHash -> m Bool
isMissing :: ContentStore -> ContentHash -> m Bool
isMissing ContentStore
store ContentHash
hash = (Status () () () -> Status () () () -> Bool
forall a. Eq a => a -> a -> Bool
== () -> Status () () ()
forall missing pending complete.
missing -> Status missing pending complete
Missing ()) (Status () () () -> Bool) -> m (Status () () ()) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContentStore -> ContentHash -> m (Status () () ())
forall (m :: * -> *).
MonadIO m =>
ContentStore -> ContentHash -> m (Status () () ())
query ContentStore
store ContentHash
hash

-- | Check if there is a pending item under the given key.
isPending :: MonadIO m => ContentStore -> ContentHash -> m Bool
isPending :: ContentStore -> ContentHash -> m Bool
isPending ContentStore
store ContentHash
hash = (Status () () () -> Status () () () -> Bool
forall a. Eq a => a -> a -> Bool
== () -> Status () () ()
forall missing pending complete.
pending -> Status missing pending complete
Pending ()) (Status () () () -> Bool) -> m (Status () () ()) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContentStore -> ContentHash -> m (Status () () ())
forall (m :: * -> *).
MonadIO m =>
ContentStore -> ContentHash -> m (Status () () ())
query ContentStore
store ContentHash
hash

-- | Check if there is a completed item under the given key.
isComplete :: MonadIO m => ContentStore -> ContentHash -> m Bool
isComplete :: ContentStore -> ContentHash -> m Bool
isComplete ContentStore
store ContentHash
hash = (Status () () () -> Status () () () -> Bool
forall a. Eq a => a -> a -> Bool
== () -> Status () () ()
forall missing pending complete.
complete -> Status missing pending complete
Complete ()) (Status () () () -> Bool) -> m (Status () () ()) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContentStore -> ContentHash -> m (Status () () ())
forall (m :: * -> *).
MonadIO m =>
ContentStore -> ContentHash -> m (Status () () ())
query ContentStore
store ContentHash
hash

-- | Query the state under the given key and return the item if completed.
-- Doesn't block if the item is pending.
lookup :: MonadIO m => ContentStore -> ContentHash -> m (Status () () Item)
lookup :: ContentStore -> ContentHash -> m (Status () () Item)
lookup ContentStore
store ContentHash
hash =
  IO (Status () () Item) -> m (Status () () Item)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Status () () Item) -> m (Status () () Item))
-> (IO (Status () () Item) -> IO (Status () () Item))
-> IO (Status () () Item)
-> m (Status () () Item)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentStore -> IO (Status () () Item) -> IO (Status () () Item)
forall (m :: * -> *) a.
MonadUnliftIO m =>
ContentStore -> m a -> m a
withStoreLock ContentStore
store (IO (Status () () Item) -> m (Status () () Item))
-> IO (Status () () Item) -> m (Status () () Item)
forall a b. (a -> b) -> a -> b
$
    ContentStore -> ContentHash -> IO (Status () (Path Abs Dir) Item)
forall (m :: * -> *).
MonadIO m =>
ContentStore -> ContentHash -> m (Status () (Path Abs Dir) Item)
internalQuery ContentStore
store ContentHash
hash IO (Status () (Path Abs Dir) Item)
-> (Status () (Path Abs Dir) Item -> IO (Status () () Item))
-> IO (Status () () Item)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Missing () -> Status () () Item -> IO (Status () () Item)
forall (m :: * -> *) a. Monad m => a -> m a
return (Status () () Item -> IO (Status () () Item))
-> Status () () Item -> IO (Status () () Item)
forall a b. (a -> b) -> a -> b
$ () -> Status () () Item
forall missing pending complete.
missing -> Status missing pending complete
Missing ()
      Pending Path Abs Dir
_ -> Status () () Item -> IO (Status () () Item)
forall (m :: * -> *) a. Monad m => a -> m a
return (Status () () Item -> IO (Status () () Item))
-> Status () () Item -> IO (Status () () Item)
forall a b. (a -> b) -> a -> b
$ () -> Status () () Item
forall missing pending complete.
pending -> Status missing pending complete
Pending ()
      Complete Item
item -> Status () () Item -> IO (Status () () Item)
forall (m :: * -> *) a. Monad m => a -> m a
return (Status () () Item -> IO (Status () () Item))
-> Status () () Item -> IO (Status () () Item)
forall a b. (a -> b) -> a -> b
$ Item -> Status () () Item
forall missing pending complete.
complete -> Status missing pending complete
Complete Item
item

-- | Query the state under the given key and return the item if completed.
-- Return an 'Control.Concurrent.Async' to await an update, if pending.
lookupOrWait ::
  MonadIO m =>
  ContentStore ->
  ContentHash ->
  m (Status () (Async Update) Item)
lookupOrWait :: ContentStore -> ContentHash -> m (Status () (Async Update) Item)
lookupOrWait ContentStore
store ContentHash
hash =
  IO (Status () (Async Update) Item)
-> m (Status () (Async Update) Item)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Status () (Async Update) Item)
 -> m (Status () (Async Update) Item))
-> (IO (Status () (Async Update) Item)
    -> IO (Status () (Async Update) Item))
-> IO (Status () (Async Update) Item)
-> m (Status () (Async Update) Item)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentStore
-> IO (Status () (Async Update) Item)
-> IO (Status () (Async Update) Item)
forall (m :: * -> *) a.
MonadUnliftIO m =>
ContentStore -> m a -> m a
withStoreLock ContentStore
store (IO (Status () (Async Update) Item)
 -> m (Status () (Async Update) Item))
-> IO (Status () (Async Update) Item)
-> m (Status () (Async Update) Item)
forall a b. (a -> b) -> a -> b
$
    ContentStore -> ContentHash -> IO (Status () (Path Abs Dir) Item)
forall (m :: * -> *).
MonadIO m =>
ContentStore -> ContentHash -> m (Status () (Path Abs Dir) Item)
internalQuery ContentStore
store ContentHash
hash IO (Status () (Path Abs Dir) Item)
-> (Status () (Path Abs Dir) Item
    -> IO (Status () (Async Update) Item))
-> IO (Status () (Async Update) Item)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Complete Item
item -> Status () (Async Update) Item -> IO (Status () (Async Update) Item)
forall (m :: * -> *) a. Monad m => a -> m a
return (Status () (Async Update) Item
 -> IO (Status () (Async Update) Item))
-> Status () (Async Update) Item
-> IO (Status () (Async Update) Item)
forall a b. (a -> b) -> a -> b
$ Item -> Status () (Async Update) Item
forall missing pending complete.
complete -> Status missing pending complete
Complete Item
item
      Missing () -> Status () (Async Update) Item -> IO (Status () (Async Update) Item)
forall (m :: * -> *) a. Monad m => a -> m a
return (Status () (Async Update) Item
 -> IO (Status () (Async Update) Item))
-> Status () (Async Update) Item
-> IO (Status () (Async Update) Item)
forall a b. (a -> b) -> a -> b
$ () -> Status () (Async Update) Item
forall missing pending complete.
missing -> Status missing pending complete
Missing ()
      Pending Path Abs Dir
_ -> Async Update -> Status () (Async Update) Item
forall missing pending complete.
pending -> Status missing pending complete
Pending (Async Update -> Status () (Async Update) Item)
-> IO (Async Update) -> IO (Status () (Async Update) Item)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContentStore -> ContentHash -> IO (Async Update)
internalWatchPending ContentStore
store ContentHash
hash

-- | Query the state under the given key and return the item once completed.
-- Blocks if the item is pending.
-- Returns 'Nothing' if the item is missing, or failed to be completed.
waitUntilComplete :: MonadIO m => ContentStore -> ContentHash -> m (Maybe Item)
waitUntilComplete :: ContentStore -> ContentHash -> m (Maybe Item)
waitUntilComplete ContentStore
store ContentHash
hash =
  ContentStore -> ContentHash -> m (Status () (Async Update) Item)
forall (m :: * -> *).
MonadIO m =>
ContentStore -> ContentHash -> m (Status () (Async Update) Item)
lookupOrWait ContentStore
store ContentHash
hash m (Status () (Async Update) Item)
-> (Status () (Async Update) Item -> m (Maybe Item))
-> m (Maybe Item)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Complete Item
item -> Maybe Item -> m (Maybe Item)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Item -> m (Maybe Item)) -> Maybe Item -> m (Maybe Item)
forall a b. (a -> b) -> a -> b
$ Item -> Maybe Item
forall a. a -> Maybe a
Just Item
item
    Missing () -> Maybe Item -> m (Maybe Item)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Item
forall a. Maybe a
Nothing
    Pending Async Update
a ->
      IO Update -> m Update
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Async Update -> IO Update
forall a. Async a -> IO a
wait Async Update
a) m Update -> (Update -> m (Maybe Item)) -> m (Maybe Item)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Completed Item
item -> Maybe Item -> m (Maybe Item)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Item -> m (Maybe Item)) -> Maybe Item -> m (Maybe Item)
forall a b. (a -> b) -> a -> b
$ Item -> Maybe Item
forall a. a -> Maybe a
Just Item
item
        Update
Failed -> Maybe Item -> m (Maybe Item)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Item
forall a. Maybe a
Nothing

-- | Atomically query the state under the given key and mark pending if missing.
constructIfMissing ::
  (MonadIO m, MonadUnliftIO m, MonadMask m, Remote.Cacher m remoteCache) =>
  ContentStore ->
  remoteCache ->
  ContentHash ->
  m (Status (Path Abs Dir) () Item)
constructIfMissing :: ContentStore
-> remoteCache -> ContentHash -> m (Status (Path Abs Dir) () Item)
constructIfMissing ContentStore
store remoteCache
remoteCacher ContentHash
hash =
  ContentStore
-> m (Status (Path Abs Dir) () Item)
-> m (Status (Path Abs Dir) () Item)
forall (m :: * -> *) a.
MonadUnliftIO m =>
ContentStore -> m a -> m a
withStoreLock ContentStore
store (m (Status (Path Abs Dir) () Item)
 -> m (Status (Path Abs Dir) () Item))
-> m (Status (Path Abs Dir) () Item)
-> m (Status (Path Abs Dir) () Item)
forall a b. (a -> b) -> a -> b
$
    ContentStore -> ContentHash -> m (Status () (Path Abs Dir) Item)
forall (m :: * -> *).
MonadIO m =>
ContentStore -> ContentHash -> m (Status () (Path Abs Dir) Item)
internalQuery ContentStore
store ContentHash
hash m (Status () (Path Abs Dir) Item)
-> (Status () (Path Abs Dir) Item
    -> m (Status (Path Abs Dir) () Item))
-> m (Status (Path Abs Dir) () Item)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Complete Item
item -> Status (Path Abs Dir) () Item -> m (Status (Path Abs Dir) () Item)
forall (m :: * -> *) a. Monad m => a -> m a
return (Status (Path Abs Dir) () Item
 -> m (Status (Path Abs Dir) () Item))
-> Status (Path Abs Dir) () Item
-> m (Status (Path Abs Dir) () Item)
forall a b. (a -> b) -> a -> b
$ Item -> Status (Path Abs Dir) () Item
forall missing pending complete.
complete -> Status missing pending complete
Complete Item
item
      Missing () -> ContentStore
-> m (Status (Path Abs Dir) () Item)
-> m (Status (Path Abs Dir) () Item)
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
ContentStore -> m a -> m a
withWritableStore ContentStore
store (m (Status (Path Abs Dir) () Item)
 -> m (Status (Path Abs Dir) () Item))
-> m (Status (Path Abs Dir) () Item)
-> m (Status (Path Abs Dir) () Item)
forall a b. (a -> b) -> a -> b
$ do
        let Path Abs Dir
destDir :: Path Abs Dir = ContentStore -> ContentHash -> Path Abs Dir
mkItemPath ContentStore
store ContentHash
hash
        remoteCache -> ContentHash -> Path Abs Dir -> m (PullResult ())
forall (m :: * -> *) a.
Cacher m a =>
a -> ContentHash -> Path Abs Dir -> m (PullResult ())
Remote.pull remoteCache
remoteCacher ContentHash
hash Path Abs Dir
destDir m (PullResult ())
-> (PullResult () -> m (Status (Path Abs Dir) () Item))
-> m (Status (Path Abs Dir) () Item)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Remote.PullOK () -> Status (Path Abs Dir) () Item -> m (Status (Path Abs Dir) () Item)
forall (m :: * -> *) a. Monad m => a -> m a
return (Status (Path Abs Dir) () Item
 -> m (Status (Path Abs Dir) () Item))
-> Status (Path Abs Dir) () Item
-> m (Status (Path Abs Dir) () Item)
forall a b. (a -> b) -> a -> b
$ Item -> Status (Path Abs Dir) () Item
forall missing pending complete.
complete -> Status missing pending complete
Complete (ContentHash -> Item
Item ContentHash
hash)
          PullResult ()
Remote.NotInCache ->
            Path Abs Dir -> Status (Path Abs Dir) () Item
forall missing pending complete.
missing -> Status missing pending complete
Missing (Path Abs Dir -> Status (Path Abs Dir) () Item)
-> m (Path Abs Dir) -> m (Status (Path Abs Dir) () Item)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Path Abs Dir) -> m (Path Abs Dir)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ContentStore -> ContentHash -> IO (Path Abs Dir)
internalMarkPending ContentStore
store ContentHash
hash)
          Remote.PullError String
_ ->
            -- TODO: That error should not be silenced
            Path Abs Dir -> Status (Path Abs Dir) () Item
forall missing pending complete.
missing -> Status missing pending complete
Missing (Path Abs Dir -> Status (Path Abs Dir) () Item)
-> m (Path Abs Dir) -> m (Status (Path Abs Dir) () Item)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Path Abs Dir) -> m (Path Abs Dir)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ContentStore -> ContentHash -> IO (Path Abs Dir)
internalMarkPending ContentStore
store ContentHash
hash)
      Pending Path Abs Dir
_ -> Status (Path Abs Dir) () Item -> m (Status (Path Abs Dir) () Item)
forall (m :: * -> *) a. Monad m => a -> m a
return (Status (Path Abs Dir) () Item
 -> m (Status (Path Abs Dir) () Item))
-> Status (Path Abs Dir) () Item
-> m (Status (Path Abs Dir) () Item)
forall a b. (a -> b) -> a -> b
$ () -> Status (Path Abs Dir) () Item
forall missing pending complete.
pending -> Status missing pending complete
Pending ()

-- | Atomically query the state under the given key and mark pending if missing.
-- Execute the given function to construct the item, mark as complete on success
-- and remove on failure. Forcibly removes if an uncaught exception occurs
-- during item construction.
withConstructIfMissing ::
  (MonadIO m, MonadUnliftIO m, MonadMask m, Remote.Cacher m remoteCache) =>
  ContentStore ->
  remoteCache ->
  -- | In case an exception occurs (to log something for instance)
  m () ->
  ContentHash ->
  (Path Abs Dir -> m (Either e a)) ->
  m (Status e () (Maybe a, Item))
withConstructIfMissing :: ContentStore
-> remoteCache
-> m ()
-> ContentHash
-> (Path Abs Dir -> m (Either e a))
-> m (Status e () (Maybe a, Item))
withConstructIfMissing ContentStore
store remoteCache
remoteCacher m ()
ifExc ContentHash
hash Path Abs Dir -> m (Either e a)
f =
  m (Status (Path Abs Dir) () Item)
-> (Status (Path Abs Dir) () Item -> m ())
-> (Status (Path Abs Dir) () Item
    -> m (Status e () (Maybe a, Item)))
-> m (Status e () (Maybe a, Item))
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError
    (ContentStore
-> remoteCache -> ContentHash -> m (Status (Path Abs Dir) () Item)
forall (m :: * -> *) remoteCache.
(MonadIO m, MonadUnliftIO m, MonadMask m, Cacher m remoteCache) =>
ContentStore
-> remoteCache -> ContentHash -> m (Status (Path Abs Dir) () Item)
constructIfMissing ContentStore
store remoteCache
remoteCacher ContentHash
hash)
    ( \Status (Path Abs Dir) () Item
status -> do
        case Status (Path Abs Dir) () Item
status of
          Missing Path Abs Dir
_ -> ContentStore -> ContentHash -> m ()
forall (m :: * -> *).
MonadIO m =>
ContentStore -> ContentHash -> m ()
removeForcibly ContentStore
store ContentHash
hash
          Status (Path Abs Dir) () Item
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        m ()
ifExc
    )
    ( \case
        Pending () -> Status e () (Maybe a, Item) -> m (Status e () (Maybe a, Item))
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Status e () (Maybe a, Item)
forall missing pending complete.
pending -> Status missing pending complete
Pending ())
        Complete Item
item -> Status e () (Maybe a, Item) -> m (Status e () (Maybe a, Item))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe a, Item) -> Status e () (Maybe a, Item)
forall missing pending complete.
complete -> Status missing pending complete
Complete (Maybe a
forall a. Maybe a
Nothing, Item
item))
        Missing Path Abs Dir
fp ->
          Path Abs Dir -> m (Either e a)
f Path Abs Dir
fp m (Either e a)
-> (Either e a -> m (Status e () (Maybe a, Item)))
-> m (Status e () (Maybe a, Item))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left e
e -> do
              ContentStore -> ContentHash -> m ()
forall (m :: * -> *).
MonadIO m =>
ContentStore -> ContentHash -> m ()
removeFailed ContentStore
store ContentHash
hash
              Status e () (Maybe a, Item) -> m (Status e () (Maybe a, Item))
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> Status e () (Maybe a, Item)
forall missing pending complete.
missing -> Status missing pending complete
Missing e
e)
            Right a
x -> do
              Item
item <- ContentStore -> ContentHash -> m Item
forall (m :: * -> *).
MonadIO m =>
ContentStore -> ContentHash -> m Item
markComplete ContentStore
store ContentHash
hash
              PushResult
_ <- remoteCache
-> ContentHash -> Maybe ContentHash -> Path Abs Dir -> m PushResult
forall (m :: * -> *) a.
Cacher m a =>
a
-> ContentHash -> Maybe ContentHash -> Path Abs Dir -> m PushResult
Remote.push remoteCache
remoteCacher (Item -> ContentHash
itemHash Item
item) (ContentHash -> Maybe ContentHash
forall a. a -> Maybe a
Just ContentHash
hash) (ContentStore -> Item -> Path Abs Dir
itemPath ContentStore
store Item
item)
              Status e () (Maybe a, Item) -> m (Status e () (Maybe a, Item))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe a, Item) -> Status e () (Maybe a, Item)
forall missing pending complete.
complete -> Status missing pending complete
Complete (a -> Maybe a
forall a. a -> Maybe a
Just a
x, Item
item))
    )

-- | Mark a non-existent item as pending.
--
-- Creates the build directory and returns its path.
--
-- See also: 'Data.CAS.ContentStore.constructIfMissing'.
markPending :: MonadIO m => ContentStore -> ContentHash -> m (Path Abs Dir)
markPending :: ContentStore -> ContentHash -> m (Path Abs Dir)
markPending ContentStore
store ContentHash
hash =
  IO (Path Abs Dir) -> m (Path Abs Dir)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Path Abs Dir) -> m (Path Abs Dir))
-> (IO (Path Abs Dir) -> IO (Path Abs Dir))
-> IO (Path Abs Dir)
-> m (Path Abs Dir)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentStore -> IO (Path Abs Dir) -> IO (Path Abs Dir)
forall (m :: * -> *) a.
MonadUnliftIO m =>
ContentStore -> m a -> m a
withStoreLock ContentStore
store (IO (Path Abs Dir) -> m (Path Abs Dir))
-> IO (Path Abs Dir) -> m (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$
    ContentStore -> ContentHash -> IO (Status () (Path Abs Dir) Item)
forall (m :: * -> *).
MonadIO m =>
ContentStore -> ContentHash -> m (Status () (Path Abs Dir) Item)
internalQuery ContentStore
store ContentHash
hash IO (Status () (Path Abs Dir) Item)
-> (Status () (Path Abs Dir) Item -> IO (Path Abs Dir))
-> IO (Path Abs Dir)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Complete Item
_ -> StoreError -> IO (Path Abs Dir)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ContentHash -> StoreError
AlreadyComplete ContentHash
hash)
      Pending Path Abs Dir
_ -> StoreError -> IO (Path Abs Dir)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ContentHash -> StoreError
AlreadyPending ContentHash
hash)
      Missing () ->
        ContentStore -> IO (Path Abs Dir) -> IO (Path Abs Dir)
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
ContentStore -> m a -> m a
withWritableStore ContentStore
store (IO (Path Abs Dir) -> IO (Path Abs Dir))
-> IO (Path Abs Dir) -> IO (Path Abs Dir)
forall a b. (a -> b) -> a -> b
$
          ContentStore -> ContentHash -> IO (Path Abs Dir)
internalMarkPending ContentStore
store ContentHash
hash

-- | Mark a pending item as complete.
markComplete :: MonadIO m => ContentStore -> ContentHash -> m Item
markComplete :: ContentStore -> ContentHash -> m Item
markComplete ContentStore
store ContentHash
inHash =
  IO Item -> m Item
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Item -> m Item) -> (IO Item -> IO Item) -> IO Item -> m Item
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentStore -> IO Item -> IO Item
forall (m :: * -> *) a.
MonadUnliftIO m =>
ContentStore -> m a -> m a
withStoreLock ContentStore
store (IO Item -> m Item) -> IO Item -> m Item
forall a b. (a -> b) -> a -> b
$
    ContentStore -> ContentHash -> IO (Status () (Path Abs Dir) Item)
forall (m :: * -> *).
MonadIO m =>
ContentStore -> ContentHash -> m (Status () (Path Abs Dir) Item)
internalQuery ContentStore
store ContentHash
inHash IO (Status () (Path Abs Dir) Item)
-> (Status () (Path Abs Dir) Item -> IO Item) -> IO Item
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Missing () -> StoreError -> IO Item
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ContentHash -> StoreError
NotPending ContentHash
inHash)
      Complete Item
_ -> StoreError -> IO Item
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ContentHash -> StoreError
AlreadyComplete ContentHash
inHash)
      Pending Path Abs Dir
build -> ContentStore -> IO Item -> IO Item
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
ContentStore -> m a -> m a
withWritableStore ContentStore
store (IO Item -> IO Item) -> IO Item -> IO Item
forall a b. (a -> b) -> a -> b
$
        IO Item -> IO Item
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Item -> IO Item) -> IO Item -> IO Item
forall a b. (a -> b) -> a -> b
$ do
          do
            let metadataDir :: Path Abs Dir
metadataDir = ContentStore -> ContentHash -> Path Abs Dir
mkMetadataDirPath ContentStore
store ContentHash
inHash
            Bool
exists <- Path Abs Dir -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
metadataDir
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
              Path Abs Dir -> IO ()
unsetWritableRecursively Path Abs Dir
metadataDir
          -- XXX: Hashing large data can take some time,
          --   could we avoid locking the store for all that time?
          ContentHash
outHash <- DirectoryContent -> IO ContentHash
forall (m :: * -> *) a. ContentHashable m a => a -> m ContentHash
contentHash (Path Abs Dir -> DirectoryContent
DirectoryContent Path Abs Dir
build)
          let out :: Path Abs Dir
out = ContentStore -> ContentHash -> Path Abs Dir
mkItemPath ContentStore
store ContentHash
outHash
              link' :: Path Abs Dir
link' = ContentStore -> ContentHash -> Path Abs Dir
mkCompletePath ContentStore
store ContentHash
inHash
          Path Abs Dir -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
out IO Bool -> (Bool -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
True -> String -> IO ()
removePathForcibly (Path Abs Dir -> String
fromAbsDir Path Abs Dir
build)
            Bool
False -> do
              Path Abs Dir -> Path Abs Dir -> IO ()
forall (m :: * -> *) b0 b1.
MonadIO m =>
Path b0 Dir -> Path b1 Dir -> m ()
renameDir Path Abs Dir
build Path Abs Dir
out
              Path Abs Dir -> IO ()
unsetWritableRecursively Path Abs Dir
out
          Path Rel Dir
rel <- Path Abs Dir -> Path Abs Dir -> IO (RelPath (Path Abs Dir))
forall path (m :: * -> *).
(AnyPath path, MonadThrow m) =>
Path Abs Dir -> path -> m (RelPath path)
makeRelative (Path Abs Dir -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs Dir
link') Path Abs Dir
out
          let from' :: String
from' = ShowS
dropTrailingPathSeparator ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> String
fromAbsDir Path Abs Dir
link'
              to' :: String
to' = ShowS
dropTrailingPathSeparator ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Path Rel Dir -> String
fromRelDir Path Rel Dir
rel
          String -> String -> IO ()
createSymbolicLink String
to' String
from'
          ContentStore -> ContentHash -> Item -> IO ()
addBackReference ContentStore
store ContentHash
inHash (ContentHash -> Item
Item ContentHash
outHash)
          Item -> IO Item
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Item -> IO Item) -> Item -> IO Item
forall a b. (a -> b) -> a -> b
$! ContentHash -> Item
Item ContentHash
outHash

-- | Remove a pending item.
--
-- It is the callers responsibility to ensure that no other threads or processes
-- will attempt to access the item's contents afterwards.
removeFailed :: MonadIO m => ContentStore -> ContentHash -> m ()
removeFailed :: ContentStore -> ContentHash -> m ()
removeFailed ContentStore
store ContentHash
hash =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (IO () -> IO ()) -> IO () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentStore -> IO () -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
ContentStore -> m a -> m a
withStoreLock ContentStore
store (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    ContentStore -> ContentHash -> IO (Status () (Path Abs Dir) Item)
forall (m :: * -> *).
MonadIO m =>
ContentStore -> ContentHash -> m (Status () (Path Abs Dir) Item)
internalQuery ContentStore
store ContentHash
hash IO (Status () (Path Abs Dir) Item)
-> (Status () (Path Abs Dir) Item -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Missing () -> StoreError -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ContentHash -> StoreError
NotPending ContentHash
hash)
      Complete Item
_ -> StoreError -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (ContentHash -> StoreError
AlreadyComplete ContentHash
hash)
      Pending Path Abs Dir
build ->
        ContentStore -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
ContentStore -> m a -> m a
withWritableStore ContentStore
store (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          String -> IO ()
removePathForcibly (Path Abs Dir -> String
fromAbsDir Path Abs Dir
build)

-- | Remove a key association independent of the corresponding item state.
-- Do nothing if no item exists under the given key.
--
-- It is the callers responsibility to ensure that no other threads or processes
-- will attempt to access the contents afterwards.
--
-- Note, this will leave an orphan item behind if no other keys point to it.
-- There is no garbage collection mechanism in place at the moment.
removeForcibly :: MonadIO m => ContentStore -> ContentHash -> m ()
removeForcibly :: ContentStore -> ContentHash -> m ()
removeForcibly ContentStore
store ContentHash
hash =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (IO () -> IO ()) -> IO () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentStore -> IO () -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
ContentStore -> m a -> m a
withStoreLock ContentStore
store (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    ContentStore -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
ContentStore -> m a -> m a
withWritableStore ContentStore
store (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      ContentStore -> ContentHash -> IO (Status () (Path Abs Dir) Item)
forall (m :: * -> *).
MonadIO m =>
ContentStore -> ContentHash -> m (Status () (Path Abs Dir) Item)
internalQuery ContentStore
store ContentHash
hash IO (Status () (Path Abs Dir) Item)
-> (Status () (Path Abs Dir) Item -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Missing () -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Pending Path Abs Dir
build -> IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removePathForcibly (Path Abs Dir -> String
fromAbsDir Path Abs Dir
build)
        Complete Item
_out ->
          IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> IO ()
removePathForcibly (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
              ShowS
dropTrailingPathSeparator ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
                Path Abs Dir -> String
fromAbsDir (Path Abs Dir -> String) -> Path Abs Dir -> String
forall a b. (a -> b) -> a -> b
$
                  ContentStore -> ContentHash -> Path Abs Dir
mkCompletePath ContentStore
store ContentHash
hash

-- XXX: This will leave orphan store items behind.
--   Add GC in some form.

-- | Remove a completed item in the store.
-- Do nothing if not completed.
--
-- It is the callers responsibility to ensure that no other threads or processes
-- will attempt to access the contents afterwards.
--
-- Note, this will leave keys pointing to that item dangling.
-- There is no garbage collection mechanism in place at the moment.
removeItemForcibly :: MonadIO m => ContentStore -> Item -> m ()
removeItemForcibly :: ContentStore -> Item -> m ()
removeItemForcibly ContentStore
store Item
item =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (IO () -> IO ()) -> IO () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentStore -> IO () -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
ContentStore -> m a -> m a
withStoreLock ContentStore
store (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    ContentStore -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
ContentStore -> m a -> m a
withWritableStore ContentStore
store (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> IO ()
removePathForcibly (Path Abs Dir -> String
fromAbsDir (Path Abs Dir -> String) -> Path Abs Dir -> String
forall a b. (a -> b) -> a -> b
$ ContentStore -> Item -> Path Abs Dir
itemPath ContentStore
store Item
item)

-- XXX: Remove dangling links.
--   Add back-references in some form.

-- We need this orphan instance here so cas-hash doesn't depend on sqlite
instance SQL.FromField ContentHash where
  fromField :: FieldParser ContentHash
fromField Field
f = do
    ByteString
bs <- FieldParser ByteString
forall a. FromField a => FieldParser a
SQL.fromField Field
f
    case ByteString -> Maybe ContentHash
decodeHash ByteString
bs of
      Just ContentHash
h -> ContentHash -> Ok ContentHash
forall (f :: * -> *) a. Applicative f => a -> f a
pure ContentHash
h
      Maybe ContentHash
Nothing -> Ok ContentHash
forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance SQL.ToField ContentHash where
  toField :: ContentHash -> SQLData
toField = ByteString -> SQLData
forall a. ToField a => a -> SQLData
SQL.toField (ByteString -> SQLData)
-> (ContentHash -> ByteString) -> ContentHash -> SQLData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentHash -> ByteString
encodeHash

-- | Link the given alias to the given item.
-- If the alias existed before it is overwritten.
assignAlias :: MonadIO m => ContentStore -> Alias -> Item -> m ()
assignAlias :: ContentStore -> Alias -> Item -> m ()
assignAlias ContentStore
store Alias
alias Item
item =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (IO () -> IO ()) -> IO () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentStore -> IO () -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
ContentStore -> m a -> m a
withStoreLock ContentStore
store (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    ContentStore -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
ContentStore -> m a -> m a
withWritableStore ContentStore
store (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ContentHash
hash <- Alias -> IO ContentHash
forall (m :: * -> *) a. ContentHashable m a => a -> m ContentHash
contentHash Alias
alias
      Connection -> Query -> [NamedParam] -> IO ()
SQL.executeNamed
        (ContentStore -> Connection
storeDb ContentStore
store)
        Query
"INSERT OR REPLACE INTO\
        \  aliases\
        \ VALUES\
        \  (:hash, :dest, :name)"
        [ Text
":hash" Text -> ContentHash -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
SQL.:= ContentHash
hash,
          Text
":dest" Text -> ContentHash -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
SQL.:= Item -> ContentHash
itemHash Item
item,
          Text
":name" Text -> Alias -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
SQL.:= Alias
alias
        ]

-- | Lookup an item under the given alias.
-- Returns 'Nothing' if the alias does not exist.
lookupAlias :: MonadIO m => ContentStore -> Alias -> m (Maybe Item)
lookupAlias :: ContentStore -> Alias -> m (Maybe Item)
lookupAlias ContentStore
store Alias
alias =
  IO (Maybe Item) -> m (Maybe Item)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Item) -> m (Maybe Item))
-> (IO (Maybe Item) -> IO (Maybe Item))
-> IO (Maybe Item)
-> m (Maybe Item)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentStore -> IO (Maybe Item) -> IO (Maybe Item)
forall (m :: * -> *) a.
MonadUnliftIO m =>
ContentStore -> m a -> m a
withStoreLock ContentStore
store (IO (Maybe Item) -> m (Maybe Item))
-> IO (Maybe Item) -> m (Maybe Item)
forall a b. (a -> b) -> a -> b
$ do
    ContentHash
hash <- Alias -> IO ContentHash
forall (m :: * -> *) a. ContentHashable m a => a -> m ContentHash
contentHash Alias
alias
    [Only ContentHash]
r <-
      Connection -> Query -> [NamedParam] -> IO [Only ContentHash]
forall r.
FromRow r =>
Connection -> Query -> [NamedParam] -> IO [r]
SQL.queryNamed
        (ContentStore -> Connection
storeDb ContentStore
store)
        Query
"SELECT dest FROM aliases\
        \ WHERE\
        \  hash = :hash"
        [Text
":hash" Text -> ContentHash -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
SQL.:= ContentHash
hash]
    Maybe Item -> IO (Maybe Item)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Item -> IO (Maybe Item)) -> Maybe Item -> IO (Maybe Item)
forall a b. (a -> b) -> a -> b
$! [Item] -> Maybe Item
forall a. [a] -> Maybe a
listToMaybe ([Item] -> Maybe Item) -> [Item] -> Maybe Item
forall a b. (a -> b) -> a -> b
$ ContentHash -> Item
Item (ContentHash -> Item)
-> (Only ContentHash -> ContentHash) -> Only ContentHash -> Item
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only ContentHash -> ContentHash
forall a. Only a -> a
SQL.fromOnly (Only ContentHash -> Item) -> [Only ContentHash] -> [Item]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Only ContentHash]
r

-- | Remove the given alias.
removeAlias :: MonadIO m => ContentStore -> Alias -> m ()
removeAlias :: ContentStore -> Alias -> m ()
removeAlias ContentStore
store Alias
alias =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (IO () -> IO ()) -> IO () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentStore -> IO () -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
ContentStore -> m a -> m a
withStoreLock ContentStore
store (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    ContentStore -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
ContentStore -> m a -> m a
withWritableStore ContentStore
store (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      ContentHash
hash <- Alias -> IO ContentHash
forall (m :: * -> *) a. ContentHashable m a => a -> m ContentHash
contentHash Alias
alias
      Connection -> Query -> [NamedParam] -> IO ()
SQL.executeNamed
        (ContentStore -> Connection
storeDb ContentStore
store)
        Query
"DELETE FROM aliases\
        \ WHERE\
        \  hash = :hash"
        [Text
":hash" Text -> ContentHash -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
SQL.:= ContentHash
hash]

-- | List all aliases and the respective items.
listAliases :: MonadIO m => ContentStore -> m [(Alias, Item, ContentHash)]
listAliases :: ContentStore -> m [(Alias, Item, ContentHash)]
listAliases ContentStore
store =
  IO [(Alias, Item, ContentHash)] -> m [(Alias, Item, ContentHash)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Alias, Item, ContentHash)] -> m [(Alias, Item, ContentHash)])
-> (IO [(Alias, Item, ContentHash)]
    -> IO [(Alias, Item, ContentHash)])
-> IO [(Alias, Item, ContentHash)]
-> m [(Alias, Item, ContentHash)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentStore
-> IO [(Alias, Item, ContentHash)]
-> IO [(Alias, Item, ContentHash)]
forall (m :: * -> *) a.
MonadUnliftIO m =>
ContentStore -> m a -> m a
withStoreLock ContentStore
store (IO [(Alias, Item, ContentHash)] -> m [(Alias, Item, ContentHash)])
-> IO [(Alias, Item, ContentHash)]
-> m [(Alias, Item, ContentHash)]
forall a b. (a -> b) -> a -> b
$
    ((Alias, ContentHash, ContentHash) -> (Alias, Item, ContentHash))
-> [(Alias, ContentHash, ContentHash)]
-> [(Alias, Item, ContentHash)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Alias
a,ContentHash
b,ContentHash
c) -> (Alias
a, ContentHash -> Item
Item ContentHash
b, ContentHash
c)) ([(Alias, ContentHash, ContentHash)]
 -> [(Alias, Item, ContentHash)])
-> IO [(Alias, ContentHash, ContentHash)]
-> IO [(Alias, Item, ContentHash)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      Connection -> Query -> IO [(Alias, ContentHash, ContentHash)]
forall r. FromRow r => Connection -> Query -> IO [r]
SQL.query_
        (ContentStore -> Connection
storeDb ContentStore
store)
        Query
"SELECT name, dest, hash FROM aliases"

-- | Get all hashes that resulted in the given item.
getBackReferences :: MonadIO m => ContentStore -> Item -> m [ContentHash]
getBackReferences :: ContentStore -> Item -> m [ContentHash]
getBackReferences ContentStore
store (Item ContentHash
outHash) =
  IO [ContentHash] -> m [ContentHash]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ContentHash] -> m [ContentHash])
-> (IO [ContentHash] -> IO [ContentHash])
-> IO [ContentHash]
-> m [ContentHash]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentStore -> IO [ContentHash] -> IO [ContentHash]
forall (m :: * -> *) a.
MonadUnliftIO m =>
ContentStore -> m a -> m a
withStoreLock ContentStore
store (IO [ContentHash] -> m [ContentHash])
-> IO [ContentHash] -> m [ContentHash]
forall a b. (a -> b) -> a -> b
$
    (Only ContentHash -> ContentHash)
-> [Only ContentHash] -> [ContentHash]
forall a b. (a -> b) -> [a] -> [b]
map Only ContentHash -> ContentHash
forall a. Only a -> a
SQL.fromOnly
      ([Only ContentHash] -> [ContentHash])
-> IO [Only ContentHash] -> IO [ContentHash]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Query -> [NamedParam] -> IO [Only ContentHash]
forall r.
FromRow r =>
Connection -> Query -> [NamedParam] -> IO [r]
SQL.queryNamed
        (ContentStore -> Connection
storeDb ContentStore
store)
        Query
"SELECT hash FROM backrefs\
        \ WHERE\
        \  dest = :out"
        [Text
":out" Text -> ContentHash -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
SQL.:= ContentHash
outHash]

-- | Define the input items to a subtree.
setInputs :: MonadIO m => ContentStore -> ContentHash -> [Item] -> m ()
setInputs :: ContentStore -> ContentHash -> [Item] -> m ()
setInputs ContentStore
store ContentHash
hash [Item]
items =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    ContentStore -> IO () -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
ContentStore -> m a -> m a
withStoreLock ContentStore
store (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      ContentStore -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
ContentStore -> m a -> m a
withWritableStore ContentStore
store (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        ContentStore -> ContentHash -> IO (Status () (Path Abs Dir) Item)
forall (m :: * -> *).
MonadIO m =>
ContentStore -> ContentHash -> m (Status () (Path Abs Dir) Item)
internalQuery ContentStore
store ContentHash
hash IO (Status () (Path Abs Dir) Item)
-> (Status () (Path Abs Dir) Item -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Pending Path Abs Dir
_ -> [Item] -> (Item -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Item]
items ((Item -> IO ()) -> IO ()) -> (Item -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Item ContentHash
input) ->
            Connection -> Query -> [NamedParam] -> IO ()
SQL.executeNamed
              (ContentStore -> Connection
storeDb ContentStore
store)
              Query
"INSERT OR REPLACE INTO\
              \  inputs (hash, input)\
              \ VALUES\
              \  (:hash, :input)"
              [ Text
":hash" Text -> ContentHash -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
SQL.:= ContentHash
hash,
                Text
":input" Text -> ContentHash -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
SQL.:= ContentHash
input
              ]
          Status () (Path Abs Dir) Item
_ -> StoreError -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (StoreError -> IO ()) -> StoreError -> IO ()
forall a b. (a -> b) -> a -> b
$ ContentHash -> StoreError
NotPending ContentHash
hash

-- | Get the input items to a subtree if any were defined.
getInputs :: MonadIO m => ContentStore -> ContentHash -> m [Item]
getInputs :: ContentStore -> ContentHash -> m [Item]
getInputs ContentStore
store ContentHash
hash =
  IO [Item] -> m [Item]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Item] -> m [Item])
-> (IO [Item] -> IO [Item]) -> IO [Item] -> m [Item]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentStore -> IO [Item] -> IO [Item]
forall (m :: * -> *) a.
MonadUnliftIO m =>
ContentStore -> m a -> m a
withStoreLock ContentStore
store (IO [Item] -> m [Item]) -> IO [Item] -> m [Item]
forall a b. (a -> b) -> a -> b
$
    (Only ContentHash -> Item) -> [Only ContentHash] -> [Item]
forall a b. (a -> b) -> [a] -> [b]
map (ContentHash -> Item
Item (ContentHash -> Item)
-> (Only ContentHash -> ContentHash) -> Only ContentHash -> Item
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Only ContentHash -> ContentHash
forall a. Only a -> a
SQL.fromOnly)
      ([Only ContentHash] -> [Item])
-> IO [Only ContentHash] -> IO [Item]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Connection -> Query -> [NamedParam] -> IO [Only ContentHash]
forall r.
FromRow r =>
Connection -> Query -> [NamedParam] -> IO [r]
SQL.queryNamed
        (ContentStore -> Connection
storeDb ContentStore
store)
        Query
"SELECT input FROM inputs\
        \ WHERE\
        \  hash = :hash"
        [Text
":hash" Text -> ContentHash -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
SQL.:= ContentHash
hash]

-- | Set a metadata entry on an item.
setMetadata ::
  (SQL.ToField k, SQL.ToField v, MonadIO m) =>
  ContentStore ->
  ContentHash ->
  k ->
  v ->
  m ()
setMetadata :: ContentStore -> ContentHash -> k -> v -> m ()
setMetadata ContentStore
store ContentHash
hash k
k v
v =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    ContentStore -> IO () -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
ContentStore -> m a -> m a
withStoreLock ContentStore
store (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      ContentStore -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
ContentStore -> m a -> m a
withWritableStore ContentStore
store (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Connection -> Query -> [NamedParam] -> IO ()
SQL.executeNamed
          (ContentStore -> Connection
storeDb ContentStore
store)
          Query
"INSERT OR REPLACE INTO\
          \  metadata (hash, key, value)\
          \ VALUES\
          \  (:hash, :key, :value)"
          [ Text
":hash" Text -> ContentHash -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
SQL.:= ContentHash
hash,
            Text
":key" Text -> k -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
SQL.:= k
k,
            Text
":value" Text -> v -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
SQL.:= v
v
          ]

-- | Retrieve a metadata entry on an item, or 'Nothing' if missing.
getMetadata ::
  (SQL.ToField k, SQL.FromField v, MonadIO m) =>
  ContentStore ->
  ContentHash ->
  k ->
  m (Maybe v)
getMetadata :: ContentStore -> ContentHash -> k -> m (Maybe v)
getMetadata ContentStore
store ContentHash
hash k
k = IO (Maybe v) -> m (Maybe v)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe v) -> m (Maybe v))
-> (IO (Maybe v) -> IO (Maybe v)) -> IO (Maybe v) -> m (Maybe v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentStore -> IO (Maybe v) -> IO (Maybe v)
forall (m :: * -> *) a.
MonadUnliftIO m =>
ContentStore -> m a -> m a
withStoreLock ContentStore
store (IO (Maybe v) -> m (Maybe v)) -> IO (Maybe v) -> m (Maybe v)
forall a b. (a -> b) -> a -> b
$ do
  [[v]]
r <-
    Connection -> Query -> [NamedParam] -> IO [[v]]
forall r.
FromRow r =>
Connection -> Query -> [NamedParam] -> IO [r]
SQL.queryNamed
      (ContentStore -> Connection
storeDb ContentStore
store)
      Query
"SELECT value FROM metadata\
      \ WHERE\
      \  (hash = :hash AND key = :key)"
      [ Text
":hash" Text -> ContentHash -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
SQL.:= ContentHash
hash,
        Text
":key" Text -> k -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
SQL.:= k
k
      ]
  case [[v]]
r of
    [] -> Maybe v -> IO (Maybe v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe v
forall a. Maybe a
Nothing
    [[v
v]] -> Maybe v -> IO (Maybe v)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe v -> IO (Maybe v)) -> Maybe v -> IO (Maybe v)
forall a b. (a -> b) -> a -> b
$ v -> Maybe v
forall a. a -> Maybe a
Just v
v
    [[v]]
_ -> StoreError -> IO (Maybe v)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (StoreError -> IO (Maybe v)) -> StoreError -> IO (Maybe v)
forall a b. (a -> b) -> a -> b
$ ContentHash -> SQLData -> StoreError
MalformedMetadataEntry ContentHash
hash (k -> SQLData
forall a. ToField a => a -> SQLData
SQL.toField k
k)

-- | Create and open a new metadata file on a pending item in write mode.
createMetadataFile ::
  MonadIO m =>
  ContentStore ->
  ContentHash ->
  Path Rel File ->
  m (Path Abs File, Handle)
createMetadataFile :: ContentStore
-> ContentHash -> Path Rel File -> m (Path Abs File, Handle)
createMetadataFile ContentStore
store ContentHash
hash Path Rel File
file =
  IO (Path Abs File, Handle) -> m (Path Abs File, Handle)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Path Abs File, Handle) -> m (Path Abs File, Handle))
-> (IO (Path Abs File, Handle) -> IO (Path Abs File, Handle))
-> IO (Path Abs File, Handle)
-> m (Path Abs File, Handle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentStore
-> IO (Path Abs File, Handle) -> IO (Path Abs File, Handle)
forall (m :: * -> *) a.
MonadUnliftIO m =>
ContentStore -> m a -> m a
withStoreLock ContentStore
store (IO (Path Abs File, Handle) -> m (Path Abs File, Handle))
-> IO (Path Abs File, Handle) -> m (Path Abs File, Handle)
forall a b. (a -> b) -> a -> b
$
    ContentStore -> ContentHash -> IO (Status () (Path Abs Dir) Item)
forall (m :: * -> *).
MonadIO m =>
ContentStore -> ContentHash -> m (Status () (Path Abs Dir) Item)
internalQuery ContentStore
store ContentHash
hash IO (Status () (Path Abs Dir) Item)
-> (Status () (Path Abs Dir) Item -> IO (Path Abs File, Handle))
-> IO (Path Abs File, Handle)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Pending Path Abs Dir
_ -> do
        let path :: Path Abs File
path = ContentStore -> ContentHash -> Path Rel File -> Path Abs File
mkMetadataFilePath ContentStore
store ContentHash
hash Path Rel File
file
        Bool -> Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Bool -> Path b Dir -> m ()
createDirIfMissing Bool
True (Path Abs File -> Path Abs Dir
forall b t. Path b t -> Path b Dir
parent Path Abs File
path)
        Handle
hndl <- String -> IOMode -> IO Handle
openFile (Path Abs File -> String
fromAbsFile Path Abs File
path) IOMode
WriteMode
        (Path Abs File, Handle) -> IO (Path Abs File, Handle)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Path Abs File
path, Handle
hndl)
      Status () (Path Abs Dir) Item
_ -> StoreError -> IO (Path Abs File, Handle)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (StoreError -> IO (Path Abs File, Handle))
-> StoreError -> IO (Path Abs File, Handle)
forall a b. (a -> b) -> a -> b
$ ContentHash -> StoreError
NotPending ContentHash
hash

-- | Return the path to a metadata file if it exists.
getMetadataFile ::
  MonadIO m =>
  ContentStore ->
  ContentHash ->
  Path Rel File ->
  m (Maybe (Path Abs File))
getMetadataFile :: ContentStore
-> ContentHash -> Path Rel File -> m (Maybe (Path Abs File))
getMetadataFile ContentStore
store ContentHash
hash Path Rel File
file = IO (Maybe (Path Abs File)) -> m (Maybe (Path Abs File))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Path Abs File)) -> m (Maybe (Path Abs File)))
-> (IO (Maybe (Path Abs File)) -> IO (Maybe (Path Abs File)))
-> IO (Maybe (Path Abs File))
-> m (Maybe (Path Abs File))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentStore
-> IO (Maybe (Path Abs File)) -> IO (Maybe (Path Abs File))
forall (m :: * -> *) a.
MonadUnliftIO m =>
ContentStore -> m a -> m a
withStoreLock ContentStore
store (IO (Maybe (Path Abs File)) -> m (Maybe (Path Abs File)))
-> IO (Maybe (Path Abs File)) -> m (Maybe (Path Abs File))
forall a b. (a -> b) -> a -> b
$ do
  let path :: Path Abs File
path = ContentStore -> ContentHash -> Path Rel File -> Path Abs File
mkMetadataFilePath ContentStore
store ContentHash
hash Path Rel File
file
  Bool
exists <- Path Abs File -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
doesFileExist Path Abs File
path
  if Bool
exists
    then Maybe (Path Abs File) -> IO (Maybe (Path Abs File))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Path Abs File) -> IO (Maybe (Path Abs File)))
-> Maybe (Path Abs File) -> IO (Maybe (Path Abs File))
forall a b. (a -> b) -> a -> b
$ Path Abs File -> Maybe (Path Abs File)
forall a. a -> Maybe a
Just Path Abs File
path
    else Maybe (Path Abs File) -> IO (Maybe (Path Abs File))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Path Abs File)
forall a. Maybe a
Nothing

----------------------------------------------------------------------
-- Internals

lockPath :: Path Abs Dir -> Path Abs Dir
lockPath :: Path Abs Dir -> Path Abs Dir
lockPath = (Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> [reldir|lock|])

dbPath :: Path Abs Dir -> Path Abs File
dbPath :: Path Abs Dir -> Path Abs File
dbPath = (Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> [relfile|metadata.db|])

metadataPath :: Path Abs Dir -> Path Abs Dir
metadataPath :: Path Abs Dir -> Path Abs Dir
metadataPath = (Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> [reldir|metadata|])

-- | Holds a lock on the global 'MVar' and on the global lock file
-- for the duration of the given action.
withStoreLock :: MonadUnliftIO m => ContentStore -> m a -> m a
withStoreLock :: ContentStore -> m a -> m a
withStoreLock ContentStore
store = Lock -> m a -> m a
forall (m :: * -> *) a. MonadUnliftIO m => Lock -> m a -> m a
withLock (ContentStore -> Lock
storeLock ContentStore
store)

prefixHashPath :: C8.ByteString -> ContentHash -> Path Rel Dir
prefixHashPath :: ByteString -> ContentHash -> Path Rel Dir
prefixHashPath ByteString
pref ContentHash
hash
  | Just Path Rel Dir
dir <- String -> Maybe (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
Path.parseRelDir (String -> Maybe (Path Rel Dir)) -> String -> Maybe (Path Rel Dir)
forall a b. (a -> b) -> a -> b
$ ByteString -> String
C8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ ByteString
pref ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ContentHash -> ByteString
encodeHash ContentHash
hash =
    Path Rel Dir
dir
  | Bool
otherwise =
    String -> Path Rel Dir
forall a. HasCallStack => String -> a
error
      String
"[Data.CAS.ContentStore.prefixHashPath] \
      \Failed to construct hash path."

pendingPrefix, completePrefix, hashPrefix, itemPrefix :: IsString s => s
pendingPrefix :: s
pendingPrefix = s
"pending-"
completePrefix :: s
completePrefix = s
"complete-"
hashPrefix :: s
hashPrefix = s
"hash-"
itemPrefix :: s
itemPrefix = s
"item-"

-- | Return the full build path for the given input hash.
mkPendingPath :: ContentStore -> ContentHash -> Path Abs Dir
mkPendingPath :: ContentStore -> ContentHash -> Path Abs Dir
mkPendingPath ContentStore {Path Abs Dir
storeRoot :: Path Abs Dir
storeRoot :: ContentStore -> Path Abs Dir
storeRoot} ContentHash
hash =
  Path Abs Dir
storeRoot Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> ByteString -> ContentHash -> Path Rel Dir
prefixHashPath ByteString
forall s. IsString s => s
pendingPrefix ContentHash
hash

-- | Return the full link path for the given input hash.
mkCompletePath :: ContentStore -> ContentHash -> Path Abs Dir
mkCompletePath :: ContentStore -> ContentHash -> Path Abs Dir
mkCompletePath ContentStore {Path Abs Dir
storeRoot :: Path Abs Dir
storeRoot :: ContentStore -> Path Abs Dir
storeRoot} ContentHash
hash =
  Path Abs Dir
storeRoot Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> ByteString -> ContentHash -> Path Rel Dir
prefixHashPath ByteString
forall s. IsString s => s
completePrefix ContentHash
hash

-- | Return the full store path to the given output hash.
mkItemPath :: ContentStore -> ContentHash -> Path Abs Dir
mkItemPath :: ContentStore -> ContentHash -> Path Abs Dir
mkItemPath ContentStore {Path Abs Dir
storeRoot :: Path Abs Dir
storeRoot :: ContentStore -> Path Abs Dir
storeRoot} ContentHash
hash =
  Path Abs Dir
storeRoot Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> ByteString -> ContentHash -> Path Rel Dir
prefixHashPath ByteString
forall s. IsString s => s
itemPrefix ContentHash
hash

-- | Return the full store path to the given metadata directory.
mkMetadataDirPath :: ContentStore -> ContentHash -> Path Abs Dir
mkMetadataDirPath :: ContentStore -> ContentHash -> Path Abs Dir
mkMetadataDirPath ContentStore {Path Abs Dir
storeRoot :: Path Abs Dir
storeRoot :: ContentStore -> Path Abs Dir
storeRoot} ContentHash
hash =
  Path Abs Dir -> Path Abs Dir
metadataPath Path Abs Dir
storeRoot Path Abs Dir -> Path Rel Dir -> Path Abs Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> ByteString -> ContentHash -> Path Rel Dir
prefixHashPath ByteString
forall s. IsString s => s
hashPrefix ContentHash
hash

-- | Return the full store path to the given metadata file.
mkMetadataFilePath ::
  ContentStore -> ContentHash -> Path Rel File -> Path Abs File
mkMetadataFilePath :: ContentStore -> ContentHash -> Path Rel File -> Path Abs File
mkMetadataFilePath ContentStore
store ContentHash
hash Path Rel File
file =
  ContentStore -> ContentHash -> Path Abs Dir
mkMetadataDirPath ContentStore
store ContentHash
hash Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
file

-- | Query the state under the given key without taking a lock.
internalQuery ::
  MonadIO m =>
  ContentStore ->
  ContentHash ->
  m (Status () (Path Abs Dir) Item)
internalQuery :: ContentStore -> ContentHash -> m (Status () (Path Abs Dir) Item)
internalQuery ContentStore
store ContentHash
inHash = IO (Status () (Path Abs Dir) Item)
-> m (Status () (Path Abs Dir) Item)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Status () (Path Abs Dir) Item)
 -> m (Status () (Path Abs Dir) Item))
-> IO (Status () (Path Abs Dir) Item)
-> m (Status () (Path Abs Dir) Item)
forall a b. (a -> b) -> a -> b
$ do
  let build :: Path Abs Dir
build = ContentStore -> ContentHash -> Path Abs Dir
mkPendingPath ContentStore
store ContentHash
inHash
      link' :: Path Abs Dir
link' = ContentStore -> ContentHash -> Path Abs Dir
mkCompletePath ContentStore
store ContentHash
inHash
  Bool
buildExists <- Path Abs Dir -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
build
  if Bool
buildExists
    then Status () (Path Abs Dir) Item -> IO (Status () (Path Abs Dir) Item)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Status () (Path Abs Dir) Item
 -> IO (Status () (Path Abs Dir) Item))
-> Status () (Path Abs Dir) Item
-> IO (Status () (Path Abs Dir) Item)
forall a b. (a -> b) -> a -> b
$! Path Abs Dir -> Status () (Path Abs Dir) Item
forall missing pending complete.
pending -> Status missing pending complete
Pending Path Abs Dir
build
    else do
      Bool
linkExists <- Path Abs Dir -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
link'
      if Bool
linkExists
        then do
          String
out <-
            String -> IO String
readSymbolicLink
              (ShowS
dropTrailingPathSeparator ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Path Abs Dir -> String
fromAbsDir Path Abs Dir
link')
          case String -> Maybe ContentHash
pathToHash (String -> Maybe ContentHash) -> Maybe String -> Maybe ContentHash
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
forall s. IsString s => s
itemPrefix String
out of
            Maybe ContentHash
Nothing -> StoreError -> IO (Status () (Path Abs Dir) Item)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (StoreError -> IO (Status () (Path Abs Dir) Item))
-> StoreError -> IO (Status () (Path Abs Dir) Item)
forall a b. (a -> b) -> a -> b
$ ContentHash -> String -> StoreError
CorruptedLink ContentHash
inHash String
out
            Just ContentHash
outHash -> Status () (Path Abs Dir) Item -> IO (Status () (Path Abs Dir) Item)
forall (m :: * -> *) a. Monad m => a -> m a
return (Status () (Path Abs Dir) Item
 -> IO (Status () (Path Abs Dir) Item))
-> Status () (Path Abs Dir) Item
-> IO (Status () (Path Abs Dir) Item)
forall a b. (a -> b) -> a -> b
$ Item -> Status () (Path Abs Dir) Item
forall missing pending complete.
complete -> Status missing pending complete
Complete (ContentHash -> Item
Item ContentHash
outHash)
        else Status () (Path Abs Dir) Item -> IO (Status () (Path Abs Dir) Item)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Status () (Path Abs Dir) Item
 -> IO (Status () (Path Abs Dir) Item))
-> Status () (Path Abs Dir) Item
-> IO (Status () (Path Abs Dir) Item)
forall a b. (a -> b) -> a -> b
$! () -> Status () (Path Abs Dir) Item
forall missing pending complete.
missing -> Status missing pending complete
Missing ()

-- | Create the build directory for the given input hash
--   and make the metadata directory writable if it exists.
internalMarkPending :: ContentStore -> ContentHash -> IO (Path Abs Dir)
internalMarkPending :: ContentStore -> ContentHash -> IO (Path Abs Dir)
internalMarkPending ContentStore
store ContentHash
hash = do
  let dir :: Path Abs Dir
dir = ContentStore -> ContentHash -> Path Abs Dir
mkPendingPath ContentStore
store ContentHash
hash
  Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
createDir Path Abs Dir
dir
  Path Abs Dir -> IO ()
setDirWritable Path Abs Dir
dir
  let metadataDir :: Path Abs Dir
metadataDir = ContentStore -> ContentHash -> Path Abs Dir
mkMetadataDirPath ContentStore
store ContentHash
hash
  Bool
metadirExists <- Path Abs Dir -> IO Bool
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m Bool
doesDirExist Path Abs Dir
metadataDir
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
metadirExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Path Abs Dir -> IO ()
setWritableRecursively Path Abs Dir
metadataDir
  Path Abs Dir -> IO (Path Abs Dir)
forall (m :: * -> *) a. Monad m => a -> m a
return Path Abs Dir
dir

-- | Watch the build directory of the pending item under the given key.
-- The returned 'Async' completes after the item is completed or failed.
internalWatchPending ::
  ContentStore ->
  ContentHash ->
  IO (Async Update)
internalWatchPending :: ContentStore -> ContentHash -> IO (Async Update)
internalWatchPending ContentStore
store ContentHash
hash = do
  let build :: Path Abs Dir
build = ContentStore -> ContentHash -> Path Abs Dir
mkPendingPath ContentStore
store ContentHash
hash
  -- Add an inotify/kqueue watch and give a signal on relevant events.
  let notifier :: Notifier
notifier = ContentStore -> Notifier
storeNotifier ContentStore
store
  MVar ()
signal <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
  -- Signal the listener. If the 'MVar' is full,
  -- the listener didn't handle earlier signals, yet.
  let giveSignal :: IO ()
giveSignal = IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar ()
signal ()
  Watch
watch <- Notifier -> String -> IO () -> IO Watch
addDirWatch Notifier
notifier (Path Abs Dir -> String
fromAbsDir Path Abs Dir
build) IO ()
giveSignal
  -- Additionally, poll on regular intervals.
  -- Inotify/Kqueue don't cover all cases, e.g. network filesystems.
  Async Any
ticker <- IO Any -> IO (Async Any)
forall a. IO a -> IO (Async a)
async (IO Any -> IO (Async Any)) -> IO Any -> IO (Async Any)
forall a b. (a -> b) -> a -> b
$ IO () -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO Any) -> IO () -> IO Any
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
3007000 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
giveSignal
  let stopWatching :: IO ()
stopWatching = do
        Async Any -> IO ()
forall a. Async a -> IO ()
cancel Async Any
ticker
        Watch -> IO ()
removeDirWatch Watch
watch
  -- Listen to the signal asynchronously,
  -- and query the status when it fires.
  -- If the status changed, fill in the update.
  MVar Update
update <- IO (MVar Update)
forall a. IO (MVar a)
newEmptyMVar
  let query' :: IO (Status () (Path Abs Dir) Item)
query' = IO (Status () (Path Abs Dir) Item)
-> IO (Status () (Path Abs Dir) Item)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Status () (Path Abs Dir) Item)
 -> IO (Status () (Path Abs Dir) Item))
-> (IO (Status () (Path Abs Dir) Item)
    -> IO (Status () (Path Abs Dir) Item))
-> IO (Status () (Path Abs Dir) Item)
-> IO (Status () (Path Abs Dir) Item)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContentStore
-> IO (Status () (Path Abs Dir) Item)
-> IO (Status () (Path Abs Dir) Item)
forall (m :: * -> *) a.
MonadUnliftIO m =>
ContentStore -> m a -> m a
withStoreLock ContentStore
store (IO (Status () (Path Abs Dir) Item)
 -> IO (Status () (Path Abs Dir) Item))
-> IO (Status () (Path Abs Dir) Item)
-> IO (Status () (Path Abs Dir) Item)
forall a b. (a -> b) -> a -> b
$ ContentStore -> ContentHash -> IO (Status () (Path Abs Dir) Item)
forall (m :: * -> *).
MonadIO m =>
ContentStore -> ContentHash -> m (Status () (Path Abs Dir) Item)
internalQuery ContentStore
store ContentHash
hash
      loop :: IO Bool
loop =
        MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
signal IO ()
-> IO (Status () (Path Abs Dir) Item)
-> IO (Status () (Path Abs Dir) Item)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO (Status () (Path Abs Dir) Item)
query' IO (Status () (Path Abs Dir) Item)
-> (Status () (Path Abs Dir) Item -> IO Bool) -> IO Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Pending Path Abs Dir
_ -> IO Bool
loop
          Complete Item
item -> MVar Update -> Update -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar Update
update (Update -> IO Bool) -> Update -> IO Bool
forall a b. (a -> b) -> a -> b
$ Item -> Update
Completed Item
item
          Missing () -> MVar Update -> Update -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar Update
update Update
Failed
  IO (Async Bool) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Async Bool) -> IO ()) -> IO (Async Bool) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO (Async Bool)
forall a. IO a -> IO (Async a)
async IO Bool
loop
  -- Wait for the update asynchronously.
  -- Stop watching when it arrives.
  IO Update -> IO (Async Update)
forall a. IO a -> IO (Async a)
async (IO Update -> IO (Async Update)) -> IO Update -> IO (Async Update)
forall a b. (a -> b) -> a -> b
$ MVar Update -> IO Update
forall a. MVar a -> IO a
takeMVar MVar Update
update IO Update -> IO () -> IO Update
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* IO ()
stopWatching

setRootDirWritable :: MonadIO m => Path Abs Dir -> m ()
setRootDirWritable :: Path Abs Dir -> m ()
setRootDirWritable Path Abs Dir
storeRoot =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    String -> FileMode -> IO ()
setFileMode (Path Abs Dir -> String
fromAbsDir Path Abs Dir
storeRoot) FileMode
writableRootDirMode

writableRootDirMode :: FileMode
writableRootDirMode :: FileMode
writableRootDirMode = FileMode
writableDirMode

setRootDirReadOnly :: MonadIO m => Path Abs Dir -> m ()
setRootDirReadOnly :: Path Abs Dir -> m ()
setRootDirReadOnly Path Abs Dir
storeRoot =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    String -> FileMode -> IO ()
setFileMode (Path Abs Dir -> String
fromAbsDir Path Abs Dir
storeRoot) FileMode
readOnlyRootDirMode

readOnlyRootDirMode :: FileMode
readOnlyRootDirMode :: FileMode
readOnlyRootDirMode = FileMode
writableDirMode FileMode -> FileMode -> FileMode
`intersectFileModes` FileMode
allButWritableMode

withWritableStoreRoot :: (MonadMask m, MonadIO m) => Path Abs Dir -> m a -> m a
withWritableStoreRoot :: Path Abs Dir -> m a -> m a
withWritableStoreRoot Path Abs Dir
storeRoot =
  m () -> m () -> m a -> m a
forall (m :: * -> *) a b c. MonadMask m => m a -> m b -> m c -> m c
bracket_ (Path Abs Dir -> m ()
forall (m :: * -> *). MonadIO m => Path Abs Dir -> m ()
setRootDirWritable Path Abs Dir
storeRoot) (Path Abs Dir -> m ()
forall (m :: * -> *). MonadIO m => Path Abs Dir -> m ()
setRootDirReadOnly Path Abs Dir
storeRoot)

withWritableStore :: (MonadMask m, MonadIO m) => ContentStore -> m a -> m a
withWritableStore :: ContentStore -> m a -> m a
withWritableStore ContentStore {Path Abs Dir
storeRoot :: Path Abs Dir
storeRoot :: ContentStore -> Path Abs Dir
storeRoot} =
  Path Abs Dir -> m a -> m a
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
Path Abs Dir -> m a -> m a
withWritableStoreRoot Path Abs Dir
storeRoot

setDirWritable :: Path Abs Dir -> IO ()
setDirWritable :: Path Abs Dir -> IO ()
setDirWritable Path Abs Dir
fp = String -> FileMode -> IO ()
setFileMode (Path Abs Dir -> String
fromAbsDir Path Abs Dir
fp) FileMode
writableDirMode

writableDirMode :: FileMode
writableDirMode :: FileMode
writableDirMode =
  (FileMode -> FileMode -> FileMode)
-> FileMode -> [FileMode] -> FileMode
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
    FileMode -> FileMode -> FileMode
unionFileModes
    FileMode
nullFileMode
    [ FileMode
directoryMode,
      FileMode
ownerModes,
      FileMode
groupReadMode,
      FileMode
groupExecuteMode,
      FileMode
otherReadMode,
      FileMode
otherExecuteMode
    ]

-- | Set write permissions on the given path.
setWritable :: Path Abs t -> IO ()
setWritable :: Path Abs t -> IO ()
setWritable Path Abs t
fp = do
  FileMode
mode <- FileStatus -> FileMode
fileMode (FileStatus -> FileMode) -> IO FileStatus -> IO FileMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO FileStatus
getFileStatus (Path Abs t -> String
forall b t. Path b t -> String
toFilePath Path Abs t
fp)
  String -> FileMode -> IO ()
setFileMode (Path Abs t -> String
forall b t. Path b t -> String
toFilePath Path Abs t
fp) (FileMode -> IO ()) -> FileMode -> IO ()
forall a b. (a -> b) -> a -> b
$ FileMode
mode FileMode -> FileMode -> FileMode
`unionFileModes` FileMode
ownerWriteMode

-- | Unset write permissions on the given path.
unsetWritable :: Path Abs t -> IO ()
unsetWritable :: Path Abs t -> IO ()
unsetWritable Path Abs t
fp = do
  FileMode
mode <- FileStatus -> FileMode
fileMode (FileStatus -> FileMode) -> IO FileStatus -> IO FileMode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO FileStatus
getFileStatus (Path Abs t -> String
forall b t. Path b t -> String
toFilePath Path Abs t
fp)
  String -> FileMode -> IO ()
setFileMode (Path Abs t -> String
forall b t. Path b t -> String
toFilePath Path Abs t
fp) (FileMode -> IO ()) -> FileMode -> IO ()
forall a b. (a -> b) -> a -> b
$ FileMode
mode FileMode -> FileMode -> FileMode
`intersectFileModes` FileMode
allButWritableMode

allButWritableMode :: FileMode
allButWritableMode :: FileMode
allButWritableMode =
  FileMode -> FileMode
forall a. Bits a => a -> a
complement (FileMode -> FileMode) -> FileMode -> FileMode
forall a b. (a -> b) -> a -> b
$
    (FileMode -> FileMode -> FileMode)
-> FileMode -> [FileMode] -> FileMode
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
      FileMode -> FileMode -> FileMode
unionFileModes
      FileMode
nullFileMode
      [FileMode
ownerWriteMode, FileMode
groupWriteMode, FileMode
otherWriteMode]

-- | Set write permissions on all items in a directory tree recursively.
setWritableRecursively :: Path Abs Dir -> IO ()
setWritableRecursively :: Path Abs Dir -> IO ()
setWritableRecursively = (Path Abs Dir
 -> [Path Abs Dir] -> [Path Abs File] -> IO (WalkAction Abs))
-> Path Abs Dir -> IO ()
forall (m :: * -> *) b.
MonadIO m =>
(Path Abs Dir
 -> [Path Abs Dir] -> [Path Abs File] -> m (WalkAction Abs))
-> Path b Dir -> m ()
walkDir ((Path Abs Dir
  -> [Path Abs Dir] -> [Path Abs File] -> IO (WalkAction Abs))
 -> Path Abs Dir -> IO ())
-> (Path Abs Dir
    -> [Path Abs Dir] -> [Path Abs File] -> IO (WalkAction Abs))
-> Path Abs Dir
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir [Path Abs Dir]
_ [Path Abs File]
files -> do
  (Path Abs File -> IO ()) -> [Path Abs File] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Path Abs File -> IO ()
forall t. Path Abs t -> IO ()
setWritable [Path Abs File]
files
  Path Abs Dir -> IO ()
forall t. Path Abs t -> IO ()
setWritable Path Abs Dir
dir
  WalkAction Abs -> IO (WalkAction Abs)
forall (m :: * -> *) a. Monad m => a -> m a
return (WalkAction Abs -> IO (WalkAction Abs))
-> WalkAction Abs -> IO (WalkAction Abs)
forall a b. (a -> b) -> a -> b
$ [Path Abs Dir] -> WalkAction Abs
forall b. [Path b Dir] -> WalkAction b
WalkExclude []

-- | Unset write permissions on all items in a directory tree recursively.
unsetWritableRecursively :: Path Abs Dir -> IO ()
unsetWritableRecursively :: Path Abs Dir -> IO ()
unsetWritableRecursively = (Path Abs Dir
 -> [Path Abs Dir] -> [Path Abs File] -> IO (WalkAction Abs))
-> Path Abs Dir -> IO ()
forall (m :: * -> *) b.
MonadIO m =>
(Path Abs Dir
 -> [Path Abs Dir] -> [Path Abs File] -> m (WalkAction Abs))
-> Path b Dir -> m ()
walkDir ((Path Abs Dir
  -> [Path Abs Dir] -> [Path Abs File] -> IO (WalkAction Abs))
 -> Path Abs Dir -> IO ())
-> (Path Abs Dir
    -> [Path Abs Dir] -> [Path Abs File] -> IO (WalkAction Abs))
-> Path Abs Dir
-> IO ()
forall a b. (a -> b) -> a -> b
$ \Path Abs Dir
dir [Path Abs Dir]
_ [Path Abs File]
files -> do
  (Path Abs File -> IO ()) -> [Path Abs File] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Path Abs File -> IO ()
forall t. Path Abs t -> IO ()
unsetWritable [Path Abs File]
files
  Path Abs Dir -> IO ()
forall t. Path Abs t -> IO ()
unsetWritable Path Abs Dir
dir
  WalkAction Abs -> IO (WalkAction Abs)
forall (m :: * -> *) a. Monad m => a -> m a
return (WalkAction Abs -> IO (WalkAction Abs))
-> WalkAction Abs -> IO (WalkAction Abs)
forall a b. (a -> b) -> a -> b
$ [Path Abs Dir] -> WalkAction Abs
forall b. [Path b Dir] -> WalkAction b
WalkExclude []

storeVersion :: Int
storeVersion :: Int
storeVersion = Int
1

-- | Initialize the database.
initDb :: Path Abs Dir -> SQL.Connection -> IO ()
initDb :: Path Abs Dir -> Connection -> IO ()
initDb Path Abs Dir
storeDir Connection
db = do
  [[Int
version]] <- Connection -> Query -> IO [[Int]]
forall r. FromRow r => Connection -> Query -> IO [r]
SQL.query_ Connection
db Query
"PRAGMA user_version"
  if Int
version Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
    then
      Connection -> Query -> IO ()
SQL.execute_ Connection
db (Query -> IO ()) -> Query -> IO ()
forall a b. (a -> b) -> a -> b
$
        Query
"PRAGMA user_version = " Query -> Query -> Query
forall a. Semigroup a => a -> a -> a
<> String -> Query
forall a. IsString a => String -> a
fromString (Int -> String
forall a. Show a => a -> String
show Int
storeVersion)
    else
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
version Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
storeVersion) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        StoreError -> IO ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (StoreError -> IO ()) -> StoreError -> IO ()
forall a b. (a -> b) -> a -> b
$
          Path Abs Dir -> Int -> Int -> StoreError
IncompatibleStoreVersion Path Abs Dir
storeDir Int
version Int
storeVersion
  -- Aliases to items.
  Connection -> Query -> IO ()
SQL.execute_
    Connection
db
    Query
"CREATE TABLE IF NOT EXISTS\
    \  aliases\
    \  ( hash TEXT PRIMARY KEY\
    \  , dest TEXT NOT NULL\
    \  , name TEXT NOT NULL\
    \  )"
  -- Back-references from items @dest@ to hashes @hash@.
  Connection -> Query -> IO ()
SQL.execute_
    Connection
db
    Query
"CREATE TABLE IF NOT EXISTS\
    \  backrefs\
    \  ( hash TEXT PRIMARY KEY\
    \  , dest TEXT NOT NULL\
    \  )"
  -- Inputs @input@ to hashes @hash@.
  Connection -> Query -> IO ()
SQL.execute_
    Connection
db
    Query
"CREATE TABLE IF NOT EXISTS\
    \  inputs\
    \  ( hash TEXT NOT NULL\
    \  , input TEXT NOT NULL\
    \  , UNIQUE (hash, input)\
    \  )"
  -- Arbitrary metadata on hashes.
  Connection -> Query -> IO ()
SQL.execute_
    Connection
db
    Query
"CREATE TABLE IF NOT EXISTS\
    \  metadata\
    \  ( hash  TEXT NOT NULL\
    \  , key   TEXT NOT NULL\
    \  , value TEXT\
    \  , PRIMARY KEY(hash, key)\
    \  )"

-- | Adds a link between input hash and the output hash.
--
-- Assumes that the store is locked and writable.
addBackReference :: ContentStore -> ContentHash -> Item -> IO ()
addBackReference :: ContentStore -> ContentHash -> Item -> IO ()
addBackReference ContentStore
store ContentHash
inHash (Item ContentHash
outHash) =
  Connection -> Query -> [NamedParam] -> IO ()
SQL.executeNamed
    (ContentStore -> Connection
storeDb ContentStore
store)
    Query
"INSERT OR REPLACE INTO\
    \  backrefs (hash, dest)\
    \ VALUES\
    \  (:in, :out)"
    [ Text
":in" Text -> ContentHash -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
SQL.:= ContentHash
inHash,
      Text
":out" Text -> ContentHash -> NamedParam
forall v. ToField v => Text -> v -> NamedParam
SQL.:= ContentHash
outHash
    ]

-- | A cacher is responsible for controlling how steps are cached.
data CacherM m i o
  = -- | This step cannot be cached (default).
    NoCache
  | Cache
      { -- | Function to encode the input into a content
        --   hash.
        --   This function additionally takes an
        --   'identities' which gets incorporated into
        --   the cacher.
        CacherM m i o -> Int -> i -> m ContentHash
cacherKey :: Int -> i -> m ContentHash,
        CacherM m i o -> o -> ByteString
cacherStoreValue :: o -> ByteString,
        -- | Attempt to read the cache value back. May throw exceptions.
        CacherM m i o -> ByteString -> o
cacherReadValue :: ByteString -> o
      }

-- | A pure 'CacherM'
type Cacher = CacherM Identity

-- | Constructs a 'Cacher' that will use hashability of input and
-- serializability of output to make a step cacheable
defaultCacherWithIdent ::
  forall m i o.
  (ContentHashable m i, Data.Store.Store o) =>
  -- | Seed for the cacher
  Int ->
  CacherM m i o
defaultCacherWithIdent :: Int -> CacherM m i o
defaultCacherWithIdent Int
ident =
  Cache :: forall (m :: * -> *) i o.
(Int -> i -> m ContentHash)
-> (o -> ByteString) -> (ByteString -> o) -> CacherM m i o
Cache
    { cacherKey :: Int -> i -> m ContentHash
cacherKey = \Int
i i
ident' -> (i, Int, Int) -> m ContentHash
forall (m :: * -> *) a. ContentHashable m a => a -> m ContentHash
contentHash (i
ident', Int
ident, Int
i),
      cacherStoreValue :: o -> ByteString
cacherStoreValue = o -> ByteString
forall a. Store a => a -> ByteString
Data.Store.encode,
      cacherReadValue :: ByteString -> o
cacherReadValue = ByteString -> o
forall a. Store a => ByteString -> a
Data.Store.decodeEx
    }

-- | Looks for a @CacherM IO@, then lifts it
defaultIOCacherWithIdent ::
  (MonadIO m, ContentHashable IO i, Data.Store.Store o) =>
  -- | Seed for the cacher
  Int ->
  CacherM m i o
defaultIOCacherWithIdent :: Int -> CacherM m i o
defaultIOCacherWithIdent Int
ident = CacherM IO i o
c {cacherKey :: Int -> i -> m ContentHash
cacherKey = \Int
x i
i -> IO ContentHash -> m ContentHash
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ContentHash -> m ContentHash)
-> IO ContentHash -> m ContentHash
forall a b. (a -> b) -> a -> b
$ CacherM IO i o -> Int -> i -> IO ContentHash
forall (m :: * -> *) i o.
CacherM m i o -> Int -> i -> m ContentHash
cacherKey CacherM IO i o
c Int
x i
i}
  where
    c :: CacherM IO i o
c = Int -> CacherM IO i o
forall (m :: * -> *) i o.
(ContentHashable m i, Store o) =>
Int -> CacherM m i o
defaultCacherWithIdent Int
ident

-- | Runs a computation only if the ContentHash isn't already associated to an
-- entry in the store
cacheComputation ::
  (MonadIO m, MonadUnliftIO m, MonadMask m, Remote.Cacher m remoteCache) =>
  ContentStore ->
  remoteCache ->
  -- | In case an exception occurs
  m () ->
  -- | A ContentHash to identify the computation inputs
  ContentHash ->
  -- | The computation to cache, receving the path of a
  -- store folder to which it should write its results
  (Path Abs Dir -> m a) ->
  -- | The result if it was just computed, and the item
  -- corresponding to the store folder
  m (Maybe a, Item)
cacheComputation :: ContentStore
-> remoteCache
-> m ()
-> ContentHash
-> (Path Abs Dir -> m a)
-> m (Maybe a, Item)
cacheComputation ContentStore
store remoteCache
remoteCacher m ()
ifExc ContentHash
inputCHash Path Abs Dir -> m a
computation =
  ContentStore
-> remoteCache
-> m ()
-> ContentHash
-> (Path Abs Dir -> m (Either Void a))
-> m (Status Void () (Maybe a, Item))
forall (m :: * -> *) remoteCache e a.
(MonadIO m, MonadUnliftIO m, MonadMask m, Cacher m remoteCache) =>
ContentStore
-> remoteCache
-> m ()
-> ContentHash
-> (Path Abs Dir -> m (Either e a))
-> m (Status e () (Maybe a, Item))
withConstructIfMissing ContentStore
store remoteCache
remoteCacher m ()
ifExc ContentHash
inputCHash ((a -> Either Void a) -> m a -> m (Either Void a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either Void a
forall a b. b -> Either a b
Right (m a -> m (Either Void a))
-> (Path Abs Dir -> m a) -> Path Abs Dir -> m (Either Void a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> m a
computation) m (Status Void () (Maybe a, Item))
-> (Status Void () (Maybe a, Item) -> m (Maybe a, Item))
-> m (Maybe a, Item)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Missing Void
e -> Void -> m (Maybe a, Item)
forall a. Void -> a
absurd Void
e
    Pending ()
_ ->
      IO (Maybe Item) -> m (Maybe Item)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ContentStore -> ContentHash -> IO (Maybe Item)
forall (m :: * -> *).
MonadIO m =>
ContentStore -> ContentHash -> m (Maybe Item)
waitUntilComplete ContentStore
store ContentHash
inputCHash) m (Maybe Item)
-> (Maybe Item -> m (Maybe a, Item)) -> m (Maybe a, Item)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Item
item -> (Maybe a, Item) -> m (Maybe a, Item)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a
forall a. Maybe a
Nothing, Item
item)
        Maybe Item
Nothing -> StoreError -> m (Maybe a, Item)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (StoreError -> m (Maybe a, Item))
-> StoreError -> m (Maybe a, Item)
forall a b. (a -> b) -> a -> b
$ ContentHash -> StoreError
FailedToConstruct ContentHash
inputCHash
    Complete (Maybe a, Item)
resultAndItem -> (Maybe a, Item) -> m (Maybe a, Item)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a, Item)
resultAndItem

-- | Caches a Kleisli of some MonadIO action in the store given the required
-- properties
cacheKleisliIO ::
  (MonadIO m, MonadUnliftIO m, MonadMask m, Remote.Cacher m remoteCache) =>
  -- | This can be used to disambiguate the same program run in
  -- multiple configurations. If Nothing, then it means this
  -- program has no identity, this implies that steps will be
  -- executed without cache, even if 'Cache' has been given.
  Maybe Int ->
  CacherM m i o ->
  ContentStore ->
  remoteCache ->
  (i -> m o) ->
  i ->
  m o
cacheKleisliIO :: Maybe Int
-> CacherM m i o
-> ContentStore
-> remoteCache
-> (i -> m o)
-> i
-> m o
cacheKleisliIO Maybe Int
confIdent c :: CacherM m i o
c@Cache {} ContentStore
store remoteCache
remoteCacher i -> m o
f i
i
  | Just Int
confIdent' <- Maybe Int
confIdent = do
    ContentHash
chash <- CacherM m i o -> Int -> i -> m ContentHash
forall (m :: * -> *) i o.
CacherM m i o -> Int -> i -> m ContentHash
cacherKey CacherM m i o
c Int
confIdent' i
i
    (Maybe o
res, Item
item) <- ContentStore
-> remoteCache
-> m ()
-> ContentHash
-> (Path Abs Dir -> m o)
-> m (Maybe o, Item)
forall (m :: * -> *) remoteCache a.
(MonadIO m, MonadUnliftIO m, MonadMask m, Cacher m remoteCache) =>
ContentStore
-> remoteCache
-> m ()
-> ContentHash
-> (Path Abs Dir -> m a)
-> m (Maybe a, Item)
cacheComputation ContentStore
store remoteCache
remoteCacher (() -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ContentHash
chash Path Abs Dir -> m o
computeAndStore
    case Maybe o
res of
      Just o
r -> o -> m o
forall (m :: * -> *) a. Monad m => a -> m a
return o
r
      Maybe o
Nothing -> do
        ByteString
bs <- IO ByteString -> m ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> m ByteString)
-> (String -> IO ByteString) -> String -> m ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ByteString
BS.readFile (String -> m ByteString) -> String -> m ByteString
forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> String) -> Path Abs File -> String
forall a b. (a -> b) -> a -> b
$ ContentStore -> Item -> Path Abs Dir
itemPath ContentStore
store Item
item Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> [relfile|out|]
        o -> m o
forall (m :: * -> *) a. Monad m => a -> m a
return (o -> m o) -> o -> m o
forall a b. (a -> b) -> a -> b
$ CacherM m i o -> ByteString -> o
forall (m :: * -> *) i o. CacherM m i o -> ByteString -> o
cacherReadValue CacherM m i o
c (ByteString -> o) -> ByteString -> o
forall a b. (a -> b) -> a -> b
$ ByteString
bs
  where
    computeAndStore :: Path Abs Dir -> m o
computeAndStore Path Abs Dir
fp = do
      o
res <- i -> m o
f i
i -- Do the actual computation
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
        String -> ByteString -> IO ()
BS.writeFile (Path Abs File -> String
forall b t. Path b t -> String
toFilePath (Path Abs File -> String) -> Path Abs File -> String
forall a b. (a -> b) -> a -> b
$ Path Abs Dir
fp Path Abs Dir -> Path Rel File -> Path Abs File
forall b t. Path b Dir -> Path Rel t -> Path b t
</> [relfile|out|]) (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
          CacherM m i o -> o -> ByteString
forall (m :: * -> *) i o. CacherM m i o -> o -> ByteString
cacherStoreValue CacherM m i o
c (o -> ByteString) -> o -> ByteString
forall a b. (a -> b) -> a -> b
$
            o
res
      o -> m o
forall (m :: * -> *) a. Monad m => a -> m a
return o
res
cacheKleisliIO Maybe Int
_ CacherM m i o
_ ContentStore
_ remoteCache
_ i -> m o
f i
i = i -> m o
f i
i

-- | Caches an action that writes content-addressed data to the store. Returns
-- the Item of the written content.
putInStore ::
  ( MonadIO m,
    MonadMask m,
    MonadUnliftIO m,
    Remote.Cacher m remoteCacher,
    ContentHashable IO t
  ) =>
  ContentStore ->
  remoteCacher ->
  -- | In case an exception occurs
  (ContentHash -> m ()) ->
  -- | The action that writes to the new store
  -- directory
  (Path Abs Dir -> t -> m ()) ->
  t ->
  -- | The Item in the store to which @t@ has been written
  m Item
putInStore :: ContentStore
-> remoteCacher
-> (ContentHash -> m ())
-> (Path Abs Dir -> t -> m ())
-> t
-> m Item
putInStore ContentStore
store remoteCacher
remoteCacher ContentHash -> m ()
ifExc Path Abs Dir -> t -> m ()
f t
x = do
  ContentHash
chash <- IO ContentHash -> m ContentHash
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ContentHash -> m ContentHash)
-> IO ContentHash -> m ContentHash
forall a b. (a -> b) -> a -> b
$ t -> IO ContentHash
forall (m :: * -> *) a. ContentHashable m a => a -> m ContentHash
contentHash t
x
  (Maybe (), Item) -> Item
forall a b. (a, b) -> b
snd ((Maybe (), Item) -> Item) -> m (Maybe (), Item) -> m Item
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContentStore
-> remoteCacher
-> m ()
-> ContentHash
-> (Path Abs Dir -> m ())
-> m (Maybe (), Item)
forall (m :: * -> *) remoteCache a.
(MonadIO m, MonadUnliftIO m, MonadMask m, Cacher m remoteCache) =>
ContentStore
-> remoteCache
-> m ()
-> ContentHash
-> (Path Abs Dir -> m a)
-> m (Maybe a, Item)
cacheComputation ContentStore
store remoteCacher
remoteCacher (ContentHash -> m ()
ifExc ContentHash
chash) ContentHash
chash ((Path Abs Dir -> t -> m ()) -> t -> Path Abs Dir -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Path Abs Dir -> t -> m ()
f t
x)