{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}

module Simplex.Messaging.Parsers
  ( base64P,
    parse,
    parseAll,
    parseE,
    parseE',
    parseRead1,
    parseString,
    fstToLower,
    dropPrefix,
    enumJSON,
    sumTypeJSON,
    taggedObjectJSON,
    singleFieldJSON,
    singleFieldJSON_,
    defaultJSON,
    textP,
    pattern SingleFieldJSONTag,
    pattern TaggedObjectJSONTag,
    pattern TaggedObjectJSONData,
  ) where

import Control.Monad.Trans.Except
import qualified Data.Aeson as J
import Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Bifunctor (first)
import Data.ByteString.Base64
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Char (isAlphaNum, toLower)
import Data.String
import qualified Data.Text as T
import Data.Time.Clock (UTCTime)
import Data.Time.ISO8601 (parseISO8601)
import Simplex.Messaging.Util (safeDecodeUtf8, (<$?>))
import Text.Read (readMaybe)

base64P :: Parser ByteString
base64P :: Parser ByteString
base64P = ByteString -> Either String ByteString
decode (ByteString -> Either String ByteString)
-> Parser ByteString -> Parser ByteString
forall (m :: * -> *) a b.
MonadFail m =>
(a -> Either String b) -> m a -> m b
<$?> Parser ByteString -> Parser ByteString
paddedBase64 Parser ByteString
rawBase64P

paddedBase64 :: Parser ByteString -> Parser ByteString
paddedBase64 :: Parser ByteString -> Parser ByteString
paddedBase64 Parser ByteString
raw = ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
(<>) (ByteString -> ByteString -> ByteString)
-> Parser ByteString
-> Parser ByteString (ByteString -> ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
raw Parser ByteString (ByteString -> ByteString)
-> Parser ByteString -> Parser ByteString
forall a b.
Parser ByteString (a -> b)
-> Parser ByteString a -> Parser ByteString b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString
pad
  where
    pad :: Parser ByteString
pad = (Char -> Bool) -> Parser ByteString
A.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=')

rawBase64P :: Parser ByteString
rawBase64P :: Parser ByteString
rawBase64P = (Char -> Bool) -> Parser ByteString
A.takeWhile1 (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'+' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/')

-- rawBase64UriP :: Parser ByteString
-- rawBase64UriP = A.takeWhile1 (\c -> isAlphaNum c || c == '-' || c == '_')

tsISO8601P :: Parser UTCTime
tsISO8601P :: Parser UTCTime
tsISO8601P = Parser UTCTime
-> (UTCTime -> Parser UTCTime) -> Maybe UTCTime -> Parser UTCTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser UTCTime
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"timestamp") UTCTime -> Parser UTCTime
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe UTCTime -> Parser UTCTime)
-> (ByteString -> Maybe UTCTime) -> ByteString -> Parser UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe UTCTime
parseISO8601 (String -> Maybe UTCTime)
-> (ByteString -> String) -> ByteString -> Maybe UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack (ByteString -> Parser UTCTime)
-> Parser ByteString -> Parser UTCTime
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Char -> Bool) -> Parser ByteString
A.takeTill Char -> Bool
wordEnd

parse :: Parser a -> e -> (ByteString -> Either e a)
parse :: forall a e. Parser a -> e -> ByteString -> Either e a
parse Parser a
parser e
err = (String -> e) -> Either String a -> Either e a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (e -> String -> e
forall a b. a -> b -> a
const e
err) (Either String a -> Either e a)
-> (ByteString -> Either String a) -> ByteString -> Either e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a -> ByteString -> Either String a
forall a. Parser a -> ByteString -> Either String a
parseAll Parser a
parser

parseAll :: Parser a -> (ByteString -> Either String a)
parseAll :: forall a. Parser a -> ByteString -> Either String a
parseAll Parser a
parser = Parser a -> ByteString -> Either String a
forall a. Parser a -> ByteString -> Either String a
A.parseOnly (Parser a
parser Parser a -> Parser ByteString () -> Parser a
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
A.endOfInput)

