{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}

-- | Parsers for PASETO tokens according to the
-- [message format](https://github.com/paseto-standard/paseto-spec/tree/af79f25908227555404e7462ccdd8ce106049469/docs#paseto-message-format)
-- defined in the specification.
--
-- Note that the parsers exported from this module /do not/ perform any kind
-- of token validation, cryptographic or otherwise. These parsers simply
-- ensure that the input /looks like/ a well-formed token.
module Crypto.Paseto.Token.Parser
  ( -- * Token parsers
    parseTokenV3Local
  , parseTokenV3Public
  , parseTokenV4Local
  , parseTokenV4Public
  , parseSomeToken

    -- ** Parsec parsers
  , pVersion
  , pVersionV3
  , pVersionV4
  , pPurpose
  , pPurposeLocal
  , pPurposePublic
  , pPayload
  , pFooter
  , pPayloadAndFooter
  , pTokenParts
  , pTokenV3Local
  , pTokenV3Public
  , pTokenV4Local
  , pTokenV4Public
  , pSomeToken
  ) where

import Control.Applicative ( some, (<|>) )
import Crypto.Paseto.Mode ( Purpose (..), Version (..) )
import Crypto.Paseto.Token
  ( Footer (..), Payload (..), SomeToken (..), Token (..) )
import qualified Data.ByteString.Base64.URL as B64URL
import qualified Data.ByteString.Char8 as B8
import Data.Char ( isAsciiLower, isAsciiUpper, isDigit )
import Data.Functor ( void, ($>) )
import Data.Maybe ( isJust )
import Data.Text ( Text )
import Prelude
import Text.Parsec
  ( ParseError
  , ParsecT
  , Stream
  , char
  , eof
  , optionMaybe
  , parse
  , satisfy
  , string
  , try
  , (<?>)
  )
import Text.Parsec.Text ( Parser )

-- | Parse a version 3 local PASETO token from human-readable text according
-- to the
-- [message format](https://github.com/paseto-standard/paseto-spec/tree/af79f25908227555404e7462ccdd8ce106049469/docs#paseto-message-format)
-- defined in the specification.
--
-- Note that this function does not perform any kind of token validation,
-- cryptographic or otherwise. It simply parses the token and ensures that it
-- is well-formed.
parseTokenV3Local :: Text -> Either ParseError (Token V3 Local)
parseTokenV3Local :: Text -> Either ParseError (Token 'V3 'Local)
parseTokenV3Local = Parsec Text () (Token 'V3 'Local)
-> SourceName -> Text -> Either ParseError (Token 'V3 'Local)
forall s t a.
Stream s Identity t =>
Parsec s () a -> SourceName -> s -> Either ParseError a
parse Parsec Text () (Token 'V3 'Local)
pTokenV3Local SourceName
""

-- | Parse a version 3 public PASETO token from human-readable text according
-- to the
-- [message format](https://github.com/paseto-standard/paseto-spec/tree/af79f25908227555404e7462ccdd8ce106049469/docs#paseto-message-format)
-- defined in the specification.
--
-- Note that this function does not perform any kind of token validation,
-- cryptographic or otherwise. It simply parses the token and ensures that it
-- is well-formed.
parseTokenV3Public :: Text -> Either ParseError (Token V3 Public)
parseTokenV3Public :: Text -> Either ParseError (Token 'V3 'Public)
parseTokenV3Public = Parsec Text () (Token 'V3 'Public)
-> SourceName -> Text -> Either ParseError (Token 'V3 'Public)
forall s t a.
Stream s Identity t =>
Parsec s () a -> SourceName -> s -> Either ParseError a
parse Parsec Text () (Token 'V3 'Public)
pTokenV3Public SourceName
""

-- | Parse a version 4 local PASETO token from human-readable text according
-- to the
-- [message format](https://github.com/paseto-standard/paseto-spec/tree/af79f25908227555404e7462ccdd8ce106049469/docs#paseto-message-format)
-- defined in the specification.
--
-- Note that this function does not perform any kind of token validation,
-- cryptographic or otherwise. It simply parses the token and ensures that it
-- is well-formed.
parseTokenV4Local :: Text -> Either ParseError (Token V4 Local)
parseTokenV4Local :: Text -> Either ParseError (Token 'V4 'Local)
parseTokenV4Local = Parsec Text () (Token 'V4 'Local)
-> SourceName -> Text -> Either ParseError (Token 'V4 'Local)
forall s t a.
Stream s Identity t =>
Parsec s () a -> SourceName -> s -> Either ParseError a
parse Parsec Text () (Token 'V4 'Local)
pTokenV4Local SourceName
""

-- | Parse a version 4 public PASETO token from human-readable text according
-- to the
-- [message format](https://github.com/paseto-standard/paseto-spec/tree/af79f25908227555404e7462ccdd8ce106049469/docs#paseto-message-format)
-- defined in the specification.
--
-- Note that this function does not perform any kind of token validation,
-- cryptographic or otherwise. It simply parses the token and ensures that it
-- is well-formed.
parseTokenV4Public :: Text -> Either ParseError (Token V4 Public)
parseTokenV4Public :: Text -> Either ParseError (Token 'V4 'Public)
parseTokenV4Public = Parsec Text () (Token 'V4 'Public)
-> SourceName -> Text -> Either ParseError (Token 'V4 'Public)
forall s t a.
Stream s Identity t =>
Parsec s () a -> SourceName -> s -> Either ParseError a
parse Parsec Text () (Token 'V4 'Public)
pTokenV4Public SourceName
""

-- | Parse some kind of PASETO token from human-readable text according to the
-- [message format](https://github.com/paseto-standard/paseto-spec/tree/af79f25908227555404e7462ccdd8ce106049469/docs#paseto-message-format)
-- defined in the specification.
--
-- Note that this function does not perform any kind of token validation,
-- cryptographic or otherwise. It simply parses the token and ensures that it
-- is well-formed.
parseSomeToken :: Text -> Either ParseError SomeToken
parseSomeToken :: Text -> Either ParseError SomeToken
parseSomeToken = Parsec Text () SomeToken
-> SourceName -> Text -> Either ParseError SomeToken
forall s t a.
Stream s Identity t =>
Parsec s () a -> SourceName -> s -> Either ParseError a
parse Parsec Text () SomeToken
pSomeToken SourceName
""

------------------------------------------------------------------------------
-- Parsec parsers
------------------------------------------------------------------------------

-- | Parse a valid @base64url@ character.
base64urlChar :: Stream s m Char => ParsecT s u m Char
base64urlChar :: forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
base64urlChar = (Char -> Bool) -> ParsecT s u m Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (\Char
c -> Char -> Bool
isAsciiUpper Char
c Bool -> Bool -> Bool
|| Char -> Bool
isAsciiLower Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit 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
'_') ParsecT s u m Char -> SourceName -> ParsecT s u m Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> SourceName -> ParsecT s u m a
<?> SourceName
"base64url character"

-- | Period (\".\") parser.
period :: Parser ()
period :: Parser ()
period = ParsecT Text () Identity Char -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Text () Identity Char -> Parser ())
-> ParsecT Text () Identity Char -> Parser ()
forall a b. (a -> b) -> a -> b
$ Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.'

-- | Parse a 'Version' from its string representation.
pVersion :: Parser Version
pVersion :: Parser Version
pVersion =
  Parser Version -> Parser Version
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser Version
pVersionV3
    Parser Version -> Parser Version -> Parser Version
forall a.
ParsecT Text () Identity a
-> ParsecT Text () Identity a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Version
pVersionV4
    Parser Version -> SourceName -> Parser Version
forall s u (m :: * -> *) a.
ParsecT s u m a -> SourceName -> ParsecT s u m a
<?> SourceName
"version"

-- | Parse the 'Version' string @v3@.
pVersionV3 :: Parser Version
pVersionV3 :: Parser Version
pVersionV3 = SourceName -> ParsecT Text () Identity SourceName
forall s (m :: * -> *) u.
Stream s m Char =>
SourceName -> ParsecT s u m SourceName
string SourceName
"v3" ParsecT Text () Identity SourceName -> Version -> Parser Version
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Version
V3

-- | Parse the 'Version' string @v4@.
pVersionV4 :: Parser Version
pVersionV4 :: Parser Version
pVersionV4 = SourceName -> ParsecT Text () Identity SourceName
forall s (m :: * -> *) u.
Stream s m Char =>
SourceName -> ParsecT s u m SourceName
string SourceName
"v4" ParsecT Text () Identity SourceName -> Version -> Parser Version
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Version
V4

-- | Parse a 'Purpose' from its string representation.
pPurpose :: Parser Purpose
pPurpose :: Parser Purpose
pPurpose =
  Parser Purpose -> Parser Purpose
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
try Parser Purpose
pPurposeLocal
    Parser Purpose -> Parser Purpose -> Parser Purpose
forall a.
ParsecT Text () Identity a
-> ParsecT Text () Identity a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Purpose
pPurposePublic
    Parser Purpose -> SourceName -> Parser Purpose
forall s u (m :: * -> *) a.
ParsecT s u m a -> SourceName -> ParsecT s u m a
<?> SourceName
"purpose"

-- | Parse the 'Purpose' string @local@.
pPurposeLocal :: Parser Purpose
pPurposeLocal :: Parser Purpose
pPurposeLocal = SourceName -> ParsecT Text () Identity SourceName
forall s (m :: * -> *) u.
Stream s m Char =>
SourceName -> ParsecT s u m SourceName
string SourceName
"local" ParsecT Text () Identity SourceName -> Purpose -> Parser Purpose
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Purpose
Local

-- | Parse the 'Purpose' string @public@.
pPurposePublic :: Parser Purpose
pPurposePublic :: Parser Purpose
pPurposePublic = SourceName -> ParsecT Text () Identity SourceName
forall s (m :: * -> *) u.
Stream s m Char =>
SourceName -> ParsecT s u m SourceName
string SourceName
"public" ParsecT Text () Identity SourceName -> Purpose -> Parser Purpose
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Purpose
Public

-- | Parse a 'Payload' from its string representation.
pPayload :: Parser Payload
pPayload :: Parser Payload
pPayload = do
  ByteString
payloadB64 <- SourceName -> ByteString
B8.pack (SourceName -> ByteString)
-> ParsecT Text () Identity SourceName
-> ParsecT Text () Identity ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity Char
-> ParsecT Text () Identity SourceName
forall a.
ParsecT Text () Identity a -> ParsecT Text () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
base64urlChar
  case ByteString -> Either SourceName ByteString
B64URL.decodeUnpadded ByteString
payloadB64 of
    Left SourceName
err -> SourceName -> Parser Payload
forall a. SourceName -> ParsecT Text () Identity a
forall (m :: * -> *) a. MonadFail m => SourceName -> m a
fail SourceName
err
    Right ByteString
x -> Payload -> Parser Payload
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Payload
Payload ByteString
x)

-- | Parse a 'Footer' from its string representation.
pFooter :: Parser Footer
pFooter :: Parser Footer
pFooter = do
  ByteString
footerB64 <- SourceName -> ByteString
B8.pack (SourceName -> ByteString)
-> ParsecT Text () Identity SourceName
-> ParsecT Text () Identity ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity Char
-> ParsecT Text () Identity SourceName
forall a.
ParsecT Text () Identity a -> ParsecT Text () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
base64urlChar
  case ByteString -> Either SourceName ByteString
B64URL.decodeUnpadded ByteString
footerB64 of
    Left SourceName
err -> SourceName -> Parser Footer
forall a. SourceName -> ParsecT Text () Identity a
forall (m :: * -> *) a. MonadFail m => SourceName -> m a
fail SourceName
err
    Right ByteString
x -> Footer -> Parser Footer
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Footer
Footer ByteString
x)

-- | Parse a 'Payload' along with an optional 'Footer'.
pPayloadAndFooter :: Parser (Payload, Maybe Footer)
pPayloadAndFooter :: Parser (Payload, Maybe Footer)
pPayloadAndFooter = do
  Payload
payload <- Parser Payload
pPayload Parser Payload -> SourceName -> Parser Payload
forall s u (m :: * -> *) a.
ParsecT s u m a -> SourceName -> ParsecT s u m a
<?> SourceName
"payload"
  Bool
hasFooter <- Maybe () -> Bool
forall a. Maybe a -> Bool
isJust (Maybe () -> Bool)
-> ParsecT Text () Identity (Maybe ())
-> ParsecT Text () Identity Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser () -> ParsecT Text () Identity (Maybe ())
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe Parser ()
period
  case Bool
hasFooter of
    Bool
False -> do
      Parser ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
      (Payload, Maybe Footer) -> Parser (Payload, Maybe Footer)
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Payload
payload, Maybe Footer
forall a. Maybe a
Nothing)
    Bool
True -> do
      Footer
footer <- Parser Footer
pFooter Parser Footer -> SourceName -> Parser Footer
forall s u (m :: * -> *) a.
ParsecT s u m a -> SourceName -> ParsecT s u m a
<?> SourceName
"footer"
      Parser ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof
      (Payload, Maybe Footer) -> Parser (Payload, Maybe Footer)
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Payload
payload, Footer -> Maybe Footer
forall a. a -> Maybe a
Just Footer
footer)

-- | Parse the parts of a PASETO token: version, purpose, payload, and an
-- optional footer.
pTokenParts
  :: Parser Version
  -- ^ Parser for the 'Version' part of a token.
  -> Parser Purpose
  -- ^ Parser for the 'Purpose' part of a token.
  -> Parser (Version, Purpose, Payload, Maybe Footer)
pTokenParts :: Parser Version
-> Parser Purpose
-> Parser (Version, Purpose, Payload, Maybe Footer)
pTokenParts Parser Version
pV Parser Purpose
pP = do
  Version
version <- Parser Version
pV
  Parser ()
period
  Purpose
purpose <- Parser Purpose
pP
  Parser ()
period
  (Payload
payload, Maybe Footer
mbFooter) <- Parser (Payload, Maybe Footer)
pPayloadAndFooter
  (Version, Purpose, Payload, Maybe Footer)
-> Parser (Version, Purpose, Payload, Maybe Footer)
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Version
version, Purpose
purpose, Payload
payload, Maybe Footer
mbFooter)

-- | Parse a version 3 local PASETO token from its string representation.
--
-- Accepted token format:
--
-- * Without the optional footer: @v3.local.${payload}@
--
-- * With the optional footer: @v3.local.${payload}.${footer}@
--
-- Both the @payload@ and optional @footer@ are @base64url@-encoded values
-- (unpadded).
pTokenV3Local :: Parser (Token V3 Local)
pTokenV3Local :: Parsec Text () (Token 'V3 'Local)
pTokenV3Local = do
  (Version
_, Purpose
_, Payload
payload, Maybe Footer
mbFooter) <- Parser Version
-> Parser Purpose
-> Parser (Version, Purpose, Payload, Maybe Footer)
pTokenParts Parser Version
pVersionV3 Parser Purpose
pPurposeLocal
  Token 'V3 'Local -> Parsec Text () (Token 'V3 'Local)
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Payload -> Maybe Footer -> Token 'V3 'Local
TokenV3Local Payload
payload Maybe Footer
mbFooter)

