module Database.Couch.Types where
import Control.Applicative ((<$>), (<*>))
import Control.Monad (mapM, mzero, return)
import Data.Aeson (FromJSON, ToJSON,
Value (Array, Object, String), object,
parseJSON, toJSON, (.:), (.:?), (.=))
import Data.Aeson.Types (typeMismatch)
import Data.Biapplicative ((<<*>>))
import Data.Bool (Bool)
import Data.ByteString (ByteString)
import Data.ByteString.Builder (intDec, toLazyByteString)
import Data.ByteString.Lazy (toStrict)
import Data.Either (Either)
import Data.Eq (Eq)
import Data.Function (($), (.))
import Data.Functor (fmap)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap (fromList, toList)
import Data.Int (Int)
import Data.List ((++))
import Data.Maybe (Maybe (Just, Nothing), catMaybes,
maybe)
import Data.Monoid (mempty)
import Data.String (IsString)
import Data.Text (Text, null)
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Vector as Vector (fromList)
import GHC.Generics (Generic)
import Network.HTTP.Client (CookieJar, HttpException, Manager)
import Network.HTTP.Types (Header, HeaderName)
import Text.Show (Show)
newtype Db = Db { unwrapDb :: Text } deriving (Eq, FromJSON, IsString, Show, ToJSON)
newtype DocId = DocId { unwrapDocId :: Text } deriving (Eq, FromJSON, IsString, Show, ToJSON)
newtype DocRev = DocRev { unwrapDocRev :: Text } deriving (Eq, FromJSON, IsString, Show, ToJSON)
newtype Host = Host { unwrapHost :: Text } deriving (Eq, FromJSON, IsString, Show, ToJSON)
newtype Password = Password { unwrapPassword :: Text } deriving (Eq, FromJSON, IsString, Show, ToJSON)
newtype Port = Port { unwrapPort :: Int } deriving (Eq, Show)
newtype User = User { unwrapUser :: Text } deriving (Eq, FromJSON, IsString, Show, ToJSON)
reqDocId :: DocId -> ByteString
reqDocId = encodeUtf8 . unwrapDocId
reqDocRev :: DocRev -> ByteString
reqDocRev = encodeUtf8 . unwrapDocRev
reqPassword :: Password -> ByteString
reqPassword = encodeUtf8 . unwrapPassword
reqUser :: User -> ByteString
reqUser = encodeUtf8 . unwrapUser
data Context
= Context {
ctxManager :: Manager,
ctxHost :: Host,
ctxPort :: Port,
ctxCred :: Maybe Credentials,
ctxCookies :: CookieJar,
ctxDb :: Maybe Db
}
reqDb :: Context -> ByteString
reqDb c = maybe mempty (encodeUtf8 . unwrapDb) (ctxDb c)
reqHost :: Context -> ByteString
reqHost = encodeUtf8 . unwrapHost . ctxHost
reqPort :: Context -> Int
reqPort = unwrapPort . ctxPort
data Credentials
= Basic {
credUser :: User,
credPass :: Password
}
type QueryParameters = [(ByteString, Maybe ByteString)]
class ToQueryParameters a where
toQueryParameters :: a -> QueryParameters
toQP :: ByteString
-> (a -> ByteString)
-> Maybe a
-> Maybe (ByteString, Maybe ByteString)
toQP name fun = fmap ((name,) . Just . fun)
boolToQP :: ByteString -> Maybe Bool -> Maybe (ByteString, Maybe ByteString)
boolToQP name = toQP name (\bool -> if bool then "true" else "false")
docIdToQP :: ByteString -> Maybe DocId -> Maybe (ByteString, Maybe ByteString)
docIdToQP name = toQP name reqDocId
docRevToQP :: ByteString -> Maybe DocRev -> Maybe (ByteString, Maybe ByteString)
docRevToQP name = toQP name reqDocRev
intToQP :: ByteString -> Maybe Int -> Maybe (ByteString, Maybe ByteString)
intToQP name = toQP name (toStrict . toLazyByteString . intDec)
textToQP :: ByteString -> Maybe Text -> Maybe (ByteString, Maybe ByteString)
textToQP name = toQP name encodeUtf8
class ToHTTPHeaders a where
toHTTPHeaders :: a -> [Header]
toHH :: HeaderName
-> (a -> ByteString)
-> Maybe a
-> Maybe Header
toHH name fun = fmap ((name,) . fun)
boolToHH :: HeaderName -> Maybe Bool -> Maybe Header
boolToHH name = toHH name (\bool -> if bool then "true" else "false")
data DbUpdates
= DbUpdates {
feed :: Maybe FeedType,
timeOut :: Maybe Int,
heartBeat :: Maybe Bool
}
instance ToQueryParameters DbUpdates where
toQueryParameters DbUpdates {..} = catMaybes [
feedTypeToQP feed,
intToQP "timeout" timeOut,
boolToQP "heartbeat" heartBeat
]
dbUpdatesParam :: DbUpdates
dbUpdatesParam = DbUpdates Nothing Nothing Nothing
data DbChanges
= DbChanges {
cDocIds :: Maybe [DocId],
cConflicts :: Maybe Bool,
cDescending :: Maybe Bool,
cFeed :: Maybe FeedType,
cFilter :: Maybe Text,
cHeartBeat :: Maybe Int,
cIncludeDocs :: Maybe Bool,
cAttachments :: Maybe Bool,
cAttEncodingInfo :: Maybe Bool,
cLastEvent :: Maybe Text,
cSince :: Maybe SinceType,
cStyle :: Maybe StyleType,
cTimeout :: Maybe Int,
cView :: Maybe Text
}
instance ToQueryParameters DbChanges where
toQueryParameters DbChanges {..} = catMaybes [
boolToQP "conflicts" cConflicts,
boolToQP "descending" cDescending,
feedTypeToQP cFeed,
textToQP "filter" cFilter,
intToQP "heartbeat" cHeartBeat,
boolToQP "include_docs" cIncludeDocs,
boolToQP "attachments" cAttachments,
boolToQP "att_encoding_info" cAttEncodingInfo,
sinceTypeToQP cSince,
styleTypeToQP cStyle,
intToQP "timeout" cTimeout,
textToQP "view" cView
]
dbChangesParam :: DbChanges
dbChangesParam = DbChanges Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
data DbAllDocs
= DbAllDocs {
adConflicts :: Maybe Bool,
adDescending :: Maybe Bool,
adEndKey :: Maybe Text,
adEndKeyDocId :: Maybe DocId,
adIncludeDocs :: Maybe Bool,
adInclusiveEnd :: Maybe Bool,
adKey :: Maybe Text,
adLimit :: Maybe Int,
adSkip :: Maybe Int,
adStale :: Maybe Bool,
adStartKey :: Maybe Text,
adStartKeyDocId :: Maybe DocId,
adUpdateSeq :: Maybe Bool
}
instance ToQueryParameters DbAllDocs where
toQueryParameters DbAllDocs {..} = catMaybes [
boolToQP "conflicts" adConflicts,
boolToQP "descending" adDescending,
textToQP "end_key" adEndKey,
docIdToQP "end_key_doc_id" adEndKeyDocId,
boolToQP "include_docs" adIncludeDocs,
boolToQP "inclusive_end" adInclusiveEnd,
textToQP "key" adKey,
intToQP "limit" adLimit,
intToQP "skip" adSkip,
boolToQP "stale" adStale,
textToQP "start_key" adStartKey,
docIdToQP "start_key_doc_id" adStartKeyDocId,
boolToQP "update_seq" adUpdateSeq
]
dbAllDocs :: DbAllDocs
dbAllDocs = DbAllDocs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
data DbBulkDocs
= DbBulkDocs {
bdAllOrNothing :: Maybe Bool,
bdFullCommit :: Maybe Bool,
bdNewEdits :: Maybe Bool
}
dbBulkDocs :: DbBulkDocs
dbBulkDocs = DbBulkDocs Nothing Nothing Nothing
data ModifyDoc
= ModifyDoc {
dpFullCommit :: Maybe Bool,
dpBatch :: Maybe Bool
}
instance ToHTTPHeaders ModifyDoc where
toHTTPHeaders ModifyDoc {..} = catMaybes [
boolToHH "X-Couch-Full-Commit" dpFullCommit
]
instance ToQueryParameters ModifyDoc where
toQueryParameters ModifyDoc {..} = catMaybes [
boolToQP "batch" dpBatch
]
modifyDoc :: ModifyDoc
modifyDoc = ModifyDoc Nothing Nothing
data RetrieveDoc
= RetrieveDoc {
dgdAttachments :: Maybe Bool,
dgdAttEncodingInfo :: Maybe Bool,
dgdAttsSince :: [DocRev],
dgdConflicts :: Maybe Bool,
dgdDeletedConflicts :: Maybe Bool,
dgdLatest :: Maybe Bool,
dgdLocalSeq :: Maybe Bool,
dgdMeta :: Maybe Bool,
dgdOpenRevs :: [DocRev],
dgdRev :: Maybe DocId,
dgdRevs :: Maybe Bool,
dgdRevsInfo :: Maybe Bool
}
instance ToQueryParameters RetrieveDoc where
toQueryParameters RetrieveDoc {..} = catMaybes $ [
boolToQP "attachments" dgdAttachments,
boolToQP "att_encoding_info" dgdAttEncodingInfo
] ++
fmap (docRevToQP "atts_since" . Just) dgdAttsSince
++ [
boolToQP "conflicts" dgdConflicts,
boolToQP "deleted_conflicts" dgdDeletedConflicts,
boolToQP "latest" dgdLatest,
boolToQP "local_seq" dgdLocalSeq,
boolToQP "meta" dgdMeta
] ++
fmap (docRevToQP "open_revs" . Just) dgdOpenRevs
++ [
docIdToQP "rev" dgdRev,
boolToQP "revs" dgdRevs,
boolToQP "revs_info" dgdRevsInfo
]
retrieveDoc :: RetrieveDoc
retrieveDoc = RetrieveDoc Nothing Nothing [] Nothing Nothing Nothing Nothing Nothing [] Nothing Nothing Nothing
data FeedType
= Continuous
| EventSource
| Longpoll
feedTypeToQP :: Maybe FeedType -> Maybe (ByteString, Maybe ByteString)
feedTypeToQP = fmap (("feed",) . Just . go)
where
go Continuous = "continuous"
go EventSource = "eventsource"
go Longpoll = "longpoll"
data SinceType
= Now
| Since Int
sinceTypeToQP :: Maybe SinceType -> Maybe (ByteString, Maybe ByteString)
sinceTypeToQP = fmap (("since",) . Just . go)
where
go Now = "now"
go (Since i) = (toStrict . toLazyByteString . intDec) i
data StyleType
= StyleAll
| StyleMain
styleTypeToQP :: Maybe StyleType -> Maybe (ByteString, Maybe ByteString)
styleTypeToQP = fmap (("style",) . Just . go)
where
go StyleAll = "all_docs"
go StyleMain = "main_docs"
data DocRevMap
= DocRevMap [(DocId, [DocRev])]
deriving (Generic, Eq, Show)
instance FromJSON DocRevMap where
parseJSON (Object o) = DocRevMap <$> mapM (\(k, v) -> (,) <$> (return . DocId $ k) <*> parseJSON v) (HashMap.toList o)
parseJSON _ = mzero
instance ToJSON DocRevMap where
toJSON (DocRevMap d) = Object . HashMap.fromList $ fmap ((unwrapDocId, Array . Vector.fromList . fmap (String . unwrapDocRev)) <<*>>) d
data ViewSpec
= ViewSpec {
vsMap :: Text,
vsReduce :: Maybe Text
} deriving (Generic, Eq, Show)
instance FromJSON ViewSpec where
parseJSON (Object o) = ViewSpec <$> o .: "map" <*> o .:? "reduce"
parseJSON v = typeMismatch "Couldn't extract ViewSpec: " v
instance ToJSON ViewSpec where
toJSON ViewSpec {..} = object $ "map" .= vsMap : maybe [] (\v -> ["reduce" .= v]) vsReduce
data DesignDoc
= DesignDoc {
ddocId :: DocId,
ddocRev :: DocRev,
ddocLanguage :: Maybe Text,
ddocOptions :: Maybe (HashMap Text Text),
ddocFilters :: Maybe (HashMap Text Text),
ddocLists :: Maybe (HashMap Text Text),
ddocShows :: Maybe (HashMap Text Text),
ddocUpdates :: Maybe (HashMap Text Text),
ddocValidation :: Maybe Text,
ddocViews :: Maybe (HashMap Text ViewSpec)
} deriving (Generic, Eq, Show)
instance FromJSON DesignDoc where
parseJSON (Object o) = DesignDoc
<$> o .: "_id"
<*> o .: "_rev"
<*> o .:? "language"
<*> o .:? "options"
<*> o .:? "filters"
<*> o .:? "lists"
<*> o .:? "shows"
<*> o .:? "updates"
<*> o .:? "validate_doc_update"
<*> o .:? "views"
parseJSON v = typeMismatch "Couldn't extract DesignDoc: " v
instance ToJSON DesignDoc where
toJSON DesignDoc {..} = object $ catMaybes [
if (null . unwrapDocId) ddocId
then Nothing
else Just ("_id" .= ddocId),
if (null . unwrapDocRev) ddocRev
then Nothing
else Just ("_rev" .= ddocRev),
fmap ("language" .=) ddocLanguage,
fmap ("options" .=) ddocOptions,
fmap ("filters" .=) ddocFilters,
fmap ("lists" .=) ddocLists,
fmap ("shows" .=) ddocShows,
fmap ("updates" .=) ddocUpdates,
fmap ("validate_doc_update" .=) ddocValidation,
fmap ("views" .=) ddocViews
]
data ViewIndexInfo
= ViewIndexInfo {
viCompactRunning :: Bool,
viDataSize :: Int,
viDiskSize :: Int,
viLanguage :: Text,
viPurgeSeq :: Int,
viSignature :: Text,
viUpdateSeq :: Int,
viUpdaterRunning :: Bool,
viWaitingClients :: Int,
viWaitingCommit :: Bool
} deriving (Generic, Eq, Show)
instance FromJSON ViewIndexInfo where
parseJSON (Object o) = ViewIndexInfo
<$> o .: "compact_running"
<*> o .: "data_size"
<*> o .: "disk_size"
<*> o .: "language"
<*> o .: "purge_seq"
<*> o .: "signature"
<*> o .: "update_seq"
<*> o .: "updater_running"
<*> o .: "waiting_clients"
<*> o .: "waiting_commit"
parseJSON v = typeMismatch "Couldn't extract ViewIndexInfo: " v
data ViewParams
= ViewParams {
vpAttachments :: Maybe Bool,
vpAttEncodingInfo :: Maybe Bool,
vpConflicts :: Maybe Bool,
vpDescending :: Maybe Bool,
vpEndKey :: Maybe Text,
vpEndKeyDocId :: Maybe DocId,
vpGroup :: Maybe Bool,
vpGroupLevel :: Maybe Int,
vpIncludeDocs :: Maybe Bool,
vpInclusiveEnd :: Maybe Bool,
vpKey :: Maybe Text,
vpLimit :: Maybe Int,
vpReduce :: Maybe Bool,
vpSkip :: Maybe Int,
vpStale :: Maybe Bool,
vpStartKey :: Maybe Text,
vpStartKeyDocId :: Maybe DocId,
vpUpdateSeq :: Maybe Bool
}
instance ToQueryParameters ViewParams where
toQueryParameters ViewParams {..} = catMaybes [
boolToQP "attachments" vpAttachments,
boolToQP "att_encoding_info" vpAttEncodingInfo,
boolToQP "conflicts" vpConflicts,
boolToQP "descending" vpDescending,
textToQP "end_key" vpEndKey,
docIdToQP "end_key_doc_id" vpEndKeyDocId,
boolToQP "group" vpGroup,
intToQP "group_level" vpGroupLevel,
boolToQP "include_docs" vpIncludeDocs,
boolToQP "inclusive_end" vpInclusiveEnd,
textToQP "key" vpKey,
intToQP "limit" vpLimit,
boolToQP "reduce" vpReduce,
intToQP "skip" vpSkip,
boolToQP "stale" vpStale,
textToQP "start_key" vpStartKey,
docIdToQP "start_key_doc_id" vpStartKeyDocId,
boolToQP "update_seq" vpUpdateSeq
]
viewParams :: ViewParams
viewParams = ViewParams Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
type Result a = Either Error (a, Maybe CookieJar)
data CreateResult
= NoRev DocId
| WithRev DocId DocRev
data Error
= AlreadyExists
| Conflict
| HttpError HttpException
| ImplementationError Text
| InvalidName Text
| NotFound
| ParseIncomplete
| ParseFail Text
| Unauthorized
| Unknown
deriving (Show)