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