Skip to content
This repository
Browse code

add remoter server authentication

  • Loading branch information...
commit fd9ce6cdf425f2c7e56b72dd7c8a65a06030b434 1 parent b672f89
Greg Weber gregwebs authored
50 persistent-mongoDB/Database/Persist/MongoDB.hs
@@ -92,20 +92,22 @@ instance PathPiece (Key DB.Action entity) where
92 92
93 93
94 94 withMongoDBConn :: (Trans.MonadIO m, Applicative m) =>
95   - Database -> HostName -> UString -> UString ->(ConnectionPool -> m b) -> m b
96   -withMongoDBConn dbname hostname user pass = withMongoDBPool dbname hostname user pass 1
  95 + Database -> HostName -> Maybe (UString, UString) -> (ConnectionPool -> m b) -> m b
  96 +withMongoDBConn dbname hostname mauth = withMongoDBPool dbname hostname mauth 1
97 97
98   -connectMongoDB :: Database -> HostName -> UString -> UString -> DB.IOE DB.Pipe
99   -connectMongoDB dbname hostname user pass = do
  98 +connectMongoDB :: Database -> HostName -> Maybe (UString, UString) -> DB.IOE DB.Pipe
  99 +connectMongoDB dbname hostname mAuth = do
100 100 x <- DB.connect (DB.host hostname)
101   - _ <- DB.access x DB.UnconfirmedWrites dbname (DB.auth user pass)
  101 + _ <- case mAuth of
  102 + Just (user, pass) -> DB.access x DB.UnconfirmedWrites dbname (DB.auth user pass)
  103 + Nothing -> return undefined
102 104 return x
103 105
104 106 createMongoDBPool :: (Trans.MonadIO m, Applicative m) =>
105   - Database -> HostName -> UString -> UString -> Int -> m ConnectionPool
106   -createMongoDBPool dbname hostname user pass connectionPoolSize = do
  107 + Database -> HostName -> Maybe (UString, UString) -> Int -> m ConnectionPool
  108 +createMongoDBPool dbname hostname mAuth connectionPoolSize = do
