{-# language RecordWildCards     #-}
module System.Nix.Store.Remote.Util where

import           Prelude                 hiding ( putText )
import           Control.Monad.Except

import           Data.Binary.Get
import           Data.Binary.Put
import qualified Data.Text.Lazy.Encoding       as TL
import           Data.Time
import           Data.Time.Clock.POSIX
import qualified Data.ByteString.Char8         as BSC
import qualified Data.ByteString.Lazy          as BSL

import           Network.Socket.ByteString      ( recv
                                                , sendAll
                                                )

import           Nix.Derivation

import           System.Nix.Build
import           System.Nix.StorePath
import           System.Nix.Store.Remote.Binary
import           System.Nix.Store.Remote.Types

import qualified Data.HashSet
import qualified Data.Map

genericIncremental :: (MonadIO m) => m (Maybe ByteString) -> Get a -> m a
genericIncremental :: forall (m :: * -> *) a.
MonadIO m =>
m (Maybe RawFilePath) -> Get a -> m a
genericIncremental m (Maybe RawFilePath)
getsome Get a
parser = Decoder a -> m a
forall {a}. Decoder a -> m a
go Decoder a
decoder
 where
  decoder :: Decoder a
decoder = Get a -> Decoder a
forall a. Get a -> Decoder a
runGetIncremental Get a
parser
  go :: Decoder a -> m a
go (Done RawFilePath
_leftover ByteOffset
_consumed a
x  ) = a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  go (Partial Maybe RawFilePath -> Decoder a
k                   ) = do
    chunk <- m (Maybe RawFilePath)
getsome
    go (k chunk)
  go (Fail RawFilePath
_leftover ByteOffset
_consumed String
msg) = Text -> m a
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> m a) -> Text -> m a
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. IsString a => String -> a
fromString String
msg

