{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Aeson.IP () where

import           Data.Aeson
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
import           Data.Aeson.Types
import           Data.IP
import           Data.IP.RouteTable (Routable, IPRTable)
import qualified Data.IP.RouteTable as RouteTable
import qualified Data.Text as Text
import           Text.Read (readMaybe)

instance FromJSON IPv4 where
    parseJSON :: Value -> Parser IPv4
parseJSON (String Text
s)
        | Just IPv4
r <- String -> Maybe IPv4
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
s) = IPv4 -> Parser IPv4
forall (f :: * -> *) a. Applicative f => a -> f a
pure IPv4
r
        | Bool
otherwise = String -> Parser IPv4
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to parse"
    parseJSON Value
v = String -> Value -> Parser IPv4
forall a. String -> Value -> Parser a
typeMismatch String
"IPv4" Value
v

instance FromJSONKey IPv4 where
    fromJSONKey :: FromJSONKeyFunction IPv4
fromJSONKey = (Text -> Parser IPv4) -> FromJSONKeyFunction IPv4
forall a. (Text -> Parser a) -> FromJSONKeyFunction a
FromJSONKeyTextParser ((Text -> Parser IPv4) -> FromJSONKeyFunction IPv4)
-> (Text -> Parser IPv4) -> FromJSONKeyFunction IPv4
forall a b. (a -> b) -> a -> b
$ \Text
t ->
                      case String -> Maybe IPv4
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
t) of
                          Just IPv4
r -> IPv4 -> Parser IPv4
forall (f :: * -> *) a. Applicative f => a -> f a
pure IPv4
r
                          Maybe IPv4
Nothing -> String -> Parser IPv4
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to parse IPv4"

-- | The @ToJSON@ instance produces JSON strings matching the @Show@ instance.
--
-- >>> toJSON (toIPv4 [127,0,0,1])
-- String "127.0.0.1"
instance ToJSON IPv4 where
    toJSON :: IPv4 -> Value
toJSON = Text -> Value
String (Text -> Value) -> (IPv4 -> Text) -> IPv4 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (IPv4 -> String) -> IPv4 -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPv4 -> String
forall a. Show a => a -> String
show

instance ToJSONKey IPv4 where
    toJSONKey :: ToJSONKeyFunction IPv4
toJSONKey = (IPv4 -> Text) -> ToJSONKeyFunction IPv4
forall a. (a -> Text) -> ToJSONKeyFunction a
toJSONKeyText (String -> Text
Text.pack (String -> Text) -> (IPv4 -> String) -> IPv4 -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPv4 -> String
forall a. Show a => a -> String
show)

instance FromJSON IPv6 where
    parseJSON :: Value -> Parser IPv6
parseJSON (String Text
s)
        | Just IPv6
r <- String -> Maybe IPv6
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
s) = IPv6 -> Parser IPv6
forall (f :: * -> *) a. Applicative f => a -> f a
pure IPv6
r
        | Bool
otherwise = String -> Parser IPv6
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to parse"
    parseJSON Value
v = String -> Value -> Parser IPv6
forall a. String -> Value -> Parser a
typeMismatch String
"IPv6" Value
v

instance FromJSONKey IPv6 where
    fromJSONKey :: FromJSONKeyFunction IPv6
fromJSONKey = (Text -> Parser IPv6) -> FromJSONKeyFunction IPv6
forall a. (Text -> Parser a) -> FromJSONKeyFunction a
FromJSONKeyTextParser ((Text -> Parser IPv6) -> FromJSONKeyFunction IPv6)
-> (Text -> Parser IPv6) -> FromJSONKeyFunction IPv6
forall a b. (a -> b) -> a -> b
$ \Text
t ->
                      case String -> Maybe IPv6
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
t) of
                          Just IPv6
r -> IPv6 -> Parser IPv6
forall (f :: * -> *) a. Applicative f => a -> f a
pure IPv6
r
                          Maybe IPv6
Nothing -> String -> Parser IPv6
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to parse IPv6"

