From f22675189e19d1cce20362121ef8c8aebe3628f1 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gregor.kleen@ifi.lmu.de>
Date: Wed, 9 Dec 2020 23:51:46 +0100
Subject: [PATCH] feat: use c++ library for json parsing from database

---
 package.yaml               |  6 ++++++
 src/Model/Types/TH/JSON.hs | 13 +++++++++++++
 stack.yaml                 |  3 +++
 stack.yaml.lock            | 11 +++++++++++
 4 files changed, 33 insertions(+)

diff --git a/package.yaml b/package.yaml
index daaec32f3..2b0555f37 100644
--- a/package.yaml
+++ b/package.yaml
@@ -159,6 +159,7 @@ dependencies:
   - insert-ordered-containers
   - topograph
   - network-uri
+  - sajson
 
 other-extensions:
   - GeneralizedNewtypeDeriving
@@ -252,6 +253,8 @@ when:
     else:
       ghc-options:
         - -O -fllvm
+  - condition: flag(sajson)
+    cpp-options: -DSAJSON
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.
@@ -363,3 +366,6 @@ flags:
     description: Be very pedantic about warnings and errors
     manual: false
     default: true
+  sajson:
+    manual: false
+    default: true
diff --git a/src/Model/Types/TH/JSON.hs b/src/Model/Types/TH/JSON.hs
index 5320d6174..552f8a701 100644
--- a/src/Model/Types/TH/JSON.hs
+++ b/src/Model/Types/TH/JSON.hs
@@ -4,6 +4,7 @@ import ClassyPrelude.Yesod hiding (derivePersistFieldJSON, toPersistValueJSON, f
 import Data.List (foldl)
 import Database.Persist.Sql hiding (toPersistValueJSON, fromPersistValueJSON)
 
+import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.Text.Encoding as Text
 
@@ -14,6 +15,10 @@ import Language.Haskell.TH.Datatype
 
 import Utils.PathPiece
 
+#ifdef SAJSON
+import qualified Data.Sajson as Sajson
+#endif
+
 
 toPersistValueJSON :: ToJSON a => a -> PersistValue
 toPersistValueJSON = PersistDbSpecific . LBS.toStrict . JSON.encode
@@ -24,7 +29,15 @@ fromPersistValueJSON = \case
   PersistByteString bs   -> decodeBS bs
   PersistText       text -> decodeBS $ Text.encodeUtf8 text
   _other                 -> Left "JSON values must be converted from PersistDbSpecific, PersistText, or PersistByteString"
+#ifdef SAJSON
+  where
+    decodeBS bs
+      | compatibleToplevel bs = first pack $ Sajson.eitherDecodeStrict bs
+      | otherwise = first pack $ JSON.eitherDecodeStrict' bs
+    compatibleToplevel bs = any (`BS.isPrefixOf` bs) ["[", "{"]
+#else
   where decodeBS = first pack . JSON.eitherDecodeStrict'
+#endif
 
 sqlTypeJSON :: SqlType
 sqlTypeJSON = SqlOther "jsonb"
diff --git a/stack.yaml b/stack.yaml
index 57df0f3c6..8308af5cb 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -56,6 +56,9 @@ extra-deps:
   - git: git@gitlab2.rz.ifi.lmu.de:uni2work/zip-stream.git
     commit: 843683d024f767de236f74d24a3348f69181a720
 
+  - git: https://github.com/kccqzy/haskell-sajson.git
+    commit: ffc9670f24e308e32979f4e0343e6637a9f72cf4
+
   - acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207
   - commonmark-0.1.0.2@sha256:fbff7a2ade0ce7d699964a87f765e503a3a9e22542c05f0f02ba7aad64e38af4,3278
   - commonmark-extensions-0.2.0.1@sha256:647aa8dba5fd46984ddedc15c3693c9c4d9655503d42006576bd8f0dadf8cd39,3176
diff --git a/stack.yaml.lock b/stack.yaml.lock
index ce3b7f6f5..de0369e60 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -233,6 +233,17 @@ packages:
   original:
     git: git@gitlab2.rz.ifi.lmu.de:uni2work/zip-stream.git
     commit: 843683d024f767de236f74d24a3348f69181a720
+- completed:
+    name: sajson
+    version: 0.1.0.0
+    git: https://github.com/kccqzy/haskell-sajson.git
+    pantry-tree:
+      size: 651
+      sha256: faff738ae449bf7046bc9775cf4ce4db115d7c52cbf40040e11e6a232f9d1187
+    commit: ffc9670f24e308e32979f4e0343e6637a9f72cf4
+  original:
+    git: https://github.com/kccqzy/haskell-sajson.git
+    commit: ffc9670f24e308e32979f4e0343e6637a9f72cf4
 - completed:
     hackage: acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207
     pantry-tree: