-----------------------------------------------------------------------------
-- Copyright 2018, Ideas project team. This file is distributed under the
-- terms of the Apache License 2.0. For more information, see the files
-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer  :  bastiaan.heeren@ou.nl
-- Stability   :  provisional
-- Portability :  portable (depends on ghc)
--
-- Services using JSON notation
--
-----------------------------------------------------------------------------

module Ideas.Encoding.ModeJSON (processJSON) where

import Control.Monad
import Data.Char
import Data.Maybe
import Data.Semigroup ((<>))
import Ideas.Common.Library hiding (exerciseId)
import Ideas.Encoding.DecoderJSON
import Ideas.Encoding.EncoderJSON
import Ideas.Encoding.Evaluator
import Ideas.Encoding.Logging (LogRef, changeLog, errormsg)
import Ideas.Encoding.Options (Options, makeOptions, maxTime, cgiBin)
import Ideas.Encoding.Request
import Ideas.Service.DomainReasoner
import Ideas.Text.JSON
import Ideas.Utils.Prelude (timedSeconds)

processJSON :: Options -> DomainReasoner -> LogRef -> String -> IO (Request, String, String)
processJSON options dr logRef txt = do
   json <- either fail return (parseJSON txt)
   req  <- jsonRequest options json
   resp <- jsonRPC json $ \fun arg ->
              maybe id timedSeconds (maxTime options) (myHandler options dr logRef req fun arg)
   unless (responseError resp == Null) $
      changeLog logRef (\r -> r {errormsg = show (responseError resp)})
   let f   = if compactOutput req then compactJSON else show
       out = addVersion (version dr) (toJSON resp)
   return (req, f out, "application/json")

-- TODO: Clean-up code
extractExerciseId :: Monad m => JSON -> m Id
extractExerciseId json =
   case json of
      String s -> return (newId s)
      Array [String _, String _, a@(Array _)] -> extractExerciseId a
      Array [String _, String _, _, a@(Array _)] -> extractExerciseId a
      Array (String s:tl) | any p s -> extractExerciseId (Array tl)
      Array (hd:_) -> extractExerciseId hd
      _ -> fail "no code"
 where
   p c = not (isAlphaNum c || isSpace c || c `elem` ".-_")

addVersion :: String -> JSON -> JSON
addVersion str json =
   case json of
      Object xs -> Object (xs ++ [info])
      _         -> json
 where
   info = ("version", String str)

jsonRequest :: Monad m => Options -> JSON -> m Request
jsonRequest options json = do
   let exId = lookupM "params" json >>= extractExerciseId
   srv  <- stringOption  "method"      json newId
   src  <- stringOption  "source"      json id
   rinf <- stringOption  "requestinfo" json id
   seed <- stringOptionM "randomseed"  json (defaultSeed options) (return . readM)
   enc  <- stringOptionM "encoding"    json [] readEncoding
   sch  <- stringOptionM "logging"     json Nothing (fmap Just . readSchema)
   return mempty
      { serviceId   = srv
      , exerciseId  = exId
      , source      = src
      , cgiBinary   = cgiBin options
      , requestInfo = rinf
      , logSchema   = sch
      , randomSeed  = seed
      , dataformat  = Just JSON
      , encoding    = enc
      }

-- Use a fixed seed for random number generation for command-line invocations
defaultSeed :: Options -> Maybe Int
defaultSeed options
   | isJust (cgiBin options) = Nothing
   | otherwise = Just 2805 -- magic number

stringOption :: Monad m => String -> JSON -> (String -> a) -> m (Maybe a)
stringOption attr json f = stringOptionM attr json Nothing (return . Just . f)

stringOptionM :: Monad m => String -> JSON -> a -> (String -> m a) -> m a
stringOptionM attr json a f =
   case lookupM attr json of
      Just (String s) -> f s
      Just _  -> fail $ "Invalid value for " ++ attr ++ " (expecting string)"
      Nothing -> return a

myHandler :: Options -> DomainReasoner -> LogRef -> Request -> RPCHandler
myHandler opt1 dr logRef request fun json = do
   srv <- findService dr (newId fun)
   Some ex <- case exerciseId request of
                 Just a  -> findExercise dr a
                 Nothing -> return (Some emptyExercise)
   opt2 <- makeOptions dr ex request
   let options = opt1 <> opt2
   evalService logRef ex options jsonEvaluator srv json

jsonEvaluator :: Evaluator a JSON JSON
jsonEvaluator = Evaluator jsonDecoder jsonEncoder