-- | The @ToJSON@ instance produces JSON strings matching the @Show@ instance.
--
-- >>> toJSON (toIPv6 [0x2001,0xDB8,0,0,0,0,0,1])
-- String "2001:db8::1"
instance ToJSON IPv6 where
    toJSON :: IPv6 -> Value
toJSON = Text -> Value
String (Text -> Value) -> (IPv6 -> Text) -> IPv6 -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (IPv6 -> String) -> IPv6 -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPv6 -> String
forall a. Show a => a -> String
show

instance ToJSONKey IPv6 where
    toJSONKey :: ToJSONKeyFunction IPv6
toJSONKey = (IPv6 -> Text) -> ToJSONKeyFunction IPv6
forall a. (a -> Text) -> ToJSONKeyFunction a
toJSONKeyText (String -> Text
Text.pack (String -> Text) -> (IPv6 -> String) -> IPv6 -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPv6 -> String
forall a. Show a => a -> String
show)

instance FromJSON IP where
    parseJSON :: Value -> Parser IP
parseJSON (String Text
s)
        | Just IP
r <- String -> Maybe IP
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
s) = IP -> Parser IP
forall (f :: * -> *) a. Applicative f => a -> f a
pure IP
r
        | Bool
otherwise = String -> Parser IP
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to parse"
    parseJSON Value
v = String -> Value -> Parser IP
forall a. String -> Value -> Parser a
typeMismatch String
"IP" Value
v

instance FromJSONKey IP where
    fromJSONKey :: FromJSONKeyFunction IP
fromJSONKey = (Text -> Parser IP) -> FromJSONKeyFunction IP
forall a. (Text -> Parser a) -> FromJSONKeyFunction a
FromJSONKeyTextParser ((Text -> Parser IP) -> FromJSONKeyFunction IP)
-> (Text -> Parser IP) -> FromJSONKeyFunction IP
forall a b. (a -> b) -> a -> b
$ \Text
t ->
                      case String -> Maybe IP
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
t) of
                          Just IP
r -> IP -> Parser IP
forall (f :: * -> *) a. Applicative f => a -> f a
pure IP
r
                          Maybe IP
Nothing -> String -> Parser IP
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to parse IP"

instance ToJSON IP where
    toJSON :: IP -> Value
toJSON = Text -> Value
String (Text -> Value) -> (IP -> Text) -> IP -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (IP -> String) -> IP -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IP -> String
forall a. Show a => a -> String
show

instance ToJSONKey IP where
    toJSONKey :: ToJSONKeyFunction IP
toJSONKey = (IP -> Text) -> ToJSONKeyFunction IP
forall a. (a -> Text) -> ToJSONKeyFunction a
toJSONKeyText (String -> Text
Text.pack (String -> Text) -> (IP -> String) -> IP -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IP -> String
forall a. Show a => a -> String
show)

instance Read (AddrRange a) => FromJSON (AddrRange a) where
    parseJSON :: Value -> Parser (AddrRange a)
parseJSON (String Text
s)
        | Just AddrRange a
