{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Simplex.Messaging.Parsers where

import Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Bifunctor (first)
import Data.ByteString.Base64
import qualified Data.ByteString.Base64.URL as U
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.Char (isAlphaNum)
import Data.Time.Clock (UTCTime)
import Data.Time.ISO8601 (parseISO8601)
import Data.Typeable (Typeable)
import Database.SQLite.Simple (ResultError (..), SQLData (..))
import Database.SQLite.Simple.FromField (FieldParser, returnError)
import Database.SQLite.Simple.Internal (Field (..))
import Database.SQLite.Simple.Ok (Ok (Ok))
import Simplex.Messaging.Util ((<$?>))
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
base64StringP

base64StringP :: Parser ByteString
base64StringP :: Parser ByteString
base64StringP = Parser ByteString -> Parser ByteString
paddedBase64 Parser ByteString
rawBase64P

base64UriP :: Parser ByteString
base64UriP :: Parser ByteString
base64UriP = ByteString -> Either String ByteString
U.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
base64UriStringP

base64UriStringP :: Parser ByteString
base64UriStringP :: Parser ByteString
base64UriStringP = Parser ByteString -> Parser ByteString
paddedBase64 Parser ByteString
rawBase64UriP

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 (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 :: Parser ByteString
rawBase64UriP = (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
'_')

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 (m :: * -> *) a. MonadFail m => String -> m a
fail String
"timestamp") UTCTime -> Parser UTCTime
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 :: Parser a -> e -> ByteString -> Either e a
parse Parser a
parser e
err = (String -> e) -> Either String a -> Either e a
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 :: 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 (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
forall t. Chunk t => Parser t ()
A.endOfInput)

parseRead :: Read a => Parser ByteString -> Parser a
parseRead :: Parser ByteString -> Parser a
parseRead = (Parser ByteString -> (ByteString -> Parser a) -> Parser a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser a -> (a -> Parser a) -> Maybe a -> Parser a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"cannot read") a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> Parser a)
-> (ByteString -> Maybe a) -> ByteString -> Parser 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 :: 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 :: 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 (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 (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'

parseString :: (ByteString -> Either String a) -> (String -> a)
parseString :: (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

blobFieldParser :: Typeable k => Parser k -> FieldParser k
blobFieldParser :: Parser k -> FieldParser k
blobFieldParser Parser k
p = \case
  f :: Field
f@(Field (SQLBlob ByteString
b) Int
_) ->
    case Parser k -> ByteString -> Either String k
forall a. Parser a -> ByteString -> Either String a
parseAll Parser k
p ByteString
b of
      Right k
k -> k -> Ok k
forall a. a -> Ok a
Ok k
k
      Left String
e -> (String -> String -> String -> ResultError)
-> Field -> String -> Ok k
forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
returnError String -> String -> String -> ResultError
ConversionFailed Field
f (String
"couldn't parse field: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e)
  Field
f -> (String -> String -> String -> ResultError)
-> Field -> String -> Ok k
forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
returnError String -> String -> String -> ResultError
ConversionFailed Field
f String
"expecting SQLBlob column type"