agda-server-0.1: Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}

module Main
    ( main
    ) where

import Args
import Memo
import JSDict
import JSDictDef
import Standalone

import Snap.Core
import Snap.Http.Server (httpServe)
import Snap.Http.Server.Config
import Snap.Util.FileServe (getSafePath, serveDirectoryWith, simpleDirectoryConfig)

import Data.ByteString.UTF8 (fromString, toString)

import System.FilePath

import Control.Applicative ((<|>))
import Control.Monad
import Control.Monad.Trans

---------------------------------------------------------------

main :: IO ()
main = getArgs >>= mainWithArgs

mainWithArgs :: Args -> IO ()
mainWithArgs (Args {sourcedir, port, datadir, includedir, logdir}) = do
    putStrLn $ "Working directory: " ++ show sourcedir
    putStrLn $ "Include directories: " ++ show includedir
    let -- includedirs = ["", "/home/divip/share/agda/std-lib/src"]

        templatepath = datadir </> "agda.template"
        jsfile = datadir </> "common.js"

    let ((common, definitions), idC) = runJSDictM $ jsDictM includedir

    runMemo <- initMemo idC

    ht <- liftIO $ readFile templatepath

    let serveHtml = do
            p <- getSafePath
            guard $ takeExtension p `elem` [".xml"]
            return $ standalone ht common sourcedir $ dropExtension p

        runSM name i fun = do
            mn <- getParam' "sm"
            guard $ name == mn
            fmap fun $ mapM (getParam' . ('v':) . show) [1..i]

    writeFile jsfile $ unlines [x | JSDef x <- definitions]

    httpServe

        ( setPort port
        . setAccessLog (if null logdir then ConfigNoLog else ConfigFileLog (logdir </> "access.log"))
        . setErrorLog  (if null logdir then ConfigNoLog else ConfigFileLog (logdir </> "error.log"))
        $ emptyConfig
        )

        (   method GET
            (   (writeBS . fromString =<< runMemo =<< serveHtml)
            <|> serveDirectoryWith simpleDirectoryConfig datadir
            <|> serveDirectoryWith simpleDirectoryConfig sourcedir
            )
        <|> method POST
            (   ( writeBS . fromString =<< runMemo =<<
                    msum [runSM name i fun | SMDef name i fun <- definitions]
                )
            <|> writeBS "Invalid post request"
            )
        <|> writeBS "Not found. Try to find X.xml for example."
        )

getParam' :: String -> Snap String
getParam' t = do
    Just x <- getParam $ fromString t
    return $ toString x