freckle-app 1.7.0.0 → 1.7.1.0

raw patch · 6 files changed

+545/−77 lines, 6 filesdep +cassavadep +conduit-extradep +monad-validatedep ~Blammodep ~Globdep ~MonadRandomPVP ok

version bump matches the API change (PVP)

Dependencies added: cassava, conduit-extra, monad-validate, nonempty-containers

Dependency ranges changed: Blammo, Glob, MonadRandom, QuickCheck, aeson, aws-xray-client-persistent, aws-xray-client-wai, base, bugsnag, bytestring, case-insensitive, conduit, containers, datadog, doctest, dotenv, ekg-core, envparse, errors, exceptions, extra, filepath, hashable, hspec, hspec-expectations-lifted, http-client, http-link-header, http-types, immortal, lens, lens-aeson, memcache, monad-control, mtl, network-uri, path-pieces, persistent, persistent-postgresql, postgresql-simple, primitive, resource-pool, safe, scientist, semigroupoids, template-haskell, text, time, transformers, transformers-base, typed-process, unliftio, unliftio-core, unordered-containers, vector, wai, wai-extra, yaml, yesod-core

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−1
• freckle-app.cabal +86/−75
• library/Freckle/App/Csv.hs +260/−0
• library/Freckle/App/Database.hs +1/−0
• package.yaml +10/−1
• tests/Freckle/App/CsvSpec.hs +183/−0

@@ -1,4 +1,8 @@-## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.7.0.0...main)+## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.7.1.0...main)++## [v1.7.1.0](https://github.com/freckle/freckle-app/compare/v1.7.0.0...v1.7.1.0)++- Add Incremental CSV parsing  ## [v1.7.0.0](https://github.com/freckle/freckle-app/compare/v1.6.0.3...v1.7.0.0) 

