1 {-# LANGUAGE OverloadedStrings, FunctionalDependencies, ScopedTypeVariables #-} 2 {-# OPTIONS_GHC -fno-warn-orphans #-} 3 module Databrary.JSON 4 ( module Data.Aeson 5 , module Data.Aeson.Types 6 , ToObject 7 -- -- , objectEncoding 8 , mapObjects 9 , ToNestedObject(..) 10 , (.=.) 11 , kvObjectOrEmpty-- , (.=?) 12 , lookupAtParse-- , (.!) 13 -- , (.!?) 14 , Record(..) 15 , foldObjectIntoRec -- , (.<>) 16 , recordObject 17 , recordEncoding 18 , mapRecords 19 , (.=:) 20 , recordMap 21 -- -- , eitherJSON 22 , Query 23 , jsonQuery 24 -- -- , escapeByteString 25 ) where 26 27 import Data.Aeson 28 import Data.Aeson.Types 29 import Data.Aeson.Text (encodeToTextBuilder) 30 import qualified Data.ByteString as BS 31 import qualified Data.HashMap.Strict as HM 32 import Data.Monoid ((<>)) 33 import qualified Data.Text as T 34 import qualified Data.Text.Encoding as TE 35 import qualified Data.Text.Lazy as TL 36 import qualified Data.Text.Lazy.Builder as TLB 37 import qualified Data.Vector as V 38 import Network.HTTP.Types (Query) 39 import qualified Text.Blaze.Html as Html 40 import qualified Text.Blaze.Html.Renderer.Text as Html 41 42 newtype UnsafeEncoding = UnsafeEncoding Encoding 43 44 instance KeyValue [Pair] where 45 k .= v = [k .= v] 46 47 instance KeyValue Object where 48 k .= v = HM.singleton k $ toJSON v 49 50 class (Monoid o, KeyValue o) => ToObject o 51 52 instance ToObject Series 53 instance ToObject [Pair] 54 instance ToObject Object 55 56 mapObjects :: (Functor t, Foldable t) => (a -> Series) -> t a -> Encoding 57 mapObjects f = foldable . fmap (UnsafeEncoding . pairs . f) 58 59 class (ToObject o, ToJSON u) => ToNestedObject o u | o -> u where 60 nestObject :: ToJSON v => T.Text -> ((o -> u) -> v) -> o 61 62 instance ToJSON UnsafeEncoding where 63 toJSON = error "toJSON UnsafeEncoding" 64 toEncoding (UnsafeEncoding e) = e 65 66 instance ToNestedObject Series UnsafeEncoding where 67 nestObject k f = k .= f (UnsafeEncoding . pairs) 68 69 instance ToNestedObject [Pair] Value where 70 nestObject k f = k .= f object 71 72 instance ToNestedObject Object Value where 73 nestObject k f = k .= f Object 74 75 infixr 8 .=. 76 (.=.) :: ToNestedObject o u => T.Text -> o -> o 77 k .=. v = nestObject k (\f -> f v) 78 79 -- infixr 8 .=? 80 -- (.=?) :: (ToObject o, ToJSON v) => T.Text -> Maybe v -> o 81 kvObjectOrEmpty :: (ToObject o, ToJSON v) => T.Text -> Maybe v -> o 82 _ `kvObjectOrEmpty` Nothing = mempty 83 k `kvObjectOrEmpty` (Just v) = k .= v 84 85 data Record k o = Record 86 { recordKey :: !k 87 , _recordObject :: o 88 } 89 90 -- fold object into key + object 91 -- infixl 5 .<> 92 foldObjectIntoRec :: Monoid o => Record k o -> o -> Record k o 93 Record key obj `foldObjectIntoRec` obj2 = Record key $ obj <> obj2 94 95 recordObject :: (ToJSON k, ToObject o) => Record k o -> o 96 recordObject (Record k o) = ("id" .= k) <> o 97 98 recordEncoding :: ToJSON k => Record k Series -> Encoding 99 recordEncoding = pairs . recordObject 100 101 mapRecords :: (Functor t, Foldable t, ToJSON k) => (a -> Record k Series) -> t a -> Encoding 102 mapRecords toRecord objs = mapObjects (\obj -> (recordObject . toRecord) obj) objs 103 104 infixr 8 .=: 105 (.=:) :: (ToJSON k, ToNestedObject o u) => T.Text -> Record k o -> o 106 (.=:) k = (.=.) k . recordObject 107 108 recordMap :: (ToJSON k, ToNestedObject o u) => [Record k o] -> o 109 recordMap = foldMap (\r -> tt (toJSON $ recordKey r) .=. recordObject r) where 110 tt (String t) = t 111 tt v = TL.toStrict $ TLB.toLazyText $ encodeToTextBuilder v 112 113 lookupAtParse :: FromJSON a => Array -> Int -> Parser a 114 a `lookupAtParse` i = maybe (fail $ "index " ++ show i ++ " out of range") parseJSON $ a V.!? i 115 116 instance ToJSON BS.ByteString where 117 toJSON = String . TE.decodeUtf8 -- questionable 118 119 instance ToJSONKey BS.ByteString where 120 toJSONKey = toJSONKeyText TE.decodeUtf8 121 122 instance FromJSON BS.ByteString where 123 parseJSON = fmap TE.encodeUtf8 . parseJSON 124 125 instance ToJSON Html.Html where 126 toJSON = toJSON . Html.renderHtml 127 toEncoding = toEncoding . Html.renderHtml 128 129 jsonQuery :: Monad m => (BS.ByteString -> Maybe BS.ByteString -> m (Maybe Encoding)) -> Query -> m Series 130 jsonQuery _ [] = 131 return mempty 132 jsonQuery f ((k,mVal):qryPairs) = do 133 mEncoded :: Maybe Encoding <- f k mVal 134 let jsonQueryRestAct = jsonQuery f qryPairs 135 (maybe 136 (id :: Series -> Series) 137 (\encodedObj seriesRest -> (objToPair k encodedObj) <> seriesRest) 138 mEncoded) 139 <$> jsonQueryRestAct 140 where 141 objToPair :: (KeyValue kv) => BS.ByteString -> Encoding -> kv 142 objToPair key encObj = (((TE.decodeLatin1 key) .=) . UnsafeEncoding) encObj