packages feed

happstack-plugins (empty) → 6.0.0

raw patch · 9 files changed

+375/−0 lines, 9 filesdep +basedep +containersdep +filepathsetup-changed

Dependencies added: base, containers, filepath, happstack-server, hinotify, mtl, plugins, template-haskell

Files

+ COPYING view
@@ -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.
+ Happstack/Plugins/Dynamic.hs view
@@ -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))
+ Happstack/Plugins/LiftName.hs view
@@ -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)
+ Happstack/Plugins/Plugins.hs view
@@ -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 ()++
+ Happstack/Plugins/Static.hs view
@@ -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
+ Happstack/Server/Plugins/Dynamic.hs view
@@ -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
+ Happstack/Server/Plugins/Static.hs view
@@ -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
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMainWithHooks simpleUserHooks
+ happstack-plugins.cabal view
@@ -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 <happs@googlegroups.com>+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