module Ideas.Main.Default
( defaultMain, defaultMainWith, defaultCGI
, serviceList, metaServiceList, Service
, module Ideas.Service.DomainReasoner
) where
import Control.Exception
import Control.Monad
import Data.ByteString (ByteString, unpack)
import Data.Char
import Data.Maybe
import Data.Monoid
import Data.String
import Ideas.Encoding.ModeJSON (processJSON)
import Ideas.Encoding.ModeXML (processXML)
import Ideas.Encoding.Options (Options, maxTime, optionCgiBin, logRef)
import Ideas.Encoding.Request
import Ideas.Main.CmdLineOptions hiding (fullVersion)
import Ideas.Service.DomainReasoner
import Ideas.Service.FeedbackScript.Analysis
import Ideas.Service.ServiceList
import Ideas.Service.Types (Service)
import Ideas.Text.XML.Unicode (decoding)
import Ideas.Utils.BlackBoxTests
import Ideas.Utils.Prelude
import Ideas.Utils.TestSuite
import Network.HTTP.Types
import System.IO
import qualified Ideas.Encoding.Logging as Log
import qualified Ideas.Main.CGI as CGI
import qualified Ideas.Main.CmdLineOptions as Options
import qualified Network.Wai as WAI
defaultMain :: DomainReasoner -> IO ()
defaultMain = defaultMainWith mempty
defaultMainWith :: Options -> DomainReasoner -> IO ()
defaultMainWith options dr = do
ref <- Log.defaultLogRef
let newOptions = options {logRef = logRef options <> ref}
cmdLineOptions <- getCmdLineOptions
if null cmdLineOptions
then defaultCGI newOptions dr
else defaultCommandLine newOptions (addVersion dr) cmdLineOptions
defaultCGI :: Options -> DomainReasoner -> IO ()
defaultCGI options dr = CGI.run $ \req respond -> do
let script = fromMaybe "" (findHeader "CGI-Script-Name" req)
addr = fromMaybe "" (findHeader "REMOTE_ADDR" req)
input <- inputOrDefault req >>= decoding
(preq, txt, ctp) <-
process (optionCgiBin script options) dr input
Log.changeLog (logRef options) $ \r -> Log.addRequest preq r
{ Log.ipaddress = addr
, Log.version = shortVersion
, Log.input = input
, Log.output = txt
}
when (useLogging preq) $
Log.logRecord (logRef options)
respond $ WAI.responseLBS
status200
[ (fromString "Content-Type", fromString ctp)
, (fromString "Access-Control-Allow-Origin", fromString "*")
]
(fromString txt)
inputOrDefault :: WAI.Request -> IO String
inputOrDefault req = do
maybeInput <- inputFromRequest req
case maybeInput of
Just s -> return s
Nothing
| acceptsHTML -> return defaultBrowser
| otherwise -> fail "environment variable 'input' is empty"
where
defaultBrowser :: String
defaultBrowser = "<request service='index' encoding='html'/>"
acceptsHTML :: Bool
acceptsHTML = "text/html" `elem` accepts req
defaultCommandLine :: Options -> DomainReasoner -> [CmdLineOption] -> IO ()
defaultCommandLine options dr cmdLineOptions = do
hSetBinaryMode stdout True
mapM_ doAction cmdLineOptions
where
doAction cmdLineOption =
case cmdLineOption of
Version -> putStrLn ("IDEAS, " ++ versionText)
Help -> putStrLn helpText
Rerun database ->
processDatabase dr database
InputFile file ->
withBinaryFile file ReadMode $ \h -> do
input <- hGetContents h >>= decoding
(req, txt, _) <- process options dr input
putStrLn txt
when (PrintLog `elem` cmdLineOptions) $ do
Log.changeLog (logRef options) $ \r -> Log.addRequest req r
{ Log.ipaddress = "command-line"
, Log.version = shortVersion
, Log.input = input
, Log.output = txt
}
Log.printLog (logRef options)
Test dir -> do
tests <- blackBoxTests (makeTestRunner dr) ["xml", "json"] dir
result <- runTestSuiteResult True tests
printSummary result
MakeScriptFor s -> makeScriptFor dr s
AnalyzeScript file -> parseAndAnalyzeScript dr file
PrintLog -> return ()
processDatabase :: DomainReasoner -> FilePath -> IO ()
processDatabase dr database = do
(n, time) <- getDiffTime $ do
rows <- Log.selectFrom database "requests" ["input"] $ \row -> do
txt <- headM row
(_, out, _) <- process mempty dr txt
putStrLn out
return (length rows)
putStrLn $ "processed " ++ show n ++ " requests in " ++ show time
process :: Options -> DomainReasoner -> String -> IO (Request, String, String)
process options dr input = do
format <- discoverDataFormat input
run format options {maxTime = Just 5} (addVersion dr) input
`catch` \e -> do
let msg = "Error: " ++ show (e :: SomeException)
Log.changeLog (logRef options) (\r -> r { Log.errormsg = msg })
return (mempty, msg, "text/plain")
where
run XML = processXML
run JSON = processJSON
makeTestRunner :: DomainReasoner -> String -> IO String
makeTestRunner dr input = do
(_, out, _) <- decoding input >>= process mempty dr
return out
addVersion :: DomainReasoner -> DomainReasoner
addVersion dr = dr
{ version = update version Options.shortVersion
, fullVersion = update fullVersion Options.fullVersion
}
where
update f s = if null (f dr) then s else f dr
findHeader :: String -> WAI.Request -> Maybe String
findHeader s = fmap fromByteString . lookup (fromString s) . WAI.requestHeaders
inputFromRequest :: WAI.Request -> IO (Maybe String)
inputFromRequest req =
case inputFromQuery (WAI.queryString req) of
Just s -> return (Just s)
Nothing -> do
body <- WAI.requestBody req
return (inputFromQuery (parseQuery body))
inputFromQuery :: Query -> Maybe String
inputFromQuery = fmap fromByteString . join . lookup (fromString "input")
accepts :: WAI.Request -> [String]
accepts = maybe [] (splitsWithElem ',') . findHeader "Accept"
fromByteString :: ByteString -> String
fromByteString = map (chr . fromEnum) . unpack