r <- String -> Maybe (AddrRange a)
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
s) = AddrRange a -> Parser (AddrRange a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure AddrRange a
r
        | Bool
otherwise = String -> Parser (AddrRange a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to parse"
    parseJSON Value
v = String -> Value -> Parser (AddrRange a)
forall a. String -> Value -> Parser a
typeMismatch String
"AddrRange" Value
v

instance Show a => ToJSON (AddrRange a) where
    toJSON :: AddrRange a -> Value
toJSON = Text -> Value
String (Text -> Value) -> (AddrRange a -> Text) -> AddrRange a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (AddrRange a -> String) -> AddrRange a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AddrRange a -> String
forall a. Show a => a -> String
show

instance FromJSON IPRange where
    parseJSON :: Value -> Parser IPRange
parseJSON (String Text
s)
        | Just IPRange
r <- String -> Maybe IPRange
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
s) = IPRange -> Parser IPRange
forall (f :: * -> *) a. Applicative f => a -> f a
pure IPRange
r
        | Bool
otherwise = String -> Parser IPRange
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to parse"
    parseJSON Value
v = String -> Value -> Parser IPRange
forall a. String -> Value -> Parser a
typeMismatch String
"IPRange" Value
v

instance ToJSON IPRange where
    toJSON :: IPRange -> Value
toJSON = Text -> Value
String (Text -> Value) -> (IPRange -> Text) -> IPRange -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (IPRange -> String) -> IPRange -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPRange -> String
forall a. Show a => a -> String
show

instance Read (AddrRange a) => FromJSONKey (AddrRange a) where
    fromJSONKey :: FromJSONKeyFunction (AddrRange a)
fromJSONKey = (Text -> Parser (AddrRange a)) -> FromJSONKeyFunction (AddrRange a)
forall a. (Text -> Parser a) -> FromJSONKeyFunction a
FromJSONKeyTextParser ((Text -> Parser (AddrRange a))
 -> FromJSONKeyFunction (AddrRange a))
-> (Text -> Parser (AddrRange a))
-> FromJSONKeyFunction (AddrRange a)
forall a b. (a -> b) -> a -> b
$ \Text
t ->
                      case String -> Maybe (AddrRange a)
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
t) of
                          Just AddrRange a
