Allow JSON field values

hunt-searchengine/hunt-searchengine.cabal

@@ -31,7 +31,7 @@ source-repository head
 
 library
 
-  build-depends: aeson                  >= 0.6
+  build-depends: aeson                  >= 1.0.0.0
                , aeson-pretty           >= 0.7
                , base                   >= 4.8     && < 5
                , binary                 >= 0.5     && < 1

hunt-searchengine/src/Hunt/Common/DocDesc.hs

@@ -6,23 +6,26 @@
 module Hunt.Common.DocDesc
 where
 
-import           Prelude             hiding (lookup)
+import           Prelude              hiding (lookup)
 
-import           Control.Arrow       (second)
+import           Control.Arrow        (second)
 import           Control.DeepSeq
-import           Control.Monad       (mzero)
-
-import           Data.Aeson          (FromJSON (..), ToJSON (..), Value (..),
-                                      decode, encode)
-import           Data.Binary         (Binary (..))
-import           Data.ByteString     (ByteString)
-import qualified Data.HashMap.Strict as HM
-import           Data.Maybe          (fromMaybe)
-import qualified Data.Scientific     as Scientific
+import           Control.Monad        (mzero)
+
+import           Data.Aeson           (FromJSON (..), ToJSON (..), Value (..),
+                                       decode, decode', encode)
+import qualified Data.Aeson.Encoding.Internal as Enc
+import           Data.Binary          (Binary (..))
+import qualified Data.ByteString.Builder as Builder
+import           Data.ByteString      (ByteString)
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.HashMap.Strict  as HM
+import           Data.Maybe           (fromMaybe)
+import qualified Data.Scientific      as Scientific
 import           Data.String
-import           Data.Text           (Text)
-import qualified Data.Text           as Text
-import           Data.Text.Binary    ()
+import           Data.Text            (Text)
+import qualified Data.Text            as Text
+import           Data.Text.Binary     ()
 import           Data.Typeable
 
 -- ------------------------------------------------------------
@@ -35,10 +38,14 @@ type FieldRank = Int
 data FieldValue = FV_Int !Int
                 | FV_Float !Float
                 | FV_Text !Text
+                | FV_Json !ByteString
                 | FV_Binary !ByteString
                 | FV_Null
                 deriving (Eq, Show)
 
+jsonValue :: ToJSON a => a -> FieldValue
+jsonValue = FV_Json . LBS.toStrict . encode
+
 instance IsString FieldValue where
   fromString = FV_Text . fromString
 
@@ -51,16 +58,27 @@ instance FromJSON FieldValue where
     Number n -> pure $ case Scientific.floatingOrInteger n of
                          Left f  -> toFieldValue (f :: Float)
                          Right i -> toFieldValue (i :: Int)
-    _ -> mzero
+    x        -> pure $ jsonValue x
 
 instance ToJSON FieldValue where
   toJSON fv = case fv of
     FV_Int i    -> toJSON i
     FV_Float f  -> toJSON f
     FV_Text s   -> toJSON s
+    FV_Json j   -> case decode' (LBS.fromStrict j) of
+                     Just v  -> v
+                     Nothing -> error "invalid"
     FV_Binary _ -> Null -- TODO: maybe base64 encode binary values
     FV_Null     -> Null
 
+  toEncoding fv = case fv of
+    FV_Int i    -> toEncoding i
+    FV_Float f  -> toEncoding f
+    FV_Text t   -> toEncoding t
+    FV_Json j   -> Enc.unsafeToEncoding (Builder.byteString j)
+    FV_Binary _ -> toEncoding Null -- TODO: see toJSON
+    FV_Null     -> toEncoding Null
+
 class ToFieldValue a where
   toFieldValue :: a -> FieldValue
 

stack.yaml

@@ -8,14 +8,15 @@ packages:
   - ./hunt-server
   - ./hunt-test/data/jokes
 extra-deps:
-  - servant-0.9.1.1
-  - servant-server-0.9.1.1
-  - servant-client-0.9.1.1
-  - http-api-data-0.3.2
+  - aeson-1.0.2.1
   - data-r-tree-0.0.5.0
   - data-stringmap-1.0.1.1
+  - http-api-data-0.3.2
   - hxt-cache-9.1.0.1
   - hxt-xpath-9.1.2.2
+  - servant-0.9.1.1
+  - servant-client-0.9.1.1
+  - servant-server-0.9.1.1
   - store-0.3
   - store-core-0.3
 resolver: nightly-2016-08-06