packages feed

couch-hs 0.1.0 → 0.1.1

raw patch · 7 files changed

+615/−2 lines, 7 filesdep ~bytestring

Dependency ranges changed: bytestring

Files

couch-hs.cabal view
@@ -1,5 +1,5 @@ name: couch-hs-version: 0.1.0+version: 0.1.1 cabal-version: >= 1.6 build-type: Simple license: PublicDomain@@ -27,7 +27,7 @@      build-depends: base >= 4 && < 5                  , random >= 1.0 && < 1.1-                 , bytestring >= 0.9 && < 1.0+                 , bytestring >= 0.9 && < 0.10                  , text >= 0.11 && < 0.12                  , vector >= 0.7 && < 0.8                  , transformers >= 0.2 && < 0.3@@ -39,3 +39,9 @@ Executable couch-hs     hs-source-dirs: source     main-is: server.hs+    other-modules: Database.CouchDB.ViewServer.Main+                 , Database.CouchDB.ViewServer.Main.Options+                 , Database.CouchDB.ViewServer.Main.Context+                 , Database.CouchDB.ViewServer.Main.Devel+                 , Database.CouchDB.ViewServer.Main.Server+                 , Database.CouchDB.ViewServer.Main.Server.Command
+ source/Database/CouchDB/ViewServer/Main.hs view
@@ -0,0 +1,30 @@+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 view
@@ -0,0 +1,70 @@+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 view
@@ -0,0 +1,66 @@+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 view
@@ -0,0 +1,161 @@+{-# 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 view
@@ -0,0 +1,217 @@+{-# 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+                       in  reduceResponse $ map (\f -> execReduceFunc f keys values False) funcs+++processRereduce :: [Text] -> [J.Value] -> LineProcessor ResponseValue+processRereduce codes values = do+    eitherFuncs <- eitherReduceFuncs codes+    case eitherFuncs of+        Left err    -> return $ compileErrorValue err+        Right funcs -> reduceResponse $ map (\f -> execReduceFunc f [] values True) funcs+++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 view
@@ -0,0 +1,63 @@+{-# 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