{-# LANGUAGE BlockArguments      #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# LANGUAGE TypeOperators       #-}
module Polysemy.JSONFileKVStore where

import Control.Monad.Catch
import Control.Monad.Extra
import Control.Monad.IO.Class
import Data.Aeson
import qualified Data.Map as Map
import Data.Map (Map)
import GHC.Generics
import Polysemy
import Polysemy.Error
import Polysemy.Input
import Polysemy.KVStore
import Path
import qualified UnliftIO.Path.Directory as U

newtype JSONParseException = JSONParseException String
  deriving (Int -> JSONParseException -> ShowS
[JSONParseException] -> ShowS
JSONParseException -> String
(Int -> JSONParseException -> ShowS)
-> (JSONParseException -> String)
-> ([JSONParseException] -> ShowS)
-> Show JSONParseException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JSONParseException] -> ShowS
$cshowList :: [JSONParseException] -> ShowS
show :: JSONParseException -> String
$cshow :: JSONParseException -> String
showsPrec :: Int -> JSONParseException -> ShowS
$cshowsPrec :: Int -> JSONParseException -> ShowS
Show, JSONParseException -> JSONParseException -> Bool
(JSONParseException -> JSONParseException -> Bool)
-> (JSONParseException -> JSONParseException -> Bool)
-> Eq JSONParseException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JSONParseException -> JSONParseException -> Bool
$c/= :: JSONParseException -> JSONParseException -> Bool
== :: JSONParseException -> JSONParseException -> Bool
$c== :: JSONParseException -> JSONParseException -> Bool
Eq, (forall x. JSONParseException -> Rep JSONParseException x)
-> (forall x. Rep JSONParseException x -> JSONParseException)
-> Generic JSONParseException
forall x. Rep JSONParseException x -> JSONParseException
forall x. JSONParseException -> Rep JSONParseException x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep JSONParseException x -> JSONParseException
$cfrom :: forall x. JSONParseException -> Rep JSONParseException x
Generic)

instance Exception JSONParseException where
  displayException :: JSONParseException -> String
displayException (JSONParseException String
x) = String
x

eitherDecodeOrCreate :: (ToJSON a, FromJSON a, MonadIO m) => Path b File -> a -> m (Either String a)
eitherDecodeOrCreate :: Path b File -> a -> m (Either String a)
eitherDecodeOrCreate Path b File
f a
x = do
  m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((Bool -> Bool) -> m Bool -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Bool
not (m Bool -> m Bool)
-> (Path b File -> m Bool) -> Path b File -> m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path b File -> m Bool
forall (m :: * -> *) b. MonadIO m => Path b File -> m Bool
U.doesFileExist (Path b File -> m Bool) -> Path b File -> m Bool
forall a b. (a -> b) -> a -> b
$ Path b File
f) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> a -> IO ()
forall a. ToJSON a => String -> a -> IO ()
encodeFile (Path b File -> String
forall b t. Path b t -> String
toFilePath Path b File
f) a
x
  IO (Either String a) -> m (Either String a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String a) -> m (Either String a))
-> IO (Either String a) -> m (Either String a)
forall a b. (a -> b) -> a -> b
$ String -> IO (Either String a)
forall a. FromJSON a => String -> IO (Either String a)
eitherDecodeFileStrict' (Path b File -> String
forall b t. Path b t -> String
toFilePath Path b File
f)

runKVStoreAsJSONFileStore :: (Members '[Embed IO, Error JSONParseException] r,
                              FromJSONKey k, ToJSONKey k, FromJSON v, ToJSON v, Ord k)
                          => Path b File
                          -> Sem (KVStore k v ': r) a -> Sem r a
runKVStoreAsJSONFileStore :: Path b File -> Sem (KVStore k v : r) a -> Sem r a
runKVStoreAsJSONFileStore Path b File
d = (forall x (m :: * -> *). KVStore k v m x -> Sem r x)
-> Sem (KVStore k v : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (m :: * -> *). e m x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret \case
  LookupKV k -> do
    Either String (Map k v)
z <- Path b File -> Map k v -> Sem r (Either String (Map k v))
forall a (m :: * -> *) b.
(ToJSON a, FromJSON a, MonadIO m) =>
Path b File -> a -> m (Either String a)
eitherDecodeOrCreate Path b File
d Map k v
forall a. Monoid a => a
mempty
    case Either String (Map k v)
z of
      Left String
x  -> forall (r :: [(* -> *) -> * -> *]) a.
MemberWithError (Error JSONParseException) r =>
JSONParseException -> Sem r a
forall e (r :: [(* -> *) -> * -> *]) a.
MemberWithError (Error e) r =>
e -> Sem r a
throw @JSONParseException (JSONParseException -> Sem r x) -> JSONParseException -> Sem r x
forall a b. (a -> b) -> a -> b
$ String -> JSONParseException
JSONParseException String
x
      Right Map k v
x -> Maybe v -> Sem r (Maybe v)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe v -> Sem r (Maybe v)) -> Maybe v -> Sem r (Maybe v)
forall a b. (a -> b) -> a -> b
$ k -> Map k v -> Maybe v
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k Map k v
x
  UpdateKV k v -> do
    Either String (Map k v)
z <- Path b File -> Map k v -> Sem r (Either String (Map k v))
forall a (m :: * -> *) b.
(ToJSON a, FromJSON a, MonadIO m) =>
Path b File -> a -> m (Either String a)
eitherDecodeOrCreate Path b File
d Map k v
forall a. Monoid a => a
mempty
    case Either String (Map k v)
z of
      Left String
x -> JSONParseException -> Sem r x
forall e (r :: [(* -> *) -> * -> *]) a.
MemberWithError (Error e) r =>
e -> Sem r a
throw (JSONParseException -> Sem r x) -> JSONParseException -> Sem r x
forall a b. (a -> b) -> a -> b
$ String -> JSONParseException
JSONParseException String
x
      Right (Map k v
x :: Map k v) -> IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ String -> Map k v -> IO ()
forall a. ToJSON a => String -> a -> IO ()
encodeFile (Path b File -> String
forall b t. Path b t -> String
toFilePath Path b File
d) ((Maybe v -> Maybe v) -> k -> Map k v -> Map k v
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (Maybe v -> Maybe v -> Maybe v
forall a b. a -> b -> a
const Maybe v
v) k
k Map k v
x)