diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Kamil Ciemniewski + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Kamil Ciemniewski nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/snaplet-mongoDB.cabal b/snaplet-mongoDB.cabal new file mode 100644 --- /dev/null +++ b/snaplet-mongoDB.cabal @@ -0,0 +1,85 @@ +-- snaplet-mongoDB.cabal auto-generated by cabal init. For additional +-- options, see +-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr. +-- The name of the package. +Name: snaplet-mongoDB + +-- The package version. See the Haskell package versioning policy +-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for +-- standards guiding when and how versions should be incremented. +Version: 0.2 + +-- A short (one-line) description of the package. +Synopsis: Snap Framework MongoDB support as Snaplet + +-- A longer description of the package. +-- Description: + +-- The license under which the package is released. +License: BSD3 + +-- The file containing the license text. +License-file: LICENSE + +-- The package author(s). +Author: Kamil Ciemniewski + +-- An email address to which users can send suggestions, bug reports, +-- and patches. +Maintainer: ciemniewski.kamil@gmail.com + +-- A copyright notice. +-- Copyright: + +Category: Web + +Build-type: Simple + +-- Extra files to be distributed with the package, such as examples or +-- a README. +-- Extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +Cabal-version: >= 1.6 + + +Library + hs-source-dirs: src + + library + exposed-modules: Snap.Snaplet.MongoDB + , Snap.Snaplet.MongoDB.Template + , Snap.Snaplet.MongoDB.FilterOps + , Snap.Snaplet.MongoDB.MongoEntity + , Snap.Snaplet.MongoDB.MongoValue + , Snap.Snaplet.MongoDB.Parse + + -- Packages needed in order to build this package. + Build-depends: + base >= 4 && < 5, + bytestring >= 0.9.1 && < 0.10, + bson == 0.1.6, + compact-string-fix == 0.3.2, + containers == 0.4.0.0, + mongoDB == 1.1.1, + mtl >= 2 && < 3, + regular >= 0.3.2, + safe, + snap == 0.7.*, + snap-core == 0.7.*, + text >= 0.11 && < 0.12, + time >= 1.1 && < 1.5, + parsec == 3.1.1, + haskell-src-exts == 1.11.1, + template-haskell, + MonadCatchIO-transformers == 0.2.2.2 + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. + -- Build-tools: + + extensions: + OverloadedStrings + , FlexibleInstances + , TypeSynonymInstances + , MultiParamTypeClasses + diff --git a/src/Snap/Snaplet/MongoDB.hs b/src/Snap/Snaplet/MongoDB.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/MongoDB.hs @@ -0,0 +1,330 @@ +module Snap.Snaplet.MongoDB + ( + MonadMongoDB(..) + + , MongoDBSnaplet(..) + , HasMongoDBState(..) + + , MongoValue (..) + , MongoEntity (..) + + , mongoDBInit + + , insert + , insertMany + , insertWith + , get + , getMany + , delete + , deleteWhere + , select + , selectOne + , count + , save + , update + , updateWhere + + , filters + , updates + + , offset + , limit + , orderAsc + , orderDesc + + , objid2bs + , bs2objid + , bs2objid' + , bs2cs + , getObjId + + , module Snap.Snaplet.MongoDB.FilterOps + , module Snap.Snaplet.MongoDB.MongoEntity + , module Snap.Snaplet.MongoDB.MongoValue + , module Snap.Snaplet.MongoDB.Template + , module Snap.Snaplet.MongoDB.Parse + , MongoDB.Action + , MongoDB.MonadIO' + ) where + +import Snap.Core +import Snap.Snaplet + +import Prelude hiding (lookup, or) +import Control.Applicative +import Control.Monad +import Control.Monad.MVar +import Control.Monad.Error +import Data.Bson ((=:)) +import qualified Data.Bson as BSON +import qualified Data.UString as US +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as B8 +import qualified Data.CompactString.Internal as CSI +import Data.Maybe (catMaybes, fromJust) +import qualified Data.Map as Map +import Numeric (showHex, readHex) +import Safe +import Snap.Snaplet.MongoDB.FilterOps +import Snap.Snaplet.MongoDB.MongoEntity +import Snap.Snaplet.MongoDB.MongoValue +import Snap.Snaplet.MongoDB.Template +import Snap.Snaplet.MongoDB.Parse +import qualified Database.MongoDB as MongoDB +import qualified Database.MongoDB.Internal.Util as MongoDB +import Database.MongoDB.Query (Action, Failure(..), Database, access, master, AccessMode(..)) +import qualified Database.MongoDB.Connection as MongoDB +import qualified System.IO.Pool as MPool + +import Control.Monad.CatchIO hiding (Handler) + +instance Exception String + +------------------------------------------------------------------------------ +-- | The 'MonadMongoDB' class. Minimal complete definition: +class MonadIO m => MonadMongoDB m where + + ---------------------------------------------------------------------------- + -- | Run given MongoDB action against the database + withDB :: Action IO a -> m (Either Failure a) + withDBUnsafe :: Action IO a -> m (Either Failure a) + + + + ---------------------------------------------------------------------------- + -- | Same as 'withDB' but calls 'error' if there is an exception + withDB' :: Action IO a -> m a + withDB' run = do + r <- withDB run + either (throw . show) return r + + +data MongoDBSnaplet = MongoDBSnaplet { + connPoll :: MPool.Pool IOError MongoDB.Pipe, + appDatabase :: Database +} + +------------------------------------------------------------------------------ +-- | +class HasMongoDBState s where + getMongoDBState :: Handler s s MongoDBSnaplet + setMongoDBState :: MongoDBSnaplet -> Handler s s () + + --modifyMongoDBState :: (MongoDBSnaplet -> MongoDBSnaplet) -> s -> s + --modifyMongoDBState s = setMongoDBState s getMongoDBState + +mongoDBInit :: MongoDB.Host -> Int -> US.UString -> SnapletInit b MongoDBSnaplet +mongoDBInit h n db = + makeSnaplet "mongoDB" "MongoDB abstraction" Nothing $ do + pool <- liftIO $ MPool.newPool (factoryForHost h) n + return $ MongoDBSnaplet pool (db) + where + factoryForHost :: MongoDB.Host -> MPool.Factory IOError MongoDB.Pipe + factoryForHost host = MPool.Factory (newRes h) (killRes) (isResExpired) + + newRes :: MongoDB.Host -> ErrorT IOError IO MongoDB.Pipe + newRes = MongoDB.connect + + killRes :: MongoDB.Pipe -> IO () + killRes = MongoDB.close + + isResExpired :: MongoDB.Pipe -> IO Bool + isResExpired = MongoDB.isClosed + +------------------------------------------------------------------------------ +-- | +instance HasMongoDBState s => MonadMongoDB (Handler s s) where + withDB run = do + (MongoDBSnaplet pool db) <- getMongoDBState + epipe <- liftIO $ runErrorT $ MPool.aResource pool + case epipe of + Left err -> return $ Left $ ConnectionFailure err + Right pipe -> do + liftIO (access pipe master db run) + + withDBUnsafe run = do + (MongoDBSnaplet pool db) <- getMongoDBState + epipe <- liftIO $ runErrorT $ MPool.aResource pool + case epipe of + Left err -> return $ Left $ ConnectionFailure err + Right pipe -> do + liftIO (access pipe UnconfirmedWrites db run) + + +-- | Given a type in the type class 'MongoEntity', insert this as a new document in the database. The function will +-- yield the unique key for the new document. +insert :: (MongoDB.MonadIO' m, MongoEntity a) => a -> MongoDB.Action m (Key a) +insert obj = do + (BSON.ObjId objId) <- MongoDB.insert (collectionName obj) (fromDocument $ encodeDocument obj) + pure $! toKey objId + + +-- | Similar to 'insert', this function inserts multiple documents into the databsae, yielding a unique key for each. +insertMany :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => [a] -> MongoDB.Action m [Key a] +insertMany [] = pure [] +insertMany objs = do + ids <- MongoDB.insertMany (collectionName $ head objs) (map (fromDocument . encodeDocument) objs) + forM ids $ \x -> case x of + BSON.ObjId objId -> pure $! toKey objId + _ -> throwError $ MongoDB.QueryFailure 1000 "Expected object ID as result of 'insertMany'" + +-- | Similar to 'insert', but allows you to specify the ID with which the object is to be created. +insertWith :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Key a -> a -> MongoDB.Action m (Key a) +insertWith key obj = do + (BSON.ObjId objId) <- MongoDB.insert (collectionName obj) (("_id" =: fromKey key) : (fromDocument $ encodeDocument obj)) + pure $! toKey objId + + +-- | Given a unique key for a 'MongoEntity', yield that entity. If no document with the specified ID was found, the +-- function will yield @Nothing@. +get :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Key a -> MongoDB.Action m (Maybe a) +get key = do + let collection = collectionName (dummyFromKey key) + result <- MongoDB.findOne (MongoDB.select ["_id" =: fromKey key] collection) + case result of + Just document -> do + eObj <- runErrorT (decodeDocument $ toDocument document) + case eObj of + Left message -> throwError $ MongoDB.QueryFailure 1001 message + Right obj -> pure (Just obj) + Nothing -> + pure Nothing + +-- | The application of 'get' to many keys. +getMany :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => [Key a] -> MongoDB.Action m [Maybe a] +getMany = mapM get + +-- | Delete the document with the specified key. +delete :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Key a -> MongoDB.Action m () +delete key = do + let collection = collectionName (dummyFromKey key) + MongoDB.deleteOne (MongoDB.select ["_id" =: fromKey key] collection) + +deleteWhere :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Document a -> MongoDB.Action m () +deleteWhere doc = do + MongoDB.delete (MongoDB.select (fromDocument doc) (collectionName (dummyFromDocument doc))) + +count :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Document a -> MongoDB.Action m Int +count doc = do + MongoDB.count (MongoDB.select (fromDocument doc) (collectionName (dummyFromDocument doc))) + +type SelectorOption = MongoDB.Query -> MongoDB.Query + +offset :: Int -> SelectorOption +offset n q = q { MongoDB.skip = fromIntegral n } + +limit :: Int -> SelectorOption +limit n q = q { MongoDB.limit = fromIntegral n } + +orderAsc :: (MongoEntity a, MongoValue v) => (v -> Filter a) -> SelectorOption +orderAsc f q = q { MongoDB.sort = (filterFieldName (f undefined) =: (1 :: Int)) : MongoDB.sort q } + +orderDesc :: (MongoEntity a, MongoValue v) => (v -> Filter a) -> SelectorOption +orderDesc f q = q { MongoDB.sort = (filterFieldName (f undefined) =: ((-1) :: Int)) : MongoDB.sort q } + + +-- | Select all matching documents from a collection in the database. This function yields a list of pairs of the unique +-- key and the 'MongoEntity' for each matching document in the collection. +-- +-- The query can be made using either the quasi-quoted mongoDB query format: +-- +-- @select [mongo| { userName: #{name}, userPassword: #{password} |] []@ +-- +-- Or using the filter operations: +-- +-- @select (filters [UserName `eq` name, UserPassword `eq` password]) []@ +-- +-- /Note/: in the quasi-quotation the names of the fields correspond to the fields stored in the /database/, rather than +-- the fields of the record structure. +-- +select :: (Functor m, MonadControlIO m, MongoEntity a) => Document a -> [SelectorOption] -> MongoDB.Action m [(Key a, a)] +select document options = do + cursor <- MongoDB.find (foldr ($) (MongoDB.select (fromDocument document) (collectionName (dummyFromDocument document))) options) + objects <- MongoDB.rest cursor + values <- mapM fetchKeyValue objects + return $ catMaybes values + +-- | Similar to 'select', only yielding a single result. +selectOne :: (Functor m, MonadControlIO m, MongoEntity a) => Document a -> [SelectorOption] -> MongoDB.Action m (Maybe (Key a, a)) +selectOne document options = do + result <- MongoDB.findOne (foldr ($) (MongoDB.select (fromDocument document) (collectionName (dummyFromDocument document))) options) + case result of + Just obj -> fetchKeyValue obj + Nothing -> pure Nothing + + +save :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Key a -> a -> MongoDB.Action m () +save key obj = do + MongoDB.save (collectionName obj) (("_id" := BSON.ObjId (fromKey key)) : (fromDocument $ encodeDocument obj)) + + +update :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Key a -> Document a -> MongoDB.Action m () +update key updateDoc = do + MongoDB.modify (MongoDB.select [ "_id" =: (fromKey key) ] (collectionName (dummyFromKey key))) (fromDocument updateDoc) + +updateWhere :: (Functor m, MongoDB.MonadIO' m, MongoEntity a) => Document a -> Document a -> MongoDB.Action m () +updateWhere document updateDoc = do + MongoDB.modify (MongoDB.select (fromDocument document) (collectionName (dummyFromDocument document))) (fromDocument updateDoc) + + +filters :: (MongoEntity a) => [FilterOp] -> Document a +filters = toDocument + +updates :: (MongoEntity a) => [UpdateOp] -> Document a +updates = toDocument + + +fetchKeyValue :: (Functor m, MonadControlIO m, MongoEntity a) => BSON.Document -> MongoDB.Action m (Maybe (Key a, a)) +fetchKeyValue doc = do + case BSON.look "_id" doc of + Just i -> + case i of + BSON.ObjId objId -> do + eObj <- runErrorT (decodeDocument $ toDocument doc) + case eObj of + Left message -> throwError $ MongoDB.QueryFailure 1001 message + Right obj -> pure $ Just (toKey objId, obj) + _ -> throwError $ MongoDB.QueryFailure 1000 "Expected _id field to be an ObjectId in result of selection" + Nothing -> + throwError $ MongoDB.QueryFailure 1000 "Expected to find an _id field in result of selection" + + +------------------------------------------------------------------------------ +-- | Convert 'ObjectId' into 'ByteString' +objid2bs :: ObjectId -> BS.ByteString +objid2bs (Oid a b) = B8.pack . showHex a . showChar '-' . showHex b $ "" + + +------------------------------------------------------------------------------ +-- | Convert 'ByteString' into 'ObjectId' +bs2objid :: BS.ByteString -> Maybe ObjectId +bs2objid bs = do + case B8.split '-' bs of + (a':b':_) -> do + a <- fmap fst . headMay . readHex . B8.unpack $ a' + b <- fmap fst . headMay . readHex . B8.unpack $ b' + return $ Oid a b + _ -> Nothing + +------------------------------------------------------------------------------ +-- | Like 'bs2objid', but may blow with an error if the 'ByteString' can't be +-- converted to an 'ObjectId' +bs2objid' :: BS.ByteString -> ObjectId +bs2objid' = fromJust . bs2objid + +bs2cs :: BS.ByteString -> US.UString +bs2cs = CSI.CS + + +------------------------------------------------------------------------------ +-- | If the 'Document' has an 'ObjectId' in the given field, return it as +-- 'ByteString' +getObjId :: US.UString -> BSON.Document -> Maybe BS.ByteString +getObjId v d = MongoDB.lookup v d >>= fmap objid2bs + + +dummyFromKey :: Key a -> a +dummyFromKey _ = undefined + +dummyFromDocument :: Document a -> a +dummyFromDocument _ = undefined diff --git a/src/Snap/Snaplet/MongoDB/FilterOps.hs b/src/Snap/Snaplet/MongoDB/FilterOps.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/MongoDB/FilterOps.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Snap.Snaplet.MongoDB.FilterOps + ( FilterOp + + , (==?) + , (/=?) + , eq, ne, lt, lte, gt, gte + , or, ors + , isIn, notIn + + , UpdateOp + , (==:) + , set + , inc, dec + , pop, push, pull, pushAll, pullAll + , addToSet, addManyToSet + ) where + +import Prelude hiding (or) +import qualified Data.Bson as BSON +import Snap.Snaplet.MongoDB.MongoValue +import Snap.Snaplet.MongoDB.MongoEntity + + +infix 0 ==? -- Alias to eq operation +infix 0 /=? -- Alias to neq operation +infix 0 ==: -- Alias to set operation + +type FilterOp = BSON.Field + +(==?), (/=?), (==:) :: (MongoEntity a, MongoValue v) => (v -> Filter a) -> v -> FilterOp +(==?) = eq +(/=?) = ne +(==:) = set + +stdFilterDef :: (MongoEntity a, MongoValue v) => BSON.Label -> (v -> Filter a) -> v -> FilterOp +stdFilterDef op f v = + filterFieldName (f undefined) := BSON.Doc [op := toValue v] + +eq, ne, lt, lte, gt, gte :: (MongoEntity a, MongoValue v) => (v -> Filter a) -> v -> FilterOp +eq f v = filterFieldName (f undefined) := toValue v +ne = stdFilterDef "$ne" +lt = stdFilterDef "$lt" +lte = stdFilterDef "$lte" +gt = stdFilterDef "$gt" +gte = stdFilterDef "$gte" + +or :: BSON.Field -> BSON.Field -> FilterOp +or x y = "$or" := BSON.Doc [x, y] + +ors :: [BSON.Field] -> BSON.Field +ors fs = "$or" := BSON.Doc fs + +isIn, notIn :: (MongoEntity a, MongoValue v) => (v -> Filter a) -> [v] -> FilterOp +isIn f vs = filterFieldName (f undefined) := BSON.Doc [ "$in" := BSON.Array (map toValue vs) ] +notIn f vs = filterFieldName (f undefined) := BSON.Doc [ "$nin" := BSON.Array (map toValue vs) ] + + +type UpdateOp = BSON.Field + +set :: (MongoEntity a, MongoValue v) => (v -> Filter a) -> v -> UpdateOp +set f v = "$set" := BSON.Doc [ filterFieldName (f v) := toValue v ] + +inc, dec :: (MongoEntity a, Num v, MongoValue v) => (v -> Filter a) -> v -> UpdateOp +inc f v = "$inc" := BSON.Doc [ filterFieldName (f v) := toValue v ] +dec f v = "$dec" := BSON.Doc [ filterFieldName (f v) := toValue v ] + +push, addToSet, pull :: (MongoEntity a, MongoValue v) => ([v] -> Filter a) -> v -> UpdateOp +push f v = "$push" := BSON.Doc [ filterFieldName (f [v]) := toValue v ] +addToSet f v = "$addToSet" := BSON.Doc [ filterFieldName (f undefined) := toValue v ] +pull f v = "$pull" := BSON.Doc [ filterFieldName (f undefined) := toValue v ] + +pushAll, pullAll, addManyToSet :: (MongoEntity a, MongoValue v) => ([v] -> Filter a) -> [v] -> UpdateOp +pushAll f v = "$pushAll" := BSON.Doc [ filterFieldName (f undefined) := BSON.Array (map toValue v) ] +pullAll f v = "$pullAll" := BSON.Doc [ filterFieldName (f undefined) := BSON.Array (map toValue v) ] +addManyToSet f v = "$addToSet" := BSON.Doc [ filterFieldName (f undefined) := BSON.Doc [ "$each" := BSON.Array (map toValue v) ] ] + +pop :: (MongoEntity a, MongoValue v) => ([v] -> Filter a) -> UpdateOp +pop f = "$pop" := BSON.Doc [ filterFieldName (f undefined) := BSON.Int32 1 ] + + + +-- Local Variables: +-- mode : Haskell +-- fill-column : 120 +-- default-justification : left +-- End: diff --git a/src/Snap/Snaplet/MongoDB/MongoEntity.hs b/src/Snap/Snaplet/MongoDB/MongoEntity.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/MongoDB/MongoEntity.hs @@ -0,0 +1,76 @@ +{-# 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: diff --git a/src/Snap/Snaplet/MongoDB/MongoValue.hs b/src/Snap/Snaplet/MongoDB/MongoValue.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/MongoDB/MongoValue.hs @@ -0,0 +1,307 @@ +{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, TypeFamilies #-} +{-# LANGUAGE TupleSections, TypeSynonymInstances, RankNTypes, ScopedTypeVariables, IncoherentInstances #-} + +module Snap.Snaplet.MongoDB.MongoValue + ( MongoValue (..) + , BSON.Value (..) +-- , BSON.Document (..) + , BSON.Field (..) + , BSON.ObjectId (..) + , nullObjectId + , expected +-- , lookMaybe + , lookupThrow + ) where + +import Prelude hiding (lookup, or) +import Control.Applicative +import Control.Monad.Error +import Data.Bson (Field ((:=)), ObjectId (..)) +import qualified Data.Bson as BSON +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.Char +import qualified Data.CompactString.UTF8 as CS +import Data.Int +import Data.List (find) +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Encoding as LT +import Data.Time +import Data.Time.Clock.POSIX +import Text.Printf + + + +-- | This type class represents all types which can be marshalled too and from the BSON format. +class MongoValue a where + toValue :: a -> BSON.Value + fromValue :: (Applicative m, Monad m) => BSON.Value -> ErrorT String m a + + +expected :: (Monad m) => String -> BSON.Value -> ErrorT String m a +expected what was = + throwError $ printf "Expected %s; found %s" what (describeType was) + where + describeType :: BSON.Value -> String + describeType (BSON.Float _) = "Float" + describeType (BSON.String _) = "String" + describeType (BSON.Doc _) = "Document" + describeType (BSON.Array n) = printf "Array (BSON.with %i elements)" (length n) + describeType (BSON.Bin _) = "Binary" + describeType (BSON.Fun _) = "Function" + describeType (BSON.Uuid _) = "UUID" + describeType (BSON.Md5 _) = "MD5" + describeType (BSON.UserDef _) = "UserDefined" + describeType (BSON.ObjId _) = "ObjectId" + describeType (BSON.Bool _) = "Bool" + describeType (BSON.UTC _) = "UTCTime" + describeType (BSON.Null ) = "null" + describeType (BSON.RegEx _) = "RegEx" + describeType (BSON.JavaScr _) = "JavaScript" + describeType (BSON.Sym _) = "Symbol" + describeType (BSON.Int32 _) = "Int32" + describeType (BSON.Int64 _) = "Int64" + describeType (BSON.Stamp _) = "Stamp" + describeType (BSON.MinMax _) = "MinMax" + + +-- | Represents a null 'ObjectId' (all zeros). +nullObjectId :: ObjectId +nullObjectId = Oid 0 0 + +lookMaybe :: T.Text -> BSON.Document -> Maybe BSON.Value +lookMaybe name doc = + let name' = textToCompactString name in maybe Nothing (Just . BSON.value) $ find ((name' ==) . BSON.label) doc + +lookupThrow :: (Applicative m, Monad m, MongoValue a) => T.Text -> BSON.Document -> ErrorT String m a +lookupThrow name doc = + case lookMaybe name doc of + Just val -> fromValue val + Nothing -> throwError $ printf "Could not find field '%s'" (T.unpack name) + +instance MongoValue BSON.Value where + toValue = id + fromValue = return . id + +instance MongoValue BSON.Document where + toValue = BSON.Doc + fromValue (BSON.Doc d) = pure d + fromValue v = expected "Document" v + +instance MongoValue () where + toValue _ = BSON.Null + fromValue BSON.Null = pure () + fromValue v = expected "null" v + +instance MongoValue Bool where + toValue = BSON.Bool + fromValue (BSON.Bool x) = pure x + fromValue v = expected "boolean" v + +instance MongoValue BSON.UString where + toValue = BSON.String + fromValue (BSON.String x ) = pure x + fromValue (BSON.Sym (BSON.Symbol x)) = pure x + fromValue v = expected "string or symbol" v + +instance MongoValue T.Text where + toValue = BSON.String . textToCompactString + fromValue (BSON.String x ) = pure $! compactStringToText x + fromValue (BSON.Sym (BSON.Symbol x)) = pure $! compactStringToText x + fromValue v = expected "string or symbol" v + +instance MongoValue LT.Text where + toValue = BSON.String . lazyTextToCompactString + fromValue (BSON.String x ) = pure $! compactStringToLazyText x + fromValue (BSON.Sym (BSON.Symbol x)) = pure $! compactStringToLazyText x + fromValue v = expected "string or symbol" v + +instance MongoValue (Maybe BSON.Value) where + toValue Nothing = BSON.Null + toValue (Just x) = x + + fromValue BSON.Null = pure Nothing + fromValue x = pure (Just x) + +instance (MongoValue a) => MongoValue (Maybe a) where + toValue Nothing = BSON.Null + toValue (Just x) = toValue x + + fromValue BSON.Null = pure Nothing + fromValue x = Just <$> (fromValue x) + + +instance (MongoValue a) => MongoValue [a] where + toValue = BSON.Array . map toValue + fromValue (BSON.Array x) = mapM fromValue x + fromValue v = expected "array" v + +instance (MongoValue a, MongoValue b) => MongoValue (Either a b) where + toValue (Left x) = BSON.Doc [ "_type" := (BSON.String $ BSON.u "Left" ), "value" := toValue x ] + toValue (Right y) = BSON.Doc [ "_type" := (BSON.String $ BSON.u "Right"), "value" := toValue y ] + + fromValue (BSON.Doc doc) = do + side <- fmap (map toLower) $ BSON.lookup "_type" doc + case side of + ("left" :: String) -> (return . Left) =<< fromValue =<< BSON.look "value" doc + ("right" :: String) -> (return . Right) =<< fromValue =<< BSON.look "value" doc + other -> throwError $ "Expected either 'left' or 'right', found '" ++ other ++ "'" + fromValue v = expected "document" v + +roundTo :: (RealFrac a) => a -> a -> a +roundTo mult n = fromIntegral (round (n / mult)) * mult + +instance MongoValue UTCTime where + toValue = BSON.UTC . posixSecondsToUTCTime . roundTo (1 / 1000) . utcTimeToPOSIXSeconds + fromValue (BSON.UTC x) = pure x + fromValue v = expected "UTCTime" v + +instance MongoValue POSIXTime where + toValue = BSON.UTC . posixSecondsToUTCTime . roundTo (1 / 1000) + fromValue (BSON.UTC x) = pure $! utcTimeToPOSIXSeconds x + fromValue v = expected "UTCTime" v + +instance MongoValue BS.ByteString where + toValue = BSON.Bin . BSON.Binary + fromValue (BSON.Bin (BSON.Binary x)) = pure x + fromValue v = expected "binary" v + +instance MongoValue BSL.ByteString where + toValue = BSON.Bin . BSON.Binary . BS.concat . BSL.toChunks + fromValue (BSON.Bin (BSON.Binary x)) = pure $! BSL.fromChunks [x] + fromValue v = expected "binary" v + + + +fitInt :: forall m b a. (Applicative m, Monad m, PrintfArg a, Integral a, Integral b, Bounded b) => String -> a -> ErrorT String m b +fitInt t n = + let l = minBound :: b + h = maxBound :: b + in if fromIntegral l <= n && n <= fromIntegral h + then pure $! fromIntegral n + else throwError $ printf "Integer value %i was out of range for type %s" n t + + +instance MongoValue Int32 where + toValue = BSON.Int32 + fromValue (BSON.Int32 x) = pure x + fromValue (BSON.Int64 x) = fitInt "Int32" x + fromValue (BSON.Float x) = pure $! round x + fromValue v = expected "Int32, Int64 or Float" v + +instance MongoValue Int64 where + toValue = BSON.Int64 + fromValue (BSON.Int32 x) = pure $! fromIntegral x + fromValue (BSON.Int64 x) = pure x + fromValue (BSON.Float x) = pure $! round x + fromValue v = expected "Int32, Int64 or Float" v + +instance MongoValue Int where + toValue = BSON.Int64 . fromIntegral + fromValue (BSON.Int32 x) = pure $! fromIntegral x + fromValue (BSON.Int64 x) = pure $! fromEnum x + fromValue (BSON.Float x) = pure $! round x + fromValue v = expected "Int32, Int64 or Float" v + +instance MongoValue Integer where + toValue = BSON.Int64 . fromIntegral + fromValue (BSON.Int32 x) = pure $! fromIntegral x + fromValue (BSON.Int64 x) = pure $! fromIntegral x + fromValue (BSON.Float x) = pure $! round x + fromValue v = expected "Int32, Int64 or Float" v + +instance MongoValue Float where + toValue = BSON.Float . realToFrac + fromValue (BSON.Float x) = pure $! realToFrac x + fromValue (BSON.Int32 x) = pure $! fromIntegral x + fromValue (BSON.Int64 x) = pure $! fromIntegral x + fromValue v = expected "Int32, Int64 or Float" v + +instance MongoValue Double where + toValue = BSON.Float + fromValue (BSON.Float x) = pure x + fromValue (BSON.Int32 x) = pure $! fromIntegral x + fromValue (BSON.Int64 x) = pure $! fromIntegral x + fromValue v = expected "Int32 or Int64" v + +instance MongoValue ObjectId where + toValue = BSON.ObjId + fromValue (BSON.ObjId x) = pure x + fromValue v = expected "ObjectId" v + +instance (MongoValue a, MongoValue b) => MongoValue (a, b) where + toValue (x, y) = BSON.Array [toValue x, toValue y] + fromValue v @ (BSON.Array xs) = + case xs of + [x, y] -> (,) <$> fromValue x <*> fromValue y + _ -> expected "Array (with 2 elements)" v + fromValue v = expected "Array (with 2 elements)" v + +instance (MongoValue a, MongoValue b, MongoValue c) => MongoValue (a, b, c) where + toValue (x, y, z) = BSON.Array [toValue x, toValue y, toValue z] + fromValue v @ (BSON.Array xs) = + case xs of + [x, y, z] -> (,,) <$> fromValue x <*> fromValue y <*> fromValue z + _ -> expected "Array (with 3 elements)" v + fromValue v = expected "Array (with 3 elements)" v + + +-- | Instance of the 'MongoValue' type class for a map of strict 'T.Text' to some value which also an instance of the +-- 'MongoValue' type class. This type class is provided for more efficient storage of maps with textual keys. +-- +-- For example, the map @M.fromList [("cat", 1), ("dog", 2), ("mat", 3)]@ would yield the JSON equivalent of: +-- @{ cat: 1, dog: 2, mat: 3 }@. +-- +instance (MongoValue val) => MongoValue (M.Map T.Text val) where + toValue m = BSON.Doc $ map (\(k, v) -> textToCompactString k := toValue v) $ M.toList m + fromValue (BSON.Doc m) = do + elements <- mapM (\ (k := v) -> do + val <- fromValue v + pure (compactStringToText k, val)) m + pure $! M.fromList elements + fromValue v = expected "Document" v + +-- | Instance of the 'MongoValue' type class for a map of lazy 'LT.Text' to some value which also an instance of the +-- 'MongoValue' type class. This type class is provided for more efficient storage of maps with textual keys. +-- +-- For example, the map @M.fromList [("cat", 1), ("dog", 2), ("mat", 3)]@ would yield the JSON equivalent of: +-- @{ cat: 1, dog: 2, mat: 3 }@. +-- +instance (MongoValue val) => MongoValue (M.Map LT.Text val) where + toValue m = BSON.Doc $ map (\(k, v) -> lazyTextToCompactString k := toValue v) $ M.toList m + fromValue (BSON.Doc m) = do + elements <- mapM (\ (k := v) -> do + val <- fromValue v + pure (compactStringToLazyText k, val)) m + pure $! M.fromList elements + fromValue v = expected "Document" v + + +instance (Ord key, MongoValue key, MongoValue val) => MongoValue (M.Map key val) where + toValue = toValue . M.toList + fromValue v = M.fromList <$> fromValue v + + + +compactStringToText :: CS.CompactString -> T.Text +compactStringToText = T.decodeUtf8 . CS.toByteString + +textToCompactString :: T.Text -> CS.CompactString +textToCompactString = CS.fromByteString_ . T.encodeUtf8 + +compactStringToLazyText :: CS.CompactString -> LT.Text +compactStringToLazyText = + LT.decodeUtf8 . (\x -> BSL.fromChunks [x]) . CS.toByteString + +lazyTextToCompactString :: LT.Text -> CS.CompactString +lazyTextToCompactString = + CS.fromByteString_ . BS.concat . BSL.toChunks . LT.encodeUtf8 + +-- Local Variables: +-- mode : Haskell +-- fill-column : 120 +-- default-justification : left +-- End: diff --git a/src/Snap/Snaplet/MongoDB/Parse.hs b/src/Snap/Snaplet/MongoDB/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/MongoDB/Parse.hs @@ -0,0 +1,491 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-missing-fields #-} + + +module Snap.Snaplet.MongoDB.Parse + ( mongo + ) where + +import Control.Applicative +--import qualified Data.Bson as BSON +--import Data.Bson (Field ((:=))) +import Data.Char (isSpace, digitToInt) +import Data.Text (Text) +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Syntax.Internals +import Language.Haskell.TH.Quote +import qualified Language.Haskell.Exts as H +import Snap.Snaplet.MongoDB.MongoValue +import Snap.Snaplet.MongoDB.MongoEntity +import Text.Parsec hiding (many, (<|>)) + +mongo :: QuasiQuoter +mongo = QuasiQuoter { quoteExp = mongoQuote } + +mongoQuote :: String -> Q Exp +mongoQuote input = do + expr <- runParserT parseMongo () "" input + case expr of + Left err -> error $ show err + Right e -> return e + + +type Parser = ParsecT String () Q + +parseMongo :: Parser Exp +parseMongo = do + doc <- whitespace *> topObjectDef + return ((VarE 'toDocument) `AppE` doc) + where + topObjectDef = + singleField <|> multipleFields + singleField = + (ListE . (: [])) <$> objectField + multipleFields = + objectDef + +whitespace :: Parser () +whitespace = + skipMany . satisfy $ isSpace + +lexeme :: Parser a -> Parser a +lexeme p = + p <* whitespace + +objectDef :: Parser Exp +objectDef = + (lexeme (char '{') "'{' at start of JSON object") + *> (lexeme objectFields) <* + (lexeme (char '}') "'}' at end of JSON object") + +objectFields :: Parser Exp +objectFields = do + ListE <$> sepBy objectField (lexeme $ char ',') + +objectField :: Parser Exp +objectField = do + name <- lexeme (identifier <|> stringLiteral) "identifier for field definition" + _ <- lexeme (char ':') + val <- lexeme (fieldValue <|> arrayValue <|> objectDef) ("value for field `" ++ name ++ "'") + + return (InfixE (Just . LitE . StringL $ name) + (ConE '(:=)) + (Just (AppE (VarE 'toValue) val))) + +arrayValue :: Parser Exp +arrayValue = do + (lexeme (char '[') "'[' at start of JSON array") + *> (lexeme arrayElements) <* + (lexeme (char ']') "']' at end of JSON array") + where + arrayElements = + ListE . map ((VarE 'toValue) `AppE`) <$> sepBy (fieldValue <|> arrayValue <|> objectDef) (lexeme $ char ',') + + +fieldValue :: Parser Exp +fieldValue = do + (stringValue <|> altBaseIntegerValue <|> numericalValue <|> boolNullValue <|> pasteValue) "field value" + where + stringValue = + ((`SigE` (ConT ''Text)) . LitE . StringL) <$> stringLiteral + + numericalValue = do + int <- decimal + rl <- do + (Left . (+ fromIntegral int) <$> denom) <|> pure (Right int) + mEx <- option Nothing (Just <$> (oneOf "eE" *> (option id ((char '-' *> pure negate) <|> (char '+' *> pure id)) <*> decimal))) + case mEx of + Just ex -> pure $! ((`SigE` (ConT ''Double)) . LitE . RationalL. toRational $ either id fromIntegral rl * (10 ** fromIntegral ex)) + Nothing -> + case rl of + Left f -> pure $! ((`SigE` (ConT ''Double)) . LitE . RationalL . toRational $ f) + Right i -> pure $! ((`SigE` (ConT ''Integer)) . LitE . IntegerL $ i) + altBaseIntegerValue = + ((`SigE` (ConT ''Integer)) . LitE . IntegerL) <$> (hexadecimal <|> octal <|> binary) + hexadecimal = try (char '0' *> oneOf "xX" *> numberBuilder 16 hexDigit) + octal = try (char '0' *> oneOf "oO" *> numberBuilder 8 octDigit) + binary = try (char '0' *> oneOf "bB" *> numberBuilder 2 (char '0' <|> char '1')) + denom = + let op = ((/ 10) .) . ((+) . (fromIntegral . digitToInt)) + in pure (foldr op 0.0) <*> (char '.' *> many1 digit) + + boolNullValue = + identifier >>= (\i -> case i of + "true" -> pure . ConE $ 'True + "false" -> pure . ConE $ 'False + "null" -> pure . ConE $ '() + _ -> unexpected i) + pasteValue = do + text <- (char '#' *> betweenBraces) + case H.parseExp text of + H.ParseOk expr -> return (mapExpToTH expr) + H.ParseFailed _ msg -> parserFail msg + +betweenBraces :: Parser String +betweenBraces = do + between (char '{') (char '}') (concat <$> many insideBraces) + where + insideBraces = do + ((\s -> '{' : s ++ "}") <$> betweenBraces) <|> ((: []) <$> satisfy (/= '}')) + + +identifier :: Parser String +identifier = + try (ident "identifier") + where + ident = do + c <- (letter <|> char '_' <|> char '$') + cs <- many (alphaNum <|> char '_') + return (c : cs) + + +stringLiteral :: Parser String +stringLiteral = + (do + str <- between (char '"') + (char '"' "end of string") + (many stringChar) + return . foldr (maybe id (:)) "" $ str) "string literal" + +stringChar :: Parser (Maybe Char) +stringChar = + ( do + c <- stringLetter + return $ Just c) <|> stringEscape "string character" + +stringLetter :: Parser Char +stringLetter = + satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) + +stringEscape :: Parser (Maybe Char) +stringEscape = + char '\\' *> ((escapeGap *> return Nothing) <|> + (escapeEmpty *> return Nothing) <|> + (Just <$> escapeCode )) + where + escapeEmpty = char '&' + escapeGap = many1 space >> (char '\\' "end of string gap") + escapeCode = charEsc <|> charNum <|> charAscii <|> charControl "escape code" + + charControl = char '^' *> ((\c -> toEnum (fromEnum c - fromEnum 'A')) <$> upper) + charNum = + (toEnum . fromInteger) <$> (decimal <|> (char 'o' *> numberBuilder 8 octDigit) + <|> (char 'x' *> numberBuilder 16 hexDigit)) + charEsc = + choice (map parseEsc escMap) + where + parseEsc (c, code) = char c *> pure code + + charAscii = + choice (map parseAscii asciiMap) + where + parseAscii (asc, code) = try (string asc *> pure code) + + escMap = zip "abfnrtv\\\"\'" "\a\b\f\n\r\t\v\\\"\'" + asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) + + ascii2codes = [ "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", "EM", "FS", + "GS", "RS", "US", "SP" ] + ascii3codes = [ "NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL", "DLE", + "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB", "CAN", "SUB", + "ESC", "DEL" ] + ascii2 = [ '\BS', '\HT', '\LF', '\VT', '\FF', '\CR', '\SO', '\SI', '\EM', + '\FS', '\GS', '\RS', '\US', '\SP' ] + ascii3 = [ '\NUL', '\SOH', '\STX', '\ETX', '\EOT', '\ENQ', '\ACK', '\BEL', + '\DLE', '\DC1', '\DC2', '\DC3', '\DC4', '\NAK', '\SYN', '\ETB', + '\CAN', '\SUB', '\ESC', '\DEL' ] + + +numberBuilder :: Integer -> Parser Char -> Parser Integer +numberBuilder base baseDigit = do + digits <- many1 baseDigit + let n = foldl (\x d -> base * x + toInteger (digitToInt d)) 0 digits + seq n (return n) + +decimal :: Parser Integer +decimal = numberBuilder 10 digit + + +------------------------------------------------------------------------------------------------------------------------ + + +mapQName :: H.QName -> Name +mapQName (H.Qual modu name) = Name (OccName $ strFromName name) (NameQ (ModName $ strFromModule modu)) +mapQName (H.UnQual name) = mkName (strFromName name) +mapQName (H.Special con) = + case con of + H.UnitCon -> '() + H.ListCon -> '[] + H.FunCon -> mkName "(->)" + H.TupleCon _ n -> mkName ('(' : replicate n ',' ++ ")") + H.Cons -> '(:) +-- H.UnboxedSingleCon -> '(# #) + H.UnboxedSingleCon -> error "No name for unboxed constructor" + +mapName :: H.Name -> Name +mapName = mkName . strFromName + +strFromName :: H.Name -> String +strFromName (H.Ident str) = str +strFromName (H.Symbol op) = op + +strFromModule :: H.ModuleName -> String +strFromModule (H.ModuleName name) = name + +mapDecl :: H.Decl -> [Dec] +mapDecl (H.TypeDecl _ name binds typ) = [TySynD (mapName name) (map mapTypeBind binds) (mapTypeToTH typ)] +mapDecl (H.TypeFamDecl _ name binds mKind) = [FamilyD TypeFam (mapName name) (map mapTypeBind binds) (maybe Nothing (Just . mapKind) mKind)] +mapDecl (H.DataDecl _ H.DataType ctx name binds qConDecl deriv) = [DataD (mapContext ctx) (mapName name) (map mapTypeBind binds) + (map mapQCon qConDecl) (map (mapQName . fst) deriv)] +mapDecl (H.DataDecl _ H.NewType ctx name binds qConDecl deriv) = [NewtypeD (mapContext ctx) (mapName name) (map mapTypeBind binds) + (mapQCon (head qConDecl)) (map (mapQName . fst) deriv)] +mapDecl (H.GDataDecl _ _ _ _ _ _ _ _) = error "No support for GADTs in Template Haskell" +mapDecl (H.DataFamDecl _ _ name binds mKind) = [FamilyD DataFam (mapName name) (map mapTypeBind binds) (maybe Nothing (Just . mapKind) mKind)] +mapDecl (H.TypeInsDecl _ _ _) = error "No support for type instances" +mapDecl (H.DataInsDecl _ H.DataType _ _ _) = error "No support for data instances" +mapDecl (H.DataInsDecl _ H.NewType _ _ _ ) = error "No support for data instances" +mapDecl (H.GDataInsDecl _ _ _ _ _ _) = error "No support for GADTs in Template Haskell" +mapDecl (H.ClassDecl _ ctx name binds funDeps classDecls) = [ClassD (mapContext ctx) (mapName name) (map mapTypeBind binds) + (map mapFunDep funDeps) (map mapClassDecl classDecls)] +mapDecl (H.InstDecl _ ctx _ types instDecls) = [InstanceD (mapContext ctx) (mapTypeToTH (head types)) (map mapInstDecl instDecls)] +mapDecl (H.DerivDecl _ _ _ _) = error "No support for standalone deriving declarations in Template Haskell" +mapDecl (H.InfixDecl _ _ _ _) = error "No support for operator fixity declarations in Template Haskell" +mapDecl (H.DefaultDecl _ _) = error "No support for default declarations in Template Haskell" +mapDecl (H.SpliceDecl _ _) = error "Template Haskell brackets cannot be nested (without intervening splices)" +mapDecl (H.TypeSig _ names typ) = map (flip SigD (mapTypeToTH typ) . mapName) names +mapDecl (H.FunBind matches) = [FunD (matchName (head matches)) (map mapClause matches)] +mapDecl (H.PatBind _ pat _ rhs binds) = [ValD (mapPatToTH pat) (mapRhs rhs) (mapBinds binds)] +mapDecl (H.ForImp _ cc safe str name typ) = [ForeignD (ImportF (mapCC cc) (mapSafety safe) str (mapName name) (mapTypeToTH typ))] +mapDecl (H.ForExp _ cc str name typ) = [ForeignD (ExportF (mapCC cc) str (mapName name) (mapTypeToTH typ))] +mapDecl (H.RulePragmaDecl _ _) = error "No support for RULES pragma in Template Haskell" +mapDecl (H.DeprPragmaDecl _ _) = error "No support for DEPRECATED pragma in Template Haskell" +mapDecl (H.WarnPragmaDecl _ _) = error "No support for WARNING pragma in Template Haskell" +mapDecl (H.InlineSig _ _ _ name) = [PragmaD (InlineP (mapQName name) (InlineSpec True False Nothing))] +mapDecl (H.InlineConlikeSig _ _ _) = error "No current support for INLINE CONLIKE pragma" +mapDecl (H.SpecSig _ name types) = [PragmaD (SpecialiseP (mapQName name) (mapTypeToTH (head types)) Nothing)] +mapDecl (H.SpecInlineSig _ _ _ name types) = [PragmaD (SpecialiseP (mapQName name) (mapTypeToTH (head types)) (Just (InlineSpec True False Nothing)))] +mapDecl (H.InstSig _ _ _ _) = error "No support for SPECIALISE instance pragma in Template Haskell (I think...)" +mapDecl (H.AnnPragma _ _) = error "No support for ANN pragma in Template Haskell" + +mapCC :: H.CallConv -> Callconv +mapCC (H.StdCall) = StdCall +mapCC (H.CCall ) = CCall + +mapSafety :: H.Safety -> Safety +mapSafety (H.PlayRisky ) = Unsafe +mapSafety (H.PlaySafe t) = if t then Threadsafe else Safe + +matchName :: H.Match -> Name +matchName (H.Match _ name _ _ _ _) = mapName name + +mapClause :: H.Match -> Clause +mapClause (H.Match _ _ pats _ rhs binds) = Clause (map mapPatToTH pats) (mapRhs rhs) (mapBinds binds) + +mapRhs :: H.Rhs -> Body +mapRhs (H.UnGuardedRhs e) = NormalB (mapExpToTH e) +mapRhs (H.GuardedRhss guards) = + GuardedB (map mapGRhs guards) + where + mapGRhs (H.GuardedRhs _ stmts e) = (PatG (map mapStmt stmts), mapExpToTH e) + + +mapInstDecl :: H.InstDecl -> Dec +mapInstDecl (H.InsDecl decl) = head (mapDecl decl) +mapInstDecl _ = error "Unsupported" + +mapClassDecl :: H.ClassDecl -> Dec +mapClassDecl (H.ClsDecl decl) = head (mapDecl decl) +mapClassDecl _ = error "Unsupported" + +mapFunDep :: H.FunDep -> FunDep +mapFunDep (H.FunDep xs ys) = FunDep (map mapName xs) (map mapName ys) + +mapQCon :: H.QualConDecl -> Con +mapQCon (H.QualConDecl _ [] [] conDecl) = mapCon conDecl +mapQCon (H.QualConDecl _ binds ctx conDecl) = ForallC (map mapTypeBind binds) (mapContext ctx) (mapCon conDecl) + +mapCon :: H.ConDecl -> Con +mapCon (H.ConDecl name args) = NormalC (mapName name) (map mapBangType args) +mapCon (H.InfixConDecl x name y) = InfixC (mapBangType x) (mapName name) (mapBangType y) +mapCon (H.RecDecl name fields) = RecC (mapName name) $ map (uncurry mapFieldDecl) $ concatMap (uncurry ((. repeat) . zip)) fields + +mapFieldDecl :: H.Name -> H.BangType -> VarStrictType +mapFieldDecl name bType = let (strict, typ) = mapBangType bType + in (mapName name, strict, typ) + +mapBangType :: H.BangType -> StrictType +mapBangType (H.BangedTy t) = (IsStrict, mapTypeToTH t) +mapBangType (H.UnBangedTy t) = (NotStrict, mapTypeToTH t) +mapBangType (H.UnpackedTy _) = error "No support for unboxed type (via UNPACK pragma) in Template Haskell" + + +mapExpToTH :: H.Exp -> Exp +mapExpToTH (H.Var name) = VarE (mapQName name) +mapExpToTH (H.IPVar _) = error "No implicit parameter support" +mapExpToTH (H.Con name) = ConE (mapQName name) +mapExpToTH (H.Lit lit) = LitE (mapLitToTH lit) +mapExpToTH (H.InfixApp l op r) = InfixE (Just $ mapExpToTH l) (mapQOpToTH op) (Just $ mapExpToTH r) +mapExpToTH (H.App l r) = (mapExpToTH l) `AppE` (mapExpToTH r) +mapExpToTH (H.NegApp o) = AppE (VarE 'negate) (mapExpToTH o) +mapExpToTH (H.Lambda _ pat e) = LamE (map mapPatToTH pat) (mapExpToTH e) +mapExpToTH (H.Let bs e) = LetE (mapBinds bs) (mapExpToTH e) +mapExpToTH (H.If e t f) = CondE (mapExpToTH e) (mapExpToTH t) (mapExpToTH f) +mapExpToTH (H.Case e ms) = CaseE (mapExpToTH e) (map mapAlt ms) +mapExpToTH (H.Do s) = DoE (map mapStmt s) +mapExpToTH (H.MDo _) = error "No support for mdo expressions" +mapExpToTH (H.Tuple es) = TupE (map mapExpToTH es) +mapExpToTH (H.TupleSection _) = error "Tuple sections currently not supported by template haskell" +mapExpToTH (H.List es) = ListE (map mapExpToTH es) +mapExpToTH (H.Paren e) = mapExpToTH e +mapExpToTH (H.LeftSection e o) = InfixE (Just (mapExpToTH e)) (mapQOpToTH o) Nothing +mapExpToTH (H.RightSection o e) = InfixE Nothing (mapQOpToTH o) (Just (mapExpToTH e)) +mapExpToTH (H.RecConstr n fs) = RecConE (mapQName n) (map mapFieldUpdate fs) +mapExpToTH (H.RecUpdate e fs) = RecUpdE (mapExpToTH e) (map mapFieldUpdate fs) +mapExpToTH (H.EnumFrom e) = ArithSeqE (FromR (mapExpToTH e)) +mapExpToTH (H.EnumFromTo x y) = ArithSeqE (FromToR (mapExpToTH x) (mapExpToTH y)) +mapExpToTH (H.EnumFromThen x y) = ArithSeqE (FromThenR (mapExpToTH x) (mapExpToTH y)) +mapExpToTH (H.EnumFromThenTo x y z) = ArithSeqE (FromThenToR (mapExpToTH x) (mapExpToTH y) (mapExpToTH z)) +mapExpToTH (H.ListComp e qs) = CompE (map mapQualStmt qs ++ [NoBindS $ mapExpToTH e]) +mapExpToTH (H.ParComp _ _) = error "No support for parallel list comprehensions in Template Haskell" +mapExpToTH (H.ExpTypeSig _ e t) = SigE (mapExpToTH e) (mapTypeToTH t) +mapExpToTH (H.VarQuote _) = error "Template Haskell brackets cannot be nested (without intervening splices)" +mapExpToTH (H.TypQuote _) = error "Template Haskell brackets cannot be nested (without intervening splices)" +mapExpToTH (H.BracketExp _) = error "Template Haskell brackets cannot be nested (without intervening splices)" +mapExpToTH (H.SpliceExp _) = error "Template Haskell brackets cannot be nested (without intervening splices)" +mapExpToTH (H.QuasiQuote _ _) = error "Template Haskell brackets cannot be nested (without intervening splices)" +mapExpToTH (H.XTag _ _ _ _ _) = error "No support for XML extension in Template Haskell" +mapExpToTH (H.XETag _ _ _ _) = error "No support for XML extension in Template Haskell" +mapExpToTH (H.XPcdata _) = error "No support for XML extension in Template Haskell" +mapExpToTH (H.XExpTag _) = error "No support for XML extension in Template Haskell" +mapExpToTH (H.XChildTag _ _) = error "No support for XML extension in Template Haskell" +mapExpToTH (H.CorePragma _ _) = error "No support for pragmas in Template Haskell" +mapExpToTH (H.SCCPragma _ _) = error "No support for pragmas in Template Haskell" +mapExpToTH (H.GenPragma _ _ _ _) = error "No support for pragmas in Template Haskell" +mapExpToTH (H.Proc _ _ _) = error "No support for arrows 'proc' in Template Haskell" +mapExpToTH (H.LeftArrApp _ _) = error "No support for left arrow application in Template Haskell" +mapExpToTH (H.RightArrApp _ _) = error "No support for right arrow application in Template Haskell" +mapExpToTH (H.LeftArrHighApp _ _) = error "No support for higher-order left arrow application in Template Haskell" +mapExpToTH (H.RightArrHighApp _ _) = error "No support for higher-order right arrow application in Template Haskell" + + +mapQualStmt :: H.QualStmt -> Stmt +mapQualStmt (H.QualStmt stmt) = mapStmt stmt +mapQualStmt _ = error "No support for SQL-like generalized list comprehensions (not supported by Template Haskell)" + +mapFieldUpdate :: H.FieldUpdate -> FieldExp +mapFieldUpdate (H.FieldUpdate n e) = (mapQName n, mapExpToTH e) +mapFieldUpdate (H.FieldPun _) = error "No support for field puns in update expressions" +mapFieldUpdate (H.FieldWildcard ) = error "No support for field wildcards in update expressions" + +mapAlt :: H.Alt -> Match +mapAlt (H.Alt _ p g bs) = Match (mapPatToTH p) (mapGuard g) (mapBinds bs) + +mapGuard :: H.GuardedAlts -> Body +mapGuard (H.UnGuardedAlt e) = NormalB (mapExpToTH e) +mapGuard (H.GuardedAlts gs) = + GuardedB (map mapGAlt gs) + where + mapGAlt (H.GuardedAlt _ stmts e) = (PatG (map mapStmt stmts), mapExpToTH e) + +mapStmt :: H.Stmt -> Stmt +mapStmt (H.Generator _ p e) = BindS (mapPatToTH p) (mapExpToTH e) +mapStmt (H.Qualifier e) = NoBindS (mapExpToTH e) +mapStmt (H.LetStmt bs) = LetS (mapBinds bs) +mapStmt (H.RecStmt rs) = ParS [map mapStmt rs] + +mapBinds :: H.Binds -> [Dec] +mapBinds (H.BDecls decls) = concatMap mapDecl decls +mapBinds (H.IPBinds _) = error "No support for implicit parameter bindings" + +mapQOpToTH :: H.QOp -> Exp +mapQOpToTH (H.QVarOp name) = VarE (mapQName name) +mapQOpToTH (H.QConOp name) = ConE (mapQName name) + +{- +mapQOpToTHT :: H.QOp -> Type +mapQOpToTHT (H.QVarOp name) = VarT (mapQName name) +mapQOpToTHT (H.QConOp name) = ConT (mapQName name) +-} + +mapPatToTH :: H.Pat -> Pat +mapPatToTH (H.PVar name) = VarP (mapName name) +mapPatToTH (H.PLit lit) = LitP (mapLitToTH lit) +mapPatToTH (H.PNeg _) = error "What?! (http://trac.haskell.org/haskell-src-exts/ticket/209)" +mapPatToTH (H.PNPlusK _ _) = error "No support for N+K patterns" +mapPatToTH (H.PInfixApp l n r) = InfixP (mapPatToTH l) (mapQName n) (mapPatToTH r) +mapPatToTH (H.PApp n p) = ConP (mapQName n) (map mapPatToTH p) +mapPatToTH (H.PTuple p) = TupP (map mapPatToTH p) +mapPatToTH (H.PList p) = ListP (map mapPatToTH p) +mapPatToTH (H.PParen p) = mapPatToTH p +mapPatToTH (H.PRec n pf) = RecP (mapQName n) (map mapPatFieldToTH pf) +mapPatToTH (H.PAsPat n p) = AsP (mapName n) (mapPatToTH p) +mapPatToTH (H.PWildCard ) = WildP +mapPatToTH (H.PIrrPat p) = TildeP (mapPatToTH p) +mapPatToTH (H.PatTypeSig _ p t) = SigP (mapPatToTH p) (mapTypeToTH t) +mapPatToTH (H.PViewPat _ _) = error "No support for view patterns" +mapPatToTH (H.PRPat _) = error "I don't know what a PR pattern is" +mapPatToTH (H.PXTag _ _ _ _ _) = error "No support for XML" +mapPatToTH (H.PXETag _ _ _ _) = error "No support for XML" +mapPatToTH (H.PXPcdata _) = error "No support for XML" +mapPatToTH (H.PXPatTag _) = error "No support for XML" +mapPatToTH (H.PXRPats _) = error "No support for XML" +mapPatToTH (H.PExplTypeArg _ _) = error "No support for explicit type arguments" +mapPatToTH (H.PQuasiQuote _ _) = error "No support for quasi-quotation" +mapPatToTH (H.PBangPat _) = error "No support for bang patterns" + +mapTypeToTH :: H.Type -> Type +mapTypeToTH (H.TyForall vb ctx t) = ForallT (maybe [] (map mapTypeBind) vb) (mapContext ctx) (mapTypeToTH t) +mapTypeToTH (H.TyFun l r) = AppT (AppT ArrowT (mapTypeToTH l)) (mapTypeToTH r) +mapTypeToTH (H.TyTuple _ ts) = foldl AppT (TupleT (length ts)) (map mapTypeToTH ts) +mapTypeToTH (H.TyList t) = AppT ListT (mapTypeToTH t) +mapTypeToTH (H.TyApp l r) = AppT (mapTypeToTH l) (mapTypeToTH r) +mapTypeToTH (H.TyVar v) = VarT (mapName v) +mapTypeToTH (H.TyCon c) = ConT (mapQName c) +mapTypeToTH (H.TyParen t) = mapTypeToTH t +mapTypeToTH (H.TyInfix l op r) = AppT (AppT (ConT $ mapQName op) (mapTypeToTH l)) (mapTypeToTH r) +mapTypeToTH (H.TyKind _ _) = error "No support for types with explicit type kinds" + +mapTypeBind :: H.TyVarBind -> TyVarBndr +mapTypeBind (H.KindedVar n k) = KindedTV (mapName n) (mapKind k) +mapTypeBind (H.UnkindedVar n) = PlainTV (mapName n) + +mapKind :: H.Kind -> Kind +mapKind (H.KindStar ) = StarK +mapKind (H.KindBang ) = error "No support for bang-kinds" +mapKind (H.KindFn x y) = ArrowK (mapKind x) (mapKind y) +mapKind (H.KindParen k) = mapKind k +mapKind (H.KindVar _) = error "No support for kind variables" + +mapContext :: H.Context -> Cxt +mapContext = + map mapAssert + where + mapAssert (H.ClassA q ts) = ClassP (mapQName q) (map mapTypeToTH ts) + mapAssert (H.InfixA x q y) = ClassP (mapQName q) [mapTypeToTH x, mapTypeToTH y] + mapAssert (H.IParam _ _) = error "No support for implicit parameter assertion" + mapAssert (H.EqualP x y) = EqualP (mapTypeToTH x) (mapTypeToTH y) + +mapPatFieldToTH :: H.PatField -> FieldPat +mapPatFieldToTH (H.PFieldPat name pat) = (mapQName name, mapPatToTH pat) +mapPatFieldToTH (H.PFieldPun _) = error "field puns not yet supported" +mapPatFieldToTH (H.PFieldWildcard ) = (mkName "", WildP) + +mapLitToTH :: H.Literal -> Lit +mapLitToTH (H.Char c) = CharL c +mapLitToTH (H.String s) = StringL s +mapLitToTH (H.Int i) = IntegerL i +mapLitToTH (H.Frac r) = RationalL r +mapLitToTH (H.PrimInt i) = IntPrimL i +mapLitToTH (H.PrimWord w) = WordPrimL w +mapLitToTH (H.PrimFloat f) = FloatPrimL f +mapLitToTH (H.PrimDouble d) = DoublePrimL d +mapLitToTH (H.PrimChar c) = CharL c +mapLitToTH (H.PrimString s) = StringPrimL s + + + +-- Local Variables: +-- mode : Haskell +-- fill-column : 120 +-- default-justification : left +-- End: diff --git a/src/Snap/Snaplet/MongoDB/Template.hs b/src/Snap/Snaplet/MongoDB/Template.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Snaplet/MongoDB/Template.hs @@ -0,0 +1,487 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} + + +module Snap.Snaplet.MongoDB.Template + ( asMongoEntity + , useDefaults + , setCollectionName + , forConstructor + , ConstructorOp + , setConstructorName + , renameFields + , assocFieldNames + , indexedFieldName + , setFieldReadOnly + , asMongoValue + , encodedViaShow + ) where + +import Control.Applicative +import Control.Monad.Error +import Control.Monad.State +import Control.Monad.Writer +import qualified Data.Bson as BSON +import Data.Char (toUpper, toLower) +import Data.List (find) +import Data.Maybe (catMaybes) +import Data.Text (Text) +import qualified Data.Text as T +import Language.Haskell.TH.Syntax hiding (lift) +import Snap.Snaplet.MongoDB.MongoValue +import Snap.Snaplet.MongoDB.MongoEntity + + +-- Represents a field declaration from the type we are to store. +data FieldDecl = -- A field in a record data type constructor. + FieldDecl { fieldName :: Name -- The actual name of the field. + , fieldSimpleName :: String -- The simple name of the field, as stored in the document (can be changed). + , fieldType :: Type + , fieldReadOnly :: Bool -- If 'True', the field will not be output by the 'toDocument' function. + } + -- Represents a field in a 'NormalC' data type constructor. + | SimpleFieldDecl { simpleFieldName :: String + , simpleFieldType :: Type } + +-- Represents a constructor to a data type. We blend both 'NormalC' and 'RecordC' data type constructors into this type. +data Constructor = Constructor { constrName :: Name -- The actual name of the constructor. + , constrSimpleName :: String -- The simple name of the constructor, as stored in the _type field in the document (can be changed). + , constrBody :: [FieldDecl] + } + +-- The environment in which our template builder lives. This is actually used as _state_, but whatever. +data TemplateEnv = TemplateEnv { envTypeName :: Name -- The name of the type we are generating a MongoEntity instance for. + , envSimpleTypeName :: String -- The simple name of the type. + , envCollectionName :: String -- The name of the collection to which we are to store this type. + , envEncodedViaShow :: Bool -- Is the 'MongoValue' instance encoded via Show/Read rather than toDocument/fromDocument? + , envConstructors :: [Constructor] + } + +type EndoFunctor a = a -> a +type TemplateGen = StateT TemplateEnv (WriterT (EndoFunctor [Dec]) Q) + + +-- | This function is used to indicate to 'asMongoEntity' and 'asMongoValue' that the default behaviour is to be used. +useDefaults :: TemplateGen () +useDefaults = return () + +-- | This function generates an instance of the 'MongoEntity' and 'MongoValue' type classes for the specified type. +asMongoEntity :: Name -> TemplateGen () -> Q [Dec] +asMongoEntity typeName actions = + runTemplateGen typeName (actions >> genEntityInstance >> genValueInstance) + +-- | This function generates an instance of the 'MongoValue' type class for the given type. If the type is to be encoded +-- via 'show' and 'read', then a 'MongoEntity' instance is /not/ created; otherwise one will be. +asMongoValue :: Name -> TemplateGen () -> Q [Dec] +asMongoValue typeName actions = do + runTemplateGen typeName $ do + actions + viaShow <- gets envEncodedViaShow + if viaShow then genValueViaShowInstance else (genEntityInstance >> genValueInstance) + + +-- | Set the name of the collection to which the type is to be stored. By default, the name of the collection is the +-- same as the name of the type. +setCollectionName :: String -> TemplateGen () +setCollectionName newName = + modify (\s -> s { envCollectionName = newName }) + +-- | Sets whether the 'MongoValue' instance for the type should be encoded via 'read' and 'show' rather than +-- 'fromDocument' and 'toDocument'. +encodedViaShow :: TemplateGen () +encodedViaShow = + modify (\s -> s { envEncodedViaShow = True }) + +-- | Operations over constructors live in the 'ConstructorOp' monad. +type ConstructorOp = StateT Constructor TemplateGen + +-- | For @foConstructor name ops@, perform @ops@ for the constructor matching @name@. This allows us to change the name +-- of the constructor stored in the @_type@ field, and alter the behaviour of individual fields. +forConstructor :: Name -> ConstructorOp () -> TemplateGen () +forConstructor name f = do + constrs <- dConstr name f =<< gets envConstructors + modify (\s -> s { envConstructors = constrs }) + where + dConstr _ _ [] = return [] + dConstr name f (x : xs) + | constrName x == name = do + (_, x') <- runStateT f x + return (x' : xs) + | otherwise = do + xs' <- dConstr name f xs + return (x : xs') + +-- | Set the name stored in the @_type@ field of the document for the current constructor. +setConstructorName :: String -> ConstructorOp () +setConstructorName newName = do + modify (\c -> c { constrSimpleName = newName }) + +-- | Set the field with the specified name to read only. This will mean that the 'toDocument' function will not output +-- this field. This means that the field's value will not be written to the document. +setFieldReadOnly :: Name -> ConstructorOp () +setFieldReadOnly name = + modify (\c -> c { constrBody = dField name (constrBody c) }) + where + dField _ [] = [] + dField name (f : fs) + | fieldName f == name = + f { fieldReadOnly = True } : fs + | otherwise = + f : dField name fs + +-- | Change the names of a number of fields. The default behaviour is for the fields in the document to have the same +-- name as the fields in the record type constructor. +assocFieldNames :: [(Name, String)] -> ConstructorOp () +assocFieldNames assocs = + modify (\c -> c { constrBody = dField (constrBody c) }) + where + dField [] = [] + dField (field : fields) = + case field of + FieldDecl name _ _ _ -> + (maybe field (\newName -> field { fieldSimpleName = newName }) $ lookup name assocs) : dField fields + SimpleFieldDecl name _ -> + let name' = mkName name in (maybe field (\newName -> field { simpleFieldName = newName }) $ lookup name' assocs) : dField fields + +-- | Renames fields in the order they are found in the type constructor. +renameFields :: [String] -> ConstructorOp () +renameFields newNames = + modify (\c -> c { constrBody = zipWith renameField newNames (constrBody c) }) + where + renameField newName (FieldDecl fn _ ft ro) = FieldDecl fn newName ft ro + renameField newName (SimpleFieldDecl _ ft) = SimpleFieldDecl newName ft + + +indexedFieldName :: Int -> Name +indexedFieldName = mkName . ("field" ++) . show + + +runTemplateGen :: Name -> TemplateGen () -> Q [Dec] +runTemplateGen typeName actions = do + (simpleName, constructors) <- getSimpleNameAndConstrs typeName + + let env = TemplateEnv { envTypeName = typeName + , envSimpleTypeName = simpleName + , envCollectionName = simpleName + , envEncodedViaShow = False + , envConstructors = buildConstructors constructors + } + (_, decls) <- runWriterT (runStateT actions env) + return $ decls [] + + +inner :: TemplateGen a -> TemplateGen (a, [Dec]) +inner action = do + state <- get + ((result, newState), decls) <- lift . lift $ runWriterT (runStateT action state) + put newState + return (result, decls []) + + +getSimpleNameAndConstrs :: Name -> Q (String, [Con]) +getSimpleNameAndConstrs typeName = do + typeInfo <- reify typeName + case typeInfo of + TyConI tyCon -> + case tyCon of + DataD _ n _ c _ -> return (dropPrefix $ show n, c ) + NewtypeD _ n _ c _ -> return (dropPrefix $ show n, [c]) + _ -> error $ "No able to handle `" ++ show typeName ++ "'; not a data or newtype" + _ -> error $ "Not able to handle `" ++ show typeName ++ "'; not a type constructor" + + +buildConstructors :: [Con] -> [Constructor] +buildConstructors = + map buildConstructor + where + buildConstructor :: Con -> Constructor + buildConstructor (NormalC name types) = + Constructor { constrName = name + , constrSimpleName = dropPrefix $ show name + , constrBody = map (\(n, (_, t)) -> SimpleFieldDecl { simpleFieldName = "field" ++ show n, simpleFieldType = t }) $ zip [1 ..] types + } + buildConstructor (RecC name fields) = + Constructor { constrName = name + , constrSimpleName = dropPrefix $ show name + , constrBody = map (\(n, _, t) -> + let (r, n') = if ((dropPrefix . show $ n) == ((uncapitalize . dropPrefix . show $ name) ++ "Id")) + then (True, "_id") + else (False, dropPrefix $ show n) + in FieldDecl { fieldName = n + , fieldSimpleName = n' + , fieldType = t + , fieldReadOnly = r + }) + fields + } + buildConstructor _ = error "Cannot build constructor for non-record or non-normal data type constructor" + + +-- Emits a declaration in the underlying writer monad. +emitDecl :: Dec -> TemplateGen () +emitDecl = lift . tell . (:) + +-- Generate the key newtype and the 'fromKey' and 'toKey' functions for the specified type. For a given type MyType, we +-- generate a newtype with the following definition: +-- +-- newtype Key MyType = MyTypeId { unMyTypeId :: ObjectId } +-- deriving (Show) +-- +-- The two functions 'toKey' and 'fromKey' are simply aliases for constructing and deconstructing this type: +-- +-- toKey = MyTypeId +-- fromKey = unMyTypeId +-- +genKeyDecls :: TemplateGen () +genKeyDecls = do + name <- gets envTypeName + name' <- gets envSimpleTypeName + emitDecl $ NewtypeInstD [] ''Key [ConT name] + (RecC (mkName $ name' ++ "Id") + [ (mkName $ "un" ++ name' ++ "Id", NotStrict, ConT ''ObjectId) ]) + [ ''Eq ] + emitDecl $ FunD (mkName "toKey") + [ Clause [] (NormalB . ConE . mkName $ name' ++ "Id") [] ] + emitDecl $ FunD (mkName "fromKey") + [ Clause [] (NormalB . VarE . mkName $ "un" ++ name' ++ "Id") []] + + +genDocumentDecls :: TemplateGen () +genDocumentDecls = do + name <- gets envTypeName + name' <- gets envSimpleTypeName + emitDecl $ NewtypeInstD [] ''Document [ConT name] + (RecC (mkName $ name' ++ "Document") + [ (mkName $ "un" ++ name' ++ "Document", NotStrict, ConT ''BSON.Document) ]) + [] + emitDecl $ FunD (mkName "toDocument") + [ Clause [] (NormalB . ConE . mkName $ name' ++ "Document") [] ] + emitDecl $ FunD (mkName "fromDocument") + [ Clause [] (NormalB . VarE . mkName $ "un" ++ name' ++ "Document") [] ] + + +genCollNameDecl :: TemplateGen () +genCollNameDecl = do + cName <- gets envCollectionName + emitDecl $ FunD (mkName "collectionName") + [ Clause [WildP] (NormalB $ LitE $ StringL cName) [] ] + + +-- This function generates the filter declaration. The filter type instance has the following form: +-- +-- data Filter MyType = MyFieldA Int | MyFieldB String | ... +-- +-- Where each field in MyType has a constructor in the (Filter MyType) data type. +genFilterDecl :: TemplateGen () +genFilterDecl = do + name <- gets envTypeName + constrs <- gets envConstructors + let cons = catMaybes $ concatMap (\c -> map (buildFieldCon (dropPrefix . show $ constrName c)) (constrBody c)) constrs + emitDecl $ DataInstD [] ''Filter [ConT name] + (map fst cons) + [] + let clauses = map (\((NormalC name _), fName) -> + Clause [ConP name [WildP]] (NormalB . LitE . StringL . dropPrefix . show $ fName) []) cons + if not . null $ clauses + then emitDecl $ FunD (mkName "filterFieldName") clauses + else emitDecl $ FunD (mkName "filterFieldName") [Clause [WildP] (NormalB ((VarE 'error) `AppE` (LitE $ StringL "no filters can be defined"))) []] + where + buildFieldCon :: String -> FieldDecl -> Maybe (Con, Name) + buildFieldCon constrName (FieldDecl fieldName simpleName fType _) = + if ((dropPrefix . show $ fieldName) == (uncapitalize constrName ++ "Id")) || + (simpleName == "_id") + then Nothing + else Just (NormalC (mkName . capitalize . dropPrefix . show $ fieldName) [(NotStrict, fType)], mkName simpleName) + buildFieldCon _ (SimpleFieldDecl _ _) = + Nothing + + + +-- This function generates the 'encodeDocument' function for the 'MongoEntity' instance. The 'encodeDocument' function +-- generates a Document from an instance of the type. For example, given the type: +-- +-- data A = A { fieldA :: Int +-- , fieldB :: String +-- } +-- | B { fieldC :: String +-- , fieldD :: Int +-- } +-- +-- A document will have one of the following forms: +-- +-- { _type: "A", fieldA: 123, fieldB: "hello" } +-- { _type: "B", fieldA: "world", fieldB: 456 } +-- +-- The Haskell code to generate this will be equivalent to: +-- +-- encodeDocument (A field1 field2) = toDocument [ "_type" := toValue "A", "fieldA" := toValue field1, "fieldB" := toValue field2 ] +-- encodeDocument (B field1 field2) = toDocument [ "_type" := toValue "B", "fieldC" := toValue field1, "fieldD" := toValue field2 ] +-- +-- +-- Note: The extra field '_type' is stored in the document such that we know which constructor to use when we load the +-- document back into Haskell. +-- +-- Note: A field will not be written to the document if it has been set 'readOnly'. +-- +-- Note: A field will not be written to the document if it matches as the ID of the document. A field is recognised as +-- the ID of the document if it's name matches the constructor of the type, followed by "Id". For example, for a data +-- type constructor 'MyType', a field with the name 'myTypeId' will be assumed to be the ID field. +-- +genEncodeDocument :: TemplateGen () +genEncodeDocument = do + constrs <- gets envConstructors + emitDecl $ FunD (mkName "encodeDocument") $ map buildClause constrs + where + buildClause :: Constructor -> Clause + buildClause constr = +-- let patNames = map (mkName . ("field" ++) . show . fst) $ zip [1 ..] (constrBody constr) + let fn (FieldDecl _ n _ _) = n + fn (SimpleFieldDecl n _) = n + patNames = map (mkName . ('_' :) . fn) (constrBody constr) + setType = InfixE (Just . LitE $ StringL "_type") + (ConE '(:=)) + (Just ((VarE 'toValue) `AppE` ((LitE $ StringL (constrSimpleName constr)) `SigE` (ConT ''Text)))) + setFields = catMaybes (map (genField (dropPrefix . show $ constrName constr)) (zip patNames (constrBody constr))) + in Clause [ConP (constrName constr) (map VarP patNames)] + (NormalB $ ((VarE 'toDocument) `AppE` (ListE (setType : setFields)))) + [] + + genField :: String -> (Name, FieldDecl) -> Maybe Exp + genField constrName (patName, SimpleFieldDecl fieldName _) = + Just (InfixE (Just . LitE . StringL $ fieldName) (ConE '(:=)) (Just ((VarE 'toValue) `AppE` (VarE patName)))) + genField constrName (patName, FieldDecl fieldName simpleName _ readOnly) = + if readOnly || + ((dropPrefix . show $ fieldName) == (uncapitalize constrName ++ "Id")) || + (simpleName == "_id") + then Nothing + else Just (InfixE (Just . LitE . StringL $ simpleName) (ConE '(:=)) (Just ((VarE 'toValue) `AppE` (VarE patName)))) + +{- +decodeDocument doc' = do + let doc = fromDocument doc' + typ <- lookupThrow "_type" doc + case typ of + "A" -> A <$> lookupThrow "fieldA" doc <*> lookupThrow "fieldB" doc + other -> throwError $ "Unknown type constructor '" ++ other ++ "' found in collection for data type '" ++ "A" +-} + +genDecodeDocument :: TemplateGen () +genDecodeDocument = do + name <- gets envTypeName + cName <- gets envCollectionName + constrs <- gets envConstructors + let doc' = mkName "doc'" + emitDecl $ FunD (mkName "decodeDocument") $ + [ Clause [VarP doc'] (NormalB $ buildBody name cName doc' constrs) [] ] + where + buildBody :: Name -> String -> Name -> [Constructor] -> Exp + buildBody name cName doc' constrs = + let typ = mkName "typ" + other = mkName "other" + doc = mkName "doc" + in DoE [ LetS [ ValD (VarP doc) (NormalB ((VarE 'fromDocument) `AppE` (VarE doc'))) [] ] + , BindS (VarP typ) (((VarE 'lookupThrow) `AppE` (LitE $ StringL "_type")) `AppE` (VarE doc)) + , NoBindS $ CaseE (VarE typ) (map (buildMatch doc) constrs ++ [ Match (VarP other) + (NormalB $ ((VarE 'throwError) `AppE` + ((VarE 'concat) `AppE` + ListE [ LitE $ StringL "Unknown type constructor '" + , ((VarE 'T.unpack) `AppE` (VarE other)) + , LitE $ StringL "' found in collection for data type '" + , LitE $ StringL (dropPrefix $ show name) + , LitE $ StringL "' (" + , LitE $ StringL cName + , LitE $ StringL ")"]))) []]) ] + + buildMatch :: Name -> Constructor -> Match + buildMatch doc constr = + let body = if null (constrBody constr) + then ((VarE 'return) `AppE` (ConE (constrName constr))) + else foldl (genFieldApp doc) + (InfixE (Just (ConE $ constrName constr)) + (VarE '(<$>)) + (Just (genFieldLookup doc $ head (constrBody constr)))) + (tail (constrBody constr)) + in Match (LitP $ StringL $ constrSimpleName constr) (NormalB $ body) [] + + genFieldApp :: Name -> Exp -> FieldDecl -> Exp + genFieldApp doc lhs fieldDecl = + InfixE (Just lhs) + (VarE '(<*>)) + (Just $ genFieldLookup doc fieldDecl) + + genFieldLookup :: Name -> FieldDecl -> Exp + genFieldLookup doc (SimpleFieldDecl simpleName _) = + ((VarE 'lookupThrow) `AppE` (LitE $ StringL simpleName)) `AppE` (VarE doc) + genFieldLookup doc (FieldDecl _ simpleName _ _) = + ((VarE 'lookupThrow) `AppE` (LitE $ StringL simpleName)) `AppE` (VarE doc) + + +genEntityInstance :: TemplateGen () +genEntityInstance = do + name <- gets envTypeName + (_, decls) <- inner $ do + genKeyDecls + genDocumentDecls + genCollNameDecl + genFilterDecl + genEncodeDocument + genDecodeDocument + emitDecl $ InstanceD [] (ConT ''MongoEntity `AppT` ConT name) decls + + +genValueViaShowInstance :: TemplateGen () +genValueViaShowInstance = do + name <- gets envTypeName + emitDecl $ InstanceD [] (ConT ''MongoValue `AppT` ConT name) + [ FunD (mkName "toValue") + [ Clause [] + (NormalB (InfixE (Just (VarE 'toValue)) (VarE '(.)) (Just $ InfixE (Just (VarE 'T.pack)) (VarE '(.)) (Just (VarE 'show))))) + [] + ] + , FunD (mkName "fromValue") + [ Clause [VarP (mkName "v")] + (NormalB (InfixE (Just (InfixE (Just (VarE 'return)) (VarE '(.)) + (Just $ InfixE (Just (VarE 'read)) (VarE '(.)) (Just (VarE 'T.unpack))))) + (VarE '(=<<)) + (Just (AppE (VarE 'fromValue) (VarE (mkName "v")))))) + [] + ] + ] + + +genValueInstance :: TemplateGen () +genValueInstance = do + name <- gets envTypeName + let x = InfixE (Just $ VarE 'toValue) (VarE '(.)) (Just $ InfixE (Just $ VarE 'fromDocument) (VarE '(.)) (Just $ VarE 'encodeDocument)) + let y d = InfixE (Just $ InfixE (Just $ VarE 'decodeDocument) (VarE '(.)) (Just $ VarE 'toDocument)) (VarE '($)) (Just d) + let doc = mkName "doc" + val = mkName "val" + emitDecl $ InstanceD [] (ConT ''MongoValue `AppT` ConT name) + [ FunD (mkName "toValue") + [ Clause [] (NormalB x) [] ] + , FunD (mkName "fromValue") + [ --Clause [ConP 'Doc [VarP doc]] (NormalB ((VarE 'fromDocument) `AppE` (VarE doc))) [] + Clause [ConP 'Doc [VarP doc]] (NormalB $ y (VarE doc)) [] + , Clause [VarP val] (NormalB (((VarE 'expected) `AppE` (LitE $ StringL "Document")) `AppE` (VarE val))) [] + ] + ] + + + + +dropPrefix :: String -> String +dropPrefix = reverse . takeWhile (/= '.') . reverse + +capitalize :: String -> String +capitalize [] = [] +capitalize (c : cs) = toUpper c : cs + +uncapitalize :: String -> String +uncapitalize [] = [] +uncapitalize (c : cs) = toLower c : cs + + +-- Local Variables: +-- mode : Haskell +-- fill-column : 120 +-- default-justification : left +-- End: