Skip to content
This repository
Newer
Older
100644 67 lines (54 sloc) 2.083 kb
4b21b6c5 »
2009-08-12 Added expireGititCache program.
1 {-
2 expireGititCache - (C) 2009 John MacFarlane, licensed under the GPL
3
4 This program is designed to be used in post-update hooks and other scripts.
5
6 Usage: expireGititCache base-url [file..]
7
8 Example:
9
10 expireGititCache http://localhost:5001 page1.page foo/bar.hs "Front Page.page"
11
12 will produce POST requests to http://localhost:5001/_expire/page1,
13 http://localhost:5001/_expire/foo/bar.hs, and
14 http://localhost:5001/_expire/Front Page.
15
16 Return statuses:
17
18 0 -> the cached page was successfully expired (or was not cached in the first place)
19 1 -> fewer than two arguments were supplied
20 3 -> did not receive a 200 OK response from the request
21 5 -> could not parse the uri
22
23 -}
24
25 module Main
26 where
27 import Network.HTTP
28 import System.Environment
29 import Network.URI
30 import System.FilePath
31 import Control.Monad
32 import System.IO
33 import System.Exit
34
35 main :: IO ()
36 main = do
37 args <- getArgs
38 (uriString : files) <- if length args < 2
39 then usageMessage >> return [""]
40 else return args
41 uri <- case parseURI uriString of
42 Just u -> return u
43 Nothing -> do
44 hPutStrLn stderr ("Could not parse URI " ++ uriString)
45 exitWith (ExitFailure 5)
2465bcbb »
2011-04-13 Strip trailing whitespace; misc -Wall and hlint
46 forM_ files (expireFile uri)
4b21b6c5 »
2009-08-12 Added expireGititCache program.
47
48 usageMessage :: IO ()
49 usageMessage = do
50 hPutStrLn stderr $ "Usage: expireGititCache base-url [file..]\n" ++
51 "Example: expireGititCache http://localhost:5001 page1.page foo/bar.hs"
52 exitWith (ExitFailure 1)
53
54 expireFile :: URI -> FilePath -> IO ()
55 expireFile uri file = do
56 let path' = if takeExtension file == ".page"
57 then dropExtension file
58 else file
59 let uri' = uri{uriPath = "/_expire/" ++ urlEncode path'}
60 resResp <- simpleHTTP Request{rqURI = uri', rqMethod = POST, rqHeaders = [], rqBody = ""}
61 case resResp of
62 Left connErr -> error $ show connErr
63 Right (Response (2,0,0) _ _ _) -> return ()
64 _ -> do
65 hPutStrLn stderr ("Request for " ++ show uri' ++ " did not return success status")
66 exitWith (ExitFailure 3)
Something went wrong with that request. Please try again.