{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Convert JSON to BSON and the other way around.
--
-- Note that BSON has more data types than JSON,
-- so some BSON to JSON conversions are not bijective and somewhat arbitrary.
--
-- This means that for some BSON objects:
--
-- >bsonify . aesonify /= id
-- >bsonifyValue . aesonifyValue /= id
--
-- We tried to choose sensible translations on those cases.
module Data.AesonBson (
  aesonify, aesonifyValue,
  bsonify, bsonifyValue,
  bsonifyError, bsonifyBound,
  errorRange, bound,
) where

-- TODO Document the arbitrary choices in the Haddock.

import           Data.Bson as BSON
import           Data.Aeson.Types as AESON
import           Data.Int
import qualified Data.Scientific as S
import qualified Data.Text as Text
import qualified Data.Text.Encoding as T
import qualified Data.Vector as Vector (fromList, toList)

# if MIN_VERSION_aeson(2, 0, 0)
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as HashMap (fromList, toList)
textToKey :: Text.Text -> AESON.Key
textToKey :: Text -> Key
textToKey = Text -> Key
Key.fromText
keyToText :: AESON.Key -> Text.Text
keyToText :: Key -> Text
keyToText = Key -> Text
Key.toText
# else
import qualified Data.HashMap.Strict as HashMap (fromList, toList)
textToKey :: Text.Text -> Text.Text
textToKey = id
keyToText :: Text.Text -> Text.Text
keyToText = id
# endif

-- | Converts an AESON object to a BSON document. Will yeld an error for JSON numbers that are too big.
bsonifyError :: AESON.Object -> BSON.Document
bsonifyError :: Object -> Document
bsonifyError = (Scientific -> Value) -> Object -> Document
bsonify Scientific -> Value
errorRange

-- | Converts an AESON object to a BSON document. Will bound JSON numbers that are too big.
bsonifyBound :: AESON.Object -> BSON.Document
bsonifyBound :: Object -> Document
bsonifyBound = (Scientific -> Value) -> Object -> Document
bsonify Scientific -> Value
bound

-- | Converts an AESON object to a BSON document. The user can provide a function to deal with JSON numbers that are too big.
bsonify :: (S.Scientific -> BSON.Value) -> AESON.Object -> BSON.Document
bsonify :: (Scientific -> Value) -> Object -> Document
bsonify Scientific -> Value
f Object
o = ((Key, Value) -> Field) -> [(Key, Value)] -> Document
forall a b. (a -> b) -> [a] -> [b]
map (\(Key
t, Value
v) -> Key -> Text
keyToText Key
t Text -> Value -> Field
:= (Scientific -> Value) -> Value -> Value
bsonifyValue Scientific -> Value
f Value
v) ([(Key, Value)] -> Document) -> [(Key, Value)] -> Document
forall a b. (a -> b) -> a -> b
$ Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
HashMap.toList Object
o

-- | Converts a BSON document to an AESON object.
aesonify :: BSON.Document -> AESON.Object
aesonify :: Document -> Object
aesonify = [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
HashMap.fromList ([(Key, Value)] -> Object)
-> (Document -> [(Key, Value)]) -> Document -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Field -> (Key, Value)) -> Document -> [(Key, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
l := Value
v) -> (Text -> Key
textToKey Text
l, Value -> Value
aesonifyValue Value
v))


-- | Helpers

-- | Converts a JSON value to BSON.
bsonifyValue :: (S.Scientific -> BSON.Value) -> AESON.Value -> BSON.Value
bsonifyValue :: (Scientific -> Value) -> Value -> Value
bsonifyValue Scientific -> Value
f (Object Object
obj)        = Document -> Value
Doc (Document -> Value) -> Document -> Value
forall a b. (a -> b) -> a -> b
$ (Scientific -> Value) -> Object -> Document
bsonify Scientific -> Value
f Object
obj
bsonifyValue Scientific -> Value
f (AESON.Array Array
array) = [Value] -> Value
BSON.Array ([Value] -> Value) -> (Array -> [Value]) -> Array -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Value) -> [Value] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map ((Scientific -> Value) -> Value -> Value
bsonifyValue Scientific -> Value
f) ([Value] -> [Value]) -> (Array -> [Value]) -> Array -> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Array -> [Value]
forall a. Vector a -> [a]
Vector.toList (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ Array
array
bsonifyValue Scientific -> Value
_ (AESON.String Text
str)  = Text -> Value
BSON.String Text
str
bsonifyValue Scientific -> Value
_ (AESON.Bool Bool
b)      = Bool -> Value
BSON.Bool Bool
b
bsonifyValue Scientific -> Value
_ (Value
AESON.Null)        = Value
BSON.Null
bsonifyValue Scientific -> Value
f (AESON.Number Scientific
n)    = Scientific -> Value
f Scientific
n 


-- | Converts a BSON value to JSON.
aesonifyValue :: BSON.Value -> AESON.Value
aesonifyValue :: Value -> Value
aesonifyValue (Float Double
f)                       = Double -> Value
forall a. ToJSON a => a -> Value
toJSON Double
f
aesonifyValue (BSON.String Text
s)                 = Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
s
aesonifyValue (Doc Document
doc)                       = Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ Document -> Object
aesonify Document
doc
aesonifyValue (BSON.Array [Value]
list)               = Array -> Value
AESON.Array (Array -> Value) -> ([Value] -> Array) -> [Value] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Value] -> Array
forall a. [a] -> Vector a
Vector.fromList ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ (Value -> Value) -> [Value] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Value
aesonifyValue [Value]
list
aesonifyValue (Bin (Binary ByteString
binary))           = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
binary
aesonifyValue (Fun (Function ByteString
function))       = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
function
aesonifyValue (Uuid (UUID ByteString
uuid))              = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
uuid
aesonifyValue (Md5 (MD5 ByteString
md5))                 = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
md5
aesonifyValue (UserDef (UserDefined ByteString
userdef)) = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
userdef
aesonifyValue (ObjId ObjectId
oid)                     = String -> Value
forall a. ToJSON a => a -> Value
toJSON (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ ObjectId -> String
forall a. Show a => a -> String
show ObjectId
oid -- Relies on bson to show the OID as 24 digit hex. It would be better if BSON exposed a non-show function for this, preferably a fast one.
aesonifyValue (BSON.Bool Bool
bool)                = Bool -> Value
forall a. ToJSON a => a -> Value
toJSON Bool
bool
aesonifyValue (UTC UTCTime
utc)                       = UTCTime -> Value
forall a. ToJSON a => a -> Value
toJSON UTCTime
utc
aesonifyValue (Value
BSON.Null)                     = Value
AESON.Null
aesonifyValue (RegEx (Regex Text
pattern Text
mods))    = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat [Text
"/", Text
pattern, Text
"/", Text
mods]
aesonifyValue (JavaScr (Javascript Document
env Text
code)) = [(Key, Value)] -> Value
object [ Key
"environment" Key -> Object -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Document -> Object
aesonify Document
env, Key
"code" Key -> Text -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
code ]
aesonifyValue (Sym (Symbol Text
sym))              = Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
sym
aesonifyValue (Int32 Int32
int32)                   = Int32 -> Value
forall a. ToJSON a => a -> Value
toJSON Int32
int32
aesonifyValue (Int64 Int64
int64)                   = Int64 -> Value
forall a. ToJSON a => a -> Value
toJSON Int64
int64
aesonifyValue (Stamp (MongoStamp Int64
int64))      = Int64 -> Value
forall a. ToJSON a => a -> Value
toJSON Int64
int64
aesonifyValue (MinMax MinMaxKey
mm)                     = case MinMaxKey
mm of { MinMaxKey
MinKey -> Int -> Value
forall a. ToJSON a => a -> Value
toJSON (-Int
1 :: Int)
                                                           ; MinMaxKey
MaxKey -> Int -> Value
forall a. ToJSON a => a -> Value
toJSON (Int
1 :: Int)}

int64MaxBound, int32MaxBound, int64MinBound, int32MinBound :: S.Scientific
int64MaxBound :: Scientific
int64MaxBound  = Int64 -> Scientific
forall i. Integral i => i -> Scientific
toScientific (Int64
forall a. Bounded a => a
maxBound :: Int64)
int32MaxBound :: Scientific
int32MaxBound  = Int32 -> Scientific
forall i. Integral i => i -> Scientific
toScientific (Int32
forall a. Bounded a => a
maxBound :: Int32)
int64MinBound :: Scientific
int64MinBound  = Int64 -> Scientific
forall i. Integral i => i -> Scientific
toScientific (Int64
forall a. Bounded a => a
minBound :: Int64)
int32MinBound :: Scientific
int32MinBound  = Int32 -> Scientific
forall i. Integral i => i -> Scientific
toScientific (Int32
forall a. Bounded a => a
minBound :: Int32)

toScientific :: Integral i => i -> S.Scientific
toScientific :: i -> Scientific
toScientific i
i = Integer -> Int -> Scientific
S.scientific (i -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral i
i :: Integer ) Int
0

expo :: S.Scientific -> Int
expo :: Scientific -> Int
expo Scientific
n  = Scientific -> Int
S.base10Exponent Scientific
n

coef :: S.Scientific -> Integer
coef :: Scientific -> Integer
coef Scientific
n = Scientific -> Integer
S.coefficient Scientific
n

-- Error when the number of out of range
errorRange :: S.Scientific -> BSON.Value
errorRange :: Scientific -> Value
errorRange Scientific
n | Scientific
n Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
< Scientific
int64MinBound = String -> Value
forall a. HasCallStack => String -> a
error (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ String
"Number out of min range: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Scientific -> String
forall a. Show a => a -> String
show Scientific
n)
errorRange Scientific
n | Scientific
n Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
> Scientific
int64MaxBound = String -> Value
forall a. HasCallStack => String -> a
error (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ String
"Number out of max range: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Scientific -> String
forall a. Show a => a -> String
show Scientific
n)
errorRange Scientific
n = Scientific -> Value
bsonifyNumberInRange Scientific
n 

-- Bound the number when out of range.
bound :: S.Scientific -> BSON.Value
bound :: Scientific -> Value
bound Scientific
n | Scientific
n Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
< Scientific
int64MinBound = Int64 -> Value
Int64 Int64
forall a. Bounded a => a
minBound
bound Scientific
n | Scientific
n Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
> Scientific
int64MaxBound = Int64 -> Value
Int64 Int64
forall a. Bounded a => a
maxBound
bound Scientific
n = Scientific -> Value
bsonifyNumberInRange Scientific
n 

-- Function for converting numbers within range; int64MinBound < n < int64MaxBound
bsonifyNumberInRange :: S.Scientific -> BSON.Value 
bsonifyNumberInRange :: Scientific -> Value
bsonifyNumberInRange Scientific
n | (Scientific -> Int
expo Scientific
n) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0                              = Double -> Value
Float (Scientific -> Double
forall a. RealFloat a => Scientific -> a
S.toRealFloat Scientific
n :: Double)
bsonifyNumberInRange Scientific
n | Scientific
int64MinBound Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
<= Scientific
n Bool -> Bool -> Bool
&& Scientific
n Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
<  Scientific
int32MinBound  = Int64 -> Value
Int64 (Int64 -> Value) -> Int64 -> Value
forall a b. (a -> b) -> a -> b
$ Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Scientific -> Integer
coef Scientific
n) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
10 Int64 -> Int -> Int64
forall a b. (Num a, Integral b) => a -> b -> a
^ (Scientific -> Int
expo Scientific
n)
bsonifyNumberInRange Scientific
n | Scientific
int32MinBound Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
<= Scientific
n Bool -> Bool -> Bool
&& Scientific
n Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
<= Scientific
int32MaxBound  = Int32 -> Value
Int32 (Int32 -> Value) -> Int32 -> Value
forall a b. (a -> b) -> a -> b
$ Integer -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Scientific -> Integer
coef Scientific
n) Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
10 Int32 -> Int -> Int32
forall a b. (Num a, Integral b) => a -> b -> a
^ (Scientific -> Int
expo Scientific
n)
bsonifyNumberInRange Scientific
n | Scientific
int32MaxBound Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
<  Scientific
n Bool -> Bool -> Bool
&& Scientific
n Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
<= Scientific
int64MaxBound  = Int64 -> Value
Int64 (Int64 -> Value) -> Int64 -> Value
forall a b. (a -> b) -> a -> b
$ Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Scientific -> Integer
coef Scientific
n) Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
* Int64
10 Int64 -> Int -> Int64
forall a b. (Num a, Integral b) => a -> b -> a
^ (Scientific -> Int
expo Scientific
n)
bsonifyNumberInRange Scientific
_ = String -> Value
forall a. HasCallStack => String -> a
error String
"bsonifyiNumberInRange should be invoked only with n | int64MinBound < n < int64MaxBound"