module Ideas.Main.Default
( defaultMain, newDomainReasoner
, Some(..), serviceList, metaServiceList, Service
, module Ideas.Service.DomainReasoner
) where
import Control.Exception
import Control.Monad
import Data.IORef
import Data.Maybe
import Data.Time
import Ideas.Common.Id
import Ideas.Common.Utils (useFixedStdGen, Some(..))
import Ideas.Common.Utils.TestSuite
import Ideas.Encoding.ModeJSON (processJSON)
import Ideas.Encoding.ModeXML (processXML)
import Ideas.Main.BlackBoxTests
import Ideas.Main.Documentation
import Ideas.Main.LoggingDatabase
import Ideas.Main.Options hiding (fullVersion)
import Ideas.Service.DomainReasoner
import Ideas.Service.FeedbackScript.Analysis
import Ideas.Service.Request
import Ideas.Service.ServiceList
import Ideas.Service.Types (Service)
import Network.CGI
import Prelude hiding (catch)
import System.IO
import System.IO.Error (ioeGetErrorString)
import qualified Ideas.Main.Options as Options
defaultMain :: DomainReasoner -> IO ()
defaultMain dr = do
startTime <- getCurrentTime
flags <- getFlags
if null flags
then defaultCGI dr startTime
else defaultCommandLine dr flags
defaultCGI :: DomainReasoner -> UTCTime -> IO ()
defaultCGI dr startTime = do
logRef <- newIORef (return ())
runCGI $ do
addr <- remoteAddr
cgiBin <- scriptName
raw <- getInput "input"
input <- case raw of
Nothing -> fail "Invalid request: environment variable \"input\" is empty"
Just s -> return s
(req, txt, ctp) <- liftIO $ process dr (Just cgiBin) input
when (useLogging req) $
liftIO $ writeIORef logRef $
logMessage req input txt addr startTime
setHeader "Content-type" ctp
setHeader "Access-Control-Allow-Origin" "*"
output txt
join (readIORef logRef)
`catch` \ioe -> runCGI $ do
setHeader "Content-type" "text/plain"
setHeader "Access-Control-Allow-Origin" "*"
output ("Invalid request\n" ++ ioeGetErrorString ioe)
defaultCommandLine :: DomainReasoner -> [Flag] -> IO ()
defaultCommandLine dr flags = do
hSetBinaryMode stdout True
useFixedStdGen
mapM_ doAction flags
where
doAction flag =
case flag of
Version -> putStrLn ("IDEAS, " ++ versionText)
Help -> putStrLn helpText
InputFile file ->
withBinaryFile file ReadMode $ \h -> do
input <- hGetContents h
(_, txt, _) <- process dr Nothing input
putStrLn txt
Test dir -> do
tests <- blackBoxTests dr dir
result <- runTestSuiteResult True tests
printSummary result
MakePages dir ->
makeDocumentation dr dir
MakeScriptFor s -> makeScriptFor dr s
AnalyzeScript file -> parseAndAnalyzeScript dr file
process :: DomainReasoner -> Maybe String -> String -> IO (Request, String, String)
process dr cgiBin input =
case discoverDataFormat input of
Just XML -> processXML (Just 5) dr cgiBin input
Just JSON -> processJSON (Just 5) (isJust cgiBin) dr input
_ -> fail "Invalid input"
newDomainReasoner :: IsId a => a -> DomainReasoner
newDomainReasoner a = mempty
{ reasonerId = newId a
, version = shortVersion
, fullVersion = Options.fullVersion
}