{-# 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 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 = do
  ByteString
str <- (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
'/')
  ByteString
pad <- (Char -> Bool) -> Parser ByteString
A.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=')
  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
str ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
pad

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 -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')

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 -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')

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 -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') 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 -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ')
  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

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"