Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

couchDB: PersistConfig instance

  • Loading branch information...
commit 60ab5616ba7075f4a00f18b3f2108db5e0bceaaf 1 parent 0957b56
@gregwebs gregwebs authored
View
60 experimental/couchDB/Database/Persist/CouchDB.hs
@@ -32,24 +32,28 @@ import Control.Applicative (Applicative)
import Text.JSON
import Data.Char
-import Data.List (intercalate, nub, nubBy)
+import Data.List (intercalate, nub) -- , nubBy)
import Data.Pool
import Data.Maybe
import Data.Digest.Pure.SHA
-- import Data.Object
-- import Data.Neither (MEither (..), meither)
-import Data.Enumerator (Stream (..), Step (..), Iteratee (..), returnI, run_, ($$))
+-- import Data.Enumerator (Stream (..), Step (..), Iteratee (..), returnI, run_, ($$))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as BL
-import qualified Data.Enumerator.List as EL
+-- import qualified Data.Enumerator.List as EL
import qualified Database.CouchDB as DB
import qualified Control.Exception.Base as E
+import Data.Aeson (Value (Object, Number), (.:), (.:?), (.!=), FromJSON(..))
+import Data.Time (NominalDiffTime)
+import Data.Attoparsec.Number
type Couch = (DB.CouchConn, DB.DB)
type ConnectionPool = Pool Couch
+
newtype (CouchReader m a) = CouchReader {unCouchConn :: ReaderT Couch m a}
deriving (Monad, MonadIO, MonadTrans, MonadCatchIO, Functor, Applicative)
@@ -82,8 +86,7 @@ withCouchDBPool :: (MonadBaseControl IO m, MonadIO m)
-> Int -- ^ number of connections to open
-> (ConnectionPool -> m b) -> m b
withCouchDBPool db host port = createPool
- (do unless (DB.isDBString db)
- (error "Wrong database name.")
+ (do unless (DB.isDBString db) $ error $ "Wrong database name: " ++ db
conn <- DB.createCouchConn host port
E.catch (run conn $ DB.createDB db)
(\(E.ErrorCall _) -> return ())
@@ -221,6 +224,7 @@ filtersToNames = nub . concatMap f
f (FilterOr fs) = concatMap f fs
f (FilterAnd fs) = concatMap f fs
+{-
opts :: [SelectOpt a] -> [(String, JSValue)]
opts = nubBy (\(x, _) (y, _) -> x == "descending" && x == y) . map o
-- The Asc and Desc options should be attribute dependent. Now, they just handle reversing of the output.
@@ -228,6 +232,7 @@ opts = nubBy (\(x, _) (y, _) -> x == "descending" && x == y) . map o
o (Desc _) = ("descending", JSBool True)
o (OffsetBy x) = ("skip", JSRational False $ fromIntegral x)
o (LimitTo x) = ("limit", JSRational False $ fromIntegral x)
+-}
designName :: EntityDef -> DB.Doc
designName entity = DB.doc . (\(x:xs) -> toLower x : xs) $ (T.unpack $ unDBName $ entityDB entity)
@@ -247,6 +252,7 @@ runView conn db design name dict views =
in liftIO $ E.catch query (\(E.ErrorCall _) -> create >> query)
-- This is not a very effective solution, since it takes the whole input in once. It should be rewritten completely.
+{-
select :: (PersistEntity val, MonadIO m) => [Filter val] -> [(String, JSValue)]
-> Step a' (CouchReader m) b -> [String] -> ((DB.Doc, PersistValue) -> a') -> Iteratee a' (CouchReader m) b
select f o (Continue k) vals process = do
@@ -258,6 +264,7 @@ select f o (Continue k) vals process = do
(conn, db) <- lift $ CouchReader ask
x <- runView conn db design name o [DB.ViewMap name $ defaultView t names filters]
returnI $$ k . Chunks $ map process x
+-}
instance (MonadIO m, MonadBaseControl IO m) => PersistStore CouchReader m where
insert v = do
@@ -311,7 +318,7 @@ fieldName = unDBName . fieldDB . persistFieldDef
instance (MonadIO m, MonadBaseControl IO m) => PersistQuery CouchReader m where
update key = modify (\u x -> return $ foldr field x u) key
where -- e = entityDef $ dummyFromKey key
- field upd@(Update updField value up) doc = case up of
+ field (Update updField value up) doc = case up of
Assign -> execute doc $ const val
Add -> execute doc $ op (+) val
Subtract -> execute doc $ op (-) val
@@ -352,33 +359,34 @@ data CouchConf = CouchConf
, couchPoolSize :: Int
}
-{-
+newtype NoOrphanNominalDiffTime = NoOrphanNominalDiffTime NominalDiffTime
+ deriving (Show, Eq, Num)
+instance FromJSON NoOrphanNominalDiffTime where
+ parseJSON (Number (I x)) = (return . NoOrphanNominalDiffTime . fromInteger) x
+ parseJSON (Number (D x)) = (return . NoOrphanNominalDiffTime . fromRational . toRational) x
+ parseJSON _ = fail "couldn't parse diff time"
+
instance PersistConfig CouchConf where
type PersistConfigBackend CouchConf = CouchReader
type PersistConfigPool CouchConf = ConnectionPool
- withPool (CouchConf db host port poolsize) = withCouchDBPool db host port poolsize
+ -- createPoolConfig (CouchConf db host port poolsize) = withCouchDBPool db host port poolsize
runPool _ = runCouchDBConn
- loadConfig e' = meither Left Right $ do
- e <- go $ fromMapping e'
- db <- go $ lookupScalar "database" e
- host <- go $ lookupScalar "host" e
- pool <- (go $ lookupScalar "poolsize" e) >>= safeRead "poolsize"
- port <- (go $ lookupScalar "port" e) >>= safeRead "port"
+ loadConfig (Object o) = do
+ db <- o .: "database"
+ host <- o .:? "host" .!= "127.0.0.1"
+ port <- o .:? "port" .!= 5984 -- (PortNumber 5984)
+ pool <- o .:? "poolsize" .!= 1
+ {-
+ poolStripes <- o .:? "poolstripes" .!= 1
+ stripeConnections <- o .: "connections"
+ -- (NoOrphanNominalDiffTime connectionIdleTime) <- o .:? "connectionIdleTime" .!= 20
+ mUser <- o .:? "user"
+ mPass <- o .:? "password"
+ -}
return $ CouchConf { couchDatabase = T.unpack db
, couchHost = T.unpack host
, couchPort = port
, couchPoolSize = pool
}
- where
- go :: MEither ObjectExtractError a -> MEither String a
- go (MLeft e) = MLeft $ show e
- go (MRight a) = MRight a
-
-safeRead :: String -> T.Text -> MEither String Int
-safeRead name t = case reads s of
- (i, _):_ -> MRight i
- [] -> MLeft $ concat ["Invalid value for ", name, ": ", s]
- where
- s = T.unpack t
--}
+ loadConfig _ = mzero
View
2  experimental/couchDB/persistent-couchdb.cabal
@@ -17,6 +17,8 @@ library
, enumerator
, pool
, json
+ , aeson
+ , attoparsec
, transformers-base
, MonadCatchIO-transformers
, transformers >= 0.2.1 && < 0.3
Please sign in to comment.
Something went wrong with that request. Please try again.