diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,29 @@ +Copyright (c) 2010, Jeremy Shaw +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 the HAppS.org; nor the names of its 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. diff --git a/Happstack/Plugins/Dynamic.hs b/Happstack/Plugins/Dynamic.hs new file mode 100644 --- /dev/null +++ b/Happstack/Plugins/Dynamic.hs @@ -0,0 +1,16 @@ +module Happstack.Plugins.Dynamic + ( PluginHandle(..) + , initPlugins + ) where + +import Data.IORef (newIORef) +import qualified Data.Map as Map +import Happstack.Plugins.Plugins (PluginHandle(..)) +import System.INotify (initINotify) + +-- |initialize the plugin system and return a 'PluginHandle' +initPlugins :: IO PluginHandle +initPlugins = + do inotify <- initINotify + objMap <- newIORef Map.empty + return (PluginHandle (inotify, objMap)) diff --git a/Happstack/Plugins/LiftName.hs b/Happstack/Plugins/LiftName.hs new file mode 100644 --- /dev/null +++ b/Happstack/Plugins/LiftName.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE TemplateHaskell, MagicHash #-} +module Happstack.Plugins.LiftName where + +import GHC.Exts +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Syntax.Internals + +liftName :: Name -> ExpQ +liftName (Name occName nameFlavour) = appE (appE [| Name |] (liftOccName occName)) (liftNameFlavour nameFlavour) + +liftOccName :: OccName -> ExpQ +liftOccName (OccName str) = [| OccName str |] + +liftNameSpace :: NameSpace -> ExpQ +liftNameSpace VarName = [| VarName |] +liftNameSpace DataName = [| DataName |] +liftNameSpace TcClsName = [| TcClsName |] + +liftPkgName :: PkgName -> ExpQ +liftPkgName (PkgName str) = [| PkgName str |] + +liftModName :: ModName -> ExpQ +liftModName (ModName str) = [| ModName str |] + +liftNameFlavour :: NameFlavour -> ExpQ +liftNameFlavour NameS = [| NameS |] +liftNameFlavour (NameQ modName) = appE [| NameQ |] (liftModName modName) +liftNameFlavour (NameU i) = [| case $( lift (I# i) ) of + I# i' -> NameU i' |] +liftNameFlavour (NameL i) = [| case $( lift (I# i) ) of + I# i' -> NameL i' |] +liftNameFlavour (NameG nameSpace pkgName modName) + = appE (appE (appE [| NameG |] (liftNameSpace nameSpace)) (liftPkgName pkgName)) (liftModName modName) diff --git a/Happstack/Plugins/Plugins.hs b/Happstack/Plugins/Plugins.hs new file mode 100644 --- /dev/null +++ b/Happstack/Plugins/Plugins.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE EmptyDataDecls, TemplateHaskell #-} +module Happstack.Plugins.Plugins + ( rebuild + , func + , funcTH + , withIO + , PluginHandle(..) + ) where + +import Control.Applicative ((<$>)) +import Data.IORef (IORef, atomicModifyIORef, readIORef) +import Data.List (nub) +import Data.Maybe (mapMaybe) +import qualified Data.Map as Map +import Data.Map (Map) +import Language.Haskell.TH.Syntax (Name(Name),NameFlavour(NameG), occString, modString) +import System.FilePath (addExtension, dropExtension) +import System.Plugins.Load (Module, Symbol, LoadStatus(..), getImports, load, unloadAll) +import System.Plugins.Make (Errors, MakeStatus(..), MakeCode(..), makeAll) +import System.INotify (INotify, WatchDescriptor, Event(..), EventVariety(..), addWatch, removeWatch) +import Unsafe.Coerce (unsafeCoerce) + +-- A very unsafe version of Data.Dynamic + +data Sym + +toSym :: a -> Sym +toSym = unsafeCoerce + +fromSym :: Sym -> a +fromSym = unsafeCoerce + +newtype PluginHandle = PluginHandle (INotify, IORef (Map FilePath ([WatchDescriptor], [FilePath], Maybe Errors, Map Symbol (FilePath -> IO (Either Errors (Module, Sym)), Either Errors (Module, Sym))))) + +atomicModifyIORef' :: IORef a -> (a -> a) -> IO () +atomicModifyIORef' ref fn = atomicModifyIORef ref (\val -> (fn val, ())) + +funcTH :: PluginHandle -> Name -> IO (Either Errors a) +funcTH objMap name = + do let (fp, sym) = nameToFileSym name + func objMap fp sym + + +withIO :: PluginHandle -> Name -> (a -> IO ()) -> IO () +withIO objMap name use = + do r <- funcTH objMap name + case r of + (Left e) -> putStrLn $ unlines e + (Right f) -> use f + +nameToFileSym :: Name -> (FilePath, Symbol) +nameToFileSym (Name occName (NameG _ _ mn)) = + let dotToSlash '.' = '/' + dotToSlash c = c + fp = (map dotToSlash (modString mn)) ++ ".hs" + sym = occString occName + in (fp, sym) +nameToFileSym n = error $ "nameToFileSym failed because Name was not the right kind. " ++ show n + +func :: PluginHandle -> FilePath -> Symbol -> IO (Either Errors a) +func ph@(PluginHandle (_inotify, objMap)) fp sym = + do om <- readIORef objMap + case Map.lookup fp om of + Nothing -> + do addSymbol ph fp sym + rebuild ph fp True + func ph fp sym + (Just (_, _, Just errs, _)) -> return $ Left errs + (Just (_, _, Nothing, symbols)) -> + case Map.lookup sym symbols of + Nothing -> + do addSymbol ph fp sym + rebuild ph fp True + func ph fp sym + (Just (_, Left errs)) -> return $ Left errs + (Just (_, Right (_, dynSym))) -> return (Right $ fromSym dynSym) + +rebuild :: PluginHandle -- ^ list of currently loaded modules/symbols + -> FilePath -- ^ source file to compile + -> Bool + -> IO () +rebuild (PluginHandle (inotify, objMap)) fp forceReload = + do putStrLn ("Rebuilding " ++ fp) + makeStatus <- makeAll fp [] -- FIXME: allow user to specify additional flags, such as -O2 + case makeStatus of + (MakeFailure errs) -> + do unload <- atomicModifyIORef objMap $ \om -> + case Map.lookup fp om of + Nothing -> (Map.insert fp ([], [], Just errs, Map.empty) om, []) + (Just (wds, deps, _, symbols)) -> + let symbols' = Map.map (\(loader,_) -> (loader, Left errs)) symbols -- propogate error to all symbols + in (Map.insert fp (wds, deps, Just errs, symbols') om, unloadList symbols) + mapM_ unloadAll unload + putStrLn $ unlines errs + (MakeSuccess NotReq _objFilePath) | not forceReload -> + do putStrLn "skipped reload." + return () + (MakeSuccess _makeCode objFilePath) -> + do om <- readIORef objMap + case Map.lookup fp om of + Nothing -> return () + (Just (oldWds, _, _, symbols)) -> + do mapM_ unloadAll (unloadList symbols) + mapM_ (removeWatch inotify) oldWds + res <- mapM (load' objFilePath) (Map.assocs symbols) + imports <- map (\bn -> addExtension bn ".hs") <$> getImports (dropExtension objFilePath) + wds <- mapM (\depFp -> putStrLn ("Adding watch for: " ++ depFp) >> addWatch inotify [Modify, Move, Delete] depFp + (\e -> do putStrLn ("Got event for " ++ depFp ++ ": " ++ show e) + case e of + Ignored -> return () + _ -> rebuild (PluginHandle (inotify, objMap)) fp False)) (fp:imports) + atomicModifyIORef' objMap $ Map.insert fp (wds, [], Nothing, Map.fromList res) + where + unloadList symbols = + nub $ mapMaybe (\(_, eSym) -> + case eSym of + (Left _) -> Nothing + (Right (m,_)) -> Just m) (Map.elems symbols) + + load' :: FilePath + -> (Symbol, (FilePath -> IO (Either Errors (Module, Sym)), Either Errors (Module, Sym))) + -> IO (Symbol, (FilePath -> IO (Either Errors (Module, Sym)), Either Errors (Module, Sym))) + load' obj (symbol, (reloader, _)) = + do r <- reloader obj + case r of + (Left errs) -> putStrLn $ unlines errs + (Right _) -> return () + return (symbol, (reloader, r)) + +addSymbol :: PluginHandle -> FilePath -> Symbol -> IO () +addSymbol (PluginHandle (_inotify, objMap)) sourceFP sym = + do let reloader obj = + do putStrLn $ "loading " ++ sym ++ " from " ++ sourceFP + ldStatus <- load obj ["."] [] sym + case ldStatus of + (LoadSuccess m s) -> + do putStrLn "Succeed." + return (Right (m, toSym s)) + (LoadFailure errs) -> + do putStrLn "Failed." + return (Left errs) + symVal = (reloader, Left ["Not loaded yet.."]) + atomicModifyIORef' objMap $ \om -> + case Map.lookup sourceFP om of + Nothing -> Map.insert sourceFP ([], [], Nothing, Map.singleton sym symVal) om + (Just (wds, deps, errs, symbols)) -> + let symbols' = Map.insert sym symVal symbols + in Map.insert sourceFP (wds, deps, errs, symbols') om + + return () + + diff --git a/Happstack/Plugins/Static.hs b/Happstack/Plugins/Static.hs new file mode 100644 --- /dev/null +++ b/Happstack/Plugins/Static.hs @@ -0,0 +1,12 @@ +module Happstack.Plugins.Static + ( PluginHandle(..) + , initPlugins + ) where + +data PluginHandle = PluginHandle + +-- | pretend to initialize the plugin system. This is provided so that +-- you can easily switch between dynamic and static mode by only +-- changing the imports via a CPP flag. +initPlugins :: IO PluginHandle +initPlugins = return PluginHandle diff --git a/Happstack/Server/Plugins/Dynamic.hs b/Happstack/Server/Plugins/Dynamic.hs new file mode 100644 --- /dev/null +++ b/Happstack/Server/Plugins/Dynamic.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE FlexibleContexts, TemplateHaskell #-} +module Happstack.Server.Plugins.Dynamic + ( PluginHandle + , initPlugins + , withServerPart + , withServerPart_ + ) where + +import Control.Monad.Trans (MonadIO(liftIO)) +import Language.Haskell.TH (ExpQ, appE, varE) +import Language.Haskell.TH.Syntax (Name) +import Happstack.Plugins.Dynamic (initPlugins) +import Happstack.Plugins.LiftName (liftName) +import Happstack.Plugins.Plugins (PluginHandle, funcTH) +import Happstack.Server (ServerMonad, FilterMonad, WebMonad, Response, internalServerError, escape, toResponse) + +-- | dynamically load the specified symbol pass it as an argument to +-- the supplied server monad function. +-- +-- This is a wrapper aronud 'withServerPart_' which ensures the first +-- and second argument stay in-sync. +-- +-- Usage: +-- +-- > $(withServerPart 'symbol) pluginHandle $ \a -> ... +-- +withServerPart :: Name -> ExpQ +withServerPart name = appE (appE [| withServerPart_ |] (liftName name)) (varE name) + +-- | dynamically load the specified symbol pass it as an argument to +-- the supplied server monad function. +-- +-- If something fails, this function will return '500 Internal Server +-- Error' and a list of the errors encountered. +-- +-- see also: 'withServerPart' +withServerPart_ :: (MonadIO m, ServerMonad m, FilterMonad Response m, WebMonad Response m) => + Name -- ^ name of the symbol to dynamically load + -> a -- ^ the symbol (must be the function refered to by the 'Name' argument) + -> PluginHandle -- ^ Handle to the function reloader + -> (a -> m b) -- ^ function which uses the loaded result + -> m b +withServerPart_ name _fun ph use = + do r <- liftIO $ funcTH ph name + case r of + (Left e) -> escape $ internalServerError (toResponse (unlines e)) + (Right f) -> use f diff --git a/Happstack/Server/Plugins/Static.hs b/Happstack/Server/Plugins/Static.hs new file mode 100644 --- /dev/null +++ b/Happstack/Server/Plugins/Static.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE FlexibleContexts, TemplateHaskell #-} +module Happstack.Server.Plugins.Static + ( PluginHandle + , initPlugins + , withServerPart + , withServerPart_ + ) where + +import Control.Monad.Trans (MonadIO(..)) +import Happstack.Plugins.Static (PluginHandle, initPlugins) +import Happstack.Plugins.LiftName (liftName) +import Happstack.Server (ServerMonad, FilterMonad, WebMonad, Response) +import Language.Haskell.TH (ExpQ, Name, appE, varE) + + +-- | A template haskell wrapper around 'withServerPart_'. +-- Usage: +-- +-- > $(withServerPart 'symbol) pluginHandle $ \a -> ... +-- +withServerPart :: Name -> ExpQ +withServerPart name = appE (appE [| withServerPart_ |] (liftName name)) (varE name) + +-- | a static version of 'Happstack.Server.Plugins.Dynamic.withServerPart_' +-- +-- This function has the same signature as its dynamic sibling, but it +-- does not do any fancy dynamic loading. It simply applies the +-- function to the supplied value. +-- +-- This function exists so that you can that you can compile using +-- dynamic plugins during development, but statically link the final +-- build. +-- +-- Use a CPP to select between the Dynamic and Static versions of this module. +withServerPart_ :: (MonadIO m, ServerMonad m, FilterMonad Response m, WebMonad Response m) => Name -> a -> PluginHandle -> (a -> m b) -> m b +withServerPart_ _name fun _objMap use = use fun diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMainWithHooks simpleUserHooks diff --git a/happstack-plugins.cabal b/happstack-plugins.cabal new file mode 100644 --- /dev/null +++ b/happstack-plugins.cabal @@ -0,0 +1,46 @@ +Name: happstack-plugins +Version: 6.0.0 +Synopsis: The haskell application server stack + reload +Description: This library provides support for automatically recompiling and reloading modules into a running server. +License: BSD3 +License-file: COPYING +Author: Happstack team, HAppS LLC +Maintainer: Happstack team +homepage: http://happstack.com +Category: Web, Distributed Computing +Build-Type: Simple +Cabal-Version: >= 1.6 + +source-repository head + type: darcs + subdir: happstack-plugins + location: http://patch-tag.com/r/mae/happstack/pullrepo + +Flag base4 + Description: Choose the even newer, even smaller, split-up base package. + +Flag tests + Description: Build the testsuite, and include the tests in the library + Default: False + +Library + exposed-modules: Happstack.Plugins.Plugins + Happstack.Plugins.Static + Happstack.Plugins.Dynamic + Happstack.Plugins.LiftName + Happstack.Server.Plugins.Dynamic + Happstack.Server.Plugins.Static + + build-depends: base >= 3 && < 5, + containers, + filepath, + happstack-server >= 6.0 && < 6.1, + hinotify, + mtl, + plugins >= 1.5.1.4, + template-haskell + + if impl(ghc >= 6.12) + ghc-options: -Wall -fno-warn-unused-do-bind + else + ghc-options: -Wall