@@ -1,6 +1,6 @@ cabal-version:      1.18 name:               freckle-app-version:            1.7.0.0+version:            1.7.1.0 license:            MIT license-file:       LICENSE maintainer:         Freckle Education@@ -26,6 +26,7 @@         Freckle.App.Aeson         Freckle.App.Bugsnag         Freckle.App.Bugsnag.MetaData+        Freckle.App.Csv         Freckle.App.Database         Freckle.App.Dotenv         Freckle.App.Ecs@@ -69,66 +70,70 @@         TypeApplications TypeFamilies      build-depends:-        Blammo >=1.0.2.2,-        Glob >=0.9.3,-        MonadRandom >=0.5.1.1,-        aeson >=1.5.2.0,-        aws-xray-client-persistent >=0.1.0.5,-        aws-xray-client-wai >=0.1.0.2,-        base >=4.11.1.0 && <5,-        bugsnag >=1.0.0.1,-        bytestring >=0.10.8.2,-        case-insensitive >=1.2.0.11,-        conduit >=1.3.1,-        containers >=0.5.11.0,-        datadog >=0.2.3.0,-        doctest >=0.16.0.1,-        dotenv >=0.5.2.5,-        ekg-core >=0.1.1.7,-        envparse >=0.5.0,-        errors >=2.3.0,-        exceptions >=0.10.0,-        extra >=1.6.14,-        filepath >=1.4.2,-        hashable >=1.2.7.0,+        Blammo,+        Glob,+        MonadRandom,+        aeson,+        aws-xray-client-persistent,+        aws-xray-client-wai,+        base >=4.12.0.0 && <5,+        bugsnag,+        bytestring,+        case-insensitive,+        cassava,+        conduit,+        conduit-extra,+        containers,+        datadog,+        doctest,+        dotenv,+        ekg-core,+        envparse,+        errors,+        exceptions,+        extra,+        filepath,+        hashable,         hspec >=2.8.1,         hspec-core >=2.8.1,-        hspec-expectations-lifted >=0.10.0,+        hspec-expectations-lifted,         hspec-junit-formatter >=1.1.0.1,-        http-client >=0.5.14,+        http-client,         http-conduit >=2.3.5,-        http-link-header >=1.0.3.1,-        http-types >=0.12.2,-        immortal >=0.3,-        lens >=4.16.1,-        memcache >=0.3.0.1,-        monad-control >=1.0.2.3,-        mtl >=2.2.2,-        network-uri >=2.6.1.0,-        path-pieces >=0.2.1,-        persistent >=2.9.0,-        persistent-postgresql >=2.9.0,-        postgresql-simple >=0.6.2,-        primitive >=0.7.0.1,-        resource-pool >=0.2.3.2,+        http-link-header,+        http-types,+        immortal,+        lens,+        memcache,+        monad-control,+        monad-validate,+        mtl,+        network-uri,+        nonempty-containers,+        path-pieces,+        persistent,+        persistent-postgresql,+        postgresql-simple,+        primitive,+        resource-pool,         retry >=0.8.1.0,-        safe >=0.3.17,-        scientist >=0.0.0.0,-        semigroupoids >=5.2.2,-        template-haskell >=2.13.0.0,-        text >=1.2.3.1,-        time >=1.8.0.2,-        transformers >=0.5.5.0,-        transformers-base >=0.4.5.2,-        typed-process >=0.2.3.0,-        unliftio >=0.2.9.0,-        unliftio-core >=0.1.2.0,-        unordered-containers >=0.2.10.0,-        vector >=0.12.0.2,-        wai >=3.2.1.2,-        wai-extra >=3.0.29,-        yaml >=0.8.32,-        yesod-core >=1.6.9+        safe,+        scientist,+        semigroupoids,+        template-haskell,+        text,+        time,+        transformers,+        transformers-base,+        typed-process,+        unliftio,+        unliftio-core,+        unordered-containers,+        vector,+        wai,+        wai-extra,+        yaml,+        yesod-core  test-suite doctest     type:               exitcode-stdio-1.0@@ -146,8 +151,8 @@         TypeApplications TypeFamilies      build-depends:-        base >=4.11.1.0 && <5,-        freckle-app -any+        base >=4.12.0.0 && <5,+        freckle-app  test-suite spec     type:               exitcode-stdio-1.0@@ -156,6 +161,7 @@     other-modules:         Freckle.App.Bugsnag.MetaDataSpec         Freckle.App.BugsnagSpec+        Freckle.App.CsvSpec         Freckle.App.HttpSpec         Freckle.App.Memcached.ServersSpec         Freckle.App.MemcachedSpec@@ -177,20 +183,25 @@      ghc-options:        -threaded -rtsopts -with-rtsopts=-N     build-depends:-        Blammo >=1.0.2.2,-        QuickCheck >=2.13.1,-        aeson >=1.5.2.0,-        base >=4.11.1.0 && <5,-        bugsnag >=1.0.0.1,-        bytestring >=0.10.8.2,-        errors >=2.3.0,-        freckle-app -any,-        hspec >=2.8.1,-        http-types >=0.12.2,-        lens >=4.16.1,-        lens-aeson >=1.1,-        memcache >=0.3.0.1,-        postgresql-simple >=0.6.2,-        unliftio >=0.2.9.0,-        wai >=3.2.1.2,-        wai-extra >=3.0.29+        Blammo,+        QuickCheck,+        aeson,+        base >=4.12.0.0 && <5,+        bugsnag,+        bytestring,+        cassava,+        conduit,+        errors,+        freckle-app,+        hspec,+        http-types,+        lens,+        lens-aeson,+        memcache,+        monad-validate,+        nonempty-containers,+        postgresql-simple,+        unliftio,+        vector,+        wai,+        wai-extra

