{-# 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 :: m (Maybe ByteString) -> Get a -> m a
genericIncremental m (Maybe ByteString)
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 ByteString
_leftover ByteOffset
_consumed a
x  ) = a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
  go (Partial Maybe ByteString -> Decoder a
k                   ) = do
    Maybe ByteString
chunk <- m (Maybe ByteString)
getsome
    Decoder a -> m a
go (Maybe ByteString -> Decoder a
k Maybe ByteString
chunk)
  go (Fail ByteString
_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 :: Get a -> MonadStore a
getSocketIncremental = ExceptT
  String
  (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
  (Maybe ByteString)
-> Get a -> MonadStore a
forall (m :: * -> *) a.
MonadIO m =>
m (Maybe ByteString) -> Get a -> m a
genericIncremental ExceptT
  String
  (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
  (Maybe ByteString)
sockGet8
 where
  sockGet8 :: MonadStore (Maybe BSC.ByteString)
  sockGet8 :: ExceptT
  String
  (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
  (Maybe ByteString)
sockGet8 = do
    Socket
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
    IO (Maybe ByteString)
-> ExceptT
     String
     (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
     (Maybe ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString)
 -> ExceptT
      String
      (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
      (Maybe ByteString))
-> IO (Maybe ByteString)
-> ExceptT
     String
     (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
     (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> IO ByteString -> IO (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Socket -> Int -> IO ByteString
recv Socket
soc Int
8

sockPut :: Put -> MonadStore ()
sockPut :: Put -> MonadStore ()
sockPut Put
p = do
  Socket
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
  IO () -> MonadStore ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> MonadStore ()) -> IO () -> MonadStore ()
forall a b. (a -> b) -> a -> b
$ Socket -> ByteString -> IO ()
sendAll Socket
soc (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
forall l s. LazyStrict l s => l -> s
toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
runPut Put
p

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

sockGetInt :: Integral a => MonadStore a
sockGetInt :: 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 ByteString
sockGetStr = Get ByteString -> MonadStore ByteString
forall a. Get a -> MonadStore a
getSocketIncremental Get ByteString
getByteStringLen

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

sockGetPath :: MonadStore StorePath
sockGetPath :: MonadStore StorePath
sockGetPath = do
  String
sd  <- MonadStore String
getStoreDir
  Either String StorePath
pth <- Get (Either String StorePath)
-> MonadStore (Either String StorePath)
forall a. Get a -> MonadStore a
getSocketIncremental (String -> Get (Either String StorePath)
getPath String
sd)
  (String -> MonadStore StorePath)
-> (StorePath -> MonadStore StorePath)
-> Either String StorePath
-> MonadStore StorePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    String -> MonadStore StorePath
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
    StorePath -> MonadStore StorePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Either String StorePath
pth

sockGetPathMay :: MonadStore (Maybe StorePath)
sockGetPathMay :: MonadStore (Maybe StorePath)
sockGetPathMay = do
  String
sd  <- MonadStore String
getStoreDir
  Either String StorePath
pth <- Get (Either String StorePath)
-> MonadStore (Either String StorePath)
forall a. Get a -> MonadStore a
getSocketIncremental (String -> Get (Either String StorePath)
getPath String
sd)
  Maybe StorePath -> MonadStore (Maybe StorePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe StorePath -> MonadStore (Maybe StorePath))
-> Maybe StorePath -> MonadStore (Maybe StorePath)
forall a b. (a -> b) -> a -> b
$
    (String -> Maybe StorePath)
-> (StorePath -> Maybe StorePath)
-> Either String StorePath
-> Maybe StorePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
      (Maybe StorePath -> String -> Maybe StorePath
forall a b. a -> b -> a
const Maybe StorePath
forall a. Maybe a
Nothing)
      StorePath -> Maybe StorePath
forall a. a -> Maybe a
Just
      Either String StorePath
pth

sockGetPaths :: MonadStore StorePathSet
sockGetPaths :: MonadStore StorePathSet
sockGetPaths = do
  String
sd <- MonadStore String
getStoreDir
  Get StorePathSet -> MonadStore StorePathSet
forall a. Get a -> MonadStore a
getSocketIncremental (String -> Get StorePathSet
getPaths String
sd)

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

textToBS :: Text -> ByteString
textToBS :: Text -> ByteString
textToBS = Text -> ByteString
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 (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 -> ByteString -> Either String StorePath
parsePath String
sd (ByteString -> Either String StorePath)
-> Get ByteString -> Get (Either String StorePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
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)
-> ([ByteString] -> [StorePath]) -> [ByteString] -> 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])
-> ([ByteString] -> [Either String StorePath])
-> [ByteString]
-> [StorePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Either String StorePath)
-> [ByteString] -> [Either String StorePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> ByteString -> Either String StorePath
parsePath String
sd) ([ByteString] -> StorePathSet)
-> Get [ByteString] -> Get StorePathSet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get [ByteString]
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
. ByteString -> ByteString
forall l s. LazyStrict l s => s -> l
fromStrict (ByteString -> ByteString)
-> (StorePath -> ByteString) -> StorePath -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePath -> ByteString
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
  (ByteString -> ByteString
forall l s. LazyStrict l s => s -> l
fromStrict (ByteString -> ByteString)
-> (StorePath -> ByteString) -> StorePath -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorePath -> ByteString
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 :: 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 :: 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 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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> (ByteString -> Text) -> ByteString -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
bsToText (ByteString -> Maybe Text) -> Get ByteString -> Get (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
getByteStringLen)
    Get (Integer -> Bool -> UTCTime -> UTCTime -> BuildResult)
-> Get Integer -> Get (Bool -> UTCTime -> UTCTime -> BuildResult)
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 (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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get UTCTime
getTime
    Get (UTCTime -> BuildResult) -> Get UTCTime -> Get BuildResult
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{Text
Map Text Text
Map Text (DerivationOutput StorePath Text)
Map StorePath (Set Text)
Set StorePath
Vector Text
outputs :: forall fp txt.
Derivation fp txt -> Map txt (DerivationOutput fp txt)
inputDrvs :: forall fp txt. Derivation fp txt -> Map fp (Set txt)
inputSrcs :: forall fp txt. Derivation fp txt -> Set fp
platform :: forall fp txt. Derivation fp txt -> txt
builder :: forall fp txt. Derivation fp txt -> txt
args :: forall fp txt. Derivation fp txt -> Vector txt
env :: forall fp txt. Derivation fp txt -> Map txt txt
env :: Map Text Text
args :: Vector Text
builder :: Text
platform :: Text
inputSrcs :: Set StorePath
inputDrvs :: Map StorePath (Set Text)
outputs :: Map Text (DerivationOutput StorePath Text)
..} = 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{Text
StorePath
path :: forall fp txt. DerivationOutput fp txt -> fp
hashAlgo :: forall fp txt. DerivationOutput fp txt -> txt
hash :: forall fp txt. DerivationOutput fp txt -> txt
hash :: Text
hashAlgo :: Text
path :: StorePath
..}) -> 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 (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Put
putText Text
a2