parseE :: (String -> e) -> Parser a -> (ByteString -> ExceptT e IO a)
parseE :: forall e a.
(String -> e) -> Parser a -> ByteString -> ExceptT e IO a
parseE String -> e
err Parser a
parser = Either e a -> ExceptT e IO a
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either e a -> ExceptT e IO a)
-> (ByteString -> Either e a) -> ByteString -> ExceptT e IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> e) -> Either String a -> Either e a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> e
err (Either String a -> Either e a)
-> (ByteString -> Either String a) -> ByteString -> Either e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a -> ByteString -> Either String a
forall a. Parser a -> ByteString -> Either String a
parseAll Parser a
parser

parseE' :: (String -> e) -> Parser a -> (ByteString -> ExceptT e IO a)
parseE' :: forall e a.
(String -> e) -> Parser a -> ByteString -> ExceptT e IO a
parseE' String -> e
err Parser a
parser = Either e a -> ExceptT e IO a
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either e a -> ExceptT e IO a)
-> (ByteString -> Either e a) -> ByteString -> ExceptT e IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> e) -> Either String a -> Either e a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> e
err (Either String a -> Either e a)
-> (ByteString -> Either String a) -> ByteString -> Either e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser a -> ByteString -> Either String a
forall a. Parser a -> ByteString -> Either String a
A.parseOnly Parser a
parser

parseRead :: Read a => Parser ByteString -> Parser a
parseRead :: forall a. Read a => Parser ByteString -> Parser a
parseRead = (Parser ByteString
-> (ByteString -> Parser ByteString a) -> Parser ByteString a
forall a b.
Parser ByteString a
-> (a -> Parser ByteString b) -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser ByteString a
-> (a -> Parser ByteString a) -> Maybe a -> Parser ByteString a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser ByteString a
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"cannot read") a -> Parser ByteString a
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> Parser ByteString a)
-> (ByteString -> Maybe a) -> ByteString -> Parser ByteString a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe a)
-> (ByteString -> String) -> ByteString -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack)

parseRead1 :: Read a => Parser a
parseRead1 :: forall a. Read a => Parser a
parseRead1 = Parser ByteString -> Parser a
forall a. Read a => Parser ByteString -> Parser a
parseRead (Parser ByteString -> Parser a) -> Parser ByteString -> Parser a
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Parser ByteString
A.takeTill Char -> Bool
wordEnd

parseRead2 :: Read a => Parser a
parseRead2 :: forall a. Read a => Parser a
parseRead2 = Parser ByteString -> Parser a
forall a. Read a => Parser ByteString -> Parser a
parseRead (Parser ByteString -> Parser a) -> Parser ByteString -> Parser a
forall a b. (a -> b) -> a -> b
$ do
  ByteString
w1 <- (Char -> Bool) -> Parser ByteString
A.takeTill Char -> Bool
wordEnd Parser ByteString -> Parser ByteString Char -> Parser ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
A.char Char
' '
  ByteString
w2 <- (Char -> Bool) -> Parser ByteString
A.takeTill Char -> Bool
wordEnd
  ByteString -> Parser ByteString
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Parser ByteString)
-> ByteString -> Parser ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
w1 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
" " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
w2

wordEnd :: Char -> Bool
wordEnd :: Char -> Bool
wordEnd Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n'
{-# INLINE wordEnd #-}

parseString :: (ByteString -> Either String a) -> (String -> a)
parseString :: forall a. (ByteString -> Either String a) -> String -> a
parseString ByteString -> Either String a
p = (String -> a) -> (a -> a) -> Either String a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> a
forall a. HasCallStack => String -> a
error a -> a
forall a. a -> a
id (Either String a -> a)
-> (String -> Either String a) -> String -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String a
p (ByteString -> Either String a)
-> (String -> ByteString) -> String -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
B.pack

fstToLower :: String -> String
fstToLower :: String -> String
fstToLower String
"" = String
""
fstToLower (Char
h : String
t) = Char -> Char
toLower Char
h Char -> String -> String
forall a. a -> [a] -> [a]
: String
t

dropPrefix :: String -> String -> String
dropPrefix :: String -> String -> String
dropPrefix String
pfx String
s =
  let (String
p, String
rest) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
pfx) String
s
   in String -> String
