Moved decoders to separate module so they can be used externally

.circleci/config.yml

@@ -1,7 +1,7 @@
 version: 2.1
 
 orbs:
-  haskell: haskell-works/haskell-build@1.6.2
+  haskell: haskell-works/haskell-build@1.6.3
   github: haskell-works/github-release@1.2.1
   hackage: haskell-works/hackage@1.0.0
 

app/App/Dump.hs

@@ -9,27 +9,26 @@ module App.Dump
   ) where
 
 import Arbor.File.Format.Asif.Data.Ip
+import Arbor.File.Format.Asif.Format.Decoder as D
 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 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.Clock
-import Data.Thyme.Clock.POSIX          (POSIXTime)
-import Data.Thyme.Format               (formatTime)
+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 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
@@ -40,6 +39,8 @@ 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) #-}
@@ -48,14 +49,6 @@ import qualified System.IO                              as IO
 showTime :: FormatTime t => t -> String
 showTime = formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S %Z"))
 
-getWord32x4 :: G.Get (Word32, Word32, Word32, Word32)
-getWord32x4 = do
-  a <- G.getWord32be
-  b <- G.getWord32be
-  c <- G.getWord32be
-  d <- G.getWord32be
-  return (a, b, c, d)
-
 word64ToList :: Int -> Word64 -> [Word32] -> [Word32]
 word64ToList _ 0 = id
 word64ToList o w = (ip:) . word64ToList o (w .&. comp b)
@@ -66,94 +59,133 @@ word64ToList o w = (ip:) . word64ToList o (w .&. comp b)
 
 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 w = G.runGet G.getInt64le (LBS.take 8 (bs <> LBS.replicate 8 0))
-              let t :: POSIXTime = (w * 1000) ^. from microseconds
-              liftIO $ IO.hPutStrLn hOut $ showTime (posixSecondsToUTCTime t) <> " (" <> show w <> " ms)"
-          Just (Known F.TimeMicros64LE) ->
-            forM_ (LBS.chunkBy 8 (segment ^. the @"payload")) $ \bs -> do
-              let w = G.runGet G.getInt64le (LBS.take 8 (bs <> LBS.replicate 8 0))
-              let t :: POSIXTime = w ^. from microseconds
-              liftIO $ IO.hPutStrLn hOut $ showTime (posixSecondsToUTCTime t) <> " (" <> show w <> " µs)"
-          Just (Known F.Ipv4) ->
-            forM_ (LBS.chunkBy 4 (segment ^. the @"payload")) $ \bs -> do
-              let w = G.runGet G.getWord32le (LBS.take 8 (bs <> LBS.replicate 4 0))
-              let ipString = w & word32ToIpv4 & 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 (a, b, c, d) = G.runGet getWord32x4 (LBS.take 16 (bs <> LBS.replicate 16 0))
-              if a == 0 && b == 0 && c == 0xFFFF
-                then do
-                  let ipString = d & word32ToIpv4 & ipv4ToString
-                  liftIO $ IO.hPutStrLn hOut $ ipString <> replicate (64 - length ipString) ' ' <> "(" <> show d <> ")"
-                else do
-                  let ipString = word32x4ToIpv6 (a, b, c, d) & ipv6ToString
-                  liftIO $ IO.hPutStrLn hOut $ ipString <> replicate (64 - length ipString) ' ' <> "(" <> show (a, b, c, d) <> ")"
-          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
-          _ ->
-            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 ""
+  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 ""