{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

module Cachix.Client.Store
  ( Store,

    -- * Getting a Store
    openStore,
    releaseStore,

    -- * Query a path
    followLinksToStorePath,
    queryPathInfo,
    validPathInfoNarSize,
    validPathInfoNarHash,
    validPathInfoDeriver,
    unknownDeriver,
    validPathInfoReferences,

    -- * Get closures
    computeFSClosure,
    ClosureParams (..),
    defaultClosureParams,
    PathSet,
    newEmptyPathSet,
    addToPathSet,
    traversePathSet,

    -- * Miscellaneous
    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"

-- | TODO: foreignptr
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) } |]

-- | Follow symlinks to the store and chop off the parts after the top-level store name
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 ->
  -- | Exact store path, not a subpath
  ByteString ->
  -- | ValidPathInfo or exception
  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; }
  } |]

-- | The narSize field of a ValidPathInfo struct. Source: store-api.hh
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 }
      |]

-- | Copy the narHash field of a ValidPathInfo struct. Source: store-api.hh
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()) }
      |]

-- | Deriver field of a ValidPathInfo struct. Source: store-api.hh
--
-- Returns 'unknownDeriver' when missing.
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()));
        }
      |]

-- | String constant representing the case when the deriver of a store path does
-- not exist or is not known. Value: @unknown-deriver@
unknownDeriver :: Text
unknownDeriver :: Text
unknownDeriver = "unknown-deriver"

-- | References field of a ValidPathInfo struct. Source: store-api.hh
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

----- PathSet -----
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

----- computeFSClosure -----
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