{-# language RankNTypes #-}

module System.Nix.Store.Remote.Logger
  ( Logger(..)
  , Field(..)
  , processOutput
  )
where


import           Prelude                 hiding ( Last )
import           Control.Monad.Except           ( throwError )
import           Data.Binary.Get

import           Network.Socket.ByteString      ( recv )

import           System.Nix.Store.Remote.Binary
import           System.Nix.Store.Remote.Types
import           System.Nix.Store.Remote.Util


controlParser :: Get Logger
controlParser :: Get Logger
controlParser = do
  Int
ctrl <- Get Int
forall a. Integral a => Get a
getInt
  case (Int
ctrl :: Int) of
    Int
0x6f6c6d67 -> ByteString -> Logger
Next          (ByteString -> Logger) -> Get ByteString -> Get Logger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
getByteStringLen
    Int
0x64617461 -> Int -> Logger
Read          (Int -> Logger) -> Get Int -> Get Logger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int
forall a. Integral a => Get a
getInt
    Int
0x64617416 -> ByteString -> Logger
Write         (ByteString -> Logger) -> Get ByteString -> Get Logger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
getByteStringLen
    Int
0x616c7473 -> Logger -> Get Logger
forall (f :: * -> *) a. Applicative f => a -> f a
pure Logger
Last
    Int
0x63787470 -> (Int -> ByteString -> Logger) -> ByteString -> Int -> Logger
forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> ByteString -> Logger
Error    (ByteString -> Int -> Logger)
-> Get ByteString -> Get (Int -> Logger)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
getByteStringLen
                                Get (Int -> Logger) -> Get Int -> Get Logger
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Int
forall a. Integral a => Get a
getInt
    Int
0x53545254 -> Int -> Int -> Int -> ByteString -> [Field] -> Int -> Logger
StartActivity (Int -> Int -> Int -> ByteString -> [Field] -> Int -> Logger)
-> Get Int
-> Get (Int -> Int -> ByteString -> [Field] -> Int -> Logger)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int
forall a. Integral a => Get a
getInt
                                Get (Int -> Int -> ByteString -> [Field] -> Int -> Logger)
-> Get Int -> Get (Int -> ByteString -> [Field] -> Int -> Logger)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Int
forall a. Integral a => Get a
getInt
                                Get (Int -> ByteString -> [Field] -> Int -> Logger)
-> Get Int -> Get (ByteString -> [Field] -> Int -> Logger)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Int
forall a. Integral a => Get a
getInt
                                Get (ByteString -> [Field] -> Int -> Logger)
-> Get ByteString -> Get ([Field] -> Int -> Logger)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get ByteString
getByteStringLen
                                Get ([Field] -> Int -> Logger)
-> Get [Field] -> Get (Int -> Logger)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [Field]
getFields
                                Get (Int -> Logger) -> Get Int -> Get Logger
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Int
forall a. Integral a => Get a
getInt
    Int
0x53544f50 -> Int -> Logger
StopActivity  (Int -> Logger) -> Get Int -> Get Logger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int
forall a. Integral a => Get a
getInt
    Int
0x52534c54 -> Int -> Int -> [Field] -> Logger
Result        (Int -> Int -> [Field] -> Logger)
-> Get Int -> Get (Int -> [Field] -> Logger)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int
forall a. Integral a => Get a
getInt
                                Get (Int -> [Field] -> Logger)
-> Get Int -> Get ([Field] -> Logger)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Int
forall a. Integral a => Get a
getInt
                                Get ([Field] -> Logger) -> Get [Field] -> Get Logger
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get [Field]
getFields
    Int
x          -> String -> Get Logger
forall (m :: * -> *) a. MonadFail m => String -> m a
fail          (String -> Get Logger) -> String -> Get Logger
forall a b. (a -> b) -> a -> b
$ String
"Invalid control message received:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
x

processOutput :: MonadStore [Logger]
processOutput :: MonadStore [Logger]
processOutput = Decoder Logger -> MonadStore [Logger]
go Decoder Logger
decoder
 where
  decoder :: Decoder Logger
decoder = Get Logger -> Decoder Logger
forall a. Get a -> Decoder a
runGetIncremental Get Logger
controlParser
  go :: Decoder Logger -> MonadStore [Logger]
  go :: Decoder Logger -> MonadStore [Logger]
go (Done ByteString
_leftover ByteOffset
_consumed Logger
ctrl) = do
    case Logger
ctrl of
      e :: Logger
e@(Error Int
_ ByteString
_) -> [Logger] -> MonadStore [Logger]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Logger
e]
      Logger
Last          -> [Logger] -> MonadStore [Logger]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Logger
Last]
      Read Int
_n       -> do
        (Maybe ByteString
mdata, [Logger]
_) <- ExceptT
  String
  (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
  (Maybe ByteString, [Logger])
forall s (m :: * -> *). MonadState s m => m s
get
        case Maybe ByteString
mdata of
          Maybe ByteString
Nothing   -> String
-> ExceptT
     String
     (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
     ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError String
"No data to read provided"
          Just ByteString
part -> do
            -- XXX: we should check/assert part size against n of (Read n)
            Put
-> ExceptT
     String
     (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
     ()
sockPut (Put
 -> ExceptT
      String
      (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
      ())
-> Put
-> ExceptT
     String
     (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
     ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Put
putByteStringLen ByteString
part
            ExceptT
  String
  (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
  ()
clearData

        Decoder Logger -> MonadStore [Logger]
go Decoder Logger
decoder

      -- we should probably handle Read here as well
      Logger
x -> do
        [Logger]
next <- Decoder Logger -> MonadStore [Logger]
go Decoder Logger
decoder
        [Logger] -> MonadStore [Logger]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Logger] -> MonadStore [Logger])
-> [Logger] -> MonadStore [Logger]
forall a b. (a -> b) -> a -> b
$ Logger
x Logger -> [Logger] -> [Logger]
forall a. a -> [a] -> [a]
: [Logger]
next
  go (Partial Maybe ByteString -> Decoder Logger
k) = 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
    Maybe ByteString
chunk <- IO (Maybe ByteString)
-> ExceptT
     String
     (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
     (Maybe ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (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)
    Decoder Logger -> MonadStore [Logger]
go (Maybe ByteString -> Decoder Logger
k Maybe ByteString
chunk)

  go (Fail ByteString
_leftover ByteOffset
_consumed String
msg) = Text -> MonadStore [Logger]
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> MonadStore [Logger]) -> Text -> MonadStore [Logger]
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. IsString a => String -> a
fromString String
msg

getFields :: Get [Field]
getFields :: Get [Field]
getFields = do
  Int
cnt <- Get Int
forall a. Integral a => Get a
getInt
  Int -> Get Field -> Get [Field]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
cnt Get Field
getField

getField :: Get Field
getField :: Get Field
getField = do
  Int
typ <- Get Int
forall a. Integral a => Get a
getInt
  case (Int
typ :: Int) of
    Int
0 -> Int -> Field
LogInt (Int -> Field) -> Get Int -> Get Field
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int
forall a. Integral a => Get a
getInt
    Int
1 -> ByteString -> Field
LogStr (ByteString -> Field) -> Get ByteString -> Get Field
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
getByteStringLen
    Int
x -> String -> Get Field
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get Field) -> String -> Get Field
forall a b. (a -> b) -> a -> b
$ String
"Unknown log type: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
x