From 6dc02d4d3a1f951a7d07a2a63a4331fd710cc1f0 Mon Sep 17 00:00:00 2001 From: Alexander Kobjolke Date: Tue, 17 Oct 2023 15:27:39 +0200 Subject: [PATCH] Add Encode typeclass --- app/filepack.hs | 4 +-- filepack.cabal | 76 +++++++++++++++++++++++++++++++++++++--- package.yaml | 35 +++++++++++++++++- src/FilePack.hs | 13 +++---- src/FilePack/Encode.hs | 49 ++++++++++++++++++++++++++ src/FilePack/FileData.hs | 42 ++++++++++++++++++++++ test/doctest/Doctest.hs | 10 ++++++ test/spec/Spec.hs | 1 + 8 files changed, 214 insertions(+), 16 deletions(-) create mode 100644 src/FilePack/Encode.hs create mode 100644 src/FilePack/FileData.hs create mode 100644 test/doctest/Doctest.hs create mode 100644 test/spec/Spec.hs diff --git a/app/filepack.hs b/app/filepack.hs index 85d2730..62c68fc 100644 --- a/app/filepack.hs +++ b/app/filepack.hs @@ -1,6 +1,6 @@ module Main (main) where -import FilePack (greet) +import FilePack (filepack) main :: IO () -main = greet "Hello, World!" +main = filepack diff --git a/filepack.cabal b/filepack.cabal index 39f4312..89ec9bf 100644 --- a/filepack.cabal +++ b/filepack.cabal @@ -17,13 +17,23 @@ extra-source-files: library exposed-modules: FilePack + FilePack.Encode + FilePack.FileData other-modules: Paths_filepack hs-source-dirs: src - ghc-options: -Wall + default-extensions: + BlockArguments + OverloadedStrings + ImportQualifiedPost + ghc-options: -Wall -fdefer-typed-holes build-depends: - base >=4.13 && <5 + base + , base64-bytestring + , bytestring + , text + , unix default-language: GHC2021 executable filepack @@ -32,8 +42,66 @@ executable filepack Paths_filepack hs-source-dirs: app - ghc-options: -Wall + default-extensions: + BlockArguments + OverloadedStrings + ImportQualifiedPost + ghc-options: -Wall -fdefer-typed-holes build-depends: - base >=4.13 && <5 + base + , base64-bytestring + , bytestring , filepack + , text + , unix + default-language: GHC2021 + +test-suite doctest + type: exitcode-stdio-1.0 + main-is: Doctest.hs + other-modules: + Paths_filepack + hs-source-dirs: + test/doctest + default-extensions: + BlockArguments + OverloadedStrings + ImportQualifiedPost + ghc-options: -Wall -fdefer-typed-holes + build-tool-depends: + doctest:doctest + build-depends: + base + , base64-bytestring + , bytestring + , process + , text + , unix + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_filepack + hs-source-dirs: + test/spec + default-extensions: + BlockArguments + OverloadedStrings + ImportQualifiedPost + ghc-options: -Wall -fdefer-typed-holes + cpp-options: -DTEST + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + QuickCheck + , base + , base64-bytestring + , bytestring + , filepack + , hspec + , quickcheck-instances + , text + , unix default-language: GHC2021 diff --git a/package.yaml b/package.yaml index 9a610aa..14d55d7 100644 --- a/package.yaml +++ b/package.yaml @@ -9,10 +9,20 @@ extra-source-files: - README.org dependencies: - - base >= 4.13 && < 5 + - base + - unix + - text + - bytestring + - base64-bytestring ghc-options: - -Wall + - -fdefer-typed-holes + +default-extensions: + - BlockArguments + - OverloadedStrings + - ImportQualifiedPost library: source-dirs: src @@ -27,3 +37,26 @@ executables: - filepack verbatim: default-language: GHC2021 + +tests: + spec: + cpp-options: -DTEST + main: Spec.hs + source-dirs: + - test/spec + dependencies: + - filepack + - hspec + - QuickCheck + - quickcheck-instances + # - quickcheck-text + build-tools: hspec-discover + verbatim: + default-language: GHC2021 + doctest: + main: Doctest.hs + source-dirs: + - test/doctest + dependencies: + - process + build-tools: doctest diff --git a/src/FilePack.hs b/src/FilePack.hs index 1c106f2..95681fd 100644 --- a/src/FilePack.hs +++ b/src/FilePack.hs @@ -1,11 +1,6 @@ -module FilePack ( - greet, -) where +module FilePack where -import Control.Monad.IO.Class ( - MonadIO, - liftIO, - ) +import FilePack.FileData -greet :: MonadIO m => String -> m () -greet = liftIO <$> putStrLn +filepack :: IO () +filepack = putStrLn "filepack" diff --git a/src/FilePack/Encode.hs b/src/FilePack/Encode.hs new file mode 100644 index 0000000..91cc71e --- /dev/null +++ b/src/FilePack/Encode.hs @@ -0,0 +1,49 @@ +module FilePack.Encode where + +import Data.Bits (Bits (shift), (.&.)) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BC +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Data.Word (Word32, Word8) + +class Encode a where + encode :: a -> ByteString + +instance Encode ByteString where + encode = id + +instance Encode Text where + encode = encodeUtf8 + +instance Encode String where + encode = BC.pack + +type Byte = Word8 + +{- | @word32ToBytes@ splits a 32bit word into its 4 byte components. + + >>> word32ToBytes 0xdeadbeef + (222,173,190,239) +-} +word32ToBytes :: Word32 -> (Byte, Byte, Byte, Byte) +word32ToBytes word = (a, b, c, d) + where + !a = fromIntegral $ (word .&. 0xff000000) `shift` (-24) + !b = fromIntegral $ (word .&. 0x00ff0000) `shift` (-16) + !c = fromIntegral $ (word .&. 0x0000ff00) `shift` (-8) + !d = fromIntegral $ (word .&. 0x000000ff) `shift` (-0) + +{- | @word32ToByteString@ encodes a 32-bit wide word into a bytestring. + + >>> word32ToByteString 0xdeadbeef + "\222\173\190\239" +-} +word32ToByteString :: Word32 -> ByteString +word32ToByteString word = + let (a, b, c, d) = word32ToBytes word + in BS.pack [a, b, c, d] + +instance Encode Word32 where + encode = word32ToByteString diff --git a/src/FilePack/FileData.hs b/src/FilePack/FileData.hs new file mode 100644 index 0000000..2cbae28 --- /dev/null +++ b/src/FilePack/FileData.hs @@ -0,0 +1,42 @@ +module FilePack.FileData where + +import Data.ByteString (ByteString) + +import Data.Text (Text) + +import Data.ByteString.Base64 qualified as B64 +import Data.ByteString.Char8 qualified as BC +import GHC.Natural (Natural) +import System.Posix.Types (CMode (..), FileMode) +import Text.Read (readEither) + +import FilePack.Encode () + +data FileData = FileData + { fileName :: Text + , fileSize :: Natural + , filePermissions :: FileMode + , fileData :: ByteString + } + deriving (Eq, Read, Show) + +newtype FilePack = FilePack {getPackedFiles :: [FileData]} + deriving (Eq, Read, Show) + +{- | @packFiles@ takes a FilePack and encodes it into a serialized form. + + >>> import Data.Text qualified as T + >>> import Data.ByteString qualified as BS + >>> import System.Posix.Files (stdFileMode) + >>> let sampleFileData = FileData{fileName=T.pack "foo.txt", fileSize = 1024, filePermissions = stdFileMode, fileData = BS.empty} + >>> let sampleFilePack = FilePack [sampleFileData] + >>> (Right sampleFilePack) == (unpackFiles . packFiles $ sampleFilePack) + True +-} +packFiles :: FilePack -> ByteString +packFiles = B64.encode . BC.pack . show + +-- | @unpackFiles@ tries to recover a FilePack from its serialized form. +unpackFiles :: ByteString -> Either String FilePack +unpackFiles serializedData = + B64.decode serializedData >>= readEither . BC.unpack diff --git a/test/doctest/Doctest.hs b/test/doctest/Doctest.hs new file mode 100644 index 0000000..72c84cf --- /dev/null +++ b/test/doctest/Doctest.hs @@ -0,0 +1,10 @@ +-- | Rn the doctest executable +module Main where + +import System.Process (callProcess) + +doctest :: [String] -> IO () +doctest = callProcess "doctest" + +main :: IO () +main = doctest ["--fast", "src"] diff --git a/test/spec/Spec.hs b/test/spec/Spec.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/test/spec/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}