r -> AddrRange a -> Parser (AddrRange a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure AddrRange a
r
                          Maybe (AddrRange a)
Nothing -> String -> Parser (AddrRange a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to parse AddrRange"

instance Show a => ToJSONKey (AddrRange a) where
    toJSONKey :: ToJSONKeyFunction (AddrRange a)
toJSONKey = (AddrRange a -> Text) -> ToJSONKeyFunction (AddrRange a)
forall a. (a -> Text) -> ToJSONKeyFunction a
toJSONKeyText (String -> Text
Text.pack (String -> Text) -> (AddrRange a -> String) -> AddrRange a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AddrRange a -> String
forall a. Show a => a -> String
show)

instance FromJSONKey IPRange where
    fromJSONKey :: FromJSONKeyFunction IPRange
fromJSONKey = (Text -> Parser IPRange) -> FromJSONKeyFunction IPRange
forall a. (Text -> Parser a) -> FromJSONKeyFunction a
FromJSONKeyTextParser ((Text -> Parser IPRange) -> FromJSONKeyFunction IPRange)
-> (Text -> Parser IPRange) -> FromJSONKeyFunction IPRange
forall a b. (a -> b) -> a -> b
$ \Text
t ->
                      case String -> Maybe IPRange
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
Text.unpack Text
t) of
                          Just IPRange
r -> IPRange -> Parser IPRange
forall (f :: * -> *) a. Applicative f => a -> f a
pure IPRange
r
                          Maybe IPRange
Nothing -> String -> Parser IPRange
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unable to parse IPRange"

instance ToJSONKey IPRange where
    toJSONKey :: ToJSONKeyFunction IPRange
toJSONKey = (IPRange -> Text) -> ToJSONKeyFunction IPRange
forall a. (a -> Text) -> ToJSONKeyFunction a
toJSONKeyText (String -> Text
Text.pack (String -> Text) -> (IPRange -> String) -> IPRange -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPRange -> String
forall a. Show a => a -> String
show)

instance ( FromJSONKey k
         , Read (AddrRange k)
         , Routable k
         ) => FromJSON1 (IPRTable k) where
    liftParseJSON :: (Value -> Parser a)
-> (Value -> Parser [a]) -> Value -> Parser (IPRTable k a)
liftParseJSON Value -> Parser a
p Value -> Parser [a]
_ = case FromJSONKeyFunction (AddrRange k)
forall a. FromJSONKey a => FromJSONKeyFunction a
fromJSONKey of
        FromJSONKeyTextParser Text -> Parser (AddrRange k)
f -> String
-> (Object -> Parser (IPRTable k a))
-> Value
-> Parser (IPRTable k a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"IPRTable k v" ((Object -> Parser (IPRTable k a))
 -> Value -> Parser (IPRTable k a))
-> (Object -> Parser (IPRTable k a))
-> Value
-> Parser (IPRTable k a)
forall a b. (a -> b) -> a -> b
$
            (Key -> Value -> Parser (IPRTable k a) -> Parser (IPRTable k a))
-> Parser (IPRTable k a) -> Object -> Parser (IPRTable k a)
forall v a. (Key -> v -> a -> a) -> a -> KeyMap v -> a
KeyMap.foldrWithKey
                (\Key
k Value
v Parser (IPRTable k a)
rt -> AddrRange k -> a -> IPRTable k a -> IPRTable k a
forall k a.
Routable k =>
AddrRange k -> a -> IPRTable k a -> IPRTable k a
RouteTable.insert (AddrRange k -> a -> IPRTable k a -> IPRTable k a)
-> Parser (AddrRange k)
-> Parser (a -> IPRTable k a -> IPRTable k a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Parser (AddrRange k)
f (Key -> Text
Key.toText Key
k) Parser (AddrRange k) -> JSONPathElement -> Parser (AddrRange k)
forall a. Parser a -> JSONPathElement -> Parser a
<?> Key -> JSONPathElement
Key Key
k
                                              Parser (a -> IPRTable k a -> IPRTable k a)
-> Parser a -> Parser (IPRTable k a -> IPRTable k a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Parser a
p Value
v Parser a -> JSONPathElement -> Parser a
forall a. Parser a -> JSONPathElement -> Parser a
<?> Key -> JSONPathElement
Key Key
k
                                              Parser (IPRTable k a -> IPRTable k a)
-> Parser (IPRTable k a) -> Parser (IPRTable k a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (IPRTable k a)
rt)
                (IPRTable k a -> Parser (IPRTable k a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure IPRTable k a
forall k a. Routable k => IPRTable k a
RouteTable.empty)
        FromJSONKeyFunction (AddrRange k)
_ -> \Value
_ -> String -> Parser (IPRTable k a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"using IPRTable in this context is not yet supported"

instance ( FromJSONKey k
         , Read (AddrRange k)
         , Routable k
         , FromJSON v
         ) => FromJSON (IPRTable k v) where
    parseJSON :: Value -> Parser (IPRTable k v)
parseJSON = Value -> Parser (IPRTable k v)
forall (f :: * -> *) a.
(FromJSON1 f, FromJSON a) =>
Value -> Parser (f a)
parseJSON1

instance (Routable k, Show k, ToJSON k) => ToJSON1 (IPRTable k) where
    liftToJSON :: (a -> Value) -> ([a] -> Value) -> IPRTable k a -> Value
liftToJSON a -> Value
g [a] -> Value
_ = case ToJSONKeyFunction (AddrRange k)
forall a. ToJSONKey a => ToJSONKeyFunction a
toJSONKey of
        ToJSONKeyText AddrRange k -> Key
f AddrRange k -> Encoding' Key
_ -> Object -> Value
Object (Object -> Value)
-> (IPRTable k a -> Object) -> IPRTable k a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KeyMap.fromList
                                    ([(Key, Value)] -> Object)
-> (IPRTable k a -> [(Key, Value)]) -> IPRTable k a -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((AddrRange k, a) -> (Key, Value))
-> [(AddrRange k, a)] -> [(Key, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (\(AddrRange k
k, a
v) -> (AddrRange k -> Key
f AddrRange k
k, a -> Value
g a
v))
                                    ([(AddrRange k, a)] -> [(Key, Value)])
-> (IPRTable k a -> [(AddrRange k, a)])
-> IPRTable k a
-> [(Key, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPRTable k a -> [(AddrRange k, a)]
forall k a. Routable k => IPRTable k a -> [(AddrRange k, a)]
RouteTable.toList
        ToJSONKeyFunction (AddrRange k)
_ -> String -> IPRTable k a -> Value
forall a. HasCallStack => String -> a
error String
"using IPRTable as a JSON key is not yet supported"

instance (Routable k, Show k, ToJSON k, ToJSON v) => ToJSON (IPRTable k v) where
    toJSON :: IPRTable k v -> Value
toJSON = IPRTable k v -> Value
forall (f :: * -> *) a. (ToJSON1 f, ToJSON a) => f a -> Value
toJSON1