{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
module Arbor.File.Format.Asif.Write
(
writeAsif
, asifContent
, asifContentC
, lazyByteStringSegment
, nullTerminatedStringSegment
, fixedLengthAsciiSegment
, textSegment
, asciiSegment
, boolSegment
, word8Segment
, word16Segment
, word32Segment
, word64Segment
, int8Segment
, int16Segment
, int32Segment
, int64Segment
, ipv4Segment
, ipv6Segment
, ipv4BlockSegment
, ipv6BlockSegment
, utcTimeMicrosSegment
, lookupSegment
, word16LookupSegment
, word32LookupSegment
, word64LookupSegment
, genericInitial
, genericStep
, genericExtract
, genericFold
)
where
import Arbor.File.Format.Asif.ByteString.Builder
import Arbor.File.Format.Asif.Data.Ip (ipv4ToWord32, ipv6ToWord32x4)
import Arbor.File.Format.Asif.Type
import Arbor.File.Format.Asif.Whatever (Whatever (..))
import Conduit
import Control.Foldl
import Control.Lens
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource (MonadResource)
import Data.Int
import Data.Profunctor (lmap)
import Data.Semigroup ((<>))
import Data.Word
import HaskellWorks.Data.Network.Ip.Validity (Canonical (..))
import System.IO (Handle, hFlush)
import System.IO.Temp (openTempFile)
import qualified Arbor.File.Format.Asif.Format as F
import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Foldable as Foldable
import qualified Data.Map.Strict as Map
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TE
import qualified HaskellWorks.Data.Network.Ip.Ipv4 as IP4
import qualified HaskellWorks.Data.Network.Ip.Ipv6 as IP6
import qualified Data.Thyme.Clock.POSIX as TY
import qualified Data.Thyme.Time.Core as TY
writeAsif :: (Foldable f, MonadResource m)
=> Handle
-> String
-> Maybe TY.POSIXTime
-> FoldM m a [Segment Handle]
-> f a
-> m ()
writeAsif hOutput asifType mTimestamp fld foldable = do
runConduit
$ asifContentC asifType mTimestamp fld foldable
.| sinkHandle hOutput
liftIO $ hFlush hOutput
asifContent :: (Foldable f, MonadResource m)
=> String
-> Maybe TY.POSIXTime
-> FoldM m a [Segment Handle]
-> f a
-> m LBS.ByteString
asifContent asifType mTimestamp fld foldable =
runConduit
$ asifContentC asifType mTimestamp fld foldable
.| sinkLazy
asifContentC :: (Foldable f, MonadResource m)
=> String
-> Maybe TY.POSIXTime
-> FoldM m a [Segment Handle]
-> f a
-> ConduitT () BS.ByteString m ()
asifContentC asifType mTimestamp fld foldable = do
segments <- lift $ foldM fld foldable
segmentsC asifType mTimestamp segments
lazyByteStringSegment :: MonadResource m => Whatever F.Format -> (a -> LBS.ByteString) -> T.Text -> FoldM m a [Segment Handle]
lazyByteStringSegment = genericFold BB.lazyByteString
nullTerminatedStringSegment :: MonadResource m => (a -> T.Text) -> T.Text -> FoldM m a [Segment Handle]
nullTerminatedStringSegment f t = FoldM step initial extract
where
initial = genericInitial t
step h b = do
liftIO $ BB.hPutBuilder h $ BB.byteString (T.encodeUtf8 . f $ b) <> BB.word8 0
pure h
extract = genericExtract t (Known F.StringZ)
textSegment :: MonadResource m => (a -> T.Text) -> T.Text -> FoldM m a [Segment Handle]
textSegment f = genericFold TE.encodeUtf8Builder (Known F.Text) (TL.fromStrict . f)
asciiSegment :: MonadResource m => (a -> Char) -> T.Text -> FoldM m a [Segment Handle]
asciiSegment = genericFold BB.char8 (Known F.Char)
fixedLengthAsciiSegment :: MonadResource m => (a -> T.Text) -> T.Text -> Word -> FoldM m a [Segment Handle]
fixedLengthAsciiSegment f name len =
genericFold (Foldable.foldMap BB.char8 . T.unpack) (Known (F.Repeat len F.Char)) (ensureLength . f) name
where
ensureLength = T.take (fromIntegral len) . T.justifyLeft 2 ' '
boolSegment :: MonadResource m => (a -> Bool) -> T.Text -> FoldM m a [Segment Handle]
boolSegment f = genericFold BB.word8 (Known F.Bool) (bool2word8 . f)
where
bool2word8 False = 0
bool2word8 True = 1
word8Segment :: MonadResource m => (a -> Word8) -> T.Text -> FoldM m a [Segment Handle]
word8Segment = genericFold BB.word8 (Known F.Word8)
word16Segment :: MonadResource m => (a -> Word16) -> T.Text -> FoldM m a [Segment Handle]
word16Segment = genericFold BB.word16LE (Known F.Word16LE)
word32Segment :: MonadResource m => (a -> Word32) -> T.Text -> FoldM m a [Segment Handle]
word32Segment = genericFold BB.word32LE (Known F.Word32LE)
word64Segment :: MonadResource m => (a -> Word64) -> T.Text -> FoldM m a [Segment Handle]
word64Segment = genericFold BB.word64LE (Known F.Word64LE)
int8Segment :: MonadResource m => (a -> Int8) -> T.Text -> FoldM m a [Segment Handle]
int8Segment = genericFold BB.int8 (Known F.Int8)
int16Segment :: MonadResource m => (a -> Int16) -> T.Text -> FoldM m a [Segment Handle]
int16Segment = genericFold BB.int16LE (Known F.Int16LE)
int32Segment :: MonadResource m => (a -> Int32) -> T.Text -> FoldM m a [Segment Handle]
int32Segment = genericFold BB.int32LE (Known F.Int32LE)
int64Segment :: MonadResource m => (a -> Int64) -> T.Text -> FoldM m a [Segment Handle]
int64Segment = genericFold BB.int64LE (Known F.Int64LE)
ipv4Segment :: MonadResource m => (a -> IP4.IpAddress) -> T.Text -> FoldM m a [Segment Handle]
ipv4Segment f = genericFold BB.word32LE (Known F.Ipv4) (ipv4ToWord32 . f)
ipv6Segment :: MonadResource m => (a -> IP6.IpAddress) -> T.Text -> FoldM m a [Segment Handle]
ipv6Segment f = genericFold encoding (Known F.Ipv6) extract
where
encoding = Prelude.foldMap BB.word32BE
extract = tupleToList . ipv6ToWord32x4 . f
ipv4BlockSegment :: MonadResource m => (a -> IP4.IpBlock Canonical) -> T.Text -> FoldM m a [Segment Handle]
ipv4BlockSegment = genericFold encoding (Known F.Ipv4Block)
where
encoding (IP4.IpBlock (IP4.IpAddress ip) (IP4.IpNetMask block)) = BB.word32LE ip <> BB.word8 block
ipv6BlockSegment :: MonadResource m => (a -> IP6.IpBlock Canonical) -> T.Text -> FoldM m a [Segment Handle]
ipv6BlockSegment = genericFold encoding (Known F.Ipv6Block)
where
encoding (IP6.IpBlock ip (IP6.IpNetMask block)) =
let extract = Prelude.foldMap BB.word32BE . tupleToList . ipv6ToWord32x4
in extract ip <> BB.word8 block
utcTimeMicrosSegment :: MonadResource m => (a -> TY.UTCTime) -> T.Text -> FoldM m a [Segment Handle]
utcTimeMicrosSegment f = genericFold BB.int64LE (Known F.TimeMicros64LE) (fromTime . f)
where
fromTime :: TY.UTCTime -> Int64
fromTime = view (TY.posixTime . TY.microseconds)
word16LookupSegment :: (MonadResource m, Ord b)
=> T.Text
-> (a -> Maybe b)
-> FoldM m b [Segment Handle]
-> FoldM m a [Segment Handle]
word16LookupSegment name f = lookupSegment name f (Known F.Word16LE) BB.word16LE
word32LookupSegment :: (MonadResource m, Ord b)
=> T.Text
-> (a -> Maybe b)
-> FoldM m b [Segment Handle]
-> FoldM m a [Segment Handle]
word32LookupSegment name f = lookupSegment name f (Known F.Word32LE) BB.word32LE
word64LookupSegment :: (MonadResource m, Ord b)
=> T.Text
-> (a -> Maybe b)
-> FoldM m b [Segment Handle]
-> FoldM m a [Segment Handle]
word64LookupSegment name f = lookupSegment name f (Known F.Word64LE) BB.word64LE
lookupSegment :: (MonadResource m, Ord b, Eq i, Num i, Bounded i)
=> T.Text
-> (a -> Maybe b)
-> Whatever F.Format
-> (i -> BB.Builder)
-> FoldM m b [Segment Handle]
-> FoldM m a [Segment Handle]
lookupSegment name f fmt enc (FoldM rstep rinit rextract) =
FoldM lstep linit lextract
where
linit = do
(_, _, h) <- openTempFile Nothing (T.unpack name)
rx <- rinit
pure (h, Map.empty, 0, rx)
lstep (h, m, c, rx) a =
case f a of
Nothing -> do
liftIO $ BB.hPutBuilder h $ enc maxBound
pure (h, m, c, rx)
Just b -> do
let (v, c', m') = updateMap b c m
liftIO $ BB.hPutBuilder h $ enc v
rx' <- if c' == c then pure rx else rstep rx b
pure (h, m', c', rx')
lextract (h, _, _, rx) = do
rres <- rextract rx
pure $ [ segment h $ metaFilename name <> metaFormat fmt] <> rres
updateMap k c m =
maybe (c, c+1, Map.insert k c m) (, c, m) (Map.lookup k m)
genericInitial :: MonadResource m => T.Text -> m Handle
genericInitial name = do
(_, _, h) <- openTempFile Nothing (T.unpack name)
pure h
genericStep :: MonadResource m => (a -> BB.Builder) -> Handle -> a -> m Handle
genericStep enc h b = do
liftIO $ BB.hPutBuilder h $ enc b
pure h
genericExtract :: MonadResource m => T.Text -> Whatever F.Format -> Handle -> m [Segment Handle]
genericExtract filen typ h = pure [segment h $ metaFilename filen <> metaFormat typ]
genericFold :: MonadResource m => (a -> BB.Builder) -> Whatever F.Format -> (b -> a) -> T.Text -> FoldM m b [Segment Handle]
genericFold enc fmt f t = lmap f $ FoldM (genericStep enc) (genericInitial t) (genericExtract t fmt)
tupleToList :: (a,a,a,a) -> [a]
tupleToList (w1,w2,w3,w4) = [w1,w2,w3,w4]