module Okapi.HTTP.RFC9651.BareItem (
    BareItem,
    renderInner,
    parseInnerToList,
) where

import Data.ByteString (ByteString)
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BS8
import Data.Scientific (FPFormat (Fixed), Scientific, formatScientific, toRealFloat)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8Lenient, encodeUtf8)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime, utcTimeToPOSIXSeconds)
import Okapi.Tree (Failure, HasLeaf (..), Info (..), Leaf (..), Piece)
import Okapi.HTTP.RFC9651.Lexer (ParseError (..), eParse, parseInnerBare, strip)

data BareItem a

type instance Piece BareItem = ByteString
type instance Failure BareItem = ParseError

bareLeaf :: (ByteString -> Either Text a) -> (a -> ByteString) -> Info -> Leaf BareItem a
bareLeaf :: forall a.
(ByteString -> Either Text a)
-> (a -> ByteString) -> Info -> Leaf BareItem a
bareLeaf ByteString -> Either Text a
dec a -> ByteString
enc Info
nfo = (Piece BareItem -> Either (Failure BareItem) a)
-> (a -> Piece BareItem) -> Info -> Leaf BareItem a
forall (t :: * -> *) a.
(Piece t -> Either (Failure t) a)
-> (a -> Piece t) -> Info -> Leaf t a
Leaf (Either Text a -> Either ParseError a
forall e a. Either e a -> Either ParseError a
eParse (Either Text a -> Either ParseError a)
-> (ByteString -> Either Text a)
-> ByteString
-> Either ParseError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text a
dec) a -> ByteString
a -> Piece BareItem
enc Info
nfo

decInteger :: ByteString -> Either Text Integer
decInteger :: ByteString -> Either Text Integer
decInteger ByteString
bs = case ByteString -> Maybe (Integer, ByteString)
BS8.readInteger ByteString
bs of
    Just (Integer
n, ByteString
r) | ByteString -> Bool
BS.null ByteString
r -> Integer -> Either Text Integer
forall a b. b -> Either a b
Right Integer
n
    Maybe (Integer, ByteString)
_ -> Text -> Either Text Integer
forall a b. a -> Either a b
Left (Text
"invalid sf-integer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
decodeUtf8Lenient ByteString
bs)

instance HasLeaf BareItem Integer where
    leaf :: Leaf BareItem Integer
leaf = (ByteString -> Either Text Integer)
-> (Integer -> ByteString) -> Info -> Leaf BareItem Integer
forall a.
(ByteString -> Either Text a)
-> (a -> ByteString) -> Info -> Leaf BareItem a
bareLeaf ByteString -> Either Text Integer
decInteger (String -> ByteString
BS8.pack (String -> ByteString)
-> (Integer -> String) -> Integer -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show) (Text -> Maybe Text -> Info
Info Text
"integer" Maybe Text
forall a. Maybe a
Nothing)

instance HasLeaf BareItem Int where
    leaf :: Leaf BareItem Int
leaf = (ByteString -> Either Text Int)
-> (Int -> ByteString) -> Info -> Leaf BareItem Int
forall a.
(ByteString -> Either Text a)
-> (a -> ByteString) -> Info -> Leaf BareItem a
bareLeaf ((Integer -> Int) -> Either Text Integer -> Either Text Int
forall a b. (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Either Text Integer -> Either Text Int)
-> (ByteString -> Either Text Integer)
-> ByteString
-> Either Text Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text Integer
decInteger) (String -> ByteString
BS8.pack (String -> ByteString) -> (Int -> String) -> Int -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) (Text -> Maybe Text -> Info
Info Text
"integer" Maybe Text
forall a. Maybe a
Nothing)

instance HasLeaf BareItem Bool where
    leaf :: Leaf BareItem Bool
leaf = (ByteString -> Either Text Bool)
-> (Bool -> ByteString) -> Info -> Leaf BareItem Bool
forall a.
(ByteString -> Either Text a)
-> (a -> ByteString) -> Info -> Leaf BareItem a
bareLeaf ByteString -> Either Text Bool
dec Bool -> ByteString
forall {a}. IsString a => Bool -> a
enc (Text -> Maybe Text -> Info
Info Text
"boolean" Maybe Text
forall a. Maybe a
Nothing)
      where
        enc :: Bool -> a
enc Bool
True  = a
"?1"
        enc Bool
False = a
"?0"
        dec :: ByteString -> Either Text Bool
dec ByteString
"?1"  = Bool -> Either Text Bool
forall a b. b -> Either a b
Right Bool
True
        dec ByteString
"?0"  = Bool -> Either Text Bool
forall a b. b -> Either a b
Right Bool
False
        dec ByteString
bs    = Text -> Either Text Bool
forall a b. a -> Either a b
Left (Text
"invalid sf-boolean: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
decodeUtf8Lenient ByteString
bs)

escapeSfString :: ByteString -> ByteString
escapeSfString :: ByteString -> ByteString
escapeSfString = (Word8 -> ByteString) -> ByteString -> ByteString
BS.concatMap Word8 -> ByteString
esc
  where
    esc :: Word8 -> ByteString
