diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for polysemy-fskvstore + +## v0.1.0.0 + +* Add interpreters for running a kvstore as a filesystem. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Daniel Firth (c) 2020 + +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 Author name here 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# polysemy-fskvstore + +This package provides interpreters to run a filesystem as a `KVStore` in +polysemy, using a `Path b File` as the key and either a UTF8 `Text` or a +`ByteString` as the value. 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/polysemy-fskvstore.cabal b/polysemy-fskvstore.cabal new file mode 100644 --- /dev/null +++ b/polysemy-fskvstore.cabal @@ -0,0 +1,40 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.2. +-- +-- see: https://github.com/sol/hpack + +name: polysemy-fskvstore +version: 0.1.0.0 +synopsis: Run a KVStore as a filesystem in polysemy. +category: Polysemy +author: Daniel Firth +maintainer: dan.firth@homotopic.tech +copyright: 2020 Daniel Firth +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://gitlab.com/homotopic-tech/polysemy-fskvstore + +library + exposed-modules: + Polysemy.FSKVStore + other-modules: + Paths_polysemy_fskvstore + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , bytestring + , path + , polysemy + , polysemy-zoo + , rio + , unliftio-path + default-language: Haskell2010 diff --git a/src/Polysemy/FSKVStore.hs b/src/Polysemy/FSKVStore.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/FSKVStore.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeOperators #-} +module Polysemy.FSKVStore ( + FSKVStore +, runFSKVStoreRelBS +, runFSKVStoreAbsBS +, runFSKVStoreRelUtf8 +, runFSKVStoreAbsUtf8 +) where + +import Data.ByteString as BS +import Path +import Polysemy +import Polysemy.KVStore +import RIO (Text, readFileUtf8, writeFileUtf8) +import qualified UnliftIO.Path.Directory as U + +-- | Type synonym for a KVStore indexed by files. +type FSKVStore b a = KVStore (Path b File) a + +-- | Run an `FSKVStore Rel ByteString` in the supplied directory in IO. +runFSKVStoreRelBS :: Members '[Embed IO] r + => Path b Dir + -> Sem (FSKVStore Rel ByteString ': r) a + -> Sem r a +runFSKVStoreRelBS d = interpret \case + LookupKV k -> embed $ do + z <- U.doesFileExist (d k) + if z + then fmap Just . BS.readFile $ toFilePath $ d k + else return Nothing + UpdateKV k v -> embed $ do + U.createDirectoryIfMissing True (d parent k) + case v of + Nothing -> pure () + Just x -> BS.writeFile (toFilePath (d k)) x + +-- | Run an `FSKVStore Abs ByteString` in IO. +runFSKVStoreAbsBS :: Members '[Embed IO] r + => Sem (FSKVStore Abs ByteString ': r) a + -> Sem r a +runFSKVStoreAbsBS = interpret \case + LookupKV k -> embed $ do + z <- U.doesFileExist k + if z + then fmap Just . BS.readFile $ toFilePath k + else return Nothing + UpdateKV k v -> embed $ do + U.createDirectoryIfMissing True (parent k) + case v of + Nothing -> pure () + Just x -> BS.writeFile (toFilePath k) x + +-- | Run an `FSKVStore Rel Text` in the supplied directory in IO as UTF8. +runFSKVStoreRelUtf8 :: Members '[Embed IO] r + => Path b Dir + -> Sem (FSKVStore Rel Text ': r) a + -> Sem r a +runFSKVStoreRelUtf8 d = interpret \case + LookupKV k -> do + z <- U.doesFileExist (d k) + if z + then fmap Just . readFileUtf8 $ toFilePath $ d k + else return Nothing + UpdateKV k v -> do + U.createDirectoryIfMissing True (d parent k) + case v of + Nothing -> pure () + Just x -> writeFileUtf8 (toFilePath (d k)) x + +-- | Run an `FSKVStore Abs Text` in IO as UTF8. +runFSKVStoreAbsUtf8 :: Members '[Embed IO] r + => Sem (FSKVStore Abs Text ': r) a + -> Sem r a +runFSKVStoreAbsUtf8 = interpret \case + LookupKV k -> do + z <- U.doesFileExist k + if z + then fmap Just . readFileUtf8 $ toFilePath k + else return Nothing + UpdateKV k v -> do + U.createDirectoryIfMissing True (parent k) + case v of + Nothing -> pure () + Just x -> writeFileUtf8 (toFilePath k) x