Dump.hs

{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

module App.Dump
  ( dumpSegment
  , word64ToList
  ) where

import Arbor.File.Format.Asif.Data.Ip
import Arbor.File.Format.Asif.Segment
import Arbor.File.Format.Asif.Whatever
import Control.Lens
import Control.Monad
import Control.Monad.IO.Class          (liftIO)
import Control.Monad.Trans.Resource    (MonadResource)
import Data.Char                       (isPrint)
import Data.Generics.Product.Any
import Data.List
import Data.Monoid                     ((<>))
import Data.Text                       (Text)
import Data.Thyme.Format               (formatTime)
import Data.Thyme.Time.Core
import Data.Word
import HaskellWorks.Data.Bits.BitShow
import HaskellWorks.Data.Bits.BitWise
import Numeric                         (showHex)
import System.IO                       (Handle)
import System.Locale                   (defaultTimeLocale, iso8601DateFormat)

import qualified Arbor.File.Format.Asif.ByteString.Lazy as LBS
import qualified Arbor.File.Format.Asif.Format          as F
import qualified Arbor.File.Format.Asif.Get             as D
import qualified Data.Binary                            as G
import qualified Data.Binary.Get                        as G
import qualified Data.Bits                              as B
import qualified Data.ByteString.Lazy                   as LBS
import qualified Data.ByteString.Lazy.Char8             as LBSC
import qualified Data.Text                              as T
import qualified Data.Text.Encoding                     as T
import qualified HaskellWorks.Data.Network.Ip.Ipv4      as IP4
import qualified HaskellWorks.Data.Network.Ip.Ipv6      as IP6
import qualified System.IO                              as IO

{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}
{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}

showTime :: FormatTime t => t -> String
showTime = formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S %Z"))

word64ToList :: Int -> Word64 -> [Word32] -> [Word32]
word64ToList _ 0 = id
word64ToList o w = (ip:) . word64ToList o (w .&. comp b)
  where p  = B.countTrailingZeros w
        hi = o .<. 6
        ip = fromIntegral (p .|. hi)
        b  = 1 .<. fromIntegral p

dumpSegment :: MonadResource m => Handle -> Int -> Text -> Segment LBS.ByteString -> m ()
dumpSegment hOut i filename segment = do
  if T.null filename
    then liftIO $ IO.hPutStrLn hOut $ "==== [" <> show i <> "] ===="
    else liftIO $ IO.hPutStrLn hOut $ "==== [" <> show i <> "] " <> T.unpack filename <> " ===="

  case segment ^. the @"meta" . the @"format" of
    Just (Known F.StringZ) -> do
      when (LBS.length (segment ^. the @"payload") > 0) $
        forM_ (init (LBS.split 0 (segment ^. the @"payload"))) $ \bs ->
          liftIO $ IO.hPutStrLn hOut $ T.unpack (T.decodeUtf8 (LBS.toStrict bs))

    Just (Known (F.Repeat n F.Char)) ->
      forM_ (LBS.chunkBy (fromIntegral n) (segment ^. the @"payload")) $ \bs ->
        liftIO $ IO.hPutStrLn hOut $ T.unpack (T.decodeUtf8 (LBS.toStrict bs))

    Just (Known F.TimeMillis64LE) ->
      forM_ (LBS.chunkBy 8 (segment ^. the @"payload")) $ \bs -> do
        let t = G.runGet D.getTimeMillis (LBS.take 8 (bs <> LBS.replicate 8 0))
        let ms = t & utcTimeToPOSIXSeconds & toMicroseconds & (`div` 1000)
        liftIO $ IO.hPutStrLn hOut $ showTime t <> " (" <> show ms <> " ms)"

    Just (Known F.TimeMicros64LE) ->
      forM_ (LBS.chunkBy 8 (segment ^. the @"payload")) $ \bs -> do
        let t = G.runGet D.getTimeMicros (LBS.take 8 (bs <> LBS.replicate 8 0))
        let micros = t & utcTimeToPOSIXSeconds & toMicroseconds
        liftIO $ IO.hPutStrLn hOut $ showTime t <> " (" <> show micros <> " µs)"

    Just (Known F.Ipv4) ->
      forM_ (LBS.chunkBy 4 (segment ^. the @"payload")) $ \bs -> do
        let w = G.runGet D.getIpv4 (LBS.take 4 (bs <> LBS.replicate 4 0))
        let ipString = w & ipv4ToString
        liftIO $ IO.hPutStrLn hOut $ ipString <> replicate (16 - length ipString) ' ' <> "(" <> show w <> ")"

    Just (Known F.Ipv6) ->
      forM_ (LBS.chunkBy 16 (segment ^. the @"payload")) $ \bs -> do
        let ip6@(IP6.IpAddress (a,b,c,d)) = G.runGet D.getIpv6 (LBS.take 16 (bs <> LBS.replicate 16 0))
        let ipString = ipv6toStringCollapseV4 ip6
        let raw = case isIpv4 ip6 of
              Just (IP4.IpAddress w32) -> "(" <> show w32 <> ")"
              Nothing                  -> "(" <> show (a, b, c, d) <> ")"
        liftIO $ IO.hPutStrLn hOut $ ipString <> replicate (64 - length ipString) ' ' <> raw

    Just (Known F.Ipv4Block) ->
      forM_ (LBS.chunkBy 5 (segment ^. the @"payload")) $ \bs -> do
        let block@(IP4.IpBlock ip mask) = G.runGet D.getIpv4Block (LBS.take 5 (bs <> LBS.replicate 5 0))
        let IP4.IpAddress ipw = ip
        let IP4.IpNetMask maskw = mask
        let ipString = block & ipv4CidrToString
        liftIO $ IO.hPutStrLn hOut $ ipString <> replicate (64 - length ipString) ' ' <> "(" <> show (ipw, maskw) <> ")"

    Just (Known F.Ipv6Block) ->
      forM_ (LBS.chunkBy 17 (segment ^. the @"payload")) $ \bs -> do
        let block@(IP6.IpBlock ip mask) = G.runGet D.getIpv6Block (LBS.take 17 (bs <> LBS.replicate 17 0))
        let IP6.IpAddress ipw = ip
        let IP6.IpNetMask maskw = mask
        let ipString = block & ipv6CidrToStringCollapseV4
        liftIO $ IO.hPutStrLn hOut $ ipString <> replicate (64 - length ipString) ' ' <> "(" <> show (ipw, maskw) <> ")"

    Just (Known F.Int64LE) ->
      forM_ (LBS.chunkBy 8 (segment ^. the @"payload")) $ \bs -> do
        let w = G.runGet G.getInt64le (LBS.take 8 (bs <> LBS.replicate 8 0))
        liftIO $ IO.hPrint hOut w

    Just (Known F.Int32LE) ->
      forM_ (LBS.chunkBy 4 (segment ^. the @"payload")) $ \bs -> do
        let w = G.runGet G.getInt32le (LBS.take 4 (bs <> LBS.replicate 4 0))
        liftIO $ IO.hPrint hOut w

    Just (Known F.Int16LE) ->
      forM_ (LBS.chunkBy 2 (segment ^. the @"payload")) $ \bs -> do
        let w = G.runGet G.getInt16le (LBS.take 2 (bs <> LBS.replicate 2 0))
        liftIO $ IO.hPrint hOut w

    Just (Known F.Int8) ->
      forM_ (LBS.chunkBy 1 (segment ^. the @"payload")) $ \bs -> do
        let w = G.runGet G.getInt8 (LBS.take 1 (bs <> LBS.replicate 1 0))
        liftIO $ IO.hPrint hOut w

    Just (Known F.Word64LE) ->
      forM_ (LBS.chunkBy 8 (segment ^. the @"payload")) $ \bs -> do
        let w = G.runGet G.getWord64le (LBS.take 8 (bs <> LBS.replicate 8 0))
        liftIO $ IO.hPrint hOut w

    Just (Known F.Word32LE) ->
      forM_ (LBS.chunkBy 4 (segment ^. the @"payload")) $ \bs -> do
        let w = G.runGet G.getWord32le (LBS.take 4 (bs <> LBS.replicate 4 0))
        liftIO $ IO.hPrint hOut w

    Just (Known F.Word16LE) ->
      forM_ (LBS.chunkBy 2 (segment ^. the @"payload")) $ \bs -> do
        let w = G.runGet G.getWord16le (LBS.take 2 (bs <> LBS.replicate 2 0))
        liftIO $ IO.hPrint hOut w

    Just (Known F.Word8) ->
      forM_ (LBS.chunkBy 1 (segment ^. the @"payload")) $ \bs -> do
        let w = G.runGet G.getWord8 (LBS.take 1 (bs <> LBS.replicate 1 0))
        liftIO $ IO.hPrint hOut w

    Just (Known F.Text) ->
      liftIO $ LBSC.hPutStrLn hOut (segment ^. the @"payload")

    Just (Known F.BitString) ->
      liftIO $ IO.hPutStrLn hOut (bitShow (segment ^. the @"payload"))

    Just (Known F.Bitmap) ->
      forM_ (zip [0..] (G.runGet G.getWord64le <$> LBS.chunkBy 8 (segment ^. the @"payload"))) $ \(idx, w64) ->
        forM_ (word64ToList idx w64 []) $ \w32 -> do
          let ipString = w32 & word32ToIpv4 & ipv4ToString
          liftIO $ IO.hPutStrLn hOut $ ipString <> replicate (16 - length ipString) ' ' <> "(" <> show w32 <> ")"

    Just (Known F.Bool) ->
      forM_ (LBS.chunkBy 1 (segment ^. the @"payload")) $ \bs -> do
        let w :: Bool = G.runGet G.get (LBS.take 1 (bs <> LBS.replicate 1 0))
        liftIO $ IO.hPrint hOut w

    -- WARNING: Don't put a true catch-all (_ -> ...) case here
    -- it means we miss this function when new formats get added.
    Just (Known F.Binary) -> catchAll
    Just (Known F.Char) -> catchAll
    Just (Known (F.Repeat _ _)) -> catchAll
    Just (Unknown _) -> catchAll
    Nothing -> catchAll
  where
    catchAll = forM_ (zip (LBS.chunkBy 16 (segment ^. the @"payload")) [0 :: Int, 16..]) $ \(bs, j) -> do
      let bytes = mconcat (intersperse " " (reverse . take 2 . reverse . ('0':) . flip showHex "" <$> LBS.unpack bs))
      liftIO $ IO.hPutStr hOut $ reverse $ take 8 $ reverse $ ("0000000" ++) $ showHex j ""
      liftIO $ IO.hPutStr hOut "  "
      liftIO $ IO.hPutStr hOut $ bytes <> replicate (47 - length bytes) ' '
      liftIO $ IO.hPutStr hOut "  "
      liftIO $ IO.hPutStr hOut $ (\c -> if isPrint c then c else '.') <$> LBSC.unpack bs
      liftIO $ IO.hPutStrLn hOut ""