esc Word8
34 = ByteString
"\\\""
    esc Word8
92 = ByteString
"\\\\"
    esc Word8
w  = Word8 -> ByteString
BS.singleton Word8
w

parseSfString :: ByteString -> Either Text Text
parseSfString :: ByteString -> Either Text Text
parseSfString ByteString
bs = case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
bs of
    Just (Word8
34, ByteString
rest) -> ByteString -> ByteString -> Either Text Text
forall {a}. IsString a => ByteString -> ByteString -> Either a Text
go ByteString
rest ByteString
forall a. Monoid a => a
mempty
    Maybe (Word8, ByteString)
_ -> Text -> Either Text Text
forall a b. a -> Either a b
Left (Text
"invalid sf-string (no opening quote): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
decodeUtf8Lenient ByteString
bs)
  where
    go :: ByteString -> ByteString -> Either a Text
go ByteString
s ByteString
acc = case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
s of
        Maybe (Word8, ByteString)
Nothing -> a -> Either a Text
forall a b. a -> Either a b
Left a
"invalid sf-string (unterminated)"
        Just (Word8
34, ByteString
r)
            | ByteString -> Bool
BS.null ByteString
r -> Text -> Either a Text
forall a b. b -> Either a b
Right (ByteString -> Text
decodeUtf8Lenient ByteString
acc)
            | Bool
otherwise -> a -> Either a Text
forall a b. a -> Either a b
Left a
"invalid sf-string (trailing bytes after close)"
        Just (Word8
92, ByteString
r) -> case ByteString -> Maybe (Word8, ByteString)
BS.uncons ByteString
r of
            Just (Word8
c, ByteString
r') | Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
34 Bool -> Bool -> Bool
|| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
92 -> ByteString -> ByteString -> Either a Text
go ByteString
r' (ByteString
acc ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word8 -> ByteString
BS.singleton Word8
c)
            Maybe (Word8, ByteString)
_ -> a -> Either a Text
forall a b. a -> Either a b
Left a
"invalid sf-string (bad escape)"
        Just (Word8
c, ByteString
r) -> ByteString -> ByteString -> Either a Text
go ByteString
r (ByteString
acc ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word8 -> ByteString
BS.singleton Word8
c)

instance HasLeaf BareItem Text where
    leaf :: Leaf BareItem Text
leaf = (ByteString -> Either Text Text)
-> (Text -> ByteString) -> Info -> Leaf BareItem Text
forall a.
(ByteString -> Either Text a)
-> (a -> ByteString) -> Info -> Leaf BareItem a
bareLeaf ByteString -> Either Text Text
parseSfString (\Text
t -> ByteString
"\"" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
escapeSfString (Text -> ByteString
encodeUtf8 Text
t) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\"") (Text -> Maybe Text -> Info
Info Text
"string" Maybe Text
forall a. Maybe a
Nothing)

instance HasLeaf BareItem ByteString where
    leaf :: Leaf BareItem ByteString
leaf = (ByteString -> Either Text ByteString)
-> (ByteString -> ByteString) -> Info -> Leaf BareItem ByteString
forall a.
(ByteString -> Either Text a)
-> (a -> ByteString) -> Info -> Leaf BareItem a
bareLeaf ByteString -> Either Text ByteString
forall a b. b -> Either a b
Right ByteString -> ByteString
forall a. a -> a
id (Text -> Maybe Text -> Info
Info Text
"string" Maybe Text
forall a. Maybe a
Nothing)

renderSfDecimal :: Scientific -> ByteString
renderSfDecimal :: Scientific -> ByteString
renderSfDecimal = String -> ByteString
BS8.pack (String -> ByteString)
-> (Scientific -> String) -> Scientific -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FPFormat -> Maybe Int -> Scientific -> String
formatScientific FPFormat
Fixed (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
3)

parseSfDecimal :: ByteString -> Either Text Scientific
parseSfDecimal :: ByteString -> Either Text Scientific
parseSfDecimal ByteString
bs = case ByteString -> Maybe (Int, ByteString)
BS8.readInt ByteString
bs of
    Maybe (Int, ByteString)
_ -> case ReadS Scientific
forall a. Read a => ReadS a
reads (ByteString -> String
BS8.unpack ByteString
bs) of
        [(Scientific
s, String
"")] -> Scientific -> Either Text Scientific
forall a b. b -> Either a b
Right Scientific
s
        [(Scientific, String)]
_ -> Text -> Either Text Scientific
forall a b. a -> Either a b
Left (Text
"invalid sf-decimal: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
decodeUtf8Lenient ByteString
bs)

instance HasLeaf BareItem Scientific where
    leaf :: Leaf BareItem Scientific
leaf = (ByteString -> Either Text Scientific)
-> (Scientific -> ByteString) -> Info -> Leaf BareItem Scientific
forall a.
(ByteString -> Either Text a)
-> (a -> ByteString) -> Info -> Leaf BareItem a
bareLeaf ByteString -> Either Text Scientific
parseSfDecimal Scientific -> ByteString
renderSfDecimal (Text -> Maybe Text -> Info
Info Text
"number" Maybe Text
forall a. Maybe a
Nothing)