-- | Parse a version 3 public PASETO token from its string representation.
--
-- Accepted token format:
--
-- * Without the optional footer: @v3.public.${payload}@
--
-- * With the optional footer: @v3.public.${payload}.${footer}@
--
-- Both the @payload@ and optional @footer@ are @base64url@-encoded values
-- (unpadded).
pTokenV3Public :: Parser (Token V3 Public)
pTokenV3Public :: Parsec Text () (Token 'V3 'Public)
pTokenV3Public = do
  (Version
_, Purpose
_, Payload
payload, Maybe Footer
mbFooter) <- Parser Version
-> Parser Purpose
-> Parser (Version, Purpose, Payload, Maybe Footer)
pTokenParts Parser Version
pVersionV3 Parser Purpose
pPurposePublic
  Token 'V3 'Public -> Parsec Text () (Token 'V3 'Public)
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Payload -> Maybe Footer -> Token 'V3 'Public
TokenV3Public Payload
payload Maybe Footer
mbFooter)

-- | Parse a version 4 local PASETO token from its string representation.
--
-- Accepted token format:
--
-- * Without the optional footer: @v4.local.${payload}@
--
-- * With the optional footer: @v4.local.${payload}.${footer}@
--
-- Both the @payload@ and optional @footer@ are @base64url@-encoded values
-- (unpadded).
pTokenV4Local :: Parser (Token V4 Local)
pTokenV4Local :: Parsec Text () (Token 'V4 'Local)
pTokenV4Local = do
  (Version
_, Purpose
_, Payload
payload, Maybe Footer
mbFooter) <- Parser Version
-> Parser Purpose
-> Parser (Version, Purpose, Payload, Maybe Footer)
pTokenParts Parser Version
pVersionV4 Parser Purpose
pPurposeLocal
  Token 'V4 'Local -> Parsec Text () (Token 'V4 'Local)
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Payload -> Maybe Footer -> Token 'V4 'Local
TokenV4Local Payload
payload Maybe Footer
mbFooter)

