bake 0.4 → 0.5

raw patch · 24 files changed

+459/−180 lines, 24 filesdep +http-clientdep +http-conduitdep +wai-extradep ~extradep ~transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: http-client, http-conduit, wai-extra

Dependency ranges changed: extra, transformers

API changes (from Hackage documentation)

Files

• CHANGES.txt +3/−0
• LICENSE +1/−1
• README.md +10/−10
• bake.cabal +13/−6
• src/Development/Bake/Build.hs +1/−1
• src/Development/Bake/Core/Args.hs +3/−7
• src/Development/Bake/Core/Client.hs +0/−2
• src/Development/Bake/Core/GC.hs +2/−2
• src/Development/Bake/Core/Message.hs +36/−36
• src/Development/Bake/Core/Run.hs +18/−3
• src/Development/Bake/Core/Type.hs +11/−1
• src/Development/Bake/Git.hs +25/−15
• src/Development/Bake/Server/Brain.hs +27/−16
• src/Development/Bake/Server/Database.hs +0/−1
• src/Development/Bake/Server/Memory.hs +2/−2
• src/Development/Bake/Server/Start.hs +14/−10
• src/Development/Bake/Server/Store.hs +18/−5
• src/Development/Bake/StepGit.hs +4/−2
• src/Example.hs +1/−1
• src/General/BigString.hs +154/−0
• src/General/Extra.hs +21/−12
• src/General/HTML.hs +47/−28
• src/General/Web.hs +42/−17
• src/Test.hs +6/−2

@@ -1,5 +1,8 @@ Changelog for Bake +0.5+    Allow extra-1.5.1+    #19, support much bigger files 0.4     Remove the --author parameter from many operations     Rewrite notifications

@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2014-2015.+Copyright Neil Mitchell 2014-2016. All rights reserved.  Redistribution and use in source and binary forms, with or without

@@ -36,16 +36,16 @@ The test suite provides both [an example configuration](https://github.com/ndmitchell/bake/blob/master/src/Example.hs) and [commands to drive it](https://github.com/ndmitchell/bake/blob/master/src/Test.hs). Here we annotate a slightly simplified version of the example, for lists of imports see the original code.  First we define an enumeration for where we want tests to run. Our server is going to require tests on both Windows and Linux before a `patch` is accepted.-+```haskell     data Platform = Linux | Windows deriving (Show,Read)     platforms = [Linux,Windows]-+``` Next we define the `test` type. A `test` is something that must pass before a `patch` is accepted.-+```haskell     data Action = Compile | Run Int deriving (Show,Read)-+``` Our type is named `Action`. We have two distinct types of tests, compiling the code, and running the result with a particular argument. Now we need to supply some information about the tests:-+```haskell     allTests = [(p,t) | p <- platforms, t <- Compile : map Run [1,10,0]]          execute :: (Platform,Action) -> TestInfo (Platform,Action)@@ -53,9 +53,9 @@         cmd "ghc --make Main.hs"     execute (p,Run i) = require [(p,Compile)] $ matchOS p $ run $ do         cmd ("." </> "Main") (show i)-+``` We have to declare `allTests`, then list of all tests that must pass, and `execute`, which gives information about a test. Note that the `test` type is `(Platform,Action)`, so a test is a platform (where to run the test) and an `Action` (what to run). The `run` function gives an `IO` action to run, and `require` specifies dependencies. We use an auxiliary `matchOS` to detect whether a test is running on the right platform:-+```haskell     #if WINDOWS     myPlatform = Windows     #else@@ -64,15 +64,15 @@      matchOS :: Platform -> TestInfo t -> TestInfo t     matchOS p = suitable (return . (==) myPlatform)-+``` We use the `suitable` function to declare whether a test can run on a particular client. Finally, we define the `main` function:-+```haskell     main :: IO ()     main = bake $         ovenGit "http://example.com/myrepo.git" "master" $         ovenTest readShowStringy (return allTests) execute         defaultOven{ovenServer=("127.0.0.1",5000)}-+``` We define `main = bake`, then fill in some configuration. We first declare we are working with Git, and give a repo name and branch name. Next we declare what the tests are, passing the information about the tests. Finally we give a host/port for the server, which we can visit in a web browser or access via the HTTP API.  

@@ -1,13 +1,13 @@-cabal-version:      >= 1.10+cabal-version:      >= 1.18 build-type:         Simple name:               bake-version:            0.4+version:            0.5 license:            BSD3 license-file:       LICENSE category:           Development author:             Neil Mitchell <ndmitchell@gmail.com> maintainer:         Neil Mitchell <ndmitchell@gmail.com>-copyright:          Neil Mitchell 2014-2015+copyright:          Neil Mitchell 2014-2016 synopsis:           Continuous integration system description:     Bake is a continuous integration server, designed for large, productive, semi-trusted teams.@@ -19,7 +19,7 @@     * /Semi-trusted teams/ where code does not go through manual code review, but code does need to pass a test suite and perhaps some static analysis. People are assumed not to be malicious, but are fallible. homepage:           https://github.com/ndmitchell/bake#readme bug-reports:        https://github.com/ndmitchell/bake/issues-tested-with:        GHC==7.10.1, GHC==7.8.4, GHC==7.6.3+tested-with:        GHC==8.0.1, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3  extra-doc-files:     CHANGES.txt@@ -46,11 +46,14 @@         time,         random,         hashable,-        transformers,+        transformers >= 0.4,         HTTP,         safe,         old-locale,+        http-conduit,+        http-client,         http-types,+        wai-extra,         deepseq,         filepath,         aeson,@@ -59,7 +62,7 @@         disk-free-space,         unordered-containers,         smtp-mail,-        extra >= 1.1,+        extra >= 1.5.1,         wai >= 3.0.1,         warp >= 3.0 @@ -87,6 +90,7 @@         Development.Bake.Server.Stats         Development.Bake.Server.Store         Development.Bake.Server.Web+        General.BigString         General.Database         General.Extra         General.HTML@@ -116,7 +120,10 @@         hashable,         HTTP,         safe,+        http-client,+        http-conduit,         http-types,+        wai-extra,         transformers,         deepseq,         aeson,

@@ -32,7 +32,7 @@                 whenM (doesFileExist $ ".." </> src </> ".bake.incremental") $ do                     putStrLn $ "Preparing by copying from " ++ src                     timed "copying for ovenIncremental" $-                        unit $ cmd "cp --preserve=timestamps --recursive --no-target-directory" ("../" ++ src) "."+                        cmd "cp --preserve=timestamps --recursive --no-target-directory" ("../" ++ src) "."  incrementalStart :: IO () incrementalStart =

@@ -118,13 +118,9 @@                         (stringyFrom state)                         (map stringyFrom patch) -                    -- check the patches all make sense-                    let follow t = map stringyTo $ testDepend $ ovenTestInfo oven $ stringyFrom t-                    whenJust (findCycle follow $ map stringyTo res) $ \xs ->-                        error $ unlines $ "Tests form a cycle:" : xs-                    let missing = transitiveClosure follow (map stringyTo res) \\ map stringyTo res-                    when (missing /= []) $-                        error $ unlines $ "Test is a dependency that cannot be reached:" : missing+                    case validTests (ovenTestInfo oven) res of+                        Left err -> fail err+                        Right () -> return ()                      writeFile ".bake.result" $ show $ map stringyTo res                 Just test -> do

@@ -14,7 +14,6 @@ import Data.IORef import Data.Tuple.Extra import System.Environment.Extra-import qualified Data.Text.Lazy as TL   -- given server, name, threads@@ -50,7 +49,6 @@                     ,"Id: " ++ show i                     ,"Result: " ++ (if aSuccess then "Success" else "Failure")                     ,"Duration: " ++ maybe "none" showDuration aDuration-                    ,"Output: " ++ TL.unpack aStdout                     ]                 atomicModifyIORef nowThreads $ \now -> (now + qThreads, ())                 sendMessage hp $ Finished q a

