{-# LANGUAGE DataKinds, UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
module HtmlTest (specsWith, cleanDB, htmlMigrate) where

import Data.Char (generalCategory, GeneralCategory(..))
import qualified Data.Text as T
import System.Random (randomIO, randomRIO, Random)
import Text.Blaze.Html
import Text.Blaze.Html.Renderer.Text

import Init

-- Test lower case names
share [mkPersist persistSettings { mpsGeneric = True }, mkMigrate "htmlMigrate"] [persistLowerCase|
HtmlTable
    html Html
    deriving
|]

cleanDB :: Runner backend m => ReaderT backend m ()
cleanDB :: ReaderT backend m ()
cleanDB = do
  [Filter (HtmlTableGeneric backend)] -> ReaderT backend m ()
forall backend (m :: * -> *) record.
(PersistQueryWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m ()
deleteWhere ([] :: [Filter (HtmlTableGeneric backend)])

specsWith
    :: Runner backend m
    => RunDb backend m
    -> Maybe (ReaderT backend m a)
    -> Spec
specsWith :: RunDb backend m -> Maybe (ReaderT backend m a) -> Spec
specsWith RunDb backend m
runConn Maybe (ReaderT backend m a)
mmigrate = String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"html" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"works" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
asIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ RunDb backend m
runConn RunDb backend m -> RunDb backend m
forall a b. (a -> b) -> a -> b
$ do
        Maybe (ReaderT backend m a) -> ReaderT backend m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ Maybe (ReaderT backend m a)
mmigrate
        -- Ensure reading the data from the database works...
        Maybe (ReaderT backend m a) -> ReaderT backend m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ Maybe (ReaderT backend m a)
mmigrate

        [ReaderT backend m ()] -> ReaderT backend m ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([ReaderT backend m ()] -> ReaderT backend m ())
-> [ReaderT backend m ()] -> ReaderT backend m ()
forall a b. (a -> b) -> a -> b
$ Int -> ReaderT backend m () -> [ReaderT backend m ()]
forall a. Int -> a -> [a]
replicate Int
1000 (ReaderT backend m () -> [ReaderT backend m ()])
-> ReaderT backend m () -> [ReaderT backend m ()]
forall a b. (a -> b) -> a -> b
$ do
            Html
x <- IO Html -> ReaderT backend m Html
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Html
randomValue
            Key (HtmlTableGeneric backend)
key <- HtmlTableGeneric backend
-> ReaderT backend m (Key (HtmlTableGeneric backend))
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
insert (HtmlTableGeneric backend
 -> ReaderT backend m (Key (HtmlTableGeneric backend)))
-> HtmlTableGeneric backend
-> ReaderT backend m (Key (HtmlTableGeneric backend))
forall a b. (a -> b) -> a -> b
$ Html -> HtmlTableGeneric backend
forall backend. Html -> HtmlTableGeneric backend
HtmlTable Html
x
            Just HtmlTableGeneric backend
htmlTableY <- Key (HtmlTableGeneric backend)
-> ReaderT backend m (Maybe (HtmlTableGeneric backend))
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get Key (HtmlTableGeneric backend)
key
            IO () -> ReaderT backend m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT backend m ()) -> IO () -> ReaderT backend m ()
forall a b. (a -> b) -> a -> b
$ do
                Html -> Text
renderHtml Html
x Text -> Text -> IO ()
forall a. (HasCallStack, Eq a, Show a) => a -> a -> IO ()
@?= Html -> Text
renderHtml (HtmlTableGeneric backend -> Html
forall backend. HtmlTableGeneric backend -> Html
htmlTableHtml HtmlTableGeneric backend
htmlTableY)

randomValue :: IO Html
randomValue :: IO Html
randomValue =
                Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToMarkup
              (Text -> Html) -> (String -> Text) -> String -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
              (String -> Text) -> ShowS -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter ((GeneralCategory -> [GeneralCategory] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [GeneralCategory]
forbidden) (GeneralCategory -> Bool)
-> (Char -> GeneralCategory) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> GeneralCategory
generalCategory)
              ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xFFFF') -- only BMP
              ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\0')     -- no nulls
         (String -> Html) -> IO String -> IO Html
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
forall a. Random a => IO [a]
randomIOs
    where forbidden :: [GeneralCategory]
forbidden = [GeneralCategory
NotAssigned, GeneralCategory
PrivateUse]

randomIOs :: Random a => IO [a]
randomIOs :: IO [a]
randomIOs = do
    Int
len <- (Int, Int) -> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
0, Int
20)
    [IO a] -> IO [a]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([IO a] -> IO [a]) -> [IO a] -> IO [a]
forall a b. (a -> b) -> a -> b
$ Int -> IO a -> [IO a]
forall a. Int -> a -> [a]
replicate Int
len IO a
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO