{- | A BSON document is a JSON-like object with a standard binary encoding defined at bsonspec.org. This implements version 1.0 of that spec.
Use the GHC language extension /OverloadedStrings/ to automatically convert String literals to UString (UTF8) -}{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable, RankNTypes, OverlappingInstances, IncoherentInstances, ScopedTypeVariables #-}moduleData.Bson(UString,-- * DocumentDocument,look,lookup,valueAt,at,include,exclude,merge,-- * FieldField(..),(=:),(=?),Label,-- * ValueValue(..),Val(..),fval,cast,typed,typeOfVal,-- * Special Bson value typesBinary(..),Function(..),UUID(..),MD5(..),UserDefined(..),Regex(..),Javascript(..),Symbol(..),MongoStamp(..),MinMaxKey(..),-- ** ObjectIdObjectId(..),timestamp,genObjectId)whereimportPreludehiding(lookup)importControl.Applicative((<$>),(<*>))importData.Typeablehiding(cast)importData.IntimportData.WordimportData.UString(UString,u,unpack)importData.Time.Clock(UTCTime)importData.Time.Clock.POSIXimportData.Time.Format()-- for Show and Read instances of UTCTimeimportData.List(find,findIndex)importData.Bits(shift,(.|.))importData.ByteString.Char8(ByteString,pack)importData.Digest.OpenSSL.MD5(md5sum)importNumeric(readHex,showHex)importNetwork.BSD(getHostName)importSystem.Posix.Process(getProcessID)importSystem.IO.Unsafe(unsafePerformIO)importData.IORefimportData.Maybe(maybeToList,mapMaybe)importControl.Monad.IdentityroundTo::(RealFraca)=>a->a->a-- ^ Round second number to nearest multiple of first number. Eg: roundTo (1/1000) 0.12345 = 0.123roundTomultn=fromIntegral(round(n/mult))*mult-- * DocumenttypeDocument=[Field]-- ^ A BSON document is a list of 'Field'slook::(Monadm)=>Label->Document->mValue-- ^ Value of field in document, or fail (Nothing) if field not foundlookkdoc=maybenotFound(return.value)(find((k==).label)doc)wherenotFound=fail$"expected "++showk++" in "++showdoclookup::(Valv,Monadm)=>Label->Document->mv-- ^ Lookup value of field in document and cast to expected type. Fail (Nothing) if field not found or value not of expected type.lookupkdoc=cast=<<lookkdocvalueAt::Label->Document->Value-- ^ Value of field in document. Error if missing.valueAtk=runIdentity.lookkat::forallv.(Valv)=>Label->Document->v-- ^ Typed value of field in document. Error if missing or wrong type.atkdoc=maybeerrid(lookupkdoc)whereerr=error$"expected ("++showk++" :: "++show(typeOf(undefined::v))++") in "++showdocinclude::[Label]->Document->Document-- ^ Only include fields of document in label listincludekeysdoc=mapMaybe(\k->find((k==).label)doc)keysexclude::[Label]->Document->Document-- ^ Exclude fields from document in label listexcludekeysdoc=filter(\(k:=_)->notElemkkeys)docmerge::Document->Document->Document-- ^ Merge documents with preference given to first one when both have the same label. I.e. for every (k := v) in first argument, if k exists in second argument then replace its value with v, otherwise add (k := v) to second argument.mergeesdoc=foldlfdoceswherefdoc(k:=v)=casefindIndex((k==).label)docofNothing->doc++[k:=v]Justi->let(x,_:y)=splitAtidocinx++[k:=v]++y-- * Fieldinfix0:=,=:,=?dataField=(:=){label::Label,value::Value}deriving(Typeable,Eq)-- ^ A BSON field is a named value, where the name (label) is a string and the value is a BSON 'Value'(=:)::(Valv)=>Label->v->Field-- ^ Field with given label and typed valuek=:v=k:=valv(=?)::(Vala)=>Label->Maybea->Document-- ^ If Just value then return one field document, otherwise return empty documentk=?ma=maybeToList(fmap(k=:)ma)instanceShowFieldwhereshowsPrecd(k:=v)=showParen(d>0)$showString(' ':unpackk).showString": ".showsPrec1vtypeLabel=UString-- ^ The name of a BSON field-- * Value-- | A BSON value is one of the following types of valuesdataValue=FloatDouble|StringUString|DocDocument|Array[Value]|BinBinary|FunFunction|UuidUUID|Md5MD5|UserDefUserDefined|ObjIdObjectId|BoolBool|UTCUTCTime|Null|RegExRegex|JavaScrJavascript|SymSymbol|Int32Int32|Int64Int64|StampMongoStamp|MinMaxMinMaxKeyderiving(Typeable,Eq)instanceShowValuewhereshowsPrecdv=fval(showsPrecd)vfval::(foralla.(Vala)=>a->b)->Value->b-- ^ Apply generic function to typed valuefvalfv=casevofFloatx->fxStringx->fxDocx->fxArrayx->fxBinx->fxFunx->fxUuidx->fxMd5x->fxUserDefx->fxObjIdx->fxBoolx->fxUTCx->fxNull->f()RegExx->fxJavaScrx->fxSymx->fxInt32x->fxInt64x->fxStampx->fxMinMaxx->fx-- * Value conversioncast::forallma.(Vala,Monadm)=>Value->ma-- ^ Convert Value to expected type, or fail (Nothing) if not of that typecastv=maybenotTypereturn(cast'v)wherenotType=fail$"expected "++show(typeOf(undefined::a))++": "++showvtyped::(Vala)=>Value->a-- ^ Convert Value to expected type. Error if not that type.typed=runIdentity.casttypeOfVal::Value->TypeRep-- ^ Type of typed valuetypeOfVal=fvaltypeOf-- ** conversion class-- | Haskell types of this class correspond to BSON value typesclass(Typeablea,Showa,Eqa)=>Valawhereval::a->Valuecast'::Value->MaybeainstanceValDoublewhereval=Floatcast'(Floatx)=Justxcast'(Int32x)=Just(fromIntegralx)cast'(Int64x)=Just(fromIntegralx)cast'_=NothinginstanceValFloatwhereval=Float.realToFraccast'(Floatx)=Just(realToFracx)cast'(Int32x)=Just(fromIntegralx)cast'(Int64x)=Just(fromIntegralx)cast'_=NothinginstanceValUStringwhereval=Stringcast'(Stringx)=Justxcast'(Sym(Symbolx))=Justxcast'_=NothinginstanceValStringwhereval=String.ucast'(Stringx)=Just(unpackx)cast'(Sym(Symbolx))=Just(unpackx)cast'_=NothinginstanceValDocumentwhereval=Doccast'(Docx)=Justxcast'_=NothinginstanceVal[Value]whereval=Arraycast'(Arrayx)=Justxcast'_=Nothinginstance(Vala)=>Val[a]whereval=Array.mapvalcast'(Arrayx)=mapMcastxcast'_=NothinginstanceValBinarywhereval=Bincast'(Binx)=Justxcast'_=NothinginstanceValFunctionwhereval=Funcast'(Funx)=Justxcast'_=NothinginstanceValUUIDwhereval=Uuidcast'(Uuidx)=Justxcast'_=NothinginstanceValMD5whereval=Md5cast'(Md5x)=Justxcast'_=NothinginstanceValUserDefinedwhereval=UserDefcast'(UserDefx)=Justxcast'_=NothinginstanceValObjectIdwhereval=ObjIdcast'(ObjIdx)=Justxcast'_=NothinginstanceValBoolwhereval=Boolcast'(Boolx)=Justxcast'_=NothinginstanceValUTCTimewhereval=UTC.posixSecondsToUTCTime.roundTo(1/1000).utcTimeToPOSIXSecondscast'(UTCx)=Justxcast'_=NothinginstanceValPOSIXTimewhereval=UTC.posixSecondsToUTCTime.roundTo(1/1000)cast'(UTCx)=Just(utcTimeToPOSIXSecondsx)cast'_=NothinginstanceVal()whereval()=Nullcast'Null=Just()cast'_=NothinginstanceValRegexwhereval=RegExcast'(RegExx)=Justxcast'_=NothinginstanceValJavascriptwhereval=JavaScrcast'(JavaScrx)=Justxcast'_=NothinginstanceValSymbolwhereval=Symcast'(Symx)=Justxcast'(Stringx)=Just(Symbolx)cast'_=NothinginstanceValInt32whereval=Int32cast'(Int32x)=Justxcast'(Int64x)=fitIntxcast'(Floatx)=Just(roundx)cast'_=NothinginstanceValInt64whereval=Int64cast'(Int64x)=Justxcast'(Int32x)=Just(fromIntegralx)cast'(Floatx)=Just(roundx)cast'_=NothinginstanceValIntwherevaln=maybe(Int64$fromIntegraln)Int32(fitIntn)cast'(Int32x)=Just(fromIntegralx)cast'(Int64x)=Just(fromEnumx)cast'(Floatx)=Just(roundx)cast'_=NothinginstanceValIntegerwherevaln=maybe(maybeerrInt64$fitIntn)Int32(fitIntn)whereerr=error$shown++" is too large for Bson Int Value"cast'(Int32x)=Just(fromIntegralx)cast'(Int64x)=Just(fromIntegralx)cast'(Floatx)=Just(roundx)cast'_=NothinginstanceValMongoStampwhereval=Stampcast'(Stampx)=Justxcast'_=NothinginstanceValMinMaxKeywhereval=MinMaxcast'(MinMaxx)=Justxcast'_=NothingfitInt::forallnm.(Integraln,Integralm,Boundedm)=>n->Maybem-- ^ If number fits in type m then cast to m, otherwise NothingfitIntn=iffromIntegral(minBound::m)<=n&&n<=fromIntegral(maxBound::m)thenJust(fromIntegraln)elseNothing-- * Haskell types corresponding to special Bson value types-- ** Binary typesnewtypeBinary=BinaryByteStringderiving(Typeable,Show,Read,Eq)newtypeFunction=FunctionByteStringderiving(Typeable,Show,Read,Eq)newtypeUUID=UUIDByteStringderiving(Typeable,Show,Read,Eq)newtypeMD5=MD5ByteStringderiving(Typeable,Show,Read,Eq)newtypeUserDefined=UserDefinedByteStringderiving(Typeable,Show,Read,Eq)-- ** RegexdataRegex=RegexUStringUStringderiving(Typeable,Show,Read,Eq)-- ** JavascriptdataJavascript=JavascriptDocumentUStringderiving(Typeable,Show,Eq)-- ^ Javascript code with possibly empty environment mapping variables to values that the code may reference-- ** SymbolnewtypeSymbol=SymbolUStringderiving(Typeable,Show,Read,Eq)-- ** MongoStampnewtypeMongoStamp=MongoStampInt64deriving(Typeable,Show,Read,Eq)-- ** MinMaxdataMinMaxKey=MinKey|MaxKeyderiving(Typeable,Show,Read,Eq)-- ** ObjectIddataObjectId=OidWord32Word64deriving(Typeable,Eq,Ord)-- ^ A BSON ObjectID is a 12-byte value consisting of a 4-byte timestamp (seconds since epoch), a 3-byte machine id, a 2-byte process id, and a 3-byte counter. Note that the timestamp and counter fields must be stored big endian unlike the rest of BSON. This is because they are compared byte-by-byte and we want to ensure a mostly increasing order.instanceShowObjectIdwhereshowsPrecd(Oidxy)=showParen(d>10)$showString"Oid ".showHexx.showChar' '.showHexytimestamp::ObjectId->UTCTime-- ^ Time when objectId was createdtimestamp(Oidtime_)=posixSecondsToUTCTime(fromIntegraltime)genObjectId::IOObjectId-- ^ Create a fresh ObjectIdgenObjectId=dotime<-truncate<$>getPOSIXTimepid<-fromIntegral<$>getProcessIDinc<-nextCountreturn$Oidtime(compositemachineIdpidinc)wheremachineId::Word24machineId=unsafePerformIO(fst.head.readHex.take6.md5sum.pack<$>getHostName){-# NOINLINE machineId #-}counter::IORefWord24counter=unsafePerformIO(newIORef0){-# NOINLINE counter #-}nextCount::IOWord24nextCount=atomicModifyIORefcounter$\n->(wrap24(n+1),n)composite::Word24->Word16->Word24->Word64compositemidpidinc=fromIntegralmid`shift`40.|.fromIntegralpid`shift`24.|.fromIntegralinctypeWord24=Word32-- ^ low 3 bytes only, high byte must be zerowrap24::Word24->Word24wrap24n=n`mod`0x1000000{- Authors: Tony Hannan <tony@10gen.com>
Copyright 2010 10gen Inc.
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at: http://www.apache.org/licenses/LICENSE-2.0. Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. -}