-- | Parsing and serialization for directories and their entries.
module Tahoe.Directory.Internal.Parsing where

import Control.Monad (void)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as C8
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8', encodeUtf8)
import Data.Void (Void)
import Tahoe.Directory.Internal.Types (Directory (..), Entry (..))
import Text.Megaparsec (MonadParsec (eof, label, takeP), ParseErrorBundle, Parsec, many, parse)
import Text.Megaparsec.Byte (string)
import Text.Megaparsec.Byte.Lexer (decimal)

-- | Parse the serialized form of a directory into a Directory.
parse :: B.ByteString -> Either (ParseErrorBundle B.ByteString Void) Directory
parse :: ByteString -> Either (ParseErrorBundle ByteString Void) Directory
parse = Parsec Void ByteString Directory
-> String
-> ByteString
-> Either (ParseErrorBundle ByteString Void) Directory
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
Text.Megaparsec.parse Parsec Void ByteString Directory
pDirectory String
"Directory"

-- | The parser type we will parse in.
type Parser = Parsec Void B.ByteString

-- XXX This doesn't do bounds checking.

-- | Parse the base ten representation of a natural number.
natural :: Integral i => Parser i
natural :: Parser i
natural = Parser i
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Word8, Num a) =>
m a
decimal

{- | Parse a netstring-encoded value, applying a sub-parser to the encoded
 string.
-}
pNetstring ::
    -- | A function that takes the length of the string encoded in the
    -- netstring and returns a parser for the value the encoded string
    -- represents.
    (Int -> Parser a) ->
    -- | A parser for the value.
    Parser a
pNetstring :: (Int -> Parser a) -> Parser a
pNetstring Int -> Parser a
pInner = do
    Int
len <- Parser Int
forall i. Integral i => Parser i
natural
    ParsecT Void ByteString Identity ByteString
-> ParsecT Void ByteString Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void ByteString Identity ByteString
 -> ParsecT Void ByteString Identity ())
-> ParsecT Void ByteString Identity ByteString
-> ParsecT Void ByteString Identity ()
forall a b. (a -> b) -> a -> b
$ Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens ByteString
":"
    a
result <- Int -> Parser a
pInner Int
len
    ParsecT Void ByteString Identity ByteString
-> ParsecT Void ByteString Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void ByteString Identity ByteString
 -> ParsecT Void ByteString Identity ())
-> ParsecT Void ByteString Identity ByteString
-> ParsecT Void ByteString Identity ()
forall a b. (a -> b) -> a -> b
$ Tokens ByteString
-> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens ByteString
","
    a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result

pDirectory :: Parser Directory
pDirectory :: Parsec Void ByteString Directory
pDirectory = [Entry] -> Directory
Directory ([Entry] -> Directory)
-> ParsecT Void ByteString Identity [Entry]
-> Parsec Void ByteString Directory
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Void ByteString Identity Entry
-> ParsecT Void ByteString Identity [Entry]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT Void ByteString Identity Entry
pEntry ParsecT Void ByteString Identity [Entry]
-> ParsecT Void ByteString Identity ()
-> ParsecT Void ByteString Identity [Entry]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void ByteString Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof)

pEntry :: Parser Entry
pEntry :: ParsecT Void ByteString Identity Entry
pEntry =
    String
-> ParsecT Void ByteString Identity Entry
-> ParsecT Void ByteString Identity Entry
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"entry" (ParsecT Void ByteString Identity Entry
 -> ParsecT Void ByteString Identity Entry)
-> ParsecT Void ByteString Identity Entry
-> ParsecT Void ByteString Identity Entry
forall a b. (a -> b) -> a -> b
$
        (Int -> ParsecT Void ByteString Identity Entry)
-> ParsecT Void ByteString Identity Entry
forall a. (Int -> Parser a) -> Parser a
pNetstring ((Int -> ParsecT Void ByteString Identity Entry)
 -> ParsecT Void ByteString Identity Entry)
-> (Int -> ParsecT Void ByteString Identity Entry)
-> ParsecT Void ByteString Identity Entry
forall a b. (a -> b) -> a -> b
$ \Int
_ ->
            Text -> ByteString -> ByteString -> ByteString -> Entry
Entry
                (Text -> ByteString -> ByteString -> ByteString -> Entry)
-> ParsecT Void ByteString Identity Text
-> ParsecT
     Void
     ByteString
     Identity
     (ByteString -> ByteString -> ByteString -> Entry)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> ParsecT Void ByteString Identity Text
-> ParsecT Void ByteString Identity Text
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"name" ((Int -> ParsecT Void ByteString Identity Text)
-> ParsecT Void ByteString Identity Text
forall a. (Int -> Parser a) -> Parser a
pNetstring Int -> ParsecT Void ByteString Identity Text
pUTF8)
                ParsecT
  Void
  ByteString
  Identity
  (ByteString -> ByteString -> ByteString -> Entry)
