Permalink
Browse files

minor cosmetics.

  • Loading branch information...
marius a. eriksen
marius a. eriksen committed Aug 2, 2009
1 parent 5e2bc92 commit b98ee46bc279dab57b3424a5888f2ded4030a06c
Showing with 16 additions and 13 deletions.
  1. +1 −1 Data/Task/QueueSet.hs
  2. +1 −1 Makefile
  3. +5 −4 Request.hs
  4. +9 −7 ezq.hs
View
@@ -28,7 +28,7 @@ add t name (QS m) =
getAny :: System.Time.ClockTime -- ^ Current time
-> [(String, Int)] -- ^ [(Name, howlong)]
-> QueueSet a -- ^ The queueset
- -> Maybe (((String, Q.Ident), a), QueueSet a)
+ -> Maybe ((Ident, a), QueueSet a)
getAny now names (QS m) =
takeFirst eligible
where
View
@@ -7,4 +7,4 @@ test:
cd tests; make
clean:
- rm -f *.hi *.o ezq
+ rm -f *.hi *.o ezq dist
View
@@ -7,7 +7,6 @@ module Request(
import Text.JSON
import System.Time
-import Data.Map (Map)
import qualified Data.Map as Map
import Data.Task.QueueSet(QueueSet)
import qualified Data.Task.QueueSet as QS
@@ -44,8 +43,10 @@ instance JSON Request where
where
mapsnd f = map (\(x, y) -> (x, f y))
- collectQueues = Map.toList . Map.fromListWith (++) . map opToAssoc
- opsToObject = toJSObject . Map.toList . Map.fromListWith (++)
+ concatAssocs = Map.toList . Map.fromListWith (++)
+
+ collectQueues = concatAssocs . map opToAssoc
+ opsToObject = toJSObject . concatAssocs
opToAssoc op@(Add queue task) = (queue, [("add", [showJSON task])])
opToAssoc op@(Remove queue ident) = (queue, [("remove", [showJSON ident])])
@@ -65,7 +66,7 @@ instance JSON Request where
parseAdd q = readJSON q >>= return . Add queue
parseRemove q = readJSON q >>= return . Remove queue
- -- kind of weird this isn't in the prelude.
+ -- Kind of weird something like this isn't in the prelude?
concatMapM f xs = mapM f xs >>= return . concat
readJSON _ = fail "requests must be either JSON objects or arrays."
View
16 ezq.hs
@@ -8,10 +8,10 @@ import Data.Maybe
import Data.Either
import Control.Monad
import Control.Concurrent
-import Text.JSON(decode, encode, Result(..))
+import Text.JSON(decode, encode, Result(..))
import qualified Network.Shed.Httpd as Httpd
import qualified Network.URI as URI
-import Data.Task.QueueSet(QueueSet)
+import Data.Task.QueueSet(QueueSet)
import qualified Data.Task.QueueSet as QS
import Request
@@ -51,22 +51,24 @@ dispatch mq req = do
dispatch' mq req =
case decode body of
Ok decoded -> execute decoded
- Error _ -> return $ resp 400 "invalid request"
+ Error what -> return $ resp 400 $ printf "invalid request: %s" what
where
body = Httpd.reqBody req
execute (GetRequest queues) = do
- now <- getClockTime
+ now <- getClockTime
modifyMVar mq $ \qs ->
case QS.getAny now queues qs of
- Just (which, qs') -> return (qs', resp 200 (encode which))
- Nothing -> return (qs, resp 200 "none")
+ Just (which, qs') ->
+ let ((queue, ident), task) = which in
+ return (qs', resp 200 (encode $ GetOk [(queue, ident, task)]))
+ Nothing -> return (qs, resp 200 "none")
execute (EditRequest ops) = do
modifyMVar mq $ \qs ->
case foldM applyOp qs ops of
- Just qs' -> return (qs', resp 200 "ok")
+ Just qs' -> return (qs', resp 200 (encode EditOk))
Nothing -> return (qs, resp 400 "fail")
applyOp qs (Add queue task) = Just $ QS.add task queue qs

0 comments on commit b98ee46

Please sign in to comment.