{-# OPTIONS  -XDeriveDataTypeable
             -XUndecidableInstances
             -XExistentialQuantification
             -XMultiParamTypeClasses
             -XTypeSynonymInstances
             -XFlexibleInstances
             -XScopedTypeVariables
             -XFunctionalDependencies
             -XFlexibleContexts
             -XRecordWildCards

#-}

{- | This module defines an integrated way to interact with the user. `ask` is
a single method of user interaction. it send user interfaces and return statically
typed responses. The user interface definitions are  based on the formLets interface

But additionally, unlike formLets in its current form, it permits the
 definition of widgets. A widget is data that, when renderized
and interact with the user, return data, just like a formlet, but it hasn
to be an HTML form. it can contain JavaScript, or additional Html decoration or
it can use Ajax istead of form post for the interaction.
There is an example of widget defined (`Selection`)

widgets (and formlets) can be combined in a sigle Html page.
Here is a ready-to-run example that combines a Widget (Selection) and
a HTML decorated formLet in the same page.

@
import "MFlow.Hack.XHtml.All"

import Data.Typeable
import Control.Monad.Trans
import qualified Data.Vector as V

main= do

   putStrLn $ options messageFlows
   'run' 80 $ 'hackMessageFlow' messageFlows
   where
   messageFlows=  [(\"main\",  runFlow mainProds )
                  ,(\"hello\", stateless hello)]
   options msgs= \"in the browser choose\\n\\n\" ++
     concat [ "http:\/\/server\/"++ i ++ "\n" | (i,_) \<- msgs]


\--an stateless procedure, as an example
hello :: 'Env' -> IO String
hello env =  return  \"hello, this is a stateless response\"


data Prod= Prod{pname :: String, pprice :: Int} deriving (Typeable,Read,Show)

\-- formLets can have Html formatting. Additional operators \<\++ \<+\> \<\<\< ++\> to XHtml formatting

instance 'FormLet' Prod IO Html where
   'digest' mp= table \<\<\< (
      Prod \<\$\> tr \<\<\< (td \<\< \"enter the name\"  \<++ td \<\<\< getString (pname \<\$\> mp))
           \<\*\> tr \<\<\< (td \<\< \"enter the price\" \<++ td \<\<\< getInt ( pprice \<\$\> mp)))


\-- Here an example of predefined widget (`Selection`) that return an Int, combined in the same
\-- page with the fromLet for the introduction of a product.
\-- The result of the user interaction is Either one or the other value

shopProds :: V.Vector Int -\> [Prod]
          -\> 'View' Html IO  (Either Int Prod)
shopProds cart products=

  p \<\< \"\--\--\--\--\--\--\--\--Shopping List\--\--\--\--\--\--\--\"
  \<++
  widget(Selection{
       stitle = bold \<\< \"choose an item\",
       sheader= [ bold \<\< \"item\"   , bold \<\< \"price\", bold \<\< \"times chosen\"],
       sbody= [([toHtml pname, toHtml \$ show pprice, toHtml \$ show \$ cart V.! i],i )
              | (Prod{..},i ) \<- zip products [1..]]})

  \<+\>
  p \<\< \"\--\--\--\--\--\--\--Add a new product \--\--\--\--\--\--\---\"
  \<++
  table \<\<\< (tr \<\<\< td ! [valign \"top\"]
                          \<\<\< widget (Form (Nothing :: Maybe Prod) )
             ++\>
             tr \<\< td ! [align \"center\"]
                          \<\< hotlink  \"hello\"
                                      (bold \<\< \"Hello World\"))

\-- the header

appheader user forms= thehtml
         \<\< body \<\< dlist \<\< (concatHtml
            [dterm \<\<(\"Hi \"++ user)
            ,dterm \<\< \"This example contains two forms enclosed within user defined HTML formatting\"
            ,dterm \<\< \"The first one is defined as a Widget, the second is a formlet formatted within a table\"
            ,dterm \<\< \"both are defined using an extension of the FormLets concept\"
            ,dterm \<\< \"the form results are statically typed\"
            ,dterm \<\< \"The state is implicitly logged. No explicit handling of state\"
            ,dterm \<\< \"The program logic is written as a procedure. Not    in request-response form. But request response is possible\"
            ,dterm \<\< \"lifespan of the serving process and the execution state defined by the programmer\"
            ,dterm \<\< \"user state is  automatically recovered after cold re-start\"
            ,dterm \<\< \"transient, non persistent states possible.\"
            ])
            +++ forms

\-- Here the procedure. It ask for either entering a new product
\-- or to \"buy\" one of the entered products.
\-- There is a timeout of ten minutes before the process is stopped
\-- THERE IS A timeout of one day for the whole state so after this, the
\-- user will see the list erased.
\-- The state is user specific.

\--mainProds ::  FlowM Html (Workflow IO) ()
mainProds   = do
   setTimeouts (10\*60) (24\*60\*60)
   setHeader \$ \w -\> bold \<\< \"Please enter user/password (pepe/pepe)\" +++ br +++ w


   setHeader  \$ appheader "user"
   mainProds1 [] \$ V.fromList [0]
   where
   mainProds1  prods cart=  do
     mr \<- step . ask  \$ shopProds  cart prods
     case mr of
      Right prod -\> mainProds1  (prod:prods) (V.snoc cart 0)
      Left i   -\> do
         let newCart= cart V.// [(i, cart V.! i + 1 )]
         mainProds1 prods newCart
@

-}

module MFlow.Forms(
{- basic definitions -}
Widget(..),FormLet(..), Launchable(..)
,View, FormInput(..), FormT(..),FormElm(..)
{- widget instances -}
,Form(..),Selection(..)

{- users -}
,userRegister, userAuthenticate, User(userName)
,getUser,
-- * user interaction
ask,
-- * getters to be used in instances of `FormLet` and `Widget` in the Applicative style.

getString,getInt,getInteger
,getMultilineText,getBool,getOption, getPassword,validate
--  * formatting and combining widgets

,mix,wrap,addToForm
-- * running the flow monad
,FlowM,runFlow,MFlow.Forms.step
-- * setting parameters
,setHeader
,setTimeouts
-- * Cookies
,setCookie
) where
import Data.TCache
import Data.Persistent.Queue.Text
import MFlow
import MFlow.Cookies
import Data.RefSerialize (Serialize)
import Control.Workflow.Text as WF
import Data.Typeable
import Data.Monoid
import Control.Monad.State
import Control.Monad.Trans.Maybe
import Control.Applicative
import Control.Exception
import Control.Workflow.Text(exec1,Workflow, waitUntilSTM, step, unsafeIOtoWF)

--import Debug.Trace
--
--(!>)= flip trace


type UserName=  String

data User= User
            { userName :: UserName
            , upassword :: String
            } deriving (Read, Show, Typeable)

eUser= User (error1 "username") (error1 "password")

error1 s= error $ s ++ " undefined"

userPrefix= "User#"
instance Indexable User where
   key User{userName=   user}= userPrefix++user





maybeError  err iox = runMaybeT iox >>= \x ->
  case x of
    Nothing -> error err
    Just x -> return x

-- | register an user/password combination
userRegister :: String -> String  -> IO(DBRef User)
userRegister user password  = atomically .
    newDBRef  $  User  user password

-- | authentication against `userRegister`ed users.
-- to be used with `validate`
userAuthenticate :: MonadIO m =>  User -> m (Maybe String)
userAuthenticate user@User{..} = liftIO $ atomically
     $ withSTMResources [user]
     $ \ mu -> case mu of
         [Nothing] -> resources{toReturn= just }
         [Just (User _ p )] -> resources{toReturn=
               case upassword==p  of
                 True -> Nothing
                 False -> just

               }

     where
     just= Just "Username or password invalid"


type FlowM view = StateT (MFlowState view)

runFlow :: (FormInput view, Monoid view, Monad m)
        => FlowM view m () -> Token -> m ()
runFlow f = \t -> evalStateT f mFlowState0{mfToken=t}

step
  :: (Serialize a,
      MonadIO m,
      Typeable a) =>
      FlowM view m a
      -> FlowM view (Workflow m) a

step f=do
 s <- get
 lift . WF.step $  evalStateT f s






cookieuser= "cookieuser"


instance  (MonadIO m, Functor m, FormInput view) => FormLet User m view where
  digest  muser =
        (User <$>  getString (fmap userName muser)
              <*>  getPassword)
       `validate` userAuthenticate


newtype Lang= Lang String

data MFlowState view= MFlowState{
   mfSequence :: Int,
   mfUser     :: String,
   mfLang     :: Lang,
   mfEnv      :: Params,
--   mfServer   :: String,
--   mfPath     :: String,
--   mfPort     :: Int,

   mfToken    :: Token,
   mfkillTime :: Int,
   mfStateTime :: Integer,
   mfCookies   :: [Cookie],
   mfHeader :: view -> view}



stdHeader v= v

anonymous= "anonymous"
--rAnonUser= getDBRef . key $ eUser{userName=anonymous} :: DBRef User

mFlowState0 :: (FormInput view, Monoid view) => MFlowState view
mFlowState0= MFlowState 0 anonymous (Lang "en") [] undefined 0 0 [] stdHeader

setHeader :: Monad m => (view -> view) -> FlowM view m ()
setHeader header= do
  fs <- get
  put fs{mfHeader= header}

-- | set an HTTP cookie
setCookie :: Monad m
          => String  -- ^ name
          -> String  -- ^ value
          -> String  -- ^ path
          -> Maybe String   -- ^ expires
          -> FlowM view m ()
setCookie n v p me= do
    st <- get
    put st{mfCookies=  (n,v,p,me):mfCookies st }

setTimeouts :: (Monad m)=> Int -> Integer -> FlowM view m ()
setTimeouts kt st= do
 fs <- get
 put fs{ mfkillTime= kt, mfStateTime= st}

-- | Very basic user authentication. The user is stored in a cookie.
-- it looks for the cookie. If no cookie, it ask to the user for a `userRegister`ed
-- user-password combination. It return a reference to the user.

getUser :: ( FormInput view, Monoid view, Typeable view
           , ConvertTo (HttpData view) display, Typeable display
           , MonadIO m, Functor m)
          => FlowM view m String
getUser = do

   rus <-  gets mfUser
   case  rus ==  anonymous of
     False -> return rus
     True   -> do
       env <- do
              env <- gets mfEnv
              if null env then receiveWithTimeouts>> gets mfEnv
                          else return env
       ref <- case lookup cookieuser  env  of
            Nothing -> do
                 us <- ask (Form (Nothing :: Maybe User))
                 ref <- liftIO . atomically $ newDBRef  us
                 setCookie cookieuser  (userName us) "/" Nothing
                 get >>= \s -> liftIO $ print (mfCookies s)
                 return $ userName us
            Just usname -> return usname
--       modify $ \s -> s{mfUser= ref}F
       return  ref

-- | Launchable widgets create user requests. For example whatever piece containing
-- a Form tag, a link with an embeeded Ajax invocation  etc.
--
-- A FormLet for an input field can not be an instance of Launchable, for example
-- to invoke it with ask, make the widget an instance of Launchable
class Widget a b m view => Launchable a b m view


instance   (MonadIO m, Functor m)
           => Widget(View view m a) a m view where
    widget =  id

instance (MonadIO m, Functor m)
           => Launchable (View view m a) a m view


-- | join two widgets in the same pages
-- the resulting widget, when `ask`ed with it, returns a either one or the other
mix ::  ( FormInput view , Monad m)
      => View view m a'
      -> View view m b'
      -> View view m (Either a' b')
mix digest1 digest2= FormT $ \env -> do
  FormElm f1 mx' <- (runFormT  $ digest1) env
  FormElm f2 my' <- (runFormT  $ digest2) env
  return $ FormElm (f1++f2)
         $ case (mx',my') of
              (Nothing, Nothing) -> Nothing
              (Just x,Nothing)   -> Just $ Left x
              (Nothing,Just x)   -> Just $ Right x
              (Just _,Just _)    -> error "malformed getters in widget combination"

-- | it is the way to interact with the user.
-- It takes a combination of `launchable` objects and return the user result
-- in the FlowM monad
ask
  ::  ( Launchable a b m view
      , FormInput view, Monoid view
      , Typeable view, ConvertTo (HttpData view) display
      , Typeable display )
     => a -> FlowM view m b
ask mx   = do
     st <- get
     let t= mfToken st
     FormElm forms mx' <- generateForm mx
     case mx' of
       Just x -> return  x
       _ -> do
         let header= mfHeader st
         liftIO . sendFlush t $ HttpData (mfCookies st) (header $ mconcat forms)
         put st{mfCookies=[]}
         receiveWithTimeouts
         ask  mx




receiveWithTimeouts :: MonadIO m => FlowM view m ()
receiveWithTimeouts= do
         st <- get
         let t= mfToken st
             t1= mfkillTime st
             t2= mfStateTime st
         req <- return . getParams =<< liftIO ( receiveReqTimeout t1 t2 t)
         put st{mfEnv= req}


data Selection a view= Selection{stitle:: view, sheader :: [view] , sbody :: [([view],a)]}

instance (MonadIO m, Functor m, FormInput view, Typeable a, Show a, Read a, Eq a)
         => Launchable (Selection a view) a m view

instance (MonadIO m, Functor m
         ,FormInput view, Read a , Show a, Eq a, Typeable a)
          => Widget (Selection a view) a m view where
  widget Selection {..} =FormT(\env -> do
    t <- fmap mfToken get
    let mn = getParam1 "select" env

        toSend = fformAction (twfname t) . ftable stitle sheader $
                   map(\(vs,x) -> vs ++ [finput "select" "radio"  (show x)
                   ( Just x== mn) (Just "this.form.submit()")] ) sbody
    return $ FormElm [toSend] mn)

--
--data Link  view =  Link  view (FlowM view (Workflow IO) ())
--
--instance ( FormInput view, Monoid view)
--         => Launchable (Link view ) () IO view
--
--instance (FormInput view, Monoid view)
--          => Widget (Link view ) () IO view where
--   widget (Link  v f) = FormT $ \ env -> do
--     n <- getnewname
--
--     let render= FormElm [flink (Verb n ) v]
--     case getParam1 n env :: Maybe String of
--               Nothing -> return ()
--               Just _  -> do
--                     token <-  liftIO $ getToken (n,env)
--                     liftIO $ forkIO  $ exec verb (runFlow f) token
--                     return()
--     return $ render Nothing
--
--instance Processable (String, Params)  where
--   pwfname  (pwfname, env)=  pwfname
--   puser (_,env) = case lookup "cookieuser"  env of
--                                Nothing -> "nouser"
--                                Just user -> user
--   pind (_,env)= case lookup "flow"  env of
--                                Nothing -> error ": No FlowID"
--                                Just fl -> fl
--   getParams (_,env)=  env
--
--

--data LocalLink  view =  LocalLink  view (FlowM view IO ())
--
--
--
--instance (MonadIO m, Functor m,FormInput view, Monoid view)
--         => Launchable (LocalLink view )  String m view
--
--instance (MonadIO m,Functor m,FormInput view, Monoid view)
--          => Widget (LocalLink view ) String m view where
--   widget (LocalLink  v f) = FormT $ \ env -> do
--     t <- fmap mfToken get
--     let verb= twfname t
--     widget $ Link verb v (transient f)



newtype Form  a= Form a

instance (FormInput view, Monoid view, Widget a b m view)
          => Launchable (Form a)  b m view

instance  (FormInput view, Monoid view, Widget a b m view)
          => Widget (Form a)  b m view
      where
      widget (Form x) = FormT $ \env -> do
         FormElm form mr <- (runFormT  $  widget x ) env
         t <- fmap  mfToken  get
         let form1= fformAction (twfname t) . mconcat
                     $ form
                     ++ [finput "reset" "reset" "Reset" False Nothing
                        ,finput "submit" "submit" "Submit" False Nothing]

         return $ FormElm [form1] mr



data FormElm view a = FormElm [view] (Maybe a)


newtype FormT view m a = FormT { runFormT :: Params  -> m (FormElm view a) }

instance Functor (FormElm view ) where
  fmap f (FormElm form x)= FormElm form (fmap f x)

instance Functor m => Functor (FormT view m) where
  fmap f = FormT .(\env -> fmap (fmap f) . (runFormT env) )

instance (Functor m, Monad m) => Applicative (FormT view m) where
  pure a  = FormT $ \env -> return (FormElm  [] $ Just a)
  FormT f <*> FormT g= FormT $ \env ->
                   f env >>= \(FormElm form1 k) ->
                   g env >>= \(FormElm form2 x) ->
                   return (FormElm (form1 ++ form2) (k <*> x))

instance  (Monad m, Functor m) => Monad (FormT view m) where
    x >>= f = join $ fmap f x
    return= pure

type View view m a= FormT view (FlowM view m)  a

-- a FormLet instance
class (Functor m, MonadIO m) => FormLet  a  m view  where
   digest :: Maybe a
      --    -> Validate m a
          -> View view m a


class (Functor m, MonadIO m) => Widget  a b m view |  a -> view where
   widget ::  a
  --        -> Validate m b
          -> View view m b



instance FormLet  a m view => Widget (Maybe a) a m view  where
   widget = digest


-- | Validates a form or widget result against a validating procedure
--
-- getOdd= getInt Nothing `validate` (\x-> return $ if mod x 2==0 then  Nothing else Just "only odd number please")

validate
  :: (FormInput view,
      Functor m, MonadIO m)
     => View view m a
     -> (a -> m (Maybe String))
     -> View view m a
validate  formt val= FormT $ \env ->  do
   FormElm form mx <-  (runFormT  formt) env
   case mx of
    Just x -> do
      me <- lift $ val x
      case me of
         Just str ->do
           --FormElm form mx' <- generateForm [] (Just x) noValidate
           return $ FormElm ( inred (fromString str) : form) Nothing
         Nothing  -> return $ FormElm [] mx
    _ -> return $ FormElm form mx

generateForm
  :: (Widget a b m view, FormInput view ) =>
       a ->  FlowM view m (FormElm view b)
generateForm  mx  = do
     st <- get
     (runFormT  $  widget mx ) $ mfEnv st
--     lift $ evalStateT
--           ((runFormT  $  digest mx val) $ mfEnv st)
--           st



instance (FormInput view, FormLet a m view , FormLet b m view )
          => FormLet (a,b) m view  where
  digest  mxy  = do
      let (x,y)= case mxy of Nothing -> (Nothing, Nothing); Just (x,y)-> (Just x, Just y)
      (,) <$> digest x   <*> digest  y

instance (FormInput view, FormLet a m view , FormLet b m view,FormLet c m view )
          => FormLet (a,b,c) m view  where
  digest  mxy  = do
      let (x,y,z)= case mxy of Nothing -> (Nothing, Nothing, Nothing); Just (x,y,z)-> (Just x, Just y,Just z)
      (,,) <$> digest x  <*> digest  y  <*> digest  z



--
--
--instance  (MonadIO m, Functor m, FormInput view) => FormLet Verb m view where
--     digest  _ = FormT $ \env ->  return $ case getParam1 "verb" env of
--       Nothing -> error "digst: verb not found"
--       Just x  -> FormElm [] . Just $ Verb x
--






getString  :: (FormInput view,Monad m) =>
     Maybe String -> View view m String
getString = getElem

getInteger :: (FormInput view, Functor m, MonadIO m) =>
     Maybe Integer -> View view m  Integer
getInteger =  getElem

getInt :: (FormInput view, Functor m, MonadIO m) =>
     Maybe Int -> View view m Int
getInt =  getElem

getPassword :: (FormInput view,
     Monad m) =>
     View view m String
getPassword = getParam Nothing "password" (Just "enter password")


getElem
  :: (FormInput view,
      Monad  m,
      Typeable a,
      Show a,
      Read a) =>
     Maybe a ->  View view m a
getElem ms  = getParam Nothing "text" ms


getParam
  :: (FormInput view,
      Monad m,
      Typeable a,
      Show a,
      Read a) =>
     Maybe String -> String -> Maybe a -> View view m  a
getParam look type1 mvalue = FormT $ \env -> do
    tolook <- case look of
       Nothing  -> getnewname
       Just n -> return n
    let nvalue= case mvalue of
           Nothing  -> ""
           Just v   -> show v
        form= [finput tolook type1  nvalue False Nothing]
    case getParam1 tolook env of
       Nothing ->  return $ FormElm form Nothing
       justx ->    return $ FormElm form justx
--        do
--         me <- lift $ val justx
--         case me of
--           Nothing  -> return $ FormElm [] justx
--           Just str -> return $ FormElm [bold $ fromString str,input tolook type1  nvalue False] Nothing

getnewname :: Monad m => FlowM view m String
getnewname= do
      st <- get
      let n= mfSequence st
      put $ st{mfSequence= n+1}
      return $  "Parm"++show n

getMultilineText :: (FormInput view,
      Monad m) =>
      Maybe [Char] ->  View view m String
getMultilineText mt = FormT $ \env -> do
    tolook <- getnewname

    let nvalue= case mt of
           Nothing  -> ""
           Just v -> show v
    case (getParam1 tolook env, mt) of
       (Nothing, Nothing) -> return $ FormElm [ftextarea tolook nvalue] Nothing
       (Nothing, Just v)  -> return $ FormElm [] $ Just v
       (justx,_) -> return $ FormElm [] justx

instance  (MonadIO m, Functor m, FormInput view) => FormLet Bool m view where
   digest mv =  getBool b "True" "False"
       where
       b= case mv of
           Nothing -> Nothing
           Just bool -> Just $ show bool

getBool :: (FormInput view,
      Monad m) =>
      Maybe String -> String -> String -> View view m Bool
getBool mv truestr falsestr= FormT $ \env -> do
    tolook <- getnewname
    case (getParam1 tolook env, mv) of
       (Nothing, Nothing) ->  return $ FormElm [foption1 tolook [truestr,falsestr] mv] Nothing
       (Nothing,Just x)   ->  return . FormElm [] . Just $ fromstr  x
       (Just x,_)         ->  return . FormElm [] . Just $ fromstr x
    where
    fromstr x= if x== truestr then True else False

getOption :: (FormInput view,
      Monad m) =>
      Maybe String ->[(String,String)] ->  View view m  String
getOption mv strings = FormT $ \env -> do
    tolook <- getnewname
    case (getParam1 tolook env, mv) of
       (Nothing, Nothing) ->  return $ FormElm [foption tolook strings mv] Nothing
       (Nothing,Just x)   ->  return . FormElm [] $ Just  x
       (justx,_) -> return $ FormElm [] justx


-- | encloses instances of `Widget` or `FormLet` in formating
-- view is intended to be instantiated to a particular format
-- see "MFlow.Forms.XHtml" for usage examples
wrap :: (Monad m, FormInput view, Monoid view)
          => (view ->view)
         -> View view m a
         -> View view m a
wrap v form= FormT $ \env -> do
  FormElm f mx <- runFormT form env
  return $ FormElm [v $ mconcat f] mx

-- | append formatting to  `Widget` or `FormLet` instances
-- view is intended to be instantiated to a particular format
-- see "MFlow.Forms.XHtml" for usage examples
addToForm :: (Monad m, FormInput view, Monoid view)
          => View view m a
          -> view
         -> View view m a
addToForm form v= FormT $ \env -> do
  FormElm f mx <- runFormT form env
  return $ FormElm (f++[v]) mx



type Name= String
type Type= String
type Value= String
type Checked= Bool
type OnClick= Maybe String


-- | Minimal interface for defining the abstract basic form combinators
-- defined in this module. see "MFlow.Forms.XHtml" for the instance for "Text.XHtml"
-- format
class FormInput view where
--    column :: [view] -> view
--    column columns= table (fromString "") [] [columns]
--    row    :: [view] -> view

    inred   :: view -> view
--    fs :: view -> view
--    ts :: view -> view

    ftable:: view -> [view] ->  [[view]] -> view
--    hsep   :: view
--    vsep   :: view
--    style :: String -> view -> view

    fromString :: String -> view
    flink ::  String -> view -> view

    flink1:: String -> view
    flink1 verb = flink verb (fromString verb)


    finput :: Name -> Type -> Value -> Checked -> OnClick -> view
    ftextarea :: String -> String -> view
    foption :: String -> [(String,String)] -> Maybe String -> view
    foption1 :: String -> [String] -> Maybe String -> view
    foption1  name list msel= foption name (zip list list) msel

    fformAction :: String -> view -> view