Commits

Peter Sagerson committed e696349

A CouchDB view server for Haskell.

Comments (0)

Files changed (15)

+^dist/
+import Distribution.Simple
+main = defaultMain
+name: couch-hs
+version: 0.1.0
+cabal-version: >= 1.6
+build-type: Simple
+license: PublicDomain
+author: Peter Sagerson
+maintainer: Peter Sagerson <psagers.hs@ignorare.net>
+stability: alpha
+bug-reports: https://bitbucket.org/psagers/couch-hs/issues
+synopsis: A CouchDB view server for Haskell.
+description: A CouchDB view server for Haskell.
+category: Database
+tested-with: GHC==7.0.3
+
+source-repository head
+    type: hg
+    location: https://bitbucket.org/psagers/couch-hs
+
+Library
+    hs-source-dirs: source
+
+    exposed-modules: Database.CouchDB.ViewServer
+                   , Database.CouchDB.ViewServer.Parse
+                   , Database.CouchDB.ViewServer.Internal
+                   , Database.CouchDB.ViewServer.Map
+                   , Database.CouchDB.ViewServer.Reduce
+
+    build-depends: base >= 4 && < 5
+                 , random >= 1.0 && < 1.1
+                 , bytestring >= 0.9 && < 1.0
+                 , text >= 0.11 && < 0.12
+                 , vector >= 0.7 && < 0.8
+                 , transformers >= 0.2 && < 0.3
+                 , attoparsec >= 0.9 && < 0.10
+                 , aeson >= 0.3 && < 0.4
+                 , hint >= 0.3 && < 0.4
+
+
+Executable couch-hs
+    hs-source-dirs: source
+    main-is: server.hs

source/Database/CouchDB/ViewServer.hs