107 109 --pool <- runReaderT (DB.newConnPool connectionPoolSize $ DB.host hostname) $ ANetwork Internet
108   - pool <- Trans.liftIO $ Pool.newPool Pool.Factory { Pool.newResource = connectMongoDB dbname hostname user pass
  110 + pool <- Trans.liftIO $ Pool.newPool Pool.Factory { Pool.newResource = connectMongoDB dbname hostname mAuth
109 111 , Pool.killResource = DB.close
110 112 , Pool.isExpired = DB.isClosed
111 113 }
@@ -113,9 +115,9 @@ createMongoDBPool dbname hostname user pass connectionPoolSize = do
113 115 return (pool, dbname)
114 116
115 117 withMongoDBPool :: (Trans.MonadIO m, Applicative m) =>
116   - Database -> HostName -> UString -> UString -> Int -> (ConnectionPool -> m b) -> m b
117   -withMongoDBPool dbname hostname user pass connectionPoolSize connectionReader = do
118   - pool <- createMongoDBPool dbname hostname user pass connectionPoolSize
  118 + Database -> HostName -> Maybe (UString, UString) -> Int -> (ConnectionPool -> m b) -> m b
  119 +withMongoDBPool dbname hostname mauth connectionPoolSize connectionReader = do
  120 + pool <- createMongoDBPool dbname hostname mauth connectionPoolSize
119 121 connectionReader pool
120 122
121 123 runMongoDBConn :: (Trans.MonadIO m) => DB.AccessMode -> DB.Action m b -> ConnectionPool -> m b
@@ -393,7 +395,7 @@ filterToDocument f =
393 395 showFilter Eq = error "EQ filter not expected"
394 396 showFilter (BackendSpecificFilter bsf) = throw $ PersistMongoDBError $ T.pack $ "did not expect BackendSpecificFilter " ++ T.unpack bsf
395 397
396   -fieldName :: forall v typ. (PersistEntity v) => EntityField v typ -> CS.CompactString
  398 +fieldName :: forall v typ. (PersistEntity v) => EntityField v typ -> UString
397 399 fieldName = u . idfix . T.unpack . unDBName . fieldDB . persistFieldDef
398 400 where idfix f = if f == "id" then "_id" else f
399 401
@@ -443,11 +445,11 @@ mapFromDoc :: DB.Document -> [(T.Text, PersistValue)]
443 445 mapFromDoc = Prelude.map (\f -> ( ( csToText (DB.label f)), (fromJust . DB.cast') (DB.value f) ) )
444 446
445 447 -- | CompactString is UTF8, Text is UTF16
446   -csToText :: CS.CompactString -> T.Text
  448 +csToText :: UString -> T.Text
447 449 csToText = E.decodeUtf8 . CS.toByteString
448 450
449 451 -- | CompactString is UTF8, Text is UTF16
450   -textToCS :: T.Text -> CS.CompactString
  452 +textToCS :: T.Text -> UString
451 453 textToCS = CS.fromByteString_ . E.encodeUtf8
452 454
453 455 oidToPersistValue :: DB.ObjectId -> PersistValue
@@ -518,8 +520,7 @@ dummyFromFilts _ = error "dummyFromFilts"
518 520 data MongoConf = MongoConf
519 521 { mgDatabase :: String
520 522 , mgHost :: String
521   - , mgUser :: String
522   - , mgPass :: String
  523 + , mgAuth :: Maybe (String, String)
523 524 , mgPoolSize :: Int
524 525 , mgAccessMode :: DB.AccessMode
525 526 }
@@ -527,14 +528,16 @@ data MongoConf = MongoConf
527 528 instance PersistConfig MongoConf where
528 529 type PersistConfigBackend MongoConf = DB.Action
529 530 type PersistConfigPool MongoConf = ConnectionPool
530   - createPoolConfig (MongoConf db host user pass poolsize _) = createMongoDBPool (u db) host (u user) (u pass) poolsize
531   - runPool (MongoConf _ _ _ _ _ accessMode) = runMongoDBConn accessMode
  531 + createPoolConfig (MongoConf db host mAuth poolsize _) =
  532 + createMongoDBPool (u db) host (fmap (\(us,p)-> (u us,u p) ) mAuth)
  533 + poolsize
  534 + runPool (MongoConf _ _ _ _ accessMode) = runMongoDBConn accessMode
532 535 loadConfig (Object o) = do
533 536 db <- o .: "database"
534 537 host <- o .: "host"
535   - user <- o .: "user"
536   - pass <- o .: "password"
537 538 pool <- o .: "poolsize"
  539 + mUser <- o .:? "user"
  540 + mPass <- o .:? "password"
538 541 accessString <- o .:? "accessMode" .!= "ConfirmWrites"
539 542
540 543 accessMode <- case accessString of
@@ -543,7 +546,12 @@ instance PersistConfig MongoConf where
543 546 "ConfirmWrites" -> return $ DB.ConfirmWrites [u"j" DB.=: True]
544 547 badAccess -> fail $ "unknown accessMode: " ++ (T.unpack badAccess)
545 548
546   - return $ MongoConf (T.unpack db) (T.unpack host) (T.unpack user) (T.unpack pass) pool accessMode
  549 + return $ MongoConf (T.unpack db) (T.unpack host)
  550 + (case (mUser, mPass) of
  551 + (Just user, Just pass) -> Just ((T.unpack user), (T.unpack pass))
  552 + _ -> Nothing
  553 + )
  554 + pool accessMode
547 555 where
548 556 {-
549 557 safeRead :: String -> T.Text -> MEither String Int
2  persistent-mongoDB/persistent-mongoDB.cabal
... ... @@ -1,5 +1,5 @@
1 1 name: persistent-mongoDB
2   -version: 0.9.0.1
  2 +version: 0.10
3 3 license: MIT
4 4 license-file: LICENSE
5 5 author: Greg Weber <greg@gregweber.info>
2  persistent-test/Init.hs
@@ -109,7 +109,7 @@ persistSettings = MkPersistSettings { mpsBackend = ConT ''Action }
109 109 type BackendMonad = Action
110 110 runConn f = do
111 111 -- withMongoDBConn ("test") "127.0.0.1" $ runMongoDBConn MongoDB.safe MongoDB.Master f
112   - withMongoDBConn "test" "127.0.0.1" $ runMongoDBConn MongoDB.master f
  112 + withMongoDBConn "test" "127.0.0.1" Nothing $ runMongoDBConn MongoDB.master f
113 113
114 114 --setup :: MongoPersist IO ()
115 115 setupMongo :: Action IO ()

0 comments on commit fd9ce6c

Please sign in to comment.
Something went wrong with that request. Please try again.