happs-hsp-template (empty) → 0.2
raw patch · 5 files changed
+328/−0 lines, 5 filesdep +HAppS-Serverdep +RJsondep +basesetup-changed
Dependencies added: HAppS-Server, RJson, base, bytestring, containers, directory, filepath, hinotify, hsp, mtl, network, plugins
Files
- LICENSE +35/−0
- Setup.hs +2/−0
- happs-hsp-template.cabal +15/−0
- src/HAppS/Template/HSP.hs +86/−0
- src/HAppS/Template/HSP/Handle.hs +190/−0
+ LICENSE view
@@ -0,0 +1,35 @@+Copyright (c) 2004-2006, David Himmelstrup+All rights reserved.++Redistribution and use in source and binary forms,+with or without modification, are permitted provided+that the following conditions are met:++ * Redistributions of source code must retain+ the above copyright notice, this list of+ conditions and the following disclaimer.+ * Redistributions in binary form must reproduce+ the above copyright notice, this list of+ conditions and the following disclaimer in the+ documentation and/or other materials provided+ with the distribution.+ * Neither the name of David Himmelstrup nor the+ names of other contributors may be used to+ endorse or promote products derived from this+ software without specific prior written permission.+++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND+CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER+OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE+USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY+OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ happs-hsp-template.cabal view
@@ -0,0 +1,15 @@+Name: happs-hsp-template+Version: 0.2+Category: Web+Maintainer: David Himmelstrup (lemmih@gmail.com)+Synopsis: Utilities for using HSP templates in HAppS applications.+Build-Type: Simple+Build-Depends: base, bytestring, filepath, directory, mtl, containers, network,+ hinotify, plugins>=1.2, RJson, HAppS-Server, hsp>=0.4.4+LICENSE: BSD3+License-File: LICENSE+Hs-Source-Dirs: src++Exposed-Modules:+ HAppS.Template.HSP+ HAppS.Template.HSP.Handle
+ src/HAppS/Template/HSP.hs view
@@ -0,0 +1,86 @@+module HAppS.Template.HSP+ ( WebState(..)+ , Web+ , runWeb+ , runWebXML+ , globalQuery+ , globalRead+ , simpleRequest+ , localQuery+ , localRead+ ) where++import Text.RJson+import Control.Monad.Reader+import Control.Monad.Writer++import Data.Monoid+import qualified Data.Map as Map++import qualified Data.ByteString.Lazy as Lazy++import HAppS.Server.SimpleHTTP (Request(..),Method(..),Input,Cookie,RqBody(..))+import HAppS.Server.MessageWrap+import HAppS.Server.SURI+import Network.URI (parseRelativeReference,uriQuery)++import HSP hiding (Request)++nullRequest :: Request+nullRequest = Request { rqMethod = GET+ , rqPaths = []+ , rqQuery = "/"+ , rqInputs = []+ , rqCookies = []+ , rqVersion = error "version not set"+ , rqHeaders = error "headers not set"+ , rqBody = Body Lazy.empty+ , rqPeer = ("localhost", 0) }++simpleRequest :: String -> Request+simpleRequest query = case parseRelativeReference query of+ Nothing -> nullRequest+ Just uri -> nullRequest{rqQuery = uriQuery uri+ ,rqPaths = pathEls (path $ SURI uri)+ ,rqInputs = queryInput (SURI uri)}++data WebState+ = WebState+ { queryGlobal :: Request -> IO JsonData+ , queryLocal :: Map.Map String JsonData }++type Web = HSPT (WriterT (Endo XML) (ReaderT WebState IO))++runWeb :: WebState -> Web a -> HSP a+runWeb st web+ = do env <- getEnv+ (xml,Endo w) <- liftIO $ runReaderT (runWriterT $ runHSPT web env) st+ return $ xml++runWebXML :: WebState -> Web XML -> HSP XML+runWebXML st web+ = do env <- getEnv+ (xml,Endo w) <- liftIO $ runReaderT (runWriterT $ runHSPT web env) st+ return $ w xml++globalQuery :: Request -> Web JsonData+globalQuery key+ = do fn <- lift $ lift $ asks queryGlobal+ liftIO $ fn key++localQuery :: String -> Web JsonData+localQuery key+ = do m <- lift $ lift $ asks queryLocal+ return $ Map.findWithDefault (JDString $ "Lookup failed: " ++ key) key m++globalRead :: FromJson a => Request -> Web a+globalRead key = do json <- globalQuery key+ case fromJson undefined json of+ Left err -> error err+ Right val -> return val++localRead :: FromJson a => String -> Web a+localRead key = do json <- localQuery key+ case fromJson undefined json of+ Left err -> error err+ Right val -> return val
+ src/HAppS/Template/HSP/Handle.hs view
@@ -0,0 +1,190 @@+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) }