{-# LANGUAGE RankNTypes #-}
module System.Nix.Store.Remote.Logger (
    Logger(..)
  , Field(..)
  , processOutput)
  where

import           Control.Monad.Except
import           Control.Monad.Reader      (ask)
import           Control.Monad.State       (get)
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. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
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 (m :: * -> *) a. Monad m => a -> m a
return [Logger
e]
            Logger
Last -> [Logger] -> MonadStore [Logger]
forall (m :: * -> *) a. Monad m => a -> m a
return [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

              [Logger]
next <- Decoder Logger -> MonadStore [Logger]
go Decoder Logger
decoder
              [Logger] -> MonadStore [Logger]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Logger] -> MonadStore [Logger])
-> [Logger] -> MonadStore [Logger]
forall a b. (a -> b) -> a -> b
$ [Logger]
next

            -- 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 (m :: * -> *) a. Monad m => a -> m a
return ([Logger] -> MonadStore [Logger])
-> [Logger] -> MonadStore [Logger]
forall a b. (a -> b) -> a -> b
$ Logger
xLogger -> [Logger] -> [Logger]
forall a. a -> [a] -> [a]
:[Logger]
next
        go (Partial Maybe ByteString -> Decoder Logger
k) = do
          Socket
soc <- StoreConfig -> Socket
storeSocket (StoreConfig -> Socket)
-> ExceptT
     String
     (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
     StoreConfig
-> ExceptT
     String
     (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
     Socket
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT
  String
  (StateT (Maybe ByteString, [Logger]) (ReaderT StoreConfig IO))
  StoreConfig
forall r (m :: * -> *). MonadReader r m => m r
ask
          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) = do
          String -> MonadStore [Logger]
forall a. HasCallStack => String -> a
error String
msg

getFields :: Get [Field]
getFields :: Get [Field]
getFields = do
  Int
cnt <- Get Int
forall a. Integral a => Get a
getInt
  [Get Field] -> Get [Field]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Get Field] -> Get [Field]) -> [Get Field] -> Get [Field]
forall a b. (a -> b) -> a -> b
$ Int -> Get Field -> [Get Field]
forall a. Int -> a -> [a]
replicate 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. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
x