@@ -0,0 +1,260 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Stream, parse, and validate CSVs+--+-- A minor extension of [cassava](https://hackage.haskell.org/package/cassava).+-- Using `MonadValidate` and `Conduit`.+--+module Freckle.App.Csv+  ( csvWithValidationSink+  , csvWithParserAndValidationSink+   -- * Conduit Primitives+  , runCsvConduit+  , decodeCsv+  -- * Header Validation+  , ValidateHeader+  , validateHeader+  , hasHeader+  , defaultValidateOrderedHeader+  -- * Exceptions+  , CsvException(..)+  -- * Options+  , defaultOptions+  ) where++import Freckle.App.Prelude++import Conduit+import Control.Monad (foldM)+import Control.Monad.Validate+  (MonadValidate(..), Validate, ValidateT, refute, runValidate, runValidateT)+import Data.Aeson (KeyValue(..), ToJSON(..), object, pairs, (.=))+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS8+import qualified Data.Conduit.Combinators as Conduit+import qualified Data.Conduit.Text as Conduit+import Data.Csv+  ( DefaultOrdered+  , FromNamedRecord(..)+  , Header+  , Name+  , NamedRecord+  , Parser+  , defaultDecodeOptions+  , defaultOptions+  , headerOrder+  )+import qualified Data.Csv.Incremental as CsvI+import Data.Functor.Bind (Bind)+import qualified Data.HashMap.Strict as HashMap+import qualified Data.List.NonEmpty as NE+import Data.Proxy (Proxy(Proxy))+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Data.Sequence.NonEmpty (NESeq)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Vector as V+import UnliftIO.Exception (handle)++-- | Treat CSV header line as 1+--+-- CSVs can break rows over lines, but we don't currently handle that.+--+headerLineNumber :: Int+headerLineNumber = 1++class ValidateHeader a where+  validateHeader :: (Bind m, Monad m) => proxy a -> Header -> ValidateT (NESeq String) m ()++hasHeader :: Monad m => Header -> Name -> ValidateT (NESeq String) m ()+hasHeader h name+  | name `V.elem` h = pure ()+  | otherwise = refute . pure $ BS8.unpack name++defaultValidateOrderedHeader+  :: forall a proxy m+   . (DefaultOrdered a, Monad m)+  => proxy a+  -> Header+  -> ValidateT (NESeq String) m ()+defaultValidateOrderedHeader _ h =+  traverse_ (h `hasHeader`) $ headerOrder (error "old school haskell" :: a)++-- | Stream parse a CSV+--+-- - Expects UTF-8+-- - Provides incremental validation+--+csvWithValidationSink+  :: forall a b err m+   . ( MonadThrow m+     , MonadUnliftIO m+     , PrimMonad m+     , ValidateHeader a+     , FromNamedRecord a+     )+  => ConduitT () ByteString (ResourceT m) ()+  -- ^ CSV as a byte stream+  -> (Vector a -> Validate (NonEmpty (CsvException err)) (Vector b))+  -- ^ Validation to apply to resulting rows+  -> m (Validate (NonEmpty (CsvException err)) (Vector b))+csvWithValidationSink =+  csvWithParserAndValidationSink (validateHeader (Proxy @a)) parseNamedRecord++-- | Stream parse a CSV with a custom parser+--+-- - Expects UTF-8+-- - Provides incremental validation+--+csvWithParserAndValidationSink+  :: forall a b err m+   . (MonadThrow m, MonadUnliftIO m, PrimMonad m)+  => (Header -> Validate (NESeq String) ())+  -> (NamedRecord -> Parser a)+  -- ^ Custom record parser+  -> ConduitT () ByteString (ResourceT m) ()+  -- ^ CSV as a byte stream+  -> (Vector a -> Validate (NonEmpty (CsvException err)) (Vector b))+  -- ^ Validation to apply to resulting rows+  -> m (Validate (NonEmpty (CsvException err)) (Vector b))+csvWithParserAndValidationSink headerValidator p source validation = do+  validatedCsv <-+    runCsvConduit+    $ transPipe lift source+    .| decodeCsvWithP headerValidator p+    .| transPipe lift sinkVector++  pure $ case validatedCsv of+    Left errs -> refute $ NE.fromList $ toList errs+    Right rows -> validation rows++-- | Run a CSV conduit handling invalid UTF8+runCsvConduit+  :: forall r m err+   . MonadUnliftIO m+  => ConduitT () Void (ValidateT (Seq (CsvException err)) (ResourceT m)) r+  -> m (Either (Seq (CsvException err)) r)+runCsvConduit = handle nonUtf8 . runResourceT . runValidateT . runConduit+ where+  nonUtf8 :: Conduit.TextException -> m (Either (Seq (CsvException err)) r)+  nonUtf8 = const $ pure $ Left $ pure CsvUnknownFileEncoding++-- | Stream in 'ByteString's and parse records in constant space+decodeCsv+  :: forall a m err+   . ( MonadThrow m+     , MonadValidate (Seq (CsvException err)) m+     , ValidateHeader a+     , FromNamedRecord a+     )+  => ConduitT ByteString a m ()+decodeCsv = decodeCsvWithP (validateHeader (Proxy @a)) parseNamedRecord++-- | Stream in 'ByteString's and parse records in constant space with a custom+-- record parser+--+decodeCsvWithP+  :: forall a m err+   . (MonadThrow m, MonadValidate (Seq (CsvException err)) m)+  => (Header -> Validate (NESeq String) ())+  -> (NamedRecord -> Parser a)+  -- ^ Custom record parser+  -> ConduitT ByteString a m ()+decodeCsvWithP headerValidator p =+  Conduit.detectUtf -- Strip any BOMs and decode UTF-*+    .| Conduit.encodeUtf8 -- Cassava needs ByteString+    .| parseCsv headerValidator p++parseCsv+  :: forall a m err+   . (MonadValidate (Seq (CsvException err)) m)+  => (Header -> Validate (NESeq String) ())+  -> (NamedRecord -> Parser a)+  -> ConduitT ByteString a m ()+parseCsv headerValidator p = parseHeader+  headerValidator+  (CsvI.decodeByNameWithP (stripParser p) defaultDecodeOptions)++data CsvException a+  = CsvMissingColumn !Text+  | CsvParseException !Int !Text+  | CsvFileNotFound+  | CsvUnknownFileEncoding+  | CsvExceptionExtension a+  -- ^ A constructor for providing extensible csv exceptions+  deriving stock (Eq, Show)++instance ToJSON a => ToJSON (CsvException a) where+  toJSON = csvExceptionPairs object toJSON+  toEncoding = csvExceptionPairs (pairs . mconcat) toEncoding++csvExceptionPairs+  :: KeyValue kv => ([kv] -> r) -> (a -> r) -> CsvException a -> r+csvExceptionPairs done extend = \case+  CsvMissingColumn column -> done+    [ "message" .= ("Missing column " <> tshow column)+    , "missingColumn" .= column+    ]+  CsvParseException rowNumber message ->+    done ["rowNumber" .= rowNumber, "message" .= message]+  CsvFileNotFound -> done ["message" .= ("file not found" :: Text)]+  CsvUnknownFileEncoding ->+    done ["message" .= ("file could not be decoded" :: Text)]+  CsvExceptionExtension a -> extend a++parseHeader+  :: forall a m err+   . (MonadValidate (Seq (CsvException err)) m)+  => (Header -> Validate (NESeq String) ())+  -> CsvI.HeaderParser (CsvI.Parser a)+  -> ConduitT ByteString a m ()+parseHeader headerValidator = \case+  CsvI.FailH _ err ->+    lift $ refute $ pure $ CsvParseException headerLineNumber $ pack err+  CsvI.PartialH k ->+    await >>= (parseHeader headerValidator . k) . fromMaybe mempty+  CsvI.DoneH header parser ->+    case runValidate $ headerValidator $ fmap stripUtf8 header of+      Right{} -> parseRow (succ headerLineNumber) parser+      Left errs ->+        lift $ refute $ Seq.fromList $ CsvMissingColumn . pack <$> toList errs++parseRow+  :: MonadValidate (Seq (CsvException err)) m+  => Int+  -> CsvI.Parser a+  -> ConduitT ByteString a m ()+parseRow rowNumber parse = case parse of+  CsvI.Fail _ err ->+    lift $ dispute $ pure $ CsvParseException rowNumber $ pack err+  CsvI.Many rows k -> do+    !newRowNumber <- handleRows rows+    await >>= parseRow newRowNumber . k . fromMaybe mempty+  CsvI.Done rows -> void $ handleRows rows+  where handleRows = foldM handleRow rowNumber++handleRow+  :: MonadValidate (Seq (CsvException err)) m+  => Int+  -> Either String a+  -> ConduitT i a m Int+handleRow rowNumber result = do+  either+    (lift . dispute . pure . CsvParseException rowNumber . pack)+    yield+    result+  pure $ rowNumber + 1++-- | Strip leading/trailing whitespace from each key-value pairs+stripNamedRecord :: NamedRecord -> NamedRecord+stripNamedRecord =+  HashMap.fromList . fmap (bimap stripUtf8 stripUtf8) . HashMap.toList++-- | Strip leading/trailing whitespace from @'ByteString'@ via UTF-8+stripUtf8 :: ByteString -> ByteString+stripUtf8 = T.encodeUtf8 . T.strip . T.decodeUtf8++-- | Take a custom parser and return one that strips prior to parsing+stripParser :: (NamedRecord -> Parser a) -> (NamedRecord -> Parser a)+stripParser p = p . stripNamedRecord

@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeOperators #-}  -- | Database access for your @App@ module Freckle.App.Database

@@ -1,6 +1,6 @@ --- name: freckle-app-version: 1.7.0.0+version: 1.7.1.0 maintainer: Freckle Education category: Utils github: freckle/freckle-app@@ -55,7 +55,9 @@     - bugsnag     - bytestring     - case-insensitive+    - cassava     - conduit+    - conduit-extra     - containers     - datadog     - doctest@@ -79,8 +81,10 @@     - lens     - memcache     - monad-control+    - monad-validate     - mtl     - network-uri+    - nonempty-containers     - path-pieces     - persistent     - persistent-postgresql@@ -117,6 +121,8 @@       - aeson       - bugsnag       - bytestring+      - cassava+      - conduit       - errors       - freckle-app       - hspec@@ -125,7 +131,10 @@       - lens-aeson       - memcache       - postgresql-simple+      - monad-validate+      - nonempty-containers       - unliftio+      - vector       - wai       - wai-extra 

@@ -0,0 +1,183 @@+module Freckle.App.CsvSpec+  ( spec+  ) where++import Freckle.App.Prelude++import Conduit (ConduitT, MonadThrow, ResourceT, yieldMany)+import Control.Monad.Validate (Validate, refute, runValidate)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.Csv hiding (header)+import qualified Data.List.NonEmpty as NE+import Data.Sequence.NonEmpty (NESeq)+import qualified Data.Vector as V+import Data.Void (Void)+import Freckle.App.Csv+import Test.Hspec++data Foo = Foo+  { someInt :: Int+  , someText :: Text+  }+  deriving stock (Eq, Show, Generic)++data FooError = BadFoo+  deriving stock (Eq, Show)++instance FromNamedRecord Foo where+  parseNamedRecord = genericParseNamedRecord defaultOptions++instance ToNamedRecord Foo where+  toNamedRecord = genericToNamedRecord defaultOptions++instance DefaultOrdered Foo where+  headerOrder = genericHeaderOrder defaultOptions++instance FromRecord Foo where+  parseRecord = genericParseRecord defaultOptions++instance ToRecord Foo where+  toRecord = genericToRecord defaultOptions++instance ValidateHeader Foo where+  validateHeader = defaultValidateOrderedHeader++spec :: Spec+spec = do+  describe "defaultOptions" $ do+    let+      contentRows = "123,this is some text\r\n456,this is more text\r\n"+      content = "someInt,someText\r\n" <> contentRows+      header = ["someInt", "someText"]+      rows :: [Foo]+      rows = [Foo 123 "this is some text", Foo 456 "this is more text"]+    it "should parse records as expected"+      $ decode HasHeader content+      `shouldBe` Right (V.fromList rows)++    it "should parse named records as expected"+      $ decodeByName content+      `shouldBe` Right (V.fromList header, V.fromList rows)++    it "should serialize records as expected"+      $ encode rows+      `shouldBe` contentRows++    it "should serialize named records as expected"+      $ encodeDefaultOrderedByName rows+      `shouldBe` content++  for_ [CustomParser, FromNamedRecordParser] $ \testType -> do+    describe (csvSinkTestName testType) $ do+      it "should generate errors for missing columns" $ do+        let source = yieldMany ["someInt,som_text\n", "3,meep\n", "4,morp\n"]+        result <- csvSinkTest testType source pure+        runValidate result+          `shouldBe` Left (pure $ CsvMissingColumn @Void "someText")++      it "should generate errors for parse errors" $ do+        result <- csvSinkTest testType (yieldMany []) pure+        runValidate result `shouldBe` Left+          (pure $ CsvParseException @Void 1 "parse error (not enough input)")++      it "should generate errors per row" $ do+        let+          source =+            yieldMany+              [ "someInt,someText\n"+              , "a,meep\n"+              , "1,flip\n"+              , "b,morp\n"+              , "c,merp\n"+              ]+          errorLine = \case+            CsvParseException i _ -> i+            _ -> -1+        result <- csvSinkTest testType source pure+        first (fmap errorLine) (runValidate result)+          `shouldBe` Left (NE.fromList [2, 4, 5])+++      it "should generate errors for non-utf8-encoded files" $ do+        let source = yieldMany [BS.pack [0XFF, 0XFF, 0XFF, 0XFF]]+        result <- csvSinkTest testType source pure+        runValidate result `shouldBe` Left (pure $ CsvUnknownFileEncoding @Void)++      it "should generate errors using user-specified validation" $ do+        let+          validate foo@Foo {..}+            | someInt < 4 = pure foo+            | otherwise = refute $ pure $ CsvExceptionExtension BadFoo+          source = yieldMany+            [ "someInt,someText\n"+            , "3,meep\n"+            , "4,morp\n"+            , "1,whomp\n"+            , "5,merp\n"+            ]++        result <- csvSinkTest testType source $ traverse validate+        runValidate result+          `shouldBe` Left+                       (NE.fromList+                         [ CsvExceptionExtension BadFoo+                         , CsvExceptionExtension BadFoo+                         ]+                       )++      it "should successfully parse a CSV" $ do+        let+          validate foo@Foo {..}+            | someInt < 4 = pure foo+            | otherwise = refute $ pure $ CsvExceptionExtension BadFoo+          source = yieldMany+            ["someInt,someText\n", "1,meep\n", "2,morp\n", "3,merp\n"]++        result <- csvSinkTest testType source $ traverse validate+        runValidate result `shouldBe` Right+          (V.fromList [Foo 1 "meep", Foo 2 "morp", Foo 3 "merp"])++      it "should successfully parse a CSV with weird whitespace" $ do+        let+          validate foo@Foo {..}+            | someInt < 4 = pure foo+            | otherwise = refute $ pure $ CsvExceptionExtension BadFoo+          source =+            yieldMany+              [ "someInt\t   ,someText\n"+              , "1, \t meep\n"+              , "2,morp\n"+              , "3 ,  merp\n"+              ]++        result <- csvSinkTest testType source $ traverse validate+        runValidate result `shouldBe` Right+          (V.fromList [Foo 1 "meep", Foo 2 "morp", Foo 3 "merp"])++data CSVSinkTest = CustomParser | FromNamedRecordParser++csvSinkTestName :: CSVSinkTest -> String+csvSinkTestName = \case+  CustomParser -> "csvWithParserAndValidationSink"+  FromNamedRecordParser -> "csvWithValidationSink"++customFooHeaderValidator :: Header -> Validate (NESeq String) ()+customFooHeaderValidator h = hasHeader h "someInt" *> hasHeader h "someText"++customFooP :: NamedRecord -> Parser Foo+customFooP r = Foo <$> r .: "someInt" <*> r .: "someText"++csvSinkTest+  :: forall err m+   . (MonadThrow m, MonadUnliftIO m, PrimMonad m)+  => CSVSinkTest+  -> ConduitT () ByteString (ResourceT m) ()+  -> ( Vector Foo+     -> Validate (NonEmpty (CsvException err)) (Vector Foo)+     )+  -> m (Validate (NonEmpty (CsvException err)) (Vector Foo))+csvSinkTest = \case+  CustomParser ->+    csvWithParserAndValidationSink customFooHeaderValidator customFooP+  FromNamedRecordParser -> csvWithValidationSink