diff --git a/app/App/Commands/Dump.hs b/app/App/Commands/Dump.hs --- a/app/App/Commands/Dump.hs +++ b/app/App/Commands/Dump.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module App.Commands.Dump where @@ -13,6 +15,7 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Resource (MonadResource, runResourceT) import Data.Char (isPrint) +import Data.Generics.Product.Any import Data.List import Data.Maybe import Data.Monoid @@ -25,10 +28,8 @@ import Options.Applicative import System.Locale (defaultTimeLocale, iso8601DateFormat) -import qualified App.Commands.Options.Lens as L 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.Lens as L import qualified Data.Attoparsec.ByteString as AP import qualified Data.Binary as G import qualified Data.Binary.Get as G @@ -65,8 +66,8 @@ runDump :: MonadResource m => DumpOptions -> m () runDump opt = do - (_, hIn) <- openFileOrStd (opt ^. L.source) IO.ReadMode - (_, hOut) <- openFileOrStd (opt ^. L.target) IO.WriteMode + (_, hIn) <- openFileOrStd (opt ^. the @"source") IO.ReadMode + (_, hOut) <- openFileOrStd (opt ^. the @"target") IO.WriteMode contents <- liftIO $ LBS.hGetContents hIn @@ -75,7 +76,7 @@ liftIO $ IO.hPutStrLn IO.stderr $ "Error occured: " <> errorMessage return () Right segments -> do - let filenames = fromMaybe "" . (^. L.meta . L.filename) <$> segments + let filenames = fromMaybe "" . (^. the @"meta" . the @"filename") <$> segments let namedSegments = zip filenames segments forM_ (zip [0..] namedSegments) $ \(i :: Int, (filename, segment)) -> do @@ -83,67 +84,67 @@ then liftIO $ IO.hPutStrLn hOut $ "==== [" <> show i <> "] ====" else liftIO $ IO.hPutStrLn hOut $ "==== [" <> show i <> "] " <> T.unpack filename <> " ====" - case segment ^. L.meta . L.format of + case segment ^. the @"meta" . the @"format" of Just (Known F.StringZ) -> do - when (LBS.length (segment ^. L.payload) > 0) $ - forM_ (init (LBS.split 0 (segment ^. L.payload))) $ \bs -> + 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 ^. L.payload)) $ \bs -> + 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 ^. L.payload)) $ \bs -> do + 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 `div` 1000) ^. from microseconds liftIO $ IO.hPutStrLn hOut $ showTime (posixSecondsToUTCTime t) <> " (" <> show w <> " ms)" Just (Known F.TimeMicros64LE) -> - forM_ (LBS.chunkBy 8 (segment ^. L.payload)) $ \bs -> do + 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 ^. L.payload)) $ \bs -> do + 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.Int64LE) -> - forM_ (LBS.chunkBy 8 (segment ^. L.payload)) $ \bs -> do + 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 ^. L.payload)) $ \bs -> do + 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 ^. L.payload)) $ \bs -> do + 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 ^. L.payload)) $ \bs -> do + 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 ^. L.payload)) $ \bs -> do + 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 ^. L.payload)) $ \bs -> do + 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 ^. L.payload)) $ \bs -> do + 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 ^. L.payload)) $ \bs -> do + 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 ^. L.payload) + liftIO $ LBSC.hPutStrLn hOut (segment ^. the @"payload") Just (Known F.BitString) -> - liftIO $ IO.hPutStrLn hOut (bitShow (segment ^. L.payload)) + liftIO $ IO.hPutStrLn hOut (bitShow (segment ^. the @"payload")) _ -> - forM_ (zip (LBS.chunkBy 16 (segment ^. L.payload)) [0 :: Int, 16..]) $ \(bs, j) -> do + 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 " " diff --git a/app/App/Commands/EncodeFiles.hs b/app/App/Commands/EncodeFiles.hs --- a/app/App/Commands/EncodeFiles.hs +++ b/app/App/Commands/EncodeFiles.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module App.Commands.EncodeFiles where @@ -10,16 +12,16 @@ import Control.Monad import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Resource (MonadResource, runResourceT) +import Data.Generics.Product.Any import Data.Monoid import Options.Applicative -import qualified App.Commands.Options.Lens as L -import qualified Data.ByteString as BS -import qualified Data.Conduit as C -import qualified Data.Conduit.Binary as C -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified System.IO as IO +import qualified Data.ByteString as BS +import qualified Data.Conduit as C +import qualified Data.Conduit.Binary as C +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified System.IO as IO parseEncodeFilesOptions :: Parser EncodeFilesOptions parseEncodeFilesOptions = EncodeFilesOptions @@ -45,7 +47,7 @@ runEncodeFiles :: MonadResource m => EncodeFilesOptions -> m () runEncodeFiles opt = do - let sourcePath = opt ^. L.source + let sourcePath = opt ^. the @"source" filenamesContents <- liftIO $ BS.readFile (sourcePath <> "/.asif/filenames") let filenames = mfilter (/= "") $ T.decodeUtf8 <$> BS.split 0 filenamesContents @@ -54,9 +56,9 @@ liftIO $ IO.hSeek h IO.SeekFromEnd 0 return h - let contents = segmentsRawC (opt ^. L.asifType) handles + let contents = segmentsRawC (opt ^. the @"asifType") handles - (_, hTarget) <- openFileOrStd (opt ^. L.target) IO.WriteMode + (_, hTarget) <- openFileOrStd (opt ^. the @"target") IO.WriteMode C.runConduit $ contents .| C.sinkHandle hTarget diff --git a/app/App/Commands/ExtractFiles.hs b/app/App/Commands/ExtractFiles.hs --- a/app/App/Commands/ExtractFiles.hs +++ b/app/App/Commands/ExtractFiles.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module App.Commands.ExtractFiles where @@ -9,21 +11,20 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Resource (MonadResource, runResourceT) +import Data.Generics.Product.Any import Data.List import Data.Maybe import Data.Monoid import Options.Applicative import System.Directory -import qualified App.Commands.Options.Lens as L -import qualified Arbor.File.Format.Asif.Lens as L -import qualified Data.Attoparsec.ByteString as AP -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Map as M -import qualified Data.Text as T -import qualified System.Directory as IO -import qualified System.IO as IO +import qualified Data.Attoparsec.ByteString as AP +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map as M +import qualified Data.Text as T +import qualified System.Directory as IO +import qualified System.IO as IO parseExtractFilesOptions :: Parser ExtractFilesOptions parseExtractFilesOptions = ExtractFilesOptions @@ -44,16 +45,16 @@ runExtractFiles :: MonadResource m => ExtractFilesOptions -> m () runExtractFiles opt = do - (_, hIn) <- openFileOrStd (opt ^. L.source) IO.ReadMode + (_, hIn) <- openFileOrStd (opt ^. the @"source") IO.ReadMode contents <- liftIO $ LBS.hGetContents hIn case extractSegments magic contents of Left errorMessage -> do liftIO $ IO.hPutStrLn IO.stderr $ "Error occured: " <> errorMessage return () Right segments -> do - let filenames = fromMaybe "" . (^. L.meta . L.filename) <$> segments + let filenames = fromMaybe "" . (^. the @"meta" . the @"filename") <$> segments let namedSegments = M.fromList $ mfilter ((/= "") . fst) (zip filenames segments) - let targetPath = opt ^. L.target + let targetPath = opt ^. the @"target" liftIO $ IO.hPutStrLn IO.stderr $ "Writing to: " <> targetPath liftIO $ createDirectoryIfMissing True targetPath @@ -64,7 +65,7 @@ let outFilename = T.pack targetPath <> "/" <> filename let basename = mconcat (intersperse "/" (init (T.splitOn "/" outFilename))) liftIO $ IO.createDirectoryIfMissing True (T.unpack basename) - liftIO $ LBS.writeFile (T.unpack outFilename) (segment ^. L.payload) + liftIO $ LBS.writeFile (T.unpack outFilename) (segment ^. the @"payload") Nothing -> liftIO $ IO.hPutStrLn IO.stderr $ "Segment " <> show i <> " has no filename. Skipping" diff --git a/app/App/Commands/ExtractSegments.hs b/app/App/Commands/ExtractSegments.hs --- a/app/App/Commands/ExtractSegments.hs +++ b/app/App/Commands/ExtractSegments.hs @@ -1,4 +1,6 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module App.Commands.ExtractSegments where @@ -9,17 +11,16 @@ import Control.Monad import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Resource (MonadResource, runResourceT) +import Data.Generics.Product.Any import Data.Monoid import Options.Applicative import System.Directory import Text.Printf -import qualified App.Commands.Options.Lens as L -import qualified Arbor.File.Format.Asif.Lens as L -import qualified Data.Attoparsec.ByteString as AP -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified System.IO as IO +import qualified Data.Attoparsec.ByteString as AP +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified System.IO as IO parseExtractSegmentsOptions :: Parser ExtractSegmentsOptions parseExtractSegmentsOptions = ExtractSegmentsOptions @@ -40,7 +41,7 @@ runExtractSegments :: MonadResource m => ExtractSegmentsOptions -> m () runExtractSegments opt = do - (_, hIn) <- openFileOrStd (opt ^. L.source) IO.ReadMode + (_, hIn) <- openFileOrStd (opt ^. the @"source") IO.ReadMode contents <- liftIO $ LBS.hGetContents hIn -- TODO pass in magic case extractSegments magic contents of @@ -48,12 +49,12 @@ liftIO $ IO.hPutStrLn IO.stderr $ "Error occured: " <> errorMessage return () Right segments -> do - let targetPath = opt ^. L.target + let targetPath = opt ^. the @"target" liftIO $ IO.hPutStrLn IO.stderr $ "Writing to: " <> targetPath liftIO $ createDirectoryIfMissing True targetPath forM_ (zip [0..] segments) $ \(i :: Int, segment) -> - liftIO $ LBS.writeFile (targetPath <> "/" <> printf "%03d" i <> ".seg") (segment ^. L.payload) + liftIO $ LBS.writeFile (targetPath <> "/" <> printf "%03d" i <> ".seg") (segment ^. the @"payload") where magic = AP.string "seg:" *> (BS.pack <$> many AP.anyWord8) AP. "\"seg:????\"" diff --git a/app/App/Commands/Options/Lens.hs b/app/App/Commands/Options/Lens.hs deleted file mode 100644 --- a/app/App/Commands/Options/Lens.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TemplateHaskell #-} - -module App.Commands.Options.Lens where - -import App.Commands.Options.Type -import Control.Lens - -makeFields ''DumpOptions -makeFields ''EncodeFilesOptions -makeFields ''ExtractFilesOptions -makeFields ''ExtractSegmentsOptions diff --git a/app/App/Commands/Options/Type.hs b/app/App/Commands/Options/Type.hs --- a/app/App/Commands/Options/Type.hs +++ b/app/App/Commands/Options/Type.hs @@ -1,22 +1,27 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} + module App.Commands.Options.Type where +import GHC.Generics + data EncodeFilesOptions = EncodeFilesOptions - { encodeFilesOptionsSource :: FilePath - , encodeFilesOptionsTarget :: FilePath - , encodeFilesOptionsAsifType :: String - } deriving (Eq, Show) + { source :: FilePath + , target :: FilePath + , asifType :: String + } deriving (Eq, Show, Generic) data ExtractFilesOptions = ExtractFilesOptions - { extractFilesOptionsSource :: FilePath - , extractFilesOptionsTarget :: FilePath - } deriving (Eq, Show) + { source :: FilePath + , target :: FilePath + } deriving (Eq, Show, Generic) data ExtractSegmentsOptions = ExtractSegmentsOptions - { extractSegmentsOptionsSource :: FilePath - , extractSegmentsOptionsTarget :: FilePath - } deriving (Eq, Show) + { source :: FilePath + , target :: FilePath + } deriving (Eq, Show, Generic) data DumpOptions = DumpOptions - { dumpOptionsSource :: FilePath - , dumpOptionsTarget :: FilePath - } deriving (Eq, Show) + { source :: FilePath + , target :: FilePath + } deriving (Eq, Show, Generic) diff --git a/asif.cabal b/asif.cabal --- a/asif.cabal +++ b/asif.cabal @@ -2,16 +2,16 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 975b1a79df9badb8768dba82941d8968275d859920847e829d62a65978901884 +-- hash: de051b0b916332afc5b6b544ffaf3c0cabbf5c7dbc32317927f1dbe7b6e0c55c name: asif -version: 1.0.0 +version: 2.0.0 description: Please see the README on Github at category: Services homepage: https://github.com/packetloop/asif#readme bug-reports: https://github.com/packetloop/asif/issues -author: Tyler Durden -maintainer: tyler.durden@arbor.net +author: Arbor Networks +maintainer: mayhem@arbor.net copyright: Arbor Networks license: MIT license-file: LICENSE @@ -42,6 +42,7 @@ , cpu , either , exceptions + , generic-lens , hw-bits , iproute , lens @@ -63,7 +64,6 @@ Arbor.File.Format.Asif.Format Arbor.File.Format.Asif.Get Arbor.File.Format.Asif.IO - Arbor.File.Format.Asif.Lens Arbor.File.Format.Asif.Lookup Arbor.File.Format.Asif.Segment Arbor.File.Format.Asif.Type @@ -94,6 +94,7 @@ , directory , either , exceptions + , generic-lens , hw-bits , iproute , lens @@ -110,7 +111,6 @@ App.Commands.EncodeFiles App.Commands.ExtractFiles App.Commands.ExtractSegments - App.Commands.Options.Lens App.Commands.Options.Type App.IO Paths_asif @@ -137,6 +137,7 @@ , cpu , either , exceptions + , generic-lens , hedgehog , hspec , hw-bits diff --git a/src/Arbor/File/Format/Asif/ByteString/Builder.hs b/src/Arbor/File/Format/Asif/ByteString/Builder.hs --- a/src/Arbor/File/Format/Asif/ByteString/Builder.hs +++ b/src/Arbor/File/Format/Asif/ByteString/Builder.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} + module Arbor.File.Format.Asif.ByteString.Builder ( magicString , withSize @@ -7,7 +10,6 @@ , magicLength ) where -import Arbor.File.Format.Asif.Type import Arbor.File.Format.Asif.Whatever import Conduit import Control.Lens @@ -15,6 +17,7 @@ import Data.Bits import Data.ByteString.Builder import Data.Conduit (Source) +import Data.Generics.Product.Any import Data.Int import Data.Maybe import Data.Monoid @@ -25,7 +28,7 @@ import qualified Arbor.File.Format.Asif.Format as F import qualified Arbor.File.Format.Asif.IO as IO -import qualified Arbor.File.Format.Asif.Lens as L +import qualified Arbor.File.Format.Asif.Type as Z import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as B import qualified Data.ByteString.Lazy as LBS @@ -91,7 +94,7 @@ segmentsC :: (MonadIO m, MonadResource m) => String -> Maybe POSIXTime - -> [Segment IO.Handle] + -> [Z.Segment IO.Handle] -> m (Source m BS.ByteString) segmentsC asifType maybeTimestamp metas = do fileTime <- maybe (liftIO getPOSIXTime) return maybeTimestamp @@ -99,18 +102,18 @@ (_, _, hCreateTimes ) <- IO.openTempFile Nothing "asif-timestamps" (_, _, hFormats ) <- IO.openTempFile Nothing "asif-formats" - let metaMeta = metaCreateTime fileTime - let metaFilenames = segment hFilenames $ metaMeta <> metaFilename ".asif/filenames" <> metaFormat (Known F.StringZ) - let metaCreateTimes = segment hCreateTimes $ metaMeta <> metaFilename ".asif/createtimes" <> metaFormat (Known F.TimeMicros64LE) - let metaFormats = segment hFormats $ metaMeta <> metaFilename ".asif/formats" <> metaFormat (Known F.StringZ) + let metaMeta = Z.metaCreateTime fileTime + let metaFilenames = Z.segment hFilenames $ metaMeta <> Z.metaFilename ".asif/filenames" <> Z.metaFormat (Known F.StringZ) + let metaCreateTimes = Z.segment hCreateTimes $ metaMeta <> Z.metaFilename ".asif/createtimes" <> Z.metaFormat (Known F.TimeMicros64LE) + let metaFormats = Z.segment hFormats $ metaMeta <> Z.metaFilename ".asif/formats" <> Z.metaFormat (Known F.StringZ) let moreMetas = metaFilenames:metaCreateTimes:metaFormats:metas forM_ moreMetas $ \meta -> do - liftIO $ B.hPutBuilder hFilenames $ B.byteString (meta ^. L.meta . L.filename & fromMaybe "" & T.encodeUtf8) <> B.word8 0 - liftIO $ B.hPutBuilder hCreateTimes $ B.int64LE $ (meta ^. L.meta . L.createTime) <&> (^. microseconds) & fromMaybe 0 - liftIO $ B.hPutBuilder hFormats $ B.byteString (meta ^. L.meta . L.format <&> tShowWhatever & fromMaybe "" & T.encodeUtf8) <> B.word8 0 + liftIO $ B.hPutBuilder hFilenames $ B.byteString (meta ^. the @"meta" . the @"filename" & fromMaybe "" & T.encodeUtf8) <> B.word8 0 + liftIO $ B.hPutBuilder hCreateTimes $ B.int64LE $ (meta ^. the @"meta" . the @"createTime") <&> (^. microseconds) & fromMaybe 0 + liftIO $ B.hPutBuilder hFormats $ B.byteString (meta ^. the @"meta" . the @"format" <&> tShowWhatever & fromMaybe "" & T.encodeUtf8) <> B.word8 0 return () - let source = segmentsRawC asifType ((^. L.payload) <$> moreMetas) + let source = segmentsRawC asifType ((^. the @"payload") <$> moreMetas) return source diff --git a/src/Arbor/File/Format/Asif/Format.hs b/src/Arbor/File/Format/Asif/Format.hs --- a/src/Arbor/File/Format/Asif/Format.hs +++ b/src/Arbor/File/Format/Asif/Format.hs @@ -1,5 +1,9 @@ +{-# LANGUAGE DeriveGeneric #-} + module Arbor.File.Format.Asif.Format where +import GHC.Generics + data Format = Binary | BitString @@ -18,4 +22,4 @@ | Word16LE | Word32LE | Word64LE - deriving (Eq, Read, Show) + deriving (Eq, Read, Show, Generic) diff --git a/src/Arbor/File/Format/Asif/Lens.hs b/src/Arbor/File/Format/Asif/Lens.hs deleted file mode 100644 --- a/src/Arbor/File/Format/Asif/Lens.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TemplateHaskell #-} - -module Arbor.File.Format.Asif.Lens where - -import Arbor.File.Format.Asif.Format -import Arbor.File.Format.Asif.Type -import Control.Lens - -makeFields ''Format -makeFields ''Segment -makeFields ''SegmentMeta diff --git a/src/Arbor/File/Format/Asif/Segment.hs b/src/Arbor/File/Format/Asif/Segment.hs --- a/src/Arbor/File/Format/Asif/Segment.hs +++ b/src/Arbor/File/Format/Asif/Segment.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} + module Arbor.File.Format.Asif.Segment - ( Segment(..) + ( Z.Segment(..) , mkDefaultSegment , extractSegments , extractNamedSegments @@ -9,27 +12,27 @@ import Arbor.File.Format.Asif.ByIndex import Arbor.File.Format.Asif.Get import Arbor.File.Format.Asif.Lookup -import Arbor.File.Format.Asif.Type import Control.Lens import Control.Monad import Data.Binary.Get +import Data.Generics.Product.Any import Data.Maybe import Data.Monoid import Data.Text (Text, pack) import qualified Arbor.File.Format.Asif.Extract as E import qualified Arbor.File.Format.Asif.Get as G -import qualified Arbor.File.Format.Asif.Lens as L +import qualified Arbor.File.Format.Asif.Type as Z import qualified Data.Attoparsec.ByteString as AP import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LC8 import qualified Data.Map.Strict as M -mkDefaultSegment :: LBS.ByteString -> Segment LBS.ByteString -mkDefaultSegment bs = segment bs mempty +mkDefaultSegment :: LBS.ByteString -> Z.Segment LBS.ByteString +mkDefaultSegment bs = Z.segment bs mempty -extractSegments :: AP.Parser BS.ByteString -> LBS.ByteString -> Either String [Segment LBS.ByteString] +extractSegments :: AP.Parser BS.ByteString -> LBS.ByteString -> Either String [Z.Segment LBS.ByteString] extractSegments magicParser bs = do bss <- extractSegmentByteStrings magicParser bs case bss of @@ -40,18 +43,18 @@ let metas = mempty <> ByIndex (replicate (length bss) mempty) - <> ByIndex (metaFilename <$> filenames) - <> ByIndex (metaCreateTime <$> lookupSegment ".asif/createtimes" namedSegments (E.list G.getTimeMicro64)) - <> ByIndex (metaMaybeFormat <$> lookupSegment ".asif/formats" namedSegments E.formats) + <> ByIndex (Z.metaFilename <$> filenames) + <> ByIndex (Z.metaCreateTime <$> lookupSegment ".asif/createtimes" namedSegments (E.list G.getTimeMicro64)) + <> ByIndex (Z.metaMaybeFormat <$> lookupSegment ".asif/formats" namedSegments E.formats) - return $ uncurry segment <$> zip bss (unByIndex metas) + return $ uncurry Z.segment <$> zip bss (unByIndex metas) else return (mkDefaultSegment <$> bss) _ -> return (mkDefaultSegment <$> bss) -extractNamedSegments :: AP.Parser BS.ByteString -> LBS.ByteString -> Either String (M.Map Text (Segment LBS.ByteString)) +extractNamedSegments :: AP.Parser BS.ByteString -> LBS.ByteString -> Either String (M.Map Text (Z.Segment LBS.ByteString)) extractNamedSegments magicParser bs = do segments <- extractSegments magicParser bs - let filenames = fromMaybe "" . (^. L.meta . L.filename) <$> segments + let filenames = fromMaybe "" . (^. the @"meta" . the @"filename") <$> segments return $ M.fromList $ zip filenames segments extractSegmentByteStrings :: AP.Parser BS.ByteString -> LBS.ByteString -> Either String [LBS.ByteString] @@ -64,7 +67,7 @@ fail "XXX segments not read correctly" return segs -segmentNamed :: String -> M.Map Text (Segment LC8.ByteString) -> Either String LC8.ByteString +segmentNamed :: String -> M.Map Text (Z.Segment LC8.ByteString) -> Either String LC8.ByteString segmentNamed name segments = do - let seg = M.lookup (pack name) segments >>= (\s -> Just (s ^. L.payload)) + let seg = M.lookup (pack name) segments >>= (\s -> Just (s ^. the @"payload")) seg & maybe (Left ("Missing segment: " ++ name)) Right diff --git a/src/Arbor/File/Format/Asif/Type.hs b/src/Arbor/File/Format/Asif/Type.hs --- a/src/Arbor/File/Format/Asif/Type.hs +++ b/src/Arbor/File/Format/Asif/Type.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveGeneric #-} + module Arbor.File.Format.Asif.Type where import Arbor.File.Format.Asif.Format (Format) @@ -6,55 +8,56 @@ import Data.Semigroup import Data.Text (Text) import Data.Thyme.Clock.POSIX (POSIXTime) +import GHC.Generics data SegmentMeta = SegmentMeta - { _segmentMetaCreateTime :: Maybe POSIXTime - , _segmentMetaFilename :: Maybe Text - , _segmentMetaFormat :: Maybe (Whatever Format) - } deriving (Eq, Show) + { createTime :: Maybe POSIXTime + , filename :: Maybe Text + , format :: Maybe (Whatever Format) + } deriving (Eq, Show, Generic) instance Semigroup SegmentMeta where a <> b = SegmentMeta - { _segmentMetaCreateTime = _segmentMetaCreateTime a `secondJust` _segmentMetaCreateTime b - , _segmentMetaFilename = _segmentMetaFilename a `secondJust` _segmentMetaFilename b - , _segmentMetaFormat = _segmentMetaFormat a `secondJust` _segmentMetaFormat b + { createTime = createTime a `secondJust` createTime b + , filename = filename a `secondJust` filename b + , format = format a `secondJust` format b } instance Monoid SegmentMeta where mappend = (<>) mempty = SegmentMeta - { _segmentMetaCreateTime = Nothing - , _segmentMetaFilename = Nothing - , _segmentMetaFormat = Nothing + { createTime = Nothing + , filename = Nothing + , format = Nothing } data Segment a = Segment - { _segmentMeta :: SegmentMeta - , _segmentPayload :: a - } + { meta :: SegmentMeta + , payload :: a + } deriving Generic segment :: a -> SegmentMeta -> Segment a -segment payload meta = Segment - { _segmentMeta = meta - , _segmentPayload = payload +segment payload' meta' = Segment + { meta = meta' + , payload = payload' } metaCreateTime :: POSIXTime -> SegmentMeta metaCreateTime time = mempty - { _segmentMetaCreateTime = Just time + { createTime = Just time } metaFilename :: Text -> SegmentMeta metaFilename filePath = mempty - { _segmentMetaFilename = Just filePath + { filename = Just filePath } metaFormat :: Whatever Format -> SegmentMeta -metaFormat format = mempty - { _segmentMetaFormat = Just format +metaFormat format' = mempty + { format = Just format' } metaMaybeFormat :: Maybe (Whatever Format) -> SegmentMeta metaMaybeFormat maybeFormat = mempty - { _segmentMetaFormat = maybeFormat + { format = maybeFormat } diff --git a/src/Arbor/File/Format/Asif/Whatever.hs b/src/Arbor/File/Format/Asif/Whatever.hs --- a/src/Arbor/File/Format/Asif/Whatever.hs +++ b/src/Arbor/File/Format/Asif/Whatever.hs @@ -1,6 +1,9 @@ +{-# LANGUAGE DeriveGeneric #-} + module Arbor.File.Format.Asif.Whatever where import Data.Text (Text) +import GHC.Generics import GHC.Read import Text.ParserCombinators.ReadP as P import Text.ParserCombinators.ReadPrec @@ -8,7 +11,7 @@ import qualified Data.Text as T import qualified Text.ParserCombinators.ReadPrec as R -data Whatever a = Known a | Unknown Text deriving Eq +data Whatever a = Known a | Unknown Text deriving (Eq, Generic) instance Show a => Show (Whatever a) where showsPrec n (Known a) = showsPrec n a diff --git a/test/Arbor/File/Format/Asif/ByteString/BuilderSpec.hs b/test/Arbor/File/Format/Asif/ByteString/BuilderSpec.hs --- a/test/Arbor/File/Format/Asif/ByteString/BuilderSpec.hs +++ b/test/Arbor/File/Format/Asif/ByteString/BuilderSpec.hs @@ -1,21 +1,21 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Arbor.File.Format.Asif.ByteString.BuilderSpec ( spec ) where -import Arbor.File.Format.Asif.ByteString.Builder import Arbor.File.Format.Asif.Segment import Conduit import Control.Lens +import Data.Generics.Product import HaskellWorks.Hspec.Hedgehog import Hedgehog -import System.IO (openTempFile) +import System.IO (openTempFile) import Test.Hspec -import qualified Arbor.File.Format.Asif as C import qualified Arbor.File.Format.Asif.ByteString.Builder as LB -import qualified Arbor.File.Format.Asif.Lens as L import qualified Data.Attoparsec.ByteString as AP import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS @@ -58,4 +58,4 @@ let Right segments = extractSegments (AP.string "seg:wxyz") contents - ((^. L.payload) <$> segments) === [b1, b2, b3] + ((^. the @"payload") <$> segments) === [b1, b2, b3] diff --git a/test/Arbor/File/Format/Asif/Data/IpSpec.hs b/test/Arbor/File/Format/Asif/Data/IpSpec.hs --- a/test/Arbor/File/Format/Asif/Data/IpSpec.hs +++ b/test/Arbor/File/Format/Asif/Data/IpSpec.hs @@ -14,7 +14,6 @@ import qualified Arbor.File.Format.Asif as C import qualified Arbor.File.Format.Asif.ByteString.Builder as LB -import qualified Arbor.File.Format.Asif.Lens as L import qualified Data.Attoparsec.ByteString as AP import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS