diff options
| -rw-r--r-- | erebos.cabal | 1 | ||||
| -rw-r--r-- | src/Storage.hs | 39 |
2 files changed, 35 insertions, 5 deletions
diff --git a/erebos.cabal b/erebos.cabal index d11a0f0..116bbc5 100644 --- a/erebos.cabal +++ b/erebos.cabal @@ -68,6 +68,7 @@ executable erebos time >= 1.8 && <1.9, transformers >= 0.5 && <0.6, unix >=2.7 && <2.8, + uuid >=1.3 && <1.4, zlib >=0.6 && <0.7 hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Storage.hs b/src/Storage.hs index 47f8af0..a9a5e3a 100644 --- a/src/Storage.hs +++ b/src/Storage.hs @@ -21,17 +21,17 @@ module Storage ( watchHead, Storable(..), ZeroStorable(..), - StorableText(..), StorableDate(..), + StorableText(..), StorableDate(..), StorableUUID(..), storeBlob, storeRec, storeZero, - storeInt, storeNum, storeText, storeBinary, storeDate, storeJson, storeRef, storeRawRef, - storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbJson, storeMbRef, storeMbRawRef, + storeInt, storeNum, storeText, storeBinary, storeDate, storeUUID, storeJson, storeRef, storeRawRef, + storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbUUID, storeMbJson, storeMbRef, storeMbRawRef, storeZRef, LoadRec, loadBlob, loadRec, loadZero, - loadInt, loadNum, loadText, loadBinary, loadDate, loadJson, loadRef, loadRawRef, - loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbJson, loadMbRef, loadMbRawRef, + loadInt, loadNum, loadText, loadBinary, loadDate, loadUUID, loadJson, loadRef, loadRawRef, + loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbUUID, loadMbJson, loadMbRef, loadMbRawRef, loadBinaries, loadRefs, loadZRef, @@ -86,6 +86,8 @@ import Data.Time.Calendar import Data.Time.Clock import Data.Time.Format import Data.Time.LocalTime +import Data.UUID (UUID) +import qualified Data.UUID as U import System.Directory import System.INotify @@ -177,6 +179,7 @@ copyObject' st (Rec rs) = fmap Rec . sequence <$> mapM copyItem rs RecText x -> return $ return $ RecText x RecBinary x -> return $ return $ RecBinary x RecDate x -> return $ return $ RecDate x + RecUUID x -> return $ return $ RecUUID x RecJson x -> return $ return $ RecJson x RecRef x -> fmap RecRef <$> copyRef' st x copyObject' _ ZeroObject = return $ return ZeroObject @@ -209,6 +212,7 @@ data RecItem' c | RecText Text | RecBinary ByteString | RecDate ZonedTime + | RecUUID UUID | RecJson J.Value | RecRef (Ref' c) deriving (Show) @@ -252,6 +256,7 @@ serializeRecItem name (RecText x) = [name, BC.pack ":t", BC.singleton ' ', escap escape c = BC.singleton c serializeRecItem name (RecBinary x) = [name, BC.pack ":b ", convertToBase Base64 x, BC.singleton '\n'] serializeRecItem name (RecDate x) = [name, BC.pack ":d", BC.singleton ' ', BC.pack (formatTime defaultTimeLocale "%s %z" x), BC.singleton '\n'] +serializeRecItem name (RecUUID x) = [name, BC.pack ":u", BC.singleton ' ', U.toASCIIBytes x, BC.singleton '\n'] serializeRecItem name (RecJson x) = [name, BC.pack ":j", BC.singleton ' '] ++ BL.toChunks (J.encode x) ++ [BC.singleton '\n'] serializeRecItem name (RecRef x) = [name, BC.pack ":r.b2 ", showRef x, BC.singleton '\n'] @@ -314,6 +319,7 @@ unsafeDeserializeObject st bytes = "t" -> return $ RecText $ decodeUtf8With lenientDecode content "b" -> either (const Nothing) (Just . RecBinary) $ convertFromBase Base64 content "d" -> RecDate <$> parseTimeM False defaultTimeLocale "%s %z" (BC.unpack content) + "u" -> RecUUID <$> U.fromASCIIBytes content "j" -> RecJson <$> J.decode (BL.fromStrict content) "r.b2" -> RecRef . Ref st <$> readRefDigest content _ -> Nothing @@ -536,6 +542,14 @@ instance StorableDate Day where fromDate = utctDay . fromDate +class StorableUUID a where + toUUID :: a -> UUID + fromUUID :: UUID -> a + +instance StorableUUID UUID where + toUUID = id; fromUUID = id + + storeInt :: Integral a => String -> a -> StoreRec c storeInt name x = tell [return [(BC.pack name, RecInt $ toInteger x)]] @@ -566,6 +580,12 @@ storeDate name x = tell [return [(BC.pack name, RecDate $ toDate x)]] storeMbDate :: StorableDate a => String -> Maybe a -> StoreRec c storeMbDate name = maybe (return ()) (storeDate name) +storeUUID :: StorableUUID a => String -> a -> StoreRec c +storeUUID name x = tell [return [(BC.pack name, RecUUID $ toUUID x)]] + +storeMbUUID :: StorableUUID a => String -> Maybe a -> StoreRec c +storeMbUUID name = maybe (return ()) (storeUUID name) + storeJson :: J.ToJSON a => String -> a -> StoreRec c storeJson name x = tell [return [(BC.pack name, RecJson $ J.toJSON x)]] @@ -668,6 +688,15 @@ loadMbDate name = asks (lookup (BC.pack name) . snd) >>= \case Just (RecDate x) -> return $ Just $ fromDate x Just _ -> throwError $ "Expecting type date of record item '"++name++"'" +loadUUID :: StorableUUID a => String -> LoadRec a +loadUUID name = maybe (throwError $ "Missing record iteem '"++name++"'") return =<< loadMbUUID name + +loadMbUUID :: StorableUUID a => String -> LoadRec (Maybe a) +loadMbUUID name = asks (lookup (BC.pack name) . snd) >>= \case + Nothing -> return Nothing + Just (RecUUID x) -> return $ Just $ fromUUID x + Just _ -> throwError $ "Expecting type UUID of record item '"++name++"'" + loadJson :: J.FromJSON a => String -> LoadRec a loadJson name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbJson name |