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