instance HasLeaf BareItem Double where
    leaf :: Leaf BareItem Double
leaf = (ByteString -> Either Text Double)
-> (Double -> ByteString) -> Info -> Leaf BareItem Double
forall a.
(ByteString -> Either Text a)
-> (a -> ByteString) -> Info -> Leaf BareItem a
bareLeaf ((Scientific -> Double)
-> Either Text Scientific -> Either Text Double
forall a b. (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Scientific -> Double
forall a. RealFloat a => Scientific -> a
toRealFloat (Either Text Scientific -> Either Text Double)
-> (ByteString -> Either Text Scientific)
-> ByteString
-> Either Text Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text Scientific
parseSfDecimal) (Scientific -> ByteString
renderSfDecimal (Scientific -> ByteString)
-> (Double -> Scientific) -> Double -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Scientific
forall a b. (Real a, Fractional b) => a -> b
realToFrac) (Text -> Maybe Text -> Info
Info Text
"number" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"double"))

instance HasLeaf BareItem Float where
    leaf :: Leaf BareItem Float
leaf = (ByteString -> Either Text Float)
-> (Float -> ByteString) -> Info -> Leaf BareItem Float
forall a.
(ByteString -> Either Text a)
-> (a -> ByteString) -> Info -> Leaf BareItem a
bareLeaf ((Scientific -> Float)
-> Either Text Scientific -> Either Text Float
forall a b. (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Scientific -> Float
forall a. RealFloat a => Scientific -> a
toRealFloat (Either Text Scientific -> Either Text Float)
-> (ByteString -> Either Text Scientific)
-> ByteString
-> Either Text Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text Scientific
parseSfDecimal) (Scientific -> ByteString
renderSfDecimal (Scientific -> ByteString)
-> (Float -> Scientific) -> Float -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Scientific
forall a b. (Real a, Fractional b) => a -> b
realToFrac) (Text -> Maybe Text -> Info
Info Text
"number" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"float"))

instance HasLeaf BareItem UTCTime where
    leaf :: Leaf BareItem UTCTime
leaf = (ByteString -> Either Text UTCTime)
-> (UTCTime -> ByteString) -> Info -> Leaf BareItem UTCTime
forall a.
(ByteString -> Either Text a)
-> (a -> ByteString) -> Info -> Leaf BareItem a
bareLeaf ByteString -> Either Text UTCTime
dec UTCTime -> ByteString
enc (Text -> Maybe Text -> Info
Info Text
"string" (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"date-time"))
      where
        enc :: UTCTime -> ByteString
enc UTCTime
t = Char -> ByteString -> ByteString
BS8.cons Char
'@' (String -> ByteString
BS8.pack (Integer -> String
forall a. Show a => a -> String
show (POSIXTime -> Integer
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (UTCTime -> POSIXTime
utcTimeToPOSIXSeconds UTCTime
t) :: Integer)))
        dec :: ByteString -> Either Text UTCTime
dec ByteString
bs = case ByteString -> Maybe (Char, ByteString)
BS8.uncons ByteString
bs of
            Just (Char
'@', ByteString
rest) -> case ByteString -> Maybe (Integer, ByteString)
BS8.readInteger ByteString
rest of
                Just (Integer
n, ByteString
r) | ByteString -> Bool
BS.null ByteString
r -> UTCTime -> Either Text UTCTime
forall a b. b -> Either a b
Right (POSIXTime -> UTCTime
posixSecondsToUTCTime (Integer -> POSIXTime
forall a. Num a => Integer -> a
fromInteger Integer
n))
                Maybe (Integer, ByteString)
_ -> Text -> Either Text UTCTime
forall a b. a -> Either a b
Left (Text
"invalid sf-date: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
decodeUtf8Lenient ByteString
bs)
            Maybe (Char, ByteString)
_ -> Text -> Either Text UTCTime
forall a b. a -> Either a b
Left (Text
"invalid sf-date (expected '@'): " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
decodeUtf8Lenient ByteString
bs)

renderInner :: Leaf BareItem a -> [a] -> ByteString
renderInner :: forall a. Leaf BareItem a -> [a] -> ByteString
renderInner Leaf BareItem a
vLeaf [a]
xs = ByteString
"(" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> [ByteString] -> ByteString
BS.intercalate ByteString
" " ((a -> ByteString) -> [a] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Leaf BareItem a
vLeaf.encode [a]
xs) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
")"

parseInnerToList :: Leaf BareItem a -> ByteString -> Either ParseError [a]
parseInnerToList :: forall a. Leaf BareItem a -> ByteString -> Either ParseError [a]
parseInnerToList Leaf BareItem a
vLeaf ByteString
v = case ByteString -> Maybe [ByteString]
parseInnerBare (ByteString -> ByteString
strip ByteString
v) of
    Just [ByteString]
xs -> (ByteString -> Either ParseError a)
-> [ByteString] -> Either ParseError [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Leaf BareItem a
vLeaf.decode [ByteString]
xs
    Maybe [ByteString]
Nothing -> ParseError -> Either ParseError [a]
forall a b. a -> Either a b
Left ParseError
ParseError