-> ParsecT Void ByteString Identity ByteString
-> ParsecT
     Void ByteString Identity (ByteString -> ByteString -> Entry)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String
-> ParsecT Void ByteString Identity ByteString
-> ParsecT Void ByteString Identity ByteString
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"ro_uri" ((Int -> ParsecT Void ByteString Identity ByteString)
-> ParsecT Void ByteString Identity ByteString
forall a. (Int -> Parser a) -> Parser a
pNetstring (Maybe String
-> Int -> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> Int -> m (Tokens s)
takeP Maybe String
forall a. Maybe a
Nothing))
                ParsecT
  Void ByteString Identity (ByteString -> ByteString -> Entry)
-> ParsecT Void ByteString Identity ByteString
-> ParsecT Void ByteString Identity (ByteString -> Entry)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String
-> ParsecT Void ByteString Identity ByteString
-> ParsecT Void ByteString Identity ByteString
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"rw_uri" ((Int -> ParsecT Void ByteString Identity ByteString)
-> ParsecT Void ByteString Identity ByteString
forall a. (Int -> Parser a) -> Parser a
pNetstring (Maybe String
-> Int -> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> Int -> m (Tokens s)
takeP Maybe String
forall a. Maybe a
Nothing))
                ParsecT Void ByteString Identity (ByteString -> Entry)
-> ParsecT Void ByteString Identity ByteString
-> ParsecT Void ByteString Identity Entry
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String
-> ParsecT Void ByteString Identity ByteString
-> ParsecT Void ByteString Identity ByteString
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"metadata" ((Int -> ParsecT Void ByteString Identity ByteString)
-> ParsecT Void ByteString Identity ByteString
forall a. (Int -> Parser a) -> Parser a
pNetstring (Maybe String
-> Int -> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> Int -> m (Tokens s)
takeP Maybe String
forall a. Maybe a
Nothing))

pUTF8 :: Int -> Parser T.Text
pUTF8 :: Int -> ParsecT Void ByteString Identity Text
pUTF8 Int
n = do
    ByteString
bs <- Maybe String
-> Int -> ParsecT Void ByteString Identity (Tokens ByteString)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> Int -> m (Tokens s)
takeP Maybe String
forall a. Maybe a
Nothing Int
n
    (UnicodeException -> ParsecT Void ByteString Identity Text)
-> (Text -> ParsecT Void ByteString Identity Text)
-> Either UnicodeException Text
-> ParsecT Void ByteString Identity Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\UnicodeException
e -> String -> ParsecT Void ByteString Identity Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ParsecT Void ByteString Identity Text)
-> String -> ParsecT Void ByteString Identity Text
forall a b. (a -> b) -> a -> b
$ String
"UTF-8 parsing failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
e) Text -> ParsecT Void ByteString Identity Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
bs)

-- | Serialize a Directory to the canonical bytes representation.
serialize :: Directory -> B.ByteString
serialize :: Directory -> ByteString
serialize Directory{[Entry]
directoryChildren :: Directory -> [Entry]
directoryChildren :: [Entry]
directoryChildren} = [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ Entry -> ByteString
serializeEntry (Entry -> ByteString) -> [Entry] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Entry]
directoryChildren

serializeEntry :: Entry -> B.ByteString
serializeEntry :: Entry -> ByteString
serializeEntry Entry{ByteString
Text
entryMetadata :: Entry -> ByteString
entryEncryptedWriter :: Entry -> ByteString
entryReader :: Entry -> ByteString
entryName :: Entry -> Text
entryMetadata :: ByteString
entryEncryptedWriter :: ByteString
entryReader :: ByteString
entryName :: Text
..} =
    -- XXX The name must be NFC normalized apparently, try unicode-transforms
    -- library.  Perhaps we should enforce normalization in the Entry
    -- constructor?
    ByteString -> ByteString
netstring (ByteString -> ByteString)
-> ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$
        [ ByteString -> ByteString
netstring (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text
entryName
        , ByteString -> ByteString
netstring ByteString
entryReader
        , ByteString -> ByteString
netstring ByteString
entryEncryptedWriter
        , ByteString -> ByteString
netstring ByteString
entryMetadata
        ]

-- | Encode a bytestring as a netstring.
netstring :: B.ByteString -> B.ByteString
netstring :: ByteString -> ByteString
netstring ByteString
xs =
    [ByteString] -> ByteString
B.concat
        [ String -> ByteString
C8.pack (String -> ByteString)
-> (ByteString -> String) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (ByteString -> Int) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
B.length (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
xs
        , ByteString
":"
        , ByteString
xs
        , ByteString
","
        ]