module Ideas.Encoding.ModeXML (processXML) where
import Control.Exception
import Control.Monad
import Data.Monoid
import Ideas.Common.Library hiding (exerciseId)
import Ideas.Encoding.DecoderXML
import Ideas.Encoding.EncoderHTML
import Ideas.Encoding.EncoderXML
import Ideas.Encoding.Evaluator
import Ideas.Encoding.Logging (changeLog, errormsg)
import Ideas.Encoding.Options (Options, makeOptions, maxTime, cgiBin, logRef)
import Ideas.Encoding.Request
import Ideas.Service.DomainReasoner
import Ideas.Text.HTML
import Ideas.Text.XML
import Ideas.Utils.Prelude (timedSeconds)
import System.IO.Error
processXML :: Options -> DomainReasoner -> String -> IO (Request, String, String)
processXML options dr txt = do
xml <- either fail return (parseXML txt)
req <- xmlRequest (cgiBin options) xml
resp <- maybe id timedSeconds (maxTime options) (xmlReply options dr req xml)
`catch` handler
let showXML | compactOutput req = compactXML
| otherwise = prettyXML
showHtmlDoc doc = "<!DOCTYPE html>" ++ compactXML doc
if htmlOutput req
then return (req, showHtmlDoc resp, "text/html")
else let out = addVersion (version dr) resp
in return (req, showXML out, "application/xml")
where
handler :: SomeException -> IO XML
handler e = resultError options $
case fromException e of
Just ioe -> ioeGetErrorString ioe
Nothing -> show e
addVersion :: String -> XML -> XML
addVersion s xml =
let info = [ "version" := s ]
in xml { attributes = attributes xml ++ info }
xmlRequest :: Monad m => Maybe String -> XML -> m Request
xmlRequest ms xml = do
unless (name xml == "request") $
fail "expected xml tag request"
enc <- case findAttribute "encoding" xml of
Just s -> readEncoding s
Nothing -> return []
return mempty
{ serviceId = newId <$> findAttribute "service" xml
, exerciseId = extractExerciseId xml
, source = findAttribute "source" xml
, cgiBinary = ms
, requestInfo = findAttribute "requestinfo" xml
, logSchema = findAttribute "logging" xml >>= readSchema
, feedbackScript = findAttribute "script" xml
, randomSeed = defaultSeed ms $
findAttribute "randomseed" xml >>= readM
, dataformat = Just XML
, encoding = enc
}
defaultSeed :: Maybe String -> Maybe Int -> Maybe Int
defaultSeed Nothing Nothing = Just 2805
defaultSeed _ m = m
xmlReply :: Options -> DomainReasoner -> Request -> XML -> IO XML
xmlReply opt1 dr request xml = do
srv <- case serviceId request of
Just a -> findService dr a
Nothing -> fail "No service"
Some ex <- case exerciseId request of
Just a -> findExercise dr a
Nothing -> return (Some emptyExercise)
opt2 <- makeOptions dr request
let options = opt1 <> opt2
if htmlOutput request
then toXML <$> evalService ex options (htmlEvaluator dr) srv xml
else resultOk <$> evalService ex options xmlEvaluator srv xml
extractExerciseId :: Monad m => XML -> m Id
extractExerciseId = fmap newId . findAttribute "exerciseid"
resultOk :: XMLBuilder -> XML
resultOk body = makeXML "reply" $
("result" .=. "ok")
<> body
resultError :: Options -> String -> IO XML
resultError options msg = do
changeLog (logRef options) (\r -> r {errormsg = msg})
return $ makeXML "reply" $
("result" .=. "error")
<> tag "message" (string msg)
xmlEvaluator :: Evaluator a XML XMLBuilder
xmlEvaluator = Evaluator xmlDecoder xmlEncoder
htmlEvaluator :: DomainReasoner -> Evaluator a XML HTMLPage
htmlEvaluator dr = Evaluator xmlDecoder (htmlEncoder dr)