/src/DB.hs
Haskell | 110 lines | 72 code | 31 blank | 7 comment | 0 complexity | 9fca07ac67f9a21d7a2d41ad39a65730 MD5 | raw file
1{-# LANGUAGE OverloadedStrings #-} 2module DB 3 ( 4 DB, 5 Document, 6 Failure, 7 withDB, 8 openDB, 9 closeDB, 10 returnModel, 11 run, 12 repsert, 13 modify, 14 delete, 15 select, 16 findOne, 17 count, 18 lookup, 19 at, 20 (=:) 21 ) where 22 23import Prelude hiding (lookup) 24 25import Control.Exception (bracket) 26 27import System.Posix.Env(getEnvDefault) 28import Data.String.Utils(split) 29import Text.URI(URI(..), parseURI) 30 31import Data.UString (UString, u) 32import Data.Maybe (fromJust) 33 34import Database.MongoDB ( 35 Action, Pipe, Database, Document, Failure, runIOE, connect, auth, access, master, 36 readHostPort, close, repsert, modify, delete, (=:), select, 37 findOne, count, lookup, at 38 ) 39 40-- |A connection to a mongoDB 41data DB = DB { mongoPipe :: Pipe, mongoDB :: Database } 42 43 44-- |Credentials for authenticating with a mongoDB 45data Credentials = NoAuth 46 | Credentials { crUser :: UString, crPass :: UString } 47 48 49 50-- |Opens a connection to the database speficied in the MONGO_URL 51-- environment variable 52openDB :: IO DB 53openDB = do 54 mongoURI <- getEnvDefault "MONGO_URL" "mongodb://127.0.0.1:27017/eventsourcehq" 55 openConn mongoURI 56 57 58-- |Close the connection to the database 59closeDB :: DB -> IO () 60closeDB = do 61 closeConn 62 63 64-- |Bracket around opening and closing the DB connection 65withDB :: (DB -> IO ()) -> IO () 66withDB f = do 67 mongoURI <- getEnvDefault "MONGO_URL" "mongodb://127.0.0.1:27017/eventsourcehq" 68 69 bracket (openConn mongoURI) closeConn f 70 71 72returnModel :: (Document -> a) -> Either Failure (Maybe Document) -> Either Failure (Maybe a) 73returnModel constructor (Right result) = return (fmap constructor result) 74returnModel _ (Left failure) = Left failure 75 76 77openConn :: String -> IO DB 78openConn mongoURI = do 79 let uri = fromJust $ parseURI mongoURI 80 let creds = case fmap (split ":") (uriUserInfo uri) of 81 Nothing -> NoAuth 82 Just [us, pw] -> Credentials (u us) (u pw) 83 let hostname = fromJust $ uriRegName uri 84 let port = case uriPort uri of 85 Just p -> show p 86 Nothing -> "27017" 87 88 let dbName = u $ drop 1 (uriPath uri) 89 90 pipe <- runIOE $ connect (readHostPort (hostname ++ ":" ++ port)) 91 92 let db = DB pipe dbName 93 94 authenticate db creds 95 96 return db 97 98 99authenticate :: DB -> Credentials -> IO (Either Failure Bool) 100authenticate db NoAuth = return (Right True) 101authenticate db (Credentials user pass) = run db (auth user pass) 102 103 104run :: DB -> Action IO a -> IO (Either Failure a) 105run (DB pipe db) action = 106 access pipe master db action 107 108 109closeConn :: DB -> IO () 110closeConn db = close (mongoPipe db)