module Erebos.Storage ( Storage, PartialStorage, StorageCompleteness, openStorage, memoryStorage, deriveEphemeralStorage, derivePartialStorage, Ref, PartialRef, RefDigest, refDigest, readRef, showRef, showRefDigest, refDigestFromByteString, hashToRefDigest, copyRef, partialRef, partialRefFromDigest, Object, PartialObject, Object'(..), RecItem, RecItem'(..), serializeObject, deserializeObject, deserializeObjects, ioLoadObject, ioLoadBytes, storeRawBytes, lazyLoadBytes, storeObject, collectObjects, collectStoredObjects, Head, HeadType(..), HeadTypeID, mkHeadTypeID, headId, headStorage, headRef, headObject, headStoredObject, loadHeads, loadHead, reloadHead, storeHead, replaceHead, updateHead, updateHead_, loadHeadRaw, storeHeadRaw, replaceHeadRaw, WatchedHead, watchHead, watchHeadWith, unwatchHead, watchHeadRaw, MonadStorage(..), Storable(..), ZeroStorable(..), StorableText(..), StorableDate(..), StorableUUID(..), Store, StoreRec, evalStore, evalStoreObject, storeBlob, storeRec, storeZero, storeEmpty, storeInt, storeNum, storeText, storeBinary, storeDate, storeUUID, storeRef, storeRawRef, storeMbEmpty, storeMbInt, storeMbNum, storeMbText, storeMbBinary, storeMbDate, storeMbUUID, storeMbRef, storeMbRawRef, storeZRef, storeRecItems, Load, LoadRec, evalLoad, loadCurrentRef, loadCurrentObject, loadRecCurrentRef, loadRecItems, loadBlob, loadRec, loadZero, loadEmpty, loadInt, loadNum, loadText, loadBinary, loadDate, loadUUID, loadRef, loadRawRef, loadMbEmpty, loadMbInt, loadMbNum, loadMbText, loadMbBinary, loadMbDate, loadMbUUID, loadMbRef, loadMbRawRef, loadTexts, loadBinaries, loadRefs, loadRawRefs, loadZRef, Stored, fromStored, storedRef, wrappedStore, wrappedLoad, copyStored, unsafeMapStored, StoreInfo(..), makeStoreInfo, StoredHistory, fromHistory, fromHistoryAt, storedFromHistory, storedHistoryList, beginHistory, modifyHistory, ) where import Control.Applicative import Control.Concurrent import Control.Exception import Control.Monad import Control.Monad.Except import Control.Monad.Reader import Control.Monad.Writer import Crypto.Hash import Data.Bifunctor import Data.ByteString (ByteString) import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BLC import Data.Char import Data.Function import qualified Data.HashTable.IO as HT import Data.List import qualified Data.Map as M import Data.Maybe import Data.Ratio import Data.Set (Set) import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding import Data.Text.Encoding.Error import Data.Time.Calendar import Data.Time.Clock import Data.Time.Format import Data.Time.LocalTime import Data.Typeable import Data.UUID (UUID) import qualified Data.UUID as U import qualified Data.UUID.V4 as U import System.Directory import System.FSNotify import System.FilePath import System.IO.Error import System.IO.Unsafe import Erebos.Storage.Internal type Storage = Storage' Complete type PartialStorage = Storage' Partial storageVersion :: String storageVersion = "0.1" openStorage :: FilePath -> IO Storage openStorage path = modifyIOError annotate $ do let versionFileName = "erebos-storage" let versionPath = path </> versionFileName let writeVersionFile = writeFile versionPath $ storageVersion <> "\n" doesDirectoryExist path >>= \case True -> do listDirectory path >>= \case files@(_:_) | versionFileName `elem` files -> do readFile versionPath >>= \case content | (ver:_) <- lines content, ver == storageVersion -> return () | otherwise -> fail "unsupported storage version" | "objects" `notElem` files || "heads" `notElem` files -> do fail "directory is neither empty, nor an existing erebos storage" _ -> writeVersionFile False -> do createDirectoryIfMissing True $ path writeVersionFile createDirectoryIfMissing True $ path </> "objects" createDirectoryIfMissing True $ path </> "heads" watchers <- newMVar (Nothing, [], WatchList 1 []) refgen <- newMVar =<< HT.new refroots <- newMVar =<< HT.new return $ Storage { stBacking = StorageDir path watchers , stParent = Nothing , stRefGeneration = refgen , stRefRoots = refroots } where annotate e = annotateIOError e "failed to open storage" Nothing (Just path) memoryStorage' :: IO (Storage' c') memoryStorage' = do backing <- StorageMemory <$> newMVar [] <*> newMVar M.empty <*> newMVar M.empty <*> newMVar (WatchList 1 []) refgen <- newMVar =<< HT.new refroots <- newMVar =<< HT.new return $ Storage { stBacking = backing , stParent = Nothing , stRefGeneration = refgen , stRefRoots = refroots } memoryStorage :: IO Storage memoryStorage = memoryStorage' deriveEphemeralStorage :: Storage -> IO Storage deriveEphemeralStorage parent = do st <- memoryStorage return $ st { stParent = Just parent } derivePartialStorage :: Storage -> IO PartialStorage derivePartialStorage parent = do st <- memoryStorage' return $ st { stParent = Just parent } type Ref = Ref' Complete type PartialRef = Ref' Partial zeroRef :: Storage' c -> Ref' c zeroRef s = Ref s (RefDigest h) where h = case digestFromByteString $ B.replicate (hashDigestSize $ digestAlgo h) 0 of Nothing -> error $ "Failed to create zero hash" Just h' -> h' digestAlgo :: Digest a -> a digestAlgo = undefined isZeroRef :: Ref' c -> Bool isZeroRef (Ref _ h) = all (==0) $ BA.unpack h refFromDigest :: Storage' c -> RefDigest -> IO (Maybe (Ref' c)) refFromDigest st dgst = fmap (const $ Ref st dgst) <$> ioLoadBytesFromStorage st dgst readRef :: Storage -> ByteString -> IO (Maybe Ref) readRef s b = case readRefDigest b of Nothing -> return Nothing Just dgst -> refFromDigest s dgst copyRef' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Ref' c -> IO (c (Ref' c')) copyRef' st ref'@(Ref _ dgst) = refFromDigest st dgst >>= \case Just ref -> return $ return ref Nothing -> doCopy where doCopy = do mbobj' <- ioLoadObject ref' mbobj <- sequence $ copyObject' st <$> mbobj' sequence $ unsafeStoreObject st <$> join mbobj copyRecItem' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> RecItem' c -> IO (c (RecItem' c')) copyRecItem' st = \case RecEmpty -> return $ return $ RecEmpty RecInt x -> return $ return $ RecInt x RecNum x -> return $ return $ RecNum x RecText x -> return $ return $ RecText x RecBinary x -> return $ return $ RecBinary x RecDate x -> return $ return $ RecDate x RecUUID x -> return $ return $ RecUUID x RecRef x -> fmap RecRef <$> copyRef' st x copyObject' :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (c (Object' c')) copyObject' _ (Blob bs) = return $ return $ Blob bs copyObject' st (Rec rs) = fmap Rec . sequence <$> mapM (\( n, item ) -> fmap ( n, ) <$> copyRecItem' st item) rs copyObject' _ ZeroObject = return $ return ZeroObject copyRef :: forall c c' m. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> Ref' c -> m (LoadResult c (Ref' c')) copyRef st ref' = liftIO $ returnLoadResult <$> copyRef' st ref' copyRecItem :: forall c c' m. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> RecItem' c -> m (LoadResult c (RecItem' c')) copyRecItem st item' = liftIO $ returnLoadResult <$> copyRecItem' st item' copyObject :: forall c c'. (StorageCompleteness c, StorageCompleteness c') => Storage' c' -> Object' c -> IO (LoadResult c (Object' c')) copyObject st obj' = returnLoadResult <$> copyObject' st obj' partialRef :: PartialStorage -> Ref -> PartialRef partialRef st (Ref _ dgst) = Ref st dgst partialRefFromDigest :: PartialStorage -> RefDigest -> PartialRef partialRefFromDigest st dgst = Ref st dgst data Object' c = Blob ByteString | Rec [(ByteString, RecItem' c)] | ZeroObject deriving (Show) type Object = Object' Complete type PartialObject = Object' Partial data RecItem' c = RecEmpty | RecInt Integer | RecNum Rational | RecText Text | RecBinary ByteString | RecDate ZonedTime | RecUUID UUID | RecRef (Ref' c) deriving (Show) type RecItem = RecItem' Complete serializeObject :: Object' c -> BL.ByteString serializeObject = \case Blob cnt -> BL.fromChunks [BC.pack "blob ", BC.pack (show $ B.length cnt), BC.singleton '\n', cnt] Rec rec -> let cnt = BL.fromChunks $ concatMap (uncurry serializeRecItem) rec in BL.fromChunks [BC.pack "rec ", BC.pack (show $ BL.length cnt), BC.singleton '\n'] `BL.append` cnt ZeroObject -> BL.empty -- |Serializes and stores object data without ony dependencies, so is safe only -- if all the referenced objects are already stored or reference is partial. unsafeStoreObject :: Storage' c -> Object' c -> IO (Ref' c) unsafeStoreObject storage = \case ZeroObject -> return $ zeroRef storage obj -> unsafeStoreRawBytes storage $ serializeObject obj storeObject :: PartialStorage -> PartialObject -> IO PartialRef storeObject = unsafeStoreObject storeRawBytes :: PartialStorage -> BL.ByteString -> IO PartialRef storeRawBytes = unsafeStoreRawBytes serializeRecItem :: ByteString -> RecItem' c -> [ByteString] serializeRecItem name (RecEmpty) = [name, BC.pack ":e", BC.singleton ' ', BC.singleton '\n'] serializeRecItem name (RecInt x) = [name, BC.pack ":i", BC.singleton ' ', BC.pack (show x), BC.singleton '\n'] serializeRecItem name (RecNum x) = [name, BC.pack ":n", BC.singleton ' ', BC.pack (showRatio x), BC.singleton '\n'] serializeRecItem name (RecText x) = [name, BC.pack ":t", BC.singleton ' ', escaped, BC.singleton '\n'] where escaped = BC.concatMap escape $ encodeUtf8 x escape '\n' = BC.pack "\n\t" escape c = BC.singleton c serializeRecItem name (RecBinary x) = [name, BC.pack ":b ", showHex 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 (RecRef x) = [name, BC.pack ":r ", showRef x, BC.singleton '\n'] lazyLoadObject :: forall c. StorageCompleteness c => Ref' c -> LoadResult c (Object' c) lazyLoadObject = returnLoadResult . unsafePerformIO . ioLoadObject ioLoadObject :: forall c. StorageCompleteness c => Ref' c -> IO (c (Object' c)) ioLoadObject ref | isZeroRef ref = return $ return ZeroObject ioLoadObject ref@(Ref st rhash) = do file' <- ioLoadBytes ref return $ do file <- file' let chash = hashToRefDigest file when (chash /= rhash) $ error $ "Hash mismatch on object " ++ BC.unpack (showRef ref) {- TODO throw -} return $ case runExcept $ unsafeDeserializeObject st file of Left err -> error $ err ++ ", ref " ++ BC.unpack (showRef ref) {- TODO throw -} Right (x, rest) | BL.null rest -> x | otherwise -> error $ "Superfluous content after " ++ BC.unpack (showRef ref) {- TODO throw -} lazyLoadBytes :: forall c. StorageCompleteness c => Ref' c -> LoadResult c BL.ByteString lazyLoadBytes ref | isZeroRef ref = returnLoadResult (return BL.empty :: c BL.ByteString) lazyLoadBytes ref = returnLoadResult $ unsafePerformIO $ ioLoadBytes ref unsafeDeserializeObject :: Storage' c -> BL.ByteString -> Except String (Object' c, BL.ByteString) unsafeDeserializeObject _ bytes | BL.null bytes = return (ZeroObject, bytes) unsafeDeserializeObject st bytes = case BLC.break (=='\n') bytes of (line, rest) | Just (otype, len) <- splitObjPrefix line -> do let (content, next) = first BL.toStrict $ BL.splitAt (fromIntegral len) $ BL.drop 1 rest guard $ B.length content == len (,next) <$> case otype of _ | otype == BC.pack "blob" -> return $ Blob content | otype == BC.pack "rec" -> maybe (throwError $ "Malformed record item ") (return . Rec) $ sequence $ map parseRecLine $ mergeCont [] $ BC.lines content | otherwise -> throwError $ "Unknown object type" _ -> throwError $ "Malformed object" where splitObjPrefix line = do [otype, tlen] <- return $ BLC.words line (len, rest) <- BLC.readInt tlen guard $ BL.null rest return (BL.toStrict otype, len) mergeCont cs (a:b:rest) | Just ('\t', b') <- BC.uncons b = mergeCont (b':BC.pack "\n":cs) (a:rest) mergeCont cs (a:rest) = B.concat (a : reverse cs) : mergeCont [] rest mergeCont _ [] = [] parseRecLine line = do colon <- BC.elemIndex ':' line space <- BC.elemIndex ' ' line guard $ colon < space let name = B.take colon line itype = B.take (space-colon-1) $ B.drop (colon+1) line content = B.drop (space+1) line val <- case BC.unpack itype of "e" -> do guard $ B.null content return RecEmpty "i" -> do (num, rest) <- BC.readInteger content guard $ B.null rest return $ RecInt num "n" -> RecNum <$> parseRatio content "t" -> return $ RecText $ decodeUtf8With lenientDecode content "b" -> RecBinary <$> readHex content "d" -> RecDate <$> parseTimeM False defaultTimeLocale "%s %z" (BC.unpack content) "u" -> RecUUID <$> U.fromASCIIBytes content "r" -> RecRef . Ref st <$> readRefDigest content _ -> Nothing return (name, val) deserializeObject :: PartialStorage -> BL.ByteString -> Except String (PartialObject, BL.ByteString) deserializeObject = unsafeDeserializeObject deserializeObjects :: PartialStorage -> BL.ByteString -> Except String [PartialObject] deserializeObjects _ bytes | BL.null bytes = return [] deserializeObjects st bytes = do (obj, rest) <- deserializeObject st bytes (obj:) <$> deserializeObjects st rest collectObjects :: Object -> [Object] collectObjects obj = obj : map fromStored (fst $ collectOtherStored S.empty obj) collectStoredObjects :: Stored Object -> [Stored Object] collectStoredObjects obj = obj : (fst $ collectOtherStored S.empty $ fromStored obj) collectOtherStored :: Set RefDigest -> Object -> ([Stored Object], Set RefDigest) collectOtherStored seen (Rec items) = foldr helper ([], seen) $ map snd items where helper (RecRef ref) (xs, s) | r <- refDigest ref , r `S.notMember` s = let o = wrappedLoad ref (xs', s') = collectOtherStored (S.insert r s) $ fromStored o in ((o : xs') ++ xs, s') helper _ (xs, s) = (xs, s) collectOtherStored seen _ = ([], seen) type Head = Head' Complete headId :: Head a -> HeadID headId (Head uuid _) = uuid headStorage :: Head a -> Storage headStorage = refStorage . headRef headRef :: Head a -> Ref headRef (Head _ sx) = storedRef sx headObject :: Head a -> a headObject (Head _ sx) = fromStored sx headStoredObject :: Head a -> Stored a headStoredObject (Head _ sx) = sx deriving instance StorableUUID HeadID deriving instance StorableUUID HeadTypeID mkHeadTypeID :: String -> HeadTypeID mkHeadTypeID = maybe (error "Invalid head type ID") HeadTypeID . U.fromString class Storable a => HeadType a where headTypeID :: proxy a -> HeadTypeID headTypePath :: FilePath -> HeadTypeID -> FilePath headTypePath spath (HeadTypeID tid) = spath </> "heads" </> U.toString tid headPath :: FilePath -> HeadTypeID -> HeadID -> FilePath headPath spath tid (HeadID hid) = headTypePath spath tid </> U.toString hid loadHeads :: forall a m. MonadIO m => HeadType a => Storage -> m [Head a] loadHeads s@(Storage { stBacking = StorageDir { dirPath = spath }}) = liftIO $ do let hpath = headTypePath spath $ headTypeID @a Proxy files <- filterM (doesFileExist . (hpath </>)) =<< handleJust (\e -> guard (isDoesNotExistError e)) (const $ return []) (getDirectoryContents hpath) fmap catMaybes $ forM files $ \hname -> do case U.fromString hname of Just hid -> do (h:_) <- BC.lines <$> B.readFile (hpath </> hname) Just ref <- readRef s h return $ Just $ Head (HeadID hid) $ wrappedLoad ref Nothing -> return Nothing loadHeads Storage { stBacking = StorageMemory { memHeads = theads } } = liftIO $ do let toHead ((tid, hid), ref) | tid == headTypeID @a Proxy = Just $ Head hid $ wrappedLoad ref | otherwise = Nothing catMaybes . map toHead <$> readMVar theads loadHead :: forall a m. (HeadType a, MonadIO m) => Storage -> HeadID -> m (Maybe (Head a)) loadHead st hid = fmap (Head hid . wrappedLoad) <$> loadHeadRaw st (headTypeID @a Proxy) hid loadHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> HeadID -> m (Maybe Ref) loadHeadRaw s@(Storage { stBacking = StorageDir { dirPath = spath }}) tid hid = liftIO $ do handleJust (guard . isDoesNotExistError) (const $ return Nothing) $ do (h:_) <- BC.lines <$> B.readFile (headPath spath tid hid) Just ref <- readRef s h return $ Just ref loadHeadRaw Storage { stBacking = StorageMemory { memHeads = theads } } tid hid = liftIO $ do lookup (tid, hid) <$> readMVar theads reloadHead :: (HeadType a, MonadIO m) => Head a -> m (Maybe (Head a)) reloadHead (Head hid (Stored (Ref st _) _)) = loadHead st hid storeHead :: forall a m. MonadIO m => HeadType a => Storage -> a -> m (Head a) storeHead st obj = do let tid = headTypeID @a Proxy stored <- wrappedStore st obj hid <- storeHeadRaw st tid (storedRef stored) return $ Head hid stored storeHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> Ref -> m HeadID storeHeadRaw st tid ref = liftIO $ do hid <- HeadID <$> U.nextRandom case stBacking st of StorageDir { dirPath = spath } -> do Right () <- writeFileChecked (headPath spath tid hid) Nothing $ showRef ref `B.append` BC.singleton '\n' return () StorageMemory { memHeads = theads } -> do modifyMVar_ theads $ return . (((tid, hid), ref) :) return hid replaceHead :: forall a m. (HeadType a, MonadIO m) => Head a -> Stored a -> m (Either (Maybe (Head a)) (Head a)) replaceHead prev@(Head hid pobj) stored' = liftIO $ do let st = headStorage prev tid = headTypeID @a Proxy stored <- copyStored st stored' bimap (fmap $ Head hid . wrappedLoad) (const $ Head hid stored) <$> replaceHeadRaw st tid hid (storedRef pobj) (storedRef stored) replaceHeadRaw :: forall m. MonadIO m => Storage -> HeadTypeID -> HeadID -> Ref -> Ref -> m (Either (Maybe Ref) Ref) replaceHeadRaw st tid hid prev new = liftIO $ do case stBacking st of StorageDir { dirPath = spath } -> do let filename = headPath spath tid hid showRefL r = showRef r `B.append` BC.singleton '\n' writeFileChecked filename (Just $ showRefL prev) (showRefL new) >>= \case Left Nothing -> return $ Left Nothing Left (Just bs) -> do Just oref <- readRef st $ BC.takeWhile (/='\n') bs return $ Left $ Just oref Right () -> return $ Right new StorageMemory { memHeads = theads, memWatchers = twatch } -> do res <- modifyMVar theads $ \hs -> do ws <- map wlFun . filter ((==(tid, hid)) . wlHead) . wlList <$> readMVar twatch return $ case partition ((==(tid, hid)) . fst) hs of ([] , _ ) -> (hs, Left Nothing) ((_, r):_, hs') | r == prev -> (((tid, hid), new) : hs', Right (new, ws)) | otherwise -> (hs, Left $ Just r) case res of Right (r, ws) -> mapM_ ($ r) ws >> return (Right r) Left x -> return $ Left x updateHead :: (HeadType a, MonadIO m) => Head a -> (Stored a -> m (Stored a, b)) -> m (Maybe (Head a), b) updateHead h f = do (o, x) <- f $ headStoredObject h replaceHead h o >>= \case Right h' -> return (Just h', x) Left Nothing -> return (Nothing, x) Left (Just h') -> updateHead h' f updateHead_ :: (HeadType a, MonadIO m) => Head a -> (Stored a -> m (Stored a)) -> m (Maybe (Head a)) updateHead_ h = fmap fst . updateHead h . (fmap (,()) .) data WatchedHead = forall a. WatchedHead Storage WatchID (MVar a) watchHead :: forall a. HeadType a => Head a -> (Head a -> IO ()) -> IO WatchedHead watchHead h = watchHeadWith h id watchHeadWith :: forall a b. (HeadType a, Eq b) => Head a -> (Head a -> b) -> (b -> IO ()) -> IO WatchedHead watchHeadWith (Head hid (Stored (Ref st _) _)) sel cb = do watchHeadRaw st (headTypeID @a Proxy) hid (sel . Head hid . wrappedLoad) cb watchHeadRaw :: forall b. Eq b => Storage -> HeadTypeID -> HeadID -> (Ref -> b) -> (b -> IO ()) -> IO WatchedHead watchHeadRaw st tid hid sel cb = do memo <- newEmptyMVar let addWatcher wl = (wl', WatchedHead st (wlNext wl) memo) where wl' = wl { wlNext = wlNext wl + 1 , wlList = WatchListItem { wlID = wlNext wl , wlHead = (tid, hid) , wlFun = \r -> do let x = sel r modifyMVar_ memo $ \prev -> do when (Just x /= prev) $ cb x return $ Just x } : wlList wl } watched <- case stBacking st of StorageDir { dirPath = spath, dirWatchers = mvar } -> modifyMVar mvar $ \(mbmanager, ilist, wl) -> do manager <- maybe startManager return mbmanager ilist' <- case tid `elem` ilist of True -> return ilist False -> do void $ watchDir manager (headTypePath spath tid) (const True) $ \case Added { eventPath = fpath } | Just ihid <- HeadID <$> U.fromString (takeFileName fpath) -> do loadHeadRaw st tid ihid >>= \case Just ref -> do (_, _, iwl) <- readMVar mvar mapM_ ($ ref) . map wlFun . filter ((== (tid, ihid)) . wlHead) . wlList $ iwl Nothing -> return () _ -> return () return $ tid : ilist return $ first ( Just manager, ilist', ) $ addWatcher wl StorageMemory { memWatchers = mvar } -> modifyMVar mvar $ return . addWatcher cur <- fmap sel <$> loadHeadRaw st tid hid maybe (return ()) cb cur putMVar memo cur return watched unwatchHead :: WatchedHead -> IO () unwatchHead (WatchedHead st wid _) = do let delWatcher wl = wl { wlList = filter ((/=wid) . wlID) $ wlList wl } case stBacking st of StorageDir { dirWatchers = mvar } -> modifyMVar_ mvar $ return . second delWatcher StorageMemory { memWatchers = mvar } -> modifyMVar_ mvar $ return . delWatcher class Monad m => MonadStorage m where getStorage :: m Storage mstore :: Storable a => a -> m (Stored a) default mstore :: MonadIO m => Storable a => a -> m (Stored a) mstore x = do st <- getStorage wrappedStore st x instance MonadIO m => MonadStorage (ReaderT Storage m) where getStorage = ask instance MonadIO m => MonadStorage (ReaderT (Head a) m) where getStorage = asks $ headStorage class Storable a where store' :: a -> Store load' :: Load a store :: StorageCompleteness c => Storage' c -> a -> IO (Ref' c) store st = evalStore st . store' load :: Ref -> a load = evalLoad load' class Storable a => ZeroStorable a where fromZero :: Storage -> a data Store = StoreBlob ByteString | StoreRec (forall c. StorageCompleteness c => Storage' c -> [IO [(ByteString, RecItem' c)]]) | StoreZero evalStore :: StorageCompleteness c => Storage' c -> Store -> IO (Ref' c) evalStore st = unsafeStoreObject st <=< evalStoreObject st evalStoreObject :: StorageCompleteness c => Storage' c -> Store -> IO (Object' c) evalStoreObject _ (StoreBlob x) = return $ Blob x evalStoreObject s (StoreRec f) = Rec . concat <$> sequence (f s) evalStoreObject _ StoreZero = return ZeroObject newtype StoreRecM c a = StoreRecM (ReaderT (Storage' c) (Writer [IO [(ByteString, RecItem' c)]]) a) deriving (Functor, Applicative, Monad) type StoreRec c = StoreRecM c () newtype Load a = Load (ReaderT (Ref, Object) (Except String) a) deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError String) evalLoad :: Load a -> Ref -> a evalLoad (Load f) ref = either (error {- TODO throw -} . ((BC.unpack (showRef ref) ++ ": ")++)) id $ runExcept $ runReaderT f (ref, lazyLoadObject ref) loadCurrentRef :: Load Ref loadCurrentRef = Load $ asks fst loadCurrentObject :: Load Object loadCurrentObject = Load $ asks snd newtype LoadRec a = LoadRec (ReaderT (Ref, [(ByteString, RecItem)]) (Except String) a) deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError String) loadRecCurrentRef :: LoadRec Ref loadRecCurrentRef = LoadRec $ asks fst loadRecItems :: LoadRec [(ByteString, RecItem)] loadRecItems = LoadRec $ asks snd instance Storable Object where store' (Blob bs) = StoreBlob bs store' (Rec xs) = StoreRec $ \st -> return $ do Rec xs' <- copyObject st (Rec xs) return xs' store' ZeroObject = StoreZero load' = loadCurrentObject store st = unsafeStoreObject st <=< copyObject st load = lazyLoadObject instance Storable ByteString where store' = storeBlob load' = loadBlob id instance Storable a => Storable [a] where store' [] = storeZero store' (x:xs) = storeRec $ do storeRef "i" x storeRef "n" xs load' = loadCurrentObject >>= \case ZeroObject -> return [] _ -> loadRec $ (:) <$> loadRef "i" <*> loadRef "n" instance Storable a => ZeroStorable [a] where fromZero _ = [] storeBlob :: ByteString -> Store storeBlob = StoreBlob storeRec :: (forall c. StorageCompleteness c => StoreRec c) -> Store storeRec sr = StoreRec $ do let StoreRecM r = sr execWriter . runReaderT r storeZero :: Store storeZero = StoreZero class StorableText a where toText :: a -> Text fromText :: MonadError String m => Text -> m a instance StorableText Text where toText = id; fromText = return instance StorableText [Char] where toText = T.pack; fromText = return . T.unpack class StorableDate a where toDate :: a -> ZonedTime fromDate :: ZonedTime -> a instance StorableDate ZonedTime where toDate = id; fromDate = id instance StorableDate UTCTime where toDate = utcToZonedTime utc fromDate = zonedTimeToUTC instance StorableDate Day where toDate day = toDate $ UTCTime day 0 fromDate = utctDay . fromDate class StorableUUID a where toUUID :: a -> UUID fromUUID :: UUID -> a instance StorableUUID UUID where toUUID = id; fromUUID = id storeEmpty :: String -> StoreRec c storeEmpty name = StoreRecM $ tell [return [(BC.pack name, RecEmpty)]] storeMbEmpty :: String -> Maybe () -> StoreRec c storeMbEmpty name = maybe (return ()) (const $ storeEmpty name) storeInt :: Integral a => String -> a -> StoreRec c storeInt name x = StoreRecM $ tell [return [(BC.pack name, RecInt $ toInteger x)]] storeMbInt :: Integral a => String -> Maybe a -> StoreRec c storeMbInt name = maybe (return ()) (storeInt name) storeNum :: (Real a, Fractional a) => String -> a -> StoreRec c storeNum name x = StoreRecM $ tell [return [(BC.pack name, RecNum $ toRational x)]] storeMbNum :: (Real a, Fractional a) => String -> Maybe a -> StoreRec c storeMbNum name = maybe (return ()) (storeNum name) storeText :: StorableText a => String -> a -> StoreRec c storeText name x = StoreRecM $ tell [return [(BC.pack name, RecText $ toText x)]] storeMbText :: StorableText a => String -> Maybe a -> StoreRec c storeMbText name = maybe (return ()) (storeText name) storeBinary :: BA.ByteArrayAccess a => String -> a -> StoreRec c storeBinary name x = StoreRecM $ tell [return [(BC.pack name, RecBinary $ BA.convert x)]] storeMbBinary :: BA.ByteArrayAccess a => String -> Maybe a -> StoreRec c storeMbBinary name = maybe (return ()) (storeBinary name) storeDate :: StorableDate a => String -> a -> StoreRec c storeDate name x = StoreRecM $ 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 = StoreRecM $ tell [return [(BC.pack name, RecUUID $ toUUID x)]] storeMbUUID :: StorableUUID a => String -> Maybe a -> StoreRec c storeMbUUID name = maybe (return ()) (storeUUID name) storeRef :: Storable a => StorageCompleteness c => String -> a -> StoreRec c storeRef name x = StoreRecM $ do s <- ask tell $ (:[]) $ do ref <- store s x return [(BC.pack name, RecRef ref)] storeMbRef :: Storable a => StorageCompleteness c => String -> Maybe a -> StoreRec c storeMbRef name = maybe (return ()) (storeRef name) storeRawRef :: StorageCompleteness c => String -> Ref -> StoreRec c storeRawRef name ref = StoreRecM $ do st <- ask tell $ (:[]) $ do ref' <- copyRef st ref return [(BC.pack name, RecRef ref')] storeMbRawRef :: StorageCompleteness c => String -> Maybe Ref -> StoreRec c storeMbRawRef name = maybe (return ()) (storeRawRef name) storeZRef :: (ZeroStorable a, StorageCompleteness c) => String -> a -> StoreRec c storeZRef name x = StoreRecM $ do s <- ask tell $ (:[]) $ do ref <- store s x return $ if isZeroRef ref then [] else [(BC.pack name, RecRef ref)] storeRecItems :: StorageCompleteness c => [ ( ByteString, RecItem ) ] -> StoreRec c storeRecItems items = StoreRecM $ do st <- ask tell $ flip map items $ \( name, value ) -> do value' <- copyRecItem st value return [ ( name, value' ) ] loadBlob :: (ByteString -> a) -> Load a loadBlob f = loadCurrentObject >>= \case Blob x -> return $ f x _ -> throwError "Expecting blob" loadRec :: LoadRec a -> Load a loadRec (LoadRec lrec) = loadCurrentObject >>= \case Rec rs -> do ref <- loadCurrentRef either throwError return $ runExcept $ runReaderT lrec (ref, rs) _ -> throwError "Expecting record" loadZero :: a -> Load a loadZero x = loadCurrentObject >>= \case ZeroObject -> return x _ -> throwError "Expecting zero" loadEmpty :: String -> LoadRec () loadEmpty name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbEmpty name loadMbEmpty :: String -> LoadRec (Maybe ()) loadMbEmpty name = (lookup (BC.pack name) <$> loadRecItems) >>= \case Nothing -> return Nothing Just (RecEmpty) -> return (Just ()) Just _ -> throwError $ "Expecting type int of record item '"++name++"'" loadInt :: Num a => String -> LoadRec a loadInt name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbInt name loadMbInt :: Num a => String -> LoadRec (Maybe a) loadMbInt name = (lookup (BC.pack name) <$> loadRecItems) >>= \case Nothing -> return Nothing Just (RecInt x) -> return (Just $ fromInteger x) Just _ -> throwError $ "Expecting type int of record item '"++name++"'" loadNum :: (Real a, Fractional a) => String -> LoadRec a loadNum name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbNum name loadMbNum :: (Real a, Fractional a) => String -> LoadRec (Maybe a) loadMbNum name = (lookup (BC.pack name) <$> loadRecItems) >>= \case Nothing -> return Nothing Just (RecNum x) -> return (Just $ fromRational x) Just _ -> throwError $ "Expecting type number of record item '"++name++"'" loadText :: StorableText a => String -> LoadRec a loadText name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbText name loadMbText :: StorableText a => String -> LoadRec (Maybe a) loadMbText name = (lookup (BC.pack name) <$> loadRecItems) >>= \case Nothing -> return Nothing Just (RecText x) -> Just <$> fromText x Just _ -> throwError $ "Expecting type text of record item '"++name++"'" loadTexts :: StorableText a => String -> LoadRec [a] loadTexts name = do items <- map snd . filter ((BC.pack name ==) . fst) <$> loadRecItems forM items $ \case RecText x -> fromText x _ -> throwError $ "Expecting type text of record item '"++name++"'" loadBinary :: BA.ByteArray a => String -> LoadRec a loadBinary name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbBinary name loadMbBinary :: BA.ByteArray a => String -> LoadRec (Maybe a) loadMbBinary name = (lookup (BC.pack name) <$> loadRecItems) >>= \case Nothing -> return Nothing Just (RecBinary x) -> return $ Just $ BA.convert x Just _ -> throwError $ "Expecting type binary of record item '"++name++"'" loadBinaries :: BA.ByteArray a => String -> LoadRec [a] loadBinaries name = do items <- map snd . filter ((BC.pack name ==) . fst) <$> loadRecItems forM items $ \case RecBinary x -> return $ BA.convert x _ -> throwError $ "Expecting type binary of record item '"++name++"'" loadDate :: StorableDate a => String -> LoadRec a loadDate name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbDate name loadMbDate :: StorableDate a => String -> LoadRec (Maybe a) loadMbDate name = (lookup (BC.pack name) <$> loadRecItems) >>= \case Nothing -> return Nothing 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 = (lookup (BC.pack name) <$> loadRecItems) >>= \case Nothing -> return Nothing Just (RecUUID x) -> return $ Just $ fromUUID x Just _ -> throwError $ "Expecting type UUID of record item '"++name++"'" loadRawRef :: String -> LoadRec Ref loadRawRef name = maybe (throwError $ "Missing record item '"++name++"'") return =<< loadMbRawRef name loadMbRawRef :: String -> LoadRec (Maybe Ref) loadMbRawRef name = (lookup (BC.pack name) <$> loadRecItems) >>= \case Nothing -> return Nothing Just (RecRef x) -> return (Just x) Just _ -> throwError $ "Expecting type ref of record item '"++name++"'" loadRawRefs :: String -> LoadRec [Ref] loadRawRefs name = do items <- map snd . filter ((BC.pack name ==) . fst) <$> loadRecItems forM items $ \case RecRef x -> return x _ -> throwError $ "Expecting type ref of record item '"++name++"'" loadRef :: Storable a => String -> LoadRec a loadRef name = load <$> loadRawRef name loadMbRef :: Storable a => String -> LoadRec (Maybe a) loadMbRef name = fmap load <$> loadMbRawRef name loadRefs :: Storable a => String -> LoadRec [a] loadRefs name = map load <$> loadRawRefs name loadZRef :: ZeroStorable a => String -> LoadRec a loadZRef name = loadMbRef name >>= \case Nothing -> do Ref st _ <- loadRecCurrentRef return $ fromZero st Just x -> return x type Stored a = Stored' Complete a instance Storable a => Storable (Stored a) where store st = copyRef st . storedRef store' (Stored _ x) = store' x load' = Stored <$> loadCurrentRef <*> load' instance ZeroStorable a => ZeroStorable (Stored a) where fromZero st = Stored (zeroRef st) $ fromZero st fromStored :: Stored a -> a fromStored (Stored _ x) = x storedRef :: Stored a -> Ref storedRef (Stored ref _) = ref wrappedStore :: MonadIO m => Storable a => Storage -> a -> m (Stored a) wrappedStore st x = do ref <- liftIO $ store st x return $ Stored ref x wrappedLoad :: Storable a => Ref -> Stored a wrappedLoad ref = Stored ref (load ref) copyStored :: forall c c' m a. (StorageCompleteness c, StorageCompleteness c', MonadIO m) => Storage' c' -> Stored' c a -> m (LoadResult c (Stored' c' a)) copyStored st (Stored ref' x) = liftIO $ returnLoadResult . fmap (flip Stored x) <$> copyRef' st ref' -- |Passed function needs to preserve the object representation to be safe unsafeMapStored :: (a -> b) -> Stored a -> Stored b unsafeMapStored f (Stored ref x) = Stored ref (f x) data StoreInfo = StoreInfo { infoDate :: ZonedTime , infoNote :: Maybe Text } deriving (Show) makeStoreInfo :: IO StoreInfo makeStoreInfo = StoreInfo <$> getZonedTime <*> pure Nothing storeInfoRec :: StoreInfo -> StoreRec c storeInfoRec info = do storeDate "date" $ infoDate info storeMbText "note" $ infoNote info loadInfoRec :: LoadRec StoreInfo loadInfoRec = StoreInfo <$> loadDate "date" <*> loadMbText "note" data History a = History StoreInfo (Stored a) (Maybe (StoredHistory a)) deriving (Show) type StoredHistory a = Stored (History a) instance Storable a => Storable (History a) where store' (History si x prev) = storeRec $ do storeInfoRec si storeMbRef "prev" prev storeRef "item" x load' = loadRec $ History <$> loadInfoRec <*> loadRef "item" <*> loadMbRef "prev" fromHistory :: StoredHistory a -> a fromHistory = fromStored . storedFromHistory fromHistoryAt :: ZonedTime -> StoredHistory a -> Maybe a fromHistoryAt zat = fmap (fromStored . snd) . listToMaybe . dropWhile ((at<) . zonedTimeToUTC . fst) . storedHistoryTimedList where at = zonedTimeToUTC zat storedFromHistory :: StoredHistory a -> Stored a storedFromHistory sh = let History _ item _ = fromStored sh in item storedHistoryList :: StoredHistory a -> [Stored a] storedHistoryList = map snd . storedHistoryTimedList storedHistoryTimedList :: StoredHistory a -> [(ZonedTime, Stored a)] storedHistoryTimedList sh = let History hinfo item prev = fromStored sh in (infoDate hinfo, item) : maybe [] storedHistoryTimedList prev beginHistory :: Storable a => Storage -> StoreInfo -> a -> IO (StoredHistory a) beginHistory st si x = do sx <- wrappedStore st x wrappedStore st $ History si sx Nothing modifyHistory :: Storable a => StoreInfo -> (a -> a) -> StoredHistory a -> IO (StoredHistory a) modifyHistory si f prev@(Stored (Ref st _) _) = do sx <- wrappedStore st $ f $ fromHistory prev wrappedStore st $ History si sx (Just prev) showRatio :: Rational -> String showRatio r = case decimalRatio r of Just (n, 1) -> show n Just (n', d) -> let n = abs n' in (if n' < 0 then "-" else "") ++ show (n `div` d) ++ "." ++ (concatMap (show.(`mod` 10).snd) $ reverse $ takeWhile ((>1).fst) $ zip (iterate (`div` 10) d) (iterate (`div` 10) (n `mod` d))) Nothing -> show (numerator r) ++ "/" ++ show (denominator r) decimalRatio :: Rational -> Maybe (Integer, Integer) decimalRatio r = do let n = numerator r d = denominator r (c2, d') = takeFactors 2 d (c5, d'') = takeFactors 5 d' guard $ d'' == 1 let m = if c2 > c5 then 5 ^ (c2 - c5) else 2 ^ (c5 - c2) return (n * m, d * m) takeFactors :: Integer -> Integer -> (Integer, Integer) takeFactors f n | n `mod` f == 0 = let (c, n') = takeFactors f (n `div` f) in (c+1, n') | otherwise = (0, n) parseRatio :: ByteString -> Maybe Rational parseRatio bs = case BC.groupBy ((==) `on` isNumber) bs of (m:xs) | m == BC.pack "-" -> negate <$> positive xs xs -> positive xs where positive = \case [bx] -> fromInteger . fst <$> BC.readInteger bx [bx, op, by] -> do (x, _) <- BC.readInteger bx (y, _) <- BC.readInteger by case BC.unpack op of "." -> return $ (x % 1) + (y % (10 ^ BC.length by)) "/" -> return $ x % y _ -> Nothing _ -> Nothing