@@ -8,9 +8,9 @@ import System.FilePath import Control.Monad.Extra import Control.Applicative+import Data.Time.Clock import Data.Either.Extra import Data.List.Extra-import System.Time.Extra import Data.Maybe import System.DiskSpace import Prelude@@ -59,7 +59,7 @@     now <- getCurrentTime     let f gen file = fmap eitherToMaybe $ try_ $ do             t <- getModificationTime file-            return $ gen $ now `subtractTime` t+            return $ gen $ fromRational $ toRational $ now `diffUTCTime` t      fmap (concatMap catMaybes) $ forM dirs $ \dir -> do         dirs <- listContents dir

@@ -7,13 +7,13 @@  import Development.Bake.Core.Type import General.Web+import General.BigString import Control.Applicative import Control.Monad import Control.DeepSeq import Data.Aeson hiding (Success) import System.Time.Extra import Safe-import qualified Data.Text.Lazy as TL import qualified Data.ByteString.Lazy.Char8 as LBS import Prelude @@ -31,7 +31,7 @@     -- Sent by the client     | Pinged Ping     | Finished {question :: Question, answer :: Answer}-    deriving (Show,Eq)+    deriving Show  instance NFData Message where     rnf (AddPatch x y) = rnf x `seq` rnf y@@ -57,12 +57,12 @@     rnf (Question a b c d) = rnf (a,b,c,d)  data Answer = Answer-    {aStdout :: TL.Text+    {aStdout :: BigString     ,aDuration :: Maybe Seconds -- Nothing for a skip     ,aTests :: [Test]     ,aSuccess :: Bool     }-    deriving (Show,Eq)+    deriving Show  instance NFData Answer where     rnf (Answer a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d@@ -79,16 +79,7 @@ instance NFData Ping where     rnf (Ping a b c d e) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e --- JSON instance is only true for Finished-instance ToJSON Message where-    toJSON (Finished q a) = object ["question" .= q, "answer" .= a]-    toJSON _ = error "ToJSON Message is only supported for Finished" -instance FromJSON Message where-    parseJSON (Object v) = Finished <$>-        (v .: "question") <*> (v .: "answer")-    parseJSON _ = mzero- instance ToJSON Question where     toJSON Question{..} = object         ["candidate" .= toJSONCandidate qCandidate@@ -106,33 +97,30 @@ fromJSONCandidate (Object v) = (,) <$> (v .: "state") <*> (v .: "patches") fromJSONCandidate _ = mzero -instance ToJSON Answer where-    toJSON Answer{..} = object-        ["stdout" .= aStdout-        ,"duration" .= aDuration-        ,"tests" .= aTests-        ,"success" .= aSuccess] -instance FromJSON Answer where-    parseJSON (Object v) = Answer <$>-        (v .: "stdout") <*> (v .: "duration") <*> (v .: "tests") <*> (v .: "success")-    parseJSON _ = mzero-- messageToInput :: Message -> Input-messageToInput (AddPatch author patch) = Input ["api","add"] [("author",author),("patch",fromPatch patch)] ""-messageToInput (DelPatch patch) = Input ["api","del"] [("patch",fromPatch patch)] ""-messageToInput Requeue = Input ["api","requeue"] [] ""-messageToInput (SetState author state) = Input ["api","set"] [("author",author),("state",fromState state)] ""-messageToInput Pause = Input ["api","pause"] [] ""-messageToInput Unpause = Input ["api","unpause"] [] ""-messageToInput (AddSkip author test) = Input ["api","addskip"] [("author",author),("test",fromTest test)] ""-messageToInput (DelSkip test) = Input ["api","delskip"] [("test",fromTest test)] ""+messageToInput (AddPatch author patch) = Input ["api","add"] [("author",author),("patch",fromPatch patch)] []+messageToInput (DelPatch patch) = Input ["api","del"] [("patch",fromPatch patch)] []+messageToInput Requeue = Input ["api","requeue"] [] []+messageToInput (SetState author state) = Input ["api","set"] [("author",author),("state",fromState state)] []+messageToInput Pause = Input ["api","pause"] [] []+messageToInput Unpause = Input ["api","unpause"] [] []+messageToInput (AddSkip author test) = Input ["api","addskip"] [("author",author),("test",fromTest test)] []+messageToInput (DelSkip test) = Input ["api","delskip"] [("test",fromTest test)] [] messageToInput (Pinged Ping{..}) = Input ["api","ping"]      ([("client",fromClient pClient),("author",pAuthor)] ++      [("provide",x) | x <- pProvide] ++-     [("maxthreads",show pMaxThreads),("nowthreads",show pNowThreads)]) ""-messageToInput x@Finished{} = Input ["api","finish"] [] $ encode x+     [("maxthreads",show pMaxThreads),("nowthreads",show pNowThreads)]) []+messageToInput (Finished Question{..} Answer{..}) = Input ["api","finish"] []+    [("state", bigStringFromString $ fromState $ fst qCandidate)+    ,("patch", bigStringFromString $ unlines $ map fromPatch $ snd qCandidate)+    ,("test", bigStringFromString $ maybe "" fromTest qTest)+    ,("threads", bigStringFromString $ show qThreads)+    ,("client", bigStringFromString $ fromClient qClient)+    ,("stdout", aStdout)+    ,("duration", bigStringFromString $ maybe "" show aDuration)+    ,("tests", bigStringFromString $ unlines $ map fromTest aTests)+    ,("success", bigStringFromString $ show aSuccess)]   -- return either an error message (not a valid message), or a message@@ -148,11 +136,23 @@     | msg == "unpause" = pure Unpause     | msg == "ping" = Pinged <$> (Ping <$> (toClient <$> str "client") <*>         str "author" <*> strs "provide" <*> int "maxthreads" <*> int "nowthreads")-    | msg == "finish" = eitherDecode body     where strs x = Right $ map snd $ filter ((==) x . fst) args           str x | Just v <- lookup x args = Right v                 | otherwise = Left $ "Missing field " ++ show x ++ " from " ++ show msg           int x = readNote "messageFromInput, expecting Int" <$> str x+messageFromInput (Input [msg] args body)+    | msg == "finish" = do+        let f x = case lookup x body of Nothing -> Left $ "Missing field " ++ show x ++ " from " ++ show (map fst body); Just x -> Right x+        state <- toState . bigStringToString <$> f "state"+        patch <- map toPatch . lines . filter (/= '\r') . bigStringToString <$> f "patch"+        qTest <- (\x -> if null x then Nothing else Just $ toTest x) . bigStringToString <$> f "test"+        qThreads <- read . bigStringToString <$> f "threads"+        qClient <- toClient . bigStringToString <$> f "client"+        aStdout <- f "stdout"+        aDuration <- (\x -> if null x then Nothing else Just $ read x) . bigStringToString <$> f "duration"+        aTests <- map toTest . lines . filter (/= '\r') . bigStringToString <$> f "tests"+        aSuccess <- read . bigStringToString <$> f "success"+        return $ Finished Question{qCandidate=(state,patch),..} Answer{..} messageFromInput (Input msg args body) = Left $ "Invalid API call, got " ++ show msg  

@@ -8,9 +8,12 @@ import Development.Bake.Core.Message import Development.Shake.Command import Control.Exception.Extra+import General.BigString import General.Extra import System.Time.Extra import Control.DeepSeq+import Control.Concurrent.Extra+import System.IO.Unsafe import Data.Tuple.Extra import System.IO.Extra import System.Environment.Extra@@ -22,6 +25,11 @@ import qualified Data.Text.Lazy as TL  +{-# NOINLINE running #-}+running :: Var Int+running = unsafePerformIO $ newVar 0++ state x = "--state=" ++ fromState x patch x = "--patch=" ++ fromPatch x test  x = "--test="  ++ fromTest  x@@ -48,14 +56,21 @@      (time, res) <- duration $ try_ $ do         exe <- getExecutablePath-        (exit, Stdouterr out) <- cmd (Cwd dir) exe ("run" ++ name) args1 args2+        (out, exit) <- bigStringFromFile $ \file -> do+            res <- bracket_ (modifyVar_ running $ return . succ) (modifyVar_ running $ return . pred) $ do+                v <- readVar running+                print $ "RUNNING = " ++ show v+                cmd [Cwd dir, FileStdout file, FileStderr file] exe ("run" ++ name) args1 args2+            v <- readVar running+            print $ "RUNNING = " ++ show v+            return res         ex <- if exit /= ExitSuccess then return Nothing else do             ans <- fmap parse $ readFile' $ dir </> ".bake.result"             evaluate $ rnf ans             return $ Just ans-        return (ex, Answer (TL.pack out) (Just 0) [] (exit == ExitSuccess))+        return (ex, Answer out (Just 0) [] (exit == ExitSuccess))     case res of         Left e -> do             e <- showException e-            return (Nothing, Answer (TL.pack e) (Just time) [] False)+            return (Nothing, Answer (bigStringFromString e) (Just time) [] False)         Right (ex,ans) -> return (ex, ans{aDuration=Just time})

@@ -1,5 +1,5 @@ {-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable #-}-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ViewPatterns #-}  -- | Define a continuous integration system. module Development.Bake.Core.Type(@@ -14,6 +14,7 @@     Client, toClient, fromClient,     Point,     concrete, Prettys(..),+    validTests,     Author     ) where @@ -219,3 +220,12 @@         check s | null $ stringyTo s = error "Problem with stringyTo/stringyFrom, generated blank string"                 | stringyTo s == stringyTo (stringyFrom (stringyTo s) :: o) = s                 | otherwise = error $ "Problem with stringyTo/stringyFrom on " ++ stringyTo s+++-- | Check a set of tests is valid - no cycles and no dependencies that cannot be satisfied+validTests :: Stringy test => (test -> TestInfo test) -> [test] -> Either String ()+validTests info (map stringyTo -> res)+    | Just xs <- findCycle follow res = Left $ unlines $ "Tests form a cycle:" : xs+    | missing@(_:_) <- transitiveClosure follow res \\ res = Left $ unlines $ "Test is a dependency that cannot be reached:" : missing+    | otherwise = Right ()+    where follow t = map stringyTo $ testDepend $ info $ stringyFrom t

@@ -1,7 +1,7 @@ {-# LANGUAGE ViewPatterns #-}  module Development.Bake.Git(-    SHA1(..), sha1, ovenGit,+    SHA1, fromSHA1, toSHA1, ovenGit,     gitPatchExtra, gitInit     ) where @@ -21,19 +21,29 @@ import Prelude  -newtype SHA1 = SHA1 {fromSHA1 :: String} deriving (Show,Eq)+data SHA1 = SHA1 Int String deriving (Show,Eq) -- a number of leading primes, followed by a valid SHA1 -sha1 :: String -> SHA1-sha1 x | length x /= 40 = error $ "SHA1 for Git must be 40 characters long, got " ++ show x-       | not $ all (`elem` "0123456789abcdef") x = error $ "SHA1 for Git must be all lower case hex, got " ++ show x -       | otherwise = SHA1 x+-- | Convert a SHA1 obtained from Git into a SHA1. Only done by ovenInit or ovenUpdate+toSHA1 :: String -> SHA1+toSHA1 x = checkSHA1 x $ SHA1 0 x +fromSHA1 :: SHA1 -> String+fromSHA1 (SHA1 _ x) = x+ instance Stringy SHA1 where-    stringyTo = fromSHA1-    stringyPretty = take 7 . fromSHA1-    stringyFrom = sha1+    stringyFrom x = checkSHA1 b $ SHA1 (length a) b+        where (a,b) = span (== '\'') x+    stringyTo (SHA1 primes sha) = replicate primes '\'' ++ sha+    stringyPretty (SHA1 primes sha) = replicate primes '\'' ++ take 7 sha +-- either returns the second argument, or raises an error+checkSHA1 :: String -> a -> a+checkSHA1 x res+    | length x /= 40 = error $ "SHA1 for Git must be 40 characters long, got " ++ show x+    | not $ all (`elem` "0123456789abcdef") x = error $ "SHA1 for Git must be all lower case hex, got " ++ show x+    | otherwise = res + -- | Modify an 'Oven' to work with the Git version control system. --   Requires the name of the repo (e.g. @https:\/\/github.com\/ndmitchell\/bake.git@) --   and the name of a branch (e.g. @master@). You can optionally give a path fragment@@ -69,7 +79,7 @@             gitCheckout s ps             Stdout x <- time $ cmd (Cwd path) "git rev-parse" [branch]             time_ $ cmd (Cwd path) "git push" [repo] [branch ++ ":" ++ branch]-            return $ sha1 $ trim x+            return $ toSHA1 $ trim x          gitCheckout s ps = traced "gitCheckout" $ do             createDirectoryIfMissing True path@@ -96,7 +106,7 @@     Stdout hash <- time $ cmd "git ls-remote" [repo] [branch]     case words $ concat $ takeEnd 1 $ lines hash of         [] -> error "Couldn't find branch"-        x:xs -> return $ sha1 $ trim x+        x:xs -> return $ toSHA1 $ trim x   traced :: String -> IO a -> IO a@@ -118,13 +128,13 @@     return (renderHTML $ do str_ $ count ++ " patches"; br_; str_ summary            ,renderHTML $ pre_ $ str_ full) -gitPatchExtra (SHA1 s) (Just (SHA1 p)) dir = do+gitPatchExtra s (Just p) dir = do     Stdout diff <- time $ cmd (Cwd dir)-        "git diff" [s ++ "..." ++ p]+        "git diff" [fromSHA1 s ++ "..." ++ fromSHA1 p]     Stdout stat <- time $ cmd (Cwd dir)-        "git diff --stat" [s ++ "..." ++ p]+        "git diff --stat" [fromSHA1 s ++ "..." ++ fromSHA1 p]     Stdout log <- time $ cmd (Cwd dir)-        "git log --no-merges -n1 --pretty=format:%s" [p]+        "git log --no-merges -n1 --pretty=format:%s" [fromSHA1 p]     return (renderHTML $ do str_ $ reduceStat stat; br_; str_ $ take 120 $ takeWhile (/= '\n') log            ,renderHTML $ pre_ $ do prettyStat stat; str_ "\n"; prettyDiff diff) 

@@ -12,6 +12,7 @@ import Development.Bake.Core.Type import Development.Bake.Core.Message import General.Extra+import General.BigString import Data.Tuple.Extra import Data.Maybe import Data.Monoid@@ -20,7 +21,6 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Development.Bake.Server.Store-import qualified Data.Text.Lazy as TL import Control.Exception.Extra import General.HTML import Prelude@@ -49,8 +49,8 @@                 Pinged p | null $ fatal mem, Just q <- output (ovenTestInfo $ oven mem) mem p ->                     case () of                         -- we still test things on the skip list when testing on a state (to get some feedback)-                        _ | Just t <- qTest q, snd (qCandidate q) /= [], Just reason <- Map.lookup t (storeSkip $ store mem) ->-                            prod mem $ Finished q $ Answer (TL.pack $ "Skipped due to being on the skip list\n" ++ reason) Nothing [] True+                        _ | Just t <- qTest q, snd (qCandidate q) /= [], Just reason <- Map.lookup t (storeSkip $ store mem) -> do+                            prod mem $ Finished q $ Answer (bigStringFromString $ "Skipped due to being on the skip list\n" ++ reason) Nothing [] True                         _ -> do                             now <- getCurrentTime                             return (mem{running = (now,q) : running mem}, Just $ Right q)@@ -89,7 +89,7 @@             Shower{..} <- shower mem False             notify mem "Rejected"                 [ (paAuthor,) $ do-                    showPatch p <> str_ " submitted at " <> showTime paQueued+                    showPatch p <> str_ " submitted by " <> str_ paAuthor <> str_ " at " <> showTime paQueued                     str_ " rejected due to " <> showTestAt (point p) t                     whenJust (failingTestOutput store (point p) t) $ \s ->                         br_ <> br_ <> pre_ (summary s)@@ -106,7 +106,7 @@         -- don't notify people twice in quick succession         bad <- if mergeable mem then return id else             notify mem "Plausible"-                [ (paAuthor, showPatch p <> str_ " submitted at " <> showTime paQueued <> str_ " is now plausible")+                [ (paAuthor, showPatch p <> str_ " submitted by " <> str_ paAuthor <> str_ " at " <> showTime paQueued <> str_ " is now plausible")                 | p <- xs, let PatchInfo{..} = storePatch store p]         store <- storeUpdate store $ map IUPlausible xs         return $ bad mem{store = store}@@ -114,17 +114,17 @@     | mergeable mem     , not $ null $ snd active     = Just $ do-        (s, answer) <--            if not simulated then uncurry runUpdate active-            else do s <- ovenUpdate oven (fst active) (snd active); return (Just s, Answer mempty (Just 0) mempty True)+        (s, answer) <- if not simulated then uncurry runUpdate active else do+            s <- ovenUpdate oven (fst active) (snd active)+            return (Just s, Answer mempty (Just 0) mempty True)          case s of             Nothing -> do-                return mem{fatal = ("Failed to update\n" ++ TL.unpack (aStdout answer)) : fatal}+                return mem{fatal = ("Failed to update\n" ++ bigStringToString (aStdout answer)) : fatal}             Just s -> do                 Shower{..} <- shower mem False                 bad <- notify mem "Merged"-                    [ (paAuthor, showPatch p <> str_ " submitted at " <> showTime paQueued <> str_ " is now merged")+                    [ (paAuthor, showPatch p <> str_ " submitted by " <> str_ paAuthor <> str_ " at " <> showTime paQueued <> str_ " is now merged")                     | p <- snd active, let PatchInfo{..} = storePatch store p]                 store <- storeUpdate store $ IUState s answer (Just active) : map IUMerge (snd active)                 return $ bad mem{active = (s, []), store = store}@@ -138,9 +138,10 @@     , extendActive mem     , add@(_:_) <- Set.toList $ storeAlive store `Set.difference` Set.fromList (snd active)     = Just $ do+        add <- return $ sortOn (paQueued . storePatch store) add         store <- storeUpdate store $ map IUStart add         return mem-            {active = (fst active, snd active ++ sortOn (paQueued . storePatch store) add)+            {active = (fst active, snd active ++ add)             ,store = store}      | otherwise = Nothing@@ -169,14 +170,15 @@     if fst active == s then         return $ Left "state is already at that value"     else do-        store <- storeUpdate store [IUState s (Answer (TL.pack $ "From SetState by " ++ author) Nothing [] True) Nothing]+        store <- storeUpdate store [IUState s (Answer (bigStringFromString $ "From SetState by " ++ author) Nothing [] True) Nothing]         return $ Right mem{store = store, active = (s, snd active)}  update mem@Memory{..} Requeue = do     let add = Set.toList $ storeAlive store `Set.difference` Set.fromList (snd active)+    add <- return $ sortOn (paQueued . storePatch store) add     store <- storeUpdate store $ map IUStart add     return $ Right mem-        {active = (fst active, snd active ++ sortOn (paAuthor . storePatch store) add)+        {active = (fst active, snd active ++ add)         ,store = store}  update mem@Memory{..} Pause@@ -216,9 +218,15 @@             notifyAdmins mem "State failure" $ do                 str_ "State " <> showState (fst qCandidate)                 str_ " failed due to " <> showTestAt qCandidate qTest <> br_ <> br_-                pre_ $ summary $ TL.unpack aStdout+                pre_ (bigStringWithString aStdout summary)         _ -> return id +    case () of+        _ | qTest == Nothing+          , Left bad <- validTests (ovenTestInfo oven) aTests+          -> fail bad+        _ -> return ()+     now <- getCurrentTime     let (eq,neq) = partition ((==) q . snd) running     let time = head $ map fst eq ++ [now]@@ -238,9 +246,12 @@ 2) anyone not done in active or a superset 3) anyone not done in active -}-output info mem@Memory{..} Ping{..} = -- trace (show (length bad, length good)) $-        fmap question $ enoughThreads $ listToMaybe $ filter suitable $ nubOrd $ concatMap dependencies $ bad ++ good+output info mem@Memory{..} Ping{..}+    | False, pNowThreads == pMaxThreads, isNothing res = error $ show (enoughThreads $ listToMaybe $ filter suitable $ nubOrd $ concatMap dependencies $ bad ++ good, filter suitable good, concatMap dependencies $ bad ++ good, bad, good)+    | otherwise = res     where+        res = fmap question $ enoughThreads $ listToMaybe $ filter suitable $ nubOrd $ concatMap dependencies $ bad ++ good+         self = storePoint store active         failedSelf = Set.toList $ poFail self         failedPrefix = Map.fromListWith mappend $

@@ -25,7 +25,6 @@ import Database.SQLite.Simple import Database.SQLite.Simple.FromField import Database.SQLite.Simple.ToField-import System.Time.Extra import Data.Hashable import Data.List.Extra import Control.Monad

@@ -89,7 +89,7 @@ notifyAdmins mem subject message = notify mem subject $ map (,message) $ admins mem  summary :: String -> HTML-summary x | length x < 10000 = str_ x+summary x | null $ drop 10000 x {- space efficient version of: length x < 10000 -} = str_ x           | otherwise = str_ (take 5000 x) <> br_ <> str_ "..." <> br_ <> str_ (takeEnd 5000 x)  data Shower = Shower@@ -124,7 +124,7 @@         ,showTest = f Nothing Nothing []         ,showTestAt = \(s,ps) -> f Nothing (Just s) ps         ,showQuestion = \Question{..} -> f (Just qClient) (Just $ fst qCandidate) (snd qCandidate) qTest-        ,showTime = \x -> span__ [class_ "nobr"] $ str_ $ showUTCTime "%H:%M" x ++ " (" ++ showRel x ++ ")"+        ,showTime = \x -> span__ [class_ "nobr"] $ str_ $ showUTCTime "%H:%M" x ++ " UTC (" ++ showRel x ++ ")"         ,showThreads = \i -> str_ $ show i ++ " thread" ++ ['s' | i /= 1]         }     where

@@ -11,6 +11,7 @@ import Development.Bake.Core.Message import Development.Bake.Core.Run import General.Extra+import General.BigString import Development.Bake.Server.Brain import Development.Bake.Server.Web import Development.Bake.Server.Stats@@ -87,7 +88,7 @@                  else if ["api"] `isPrefixOf` inputURL then                     case messageFromInput i{inputURL = drop 1 inputURL} of-                        Left e -> return $ OutputError e+                        Left e -> return $ OutputError $ "Encoding error when turning input into message, " ++ e ++ "\n\n" ++ take 100 (show i)                         Right v -> do                             evaluate $ rnf v                             res <- modifyCVar var $ \s -> do@@ -96,7 +97,7 @@                                         res <- patchExtra (fst $ active s) $ Just p                                         storeExtraAdd (store s) (Right p) res                                     _ -> return ()-                                (s2,q) <- recordIO $ (["brain"],) <$> prod (prune s) v+                                (s2,q) <- recordIO $ (["brain",lower $ fst $ word1 $ show v],) <$> prod (prune s) v                                 when (fst (active s2) /= fst (active s)) $ extra $ do                                     res <- patchExtra (fst $ active s2) Nothing                                     storeExtraAdd (store s2) (Left $ fst $ active s2) res@@ -115,8 +116,8 @@  clientChange :: Memory -> Memory -> IO (Memory -> Memory) clientChange s1 s2 = do-    let before = Map.keysSet $ clients s1-    let after  = Map.keysSet $ clients s2+    let before = Map.keysSet $ Map.filter ciAlive $ clients s1+    let after  = Map.keysSet $ Map.filter ciAlive $ clients s2     let f msg xs = sequence [notifyAdmins s2 (msg ++ ": " ++ fromClient x) $ str_ "" | x <- Set.toList xs]     a <- f "Client added" $ after `Set.difference` before     b <- f "Client timed out" $ before `Set.difference` after@@ -126,7 +127,7 @@ initialiseFake :: Oven State Patch Test -> Prettys -> IO Memory initialiseFake oven prettys = do     store <- newStore False "bake-store"-    mem <- newMemory oven prettys store (stateFailure, Answer (TL.pack "Initial state created by view mode") Nothing [] False)+    mem <- newMemory oven prettys store (stateFailure, Answer (bigStringFromString "Initial state created by view mode") Nothing [] False)     return mem{fatal = ["View mode, database is read-only"]}  initialise :: Oven State Patch Test -> Prettys -> [Author] -> Worker -> IO Memory@@ -140,11 +141,11 @@     when (isJust res) $ do         extra $ storeExtraAdd store (Left state0) =<< patchExtra state0 Nothing     mem <- newMemory oven prettys store (state0, answer)-    mem <- return mem{admins = admins ,fatal = ["Failed to initialise, " ++ TL.unpack (aStdout answer) | isNothing res]}+    mem <- return mem{admins = admins ,fatal = ["Failed to initialise, " ++ bigStringToString (aStdout answer) | isNothing res]}      bad <- if isJust res then notifyAdmins mem "Starting" $ str_ "Server starting" else         notifyAdmins mem "Fatal error during initialise" $-            str_ "Failed to initialise" <> br_ <> pre_ (summary $ TL.unpack $ aStdout answer)+            str_ "Failed to initialise" <> br_ <> pre_ (bigStringWithString (aStdout answer) summary)     return $ bad mem  @@ -152,6 +153,9 @@ patchExtra :: State -> Maybe Patch -> IO (T.Text, TL.Text) patchExtra s p = do     (ex,ans) <- runExtra s p-    let failSummary = T.pack $ renderHTML $ i_ $ str_ "Error when computing patch information"-    let failDetail = TL.pack $ renderHTML $ pre_ $ str_ $ TL.unpack $ aStdout ans-    return $ fromMaybe (failSummary, failDetail) ex+    case ex of+        Just x -> return x+        Nothing -> do+            let failSummary = T.pack $ renderHTML $ i_ $ str_ "Error when computing patch information"+            let failDetail = TL.pack $ renderHTML $ pre_ $ str_ (bigStringToString $ aStdout ans)+            return (failSummary, failDetail)

@@ -20,7 +20,7 @@ import qualified Data.Set as Set import qualified Data.Map as Map import General.Extra-import System.Time.Extra+import General.BigString import Data.Char import Data.List.Extra import System.IO.Unsafe@@ -298,13 +298,26 @@     | PURun UTCTime Question Answer       deriving Show +instance NFData Update where+    rnf (IUState a b c) = rnf (a,b,c)+    rnf (IUQueue a b) = rnf (a,b)+    rnf (IUStart a) = rnf a+    rnf (IUDelete a) = rnf a+    rnf (IUReject a b c) = rnf (a,b,c)+    rnf (IUPlausible a) = rnf a+    rnf (IUSupersede a) = rnf a+    rnf (IUMerge a) = rnf a+    rnf (SUAdd a b) = rnf (a,b)+    rnf (SUDel a) = rnf a+    rnf (PURun a b c) = rnf (a,b,c)+ -- don't inline so GHC can't tell the store is returned unchanged {-# NOINLINE storeUpdate #-} storeUpdate :: Store -> [Update] -> IO Store storeUpdate store xs = do     -- important so that if the updates depend on the current store they are forced first     -- the perils of impurity!-    evaluate $ rnf $ show xs+    evaluate $ rnf xs      now <- getCurrentTime     (\f -> foldM f store xs) $ \store x -> do@@ -323,7 +336,7 @@                         sqlUpdate conn [saCreate := now, saPoint := pt, saDuration := aDuration] [saId %== x]                         return x                 createDirectoryIfMissing True (path </> show x)-                TL.writeFile (path </> show x </> "update.txt") aStdout+                bigStringToFile aStdout $ path </> show x </> "update.txt"             IUQueue p a -> do                 void $ sqlInsert conn pcTable (p,a,now,Nothing,Nothing,Nothing,Nothing,Nothing,Nothing)             IUStart p -> do@@ -340,7 +353,7 @@                 pt2 <- fst <$> cachePoint cache pt                 pa <- fst <$> cachePatch cache p                 Only run:_ <- sqlSelect conn rnId [rnSuccess %== False, rnPoint %== pt2, rnTest %== t]-                sqlUpdate conn [pcReject := Just now] [pcPatch %== p]+                sqlUpdate conn [pcReject := Just now] [pcPatch %== p, pcReject %== Nothing]                 void $ sqlInsert conn rjTable (pa, t, run)             SUAdd t msg -> do                 void $ sqlInsert conn skTable (t, msg)@@ -358,7 +371,7 @@                             putStrLn $ "Warning: Test disagreement at " ++ show pt ++ ", maybe a changed generator?"                 x <- sqlInsert conn rnTable (pt,qTest,aSuccess,qClient,t,aDuration)                 createDirectoryIfMissing True $ path </> show pt-                TL.writeFile (path </> show pt </> show x ++ "-" ++ maybe "Prepare" (safely . fromTest) qTest <.> "txt") aStdout+                bigStringToFile aStdout $ path </> show pt </> show x ++ "-" ++ maybe "Prepare" (safely . fromTest) qTest <.> "txt"  safely :: String -> String safely = map f . take 100

@@ -50,12 +50,14 @@             withFileLock (root </> ".bake-lock") $ do                 ready <- doesFileExist $ git </> ".git/HEAD"                 if ready then do+                    -- if a branch goes away on the server this is required+                    time_ $ cmd (Cwd git) "git remote prune origin"                     -- for some reason git sometimes times out, not sure why                     -- hopefully this will help track it down                     time_ $ cmd (Cwd git) (Timeout $ 15*60) "git fetch"                     -- stops us creating lots of garbage in the reflog, which slows everything down                     -- time_ $ cmd (Cwd git) "git reflog expire --all --expire=all --expire-unreachable=all"-                    time_ $ cmd (Cwd git) "git reset" -- to unwedge a previous merge conflict+                    time_ $ cmd (Cwd git) "git reset --hard" -- to unwedge a previous merge conflict                     time_ $ cmd (Cwd git) "git clean -dfx" ["-e" ++ x | x <- keep] -- to remove files left over from a previous merge conflict                  else do                     time_ $ cmd (Cwd git) "git clone" [repo] "."@@ -87,7 +89,7 @@                 -- since we support SetState                 Exit _ <- time $ cmd (Cwd git) "git push" [repo] [":" ++ branch]                 time_ $ cmd (Cwd git) "git push" [repo] [branch ++ ":" ++ branch]-                return $ sha1 $ trim x+                return $ toSHA1 $ trim x          stepPrepare s ps = do             root <- root

@@ -9,7 +9,7 @@ import Data.List.Extra import Data.Tuple.Extra import System.Directory-import Control.Monad.Extra+import Control.Monad import Data.Maybe import System.Time.Extra 

@@ -0,0 +1,154 @@++module General.BigString(+    BigString,+    bigStringFromFile, bigStringFromText, bigStringFromString, bigStringFromByteString,+    bigStringToFile, bigStringToText, bigStringToString, bigStringWithString, bigStringToByteString,+    bigStringBackEnd, withBigStringPart+    ) where++import System.IO.Extra+import Control.DeepSeq+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.Concurrent+import System.IO.Unsafe+import Control.Exception+import Data.Monoid+import System.Directory+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.IO as T+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as LBS+import Network.Wai.Parse+import Data.Function+import Control.Monad+import Network.HTTP.Client.MultipartFormData+import Prelude++limit = 5000 -- above this level, save to disk+++---------------------------------------------------------------------+-- DEFINITION++data BigString = Memory T.Text+               | File FilePath (ForeignPtr ())++instance Monoid BigString where+    mempty = bigStringFromText mempty+    mappend (Memory a) (Memory b) | T.length a + T.length b <= limit = Memory $ a <> b+    mappend x y = unsafeWriteHandle $ \out -> do+        hSetBinaryMode out True+        forM_ [x,y] $ \inp -> readHandle inp $ \inp -> do+            hSetBinaryMode inp True+            src <- LBS.hGetContents inp+            LBS.hPut out src++instance NFData BigString where+    rnf (Memory x) = rnf x+    rnf (File a b) = rnf a `seq` b `seq` ()++instance Show BigString where+    show _ = "<BigString>"++---------------------------------------------------------------------+-- PRIMITIVES++bigStringFromFile :: (FilePath -> IO a) -> IO (BigString, a)+bigStringFromFile op = do+    (file, close) <- newTempFile+    ptr <- newForeignPtr_ nullPtr+    Foreign.Concurrent.addForeignPtrFinalizer ptr close+    res <- withForeignPtr ptr $ const $ op file+    return (File file ptr, res)++-- Not exported, as it is a bit unsafe - two invariants:+-- 1) must not use file after returning+-- 2) must not write to the file+bigStringWithFile :: BigString -> (FilePath -> IO a) -> IO a+bigStringWithFile (Memory x) op = withTempFile $ \file -> do T.writeFile file x; op file+bigStringWithFile (File file ptr) op = withForeignPtr ptr $ const $ op file+++writeHandle :: (Handle -> IO ()) -> IO BigString+writeHandle op = fmap fst $ bigStringFromFile $ \file ->+    withFile file WriteMode $ \h -> do+        hSetNewlineMode h noNewlineTranslation+        hSetEncoding h utf8+        op h++readHandle :: BigString -> (Handle -> IO a) -> IO a+readHandle x op = bigStringWithFile x $ \file ->+    withFile file ReadMode $ \h -> do+        hSetNewlineMode h noNewlineTranslation+        hSetEncoding h utf8+        op h+++{-# NOINLINE unsafeWriteHandle #-}+unsafeWriteHandle :: (Handle -> IO ()) -> BigString+unsafeWriteHandle op = unsafePerformIO $ writeHandle op++{-# NOINLINE unsafeReadHandle #-}+unsafeReadHandle :: BigString -> (Handle -> IO a) -> a+unsafeReadHandle x op = unsafePerformIO $ readHandle x op+++---------------------------------------------------------------------+-- DERIVED++bigStringFromText :: T.Text -> BigString+bigStringFromText x | T.length x <= limit = Memory x+                    | otherwise = unsafeWriteHandle (`T.hPutStr` x)++bigStringFromString :: String -> BigString+bigStringFromString x | null $ drop limit x = Memory $ T.pack x+                      | otherwise = unsafeWriteHandle (`hPutStr` x)++bigStringToFile :: BigString -> FilePath -> IO ()+bigStringToFile (Memory x) out = withFile out WriteMode $ \h -> do+    hSetNewlineMode h noNewlineTranslation+    hSetEncoding h utf8+    T.hPutStr h x+bigStringToFile x out = bigStringWithFile x $ \file -> copyFile file out++bigStringToText :: BigString -> T.Text+bigStringToText (Memory x) = x+bigStringToText x = unsafeReadHandle x T.hGetContents++bigStringToString :: BigString -> String+bigStringToString (Memory x) = T.unpack x+bigStringToString x = unsafeReadHandle x $ fmap T.unpack . T.hGetContents++bigStringWithString :: NFData a => BigString -> (String -> a) -> a+bigStringWithString (Memory x) op = let res = op $ T.unpack x in rnf res `seq` res+bigStringWithString x op = unsafeReadHandle x $ \h -> do+    src <- hGetContents h+    let res = op src+    evaluate $ rnf res+    return res++bigStringFromByteString :: BS.ByteString -> BigString+bigStringFromByteString x | BS.length x <= limit = Memory $ T.decodeUtf8 x+                          | otherwise = unsafeWriteHandle $ \h -> do hSetBinaryMode h True; BS.hPutStr h x++bigStringToByteString :: BigString -> BS.ByteString+bigStringToByteString (Memory x) = T.encodeUtf8 x+bigStringToByteString x = unsafeReadHandle x $ \h -> do hSetBinaryMode h True; BS.hGetContents h+++---------------------------------------------------------------------+-- WEBBY++bigStringBackEnd :: BackEnd BigString+bigStringBackEnd _ _ ask = writeHandle $ \h -> do+    fix $ \loop -> do+        bs <- ask+        unless (BS.null bs) $ do+            BS.hPut h bs+            loop++withBigStringPart :: String -> BigString -> (Part -> IO a) -> IO a+withBigStringPart name (Memory x) op = op $ partBS (T.pack name) (T.encodeUtf8 x)+withBigStringPart name body op = bigStringWithFile body $ \file -> op $ partFileSourceChunked (T.pack name) file

@@ -3,7 +3,7 @@ -- time changed incompatibly, use the functions that work everywhere  module General.Extra(-    UTCTime, getCurrentTime, addSeconds, showRelativeTime, relativeTime, showUTCTime,+    Seconds, UTCTime, getCurrentTime, addSeconds, showRelativeTime, relativeTime, showUTCTime,     readDate, showDate, timeToDate, dateToTime,     createDir,     withFileLock,@@ -21,6 +21,8 @@     transitiveClosure, findCycle,     putBlock,     maybe',+    withs,+    retrySleep,     commas, commasLimit, unwordsLimit     ) where @@ -55,22 +57,23 @@ addSeconds :: Seconds -> UTCTime -> UTCTime addSeconds x = addUTCTime (fromRational $ toRational x) +-- | Calculate the difference between two times in seconds.+diffTime :: UTCTime -> UTCTime -> Seconds+diffTime end start = fromRational $ toRational $ end `diffUTCTime` start+ relativeTime :: IO (UTCTime -> Seconds) relativeTime = do     now <- getCurrentTime-    return $ \old -> subtractTime now old+    return $ \old -> diffTime now old  showRelativeTime :: IO (UTCTime -> String) showRelativeTime = do     now <- getCurrentTime     return $ \old ->-        let secs = subtractTime now old-            mins = secs / 60-            hours = mins / 60-        in if timeToDate now /= timeToDate old then showDate (timeToDate old)-        else if hours > 5 then show (round hours) ++ " hours ago"-        else if mins > 2 then show (round mins) ++ " mins ago"-        else show (max 2 $ round secs) ++ " secs ago"+        let secs = diffTime now old in+        if timeToDate now /= timeToDate old then showDate (timeToDate old)+        else if secs < 60 then show (max 1 $ floor secs) ++ "s ago" -- 4.32s is too precise, 0s feels wrong+        else showDuration secs ++ " ago"  showUTCTime :: String -> UTCTime -> String showUTCTime = formatTime defaultTimeLocale@@ -112,9 +115,6 @@     return name  -eitherToMaybe :: Either a b -> Maybe b-eitherToMaybe = either (const Nothing) Just- pick :: [a] -> IO a pick xs = randomRIO (0, (length xs - 1)) >>= return . (xs !!) @@ -291,7 +291,12 @@ whenRight :: Applicative m => Either a b -> (b -> m ()) -> m () whenRight x f = either (const $ pure ()) f x +retrySleep :: Exception e => Seconds -> Int -> (e -> Bool) -> IO a -> IO a+retrySleep secs times test act+     | times <= 0 = act+     | otherwise = catchBool test act $ const $ sleep secs >> retrySleep secs (times-1) test act + --------------------------------------------------------------------- -- FORMATTING @@ -317,3 +322,7 @@  maybe' :: Maybe a -> b -> (a -> b) -> b maybe' x nothing just = maybe nothing just x++withs :: [(a -> r) -> r] -> ([a] -> r) -> r+withs [] act = act []+withs (f:fs) act = f $ \a -> withs fs $ \as -> act $ a:as

@@ -1,18 +1,26 @@-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ViewPatterns, GeneralizedNewtypeDeriving #-} +-- | Library for defining HTML fragments.+--   The tags will be properly nested, and all strings will be HTML escaped.+--   As an example:+--+-- > renderHTML $ html_ $+-- >    ol__ [style_ "color:darkgreen"] $+-- >        forM_ [1..10] $ \i -> li_ $ str_ $ "item number: " & show i module General.HTML(-    -- * Library-    url_,-    HTML, HTML_, renderHTML, valueHTML, str_, raw_,-    Attribute, attribute_,-    tag_, tag__,-    (<>),+    -- * HTML data type+    HTML, HTML_, renderHTML, valueHTML,+    -- * Constructing pieces+    Attribute, attribute_, tag_, tag__, str_, raw_,     -- * Tags     br_, style__, link__, hr_,-    pre_, b_, html_, head_, title_, body_, h1_, h2_, ul_, li_, p_, table_, thead_, tr_, td_, tbody_, i_,-    a__, span__, p__, h2__, tr__,+    pre_, b_, html_, head_, title_, body_, h1_, h2_, ul_, ol_, li_, p_, table_, thead_, tr_, td_, tbody_, i_,+    a__, span__, p__, h2__, tr__, ol__,+    -- * Attributes     href_, class_, name_, rel_, type_, style_, id_,     -- * Functions+    (<>),+    url_,     unlines_, commas_, commasLimit_, header_     ) where @@ -20,6 +28,8 @@ import Data.Monoid import Data.List import Control.Monad+import Control.Monad.Trans.Writer+import Control.DeepSeq import Data.Char import Numeric import Prelude@@ -33,6 +43,10 @@ instance Eq Rope where a == b = renderRope a == renderRope b instance Ord Rope where compare a b = compare (renderRope a) (renderRope b) +instance NFData Rope where+    rnf (Branch x) = rnf x+    rnf (Leaf x) = rnf x+ renderRope :: Rope -> String renderRope x = f x ""     where f (Branch []) k = k@@ -49,47 +63,46 @@     mconcat = Branch  +-- | Escape a URL using % encoding. url_ :: String -> String url_ = concatMap f     where         f x | (x >= 'A' && x <= 'Z') || (x >= 'a' && x <= 'z') || (x >= '0' && x <= '9') || x `elem` "-_.~" = [x]         f (ord -> x) = "%" ++ ['0' | x < 16] ++ showHex x "" --data HTML_ a = HTML_ Rope a deriving (Eq,Ord)+-- | The type for constructing HTML. It is a 'Monad' and 'Monoid'.+--   Typically the value paramter is '()', in which case use 'HTML'.+newtype HTML_ a = HTML_ {fromHTML_ :: Writer Rope a}+    deriving (Eq,Ord,Functor,Applicative,Monad) +-- | An alias for 'HTML_' with no interesting type. type HTML = HTML_ () +-- | Get the value out of an 'HTML_'. valueHTML :: HTML_ a -> a-valueHTML (HTML_ _ x) = x+valueHTML = fst . runWriter . fromHTML_ +-- | Render some 'HTML'. renderHTML :: HTML -> String-renderHTML (HTML_ x _) = renderRope x+renderHTML = renderRope . execWriter . fromHTML_  nullHTML :: HTML -> Bool-nullHTML (HTML_ x _) = nullRope x+nullHTML = nullRope . execWriter . fromHTML_  instance Monoid a => Monoid (HTML_ a) where-    mempty = HTML_ mempty mempty-    mappend (HTML_ x1 x2) (HTML_ y1 y2) = HTML_ (x1 `mappend` y1) (x2 `mappend` y2)--instance Functor HTML_ where-    fmap f (HTML_ a b) = HTML_ a $ f b--instance Applicative HTML_ where-    pure = HTML_ mempty-    HTML_ x1 x2 <*> HTML_ y1 y2 = HTML_ (x1 `mappend` y1) (x2 y2)--instance Monad HTML_ where-    return = pure-    HTML_ x1 x2 >>= f = let HTML_ y1 y2 = f x2 in HTML_ (x1 `mappend` y1) y2+    mempty = return mempty+    mappend = liftM2 mappend +instance NFData a => NFData (HTML_ a) where+    rnf = rnf . runWriter . fromHTML_ +-- | Turn a string into a text fragment of HTML, escaping any characters which mean something in HTML. str_ :: String -> HTML str_ = raw_ . escapeHTML +-- | Turn a string into an HTML fragment, applying no escaping. Use this function carefully. raw_ :: String -> HTML-raw_ x = HTML_ (Leaf x) ()+raw_ = HTML_ . tell . Leaf  escapeHTML :: String -> String escapeHTML = concatMap $ \c -> case c of@@ -101,16 +114,19 @@     x    -> [x]  +-- | An attribute for a tag. data Attribute = Attribute {fromAttribute :: String}  valid (x:xs) | isAlpha x && all isAlphaNum xs = True valid x = error $ "Not a valid HTML name, " ++ show x +-- | Construct an Attribute from a key and value string. The value will be escaped. attribute_ :: String -> String -> Attribute attribute_ a b | valid a = Attribute $ a ++ "=\"" ++ escapeHTML b ++ "\""                | otherwise = error $ "Invalid attribute name, " ++ a  +-- | Given a tag name, a list of attributes, and some content HTML, produce some new HTML. tag__ :: String -> [Attribute] -> HTML -> HTML tag__ name at inner | not $ valid name = error $ "Invalid tag name, " ++ name                     | otherwise = do@@ -125,6 +141,7 @@         inner         raw_ $ "</" ++ name ++ ">" +-- | Like 'tag__' but with no attributes. tag_ :: String -> HTML -> HTML tag_ name = tag__ name [] @@ -147,6 +164,7 @@ h1_ = tag_ "h1" h2_ = tag_ "h2" ul_ = tag_ "ul"+ol_ = tag_ "ol" li_ = tag_ "li" p_ = tag_ "p" table_ = tag_ "table"@@ -160,6 +178,7 @@ p__ = tag__ "p" h2__ = tag__ "h2" tr__ = tag__ "tr"+ol__ = tag__ "ol"  href_ = attribute_ "href" class_ = attribute_ "class"

@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, RecordWildCards, OverloadedStrings, CPP #-}+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- Use conduitManagerSettings to work with http-conduit-2.1.6 and below  module General.Web(     Input(..), Output(..), send, server@@ -12,24 +13,32 @@ import Network.Wai.Handler.Warp hiding (Port) #endif +-- S for server, C for client import Development.Bake.Core.Type hiding (run)-import Network.Wai+import Network.Wai as S+import Network.Wai.Parse as P+import Data.Function+import General.Extra+import General.BigString import Control.DeepSeq import Control.Exception+import Control.Applicative import Control.Monad import System.IO+import Network.HTTP.Conduit as C+import Network.HTTP.Client.MultipartFormData import Network.HTTP.Types.Status-import Network.HTTP hiding (Request) import qualified Data.Text as Text import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import System.Console.CmdArgs.Verbosity+import Prelude   data Input = Input     {inputURL :: [String]     ,inputArgs :: [(String, String)]-    ,inputBody :: LBS.ByteString+    ,inputBody :: [(String, BigString)]     } deriving Show  data Output@@ -47,20 +56,34 @@     rnf (OutputError x) = rnf x     rnf OutputMissing = () +{-+-- | Number of time to retry sending messages+maxRetryCount :: Int+maxRetryCount = 3 +-- | Timeout between each message sending attempt+retryTimeout :: Seconds+retryTimeout = 10+-}++ send :: (Host,Port) -> Input -> IO LBS.ByteString send (host,port) Input{..} = do     let url = "http://" ++ host ++ ":" ++ show port ++ concatMap ('/':) inputURL ++               concat (zipWith (++) ("?":repeat "&") [a ++ "=" ++ b | (a,b) <- inputArgs])-    whenLoud $ print ("sending",inputBody,host,port)-    res <- simpleHTTP (getRequest url)-        {rqBody=inputBody-        ,rqHeaders=[Header HdrContentType "application/x-www-form-urlencoded", Header HdrContentLength $ show $ LBS.length inputBody]}-    case res of-        Left err -> error $ show err-        Right r | rspCode r /= (2,0,0) -> error $-                    "Incorrect code: " ++ show (rspCode r,rspReason r,url) ++ "\n" ++ show (rspBody r)-                | otherwise -> return $ rspBody r+    whenLoud $ print ("sending",length inputBody,host,port)+    req <- parseUrl url+    m <- newManager conduitManagerSettings+    withs (map (uncurry withBigStringPart) inputBody) $ \parts -> do+        body <- formDataBody parts req+        responseBody <$> httpLbs body m+{-+    -- http-client 0.5 completely changes this API, so give up retrying until it can be tested+        responseBody <$> retrySleep retryTimeout maxRetryCount isConnFailure (httpLbs body m)+    where+        isConnFailure FailedConnectionException2{} = True+        isConnFailure _ = False+-}   server :: Port -> (Input -> IO Output) -> IO ()@@ -68,12 +91,13 @@ server port act = return () #else server port act = runSettings settings $ \req reply -> do-    bod <- strictRequestBody req-    whenLoud $ print ("receiving",bod,requestHeaders req,port)+    whenLoud $ print ("receiving", map Text.unpack $ pathInfo req, S.requestHeaders req, port)+    (params, files) <- parseRequestBody bigStringBackEnd req+     let pay = Input             (map Text.unpack $ pathInfo req)-            [(BS.unpack a, maybe "" BS.unpack b) | (a,b) <- queryString req]-            bod+            [(BS.unpack a, maybe "" BS.unpack b) | (a,b) <- S.queryString req] $+            [(BS.unpack name, bigStringFromByteString x) | (name,x) <- params] ++ [(BS.unpack name, fileContent) | (name, P.FileInfo{..}) <- files]     res <- act pay     -- from http://stackoverflow.com/questions/49547/making-sure-a-web-page-is-not-cached-across-all-browsers     let nocache = [("Cache-Control","no-cache, no-store, must-revalidate")@@ -91,7 +115,8 @@                    setPort port defaultSettings  -exception :: Maybe Request -> SomeException -> IO ()++exception :: Maybe S.Request -> SomeException -> IO () exception r e = when (defaultShouldDisplayException e) $     hPutStrLn stderr $ "Error when processing " ++ maybe "Nothing" (show . rawPathInfo) r ++ "\n    " ++ show e #endif

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-}  module Test(main) where @@ -7,7 +8,7 @@ import System.Time.Extra import System.Environment.Extra import System.FilePath-import Control.Monad.Extra+import Control.Monad import Control.Exception.Extra import Control.Concurrent import System.Process@@ -37,6 +38,9 @@         unit $ cmd "chmod -R 755 .bake-test"         unit $ cmd "rm -rf .bake-test"         return ()+#if __GLASGOW_HASKELL__ >= 708+    setEnv "http_proxy" ""+#endif      createDirectoryIfMissing True (dir </> "repo")     withCurrentDirectory (dir </> "repo") $ do@@ -71,7 +75,7 @@     createDirectoryIfMissing True $ dir </> "server"     curdir <- getCurrentDirectory     environment <- (\env -> ("REPO",repo):("bake_datadir",curdir):env) <$> getEnvironment-    p0 <- createProcessAlive (proc exe ["server"])+    p0 <- createProcessAlive (proc exe ["server","--author=admin"])         {cwd=Just $ dir </> "server", env=Just environment}     sleep 5     ps <- forM (zip [1..] Example.platforms) $ \(i,p) -> do