diff options
| -rw-r--r-- | app/Main.hs | 2 | ||||
| -rw-r--r-- | src/Store/Exception.hs | 2 | ||||
| -rw-r--r-- | src/Store/Query.hs | 28 | ||||
| -rw-r--r-- | src/Store/Store.hs | 6 |
4 files changed, 23 insertions, 15 deletions
diff --git a/app/Main.hs b/app/Main.hs index 3b7f59d..9da083a 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -91,6 +91,6 @@ main = do <$> W.lazyRequestBody req r <- liftIO $ Q.withStore root ref (Q.query q) respond . W.responseLBS W.status200 [] $ - J.encode r + J.encode @J.Value r | otherwise -> respond $ W.responseLBS W.status200 [] "OK" diff --git a/src/Store/Exception.hs b/src/Store/Exception.hs index 94beaab..579256c 100644 --- a/src/Store/Exception.hs +++ b/src/Store/Exception.hs @@ -9,7 +9,7 @@ where import Control.Exception (Exception) import Data.Aeson qualified as J -data DecodeException = DecodeException +data DecodeException = DecodeException String deriving (Show) instance Exception DecodeException diff --git a/src/Store/Query.hs b/src/Store/Query.hs index 8520d0b..84e22a7 100644 --- a/src/Store/Query.hs +++ b/src/Store/Query.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + module Store.Query ( module Store.Query.Type, query, @@ -6,7 +8,6 @@ where import Control.Arrow (second) import Control.Exception (throw) -import Control.Monad.Trans (lift) import Data.Aeson qualified as J import Data.Aeson.Encode.Pretty qualified as JP import Data.Aeson.Key qualified as JK @@ -36,8 +37,19 @@ instance J.ToJSON Paginated instance J.FromJSON Paginated -query :: Query -> S.StoreM J.Value -query (Delete c w) = do +query :: (J.FromJSON a) => Query -> S.StoreM a +query = + ( ( \case + J.Error e -> throw (DecodeException e) + J.Success x -> pure x + ) + =<< + ) + . fmap J.fromJSON + . query' + +query' :: Query -> S.StoreM J.Value +query' (Delete c w) = do c' <- mapM (\fn -> fmap ((fn,) . fromValue c) . decodeFile c $ fn) =<< S.listFiles c @@ -46,7 +58,7 @@ query (Delete c w) = do mapM_ S.deleteFile (map (c </>) fps) S.commit pure (J.toJSON ([] @())) -query (Insert vs c) = do +query' (Insert vs c) = do let vs' = map (\v -> ((c, fileName v), v)) vs fileName v@(J.Object kvs) = @@ -56,7 +68,7 @@ query (Insert vs c) = do mapM_ (\((c, fn), v) -> encodeFile c fn v) vs' S.commit pure (J.toJSON ([] @())) -query (Select fs c js es w l o) = do +query' (Select fs c js es w l o) = do c' <- mapM (\fn -> fromValue c <$> decodeFile c fn) =<< S.listFiles c @@ -88,7 +100,7 @@ query (Select fs c js es w l o) = do J.toJSON (Paginated (length rs) . applyLimit l . applyOffset o $ rs) _ -> J.toJSON rs pure rs' -query (Update c v w) = do +query' (Update c v w) = do c' <- mapM (\fn -> fmap (((c, fn),) . fromValue c) . decodeFile c $ fn) =<< S.listFiles c @@ -204,8 +216,8 @@ decodeFile :: String -> String -> S.StoreM J.Value decodeFile c fn = do let fp = c </> fn union (J.Object (JM.singleton "$fileName" (J.String (T.pack fn)))) - . fromMaybe (throw DecodeException) - . J.decode + . either (throw . DecodeException) id + . J.eitherDecode <$> S.readFile fp encodeFile :: String -> String -> J.Value -> S.StoreM () diff --git a/src/Store/Store.hs b/src/Store/Store.hs index 134c8c3..61be89b 100644 --- a/src/Store/Store.hs +++ b/src/Store/Store.hs @@ -32,6 +32,7 @@ import Data.Time.Clock (getCurrentTime) import Foreign import Git qualified as G import Git.Libgit2 qualified as GB +import Store.Exception (DecodeException (DecodeException)) import System.FilePath (addTrailingPathSeparator, makeRelative, normalise, (</>)) import Text.Printf (printf) import Prelude hiding (readFile, writeFile) @@ -128,11 +129,6 @@ data InappropriateType = InappropriateType String FilePath instance Exception InappropriateType -data DecodeException = DecodeException String - deriving (Show) - -instance Exception DecodeException - class Readable a where readFile :: FilePath -> StoreM a |