packages feed

couch-hs (empty) → 0.1.0

raw patch · 8 files changed

+552/−0 lines, 8 filesdep +aesondep +attoparsecdep +basesetup-changed

Dependencies added: aeson, attoparsec, base, bytestring, hint, random, text, transformers, vector

Files

+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ couch-hs.cabal view
@@ -0,0 +1,41 @@+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 view
@@ -0,0 +1,199 @@+{- |+    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 view
@@ -0,0 +1,11 @@+{-# 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/Map.hs view
@@ -0,0 +1,133 @@+{-# 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 view
@@ -0,0 +1,68 @@+{-# 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 view
@@ -0,0 +1,82 @@+{-# 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]
+ source/server.hs view
@@ -0,0 +1,16 @@+#!/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