/
Functions.hs
122 lines (108 loc) · 4.65 KB
/
Functions.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Snap.Snaplet.MongoDB.Functions
( mongoDBInit
, eitherWithDB'
, eitherWithDB
, maybeWithDB
, maybeWithDB'
, unsafeWithDB
, unsafeWithDB'
) where
import Data.Text (Text)
import Control.Monad.Error
import Snap
import Snap.Snaplet.MongoDB.Core
import Database.MongoDB
import System.IO.Pool
------------------------------------------------------------------------------
-- | Description text used in mongoDBInit as makeSnaplet argument.
description :: Text
description = "Minimalistic MongoDB Snaplet."
------------------------------------------------------------------------------
-- | Initializer function.
-- 1. argument: Maximum pool size.
-- 2. argument: Host (e.g. return value of MongoDB's host function).
-- 3. argument: Database name.
--
-- Example:
-- @
-- app :: SnapletInit App App
-- app = makeSnaplet "app" "An snaplet example application." Nothing $ do
-- d <- nestSnaplet "database" database $ mongoDBInit 10 (host "127.0.0.1") "Snaplet-MongoDB"
-- return $ App d
-- @
mongoDBInit :: Int -> Host -> Database -> SnapletInit app MongoDB
mongoDBInit n h d = makeSnaplet "snaplet-mongodb" description Nothing $ do
pool <- liftIO $ newPool (Factory (connect h) close isClosed) n
return $ MongoDB pool d
class (MonadIO m, MonadState app m, HasMongoDB app) => HasMongoDB' app m
instance (MonadIO m, MonadState app m, HasMongoDB app) => HasMongoDB' app m
------------------------------------------------------------------------------
-- | Database access function.
-- 1. argument: Action to perform. (Defaults to UnconfirmedWrites AccessMode)
-- Returns: The action's result; in case of failure error is called.
--
-- Example:
-- > unsafeWithDB $ insert "test-collection" ["some_field" = " something" ]
unsafeWithDB :: (HasMongoDB' app m) => Action IO a -> m a
unsafeWithDB = unsafeWithDB' UnconfirmedWrites
------------------------------------------------------------------------------
-- | Database access function.
-- 1. argument: AccessMode.
-- 2. argument: Action to perform.
-- Returns: The action's result; in case of failure error is called.
--
-- Example:
-- > unsafeWithDB' UnconfirmedWrites $ insert "test-collection" ["some_field" = " something" ]
unsafeWithDB' :: (HasMongoDB' app m) => AccessMode -> Action IO a -> m a
unsafeWithDB' mode action = do
res <- (eitherWithDB' mode action)
return $ either (error . show) id res
------------------------------------------------------------------------------
-- | Database access function.
-- 1. argument: Action to perform. (Defaults to UnconfirmedWrites AccessMode)
-- Returns: Nothing in case of failure or Just the rsult of the action.
--
-- Example:
-- > maybeWithDB $ insert "test-collection" ["some_field" = " something" ]
maybeWithDB :: (HasMongoDB' app m) => Action IO a -> m (Maybe a)
maybeWithDB = maybeWithDB' UnconfirmedWrites
------------------------------------------------------------------------------
-- | Database access function.
-- 1. argument: AccessMode.
-- 2. argument: Action to perform.
-- Returns: Nothing in case of failure or Just the rsult of the action.
--
-- Example:
-- > maybeWithDB' UnconfirmedWrites $ insert "test-collection" ["some_field" = " something" ]
maybeWithDB' :: (HasMongoDB' app m) => AccessMode -> Action IO a -> m (Maybe a)
maybeWithDB' mode action = do
res <- (eitherWithDB' mode action)
return $ either (const Nothing) Just res
------------------------------------------------------------------------------
-- | Database access function.
-- 1. argument: Action to perform. (Defaults to UnconfirmedWrites AccessMode)
-- Returns: Either Failure or the action's result.
--
-- Example:
-- > eitherWithDB $ insert "test-collection" ["some_field" = " something" ]
eitherWithDB :: (HasMongoDB' app m) => Action IO a -> m (Either Failure a)
eitherWithDB = eitherWithDB' UnconfirmedWrites
------------------------------------------------------------------------------
-- | Database access function.
-- 1. argument: AccessMode.
-- 2. argument: Action to perform.
-- Returns: Either Failure or the action's result.
--
-- Example:
-- > eitherWithDB' UnconfirmedWrites $ insert "test-collection" ["some_field" = " something" ]
eitherWithDB' :: (HasMongoDB' app m) => AccessMode -> Action IO a -> m (Either Failure a)
eitherWithDB' mode action = do
(MongoDB pool database) <- gets getMongoDB
ep <- liftIO $ runErrorT $ aResource pool
case ep of
Left err -> return $ Left $ ConnectionFailure err
Right pip -> liftIO $ access pip mode database action