{-# LANGUAGE UndecidableInstances, OverlappingInstances, ScopedTypeVariables, GADTs, PatternSignatures,
GeneralizedNewtypeDeriving, DeriveDataTypeable #-}moduleHappstack.Data.Serialize(Serialize(..),Version(..),Migrate(..),Mode(..),Contained,contain,extension,safeGet,safePut,serialize,deserialize,collectVersions,Object(objectType),mkObject,deserializeObject,parseObject,moduleHappstack.Data.Proxy)whereimportControl.Monad.IdentityimportData.Int()importForeignimportqualifiedData.ByteString.Lazy.Char8asLimportqualifiedData.ByteString.Char8asBimportHappstack.Data.MigrateimportHappstack.Data.ProxyimportData.TypeableimportqualifiedData.MapasMimportqualifiedData.MapasMapimportqualifiedData.IntMapasIntMapimportqualifiedData.SetasSetimportData.BinaryasBimportData.Binary.PutasBimportData.Binary.GetasB---------------------------------------------------------------- Core types--------------------------------------------------------------dataContaineda=Contained{unsafeUnPack::a}-- | Lifts the provided value into Containedcontain::a->Containedacontain=ContaineddataPreviousa=forallb.(Serializeb,Migrateba)=>Previous(Proxyb)mkPrevious::forallab.(Serializeb,Migrateba)=>Proxyb->PreviousamkPreviousProxy=Previous(Proxy::Proxyb)extension::forallab.(Serializeb,Migrateba)=>VersionIda->Proxyb->Modeaextensionvsprox=Versionedvs(Just(mkPreviousprox))newtypeVersionIda=VersionId{unVersion::Int}deriving(Num,Read,Show,Eq)instanceBinary(VersionIda)whereget=liftMVersionIdgetput=put.unVersiondataModea=Primitive-- ^ Data layout won't change. Used for types like Int and Char.|Versioned(VersionIda)(Maybe(Previousa))classVersionawheremode::Modeamode=Versioned0Nothingclass(Typeablea,Versiona)=>SerializeawheregetCopy::Contained(Geta)putCopy::a->ContainedPut---------------------------------------------------------------- Implementation--------------------------------------------------------------getSafeGet::foralla.Serializea=>Get(Geta)getSafeGet=casemode::ModeaofPrimitive->return(unsafeUnPackgetCopy)VersionedwantedVersionmbPrevious->dostoredVersion<-getreturn(safeGetVersionedwantedVersionmbPreviousstoredVersion)getSafePut::foralla.Serializea=>PutM(a->Put)getSafePut=casemode::ModeaofPrimitive->return(unsafeUnPack.putCopy)Versionedvs_->doB.putvsreturn(unsafeUnPack.putCopy)-- | Equivalent of Data.Binary.put for instances of Serialize. -- Takes into account versioning of types.safePut::foralla.Serializea=>a->PutsafePutval=dofn<-getSafePutfnval-- | Equivalent of Data.Binary.get for instances of Serialize-- Takes into account versioning of types.safeGet::foralla.Serializea=>GetasafeGet=joingetSafeGetsafeGetVersioned::forallab.(Serializeb)=>VersionIdb->Maybe(Previousb)->VersionIda->B.GetbsafeGetVersionedwantedVersionmbPreviousstoredVersion=casecompareVersionsstoredVersionwantedVersionofGT->error$"Version tag too large: "++show(wantedVersion,storedVersion)++" ("++tStr++")"EQ->unsafeUnPackgetCopyLT->casembPreviousofNothing->error$"No previous version ("++tStr++")"Just(Previous(_::Proxyf)::Previousb)->casemodeofPrimitive->error$"Previous version marked as a Primitive ("++tStr++")"VersionedwantedVersion'mbPrevious'->doold<-safeGetVersionedwantedVersion'mbPrevious'storedVersion::B.Getfreturn$migrateoldwheretStr=show(typeOf(error"huh?"::b))-- | Compares the numeric value of the versionscompareVersions::VersionIda->VersionIdb->OrderingcompareVersionsv1v2=compare(unVersionv1)(unVersionv2)-- | Pure version of 'safePut'. Serializes to a ByteStringserialize::Serializea=>a->L.ByteStringserialize=runPut.safePut-- | Pure version of 'safeGet'. Parses a ByteString into the expected type-- and a remainder.deserialize::Serializea=>L.ByteString->(a,L.ByteString)deserializebs=caserunGetStatesafeGetbs0of(val,rest,_offset)->(val,rest)-- | Version lookupscollectVersions::foralla.(Typeablea,Versiona)=>Proxya->[L.ByteString]collectVersionsprox=casemode::ModeaofPrimitive->[thisType]Versioned_Nothing->[thisType]Versioned_(Just(Previousprev))->thisType:(collectVersionsprev)wherethisType=(L.pack.show.typeOf.unProxy)prox---------------------------------------------------------------- Instances--------------------------------------------------------------instanceVersionIntwheremode=PrimitiveinstanceSerializeIntwheregetCopy=containget;putCopy=contain.putinstanceVersionIntegerwheremode=PrimitiveinstanceSerializeIntegerwheregetCopy=containget;putCopy=contain.putinstanceVersionFloatwheremode=PrimitiveinstanceSerializeFloatwheregetCopy=containget;putCopy=contain.putinstanceVersionDoublewheremode=PrimitiveinstanceSerializeDoublewheregetCopy=containget;putCopy=contain.putinstanceVersionL.ByteStringwheremode=PrimitiveinstanceSerializeL.ByteStringwheregetCopy=containget;putCopy=contain.putinstanceVersionB.ByteStringwheremode=PrimitiveinstanceSerializeB.ByteStringwheregetCopy=containget;putCopy=contain.putinstanceVersionCharwheremode=PrimitiveinstanceSerializeCharwheregetCopy=containget;putCopy=contain.putinstanceVersionWord8wheremode=PrimitiveinstanceSerializeWord8wheregetCopy=containget;putCopy=contain.putinstanceVersionWord16wheremode=PrimitiveinstanceSerializeWord16wheregetCopy=containget;putCopy=contain.putinstanceVersionWord32wheremode=PrimitiveinstanceSerializeWord32wheregetCopy=containget;putCopy=contain.putinstanceVersionWord64wheremode=PrimitiveinstanceSerializeWord64wheregetCopy=containget;putCopy=contain.putinstanceVersionOrderingwheremode=PrimitiveinstanceSerializeOrderingwheregetCopy=containget;putCopy=contain.putinstanceVersionInt8wheremode=PrimitiveinstanceSerializeInt8wheregetCopy=containget;putCopy=contain.putinstanceVersionInt16wheremode=PrimitiveinstanceSerializeInt16wheregetCopy=containget;putCopy=contain.putinstanceVersionInt32wheremode=PrimitiveinstanceSerializeInt32wheregetCopy=containget;putCopy=contain.putinstanceVersionInt64wheremode=PrimitiveinstanceSerializeInt64wheregetCopy=containget;putCopy=contain.putinstanceVersion()wheremode=PrimitiveinstanceSerialize()wheregetCopy=containget;putCopy=contain.putinstanceVersionBoolwheremode=PrimitiveinstanceSerializeBoolwheregetCopy=containget;putCopy=contain.putinstanceVersion(Eitherab)wheremode=Primitiveinstance(Serializea,Serializeb)=>Serialize(Eitherab)wheregetCopy=contain$don<-getifnthenliftMRightsafeGetelseliftMLeftsafeGetputCopy(Righta)=contain$putTrue>>safePutaputCopy(Lefta)=contain$putFalse>>safePutainstanceVersion(a,b)wheremode=Primitiveinstance(Serializea,Serializeb)=>Serialize(a,b)wheregetCopy=contain$liftM2(,)safeGetsafeGetputCopy(a,b)=contain$safePuta>>safePutbinstanceVersion(a,b,c)wheremode=Primitiveinstance(Serializea,Serializeb,Serializec)=>Serialize(a,b,c)wheregetCopy=contain$liftM3(,,)safeGetsafeGetsafeGetputCopy(a,b,c)=contain$safePuta>>safePut(b,c)instanceVersion(a,b,c,d)wheremode=Primitiveinstance(Serializea,Serializeb,Serializec,Serialized)=>Serialize(a,b,c,d)wheregetCopy=contain$liftM4(,,,)safeGetsafeGetsafeGetsafeGetputCopy(a,b,c,d)=contain$safePuta>>safePut(b,c,d)instanceVersion(a,b,c,d,e)wheremode=Primitiveinstance(Serializea,Serializeb,Serializec,Serialized,Serializee)=>Serialize(a,b,c,d,e)wheregetCopy=contain$liftM5(,,,,)safeGetsafeGetsafeGetsafeGetsafeGetputCopy(a,b,c,d,e)=contain$safePuta>>safePut(b,c,d,e)instanceVersion(Proxya)wheremode=PrimitiveinstanceTypeablea=>Serialize(Proxya)wheregetCopy=contain$returnProxyputCopyProxy=contain$return()instanceVersion[a]wheremode=PrimitiveinstanceSerializea=>Serialize[a]wheregetCopy=contain$don<-getgetSafeGet>>=replicateMnputCopylst=contain$doput(lengthlst)getSafePut>>=forM_lstinstanceVersion(Maybea)wheremode=PrimitiveinstanceSerializea=>Serialize(Maybea)wheregetCopy=contain$don<-getifnthenliftMJustsafeGetelsereturnNothingputCopy(Justa)=contain$putTrue>>safePutaputCopyNothing=contain$putFalseinstanceVersion(Set.Seta)wheremode=Primitiveinstance(Serializea,Orda)=>Serialize(Set.Seta)wheregetCopy=contain$fmapSet.fromAscListsafeGetputCopy=contain.safePut.Set.toListinstanceVersion(Map.Mapab)wheremode=Primitiveinstance(Serializea,Serializeb,Orda)=>Serialize(Map.Mapab)wheregetCopy=contain$fmapMap.fromAscListsafeGetputCopy=contain.safePut.Map.toListinstanceVersion(IntMap.IntMapa)wheremode=Primitiveinstance(Serializea)=>Serialize(IntMap.IntMapa)wheregetCopy=contain$fmapIntMap.fromAscListsafeGetputCopy=contain.safePut.IntMap.toList---------------------------------------------------------------- Object serialization---------------------------------------------------------------- | 'deserialize' specialized to Objects deserializeObject::L.ByteString->(Object,L.ByteString)deserializeObject=deserialize-- | Attempts to convert an Object back into its base type.-- If the conversion fails 'error' will be called.parseObject::Serializea=>Object->aparseObject(ObjectobjTypeobjData)=letres=runGetsafeGetobjDataresType=show(typeOfres)inifobjType/=resTypethenerror$"Failed to parse object of type '"++objType++"'. Expected type '"++resType++"'"elseres-- | Serializes data and stores it along with its type name in an ObjectmkObject::Serializea=>a->ObjectmkObjectobj=Object{objectType=show(typeOfobj),objectData=serializeobj}dataObject=Object{objectType::String,objectData::L.ByteString}deriving(Typeable,Show)instanceVersionObjectinstanceSerializeObjectwhereputCopy(ObjectobjTypeobjData)=contain$put(objType,objData)getCopy=contain$do(objType,objData)<-getreturn(ObjectobjTypeobjData)