getSocketIncremental :: Get a -> MonadStore a
getSocketIncremental :: forall a. Get a -> MonadStore a
getSocketIncremental = ExceptT
  String
  (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
  (Maybe RawFilePath)
-> Get a
-> ExceptT
     String
     (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
     a
forall (m :: * -> *) a.
MonadIO m =>
m (Maybe RawFilePath) -> Get a -> m a
genericIncremental ExceptT
  String
  (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
  (Maybe RawFilePath)
sockGet8
 where
  sockGet8 :: MonadStore (Maybe BSC.ByteString)
  sockGet8 :: ExceptT
  String
  (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
  (Maybe RawFilePath)
sockGet8 = do
    soc <- (StoreConfig -> Socket)
-> ExceptT
     String
     (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
     Socket
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks StoreConfig -> Socket
storeSocket
    liftIO $ Just <$> recv soc 8

sockPut :: Put -> MonadStore ()
sockPut :: Put -> MonadStore ()
sockPut Put
p = do
  soc <- (StoreConfig -> Socket)
-> ExceptT
     String
     (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
     Socket
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks StoreConfig -> Socket
storeSocket
  liftIO $ sendAll soc $ toStrict $ runPut p

sockGet :: Get a -> MonadStore a
sockGet :: forall a. Get a -> MonadStore a
sockGet = Get a -> MonadStore a
forall a. Get a -> MonadStore a
getSocketIncremental

sockGetInt :: Integral a => MonadStore a
sockGetInt :: forall a. Integral a => MonadStore a
sockGetInt = Get a -> MonadStore a
forall a. Get a -> MonadStore a
getSocketIncremental Get a
forall a. Integral a => Get a
getInt

sockGetBool :: MonadStore Bool
sockGetBool :: MonadStore Bool
sockGetBool = (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Int
1 :: Int)) (Int -> Bool)
-> ExceptT
     String
     (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
     Int
-> MonadStore Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT
  String
  (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
  Int
forall a. Integral a => MonadStore a
sockGetInt

sockGetStr :: MonadStore ByteString
sockGetStr :: MonadStore RawFilePath
sockGetStr = Get RawFilePath -> MonadStore RawFilePath
forall a. Get a -> MonadStore a
getSocketIncremental Get RawFilePath
getByteStringLen

sockGetStrings :: MonadStore [ByteString]
sockGetStrings :: MonadStore [RawFilePath]
sockGetStrings = Get [RawFilePath] -> MonadStore [RawFilePath]
forall a. Get a -> MonadStore a
getSocketIncremental Get [RawFilePath]
getByteStrings

sockGetPath :: MonadStore StorePath
sockGetPath :: MonadStore StorePath
sockGetPath = do
  sd  <- MonadStore String
getStoreDir
  pth <- getSocketIncremental (getPath sd)
  either
    throwError
    pure
    pth

sockGetPathMay :: MonadStore (Maybe StorePath)
sockGetPathMay :: MonadStore (Maybe StorePath)
sockGetPathMay = do
  sd  <- MonadStore String
getStoreDir
  pth <- getSocketIncremental (getPath sd)
  pure $
    either
      (const Nothing)
      Just
      pth

sockGetPaths :: MonadStore StorePathSet
sockGetPaths :: MonadStore StorePathSet
sockGetPaths = do
  sd <- MonadStore String
getStoreDir
  getSocketIncremental (getPaths sd)

bsToText :: ByteString -> Text
bsToText :: RawFilePath -> Text
bsToText = RawFilePath -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8

textToBS :: Text -> ByteString
textToBS :: Text -> RawFilePath
textToBS = Text -> RawFilePath
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8

bslToText :: BSL.ByteString -> Text
bslToText :: ByteString -> Text
bslToText = Text -> Text
forall a. ToText a => a -> Text
toText (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TL.decodeUtf8

textToBSL :: Text -> BSL.ByteString
textToBSL :: Text -> ByteString
textToBSL = Text -> ByteString
TL.encodeUtf8 (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
forall a. ToLText a => a -> Text
toLText

putText :: Text -> Put
putText :: Text -> Put
putText = ByteString -> Put
putByteStringLen (ByteString -> Put) -> (Text -> ByteString) -> Text -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
textToBSL

putTexts :: [Text] -> Put
putTexts :: [Text] -> Put
putTexts = [ByteString] -> Put
forall (t :: * -> *). Foldable t => t ByteString -> Put
putByteStrings ([ByteString] -> Put) -> ([Text] -> [ByteString]) -> [Text] -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> ByteString) -> [Text] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ByteString
textToBSL

getPath :: FilePath -> Get (Either String StorePath)
getPath :: String -> Get (Either String StorePath)
getPath String
sd = String -> RawFilePath -> Either String StorePath
parsePath String
sd (RawFilePath -> Either String StorePath)
-> Get RawFilePath -> Get (Either String StorePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get RawFilePath
getByteStringLen

getPaths :: FilePath -> Get StorePathSet
getPaths :: String -> Get StorePathSet
getPaths String
sd =
  [StorePath] -> StorePathSet
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Data.HashSet.fromList ([StorePath] -> StorePathSet)
-> ([RawFilePath] -> [StorePath]) -> [RawFilePath] -> StorePathSet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either String StorePath] -> [StorePath]
forall a b. [Either a b] -> [b]
rights ([Either String StorePath] -> [StorePath])
-> ([RawFilePath] -> [Either String StorePath])
-> [RawFilePath]
-> [StorePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RawFilePath -> Either String StorePath)
-> [RawFilePath] -> [Either String StorePath]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> RawFilePath -> Either String StorePath
parsePath String
sd) ([RawFilePath] -> StorePathSet)
-> Get [RawFilePath] -> Get StorePathSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get [RawFilePath]
getByteStrings

putPath :: StorePath -> Put
putPath :: StorePath -> Put
putPath = ByteString -> Put
putByteStringLen (ByteString -> Put)
-> (StorePath -> ByteString) -> StorePath -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawFilePath -> ByteString
forall l s. LazyStrict l s => s -> l
fromStrict (RawFilePath -> ByteString)
-> (StorePath -> RawFilePath) -> StorePath -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePath -> RawFilePath
storePathToRawFilePath

putPaths :: StorePathSet -> Put
putPaths :: StorePathSet -> Put
putPaths = [ByteString] -> Put
forall (t :: * -> *). Foldable t => t ByteString -> Put
putByteStrings ([ByteString] -> Put)
-> (StorePathSet -> [ByteString]) -> StorePathSet -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashSet ByteString -> [ByteString]
forall a. HashSet a -> [a]
Data.HashSet.toList (HashSet ByteString -> [ByteString])
-> (StorePathSet -> HashSet ByteString)
-> StorePathSet
-> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StorePath -> ByteString) -> StorePathSet -> HashSet ByteString
forall b a.
(Hashable b, Eq b) =>
(a -> b) -> HashSet a -> HashSet b
Data.HashSet.map
  (RawFilePath -> ByteString
forall l s. LazyStrict l s => s -> l
fromStrict (RawFilePath -> ByteString)
-> (StorePath -> RawFilePath) -> StorePath -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePath -> RawFilePath
storePathToRawFilePath)

putBool :: Bool -> Put
putBool :: Bool -> Put
putBool Bool
True  = Int -> Put
forall a. Integral a => a -> Put
putInt (Int
1 :: Int)
putBool Bool
False = Int -> Put
forall a. Integral a => a -> Put
putInt (Int
0 :: Int)

getBool :: Get Bool
getBool :: Get Bool
getBool = (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (Int -> Bool) -> Get Int -> Get Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Get Int
forall a. Integral a => Get a
getInt :: Get Int)

putEnum :: (Enum a) => a -> Put
putEnum :: forall a. Enum a => a -> Put
putEnum = Int -> Put
forall a. Integral a => a -> Put
putInt (Int -> Put) -> (a -> Int) -> a -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a. Enum a => a -> Int
fromEnum

getEnum :: (Enum a) => Get a
getEnum :: forall a. Enum a => Get a
getEnum = Int -> a
forall a. Enum a => Int -> a
toEnum (Int -> a) -> Get Int -> Get a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int
forall a. Integral a => Get a
getInt

putTime :: UTCTime -> Put
putTime :: UTCTime -> Put
putTime = (Int -> Put
forall a. Integral a => a -> Put
putInt :: Int -> Put) (Int -> Put) -> (UTCTime -> Int) -> UTCTime -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> Int
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (POSIXTime -> Int) -> (UTCTime -> POSIXTime) -> UTCTime -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> POSIXTime
utcTimeToPOSIXSeconds

getTime :: Get UTCTime
getTime :: Get UTCTime
getTime = POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime) -> Get POSIXTime -> Get UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get POSIXTime
forall a. Enum a => Get a
getEnum

getBuildResult :: Get BuildResult
getBuildResult :: Get BuildResult
getBuildResult =
  BuildStatus
-> Maybe Text
-> Integer
-> Bool
-> UTCTime
-> UTCTime
-> BuildResult
BuildResult
    (BuildStatus
 -> Maybe Text
 -> Integer
 -> Bool
 -> UTCTime
 -> UTCTime
 -> BuildResult)
-> Get BuildStatus
-> Get
     (Maybe Text
      -> Integer -> Bool -> UTCTime -> UTCTime -> BuildResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get BuildStatus
forall a. Enum a => Get a
getEnum
    Get
  (Maybe Text
   -> Integer -> Bool -> UTCTime -> UTCTime -> BuildResult)
-> Get (Maybe Text)
-> Get (Integer -> Bool -> UTCTime -> UTCTime -> BuildResult)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> (RawFilePath -> Text) -> RawFilePath -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawFilePath -> Text
bsToText (RawFilePath -> Maybe Text) -> Get RawFilePath -> Get (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get RawFilePath
getByteStringLen)
    Get (Integer -> Bool -> UTCTime -> UTCTime -> BuildResult)
-> Get Integer -> Get (Bool -> UTCTime -> UTCTime -> BuildResult)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Integer
forall a. Integral a => Get a
getInt
    Get (Bool -> UTCTime -> UTCTime -> BuildResult)
-> Get Bool -> Get (UTCTime -> UTCTime -> BuildResult)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Bool
getBool
    Get (UTCTime -> UTCTime -> BuildResult)
-> Get UTCTime -> Get (UTCTime -> BuildResult)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get UTCTime
getTime
    Get (UTCTime -> BuildResult) -> Get UTCTime -> Get BuildResult
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get UTCTime
getTime

putDerivation :: Derivation StorePath Text -> Put
putDerivation :: Derivation StorePath Text -> Put
putDerivation Derivation{Set StorePath
Map StorePath (Set Text)
Map Text (DerivationOutput StorePath Text)
Map Text Text
Text
Vector Text
outputs :: Map Text (DerivationOutput StorePath Text)
inputDrvs :: Map StorePath (Set Text)
inputSrcs :: Set StorePath
platform :: Text
builder :: Text
args :: Vector Text
env :: Map Text Text
env :: forall fp txt. Derivation fp txt -> Map txt txt
args :: forall fp txt. Derivation fp txt -> Vector txt
builder :: forall fp txt. Derivation fp txt -> txt
platform :: forall fp txt. Derivation fp txt -> txt
inputSrcs :: forall fp txt. Derivation fp txt -> Set fp
inputDrvs :: forall fp txt. Derivation fp txt -> Map fp (Set txt)
outputs :: forall fp txt.
Derivation fp txt -> Map txt (DerivationOutput fp txt)
..} = do
  (((Text, DerivationOutput StorePath Text) -> Put)
 -> [(Text, DerivationOutput StorePath Text)] -> Put)
-> [(Text, DerivationOutput StorePath Text)]
-> ((Text, DerivationOutput StorePath Text) -> Put)
-> Put
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Text, DerivationOutput StorePath Text) -> Put)
-> [(Text, DerivationOutput StorePath Text)] -> Put
forall (t :: * -> *) a. Foldable t => (a -> Put) -> t a -> Put
putMany (Map Text (DerivationOutput StorePath Text)
-> [(Text, DerivationOutput StorePath Text)]
forall k a. Map k a -> [(k, a)]
Data.Map.toList Map Text (DerivationOutput StorePath Text)
outputs)
    (((Text, DerivationOutput StorePath Text) -> Put) -> Put)
-> ((Text, DerivationOutput StorePath Text) -> Put) -> Put
forall a b. (a -> b) -> a -> b
$ \(Text
outputName, DerivationOutput{StorePath
Text
path :: StorePath
hashAlgo :: Text
hash :: Text
hash :: forall fp txt. DerivationOutput fp txt -> txt
hashAlgo :: forall fp txt. DerivationOutput fp txt -> txt
path :: forall fp txt. DerivationOutput fp txt -> fp
..}) -> do
        Text -> Put
putText Text
outputName
        StorePath -> Put
putPath StorePath
path
        Text -> Put
putText Text
hashAlgo
        Text -> Put
putText Text
hash

  (StorePath -> Put) -> Set StorePath -> Put
forall (t :: * -> *) a. Foldable t => (a -> Put) -> t a -> Put
putMany StorePath -> Put
putPath Set StorePath
inputSrcs
  Text -> Put
putText Text
platform
  Text -> Put
putText Text
builder
  (Text -> Put) -> Vector Text -> Put
forall (t :: * -> *) a. Foldable t => (a -> Put) -> t a -> Put
putMany Text -> Put
putText Vector Text
args

  (((Text, Text) -> Put) -> [(Text, Text)] -> Put)
-> [(Text, Text)] -> ((Text, Text) -> Put) -> Put
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Text, Text) -> Put) -> [(Text, Text)] -> Put
forall (t :: * -> *) a. Foldable t => (a -> Put) -> t a -> Put
putMany (Map Text Text -> [(Text, Text)]
forall k a. Map k a -> [(k, a)]
Data.Map.toList Map Text Text
env)
    (((Text, Text) -> Put) -> Put) -> ((Text, Text) -> Put) -> Put
forall a b. (a -> b) -> a -> b
$ \(Text
a1, Text
a2) -> Text -> Put
putText Text
a1 Put -> Put -> Put
forall a b. PutM a -> PutM b -> PutM b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Put
putText Text
a2