+{- |
+    This ia a CouchDB view server in and for Haskell. With it, you can define
+    design documents that use Haskell functions to perform map/reduce
+    operations. Database.CouchDB.ViewServer is just a container; see the
+    submodules for API documentation.
+-}
+
+module Database.CouchDB.ViewServer
+    (
+      -- * Installation
+{- |
+    This package includes the executable that runs as the CouchDB view server as
+    well as some modules that your map and reduce functions will compile
+    against. This means, for instance, that if CouchDB is running as a system
+    user, this package must be installed globally in order to work.
+
+    The executable is named @couch-hs@. Without any arguments, it will run as a
+    view server, processing lines from stdin until EOF. There are two options
+    that are important to the compilation of your map and reduce functions
+    (@couch-hs -h@ will print a short description of all options).
+
+    [@-x EXT@] Adds a language extension to the function interpreters.
+    @OverloadedStrings@ is included by default.
+
+    [@-m MODULE\[,QUALIFIED\]@] Imports a module into the function interpreter
+    context. You may include a qualified name or leave it unqualified. The
+    default environment is equivalent to the following (the last entry varying
+    for map and reduce functions):
+        
+        >import Prelude
+        >import Data.Maybe
+        >import Data.List as L
+        >import Data.Map as M
+        >improt Data.Text as T
+        >import Data.Aeson.Types as J
+        >import Control.Monad
+        >import Control.Applicative
+        >import Database.CouchDB.ViewServer.[Map|Reduce]
+
+    Assuming the package is installed properly, just add it to your CouchDB
+    config file:
+
+    >[query_servers]
+    >haskell = /path/to/couch-hs [options]
+-}
+
+      -- ** Development Modes
+{- |
+    In addition to the server mode, @couch-hs@ has some special modes to aid
+    development. CouchDB isn't very good at reporting errors in view functions,
+    so the following modes can be used to make sure your functions compile
+    before installing them into a view. To ensure valid results, be sure to
+    match the @couch-hs@ options with those in CouchDB's config file.
+
+    [@couch-hs \[options\] -M \[CODE|\@PATH\] ...@] Attempt to compile one or
+    more map functions. Each argument can either be a source string or a path to
+    a file prefixed by \@. If no arguments are given, one function will be read
+    from stdin. For each map function that is successfully compiled, @couch-hs@
+    will print OK. If any function fails, the interpreter error(s) will be
+    printed. If there are any failures, @couch-hs@ will exit with a non-zero
+    status.
+
+    [@couch-hs \[options\] -R \[CODE|\@PATH\] ...@] The same as @-M@, except to
+    compile reduce functions.
+-}
+
+      -- * Use
+
+      -- ** Overview
+{- |
+    Here is a simple summation example to get started. This example assumes
+    documents of the form:
+
+    >{"name": "Bob", "value": 5}
+
+    The map function emits name/value pairs:
+
+@
+\\doc -> 'M.emitM'
+  (doc 'M..:' \"name\" :: 'M.ViewMap' String)
+  (doc 'M..:' \"value\" :: 'M.ViewMap' Integer)
+@
+
+    The reduce function adds up all of the values:
+
+@
+\\keys values rereduce -> sum \<$\> 'R.parseJSONList' values :: 'R.ViewReduce' Integer
+@
+
+    The key things to note here:
+
+    * Map and reduce operations take place in a monadic context. The map and
+      reduce monads are transformers on top of 'J.Parser', which is used to
+      parse the decoded JSON into native values. Lifted parsing tools are
+      provided for convenience.
+
+    * Both map and reduce functions will parse JSON values and produce output
+      and log messages. If any JSON parsing operation fails, the entire
+      computation will fail and no results nor log messages will be returned to
+      the server. To handle parse failures, you can use
+      'Control.Applicative.Alternative' or 'M..:?'.
+
+    * Both map and reduce computations are parameterized in some way. In the
+      case of map functions, it's the 'M.emit' function; for the reduce
+      functions, it's the return type. In either case, since there is no
+      top-level type annotation, it will be necessary to include annotations at
+      key points in the functions. I find that annotations usually belong at the
+      points where the JSON objects are parsed.
+-}
+
+      -- ** Map Functions
+{- |
+    A map function takes a single JSON object as an argument and evaluates to
+    @'M.ViewMap' ()@. The map computation may call 'M.emit' or 'M.emitM' to
+    returnkey/value pairs for the given document. The emit functions accept any
+    type that can be converted by 'J.toJSON', which is a long list. If you want
+    to emit @null@, pass 'M.Null' or 'Nothing' (Null is easier, as it doesn't
+    require annotation).
+    
+     Map functions will generally use 'M..:' and 'M..:?' to access fields in the
+    object and may need 'M.parseJSON' to parse embedded values.
+    
+     If the map computation fails, the result will be equivalent to @return ()@.
+-}
+      M.MapSignature
+
+      -- ** Reduce Functions
+{- |
+    A reduce function takes three arguments: a list of keys as JSON 'J.Value's,
+    a list of values as JSON 'J.Value's, and a 'Bool' for rereduce. The
+    'R.ViewReduce' monad may wrap any value that can be converted by 'J.toJSON';
+    a type annotation will generally be necessary.
+    
+     A reduce function will normally use 'R.parseJSONList' to parse the JSON
+    values into primitive types for processing.
+    
+     If the reduce computation fails, the result will be equivalent to @return
+    Null@.
+-}
+    , R.ReduceSignature
+
+      -- ** Example
+{- |
+    Here's a larger example that shows off a more practical application. Suppose
+    a set of documents representing shared expenses. We'll include a couple of
+    malformed documents for good measure.
+
+    >{"date": "2011-06-05", "what": "Dinner", "credits": {"Alice": 80}, "shares": {"Alice": 1, "Bob": 2, "Carol": 1}}
+    >{"date": "2011-06-17", "credits": {"Bob": 75}, "shares": {"Bob": 1, "Doug": 1}}
+    >{"date": "2011-06-08", "what": "Concert", "credits": {"Carol": 150}, "shares": {"Alice": 1, "Carol": 1, "Doug": 1}}
+    >{"date": "2011-05-25", "what": "Bogus", "credits": {"Alice": 50}, "shares": {"Bob": 0}}
+    >{"food": "pizza", "toppings": ["mushrooms", "onions", "sausage"]}
+
+    The following map function will calculate the total credit or debt for each
+    person for each valid document. The @what@ field is carried along. The
+    reduce function sums all of the nets to produce the bottom line.
+
+    >\doc -> let net credits shares = let debts = shareAmounts (sumMap credits) (sumMap shares) shares
+    >                                 in  M.unionWith (+) credits debts
+    >
+    >            sumMap = M.fold (+) 0
+    >            shareAmounts totCredit totShares = M.map (\shares -> -(shares / totShares) * totCredit)
+    >
+    >        in  do date <- doc .: "date" :: ViewMap T.Text
+    >               what <- doc .:? "what" :: ViewMap (Maybe T.Text) -- Optional field
+    >               credits <- doc .: "credits" :: ViewMap (M.Map T.Text Double)
+    >               shares <- doc .: "shares" :: ViewMap (M.Map T.Text Double)
+    >
+    >               guard $ (sumMap shares) > 0  -- Just say no to (/ 0)
+    >
+    >               emit date $ object ["net" .= net credits shares, "what" .= what]
+
+    >\_ values _ -> do objects <- parseJSONList values :: ViewReduce [J.Object]
+    >                  nets <- mapM (.: "net") objects :: ViewReduce [M.Map T.Text Double]
+    >                  return $ L.foldl' (M.unionWith (+)) M.empty nets
+
+    Map results:
+
+    >"2011-06-05": {what: "Dinner", net: {Alice: 60, Bob: -40, Carol: -20}}
+    >"2011-06-08": {what: "Concert", net: {Alice: -50, Carol: 100, Doug: -50}}
+    >"2011-06-17": {what: null, net: {Bob: 37.5, Doug: -37.5}}
+
+    Which reduces to:
+
+    >{Alice: 10, Bob: -2.5, Carol: 80, Doug: -87.5}
+-}
+
+    -- * API Documentation
+    , module Database.CouchDB.ViewServer.Map
+    , module Database.CouchDB.ViewServer.Reduce
+    ) where
+
+import qualified Control.Applicative
+import qualified Data.Aeson.Types as J
+
+import qualified Database.CouchDB.ViewServer.Map
+import qualified Database.CouchDB.ViewServer.Reduce
+import qualified Database.CouchDB.ViewServer.Map as M
+import qualified Database.CouchDB.ViewServer.Reduce as R

source/Database/CouchDB/ViewServer/Internal.hs

+{-# OPTIONS_HADDOCK hide #-}
+
+module Database.CouchDB.ViewServer.Internal where
+
+import Data.Aeson
+
+
+newtype LogMessage = LogMessage { message :: String }
+
+instance ToJSON LogMessage where
+    toJSON (LogMessage s) = toJSON ["log", s]

source/Database/CouchDB/ViewServer/Main.hs

+module Database.CouchDB.ViewServer.Main
+    ( run
+    ) where
+
+import System.Exit
+
+import Database.CouchDB.ViewServer.Main.Options
+import Database.CouchDB.ViewServer.Main.Context
+import Database.CouchDB.ViewServer.Main.Server (runServer)
+import Database.CouchDB.ViewServer.Main.Devel (runCompileMapFuncs, runCompileReduceFuncs)
+
+
+run :: IO ExitCode
+run = do
+    eitherOpts <- getOptions
+    case eitherOpts of
+        Left usage            -> putStrLn usage >> return (ExitFailure 1)
+        Right (options, args) -> withContext options args runMode
+
+
+{-
+    Run the tool in the appropriate mode. By default, this is the view server
+    mode, but the user might also be running us in a debugging mode.
+-}
+runMode :: Context -> IO ExitCode
+runMode context = 
+    case optRunMode $ ctxOptions context of
+        ServerMode        -> runServer context
+        CompileMapMode    -> runCompileMapFuncs context
+        CompileReduceMode -> runCompileReduceFuncs context

source/Database/CouchDB/ViewServer/Main/Context.hs

+module Database.CouchDB.ViewServer.Main.Context
+    ( Context(..)
+    , withContext
+    ) where
+
+
+import System.IO
+import System.Random (getStdRandom, randomR)
+import Control.Applicative
+import Language.Haskell.Interpreter
+
+import Database.CouchDB.ViewServer.Main.Options
+import Database.CouchDB.ViewServer.Map
+import Database.CouchDB.ViewServer.Reduce
+
+
+{-
+    Important context for our computation in any mode. This contains the
+    original options and arguments as well as some derived values.
+-}
+data Context = Context
+ { ctxOptions :: Options
+ , ctxArgs :: [String]
+
+ -- Processed options
+ , ctxInputLog :: Maybe Handle
+ , ctxMapFuncInterpreter :: String -> Interpreter MapFunc
+ , ctxReduceFuncInterpreter :: String -> Interpreter ReduceFunc
+ }
+
+
+withContext :: Options -> [String] -> (Context -> IO a) -> IO a
+withContext options args f = do context <- serverContext options args
+                                result <- f context
+                                closeContext context
+                                return result
+
+
+serverContext :: Options -> [String] -> IO Context
+serverContext options args = do
+    maybeLogHandle <- openInputLog
+
+    return Context
+        { ctxOptions = options
+        , ctxArgs = args
+
+        , ctxInputLog = maybeLogHandle
+        , ctxMapFuncInterpreter = mapFuncInterpreter interpOpts interpMods
+        , ctxReduceFuncInterpreter = reduceFuncInterpreter interpOpts interpMods
+        }
+    where
+        interpOpts = [languageExtensions := map read (optExtensions options)]
+        interpMods = optModules options
+
+        openInputLog =
+            case optInputLog options of
+                Just path -> do path <- randomPath path
+                                Just <$> openFile path WriteMode
+                Nothing   -> return Nothing
+
+        randomPath base = do
+            suffix <- getStdRandom (randomR (0,999999 :: Int))
+            return $ base ++ "." ++ show suffix
+
+
+closeContext :: Context -> IO ()
+closeContext context =
+    case ctxInputLog context of
+        Just handle -> hClose handle
+        Nothing     -> return ()

source/Database/CouchDB/ViewServer/Main/Devel.hs

+module Database.CouchDB.ViewServer.Main.Devel
+    ( runCompileMapFuncs
+    , runCompileReduceFuncs
+    ) where
+
+
+import System.IO
+import System.Exit
+import Data.Either
+import qualified Data.ByteString.Lazy as L
+import Data.Aeson
+import Language.Haskell.Interpreter
+
+import Database.CouchDB.ViewServer.Main.Context
+import Database.CouchDB.ViewServer.Map
+import Database.CouchDB.ViewServer.Reduce
+
+
+runCompileMapFuncs :: Context -> IO ExitCode
+runCompileMapFuncs context = runCompileFuncs context (ctxMapFuncInterpreter context)
+
+
+runCompileReduceFuncs :: Context -> IO ExitCode
+runCompileReduceFuncs context = runCompileFuncs context (ctxReduceFuncInterpreter context)
+
+
+runCompileFuncs :: Context -> (String -> Interpreter a) -> IO ExitCode
+runCompileFuncs context interpreter = do
+    sources <- loadSources $ ctxArgs context
+    eitherFuncs <- mapM (runInterpreter . interpreter) sources
+    printResults $ zip sources eitherFuncs
+
+    if null $ lefts eitherFuncs
+        then return ExitSuccess
+        else return (ExitFailure 1)
+
+
+{-
+    Returns at least one string to compile. Arguments are either raw source
+    code, which is returned unmodified, or prefixed by '@', which indicates a
+    path to read from. If no arguments are given, we return the contents of
+    stdin.
+-}
+loadSources :: [String] -> IO [String]
+loadSources args =
+    case args of
+        [] -> mapM hGetContents [stdin]
+        _  -> mapM loadSource args
+    where
+        loadSource arg = case arg of
+            ('@':path) -> readFile path
+            _          -> return arg
+
+
+printResults :: [(String, Either InterpreterError a)] -> IO ()
+printResults = mapM_ printResult
+    where
+        printResult (_, Left err)     = printInterpreterError err
+        printResult (source, Right _) = putStrLn "OK" -- L.putStrLn $ encode $ toJSON source
+
+
+printInterpreterError :: InterpreterError -> IO ()
+printInterpreterError (UnknownError s) = putStrLn s
+printInterpreterError (WontCompile ss) = mapM_ (putStrLn . errMsg) ss
+printInterpreterError (NotAllowed s)   = putStrLn s
+printInterpreterError (GhcException s) = putStrLn s

source/Database/CouchDB/ViewServer/Main/Options.hs

+{-# LANGUAGE OverloadedStrings #-}
+
+module Database.CouchDB.ViewServer.Main.Options
+    ( RunMode(..)
+    , Options(..)
+    , getOptions
+    ) where
+
+import Prelude hiding (catch)
+import System.IO
+import System.Environment
+import System.Console.GetOpt
+import Control.Exception
+
+import qualified Data.ByteString.Char8 as B
+import Data.Either (lefts, rights)
+import Data.Maybe (fromMaybe)
+import Data.List (foldl', intercalate)
+
+import Data.Attoparsec.Char8
+import Data.Attoparsec.Combinator
+import qualified Language.Haskell.Interpreter as H
+
+
+type QualifiedModName = (String, Maybe String)
+
+data RunMode = ServerMode | CompileMapMode | CompileReduceMode
+    deriving (Show)
+
+
+data Options = Options
+ { optErrors :: [String]
+ , optHelp :: Bool
+ , optExtensions :: [String]
+ , optModules :: [QualifiedModName]
+ , optInputLog :: Maybe FilePath
+ , optRunMode :: RunMode
+ }
+ deriving (Show)
+
+
+defaultOptions = Options
+ { optErrors = []
+ , optHelp = False
+ , optExtensions = ["OverloadedStrings"]
+ , optModules = standardModules
+ , optInputLog = Nothing
+ , optRunMode = ServerMode
+ }
+
+{- Modules that are always available to interpreted code. Unqualified modules in
+   this list will go through post-processing, but that should be idempotent, so
+   no worries.
+-}
+standardModules =
+ [ ("Prelude", Nothing)
+ , ("Data.Maybe", Nothing)
+ , ("Data.List", Just "L")
+ , ("Data.Map", Just "M")
+ , ("Data.Text", Just "T")
+ , ("Data.Aeson.Types", Just "J")
+ , ("Control.Monad", Nothing)
+ , ("Control.Applicative", Nothing)
+ ]
+
+
+getOptions :: IO (Either String (Options, [String]))
+getOptions = parseOptions `catch` handleException
+
+
+handleException :: SomeException -> IO (Either String (Options, [String]))
+handleException e = return $ Left $ showHelp [show e] Nothing
+
+
+parseOptions :: IO (Either String (Options, [String]))
+parseOptions = do
+    argv <- getArgs
+    case getOpt RequireOrder optDescriptors argv of
+        (opts, args, []) -> let options = finalizedOptions $ foldl' (flip ($)) defaultOptions opts
+                                errs = optErrors options
+                            in  if optHelp options || not (null errs)
+                                   then return $ Left $ showHelp errs (Just options)
+                                   else return $ Right (options, args)
+        (_, _, errs)     -> return $ Left $ showHelp errs Nothing
+
+
+optDescriptors =
+ [ Option "h" []
+    (NoArg (\opts -> opts { optHelp = True }))
+    ""
+
+ , Option "x" []
+    (ReqArg (\ext opts -> opts { optExtensions = ext:optExtensions opts }) "EXT")
+    "Add a language extension to the view function context"
+ , Option "m" []
+    (ReqArg (\modName opts -> opts { optModules = (modName, Nothing):optModules opts }) "MODULE[,QUALIFIED]")
+    "Import a module into the view function context"
+
+ , Option "l" []
+    (ReqArg (\path opts -> opts { optInputLog = Just path }) "PATH")
+    "Log all input commands to PATH.<random suffix>"
+
+ , Option "S" []
+    (NoArg (\opts -> opts { optRunMode = ServerMode }))
+    "Run the view server (this is the default)"
+ , Option "M" []
+    (NoArg (\opts -> opts { optRunMode = CompileMapMode }))
+    "Try to compile map functions"
+ , Option "R" []
+    (NoArg (\opts -> opts { optRunMode = CompileReduceMode }))
+    "Try to compile reduce functions"
+ ]
+
+
+{-
+    These apply any necessary post-processing to the options, such as parsing
+    out qualified module names.
+-}
+finalizedOptions :: Options -> Options
+finalizedOptions = finalizedModuleOptions
+
+
+finalizedModuleOptions :: Options -> Options
+finalizedModuleOptions options =
+    options { optErrors = optErrors options ++ modErrors
+            , optModules = parsedModules
+            }
+    where
+        eitherModules = map parseModName (optModules options)
+        modErrors = lefts eitherModules
+        parsedModules = rights eitherModules
+
+        -- Only unqualified modules are parsed
+        parseModName :: (String, Maybe String) -> Either String QualifiedModName
+        parseModName (name, Nothing) = parseOnly modParser $ B.pack name
+        parseModName qname           = Right qname
+
+        modParser :: Parser QualifiedModName
+        modParser = do
+            separated <- sepBy1 (takeTill (== ',')) (char ',')
+            case separated of
+                [name]        -> return (B.unpack name, Nothing)
+                [name, ""]    -> return (B.unpack name, Nothing)
+                [name, qname] -> return (B.unpack name, Just $ B.unpack qname)
+                _             -> fail "Invalid module name\n"
+
+
+{-
+    Help text.
+-}
+showHelp :: [String] -> Maybe Options -> String
+showHelp errs maybeOptions =
+       concat errs
+    ++ "\n"
+    ++ usageInfo header optDescriptors
+    -- ++ "\n"
+    -- ++ show maybeOptions
+  where header = intercalate "\n" [ "Usage: couch-hs [options] [-S]"
+                                  , "       couch-hs [options] -M [CODE|@PATH] ..."
+                                  , "       couch-hs [options] -R [CODE|@PATH] ..."
+                                  ]

source/Database/CouchDB/ViewServer/Main/Server.hs

+{-# LANGUAGE OverloadedStrings #-}
+
+module Database.CouchDB.ViewServer.Main.Server
+    ( runServer
+    )
+    where
+
+import System.IO
+import System.Exit
+
+import Control.Applicative
+import Control.Monad (unless)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)
+import Control.Monad.Trans.State (StateT, evalStateT, get, put, modify)
+
+import Data.Either (Either(..), lefts, rights)
+import qualified Data.ByteString.Char8 as B
+import qualified Data.ByteString.Lazy as L
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T.E
+import Data.Text (Text)
+import Data.List (intercalate)
+
+import Data.Attoparsec (parseOnly)
+import qualified Data.Aeson as J
+import Data.Aeson ((.=), json, toJSON, fromJSON, Result(..))
+import qualified Language.Haskell.Interpreter as H
+
+import Database.CouchDB.ViewServer.Internal
+import Database.CouchDB.ViewServer.Map
+import Database.CouchDB.ViewServer.Reduce
+import Database.CouchDB.ViewServer.Main.Context
+import Database.CouchDB.ViewServer.Main.Server.Command
+
+
+data ServerState = ServerState
+ { stateMapFuncs :: [MapFunc]
+ , stateReduceFuncs :: [(Text, ReduceFunc)]
+ }
+
+initialServerState = ServerState
+ { stateMapFuncs = []
+ , stateReduceFuncs = []
+ }
+
+type LineProcessor a = StateT ServerState (ReaderT Context IO) a
+
+type ResponseValue = J.Value
+
+
+runServer :: Context -> IO ExitCode
+runServer context = do hSetBuffering stdout LineBuffering
+                       runReaderT (evalStateT processLines initialServerState) context
+                       return ExitSuccess
+
+
+processLines :: LineProcessor ()
+processLines = do
+    eof <- liftIO isEOF
+    unless eof $ do processNextLine
+                    processLines
+
+
+{-
+    Line processing
+-}
+processNextLine :: LineProcessor ()
+processNextLine = do
+    line <- liftIO B.getLine
+    logInputLine line
+    case line of
+        "" -> return ()
+        _  -> do result <- processLine line
+                 liftIO $ L.putStrLn $ J.encode result
+
+
+{- Log the input line to a file, if requested in the command-line arguments. -}
+logInputLine :: B.ByteString -> LineProcessor ()
+logInputLine line = do
+    commandLog <- askInputLog
+    case commandLog of
+        Just handle -> liftIO $ B.hPutStrLn handle line
+        Nothing     -> return ()
+
+
+processLine :: B.ByteString -> LineProcessor ResponseValue
+processLine line =
+    case parseOnly json line of
+        Left err     -> return $ parseErrorValue err
+        Right value  -> case fromJSON value of
+                            Error string    -> return $ parseErrorValue string
+                            Success command -> processCommand command
+
+
+processCommand :: ViewCommand -> LineProcessor ResponseValue
+processCommand command =
+    case command of
+        Reset                 -> processReset
+        AddFun code           -> processAddFun code
+        MapDoc doc            -> processMapDoc doc
+        Reduce codes args     -> processReduce codes args
+        Rereduce codes values -> processRereduce codes values
+
+
+{-
+    Command handlers
+-}
+processReset :: LineProcessor ResponseValue
+processReset = do
+    putMapFuncs []
+    return $ J.Bool True
+
+
+processAddFun :: Text -> LineProcessor ResponseValue
+processAddFun code = do
+    mapInterpreter <- askMapFuncInterpreter
+    eitherFunc <- liftIO $ H.runInterpreter $ mapInterpreter (B.unpack $ T.E.encodeUtf8 code)
+    case eitherFunc of
+        Left err   -> return $ compileErrorValue $ "Map: " ++ show err
+        Right func -> do modifyMapFuncs (++ [func])
+                         return $ J.Bool True
+
+
+processMapDoc :: J.Object -> LineProcessor ResponseValue
+processMapDoc doc = do outputs <- map (`execMapFunc` doc) <$> getMapFuncs
+                       mapM_ (liftIO . L.putStrLn . J.encode . toJSON) (concatMap logs outputs)
+                       return $ toJSON $ map emits outputs
+
+
+processReduce :: [Text] -> [ReduceArg] -> LineProcessor ResponseValue
+processReduce codes args = do
+    eitherFuncs <- eitherReduceFuncs codes
+    case eitherFuncs of
+        Left err    -> return $ compileErrorValue err
+        Right funcs -> let keys = map reduceKey args
+                           values =  map reduceValue args
+                           outputs = map (\f -> execReduceFunc f keys values False) funcs
+                       in  reduceResponse outputs
+
+
+processRereduce :: [Text] -> [J.Value] -> LineProcessor ResponseValue
+processRereduce codes values = do
+    eitherFuncs <- eitherReduceFuncs codes
+    case eitherFuncs of
+        Left err    -> return $ compileErrorValue err
+        Right funcs -> let outputs = map (\f -> execReduceFunc f [] values True) funcs
+                       in  reduceResponse outputs
+
+
+reduceResponse :: [ReduceOutput] -> LineProcessor ResponseValue
+reduceResponse outputs =
+    do mapM_ (liftIO . L.putStrLn . J.encode . toJSON) logMessages
+       return $ toJSON (True, results)
+    where logMessages = concatMap snd outputs
+          results = map fst outputs
+
+{-
+    Monadic utils
+-}
+eitherReduceFuncs :: [Text] -> LineProcessor (Either String [ReduceFunc])
+eitherReduceFuncs codes = do
+    reduceInterpreter <- askReduceFuncInterpreter
+    eitherFuncs <- mapM getReduceFunc codes
+    let errors = lefts eitherFuncs
+    if null errors
+        then return $ Right $ rights eitherFuncs
+        else return $ Left $ "Reduce: " ++ intercalate "; " (map show errors)
+
+
+getReduceFunc :: Text -> LineProcessor (Either H.InterpreterError ReduceFunc)
+getReduceFunc code = do
+    maybeFunc <- lookup code <$> getReduceFuncs
+    case maybeFunc of
+        Just func -> return $ Right func
+        Nothing   -> loadReduceFunc code
+
+
+loadReduceFunc :: Text -> LineProcessor (Either H.InterpreterError ReduceFunc)
+loadReduceFunc code = do
+    interpreter <- askReduceFuncInterpreter
+    eitherFunc <- liftIO $ H.runInterpreter $ interpreter (B.unpack $ T.E.encodeUtf8 code)
+    case eitherFunc of
+        Left _     -> return eitherFunc
+        Right func -> do modifyReduceFuncs $ ((code, func) :) . take 4  -- Cache up to 5 reduce functions
+                         return $ Right func
+
+
+couchLog :: String -> IO ()
+couchLog message = L.putStrLn $ J.encode $ toJSON $ LogMessage message
+
+
+{-
+    Monad transformer wrappers.
+-}
+askMapFuncInterpreter = ctxMapFuncInterpreter <$> lift ask
+askReduceFuncInterpreter = ctxReduceFuncInterpreter <$> lift ask
+askInputLog = ctxInputLog <$> lift ask
+
+getMapFuncs :: LineProcessor [MapFunc]
+getMapFuncs = stateMapFuncs <$> get
+putMapFuncs funcs = get >>= \state -> put state { stateMapFuncs = funcs }
+modifyMapFuncs f = getMapFuncs >>= \funcs -> putMapFuncs $ f funcs
+
+getReduceFuncs :: LineProcessor [(Text, ReduceFunc)]
+getReduceFuncs = stateReduceFuncs <$> get
+putReduceFuncs funcs = get >>= \state -> put state { stateReduceFuncs = funcs }
+modifyReduceFuncs f = getReduceFuncs >>= \funcs -> putReduceFuncs $ f funcs
+
+
+{-
+    Errors
+-}
+parseErrorValue = errorValue "parse"
+compileErrorValue = errorValue "compile"
+
+errorValue :: String -> String -> J.Value
+errorValue code reason = J.object ["error" .= code, "reason" .= reason]

source/Database/CouchDB/ViewServer/Main/Server/Command.hs

+{-# LANGUAGE OverloadedStrings #-}
+
+module Database.CouchDB.ViewServer.Main.Server.Command
+    ( ViewCommand(..)
+    , ReduceArg(..)
+    ) where
+
+import Data.Text (Text, unpack)
+import qualified Data.Vector as V
+import Data.Aeson
+import Data.Aeson.Types
+
+import Control.Monad
+import Control.Applicative
+
+
+data ViewCommand =
+    Reset |
+    AddFun Text |
+    MapDoc Object |
+    Reduce [Text] [ReduceArg] |
+    Rereduce [Text] [Value]
+
+
+data ReduceArg = ReduceArg
+ { reduceKey :: Value
+ , reduceDocId :: Value
+ , reduceValue :: Value
+ }
+
+
+instance FromJSON ViewCommand where
+    parseJSON value@(Array valueVec)
+        | V.length valueVec > 0 = 
+            case V.head valueVec of
+                String "reset"    -> return Reset
+                String "add_fun"  -> parseAddFun args
+                String "map_doc"  -> parseMapDoc args
+                String "reduce"   -> parseReduce args
+                String "rereduce" -> parseRereduce args
+                String s          -> fail $ "Unrecognized view command: " ++ unpack s
+        | otherwise = typeMismatch "view command" value
+        where
+            args :: [Value]
+            args = V.toList $ V.tail valueVec
+
+            parseAddFun [code] = AddFun <$> parseJSON code
+            parseAddFun _ = typeMismatch "add_fun command" value
+
+            parseMapDoc [doc] = MapDoc <$> parseJSON doc
+            parseMapDoc _ = typeMismatch "map_doc command" value
+
+            parseReduce [codeArray, rowArray] = Reduce <$> parseJSON codeArray <*> parseJSON rowArray
+            parseReduce _ = typeMismatch "reduce command" value
+
+            parseRereduce [codeArray, valueArray] = Rereduce <$> parseJSON codeArray <*> parseJSON valueArray
+            parseRereduce _ = typeMismatch "rereduce command" value
+
+
+instance FromJSON ReduceArg where
+    parseJSON args = do
+        ((key, docId), value) <- parseJSON args :: Parser ((Value, Value), Value)
+        return $ ReduceArg key docId value

source/Database/CouchDB/ViewServer/Map.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# OPTIONS_HADDOCK prune #-}
+
+module Database.CouchDB.ViewServer.Map
+    ( 
+    -- * Map Functions
+      MapSignature
+    , ViewMap
+
+    -- * JSON Parsing
+    , module Database.CouchDB.ViewServer.Parse
+
+    -- * ViewMap Monads
+    , emit
+    , emitM
+    , logMsg
+
+    , MapOutput(..)
+    , MapFunc(..)
+    , toMapFunc
+    , mapFuncInterpreter
+    , execMapFunc
+    , logs
+    , emits
+    ) where
+
+import Prelude hiding (log)
+import Data.Maybe
+import Data.Typeable
+import Data.Aeson ((.:), (.:?), toJSON, FromJSON, ToJSON(..))
+import Data.Aeson.Types (Value(..), Object, Parser, parseMaybe)
+import qualified Data.Aeson.Types (parseJSON)
+import Data.Text (Text, unpack)
+
+import Control.Applicative
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Writer (WriterT, tell, execWriterT)
+
+import qualified Language.Haskell.Interpreter as H
+
+import Database.CouchDB.ViewServer.Internal
+import Database.CouchDB.ViewServer.Parse
+
+
+data MapOutput =
+    Emit Value Value |
+    Log LogMessage
+
+type ViewMapT m a = WriterT [MapOutput] m a
+
+
+{- | The monad within which a map computation takes place. This is a
+     transformation of the 'Data.Aeson.Types.Parser' monad, although the precise
+     nature and depth of the transformation is an internal detail and subject to
+     change. ViewMapT is guaranteed to be an instance of the 'MonadParser'
+     class, allowing you to parse JSON structures.
+-}
+type ViewMap a = ViewMapT Parser a
+
+
+{- | The type of your map functions as they are stored in CouchDB. The trivial
+     example:
+
+   > \doc -> return ()
+-}
+type MapSignature = Object -> ViewMap ()
+
+newtype MapFunc = MapFunc { runMapFunc :: MapSignature }
+    deriving (Typeable)
+
+
+toMapFunc = MapFunc
+
+
+mapFuncInterpreter :: [H.OptionVal H.Interpreter] -> [(H.ModuleName, Maybe String)] -> String -> H.Interpreter MapFunc
+mapFuncInterpreter opts mods source = do
+    H.set opts
+    H.setImportsQ $ mods ++ [("Database.CouchDB.ViewServer.Map", Nothing)]
+    H.interpret ("toMapFunc " ++ H.parens source) (H.as :: MapFunc)
+
+
+execMapFunc :: MapFunc -> Object -> [MapOutput]
+execMapFunc mapFunc doc = fromMaybe [] $ parseMaybe execWriterT (runMapFunc mapFunc doc)
+
+
+emits :: [MapOutput] -> [MapOutput]
+emits = filter isEmit
+
+isEmit (Emit _ _) = True
+isEmit _          = False
+
+
+logs :: [MapOutput] -> [MapOutput]
+logs = filter isLog
+
+isLog (Log _) = True
+isLog _       = False
+
+
+instance ToJSON MapOutput where
+    toJSON (Emit key value) = toJSON (key, value)
+    toJSON (Log msg) = toJSON msg
+
+
+{- | Emit a key/value pair for the current document. The values will be turned
+     into JSON objects for you, although you will have to provide type
+     annotations somewhere.
+
+   >\doc -> do value <- doc .: "value" :: ViewMap Double
+   >           emit Null value
+-}
+ 
+emit :: (ToJSON k, ToJSON v) => k -> v -> ViewMap ()
+emit key value = tell [Emit (toJSON key) (toJSON value)]
+
+
+{- | Same as 'emit', but with wrapped key and value.
+
+   >\doc -> emitM (return Null) (doc .: "value" :: ViewMap Double)
+-}
+emitM :: (ToJSON k, ToJSON v) => ViewMap k -> ViewMap v -> ViewMap ()
+emitM key value = do
+    key' <- key
+    value' <- value
+    emit key' value'
+
+
+{- | Send a log message to the CouchDB server. Note that log messages are only
+     sent if the computation succeeds. If you want to log a message in the event
+     of a failure, look at 'Control.Applicative.Alternative'.
+-}
+logMsg :: String -> ViewMap ()
+logMsg msg = tell [Log $ LogMessage msg]

source/Database/CouchDB/ViewServer/Parse.hs

+{-# OPTIONS_HADDOCK hide #-}
+
+module Database.CouchDB.ViewServer.Parse
+    (
+{- |
+    JSON parsers lifted into our view monads. This also exports one or two
+    useful symbols from 'Data.Aeson.Types'.
+-}
+
+      MonadParser(..)
+    , parseJSON
+    , parseJSONList
+    , (.:)
+    , (.:?)
+    , (.=)
+    , object
+    , Value(..)
+    ) where
+
+
+import Data.Aeson.Types hiding (typeMismatch, parseJSON, (.:), (.:?))
+import qualified Data.Aeson.Types as JT
+import Data.Text (Text)
+import Data.Monoid
+
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Writer (WriterT)
+
+
+-- | Like MonadIO, but for 'Data.Aeson.Types.Parser'. This allows JSON parsing
+--   operations to be lifted into our various view monads.
+class (Monad m) => MonadParser m where
+    liftParser :: Parser a -> m a
+
+instance MonadParser Parser where
+    liftParser = id
+
+instance (Monoid w, MonadParser m) => MonadParser (WriterT w m) where
+    liftParser = lift . liftParser
+
+
+{- | Attempts to parse a JSON value into a given type. This is typically used
+     with a type annotation to indicate the target type. If the value can not
+     be parsed into that type, the entire computation will fail.
+-}
+parseJSON :: (MonadParser m, FromJSON a) => Value -> m a
+parseJSON value = liftParser $ JT.parseJSON value
+
+
+{- | Applies 'parseJSON' to a list of values. This is commonly used with the
+     reduce function arguments.
+-}
+parseJSONList :: (MonadParser m, FromJSON a) => [Value] -> m [a]
+parseJSONList = mapM parseJSON
+
+
+{- | Parses a required field of an object. If the field is not present, or the
+     value can not be parsed into the target type, the computation will fail.
+-}
+(.:) :: (MonadParser m, FromJSON a) => Object -> Text -> m a
+doc .: key = liftParser $ doc JT..: key
+
+
+{- | Parses an optional field of an object. This will not halt the computation
+     on failure.
+-}
+(.:?) :: (MonadParser m, FromJSON a) => Object -> Text -> m (Maybe a)
+doc .:? key = liftParser $ doc JT..:? key

source/Database/CouchDB/ViewServer/Reduce.hs

+{-# LANGUAGE DeriveDataTypeable #-}
+{-# OPTIONS_HADDOCK prune #-}
+
+module Database.CouchDB.ViewServer.Reduce
+    (
+      -- * Map Functions
+      ReduceSignature
+    , ViewReduce
+
+    -- * JSON Parsing
+    , module Database.CouchDB.ViewServer.Parse
+
+    -- * ViewReduce Monads
+    , logMsg
+
+    , ReduceOutput
+    , ReduceFunc
+    , toReduceFunc
+    , reduceFuncInterpreter
+    , execReduceFunc
+    ) where
+
+
+import Data.Maybe
+import Data.Typeable
+import Data.Aeson (toJSON, ToJSON)
+import Data.Aeson.Types (Value(..), Object, Parser, parseMaybe)
+
+import Control.Applicative
+import Control.Monad.Trans.Writer (WriterT, tell, runWriterT)
+import qualified Language.Haskell.Interpreter as H
+
+import Database.CouchDB.ViewServer.Internal
+import Database.CouchDB.ViewServer.Parse
+
+
+type ReduceOutput = (Value, [LogMessage])
+
+type ViewReduceT m a = WriterT [LogMessage] m a
+
+
+{- | The monad within which a reduce computation takes place. This is a
+     transformation of the 'Data.Aeson.Types.Parser' monad, although the precise
+     nature and depth of the transformation is an internal detail and subject to
+     change. ViewReduceT is guaranteed to be an instance of the 'MonadParser'
+     class, allowing you to parse JSON structures.
+-}
+type ViewReduce a = ViewReduceT Parser a
+
+
+{- | The type of your reduce functions as they are stored in CouchDB. The trivial
+     example:
+
+   > \keys values rereduce -> return Null
+-}
+type ReduceSignature a = [Value] -> [Value] -> Bool -> ViewReduce a
+
+newtype ReduceFunc = ReduceFunc { runReduceFunc :: ReduceSignature Value }
+    deriving (Typeable)
+
+
+toReduceFunc :: ToJSON a => ReduceSignature a -> ReduceFunc
+toReduceFunc f = ReduceFunc $ \k v r -> toJSON <$> f k v r
+
+
+reduceFuncInterpreter :: [H.OptionVal H.Interpreter] -> [(H.ModuleName, Maybe String)] -> String -> H.Interpreter ReduceFunc
+reduceFuncInterpreter opts mods source = do
+    H.set opts
+    H.setImportsQ $ mods ++ [("Database.CouchDB.ViewServer.Reduce", Nothing)]
+    H.interpret ("toReduceFunc " ++ H.parens source) (H.as :: ReduceFunc)
+
+
+execReduceFunc :: ReduceFunc -> [Value] -> [Value] -> Bool -> ReduceOutput
+execReduceFunc reduceFunc keys values rereduce = fromMaybe (Null, []) $ parseMaybe runWriterT (runReduceFunc reduceFunc keys values rereduce)
+
+
+{- | Send a log message to the CouchDB server. Note that log messages are only
+     sent if the computation succeeds. If you want to log a message in the event
+     of a failure, look at 'Control.Applicative.Alternative'.
+-}
+logMsg :: String -> ViewReduce ()
+logMsg msg = tell [LogMessage msg]
+#!/usr/bin/env runhaskell
+
+module Main where
+
+
+import System.IO
+import System.Exit
+
+import Database.CouchDB.ViewServer.Main (run)
+
+
+main :: IO ()
+main = do { exitCode <- run;
+            exitWith exitCode
+          } `catch` \err -> do print err
+                               exitFailure
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.