content: -----------------------------------------------------------------------------
  --
  -- Module      :  MFlow.Forms.Test
  -- Copyright   :
  -- License     :  BSD3
  --
  -- Maintainer  :  agocorona@gmail.com
  -- Stability   :  experimental
  -- Portability :
  --
  -- |
  --
  -----------------------------------------------------------------------------
  {-# OPTIONS
              -XOverlappingInstances
              -XFlexibleInstances
              -XUndecidableInstances
              -XPatternGuards
              -XRecordWildCards
              -XFlexibleContexts
              #-}
  
  module MFlow.Forms.Test (Generate(..),runTest,runTest1,inject, ask, askt, userWidget, getUser, getUserSimple, verify) where
  import MFlow.Forms hiding(ask,askt,getUser,userWidget,getUserSimple)
  import qualified MFlow.Forms (ask)
  import MFlow.Forms.Internals
  import MFlow.Forms(FormInput(..))
  import MFlow.Forms.Admin
  import Control.Workflow as WF
  import Control.Concurrent
  import Control.Monad
  import MFlow
  import qualified Data.Map as M
  import Control.Monad.Trans
  import System.IO.Unsafe
  import System.Random
  import Data.Char(chr, ord)
  import Data.List
  import Data.Typeable
  import qualified Data.ByteString.Lazy.Char8 as B
  import Control.Concurrent.MVar
  import Data.TCache.Memoization
  import Control.Monad.State
  import Data.Monoid
  import Data.Maybe
  import Data.IORef
  import MFlow.Cookies(cookieuser)
  
  import Data.Dynamic
  import Data.TCache.Memoization
  
  
  
  class Generate a where
    generate :: IO a
  
  instance Generate a => Generate (Maybe a) where
     generate= do
       b <- randomRIO(0,1 :: Int)
       case b of 0 -> generate >>= return . Just ; _ -> return Nothing
  
  instance  Generate String where
     generate= replicateM 5  $ randomRIO ('a','z')
  
  instance Generate Int where
     generate= randomRIO(1,1000)
  
  instance Generate Integer where
     generate= randomRIO(1,1000)
  
  
  instance (Generate a, Generate b) => Generate (a,b) where
    generate= fmap (,) generate `ap` generate
  
  
  instance (Generate a, Generate b) => Generate (Maybe a,Maybe b) where
    generate= do
         r <- generate
         case r of
          (Nothing,Nothing) -> generate
          other -> return other
  
  
  instance (Bounded a, Enum a) => Generate a where
      generate= mx
       where
       mx= do
            let x= typeOfIO mx
            n <- randomRIO ( fromEnum $ minBound `asTypeOf` x
                           , fromEnum $ maxBound `asTypeOf` x)
            return $ toEnum n
            where
            typeOfIO :: IO a -> a
            typeOfIO = undefined
  
  -- | Run a list of flows with a number of simultaneous threads
  runTest :: [(Int, Flow)] -> IO ()
  runTest ps= do
    mapM_ (forkIO . run1) ps
    putStrLn $ "started " ++ (show . sum . fst $ unzip ps) ++ " threads"
  
    where
    run1 (nusers,  proc) =  replicateM_ nusers $ runTest1 proc
  
  runTest1 f = do
      atomicModifyIORef testNumber (\n -> (n+1,n+1))
      name <- generate
      x <- generate
      y <- generate
      z <- generate
  
      let t = Token x y z [] [] undefined undefined undefined
      WF.start  name   f t
  
  testNumber= unsafePerformIO $ newIORef 0
  
  getTestNumber :: MonadIO m => m Int
  getTestNumber= liftIO $ readIORef testNumber
  
  -- | Inject substitutes an expression by other. It may be used to override
  -- ask interaction with the user. It should bee used infix for greater readability:
  --
  -- > ask something    `inject` const some other
  --
  -- The parameter passed is the test number
  -- if the flow has not been executed by runTest, inject return the original
  inject :: MonadIO m => m b -> (Int -> b) -> m b
  inject exp v= do
     n <- getTestNumber
     if n== 0 then exp else exp `seq` return $ v n
  
  -- | A simulated ask that generate  simulated user input of the type expected.
  --
  --  It forces the web page rendering, since it is monadic and can contain
  -- side effects and load effects to be tested.
  --
  --  it is a substitute of 'ask' from "MFlow.Forms" for testing purposes.
  
  -- execute 'runText' to initiate threads under different load conditions.
  ask :: (Generate a, MonadIO m,  Functor m, FormInput v,Typeable v) => View v m a -> FlowM v m a
  ask w = do
      FormElm forms mx <- FlowM . lift $ runView  w
      r <- liftIO generate
      let n= B.length $ toByteString  forms
      breturn $ n `seq` mx `seq` r
  --    let u= undefined
  --    liftIO $ runStateT (runView mf) s
  --    bool <- liftIO generate
  --    case bool of
  --          False -> fail ""
  --          True -> do
  --            b <- liftIO generate
  --            r <- liftIO generate
  --            case  (b,r)  of
  --                (True,x)  -> breturn x
  --                _         -> ask w
  
  
  -- | Instead of generating a result like `ask`, the result is given as the first parameter
  -- so it does not need a Generate instance.
  --
  -- It forces the web page rendering, since it is monadic so it can contain
  -- side effects and load effects to be tested.
  askt :: (MonadIO m, FormInput v) => (Int -> a) -> View v m a -> FlowM v m a
  askt v w =  do
      FormElm forms mx <- FlowM . lift $ runView  w
      n <- getTestNumber
      let l= B.length $ toByteString  forms
      breturn $ l `seq` mx `seq` v n
  
  --mvtestopts :: MVar (M.Map String (Int,Dynamic))
  --mvtestopts = unsafePerformIO $ newMVar M.empty
  
  --asktn :: (Typeable a,MonadIO m) => [a] -> View v m a -> FlowM v m a
  --asktn xs w= do
  --    v <- liftIO $ do
  --         let k = addrStr xs
  --         opts <- takeMVar mvtestopts
  --         let r = M.lookup k opts
  --         case r of
  --              Nothing -> do
  --                putMVar mvtestopts $ M.singleton k (0,toDyn xs)
  --                return $ head  xs
  --              Just (i,d) -> do
  --                putMVar mvtestopts $ M.insert k (i+1,d) opts
  --                return $ (fromMaybe (error err1) $ fromDynamic d) !! i
  --
  --    askt v w
  --
  --    where
  --    err1= "MFlow.Forms.Test: asktn: fromDynamic error"
  
  
  -- | verify a property. if not true, throw the error message.
  --
  -- It is intended to be used in a infix notation, on the right of the code,
  -- in order to separate the code assertions from the application code and make clearly
  -- visible them as a form of documentation.
  -- Separated from it:
  --
  -- > liftIO $ print (x :: Int)          `verify` (return $ x > 10, "x < = 10")
  --
  -- The expression is monadic to allow for complex verifications that may involve IO actions
  verifyM :: Monad m => m b -> (m Bool, String) -> m b
  verifyM f (mprop, msg)= do
      prop <- mprop
      case prop of
       True ->  f
       False -> error  msg
  
  -- | a pure version of verifyM
  verify :: a -> (Bool, String) -> a
  verify f (prop, msg)= do
      case prop of
       True ->  f
       False -> error  msg
  
  
  --
  --match form=do
  --  marches <- readIORef matches
  --  return $ head map (m s) matches
  --  where
  --  m s (ms,ps) = case and  $ map (flip isInfixOf $ s) ms of
  --                       True  -> Just ps
  --                       False -> Nothing
  --
  --composeParams (Gen ps) form= zip (getParams form) ps
  --  where
  --  getParams form=
  --    let  search name  form
  --          | null form = mempty
  --          | isPrefix name form = drop (length name) form
  --          | otherwise= search name $ tail form
  --
  --         par s= takeWhile(/='\"') . dropWhile (/='\"') . tail . dropWhile (/='=') $ s
  --         getPar= par $ search "name"
  --    in  getPar form
  --
  
  waction :: (Functor m, MonadIO m,Generate a, FormInput view)
       => View view m a
       -> (a -> FlowM view m b)
       -> View view m b
  waction w f= do
    x <- liftIO generate
    MFlow.Forms.waction (return x) f
  
  userWidget :: ( MonadIO m, Functor m
            , FormInput view)
           => Maybe String
           -> View view m (Maybe (String,String), Maybe String)
           -> View view m String
  userWidget muser formuser= do
     user <- getCurrentUser
     if muser== Just user then return user
      else if isJust muser then do
            let user= fromJust muser
            login user >> return user
      else liftIO generate >>= \u -> login u >> return u
  
     where
     login uname= do
           st <- get
           let t = mfToken st
               t'= t{tuser= uname}
           put st{mfToken= t'}
           return ()
  
  getUserSimple :: ( MonadIO m, FormInput view, Typeable view
                   ,  Functor m)
                => FlowM view m String
  getUserSimple= getUser Nothing userFormLine
  
  
  getUser :: ( FormInput view, Typeable view
             ,  Functor m,MonadIO m)
            => Maybe String
            -> View view m (Maybe (String,String), Maybe String)
            -> FlowM view m String
  getUser mu form= ask $ userWidget mu form
  
  --wmodify
  --  :: (Functor m, MonadIO m, FormInput v, Generate (Maybe a)) =>
  --     View v m a1
  --     -> ([v] -> Maybe a -> WState v m ([v], Maybe b))
  --     -> View v m b
  --wmodify formt act = do
  --    x <-  liftIO generate
  --    formt `MFlow.Forms.wmodify` (\ f _-> return (f,x)) `MFlow.Forms.wmodify` act
  
  {-
  type Var= String
  data Test=  Test{tflink:: [(Var,String)]
                  ,selectOptions :: [(Var,[String])]
                  ,tfinput :: [(Var, String)]
                  ,tftextarea :: [(Var, String)]
                  }
                  deriving(Read,Show)
  
  type TestM =  Test -> Test
  
  instance Monoid  TestM  where
    mempty=  id
    mappend= (.)
  
  instance  FormInput TestM  where
      ftag = const id
      inred  = const id
      fromStr = const id
      flink var _= let(n,v)=break (=='=') var in  \t ->t{tflink= (n,tail v):tflink t}
      finput n _ v _ _ = \t -> t{tfinput = (n,v):tfinput t}
      ftextarea n v= \t -> t{tftextarea = (n,v):tftextarea t}
      fselect n _= \t -> t{selectOptions=(n,[]):selectOptions t}
      foption o _ _= \t ->
           let (n,opts)= head $ selectOptions t
           in t{selectOptions=(n,o:opts):tail (selectOptions t)}
      formAction  _ _= id
      addAttributes _ _= id
  
  generateGenerate Test{..}= do
    b <- generate
    case b of
       True -> genLink
       False -> genForm
  
    where
    genForm= do
           -- one on every generate is incomplete
           n <- randomRIO(0,10) :: IO Int
           case n of
             0 -> do
               genInput
  
             _ -> do
               r1 <- genInput
               r2 <- genSelect
               r3 <- genTextArea
               return $ r1++r2++r3
    genLink= do
           let n = length tflink
           if n == 0 then genForm
            else do
              r <- randomRIO(0,n )
              return [tflink !! r]
  
    genSelect=do
     let n = length selectOptions
     if n== 0
      then return []
      else mapM gen selectOptions
      where
      gen(s,os)= do
       let m = length os
       j <- randomRIO(0,m)
       return (s, os !! j)
  
    genInput= do
       let n = length tftextarea
       if n==0
        then return []
        else mapM gen tfinput
        where gen(n,_)= do
               str <- generate
               return $  (n,str)
  
    genTextArea= do
       let n = length tfinput
       if n==0
         then return []
         else mapM gen tftextarea
         where
         gen(n,_)= do
               str <- generate
               return $  (n,str)
  
  pwf= "pwf"
  ind= "ind"
  instance  Processable Params where
       pwfname = fromMaybe noScript  . lookup pwf
       puser= fromMaybe anonymous  . lookup cookieuser
       pind = fromMaybe "0"  . lookup ind
       getParams = id
  
  
  
  runTest nusers = do
     wfs <- getMessageFlows
     replicateM nusers $ gen wfs
     where
     gen wfs = do
       u <- generate
       mapM (genTraffic u) $ M.toList wfs
  
     genTraffic u (n,_)= forkIO $ iterategenerates  [(pwf,n),(cookieuser,u)] []
  
     iterategenerates ident msg= iterate [] msg
       where
       iterate cs msg= do
         (HttpData ps cooks test,_) <- msgScheduler $  ident ++ cs++ msg
         let cs'= cs++ map (\(a,b,c,d)-> (a,b)) cooks
         resp <- generateGenerate . read $ B.unpack test
         iterate cs' resp
  
        -}
  