-- | Parse a version 4 public PASETO token from its string representation.
--
-- Accepted token format:
--
-- * Without the optional footer: @v4.public.${payload}@
--
-- * With the optional footer: @v4.public.${payload}.${footer}@
--
-- Both the @payload@ and optional @footer@ are @base64url@-encoded values
-- (unpadded).
pTokenV4Public :: Parser (Token V4 Public)
pTokenV4Public :: Parsec Text () (Token 'V4 'Public)
pTokenV4Public = do
  (Version
_, Purpose
_, Payload
payload, Maybe Footer
mbFooter) <- Parser Version
-> Parser Purpose
-> Parser (Version, Purpose, Payload, Maybe Footer)
pTokenParts Parser Version
pVersionV4 Parser Purpose
pPurposePublic
  Token 'V4 'Public -> Parsec Text () (Token 'V4 'Public)
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Payload -> Maybe Footer -> Token 'V4 'Public
TokenV4Public Payload
payload Maybe Footer
mbFooter)

-- | Parse some kind of PASETO token from its string representation.
--
-- PASETO token format:
--
-- * Without the optional footer: @version.purpose.payload@
--
-- * With the optional footer: @version.purpose.payload.footer@
--
-- Acceptable values for @version@ are @v3@ and @v4@. @v1@ and @v2@ are
-- deprecated, so they're not supported.
--
-- Acceptable values for @purpose@ are @local@ and @public@.
--
-- Both the @payload@ and optional @footer@ are @base64url@-encoded values
-- (unpadded).
pSomeToken :: Parser SomeToken
pSomeToken :: Parsec Text () SomeToken
pSomeToken = do
  (Version
version, Purpose
purpose, Payload
payload, Maybe Footer
mbFooter) <- Parser Version
-> Parser Purpose
-> Parser (Version, Purpose, Payload, Maybe Footer)
pTokenParts Parser Version
pVersion Parser Purpose
pPurpose
  SomeToken -> Parsec Text () SomeToken
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Version -> Purpose -> Payload -> Maybe Footer -> SomeToken
mkToken Version
version Purpose
purpose Payload
payload Maybe Footer
mbFooter)
  where
    mkToken :: Version -> Purpose -> Payload -> Maybe Footer -> SomeToken
    mkToken :: Version -> Purpose -> Payload -> Maybe Footer -> SomeToken
mkToken Version
version Purpose
purpose Payload
payload Maybe Footer
mbFooter =
      case (Version
version, Purpose
purpose) of
        (Version
V3, Purpose
Local) -> Token 'V3 'Local -> SomeToken
SomeTokenV3Local (Payload -> Maybe Footer -> Token 'V3 'Local
TokenV3Local Payload
payload Maybe Footer
mbFooter)
        (Version
V3, Purpose
Public) -> Token 'V3 'Public -> SomeToken
SomeTokenV3Public (Payload -> Maybe Footer -> Token 'V3 'Public
TokenV3Public Payload
payload Maybe Footer
mbFooter)
        (Version
V4, Purpose
Local) -> Token 'V4 'Local -> SomeToken
SomeTokenV4Local (Payload -> Maybe Footer -> Token 'V4 'Local
TokenV4Local Payload
payload Maybe Footer
mbFooter)
        (Version
V4, Purpose
Public) -> Token 'V4 'Public -> SomeToken
SomeTokenV4Public (Payload -> Maybe Footer -> Token 'V4 'Public
TokenV4Public Payload
payload Maybe Footer
mbFooter)