Compare commits

..

4 Commits

Author SHA1 Message Date
537c0df198 Update tests 2021-10-29 22:39:27 +03:00
75aa615263 Clean up 2021-10-29 22:37:47 +03:00
a300c88cfb Try parallel 2021-10-29 22:09:43 +03:00
560ea23861 parallel 2021-10-29 20:47:04 +03:00
7 changed files with 31 additions and 169 deletions

View File

@ -42,7 +42,6 @@ library
, containers , containers
, filepath , filepath
, parallel , parallel
, unix
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall

View File

@ -1,7 +1,7 @@
{ mkDerivation, attoparsec, base, bytestring, conduit { mkDerivation, attoparsec, base, bytestring, conduit
, conduit-extra, containers, criterion, filepath, hedgehog , conduit-extra, containers, criterion, filepath, hedgehog
, hedgehog-corpus, HUnit, lens, lib, mtl, optparse-applicative , hedgehog-corpus, HUnit, lens, lib, mtl, optparse-applicative
, parallel, tasty, tasty-hedgehog, tasty-hunit, text, unix, vector , parallel, tasty, tasty-hedgehog, tasty-hunit, text, vector
}: }:
mkDerivation { mkDerivation {
pname = "addressbook"; pname = "addressbook";
@ -11,7 +11,7 @@ mkDerivation {
isExecutable = true; isExecutable = true;
libraryHaskellDepends = [ libraryHaskellDepends = [
attoparsec base bytestring conduit conduit-extra containers attoparsec base bytestring conduit conduit-extra containers
filepath lens mtl parallel text unix vector filepath lens mtl parallel text vector
]; ];
executableHaskellDepends = [ executableHaskellDepends = [
base bytestring containers criterion hedgehog-corpus base bytestring containers criterion hedgehog-corpus

View File

@ -1,62 +0,0 @@
{
"nodes": {
"easy-hls": {
"inputs": {
"nixpkgs": [
"nixpkgs"
]
},
"locked": {
"lastModified": 1637250802,
"narHash": "sha256-/crlHEVB148PGQLZCsHOR9L5qgvCAfRSocIoKgmMAhA=",
"owner": "jkachmar",
"repo": "easy-hls-nix",
"rev": "7c123399ef8a67dc0e505d9cf7f2c7f64f1cd847",
"type": "github"
},
"original": {
"owner": "jkachmar",
"repo": "easy-hls-nix",
"type": "github"
}
},
"flake-utils": {
"locked": {
"lastModified": 1637014545,
"narHash": "sha256-26IZAc5yzlD9FlDT54io1oqG/bBoyka+FJk5guaX4x4=",
"owner": "numtide",
"repo": "flake-utils",
"rev": "bba5dcc8e0b20ab664967ad83d24d64cb64ec4f4",
"type": "github"
},
"original": {
"owner": "numtide",
"repo": "flake-utils",
"type": "github"
}
},
"nixpkgs": {
"locked": {
"lastModified": 1637312849,
"narHash": "sha256-OhVZopkyryEfLyPwcXk2IQsdi80lj6TY1YFoMNZ4hCQ=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "e4806bb4416f88c20f8be0b8ef9b5b09ff9022a6",
"type": "github"
},
"original": {
"id": "nixpkgs",
"type": "indirect"
}
},
"root": {
"inputs": {
"easy-hls": "easy-hls",
"flake-utils": "flake-utils",
"nixpkgs": "nixpkgs"
}
}
},
"root": "root",
"version": 7
}

View File

@ -1,53 +0,0 @@
{
description = "addressbook";
inputs = {
easy-hls = {
url = "github:jkachmar/easy-hls-nix";
inputs.nixpkgs.follows = "nixpkgs";
};
flake-utils = {
url = "github:numtide/flake-utils";
};
};
outputs = { self, nixpkgs, flake-utils, easy-hls }:
{ overlay = final: prev: {
haskellPackages = prev.haskellPackages.override ( old: {
overrides = final.lib.composeExtensions (old.overrides or (_: _: {})) (f: p: {
addressbook = f.callPackage ./. {};
});
});
};
}
//
flake-utils.lib.eachSystem ["x86_64-linux" "x86_64-darwin"] ( system:
let
pkgs = import nixpkgs { inherit system; overlays = [ self.overlay ]; };
hp = pkgs.haskellPackages;
hls = (easy-hls.withGhcs [ hp.ghc ]).${system};
in
rec {
packages = { inherit (hp) addressbook; };
defaultPackage = packages.addressbook;
apps.addressbook = {
type = "app";
program = "${hp.addressbook}/bin/addressbook";
};
devShell = hp.shellFor {
packages = h: [h.addressbook];
withHoogle = true;
buildInputs = with pkgs; [
entr
cabal-install
hp.hlint
stylish-haskell
ghcid
hls
];
};
}
);
}

View File

@ -29,8 +29,6 @@ import qualified Data.ByteString.Lazy.Char8 as LBC
import System.IO.Unsafe (unsafeInterleaveIO) import System.IO.Unsafe (unsafeInterleaveIO)
import Control.Parallel.Strategies (rseq, parMap) import Control.Parallel.Strategies (rseq, parMap)
import qualified Data.List as L import qualified Data.List as L
import Control.Monad (unless)
import System.Posix (touchFile)
combine :: (MonadUnliftIO m, MonadResource m, MonadThrow m, MonadIO m) => ConduitM FilePath Header m () combine :: (MonadUnliftIO m, MonadResource m, MonadThrow m, MonadIO m) => ConduitM FilePath Header m ()
combine = await >>= \case combine = await >>= \case
@ -45,28 +43,23 @@ chunks n = L.unfoldr $ \case
run :: IO () run :: IO ()
run = do run = do
datDir <- fromMaybe "./" <$> lookupEnv "HOME" datDir <- fromMaybe "./" <$> lookupEnv "HOME"
let datFile = datDir </> ".addressbook.dat"
touchFile datFile
original <- Set.fromList . map LBS.toStrict . lbsLines <$> LBS.readFile datFile
xs <- LBS.getContents >>= stream xs <- LBS.getContents >>= stream
let set = original `Set.union` F.fold (parMap rseq F.fold (chunks 200 xs)) let set = F.fold (parMap rseq F.fold (chunks 20 xs))
unless (original == set) $
runResourceT $ runResourceT $
runConduit $ runConduit $
CL.sourceList (Set.elems set) CL.sourceList (Set.elems set)
.| C.map (<> "\n") .| C.map (<> "\n")
.| CB.sinkFileCautious datFile .| CB.sinkFileCautious (datDir </> ".addressbook.dat")
where where
separate = \case separate = \case
From x -> [x] From x -> [x]
To xs -> F.toList xs To xs -> F.toList xs
-- A set of (locally) unique addresses. Composes with parMap -- A set of (locally) unique addresses. Composes with parMap
lbsLines = LBS.split (fromIntegral $ ord '\n')
stream :: LBS.ByteString -> IO [Set ByteString] stream :: LBS.ByteString -> IO [Set ByteString]
stream = stream =
traverse (unsafeInterleaveIO . parse . LBC.unpack) traverse (unsafeInterleaveIO . parse . LBC.unpack)
. filter (not . LBS.null) . filter (not . LBS.null)
. lbsLines . LBS.split (fromIntegral $ ord '\n')
parse path = parse path =
runResourceT $ runResourceT $
runConduit $ runConduit $

View File

@ -1,5 +1,4 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ApplicativeDo #-}
module Data.Email.Header where module Data.Email.Header where
import qualified Data.Foldable as F import qualified Data.Foldable as F
@ -22,39 +21,28 @@ data Header
decode :: ByteString -> Either String Header decode :: ByteString -> Either String Header
decode = parseOnly parseHeader decode = parseOnly parseHeader
{-# INLINE decode #-} where
parseHeader :: Parser Header
parseHeader :: Parser Header parseHeader = parseFrom <|> parseTo
parseHeader = parseFrom <|> parseTo parseFrom :: Parser Header
{-# INLINE parseHeader #-} parseFrom = From <$> (string "From:" *> emptySpace *> (bracketEmail <|> email))
parseTo :: Parser Header
parseFrom :: Parser Header parseTo = To <$> (string "To:" *> emptySpace *> emails)
parseFrom = From <$> (string "From:" *> emptySpace *> (bracketEmail <|> email)) emptySpace = many' space
emails :: Parser (Vector ByteString)
parseTo :: Parser Header emails = V.fromList <$> (bracketEmail <|> email) `sepBy` char ','
parseTo = To <$> (string "To:" *> emptySpace *> emails) bracketEmail :: Parser ByteString
bracketEmail = do
emptySpace :: Parser ()
emptySpace = () <$ many' space
emails :: Parser (Vector ByteString)
emails = V.fromList <$> (bracketEmail <|> email) `sepBy` char ','
bracketEmail :: Parser ByteString
bracketEmail = do
_ <- manyTill anyChar (char '<') _ <- manyTill anyChar (char '<')
email email
{-# INLINE bracketEmail #-} email :: Parser ByteString
email = do
email :: Parser ByteString
email = do
_ <- many' space _ <- many' space
name <- BC.pack <$> many' (satisfy (\c -> not (isSpace c) && c /= '@')) name <- BC.pack <$> many' (satisfy (\c -> not (isSpace c) && c /= '@'))
_ <- char '@' _ <- char '@'
rest <- BC.pack <$> many' (satisfy (\c -> not (isSpace c) && c /= ',' && c /= '>' && c /= '<')) rest <- BC.pack <$> many' (satisfy (\c -> not (isSpace c) && c /= ',' && c /= '>'))
_ <- many' (notChar ',') _ <- many' (notChar ',')
pure (name <> "@" <> rest) pure (name <> "@" <> rest)
{-# INLINE email #-}
encode :: Header -> ByteString encode :: Header -> ByteString

View File

@ -31,7 +31,4 @@ tests = testGroup "Data.Email"
[ testCase "Can parse a sample email" $ do [ testCase "Can parse a sample email" $ do
got <- parseToList sample got <- parseToList sample
got @?= [ From "me@example.com", To ["you@example.com"]] got @?= [ From "me@example.com", To ["you@example.com"]]
, testCase "Combined mailto" $ do
let got = decode "To: James Doe<james.doe@example.com<mailto:james.doe@example.com>>"
got @?= Right (To ["james.doe@example.com"])
] ]