Test driver mongo en haskell

Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-
dependencies:
- base >= 4.7 && < 5
- mongoDB >= 2.5.0.0
- mtl
- split
- async
- monad-parallel
-}

module Main where

import Database.MongoDB
import Control.Monad.Trans (liftIO)
import Control.Monad.IO.Class
import Data.List.Split
import Control.Concurrent.Async (mapConcurrently)
import Control.Monad.Parallel as Par
import Data.Traversable as T

-- https://wiki.haskell.org/Data_declaration_with_constraint
--type MongoRunner = (Action m a -> m a)

type Chunk a = [a]
data BulkResult = BulkResult { chunks :: Int, docs :: Int } deriving Show

main :: IO ()
main = do
   pipe <- connect (host "127.0.0.1")
   let runAction = access pipe master "perfimmo"
   --e <- runAction myRun
   docs <- runAction prepareData
   result <- bulkInsert runAction docs
   close pipe
   print result

prepareData :: Action IO [Document]
prepareData = do
    clearTickets2
    allTickets

-- TODO need sequence instead of mapConcurently
--  cf. https://hackage.haskell.org/package/monad-parallel-0.7.2.3/docs/Control-Monad-Parallel.html#v:sequence
bulkInsert :: {-MonadIO m => -}(Action m a -> m a) -> [Document] -> IO BulkResult
bulkInsert run docs = do
    r <- parChunks
    pure BulkResult { chunks = length r, docs = totalDocs r }
    where bulkOps :: [Action IO [Value]] = map (insertAll "detailedTickets2") (splitEvery 2000 docs)
          parChunks :: IO[[Value]] = Par.sequence $ fmap run bulkOps
          totalDocs = length . concat

myRun :: Action IO ()
myRun = do
    clearTickets2
    tickets <- allTickets
    ids <- bulkInsertTicket tickets
    println $ show $ length ids

clearTickets2 :: Action IO ()
clearTickets2 = delete (select [] "detailedTickets2")

allTickets :: Action IO [Document]
allTickets = rest =<< find (select [] "detailedTickets")

bulkInsertTicket :: [Document] -> Action IO (Chunk [Value])
bulkInsertTicket tickets = T.sequence act
    where act :: [Action IO [Value]] = map (insertAll "detailedTickets2") (splitEvery 2000 tickets)

println :: String -> Action IO ()
println s = liftIO $ putStrLn s