/src/DB.hs

  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)