fstToLower (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ if String
p String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
pfx then String
rest else String
s

enumJSON :: (String -> String) -> J.Options
enumJSON :: (String -> String) -> Options
enumJSON String -> String
tagModifier =
  Options
J.defaultOptions
    { J.constructorTagModifier = tagModifier,
      J.allNullaryToStringTag = True
    }

-- used in platform-specific encoding, includes tag for single-field encoding of sum types to allow conversion to tagged objects
sumTypeJSON :: (String -> String) -> J.Options
#if defined(darwin_HOST_OS) && defined(swiftJSON)
sumTypeJSON = singleFieldJSON_ $ Just SingleFieldJSONTag
#else
sumTypeJSON :: (String -> String) -> Options
sumTypeJSON = (String -> String) -> Options
taggedObjectJSON
#endif

pattern SingleFieldJSONTag :: (Eq a, IsString a) => a
pattern $mSingleFieldJSONTag :: forall {r} {a}.
(Eq a, IsString a) =>
a -> ((# #) -> r) -> ((# #) -> r) -> r
$bSingleFieldJSONTag :: forall a. (Eq a, IsString a) => a
SingleFieldJSONTag = "_owsf"

taggedObjectJSON :: (String -> String) -> J.Options
taggedObjectJSON :: (String -> String) -> Options
taggedObjectJSON String -> String
tagModifier =
  Options
J.defaultOptions
    { J.sumEncoding = J.TaggedObject TaggedObjectJSONTag TaggedObjectJSONData,
      J.tagSingleConstructors = True,
      J.constructorTagModifier = tagModifier,
      J.allNullaryToStringTag = False,
      J.nullaryToObject = True,
      J.omitNothingFields = True
    }

pattern TaggedObjectJSONTag :: (Eq a, IsString a) => a
pattern $mTaggedObjectJSONTag :: forall {r} {a}.
(Eq a, IsString a) =>
a -> ((# #) -> r) -> ((# #) -> r) -> r
$bTaggedObjectJSONTag :: forall a. (Eq a, IsString a) => a
TaggedObjectJSONTag = "type"

pattern TaggedObjectJSONData :: (Eq a, IsString a) => a
pattern $mTaggedObjectJSONData :: forall {r} {a}.
(Eq a, IsString a) =>
a -> ((# #) -> r) -> ((# #) -> r) -> r
$bTaggedObjectJSONData :: forall a. (Eq a, IsString a) => a
TaggedObjectJSONData = "data"

-- used in platform independent encoding, doesn't include tag for single-field encoding of sum types
singleFieldJSON :: (String -> String) -> J.Options
singleFieldJSON :: (String -> String) -> Options
singleFieldJSON = Maybe String -> (String -> String) -> Options
singleFieldJSON_ Maybe String
forall a. Maybe a
Nothing

singleFieldJSON_ :: Maybe String -> (String -> String) -> J.Options
singleFieldJSON_ :: Maybe String -> (String -> String) -> Options
singleFieldJSON_ Maybe String
objectTag String -> String
tagModifier =
  Options
J.defaultOptions
    { J.sumEncoding = J.ObjectWithSingleField objectTag,
      J.tagSingleConstructors = True,
      J.constructorTagModifier = tagModifier,
      J.allNullaryToStringTag = False,
      J.nullaryToObject = True,
      J.omitNothingFields = True
    }

defaultJSON :: J.Options
defaultJSON :: Options
defaultJSON = Options
J.defaultOptions {J.omitNothingFields = True}

textP :: Parser String
textP :: Parser String
textP = Text -> String
T.unpack (Text -> String) -> (ByteString -> Text) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
safeDecodeUtf8 (ByteString -> String) -> Parser ByteString -> Parser String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
A.takeByteString