Add flakes

Co-authored-by: Mats Rauhala <mats.rauhala@iki.fi>
Reviewed-on: #2
Co-authored-by: Mats Rauhala <masse@rauhala.info>
Co-committed-by: Mats Rauhala <masse@rauhala.info>

addressbook.cabal

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

default.nix

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

flake.lock

@@ -0,0 +1,62 @@
+{
+  "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
+}

flake.nix

@@ -0,0 +1,53 @@
+{
+  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
+          ];
+        };
+      }
+    );
+}

src/Control/Addressbook/Streaming.hs

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

src/Data/Email/Header.hs

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

test/Test/Data/Email.hs

@@ -31,4 +31,7 @@ tests = testGroup "Data.Email"
   [ testCase "Can parse a sample email" $ do
       got <- parseToList sample
       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"])
   ]