Handle.hs

module HAppS.Template.HSP.Handle
    ( HSPState
    , Store
    , newStore
    , destroyStore
    , runSimpleHSPHandle
    , runSimpleHSPHandleT
    , runHSPHandle
    , runHSPHandleT
    , execTemplate
    , addParam
    , addJsonParam
    ) where

import Text.RJson
import HSP hiding (Request)
import Control.Monad.State
import Data.IORef
import System.Plugins
import System.Plugins.Env
import System.INotify
import System.FilePath
import System.Directory

import qualified Data.ByteString.Char8 as P
import qualified Data.ByteString.Lazy.Char8 as L

import qualified Data.Map as Map
import HAppS.Server.SimpleHTTP hiding (Web,path)
--import HAppS.Server.SimpleHTTP.HTTP.Types

import HAppS.Template.HSP

hspArgs =
        [ "-fglasgow-exts"
        , "-fallow-overlapping-instances"
        , "-fallow-undecidable-instances"
        , "-F", "-pgmFtrhsx"
        , "-fno-warn-overlapping-patterns"
        ]


data HSPState
    = HSPState
    { hspStore :: Store
    , hspLocal :: Map.Map String JsonData
    , hspGlobal :: Request -> IO JsonData
    , hspPrefix :: FilePath
    , hspObjDir :: FilePath
    }

type Store = IORef (Map.Map FilePath (Either Errors (Module, Web XML)))

newStore :: IO Store
newStore = newIORef Map.empty

destroyStore :: Store -> IO ()
destroyStore store
    = do map <- atomicModifyIORef store (\ref -> (Map.empty, ref))
         mapM_ unloadAll [ m | Right (m,_) <- Map.elems map ]

instance ToMessage XML where
    toContentType _ = P.pack "text/html"
    toMessage = L.pack . renderXML

instance ToMessage JsonData where
    toContentType _ = P.pack "application/json"
    toMessage = L.pack . show

type HSPHandleT m a = ServerPartT (StateT HSPState m) a
type HSPWebT m = WebT (StateT HSPState m)

type HSPHandle a = HSPHandleT IO a
type HSPWeb = HSPWebT IO

runSimpleHSPHandle :: ToMessage a => Store -> HSPHandle a -> ServerPart a
runSimpleHSPHandle = runSimpleHSPHandleT

runSimpleHSPHandleT :: ToMessage a => Store -> HSPHandle a -> ServerPart a
runSimpleHSPHandleT = runHSPHandleT "." "."

runHSPHandle :: ToMessage a => FilePath -> FilePath -> Store -> HSPHandle a -> ServerPart a
runHSPHandle = runHSPHandleT

runHSPHandleT :: ToMessage a => FilePath -> FilePath -> Store -> HSPHandle a -> ServerPart a
runHSPHandleT prefix objDir store (ServerPartT h)
    = let hspState rq = HSPState{ hspStore = store
                                , hspGlobal = mkGlobal self rq
                                , hspLocal = Map.empty
                                , hspPrefix = prefix
                                , hspObjDir = objDir }
          self = ServerPartT $ \rq -> WebT $ evalStateT (unWebT (h rq)) (hspState rq)
      in self

mkGlobal :: ToMessage a => ServerPart a -> Request -> Request -> IO JsonData
mkGlobal sp oldRequest newRequest
    = do let Left mr = applyRequest [sp] request
         resp <- mr
         case fmap P.unpack $ getHeader "content-type" resp of
           Just "application/json" -> return $ case parseJsonByteString (rsBody resp) of
                                                 Left err -> JDString err
                                                 Right val-> val
           Just contentType        -> return $ JDString $ "Incorrect content-type: " ++ contentType
           Nothing                 -> return $ JDString $ "Missing content-type"
    where request = newRequest { rqCookies = rqCookies newRequest ++ rqCookies oldRequest
                               , rqVersion = rqVersion oldRequest
                               , rqHeaders = rqHeaders oldRequest
                               , rqPeer = rqPeer oldRequest }

execTemplate :: FilePath -> HSPWeb Response
execTemplate tmpl =
    do state <- get
       let webState = WebState { queryGlobal = hspGlobal state
                               , queryLocal = hspLocal state }
       compResult <- liftIO $ requestPage state tmpl
       case compResult of
         Left errs -> return $ toResponse $ unlines errs
         Right (_,web) -> liftM toResponse $ liftIO $ evalHSP (runWebXML webState web)

requestPage state tmpl
    = do let file = (hspPrefix state) </> tmpl
         store <- readIORef (hspStore state)
         case Map.lookup file store of
           Just x -> return x
           Nothing -> do compResult <- compileHSP (hspPrefix state) (hspObjDir state) file
                         case compResult of
                           Right (mod,_) -> do atomicModifyIORef' (hspStore state)
                                                  $ Map.insert file compResult
                                               reloadNotification state file mod mod
                           _ -> return ()
                         return compResult

replacePath newPrefix oldPrefix path
    = worker (splitDirectories oldPrefix) (splitDirectories path)
    where worker (x:xs) (y:ys) | y==x = worker xs ys
          worker _ ys = newPrefix </> joinPath ys

reloadNotification state topFile topMod mod
    = do ino <- initINotify
         let realPath = replacePath (hspPrefix state) (hspObjDir state) (path mod)
         mbFile <- findFile knownExtensions realPath
         case mbFile of
           Nothing -> return undefined
           Just file -> addWatch ino [Modify,Move,Delete] file $ \event ->
                          do putStrLn $ "Recompiling: " ++ topFile ++ " because of " ++ show event
                             doUnload <- atomicModifyIORef (hspStore state)
                                         $ \ref -> (Map.insert topFile (Left ["Compiling..."]) ref
                                                   , case Map.lookup topFile ref of
                                                       Just (Right _) -> True
                                                       _              -> False )
                             when doUnload $ unloadAll topMod
                             compResult <- compileHSP (hspPrefix state) (hspObjDir state) topFile
                             atomicModifyIORef' (hspStore state) $ Map.insert topFile compResult
         deps <- getModuleDeps mod
         mapM_ (reloadNotification state topFile topMod) deps

findFile :: [String] -> FilePath -> IO (Maybe FilePath)
findFile [] _  = return Nothing
findFile (ext:exts) file
    = do let l = replaceExtension file ext
         b <- doesFileExist l
         if b then return $ Just l
              else findFile exts file

knownExtensions = [".hs",".lhs",".hsp"]

atomicModifyIORef' ref fn = atomicModifyIORef ref (\val -> (fn val, ()))

compileHSP :: FilePath -> FilePath -> FilePath -> IO (Either Errors (Module, Web XML))
compileHSP prefix objPath file
    = do createDirectoryIfMissing True objPath
         let extraArgs = ["-hidir",objPath, "-odir",objPath,"-i"++prefix]
         mkStatus <- liftIO $ makeAll file (extraArgs ++ hspArgs)
         case mkStatus of
           MakeFailure errs  -> return $ Left errs
           MakeSuccess mkcode obj -> do
             ldStatus <- liftIO $ load obj [objPath] [] "page"
             case ldStatus of
               LoadFailure errs -> return $ Left errs
               LoadSuccess mod page -> return $ Right (mod,page)



addParam :: ToJson json => String -> json -> HSPWeb ()
addParam key val
    = addJsonParam key (toJson val)

addJsonParam :: String -> JsonData -> HSPWeb ()
addJsonParam key val
    = modify $ \st -> st{hspLocal = Map.insert key val (hspLocal st) }