{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module Cachix.Client.Store
( Store,
openStore,
releaseStore,
followLinksToStorePath,
queryPathInfo,
validPathInfoNarSize,
validPathInfoNarHash,
validPathInfoDeriver,
unknownDeriver,
validPathInfoReferences,
computeFSClosure,
ClosureParams (..),
defaultClosureParams,
PathSet,
newEmptyPathSet,
addToPathSet,
traversePathSet,
storeUri,
)
where
import Cachix.Client.Store.Context (NixStore, Ref, ValidPathInfo, context)
import qualified Cachix.Client.Store.Context as C hiding (context)
import Data.ByteString.Unsafe (unsafePackMallocCString)
import Data.Coerce
import Foreign.ForeignPtr
import qualified Language.C.Inline.Cpp as C
import qualified Language.C.Inline.Cpp.Exceptions as C
import Protolude
import System.IO.Unsafe (unsafePerformIO)
C.context context
C.include "<cstring>"
C.include "<nix/config.h>"
C.include "<nix/shared.hh>"
C.include "<nix/store-api.hh>"
C.include "<nix/get-drvs.hh>"
C.include "<nix/derivations.hh>"
C.include "<nix/affinity.hh>"
C.include "<nix/globals.hh>"
C.include "aliases.h"
C.using "namespace nix"
newtype Store = Store (Ptr (Ref NixStore))
openStore :: IO Store
openStore :: IO Store
openStore =
IO (Ptr (Ref NixStore)) -> IO Store
forall a b. Coercible a b => a -> b
coerce
[C.throwBlock| refStore* {
refStore s = openStore();
return new refStore(s);
} |]
releaseStore :: Store -> IO ()
releaseStore :: Store -> IO ()
releaseStore (Store store :: Ptr (Ref NixStore)
store) = [C.exp| void { delete $(refStore* store) } |]
followLinksToStorePath :: Store -> ByteString -> IO ByteString
followLinksToStorePath :: Store -> ByteString -> IO ByteString
followLinksToStorePath (Store store :: Ptr (Ref NixStore)
store) bs :: ByteString
bs =
Ptr CChar -> IO ByteString
unsafePackMallocCString
(Ptr CChar -> IO ByteString) -> IO (Ptr CChar) -> IO ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [C.throwBlock| const char *{
return strdup((*$(refStore* store))->followLinksToStorePath(std::string($bs-ptr:bs, $bs-len:bs)).c_str());
}|]
storeUri :: Store -> IO ByteString
storeUri :: Store -> IO ByteString
storeUri (Store store :: Ptr (Ref NixStore)
store) =
Ptr CChar -> IO ByteString
unsafePackMallocCString
(Ptr CChar -> IO ByteString) -> IO (Ptr CChar) -> IO ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [C.throwBlock| const char* {
std::string uri = (*$(refStore* store))->getUri();
return strdup(uri.c_str());
} |]
queryPathInfo ::
Store ->
ByteString ->
IO (ForeignPtr (Ref ValidPathInfo))
queryPathInfo :: Store -> ByteString -> IO (ForeignPtr (Ref ValidPathInfo))
queryPathInfo (Store store :: Ptr (Ref NixStore)
store) path :: ByteString
path = do
Ptr (Ref ValidPathInfo)
vpi <-
[C.throwBlock| refValidPathInfo*
{
return new refValidPathInfo((*$(refStore* store))->queryPathInfo($bs-cstr:path));
} |]
FinalizerPtr (Ref ValidPathInfo)
-> Ptr (Ref ValidPathInfo) -> IO (ForeignPtr (Ref ValidPathInfo))
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr (Ref ValidPathInfo)
finalizeRefValidPathInfo Ptr (Ref ValidPathInfo)
vpi
finalizeRefValidPathInfo :: FinalizerPtr (Ref ValidPathInfo)
{-# NOINLINE finalizeRefValidPathInfo #-}
finalizeRefValidPathInfo :: FinalizerPtr (Ref ValidPathInfo)
finalizeRefValidPathInfo =
IO (FinalizerPtr (Ref ValidPathInfo))
-> FinalizerPtr (Ref ValidPathInfo)
forall a. IO a -> a
unsafePerformIO
[C.exp|
void (*)(refValidPathInfo *) {
[](refValidPathInfo *v){ delete v; }
} |]
validPathInfoNarSize :: ForeignPtr (Ref ValidPathInfo) -> Int64
validPathInfoNarSize :: ForeignPtr (Ref ValidPathInfo) -> Int64
validPathInfoNarSize vpi :: ForeignPtr (Ref ValidPathInfo)
vpi =
Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer -> Int64) -> Integer -> Int64
forall a b. (a -> b) -> a -> b
$
CLong -> Integer
forall a. Integral a => a -> Integer
toInteger
[C.pure| long
{ (*$fptr-ptr:(refValidPathInfo* vpi))->narSize }
|]
validPathInfoNarHash :: ForeignPtr (Ref ValidPathInfo) -> IO ByteString
validPathInfoNarHash :: ForeignPtr (Ref ValidPathInfo) -> IO ByteString
validPathInfoNarHash vpi :: ForeignPtr (Ref ValidPathInfo)
vpi =
Ptr CChar -> IO ByteString
unsafePackMallocCString
(Ptr CChar -> IO ByteString) -> IO (Ptr CChar) -> IO ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [C.exp| const char
*{ strdup((*$fptr-ptr:(refValidPathInfo* vpi))->narHash.to_string().c_str()) }
|]
validPathInfoDeriver :: ForeignPtr (Ref ValidPathInfo) -> IO ByteString
validPathInfoDeriver :: ForeignPtr (Ref ValidPathInfo) -> IO ByteString
validPathInfoDeriver vpi :: ForeignPtr (Ref ValidPathInfo)
vpi =
Ptr CChar -> IO ByteString
unsafePackMallocCString
(Ptr CChar -> IO ByteString) -> IO (Ptr CChar) -> IO ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [C.throwBlock| const char*
{
std::optional<Path> deriver = (*$fptr-ptr:(refValidPathInfo* vpi))->deriver;
return strdup((deriver == "" ? "unknown-deriver" : deriver->c_str()));
}
|]
unknownDeriver :: Text
unknownDeriver :: Text
unknownDeriver = "unknown-deriver"
validPathInfoReferences :: ForeignPtr (Ref ValidPathInfo) -> IO PathSet
validPathInfoReferences :: ForeignPtr (Ref ValidPathInfo) -> IO PathSet
validPathInfoReferences vpi :: ForeignPtr (Ref ValidPathInfo)
vpi = do
Ptr PathSet
ptr <-
[C.exp| const PathSet*
{ new PathSet((*$fptr-ptr:(refValidPathInfo* vpi))->references) }
|]
ForeignPtr PathSet
fptr <- FinalizerPtr PathSet -> Ptr PathSet -> IO (ForeignPtr PathSet)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr PathSet
finalizePathSet Ptr PathSet
ptr
PathSet -> IO PathSet
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PathSet -> IO PathSet) -> PathSet -> IO PathSet
forall a b. (a -> b) -> a -> b
$ ForeignPtr PathSet -> PathSet
PathSet ForeignPtr PathSet
fptr
newtype PathSet = PathSet (ForeignPtr (C.Set C.CxxString))
finalizePathSet :: FinalizerPtr C.PathSet
{-# NOINLINE finalizePathSet #-}
finalizePathSet :: FinalizerPtr PathSet
finalizePathSet =
IO (FinalizerPtr PathSet) -> FinalizerPtr PathSet
forall a. IO a -> a
unsafePerformIO
[C.exp|
void (*)(PathSet *) {
[](PathSet *v){
delete v;
}
} |]
newEmptyPathSet :: IO PathSet
newEmptyPathSet :: IO PathSet
newEmptyPathSet = do
Ptr PathSet
ptr <- [C.exp| PathSet *{ new PathSet() }|]
ForeignPtr PathSet
fptr <- FinalizerPtr PathSet -> Ptr PathSet -> IO (ForeignPtr PathSet)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr PathSet
finalizePathSet Ptr PathSet
ptr
PathSet -> IO PathSet
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PathSet -> IO PathSet) -> PathSet -> IO PathSet
forall a b. (a -> b) -> a -> b
$ ForeignPtr PathSet -> PathSet
PathSet ForeignPtr PathSet
fptr
addToPathSet :: ByteString -> PathSet -> IO ()
addToPathSet :: ByteString -> PathSet -> IO ()
addToPathSet bs :: ByteString
bs pathSet_ :: PathSet
pathSet_ = PathSet -> (Ptr PathSet -> IO ()) -> IO ()
forall b. PathSet -> (Ptr PathSet -> IO b) -> IO b
withPathSet PathSet
pathSet_ ((Ptr PathSet -> IO ()) -> IO ())
-> (Ptr PathSet -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \pathSet :: Ptr PathSet
pathSet ->
[C.throwBlock| void {
$(PathSet *pathSet)->insert(std::string($bs-ptr:bs, $bs-len:bs));
}|]
withPathSet :: PathSet -> (Ptr C.PathSet -> IO b) -> IO b
withPathSet :: PathSet -> (Ptr PathSet -> IO b) -> IO b
withPathSet (PathSet pathSetFptr :: ForeignPtr PathSet
pathSetFptr) = ForeignPtr PathSet -> (Ptr PathSet -> IO b) -> IO b
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr PathSet
pathSetFptr
traversePathSet :: forall a. (ByteString -> IO a) -> PathSet -> IO [a]
traversePathSet :: (ByteString -> IO a) -> PathSet -> IO [a]
traversePathSet f :: ByteString -> IO a
f pathSet_ :: PathSet
pathSet_ = PathSet -> (Ptr PathSet -> IO [a]) -> IO [a]
forall b. PathSet -> (Ptr PathSet -> IO b) -> IO b
withPathSet PathSet
pathSet_ ((Ptr PathSet -> IO [a]) -> IO [a])
-> (Ptr PathSet -> IO [a]) -> IO [a]
forall a b. (a -> b) -> a -> b
$ \pathSet :: Ptr PathSet
pathSet -> do
Ptr (Iterator PathSet)
i <- [C.exp| PathSetIterator *{ new PathSetIterator($(PathSet *pathSet)->begin()) }|]
Ptr (Iterator PathSet)
end <- [C.exp| PathSetIterator *{ new PathSetIterator ($(PathSet *pathSet)->end()) }|]
let cleanup :: IO ()
cleanup =
[C.throwBlock| void {
delete $(PathSetIterator *i);
delete $(PathSetIterator *end);
}|]
(IO [a] -> IO () -> IO [a]) -> IO () -> IO [a] -> IO [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO [a] -> IO () -> IO [a]
forall a b. IO a -> IO b -> IO a
finally IO ()
cleanup (IO [a] -> IO [a]) -> IO [a] -> IO [a]
forall a b. (a -> b) -> a -> b
$
let go :: ([a] -> [a]) -> IO [a]
go :: ([a] -> [a]) -> IO [a]
go acc :: [a] -> [a]
acc = do
CInt
isDone <-
[C.exp| int {
*$(PathSetIterator *i) == *$(PathSetIterator *end)
}|]
if CInt
isDone CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= 0
then [a] -> IO [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([a] -> IO [a]) -> [a] -> IO [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a]
acc []
else do
ByteString
somePath <- Ptr CChar -> IO ByteString
unsafePackMallocCString (Ptr CChar -> IO ByteString) -> IO (Ptr CChar) -> IO ByteString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [C.exp| const char *{ strdup((*$(PathSetIterator *i))->c_str()) } |]
a
a <- ByteString -> IO a
f ByteString
somePath
[C.throwBlock| void { (*$(PathSetIterator *i))++; } |]
([a] -> [a]) -> IO [a]
go ([a] -> [a]
acc ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
:))
in ([a] -> [a]) -> IO [a]
go [a] -> [a]
forall a. a -> a
identity
data ClosureParams
= ClosureParams
{ ClosureParams -> Bool
flipDirection :: Bool,
ClosureParams -> Bool
includeOutputs :: Bool,
ClosureParams -> Bool
includeDerivers :: Bool
}
defaultClosureParams :: ClosureParams
defaultClosureParams :: ClosureParams
defaultClosureParams =
ClosureParams :: Bool -> Bool -> Bool -> ClosureParams
ClosureParams
{ flipDirection :: Bool
flipDirection = Bool
False,
includeOutputs :: Bool
includeOutputs = Bool
False,
includeDerivers :: Bool
includeDerivers = Bool
False
}
computeFSClosure :: Store -> ClosureParams -> PathSet -> IO PathSet
computeFSClosure :: Store -> ClosureParams -> PathSet -> IO PathSet
computeFSClosure (Store store :: Ptr (Ref NixStore)
store) params :: ClosureParams
params startingSet_ :: PathSet
startingSet_ = PathSet -> (Ptr PathSet -> IO PathSet) -> IO PathSet
forall b. PathSet -> (Ptr PathSet -> IO b) -> IO b
withPathSet PathSet
startingSet_ ((Ptr PathSet -> IO PathSet) -> IO PathSet)
-> (Ptr PathSet -> IO PathSet) -> IO PathSet
forall a b. (a -> b) -> a -> b
$ \startingSet :: Ptr PathSet
startingSet -> do
let countTrue :: Bool -> C.CInt
countTrue :: Bool -> CInt
countTrue True = 1
countTrue False = 0
flipDir :: CInt
flipDir = Bool -> CInt
countTrue (Bool -> CInt) -> Bool -> CInt
forall a b. (a -> b) -> a -> b
$ ClosureParams -> Bool
flipDirection ClosureParams
params
inclOut :: CInt
inclOut = Bool -> CInt
countTrue (Bool -> CInt) -> Bool -> CInt
forall a b. (a -> b) -> a -> b
$ ClosureParams -> Bool
includeOutputs ClosureParams
params
inclDrv :: CInt
inclDrv = Bool -> CInt
countTrue (Bool -> CInt) -> Bool -> CInt
forall a b. (a -> b) -> a -> b
$ ClosureParams -> Bool
includeDerivers ClosureParams
params
Ptr PathSet
ps <-
[C.throwBlock| PathSet* {
PathSet *r = new PathSet();
(*$(refStore* store))->computeFSClosure(*$(PathSet *startingSet), *r, $(int flipDir), $(int inclOut), $(int inclDrv));
return r;
} |]
ForeignPtr PathSet
fp <- FinalizerPtr PathSet -> Ptr PathSet -> IO (ForeignPtr PathSet)
forall a. FinalizerPtr a -> Ptr a -> IO (ForeignPtr a)
newForeignPtr FinalizerPtr PathSet
finalizePathSet Ptr PathSet
ps
PathSet -> IO PathSet
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PathSet -> IO PathSet) -> PathSet -> IO PathSet
forall a b. (a -> b) -> a -> b
$ ForeignPtr PathSet -> PathSet
PathSet ForeignPtr PathSet
fp