-- This file is part of purebred-email
-- Copyright (C) 2021  Fraser Tweedale
--
-- purebred-email is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

module Data.MIME.Boundary
  (
    Boundary
  , unBoundary
  , makeBoundary
  ) where

import Control.Monad (replicateM)

import qualified Data.ByteString as B
import qualified Data.ByteString.Internal as B
import Data.ByteString.Char8 as C8
import System.Random.Stateful

-- | MIME boundary.  Use 'makeBoundary' to construct, and 'unBoundary'
-- to unwrap.
--
-- Use the 'Uniform' instance to generate a random @Boundary@ to use
-- when constructing messages.  For example:
--
-- @
-- 'getStdRandom' 'uniform' :: MonadIO m =>  m Boundary
-- 'getStdRandom' 'uniform' ::              IO Boundary
-- @
--
newtype Boundary = Boundary B.ByteString
  deriving (Boundary -> Boundary -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Boundary -> Boundary -> Bool
$c/= :: Boundary -> Boundary -> Bool
== :: Boundary -> Boundary -> Bool
$c== :: Boundary -> Boundary -> Bool
Eq, Int -> Boundary -> ShowS
[Boundary] -> ShowS
Boundary -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Boundary] -> ShowS
$cshowList :: [Boundary] -> ShowS
show :: Boundary -> String
$cshow :: Boundary -> String
showsPrec :: Int -> Boundary -> ShowS
$cshowsPrec :: Int -> Boundary -> ShowS
Show)

unBoundary :: Boundary -> B.ByteString
unBoundary :: Boundary -> ByteString
unBoundary (Boundary ByteString
s) = ByteString
s

-- Boundary smart constructor that checks validity
makeBoundary :: B.ByteString -> Either B.ByteString Boundary
makeBoundary :: ByteString -> Either ByteString Boundary
makeBoundary ByteString
s
  | ByteString -> Bool
B.null ByteString
s                    = forall a b. a -> Either a b
Left ByteString
s
  | ByteString -> Int
B.length ByteString
s forall a. Ord a => a -> a -> Bool
> Int
70             = forall a b. a -> Either a b
Left ByteString
s
  | (Word8 -> Bool) -> ByteString -> Bool
B.any (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. (Ord a, Num a) => a -> Bool
validBchar) ByteString
s  = forall a b. a -> Either a b
Left ByteString
s
  | HasCallStack => ByteString -> Word8
B.last ByteString
s forall a. Eq a => a -> a -> Bool
== Word8
0x20            = forall a b. a -> Either a b
Left ByteString
s
  | Bool
otherwise                   = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ ByteString -> Boundary
Boundary ByteString
s
  where
    validBchar :: a -> Bool
validBchar a
c =
      a
c forall a. Ord a => a -> a -> Bool
>= a
0x2c Bool -> Bool -> Bool
&& a
c forall a. Ord a => a -> a -> Bool
<= a
0x3a -- ',', '-', '.', '/', '0'..'9', ':'
      Bool -> Bool -> Bool
|| a
c forall a. Ord a => a -> a -> Bool
>= a
0x41 Bool -> Bool -> Bool
&& a
c forall a. Ord a => a -> a -> Bool
<= a
0x5a -- 'A'..'Z'
      Bool -> Bool -> Bool
|| a
c forall a. Ord a => a -> a -> Bool
>= a
0x61 Bool -> Bool -> Bool
&& a
c forall a. Ord a => a -> a -> Bool
<= a
0x7a -- 'a'..'z'
      Bool -> Bool -> Bool
|| a
c forall a. Ord a => a -> a -> Bool
>= a
0x27 Bool -> Bool -> Bool
&& a
c forall a. Ord a => a -> a -> Bool
<= a
0x29 -- '\'', '(', ')'
      Bool -> Bool -> Bool
|| a
c forall a. Eq a => a -> a -> Bool
== a
0x2b {- '+' -}
      Bool -> Bool -> Bool
|| a
c forall a. Eq a => a -> a -> Bool
== a
0x5f {- '_' -}
      Bool -> Bool -> Bool
|| a
c forall a. Eq a => a -> a -> Bool
== a
0x3d {- '=' -}
      Bool -> Bool -> Bool
|| a
c forall a. Eq a => a -> a -> Bool
== a
0x3f {- '?' -}
      Bool -> Bool -> Bool
|| a
c forall a. Eq a => a -> a -> Bool
== a
0x20 {- ' ' -}

-- | Generate a random 'Boundary'
genBoundary :: (StatefulGen g m) => g -> m Boundary
genBoundary :: forall g (m :: * -> *). StatefulGen g m => g -> m Boundary
genBoundary g
g = do
  let
    blen :: Int
blen = Int
64
    bchars :: ByteString
bchars = String -> ByteString
C8.pack forall a b. (a -> b) -> a -> b
$ [Char
'0'..Char
'9'] forall a. Semigroup a => a -> a -> a
<> [Char
'a'..Char
'z'] forall a. Semigroup a => a -> a -> a
<> [Char
'A'..Char
'Z'] forall a. Semigroup a => a -> a -> a
<> String
"'()+_,-./:=?"
  [Word8]
chars <-
    forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
blen forall a b. (a -> b) -> a -> b
$ HasCallStack => ByteString -> Int -> Word8
B.index ByteString
bchars forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (Int
0, ByteString -> Int
B.length ByteString
bchars forall a. Num a => a -> a -> a
- Int
1) g
g
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Boundary
Boundary forall a b. (a -> b) -> a -> b
$ Int -> [Word8] -> ByteString
B.unsafePackLenBytes Int
blen [Word8]
chars

instance Uniform Boundary where
  uniformM :: forall g (m :: * -> *). StatefulGen g m => g -> m Boundary
uniformM = forall g (m :: * -> *). StatefulGen g m => g -> m Boundary
genBoundary