module Ideas.Encoding.ModeXML (processXML) where
import Control.Exception
import Control.Monad
import Data.Maybe
import Ideas.Common.Library hiding (exerciseId, (:=))
import Ideas.Common.Utils (Some(..), timedSeconds)
import Ideas.Encoding.DecoderXML
import Ideas.Encoding.EncoderHTML
import Ideas.Encoding.EncoderXML
import Ideas.Encoding.Evaluator
import Ideas.Encoding.LinkManager
import Ideas.Encoding.OpenMathSupport
import Ideas.Service.DomainReasoner
import Ideas.Service.FeedbackScript.Parser (parseScriptSafe)
import Ideas.Service.FeedbackScript.Syntax (Script)
import Ideas.Service.Request
import Ideas.Text.HTML
import Ideas.Text.OpenMath.Object
import Ideas.Text.XML
import Prelude hiding (catch)
import System.IO.Error hiding (catch)
import System.Random (StdGen, newStdGen)
processXML :: Maybe Int -> DomainReasoner -> Maybe String -> String -> IO (Request, String, String)
processXML maxTime dr cgiBin input = do
xml <- either fail return (parseXML input)
req <- either fail return (xmlRequest xml)
resp <- maybe id timedSeconds maxTime (xmlReply dr cgiBin req xml)
`catch` handler
let showXML | compactOutputDefault (isJust cgiBin) req = compactXML
| otherwise = show
if htmlOutput req
then return (req, showXML resp, "text/html")
else let out = addVersion (version dr) resp
in return (req, showXML out, "application/xml")
where
handler :: IOException -> IO XML
handler = return . resultError . ioeGetErrorString
addVersion :: String -> XML -> XML
addVersion s xml =
let info = [ "version" := s ]
in xml { attributes = attributes xml ++ info }
xmlRequest :: XML -> Either String Request
xmlRequest xml = do
unless (name xml == "request") $
fail "expected xml tag request"
srv <- findAttribute "service" xml
let a = extractExerciseId xml
enc <- case findAttribute "encoding" xml of
Just s -> readEncoding s
Nothing -> return []
return Request
{ service = srv
, exerciseId = a
, source = findAttribute "source" xml
, dataformat = XML
, encoding = enc
}
xmlReply :: DomainReasoner -> Maybe String -> Request -> XML -> IO XML
xmlReply dr cgiBin request xml = do
srv <- findService dr (newId (service request))
Some ex <-
case exerciseId request of
Just code -> findExercise dr code
Nothing
| service request `elem` ["exerciselist", "servicelist", "serviceinfo", "index"] ->
return (Some emptyExercise)
| otherwise ->
fail "unknown exercise code"
script <- case findAttribute "script" xml of
Just s -> parseScriptSafe s
Nothing
| getId ex == mempty -> return mempty
| otherwise -> defaultScript dr (getId ex)
stdgen <- newStdGen
if htmlOutput request
then do
res <- evalService (htmlConverter dr cgiBin script ex stdgen xml) srv
return (toXML res)
else if useOpenMath request
then do
res <- evalService (openMathConverter True script ex stdgen xml) srv
return (resultOk res)
else do
res <- evalService (stringFormatConverter script ex stdgen xml) srv
return (resultOk res)
extractExerciseId :: Monad m => XML -> m Id
extractExerciseId = liftM newId . findAttribute "exerciseid"
resultOk :: XMLBuilder -> XML
resultOk body = makeXML "reply" $
("result" .=. "ok")
<> body
resultError :: String -> XML
resultError txt = makeXML "reply" $
("result" .=. "error")
<> tag "message" (string txt)
stringFormatConverter :: Script -> Exercise a -> StdGen -> XML -> Evaluator a XMLBuilder
stringFormatConverter script ex stdgen xml =
Evaluator (runEncoderStateM xmlEncoder xes)
(\tp -> runEncoderStateM (xmlDecoder tp) xds xml)
where
xes = XMLEncoderState ex False (tag "expr" . string . prettyPrinter ex)
xds = XMLDecoderState ex script stdgen False g
g = (liftM getData . findChild "expr") >=> parser ex
htmlConverter :: DomainReasoner -> Maybe String -> Script -> Exercise a -> StdGen -> XML -> Evaluator a HTMLPage
htmlConverter dr cgiBin script ex stdgen xml =
Evaluator (return . htmlEncoder lm dr ex) d
where
lm = maybe staticLinks dynamicLinks cgiBin
Evaluator _ d = stringFormatConverter script ex stdgen xml
openMathConverter :: Bool -> Script -> Exercise a -> StdGen -> XML -> Evaluator a XMLBuilder
openMathConverter withMF script ex stdgen xml =
Evaluator (runEncoderStateM xmlEncoder xes)
(\tp -> runEncoderStateM (xmlDecoder tp) xds xml)
where
xes = XMLEncoderState ex True h
xds = XMLDecoderState ex script stdgen True g
h a = case toOpenMath ex a of
Left _ -> error "Error encoding term in OpenMath"
Right omobj -> builder (toXML (handleMixedFractions omobj))
g xml0 = do
xob <- findChild "OMOBJ" xml0
case xml2omobj xob of
Left msg -> Left msg
Right omobj ->
case fromOpenMath ex omobj of
Just a -> Right a
Nothing -> Left "Invalid OpenMath object for this exercise"
handleMixedFractions = if withMF then id else noMixedFractions