snaplet-mongoDB / src / Snap / Snaplet / MongoDB / MongoEntity.hs

root df0ea16 

Kamil Ciemniewsk… ac8b9ae 
{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, FlexibleContexts #-}

module Snap.Snaplet.MongoDB.MongoEntity
       ( MongoEntity (..)
       ) where

import           Control.Applicative
import           Control.Monad.Error
import qualified Data.Bson        as BSON
import           Data.Monoid
import qualified Database.MongoDB as DB
import           Snap.Snaplet.MongoDB.MongoValue
import           Numeric (readHex)
import           Text.Read
import qualified Text.ParserCombinators.ReadP as R
import qualified Text.ParserCombinators.ReadPrec as R (lift, readS_to_Prec)

-- | Any type that is an instance of this type class can be stored and retrieved as an object from a MongoDB collection.
class (Show (Key a), MongoValue (Key a)) => MongoEntity a where
  data Key a
  data Filter a
  data Document a
  -- | Convert an 'ObjectId' to a 'Key'.
  toKey               :: ObjectId -> Key a
  -- | Convert a 'Key' to an 'ObjectId'
  fromKey             :: Key a -> ObjectId
  -- | Convert a 'BSON.Document' to a 'Document'.
  toDocument          :: BSON.Document -> Document a
  -- | Convert a 'Document' to a 'BSON.Document'.
  fromDocument        :: Document a -> BSON.Document
  -- | Yields the name of the collection to which this type belongs.
  collectionName      :: a -> DB.Collection
  -- | Yields the name of the corresponding field in a collection for the given filter.
  filterFieldName     :: Filter a -> BSON.Label
  -- | Encode an object into a 'BSON.Document' that can be stored in a collection.
  encodeDocument      :: a -> Document a
  -- | Decode a 'BSON.Document' into this type; possibly failing.
  decodeDocument      :: (Applicative m, Monad m) => Document a -> ErrorT String m a

instance (MongoEntity a) => MongoValue (Key a) where
  toValue = BSON.ObjId . fromKey
  fromValue (BSON.ObjId o) = return $ toKey o
  fromValue v              = expected "ObjectId" v

instance (MongoEntity a) => MongoValue (Document a) where
  toValue = toValue . fromDocument
  fromValue (BSON.Doc doc) = return $ toDocument doc
  fromValue v              = expected "Document" v

instance (MongoEntity a) => Monoid (Document a) where
  mempty = toDocument []
  mappend x y = toDocument (fromDocument x ++ fromDocument y)

instance (MongoEntity a) => Show (Key a) where
  show = show . fromKey

instance (MongoEntity a) => Read (Key a) where
  readPrec = do
    [(x, "")] <- readHex <$> R.lift (R.count 8 R.get)
    y <- R.readS_to_Prec $ const readHex
    return (toKey (BSON.Oid x y))

-- Local Variables:
-- mode                  : Haskell
-- fill-column           : 120
-- default-justification : left
-- End:
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.