module WASH.CGI.TransactionUtil
(withCGI, withTCGI, Control (..))
where
import qualified WASH.CGI.BaseCombinators as B
import qualified WASH.CGI.HTMLWrapper as H hiding (map,head)
import WASH.CGI.CGIMonad
import WASH.CGI.LogEntry
import IO
import WASH.CGI.TCGI
onStack :: String -> [PARAMETER] -> Bool
onStack stid parms =
any h parms
where
h (PAR_TRANS stid') = stid' == stid
h _ = False
popTo :: String -> [PARAMETER] -> [PARAMETER]
popTo stid parms =
g parms
where
g [] = error "popTo did not find its transaction mark"
g (PAR_TRANS stid' : rest) | stid' == stid = rest
g (_ : rest) = popTo stid rest
splitTo :: String -> [PARAMETER] -> ([PARAMETER], [PARAMETER])
splitTo stid parms =
g parms
where
g [] = error "splitTo did not find its transaction mark"
g (mark@(PAR_TRANS stid') : rest) | stid' == stid =
([mark], rest)
g (entry : rest) =
let (prefix, rest') = splitTo stid rest in
(entry : prefix, rest')
applyTo :: String -> ([PARAMETER] -> [PARAMETER]) -> ([PARAMETER] -> [PARAMETER])
applyTo stid trafo parms =
g parms []
where
g [] _ = error "applyTo did not find its transaction mark"
g (mark@(PAR_TRANS stid') : rest) acc | stid' == stid =
reverse (trafo (mark : acc)) ++rest
g (entry : rest) acc =
g rest (entry : acc)
data Control cgi result =
Control { abandon :: result -> cgi ()
, setFail :: result -> cgi ()
, setCommit :: result -> cgi ()
}
with :: (CGIMonad cgi, Read result, Show result) =>
([PARAMETER] -> IO Bool)
-> result
-> (result -> cgi ())
-> (Control (TCGI result) result -> (TCGI result) ())
-> cgi ()
with commitFromLog result onResult fun =
wrapCGI (\cgistate ->
let abandon stid res =
wrapCGI (\cgistate -> ioError (userError (shows stid $ show res)))
setFail stid res =
B.once $
wrapCGI (\cgistate ->
let out = outparm cgistate
out' = applyTo stid onFail out
onFail (pmark : pfail : psucc : rest) =
(pmark : PAR_RESULT (show res) : psucc : rest)
in
return ((), cgistate { outparm = out' })
)
setCommit stid res =
B.once $
wrapCGI (\cgistate ->
let out = outparm cgistate
out' = applyTo stid onSucc out
onSucc (pmark : pfail : psucc : rest) =
(pmark : pfail : PAR_RESULT (show res) : rest)
in
return ((), cgistate { outparm = out' })
)
control stid =
Control { abandon = abandon stid
, setFail = setFail stid
, setCommit = setCommit stid
}
run stid cgistate =
do lr <- try (unwrapCGI (fun (control stid)) cgistate)
case lr of
Right (v, cgistate') ->
let out = outparm cgistate'
(prefix, outparm') = splitTo stid out
PAR_TRANS _ :
failp@(PAR_RESULT failString) :
succp@(PAR_RESULT succString) : _ = reverse prefix
in
do committed <- commitFromLog prefix
if committed then
unwrapCGI (onResult (read succString))
cgistate' { outparm = succp : outparm' }
else
unwrapCGI (onResult (read failString))
cgistate' { outparm = failp : outparm' }
Left err ->
case reads (ioeGetErrorString err) of
(stid', rest) : _ | stid' == stid ->
let result = read rest
newvalue = PAR_RESULT rest
out' = popTo stid (outparm cgistate)
in
unwrapCGI (onResult result)
cgistate { inparm = []
, outparm = newvalue : out'
, stateID = nextstid stid newvalue
}
_ ->
ioError err
in
case inparm cgistate of
[] ->
let stid = stateID cgistate
newmark = PAR_TRANS stid
newvalue = PAR_RESULT (show result)
in
run stid cgistate
{ outparm = newvalue : newvalue : newmark : outparm cgistate
, stateID = nextstid (nextstid (nextstid stid newmark) newvalue) newvalue }
PAR_TRANS stid : PAR_RESULT failString : PAR_RESULT successString : rest ->
run stid cgistate { inparm = rest }
PAR_RESULT str : rest ->
unwrapCGI (onResult (read str)) cgistate { inparm = rest }
_ ->
B.reportError "Out of sync" H.empty cgistate
)
withCGI :: (Read result, Show result) =>
([PARAMETER] -> IO Bool)
-> result
-> (result -> CGI ())
-> (Control (TCGI result) result -> (TCGI result) ())
-> CGI ()
withCGI commitFromLog result onResult fun =
wrapCGI (\cgistate ->
let abandon stid res =
wrapCGI (\cgistate -> ioError (userError (shows stid $ show res)))
setFail stid res =
B.once $
wrapCGI (\cgistate ->
let out = outparm cgistate
out' = applyTo stid onFail out
onFail (pmark : pfail : psucc : rest) =
(pmark : PAR_RESULT (show res) : psucc : rest)
in
return ((), cgistate { outparm = out' })
)
setCommit stid res =
B.once $
wrapCGI (\cgistate ->
let out = outparm cgistate
out' = applyTo stid onSucc out
onSucc (pmark : pfail : psucc : rest) =
(pmark : pfail : PAR_RESULT (show res) : rest)
in
return ((), cgistate { outparm = out' })
)
control stid =
Control { abandon = abandon stid
, setFail = setFail stid
, setCommit = setCommit stid
}
run stid cgistate =
do lr <- try (unwrapCGI (fun (control stid)) cgistate)
case lr of
Right (v, cgistate') ->
let out = outparm cgistate'
(prefix, outparm') = splitTo stid out
PAR_TRANS _ :
failp@(PAR_RESULT failString) :
succp@(PAR_RESULT succString) : _ = reverse prefix
in
do committed <- commitFromLog prefix
if committed then
unwrapCGI (onResult (read succString))
cgistate' { outparm = succp : outparm' }
else
unwrapCGI (onResult (read failString))
cgistate' { outparm = failp : outparm' }
Left err ->
case reads (ioeGetErrorString err) of
(stid', rest) : _ | stid' == stid ->
let result = read rest
newvalue = PAR_RESULT rest
out' = popTo stid (outparm cgistate)
in
unwrapCGI (onResult result)
cgistate { inparm = []
, outparm = newvalue : out'
, stateID = nextstid stid newvalue
}
_ ->
ioError err
in
case inparm cgistate of
[] ->
let stid = stateID cgistate
newmark = PAR_TRANS stid
newvalue = PAR_RESULT (show result)
in
run stid cgistate
{ outparm = newvalue : newvalue : newmark : outparm cgistate
, stateID = nextstid (nextstid (nextstid stid newmark) newvalue) newvalue }
PAR_TRANS stid : PAR_RESULT failString : PAR_RESULT successString : rest ->
run stid cgistate { inparm = rest }
PAR_RESULT str : rest ->
unwrapCGI (onResult (read str)) cgistate { inparm = rest }
_ ->
B.reportError "Out of sync" H.empty cgistate
)
withTCGI :: (Read result, Show result) =>
([PARAMETER] -> IO Bool)
-> result
-> (result -> TCGI result1 ())
-> (Control (TCGI result) result -> (TCGI result) ())
-> TCGI result1 ()
withTCGI checkIfCommittable result onResult fun =
wrapCGI (\cgistate ->
let abandon stid res =
wrapCGI (\cgistate -> ioError (userError (shows stid $ show res)))
setFail stid res =
B.once $
wrapCGI (\cgistate ->
let out = outparm cgistate
out' = applyTo stid onFail out
onFail (pmark : pfail : psucc : rest) =
(pmark : PAR_RESULT (show res) : psucc : rest)
in
return ((), cgistate { outparm = out' })
)
setCommit stid res =
B.once $
wrapCGI (\cgistate ->
let out = outparm cgistate
out' = applyTo stid onSucc out
onSucc (pmark : pfail : psucc : rest) =
(pmark : pfail : PAR_RESULT (show res) : rest)
in
return ((), cgistate { outparm = out' })
)
control stid =
Control { abandon = abandon stid
, setFail = setFail stid
, setCommit = setCommit stid
}
run stid cgistate =
do lr <- try (unwrapCGI (fun (control stid)) cgistate)
case lr of
Right (v, cgistate') ->
let out = outparm cgistate'
(prefix, outparm') = splitTo stid out
PAR_TRANS _ :
failp@(PAR_RESULT failString) :
succp@(PAR_RESULT succString) : _ = reverse prefix
in
do committed <- checkIfCommittable prefix
if committed then
let marker = PAR_RESULT ""
logentries = [ x | x@(PAR_DB _) <- prefix]
in
unwrapCGI (onResult (read succString))
cgistate' { outparm = succp : logentries ++
marker : outparm' }
else
unwrapCGI (onResult (read failString))
cgistate' { outparm = failp : outparm' }
Left err ->
case reads (ioeGetErrorString err) of
(stid', rest) : _ | stid' == stid ->
let result = read rest
newvalue = PAR_RESULT rest
out' = popTo stid (outparm cgistate)
in
unwrapCGI (onResult result)
cgistate { inparm = []
, outparm = newvalue : out'
, stateID = nextstid stid newvalue
}
_ ->
ioError err
in
case inparm cgistate of
[] ->
let stid = stateID cgistate
newmark = PAR_TRANS stid
newvalue = PAR_RESULT (show result)
in
run stid cgistate
{ outparm = newvalue : newvalue : newmark : outparm cgistate
, stateID = nextstid (nextstid (nextstid stid newmark) newvalue) newvalue }
PAR_TRANS stid : PAR_RESULT failString : PAR_RESULT successString : rest ->
run stid cgistate { inparm = rest }
PAR_RESULT "" : rest ->
let loop (PAR_RESULT str : rest) =
unwrapCGI (onResult (read str)) cgistate { inparm = rest }
loop (PAR_DB _ : rest) =
loop rest
loop _ =
B.reportError "Format error in nested transaction log" H.empty cgistate
in loop rest
PAR_RESULT str : rest ->
unwrapCGI (onResult (read str)) cgistate { inparm = rest }
_ ->
B.reportError "Out of sync" H.empty cgistate
)