diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) Daniel Wagner + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +!! This software is provided by the regents and contributors ``as is'' and +!! any express or implied warranties, including, but not limited to, the +!! implied warranties of merchantability and fitness for a particular purpose +!! are disclaimed. In no event shall the authors or contributors be liable +!! for any direct, indirect, incidental, special, exemplary, or consequential +!! damages (including, but not limited to, procurement of substitute goods +!! or services; loss of use, data, or profits; or business interruption) +!! however caused and on any theory of liability, whether in contract, strict +!! liability, or tort (including negligence or otherwise) arising in any way +!! out of the use of this software, even if advised of the possibility of +!! such damage. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,539 @@ +-- boilerplate {{{ +{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-} +import Control.Arrow +import Control.Monad.Error +import Control.Monad.Identity +import Control.Monad.State +import Control.Monad.Writer +import Data.Char +import Data.ConfigFile (CPError(..), ConfigParser(..)) +import Data.Function +import Data.List +import Data.List.Split +import Data.Map (Map(..)) +import Data.Maybe +import Data.SGF hiding (Point) +import Network.DGS (DGS, LoginResult(..), MoveResult(..), Point) +import Prelude hiding (log) +import System.Cmd +import System.Console.GetOpt +import System.Directory +import System.Environment (getArgs, getProgName) +import System.Exit (exitWith, ExitCode(..)) +import System.FilePath (()) +import System.IO +import Text.ParserCombinators.Parsec (parse) +import Text.Parsec.Prim +import qualified Data.ByteString as BS +import qualified Data.ConfigFile as Config +import qualified Data.Map as Map +import qualified Network.DGS as DGS + +transCatch :: MonadIO m => IO a -> (IOError -> m a) -> m a +transCatch io m = join . liftIO $ catch (liftM return io) (return . m) +-- }}} +-- Mode {{{ +showMode :: Mode -> String +readMode :: String -> Mode + +data Mode = Batch | Interactive deriving (Eq, Ord, Show, Read, Enum, Bounded) +showMode = map toLower . show +readMode s = case map toLower s of + ('b':_) -> Batch + _ -> Interactive +-- }}} +-- Configuration {{{ +data Configuration = Configuration { + username :: Maybe String, + password :: Maybe String, + mode :: Mode, + editor :: String, + server :: String, + dataDir :: String, + logLevel :: Maybe LogLevel + } deriving (Eq, Ord, Show, Read) + +defaultConfig :: IO Configuration +defaultConfig = do + dir <- getAppUserDataDirectory "wyvern" + return Configuration { + username = Nothing, + password = Nothing, + mode = Interactive, + editor = "cgoban3 #f", + server = DGS.production, + dataDir = dir, + logLevel = Nothing + } +-- }}} +-- Wyvern type {{{ +newtype Wyvern a = Wyvern { unWyvern :: StateT Configuration DGS a } deriving ( + Functor, + Monad, + MonadIO, + MonadState Configuration + ) + +runWyvern :: Wyvern a -> Configuration -> IO a +runWyvern (Wyvern m) = DGS.browseDGS . fmap fst . runStateT m + +dgs :: DGS a -> Wyvern a +dgs = Wyvern . lift +-- }}} +-- logging {{{ +data LogLevel = Quiet | Noisy | Raucous deriving (Eq, Ord, Show, Read, Enum, Bounded) + +incrementLogLevel :: Configuration -> Configuration +incrementLogLevel conf = conf { logLevel = inc (logLevel conf) } where + levels = Nothing : map Just [Quiet, Noisy, Raucous, Raucous] + inc l = dropWhile (/= l) levels !! 1 + +log :: LogLevel -> String -> Wyvern () +log l s = do + level <- gets logLevel + when (Just l <= level) (liftIO $ putStrLn s) + +whisper, say, shout :: String -> Wyvern () +[whisper, say, shout] = map log [Quiet, Noisy, Raucous] + +warn :: MonadIO m => String -> m () +warn = liftIO . hPutStrLn stderr . ("Warning: " ++) + +die :: MonadIO m => Int -> String -> m a +die n extraInfo = liftIO (speech >> death) where + speech = hPutStrLn stderr message + death = exitWith (ExitFailure n) + defaultError = "Unknown error (#" ++ show n ++ "), please report a bug with this number." + message = "Error: " ++ fromMaybe defaultError (lookup n problems) ++ separator ++ extraInfo + separator = case extraInfo of + "" -> "" + _ -> "\n" + +problems :: [(Int, String)] +problems = zip [1..] [ + "Bad command-line parameters", + "Extraneous command-line parameters", + "The impossible happened during configuration; please\nreport the following information in a bug report.", + "Parsing configuration file failed", + "Wrong username", + "Wrong password", + "Unknown problem during login attempt", + "The server issued a totally unexpected error in response to\nan attempt to make a move. Please report this in a bug,\nalong with the following error code.", + "The impossible happened; splitOn returned an empty list!\nPlease report this as a bug, along with your editor setting:" + ] + +succeedString :: String -> Wyvern a +succeedString message = liftIO (speech >> death) where + speech = hPutStrLn stderr message + death = exitWith ExitSuccess +-- }}} +-- getters/setters/misc {{{ +getLogLevel :: Wyvern (Maybe LogLevel) +getUsername, getPassword, getEditor, getServer, getDataDir :: Wyvern String +setUsername, setPassword, setEditor, setServer, setDataDir :: String -> Wyvern () +clearUsername, clearPassword, clearLogLevel :: Wyvern () + +getLogLevel = do + l <- gets logLevel + shout $ "Retrieved log level <" ++ maybe "Nothing" show l ++ ">" + return l + +getMode = do + m <- gets mode + shout $ "Retrieved mode <" ++ showMode m ++ ">" + return m + +[getUsername, getPassword] = map getX [ + ("Username", username, setUsername, True), + ("Password", password, setPassword, False) + ] where + getX (x, selector, setter, echo) + = gets selector + >>= maybe (promptX x setter echo) (shoutX x) + + shoutX x val = do + shout $ "Retrieved " ++ map toLower x ++ " <" ++ val ++ ">" + return val + + promptX x setter echo = do + val <- liftIO $ do + hSetEcho stdin echo + putStr $ x ++ ": " + hFlush stdout + getLine + liftIO $ hSetEcho stdin True >> when (not echo) (putStrLn "") + setter val + return val + +[getEditor, getServer, getDataDir] = zipWith getX + ["SGF editor", "server", "configuration directory"] + [editor, server, dataDir] where + getX x selector = do + v <- gets selector + shout $ "Retrieved " ++ x ++ " <" ++ v ++ ">" + return v + +[setUsername, setPassword, setEditor, setServer, setDataDir] = zipWith setX + ["username", "password", "SGF editor", "server", "configuration directory"] + [\s conf -> conf { username = Just s }, + \s conf -> conf { password = Just s }, + \s conf -> conf { editor = s }, + \s conf -> conf { server = s }, + \s conf -> conf { dataDir = s } + ] where + setX x set s = do + shout $ concat ["Setting ", x, " to <", s, ">"] + modify (set s) + +[clearUsername, clearPassword, clearLogLevel] = zipWith clearX + ["username", "password", "verbosity"] + [\conf -> conf { username = Nothing }, + \conf -> conf { password = Nothing }, + \conf -> conf { logLevel = Nothing } + ] where + clearX x clear = do + shout $ "Resetting " ++ x + modify clear + +setMode :: Mode -> Wyvern () +setMode m = do + shout $ "Setting mode to <" ++ showMode m ++ ">" + modify (\conf -> conf { mode = m }) + +modifyConfig :: (Configuration -> Configuration) -> Wyvern () +modifyConfig f = do + new <- gets f + put new + shout $ "Setting configuration to " ++ show new + +rm :: FilePath -> Wyvern () +rm file = do + dataDir <- getDataDir + whisper $ "Deleting <" ++ file ++ ">" + liftIO . removeFile $ dataDir file +-- }}} +-- DGS interaction {{{ +status :: Wyvern [DGS.Game] +status = do + server <- getServer + username <- getUsername + whisper $ "Retrieving games list for <" ++ username ++ "> from <" ++ server ++ ">" + dgs $ DGS.statusUser server username + +login :: Wyvern (String, String) +login = do + server <- getServer + username <- getUsername + password <- getPassword + status <- dgs (DGS.login server username password) + case status of + WrongUsername -> die 5 $ "Server <" ++ server ++ ">, username <" ++ username ++ ">" + WrongPassword -> die 6 $ "" + LoginProblem s -> die 7 $ "The server says <" ++ s ++ ">" + LoginSuccess -> shout "Successfully logged in" >> return (server, username) +-- }}} +-- options {{{ +options :: String -> String -> String -> String -> [OptDescr (Maybe (Configuration -> Configuration))] +options m e s c = [ + Option "u" ["user", "username" ] (arg (\s conf -> conf { username = Just s }) "username") "Username", + Option "p" ["pass", "password" ] (arg (\s conf -> conf { password = Just s }) "password") "Password", + Option "m" ["mode" ] (arg (\s conf -> conf { mode = readMode s }) "mode" ) (def m "Play mode"), + Option "e" ["editor", "launcher" ] (arg (\s conf -> conf { editor = s }) "editor") (def e "SGF editor"), + Option "s" ["server", "url" ] (arg (\s conf -> conf { server = s }) "server") (def s "URL of the go server"), + Option "c" ["configuration", "dir"] (arg (\s conf -> conf { dataDir = s }) "dir" ) (def c "Configuration and SGF directory"), + Option "h?" ["help" ] (NoArg Nothing ) "Show usage information", + Option "v" ["verbose"] (NoArg (Just incrementLogLevel)) "Increase verbosity" + ] where + def v n = concat [n, " (default ", v, ")"] + arg = ReqArg . (Just .) + +usage :: String -> String -> String -> String -> String -> Wyvern String +usage extra m e s c = do + name <- liftIO getProgName + return $ usageInfo (extra ++ "Usage: " ++ name ++ " [options]") (options m e s c) ++ unlines ["" + , "Valid modes are \"" ++ intercalate "\" and \"" (map showMode [minBound..maxBound]) ++ "." + , "The first \"#f\" in the editor line will be changed to the name of an SGF" + , " file. If there is no \"#f\", one will be appended for you." + , "Verbosity can be increased up to three times. The third verbosity level" + , " may print your password." + ] + +readArgs :: Wyvern () +readArgs = do + say "Parsing command-line arguments" + args <- liftIO getArgs + shout $ "Got args " ++ show args + m <- liftM showMode getMode + e <- getEditor + s <- getServer + c <- getDataDir + case getOpt Permute (options m e s c) args of + (_, _, errors@(_:_)) -> usage (concat errors) m e s c >>= die 1 + (_, nonopts@(_:_), _) -> usage (unwords nonopts ++ "\n") m e s c >>= die 2 + (modifiers, _, _) -> case sequence modifiers of + Nothing -> usage "" m e s c >>= succeedString + Just ms -> do + shout "Successfully read arguments" + clearLogLevel -- we readArgs twice, so gotta reset this each time + modifyConfig (foldr (.) id ms) +-- }}} +-- config file {{{ +rcName :: FilePath -> FilePath +rcName = ( "config") + +yesConfig :: FilePath -> IO (Either CPError ConfigParser) +yesConfig = Config.readfile Config.emptyCP . rcName + +createConfigFile :: FilePath -> ConfigParser -> IO () +createConfigFile dataDir cp = do + hSetBuffering stdin NoBuffering + putStr "Create the configuration file now? [Yn] " + hFlush stdout + response <- getChar + when (response /= '\n') (putChar '\n') + when (response `elem` "Yy\n") + (createDirectoryIfMissing True dataDir >> + writeFile (rcName dataDir) (Config.to_string cp)) + +noConfig :: Wyvern (Either CPError ConfigParser) +noConfig = do + dataDir <- getDataDir + warn $ "File <" ++ rcName dataDir ++ "> does not exist." + + -- get the important bits of the configuration + username <- getUsername + password <- getPassword + mode <- liftM showMode getMode + editor <- getEditor + server <- getServer + + -- create the config + whisper "Creating an in-memory copy of this configuration" + let set' opt val cp = Config.set cp "DEFAULT" opt val + ecp = return Config.emptyCP + >>= set' "username" username + >>= set' "password" password + >>= set' "mode" mode + >>= set' "editor" editor + >>= set' "server" server + + either (die 3 . show) (liftIO . createConfigFile dataDir) ecp + return ecp + +processConfig :: Either CPError ConfigParser -> Wyvern () +processConfig (Left (err, location)) = die 4 $ "In " ++ location ++ ":\n" ++ show err +processConfig (Right cp) = do + whisper "Updating configuration" + mapM_ (ignoreWarn "section") sections + mapM_ (ignoreWarn "option" ) (options \\ map fst actions) + mapM_ proc actions + where + ignoreWarn s s' = warn $ "Ignoring unknown " ++ s ++ " <" ++ s' ++ ">" + actions = [("username", setUsername), ("password", setPassword), ("mode", setMode . readMode), ("editor", setEditor), ("server", setServer)] + sections = Config.sections cp + Right options = Config.options cp "DEFAULT" + proc (opt, f) = case Config.get cp "DEFAULT" opt of + Right val -> (if opt == "password" then shout else say) ("Read " ++ opt ++ " as <" ++ val ++ ">") + >> f val + Left _ -> return () + +readConfigFile :: Wyvern () +readConfigFile = do + dataDir <- getDataDir + whisper $ "Attempting to read configuration <" ++ rcName dataDir ++ ">" + ecp <- transCatch (yesConfig dataDir) (const noConfig) + processConfig ecp +-- }}} +-- ByteString wrapper for Parsec {{{ +newtype Word8String = Word8String { unString :: BS.ByteString } +instance Monad m => Stream Word8String m Word8 where + uncons = return . fmap (second Word8String) . BS.uncons . unString +-- }}} +-- SGF file management {{{ +-- sample file name: dmwit-violist-520005-20091209.sgf +-- (however, note that uids are allowed to have '-' in them, which +-- complicates things somewhat) +gameIDOf :: FilePath -> [String] +gameIDOf = map reverse . take 1 . drop 1 . sepBy "-" . reverse + +hasUsername :: String -> FilePath -> Bool +hasUsername username filename = first || second where + udash = username ++ "-" + dashudash = "-" ++ udash + first = udash `isPrefixOf` filename + second = dashudash `isInfixOf` filename + +validGameID :: FilePath -> Bool +validGameID = foldr (/=) False . map (all isDigit) . gameIDOf + +isSGF :: FilePath -> Bool +isSGF = (".sgf" `isSuffixOf`) + +empty :: [a] -> b -> b -> b +empty [] v _ = v +empty _ _ v = v + +emptyM :: Monad m => [a] -> m b -> m [c] -> m [c] +emptyM xs m = empty xs (m >> return []) + +lsSGF :: Wyvern [(FilePath, Collection)] +lsSGF = do + dataDir <- getDataDir + whisper $ "Scanning <" ++ dataDir ++ "> for SGF files" + files' <- liftIO $ catch (getDirectoryContents dataDir) + (\_ -> return []) + mapM_ shout $ "Found files:" : files' + let files = filter (\f -> isSGF f && validGameID f) files' + mapM_ say $ "Found well-tagged SGFs:" : files + emptyM files (say "No files found, no need to ask for username") $ do + username <- getUsername + let result = filter (hasUsername username) files + mapM_ whisper $ "Processing these files:" : result + parseSGFs result + +parseResult :: (Stream stream Identity Word8) => String -> (input -> stream) -> input -> Wyvern (Maybe Collection) +parseResult file cast contents = case parse collection file (cast contents) of + Left err -> do + warn $ "Skipping <" ++ file ++ ">: it does not appear to be a valid SGF file" + whisper $ "The parse error is: " ++ show err + return Nothing + Right (collection, warnings) -> do + empty warnings + (say ("Game <" ++ file ++ "> parsed cleanly")) + (whisper ("Game <" ++ file ++ "> has correctable errors") >> mapM_ (say . show) warnings) + return (Just collection) + +parseSGF :: FilePath -> Wyvern (Maybe Collection) +parseSGF file | not (validGameID file) = return Nothing +parseSGF file = do + dataDir <- getDataDir + contents <- liftIO . BS.readFile $ dataDir file + parseResult file Word8String contents + +parseSGFs :: [FilePath] -> Wyvern [(FilePath, Collection)] +parseSGFs files = liftM (catMaybes . zipWith (fmap . (,)) files) (mapM parseSGF files) + +colorFor :: Map Integer Bool -> FilePath -> Collection -> Maybe (FilePath, Bool, Collection) +colorFor m file coll = do + gid <- listToMaybe (gameIDOf file) + color <- Map.lookup (read gid) m + return (file, color, coll) + +-- only keep games that need a move +filterSGFBatch :: [(FilePath, Collection)] -> Wyvern [(FilePath, Bool, Collection)] +filterSGFBatch collections = emptyM collections (shout "No valid SGF files") $ do + games <- status + let gids = Map.fromList [(gid, color) | (gid, _, color, _, _) <- games] + shout $ "Games " ++ show (Map.keys gids) ++ " awaiting a move" + return . catMaybes . map (uncurry (colorFor gids)) $ collections + +handleBatch :: FilePath -> Integer -> String -> String -> Bool -> Collection -> Collection -> Wyvern () +handleBatch file gid server username color disk network = case collectionDiff disk network of + Wait s -> say $ "Skipping <" ++ file ++ ">: " ++ s + Delete s -> rm file >> say s + Do p n -> do + whisper $ "Making move " ++ show n ++ " in game " ++ show gid + status <- dgs (DGS.move server gid color p n) + case status of + NotYourTurn -> warnSkip "did you play a move when I wasn't looking?" + MoveAlreadyPlayed -> warnSkip "did you play a move when I wasn't looking?" + IllegalPosition -> warnSkip "the server claims this causes a ko or some other illegal position." + MoveSuccess -> shout "...success" + _ -> die 8 $ show status + where warnSkip s = warn $ "Skipping game <" ++ show gid ++ ">; " ++ s + +handleAllBatch :: [(FilePath, Bool, Collection)] -> Wyvern () +handleAllBatch cs = empty cs (whisper "Not logging in") $ do + (server, username) <- login + forM_ cs $ \(file, color, disk) -> + let gid = head . map read . gameIDOf $ file + networkFileName = "network (" ++ show gid ++ ")" + in dgs (DGS.sgf server gid True) + >>= parseResult networkFileName (map (toEnum . fromEnum)) + >>= maybe (return ()) (handleBatch file gid server username color disk) + +filterSGFInteractive :: [(FilePath, Collection)] -> Wyvern [Integer] +filterSGFInteractive collections = do + gidsWaitingMove <- liftM (map (\(gid, _, _, _, _) -> gid)) status + let gidsWithMove = [read gid | (file, _) <- collections, gid <- gameIDOf file] + return (gidsWaitingMove \\ gidsWithMove) + +handleInteractive :: FilePath -> String -> String -> String -> Integer -> Wyvern () +handleInteractive dataDir editor server username gid = do + shout $ "Fetching game <" ++ show gid ++ ">" + sgfContents <- dgs (DGS.sgf server gid True) + say $ "Writing <" ++ tempFileName ++ ">" + shout $ "File contents:\n" ++ sgfContents ++ "EOF\n" + liftIO $ writeFile fullName sgfContents + shout $ "Wrote file, running editor" + success <- command + case success of + ExitSuccess -> shout $ "Successfully ran editor on <" ++ tempFileName ++">" + ExitFailure n -> warn $ "Editor exited with unsuccessful exit code <" ++ show n ++ "> when run on <" ++ tempFileName ++ ">" + where + tempFileName = intercalate "-" [username, "opponent", show gid, "0.sgf"] + fullName = dataDir tempFileName + wrappedName = "\"" ++ fullName ++ "\"" + command = case splitOn "#f" editor of + [] -> die 9 editor + [e] -> liftIO . system . unwords $ [e, wrappedName] + es -> liftIO . system . unwords $ intersperse wrappedName es + +handleAllInteractive :: [Integer] -> Wyvern () +handleAllInteractive gids = empty gids (whisper "No games awaiting moves, not logging in") $ do + dataDir <- getDataDir + editor <- getEditor + (server, username) <- login + mapM_ (handleInteractive dataDir editor server username) gids + +execute :: Mode -> Wyvern () +execute Batch = lsSGF >>= filterSGFBatch >>= handleAllBatch +execute Interactive = lsSGF >>= filterSGFInteractive >>= handleAllInteractive +-- }}} +-- decision {{{ +data Decision = Do Point Point | Wait String | Delete String + +collectionDiff :: Collection -> Collection -> Decision +collectionDiff [disk] [network] = gameDiff disk network +collectionDiff _ _ = Wait "More than one game in the collection" + +gameDiff :: Game -> Game -> Decision +gameDiff disk network + | on (/=) size disk network = Delete "File board size does not match DGS board size" + | otherwise = on treeDiff tree disk network + +treeDiff :: GameTree -> GameTree -> Decision +treeDiff (TreeGo disk) (TreeGo network) = treeGoDiff disk network +treeDiff _ _ = Wait "Game tree for game type other than go" + +treeGoDiff :: TreeGo -> TreeGo -> Decision +treeGoDiff disk network = on (forestDiff (rootLabel disk)) subForest disk network + +forestDiff :: NodeGo -> [TreeGo] -> [TreeGo] -> Decision +forestDiff prev disk [ ] = decisionForNodes prev disk +forestDiff prev disk [network] = + case filter (on (==) rootLabel network) disk of + [disk] -> treeGoDiff disk network + _ -> Delete "No move in file matches DGS move" +forestDiff _ _ _ = Wait "True game tree has multiple branches" + +decisionForNodes :: NodeGo -> [TreeGo] -> Decision +decisionForNodes _ [ ] = Delete "Reached end of move tree in file" +decisionForNodes + ( GameNode { action = Right Move { move = Just (_, Play p) } } ) + [Node { rootLabel = GameNode { action = Right Move { move = Just (_, Play c) } } }] + = Do p c +decisionForNodes _ + [Node { rootLabel = GameNode { action = Right Move { move = Just (_, Play c) } } }] + = Wait "True game tree has non-play node" +decisionForNodes _ [_] = Wait "Predicted game tree has non-play node" +decisionForNodes _ nodes = Wait "Several valid continuations available" +-- }}} +wyvern = do + readArgs + readConfigFile + readArgs + dgs DGS.silence + getMode >>= execute + +main = defaultConfig >>= runWyvern wyvern diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/wyvern.cabal b/wyvern.cabal new file mode 100644 --- /dev/null +++ b/wyvern.cabal @@ -0,0 +1,39 @@ +name: wyvern +version: 0.1 +homepage: http://dmwit.com/wyvern +synopsis: An autoresponder for Dragon Go Server. +description: Wyvern will play pre-planned sequences for you on the + Dragon Go Server. Just feed it some SGF files outlining + your plan, and it will make moves in any games that are + waiting. +category: Game +license: BSD3 +license-file: LICENSE +author: Daniel Wagner +maintainer: daniel@wagner-home.com +cabal-version: >= 1.6 +build-type: Simple + +executable wyvern + main-is: Main.hs + build-depends: base >= 3 && < 4, + bytestring >= 0.9, + ConfigFile >= 1.0, + containers >= 0.2, + dgs >= 0.2, + directory >= 1.0, + filepath >= 1.1, + mtl >= 1.1, + parsec >= 3.0, + process >= 1.0, + sgf >= 0.1.1, + split >= 0.1 + +source-repository head + type: git + location: http://www.dmwit.com/wyvern/.git + +source-repository this + type: git + location: http://www.dmwit.com/wyvern/.git + tag: 0.1