{-# LANGUAGE CPP #-}
module Push where
import Data.Aeson ((.=))
import qualified Data.Aeson as A
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as B
import qualified Data.HashMap.Strict as HM
import Data.Maybe (fromJust)
#if !(MIN_VERSION_base(4,11,0))
import Data.Monoid ((<>))
#endif
import Data.Scientific
import qualified Data.Text as T
import qualified Data.Vector as V
import Test.Hspec (Spec, describe, it)
import Test.QuickCheck
(Arbitrary(..), Gen, elements, oneof, property, vectorOf)
import Network.Pusher
test :: Spec
test = do
describe "Interest names" $ do
it "are accepted when using valid characters" $
property $ do
txt <- arbitraryInterestText
return $
case mkInterest txt of
Nothing -> False
Just _ -> True
it "are rejected when using invalid characters" $
property $ do
txt <- arbitraryInvalidInterestText
return $
case mkInterest txt of
Nothing -> True
Just _ -> False
describe "Notification JSON parser" $ do
it "correctly parses a specific FCM Notification." $
property $
let (inputBS, expected) = validFCMDecoding
in A.decode inputBS == Just expected
it "Random Notifications JSON parses correctly" $
property $ \(NotificationDecoding (bs, notification)) ->
A.decode bs == Just notification
describe "Notification JSON encoder" $ do
it "encodes a specific FCM Notification correctly" $
property $
let (bs, notification) = validFCMDecoding
in (A.encode notification) ==
(A.encode . fromJust . (A.decode :: ByteString -> Maybe Notification) $
bs)
it "encodes random Notifications correctly" $
-- NOTE: We put the expected string through a round trip to normalise trivial
-- differences such as ordering and spacing in the JSON Aeson generates
property $ \(NotificationDecoding (bs, notification)) ->
(A.encode notification) ==
(A.encode . fromJust . (A.decode :: ByteString -> Maybe Notification) $
bs)
-- A single example of a FCM notification which we expect to aeson decode to
-- the paired Notification value.
validFCMDecoding :: (B.ByteString, Notification)
validFCMDecoding =
let bs =
B.unlines
[ "{"
, " \"interests\": [\"interestOne\"],"
, " \"fcm\": {"
, " \"notification\": {"
, " \"title\": \"titleText\","
, " \"body\": \"bodyText\""
, " }"
, " }"
, "}"
]
notification =
Notification
{ notificationInterest = fromJust . mkInterest $ "interestOne"
, notificationWebhookURL = Nothing
, notificationWebhookLevel = Nothing
, notificationAPNSPayload = Nothing
, notificationGCMPayload = Nothing
, notificationFCMPayload =
Just $
FCMPayload $
HM.fromList
[ ("notification" :: T.Text) .=
(A.Object $
HM.fromList
[ ("title" :: T.Text) .= ("titleText" :: T.Text)
, ("body" :: T.Text) .= ("bodyText" :: T.Text)
])
]
}
in (bs, notification)
-- A ByteString will decode to some value 'a'.
type Decoding a = (B.ByteString, a)
newtype NotificationDecoding =
NotificationDecoding (Decoding Notification)
deriving (Show)
newtype APNSDecoding =
APNSDecoding (Decoding (Maybe APNSPayload))
newtype FCMDecoding =
FCMDecoding (Decoding (Maybe FCMPayload))
newtype GCMDecoding =
GCMDecoding (Decoding (Maybe GCMPayload))
instance Arbitrary APNSDecoding where
arbitrary = do
InterestText titleText <- arbitrary
InterestText bodyText <- arbitrary
NonRecJSON dataJSON <- arbitrary
let alert :: A.Object
alert = HM.fromList ["title" .= titleText, "body" .= bodyText]
aps :: A.Object
aps = HM.fromList ["alert" .= alert]
payload :: A.Object
payload = HM.fromList ["aps" .= aps, "data" .= dataJSON]
let apns = APNSPayload payload
bs :: ByteString
bs =
B.unlines
[ "{"
, " \"aps\": {"
, " \"alert\": {"
, " \"title\": \"" <> (B.pack . T.unpack $ titleText) <> "\","
, " \"body\": \"" <> (B.pack . T.unpack $ bodyText) <> "\""
, " }"
, " },"
, " \"data\": " <> (A.encode dataJSON)
, "}"
]
return $ APNSDecoding (bs, Just apns)
instance Arbitrary GCMDecoding where
arbitrary = do
InterestText titleText <- arbitrary
InterestText bodyText <- arbitrary
NonRecJSON dataJSON <- arbitrary
let notification :: A.Object
notification = HM.fromList ["title" .= titleText, "body" .= bodyText]
payload :: A.Object
payload =
HM.fromList ["notification" .= notification, "data" .= dataJSON]
gcm = GCMPayload payload
bs :: ByteString
bs =
B.unlines
[ "{"
, " \"notification\": {"
, " \"title\": \"" <> (B.pack . T.unpack $ titleText) <> "\","
, " \"body\": \"" <> (B.pack . T.unpack $ bodyText) <> "\""
, " },"
, " \"data\": " <> (A.encode dataJSON)
, "}"
]
return $ GCMDecoding (bs, Just gcm)
instance Arbitrary FCMDecoding where
arbitrary = do
InterestText titleText <- arbitrary
InterestText bodyText <- arbitrary
NonRecJSON dataJSON <- arbitrary
let notification :: A.Object
notification = HM.fromList ["title" .= titleText, "body" .= bodyText]
payload :: A.Object
payload =
HM.fromList ["notification" .= notification, "data" .= dataJSON]
gcm = FCMPayload payload
bs :: ByteString
bs =
B.unlines
[ "{"
, " \"notification\": {"
, " \"title\": \"" <> (B.pack . T.unpack $ titleText) <> "\","
, " \"body\": \"" <> (B.pack . T.unpack $ bodyText) <> "\""
, " },"
, " \"data\": " <> (A.encode dataJSON)
, "}"
]
return $ FCMDecoding (bs, Just gcm)
instance Arbitrary NotificationDecoding where
arbitrary = do
interestName <- arbitraryInterestText
APNSDecoding (apnsBS, mAPNS) <- arbitrary
GCMDecoding (gcmBS, mGCM) <- arbitrary
FCMDecoding (fcmBS, mFCM) <- arbitrary
let notification =
Notification
{ notificationInterest = fromJust . mkInterest $ interestName
, notificationWebhookURL = Nothing
, notificationWebhookLevel = Nothing
, notificationAPNSPayload = mAPNS
, notificationGCMPayload = mGCM
, notificationFCMPayload = mFCM
}
-- Key value pairs that are required
requiredFields :: [(ByteString, ByteString)]
requiredFields =
[("interests", "[\"" <> (B.pack . T.unpack $ interestName) <> "\"]")]
-- A function which takes an initial key value pair list and adds Just pairs and skips Nothing values.
-- Aeson would by default encode this as "value":null which we dont want.
consOptionals ::
[(ByteString, ByteString)] -> [(ByteString, ByteString)]
consOptionals =
consJust "apns" (nullToMaybe apnsBS) .
consJust "fcm" (nullToMaybe fcmBS) .
consJust "gcm" (nullToMaybe gcmBS)
fields :: [(ByteString, ByteString)]
fields = consOptionals requiredFields
bs :: B.ByteString
bs =
(\acc -> "{" <> acc <> "}") .
B.intercalate "," . map (\(k, v) -> "\"" <> k <> "\": " <> v) $
fields
return $ NotificationDecoding (bs, notification)
-- Cons an attribute value pair if Just
where
consJust ::
ByteString
-> Maybe ByteString
-> [(ByteString, ByteString)]
-> [(ByteString, ByteString)]
consJust attr = maybe id (\val rest -> (attr, val) : rest)
-- Empty ByteStrings become null
nullToMaybe :: B.ByteString -> Maybe B.ByteString
nullToMaybe bs
| B.null bs = Nothing
| otherwise = Just bs
-- Valid interest names
arbitraryInterestText :: Gen T.Text
arbitraryInterestText = do
n <- elements [1 .. 164]
str <-
vectorOf n $
elements $
concat
[['a' .. 'z'], ['A' .. 'Z'], ['0' .. '1'], ['_', '=', '@', ',', '.', ';']]
return . T.pack $ str
-- Invalid interest names
arbitraryInvalidInterestText :: Gen T.Text
arbitraryInvalidInterestText =
T.pack <$>
oneof
[tooLargeInterestText, tooSmallInterestText, invalidCharactersInterestText]
where
tooLargeInterestText = do
n <- elements [165 .. 265]
vectorOf n $
elements $
concat
[ ['a' .. 'z']
, ['A' .. 'Z']
, ['0' .. '1']
, ['_', '=', '@', ',', '.', ';']
]
tooSmallInterestText = return ""
invalidCharactersInterestText = do
n <- elements [1 .. 165]
vectorOf n $ elements "!\"£$%^&*()+}{~:?><¬` `}\""
-- JSON but with no nested objects or nested arrays to make generating arbitrary
-- structures simpler. A better solution would be to used 'sized' or similar to
-- limit the size.
newtype NonRecJSON =
NonRecJSON A.Value
instance Arbitrary NonRecJSON where
arbitrary =
NonRecJSON <$>
oneof [arbitraryJSONPrimitives, arbitraryObject, arbitraryArray]
where
arbitraryObject = A.Object . _unNonRecObject <$> arbitrary
arbitraryArray = A.Array . _unNonRecArray <$> arbitrary
-- Strings, numbers, bools and null. No arrays or objects
arbitraryJSONPrimitives :: Gen A.Value
arbitraryJSONPrimitives =
oneof [arbitraryString, arbitraryNumber, arbitraryBool, arbitraryNull]
where
arbitraryString = A.String . _unInterestText <$> arbitrary
arbitraryNumber = A.Number . _unOurNumber <$> arbitrary
arbitraryBool = A.Bool <$> arbitrary
arbitraryNull = pure A.Null
-- Valid interest text has a certain size and character set although we use
-- this as a general source of 'safe' random text elsewhere.
newtype InterestText = InterestText
{ _unInterestText :: T.Text
}
instance Arbitrary InterestText where
arbitrary =
InterestText <$> do
n <- elements [1 .. 164]
str <-
vectorOf n $
elements $
concat
[ ['a' .. 'z']
, ['A' .. 'Z']
, ['0' .. '1']
, ['_', '=', '@', ',', '.', ';']
]
return . T.pack $ str
-- The internal type of JSON objects is hashmap of text keys to values.
-- We only nest primitives.
newtype NonRecObject = NonRecObject
{ _unNonRecObject :: HM.HashMap T.Text A.Value
}
instance Arbitrary NonRecObject where
arbitrary =
NonRecObject <$> do
o <-
vectorOf 10 $ do
InterestText k <- arbitrary
v <- arbitraryJSONPrimitives
return (k, v)
return . HM.fromList $ o
-- The internal type of JSON arrays is a Vector of values.
-- We only nest primitives.
newtype NonRecArray = NonRecArray
{ _unNonRecArray :: V.Vector A.Value
}
instance Arbitrary NonRecArray where
arbitrary =
NonRecArray <$> do
xs <- vectorOf 10 arbitraryJSONPrimitives
return . V.fromList $ xs
-- The internal type of JSON numbers is a Scientific number.
-- We generate arbitrary values with the 'scientific' function.
newtype OurNumber = OurNumber
{ _unOurNumber :: Scientific
}
instance Arbitrary OurNumber where
arbitrary = OurNumber <$> (scientific <$> arbitrary <*> arbitrary)