happstack-helpers 0.46 → 0.47

raw patch · 2 files changed

+58/−2 lines, 2 filesdep +HTTPdep +network

Dependencies added: HTTP, network

Files

• Happstack/Server/Helpers.hs +55/−1
• happstack-helpers.cabal +3/−1

@@ -1,7 +1,16 @@ {-# LANGUAGE ScopedTypeVariables #-} module Happstack.Server.Helpers-    ( smartserver, exactdir, smartserver',getData',vhosts,vhost+    ( smartserver, exactdir, smartserver',getData',vhosts,vhost, cleanUpLockFile, scrapeUrl, cleanUpLockFile     ) where+import Network.Stream+import qualified Network.HTTP as HTTP+import Data.Char (toLower)+import Data.List (isInfixOf)+import Network.URI (parseURI)+import System.FilePath ((</>))+import System.Timeout (timeout)+import Control.Monad.Error+import System.Directory (getCurrentDirectory, doesFileExist, removeFile) import qualified Control.Exception as E import Data.IORef import Happstack.Server@@ -95,4 +104,49 @@   threadDelay $ waitSeconds * (10^6)   new <- readIORef eIOref   return (tid,new)++-- This is useful if you have a web server that crashes, but sometimes leaves the lock file hanging around.+-- But sometimes, due to unknown reasons, has a false restart that should quickly exit because the lock file exists and the app is really running.+-- What this function does is clean up the lock file, but only if a curl request for the actual web site fails.+-- This feels like risky business, try to find a better way (unclear on what the race condition, if any, is exactly but uneasy...)+-- Another danger is, what if the generated lock file doesn't match the actual lock file? (like if the underlying library call changes?)+cleanUpLockFile thisprog checkurl teststring waitSecs = do +  progName <- getProgName+  -- prevents inadvertent running from inside ghci.+  unless (thisprog == progName) $ error $ "prog name isn't " ++ progName ++  " exiting: " ++ progName++  lockFile <- liftM (</> "_local" </> progName ++ "_state.lock") getCurrentDirectory +  putStrLn $ "cleanUpLockFile, lock file: " ++ lockFile+  lock_fileExists <- doesFileExist lockFile+  when lock_fileExists $ do+      up <- websiteUp waitSecs checkurl teststring +      if up +        then do+          threadDelay $ 2 * 10^6+          error $ " cleanUpLockFile: " ++ progName ++ " is already running. That's odd. Exiting now."+        else removeFile lockFile++websiteUp secsWaitRequest url teststring = do+  let timeoutSecs n = timeout $ (10^6) * n+  mbEtR <- timeoutSecs secsWaitRequest $ runErrorT $ scrapeUrl url+  case mbEtR of +    Nothing -> do putStrLn $ "scrapeUrl returned nothing after " ++ (show secsWaitRequest) ++ "seconds, so we conclude it's donwn"+                  return False+    Just etR -> case etR of +      Left e -> return False+      Right s -> return $ isInfixOf (lc teststring) (lc s)++scrapeUrl :: String -> ErrorT String IO String+scrapeUrl url = do +     rq <- ErrorT $ case Network.URI.parseURI url of+                Nothing -> return . Left $ "bad url: " ++ url+                Just uri -> return . Right $ HTTP.Request uri HTTP.GET [] ""+                +     ErrorT $ do r <- catch ( HTTP.simpleHTTP rq )+                            ( \e -> return . Left . Network.Stream.ErrorMisc . show $ e)+                 case r of +                   Right x -> return . Right . HTTP.rspBody $ x+                   Left y -> return . Left $ "web fetch failed: " ++ (show rq)++lc = map toLower 

@@ -1,5 +1,5 @@ Name: happstack-helpers-Version: 0.46+Version: 0.47 License: BSD3 License-file: bsd3.txt Description: Functions I found I was using repeatedly when programming Happstack based web-apps. @@ -53,4 +53,6 @@                , pureMD5 >= 1.0.0.0 && < 1.1.0.0                , PBKDF2 >= 0.3 && < 0.4                , DebugTraceHelpers+               , network >= 2.2+               , HTTP >= 4000   ghc-options: -Wall