{-# LANGUAGE  UndecidableInstances
             , TypeSynonymInstances
             , MultiParamTypeClasses
             , DeriveDataTypeable
             , FlexibleInstances #-}
             
module MFlow.Hack(
     module MFlow.Cookies
    ,module MFlow
    ,hackMessageFlow)
where

import Data.Typeable
import Hack

import Control.Concurrent.MVar(modifyMVar_, readMVar)
import Control.Monad(when)


import Data.ByteString.Lazy.Char8 as B(pack, unpack, length, ByteString)
import Control.Concurrent(ThreadId(..))
import System.IO.Unsafe
import Control.Concurrent.MVar
import Control.Exception
import qualified Data.Map as M

import Data.TCache

import Control.Workflow.Text

import MFlow
import MFlow.Cookies
import MFlow.Hack.Response

import Data.Monoid

--(!>)= flip trace

assocList ->> k = getParam1 assocList k

instance Processable Env  where
   pwfname  env=  if null sc then "noscript" else sc
      where
      sc=  tail $ pathInfo env -- takeWhile (/= '?') $ queryString env
   puser env = case lookup "cookieuser" $ http env of
                                Nothing -> "nouser"
                                Just user -> user
   pind env= case lookup "flow" $ http env of
                                Nothing -> error ": No FlowID"
                                Just fl -> fl
   getParams env= http env
--   getServer env= serverName env
--   getPath env= pathInfo env
--   getPort env= serverPort env
   
data Flow= Flow !Int deriving (Read, Show, Typeable)


instance Indexable Flow where
  key _= "Flow"


newFlow= do
        fl <- atomically $ do
                    withSTMResources [Flow undefined] $
                       \m -> 
                           let
                               (add, ret)= case m of
                                  [Just (Flow n)] -> ([Flow $ n+1],n)
                                  [Nothing]  -> ([Flow 1],0)
                           in resources{toAdd=add, toReturn= ret}

        return $ show fl

---------------------------------------------




instance ConvertTo String TResp  where
      convert = TResp . pack

instance ConvertTo ByteString TResp  where
      convert = TResp

--instance ConvertTo Response TResp where
--      convert= TResp
--
instance ConvertTo Error TResp where
     convert (Error e)= TResp $ pack  e

instance ToResponse v =>ConvertTo (HttpData v) TResp where
    convert= TRespR
--
--instance Typeable (HSP XML) where
--     typeOf = \_ -> mkTyConApp (mkTyCon "HSP") [mkTyConApp ( mkTyCon "XML") []]
--
--
--
--instance ConvertTo (HSP XML) TResp where
--  convert xml=unsafePerformIO $ do
--       (_,html) <- evalHSP Nothing xml
--       return . TResp . pack $ renderAsHTML html
--
--
--
--instance Typeable X.Html where
--     typeOf =  \_ -> mkTyConApp (mkTyCon "Text.XHtml.Transitional.Html") []
--
--
--
--
--
--instance ConvertTo X.Html TResp where
--  convert = TResp  . pack  . X.showHtml
--

webScheduler   :: --  (Typeable c, ToResponse c)  =>
                   Env
               -> ProcList
               -> IO (TResp, ThreadId)
webScheduler = msgScheduler 

eitherToError (Right x)= x
eitherToError (Left e)= error $ "eitherToError " ++ show e

--theDir= unsafePerformIO getCurrentDirectory

wFMiddleware :: (Env -> Bool) -> (Env-> IO Response) ->   (Env -> IO Response)
wFMiddleware filter f = \ env ->  if filter env then hackWorkflow env  else f env

-- | An instance of the abstract "MFlow" scheduler to the Hack interface
-- it accept the list of processes being scheduled and return a hack handler
--
-- Example:
--
-- @main= do
--
--   putStrLn $ options messageFlows
--   'run' 80 $ 'hackMessageFlow' messageFlows
--   where
--   messageFlows=  [(\"main\",  'runFlow' flowname )
--                  ,(\"hello\", 'stateless' statelesproc)
--                  ,(\"trans\", 'transient' $ runflow transientflow]
--   options msgs= \"in the browser choose\\n\\n\" ++
--     concat [ "http:\/\/server\/"++ i ++ "\n" | (i,_) \<- msgs]
-- @
hackMessageFlow :: ProcList ->  (Env -> IO Response)
hackMessageFlow messageFlows = 
 unsafePerformIO (addMessageFlows messageFlows) `seq`
 wFMiddleware (\env ->  (pwfname env) `elem` paths)
              (\env -> defaultResponse $   "usage: http//server/" ++ show paths ++ "?verb")
 where
 (paths,_)= unzip messageFlows

splitPath ""= ("","","")
splitPath str=
       let
            strr= reverse str
            (ext, rest)= span (/= '.') strr
            (mod, path)= span(/='/') $ tail rest
       in   (tail $ reverse path, reverse mod, reverse ext)



hackWorkflow  ::  Env ->  IO Response
hackWorkflow req1=   do

  
     let httpreq1= http  req1 -- !> (show req1)
     let cookies= getCookies httpreq1

     (flow , retcookies) <-  case lookup "flow" cookies of
              Just fl -> return  (fl, [])
              Nothing  -> do
                     fl <- newFlow
                     return (fl,  [("flow",  fl, "/",Nothing)])
{-   
     putStateCookie req1 cookies
     let retcookies= case getStateCookie req1 of
                                Nothing -> retcookies1
                                Just ck -> ck:retcookies1
-}

     let [(input, str)]=
           case  ( requestMethod req1, lookup  "Content-Type" httpreq1 )  of
              (POST,Just "application/x-www-form-urlencoded") -> urlDecode  .  unpack  .  hackInput $ req1 
              (GET, _) ->   urlDecode  .  queryString $ req1
              _ -> [([("","")],"")]


     let req = case retcookies of
          [] -> req1{http= input ++ cookies ++ http req1}   -- !> "REQ"
          _  -> req1{http= ("flow", flow): input ++ cookies ++ http req1}   -- !> "REQ"

     wfs <- getMessageFlows  
     (resp',th) <- webScheduler  req  wfs


     let resp''= toResponse resp'
     let headers1= case retcookies of [] -> headers resp''; _ -> ctype : cookieHeaders retcookies
     let resp =   resp''{status=200, headers= headers1 {-,("Content-Length",show $ B.length x) -}}

 
     return resp


------persistent state in cookies (not tested)

tvresources ::  MVar (Maybe ( M.Map string string))
tvresources= unsafePerformIO $ newMVar  Nothing
statCookieName= "stat"

putStateCookie req cookies=
    case lookup statCookieName cookies of
        Nothing -> return ()
        Just (statCookieName,  str , "/", _) -> modifyMVar_ tvresources $
                          \mmap -> case mmap of
                              Just map ->  return $ Just $ M.insert (keyResource req)  str map
                              Nothing   -> return $ Just $ M.fromList [((keyResource req),  str) ]

getStateCookie req= do
    mr<- readMVar tvresources
    case mr of
     Nothing  ->  return Nothing
     Just map -> case  M.lookup (keyResource req) map  of
      Nothing -> return Nothing
      Just str -> do
        swapMVar tvresources Nothing
        return $  Just  (statCookieName,  str , "/")

{-
persistInCookies= setPersist  PersistStat{readStat=readResource, writeStat=writeResource, deleteStat=deleteResource}
    where
    writeResource stat= modifyMVar_ tvresources $  \mmap -> 
                                      case mmap of
                                            Just map-> return $ Just $ M.insert (keyResource stat) (serialize stat) map
                                            Nothing -> return $ Just $ M.fromList [((keyResource stat),   (serialize stat)) ]
    readResource stat= do
           mstr <- withMVar tvresources $ \mmap -> 
                                case mmap of
                                   Just map -> return $ M.lookup (keyResource stat) map
                                   Nothing -> return  Nothing
           case mstr of
             Nothing -> return Nothing
             Just str -> return $ deserialize str

    deleteResource stat= modifyMVar_ tvresources $  \mmap-> 
                              case mmap of
                                  Just map -> return $ Just $ M.delete  (keyResource stat) map
                                  Nothing ->  return $ Nothing

-}
-- | Users
--
--instance Display  String TResp where
--    column vs= concat ["<tr>" ++ v ++"</tr>" | v <- vs]
--    row vs= concat ["<td>" ++ v ++ "</td>" | v <- vs]
--    hsep = "$nbsp;"
--    vsep = "<br/>"
--    input n t v f= "<input type=\""++ t ++"\" name=\""++n++"\" value=\""++v++"\" "++ if f then "checked " else "" ++"/>"
--    textarea name text= "<textarea name=\""++ name++"\">"++ text ++"</textarea>"
--
--    option name list msel=  "<select name=\""++ name ++"\">"++
--            concatMap (\(n,v) -> "<option value=\""++ n ++ selected msel n ++">"++ v ++ "</option>") list ++
--            "</select>"
--            where
--            selected msel n= if Just n == msel then " \"selected\" " else ""
--
--    option1  name list msel=  "<select name=\""++ name ++"\">"++
--            concatMap (\v -> "<option" ++ selected msel v ++">"++ v ++ "</option>") list ++
--            "</select>"
--            where
--            selected msel n= if Just n == msel then " \"selected\" " else ""
--
--
--
--    formAction action form = "<form action=\""++action++"\" method=\"post\">"++ form ++ input "cancel" "button" "cancel" False++ input "submit" "submit" "submit" False ++ "</form>"
--    fromString s= s
--    bold x= "<b>" ++ x ++ "</b>"
--    fs x= "<h3>" ++ x ++ "</h3>"
--    ts  x= "<h4>" ++ x ++ "</h4>"
--    style st content = "<span style="++ st++"> "++  content ++"</span>"
--
--    table title head rows=
--          "<table>"++
--            (if not . null $ title then "<caption> " ++ title ++ " </caption>" else "") ++
--            (if not . null $ head then "<tr>"++concat ["<th>"++ h ++ "</th>"| h <- head] ++ "</tr>" else "")++
--            (concat ["<tr>" ++ concat["<td>"++ v ++ "</td>"| v <- row] ++ "</tr>" | row <- rows]) ++
--          "</table>"
--
--
----    textarea name value= "<texyarea name=\""++name++"\" rows=\"20\" cols="65" warp=\"true\">"++value++ "</textarea>"
----    option1 name options option=
----       "< input type=\"radio\" checked=\""++option++"\"  name=\""++name++"\" value="approbal"
--
--
--    link (Verb v) str = "<a href="++v++">"++ str ++"</a>"


{-

instance Monoid (HSP XML) where
    mempty =   <span/>
    mappend x y= <span> <% x %> <% y %> </span>

instance Display (HSP XML) TResp  where
    column  vs= <table><td><%  [<tr> <% v %> </tr> | v <- vs] %></td></table>
    row vs= <tr> <%  [<td> <% v %> </td> | v <- vs] %> </tr>

    table title caption rows=
        <table>
            {- <% when (not . null $ title) -} <caption><% title %> </caption> -- %>
            {-<% when (not . null $ caption)-} <tr> <%[<th> <%cap %> </th>| cap <- caption] %></tr> -- %>
            <%[<tr> <% [<td><% v %></td>| v <- row] %> </tr> | row <- rows] %>
        </table>

    hsep = <span> &nbsp; </span>
    style st content = <span style=(st)> <% content %> </span>
    vsep = <br/>
    fromString s =   <span><% s %></span>
    -- option  (Verb v) view1= <a href = (v)><%  view1 %>  </a>

    input typ name value= <input type= (typ) name=(name) value=(value)/>


-}