{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE 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 (Random, randomIO, randomRIO)
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 :: forall backend (m :: * -> *).
Runner backend m =>
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 ()
forall (m :: * -> *) record.
(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 :: forall backend (m :: * -> *) a.
Runner backend m =>
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 a. IO a -> ReaderT backend m a
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)
forall record (m :: * -> *).
(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)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get Key (HtmlTableGeneric backend)
key
            IO () -> ReaderT backend m ()
forall a. IO a -> ReaderT backend m a
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 :: forall a. Random a => 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)
forall (m :: * -> *) a. Monad m => [m a] -> m [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