<commit_before>{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE PackageImports, RankNTypes #-}
{-# LANGUAGE CPP #-}
module Database.Persist.MongoDB
--    ( MongoPersist
    ( withMongoDBConn
    , withMongoDBPool
    , runMongoDBConn 
    , HostName
    , u
    , DB.Action
    -- , DB.MasterOrSlaveOk(..)
    , DB.AccessMode(..)
    , DB.master
    , DB.slaveOk
    , (DB.=:)
    , ConnectionPool
    , module Database.Persist
    ) where

import Database.Persist
import Database.Persist.Base
import qualified Control.Monad.IO.Class as Trans
import qualified Database.MongoDB as DB
import Database.MongoDB.Query (Database, Failure)
import Control.Applicative (Applicative)
import Control.Exception (toException)
import Data.UString (u)
import qualified Data.CompactString.UTF8 as CS
import Data.Enumerator hiding (map, length, concatMap)
import Network.Socket (HostName)
import Data.Maybe (mapMaybe, fromJust)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Serialize as S
import Control.Exception (Exception, throwIO)
import Data.Typeable (Typeable)
--import Control.Monad.Context (Context (..))
--import Control.Monad.Throw (Throw (..))
import Control.Monad.MVar (MonadMVar (..))
import Prelude hiding (catch)
--import Network.Abstract (Internet (..), ANetwork (..))
import qualified System.IO.Pool as Pool

#ifdef DEBUG
import ErrorLocation (debug)
#endif

{-
newtype MongoPersist m a = MongoPersist { unMongoPersist :: ReaderT DB.Database (Action m) a }
    deriving (Monad, Trans.MonadIO, Functor, Applicative)

instance Monad m => Context DB.Database (MongoPersist m) where
    context = MongoPersist ask
    push f (MongoPersist x) = MongoPersist $ local f x

instance Monad m => Context DB.MasterOrSlaveOk (MongoPersist m) where
    context = MongoPersist context
    push f (MongoPersist x) = MongoPersist $ push f x

instance Monad m => Context DB.Pipe (MongoPersist m) where
    context = MongoPersist context
    push f (MongoPersist x) = MongoPersist $ push f x

instance Monad m => Context DB.WriteMode (MongoPersist m) where
    context = MongoPersist context
    push f (MongoPersist x) = MongoPersist $ push f x

instance Monad m => Throw Failure (MongoPersist m) where
    throw = MongoPersist . throw
    catch (MongoPersist x) f =
        MongoPersist $ ReaderT $ \db -> catch (runReaderT x db) (f' db)
      where
        f' db e = runReaderT (unMongoPersist (f e)) db
-}

--type ConnectionPool = DB.ConnPool DB.Host
type ConnectionPool = (Pool.Pool IOError DB.Pipe, Database)

withMongoDBConn :: (Trans.MonadIO m, Applicative m) =>
  Database -> HostName -> (ConnectionPool -> m b) -> m b
withMongoDBConn dbname hostname = withMongoDBPool dbname hostname 1

withMongoDBPool :: (Trans.MonadIO m, Applicative m) =>
  Database -> HostName -> Int -> (ConnectionPool -> m b) -> m b
withMongoDBPool dbname hostname connectionPoolSize connectionReader = do
  --pool <- runReaderT (DB.newConnPool connectionPoolSize $ DB.host hostname) $ ANetwork Internet
  pool <- Trans.liftIO $ Pool.newPool Pool.Factory { Pool.newResource  = DB.connect (DB.host hostname)
                                                  , Pool.killResource = DB.close
                                                  , Pool.isExpired    = DB.isClosed
                                                  }
                                     connectionPoolSize
  connectionReader (pool, dbname)

{-
runMongoDBConn :: (DB.Service s, Trans.MonadIO m) =>
                                    DB.WriteMode
                                 -> DB.MasterOrSlaveOk
                                 -> MongoPersist m b
                                 -> DB.ConnPool s
                                 -> DB.Database
                                 -> m b
runMongoDBConn wm ms (MongoPersist a) cp db = do
    res <- DB.access wm ms cp (runReaderT a db)
    either (Trans.liftIO . throwIO . MongoDBException) return res
-}


--runMongoDBConn :: (Trans.MonadIO m) => DB.AccessMode -> DB.Database -> DB.Action m b -> ConnectionPool -> m b
runMongoDBConn :: (Trans.MonadIO m) => DB.AccessMode  ->  DB.Action m b -> ConnectionPool -> m b
runMongoDBConn accessMode action (pool, databaseName) = do
  pipe <- Trans.liftIO $ DB.runIOE $ Pool.aResource pool
  res  <- DB.access pipe accessMode databaseName action
  either (Trans.liftIO . throwIO . MongoDBException) return res


newtype MongoDBException = MongoDBException Failure
    deriving (Show, Typeable)
instance Exception MongoDBException

value :: DB.Field -> DB.Value
value (_ DB.:= val) = val

rightPersistVals :: (PersistEntity val) => EntityDef -> [DB.Field] -> val
rightPersistVals ent vals = case wrapFromPersistValues ent vals of
      Left e -> error e
      Right v -> v

filterByKey :: (PersistEntity val) => Key DB.Action val -> DB.Document
filterByKey k = [u"_id" DB.=: keyToDbOid k]

queryByKey :: (PersistEntity val) => Key DB.Action val -> EntityDef -> DB.Query 
queryByKey k entity = (DB.select (filterByKey k) (u $ entityName entity)) 

selectByKey :: (PersistEntity val) => Key DB.Action val -> EntityDef -> DB.Selection 
selectByKey k entity = (DB.select (filterByKey k) (u $ entityName entity))
<commit_msg>remove commented out code<commit_after>{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE PackageImports, RankNTypes #-}
{-# LANGUAGE CPP #-}
module Database.Persist.MongoDB
--    ( MongoPersist
    ( withMongoDBConn
    , withMongoDBPool
    , runMongoDBConn 
    , HostName
    , u
    , DB.Action
    -- , DB.MasterOrSlaveOk(..)
    , DB.AccessMode(..)
    , DB.master
    , DB.slaveOk
    , (DB.=:)
    , ConnectionPool
    , module Database.Persist
    ) where

import Database.Persist
import Database.Persist.Base
import qualified Control.Monad.IO.Class as Trans
import qualified Database.MongoDB as DB
import Database.MongoDB.Query (Database, Failure)
import Control.Applicative (Applicative)
import Control.Exception (toException)
import Data.UString (u)
import qualified Data.CompactString.UTF8 as CS
import Data.Enumerator hiding (map, length, concatMap)
import Network.Socket (HostName)
import Data.Maybe (mapMaybe, fromJust)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Serialize as S
import Control.Exception (Exception, throwIO)
import Data.Typeable (Typeable)
import Control.Monad.MVar (MonadMVar (..))
import Prelude hiding (catch)
import qualified System.IO.Pool as Pool

#ifdef DEBUG
import FileLocation (debug)
#endif

newtype MongoPersist m a = MongoPersist { unMongoPersist :: ReaderT DB.Database (Action m) a }
    deriving (Monad, Trans.MonadIO, Functor, Applicative)
type ConnectionPool = (Pool.Pool IOError DB.Pipe, Database)

withMongoDBConn :: (Trans.MonadIO m, Applicative m) =>
  Database -> HostName -> (ConnectionPool -> m b) -> m b
withMongoDBConn dbname hostname = withMongoDBPool dbname hostname 1

withMongoDBPool :: (Trans.MonadIO m, Applicative m) =>
  Database -> HostName -> Int -> (ConnectionPool -> m b) -> m b
withMongoDBPool dbname hostname connectionPoolSize connectionReader = do
  --pool <- runReaderT (DB.newConnPool connectionPoolSize $ DB.host hostname) $ ANetwork Internet
  pool <- Trans.liftIO $ Pool.newPool Pool.Factory { Pool.newResource  = DB.connect (DB.host hostname)
                                                  , Pool.killResource = DB.close
                                                  , Pool.isExpired    = DB.isClosed
                                                  }
                                     connectionPoolSize
  connectionReader (pool, dbname)

--runMongoDBConn :: (Trans.MonadIO m) => DB.AccessMode -> DB.Database -> DB.Action m b -> ConnectionPool -> m b
runMongoDBConn :: (Trans.MonadIO m) => DB.AccessMode  ->  DB.Action m b -> ConnectionPool -> m b
runMongoDBConn accessMode action (pool, databaseName) = do
  pipe <- Trans.liftIO $ DB.runIOE $ Pool.aResource pool
  res  <- DB.access pipe accessMode databaseName action
  either (Trans.liftIO . throwIO . MongoDBException) return res


newtype MongoDBException = MongoDBException Failure
    deriving (Show, Typeable)
instance Exception MongoDBException

value :: DB.Field -> DB.Value
value (_ DB.:= val) = val

rightPersistVals :: (PersistEntity val) => EntityDef -> [DB.Field] -> val
rightPersistVals ent vals = case wrapFromPersistValues ent vals of
      Left e -> error e
      Right v -> v

filterByKey :: (PersistEntity val) => Key DB.Action val -> DB.Document
filterByKey k = [u"_id" DB.=: keyToDbOid k]

queryByKey :: (PersistEntity val) => Key DB.Action val -> EntityDef -> DB.Query 
queryByKey k entity = (DB.select (filterByKey k) (u $ entityName entity)) 

selectByKey :: (PersistEntity val) => Key DB.Action val -> EntityDef -> DB.Selection 
selectByKey k entity = (DB.select (filterByKey k) (u $ entityName entity))

{'fraction_non_alphanumeric': 0.10177281680892974, 'fraction_numerical': 0.0004377325454147516, 'mean_word_length': 2.957990472065829, 'pattern_counts': {'":': 0, '<': 12, '<?xml version=': 0, '>': 83, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 20, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1879380', 'n_tokens_mistral': 2832, 'n_tokens_neox': 2765, 'n_words': 827}