diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2009 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 authors ``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/Network/DGS.hs b/Network/DGS.hs new file mode 100644 --- /dev/null +++ b/Network/DGS.hs @@ -0,0 +1,198 @@ +-- boilerplate {{{ +{-| +This is a quick and dirty interface to Dragon Go Server's robot interface, as +outlined at . +It does almost no sanity-checking of things you send it, nor does it do very +much error-checking on the things Dragon sends back. Use with caution. + +Here are some sample interactions from ghci, with a fictitious password: + +> *Network.DGS> browse (silence >> login development "smartypants" "password") +> LoginSuccess +> *Network.DGS> browse (silence >> statusUID production 4155) >>= mapM_ print +> (453881,"jedge42",False,"2009-12-21 03:14 GMT","F: 30d 1h") +> (532927,"bartnix",False,"2009-12-20 06:06 GMT","F: 21d 13h") +> *Network.DGS> browse (silence >> statusUser production "dmwit") >>= mapM_ print +> (453881,"jedge42",False,"2009-12-21 03:14 GMT","F: 30d 1h") +> (532927,"bartnix",False,"2009-12-20 06:06 GMT","F: 21d 13h") +> *Network.DGS> :{ +> *Network.DGS| browse $ do { +> *Network.DGS| silence; +> *Network.DGS| login development "smartypants" "password"; +> *Network.DGS| (_, [(gid, _, black, _, _)]) <- status development; +> *Network.DGS| move development gid black (16, 18) (17, 16) +> *Network.DGS| } +> *Network.DGS| :} +> MoveSuccess +-} +module Network.DGS ( + -- * Logging in + LoginResult(..), + login, + + -- * Listing games and messages + Game, + Message, + status, + statusUID, + statusUser, + + -- * Making a move + Point, + MoveResult(..), + move, + sgf, + + -- * Miscellaneous + module Network.Browser, + DGS, + development, + production, + silence +) where + +import Data.List +import Data.List.Split +import Network.Browser +import Network.HTTP +import Network.URI +-- }}} +-- helpers {{{ +-- | a convenient type synonym for HTTP's browser monad +type DGS a = BrowserAction (HandleStream String) a + +uri :: String -> String -> URI +uri server path = full where + auth = URIAuth { uriRegName = server, uriUserInfo = "", uriPort = "" } + full = nullURI { uriScheme = "http:", uriAuthority = Just auth, uriPath = '/' : path } + +get :: (String -> a) -> URI -> [(String, String)] -> DGS a +get f uri = fmap (f . rspBody . snd) . request . formToRequest . Form GET uri + +-- | by default, HTTP's browser chatters a lot on stdout; this action turns off +-- the chatter +silence :: DGS () +silence = setErrHandler quiet >> setOutHandler quiet where quiet _ = return () +-- }}} +-- servers {{{ +-- | the address of the development server, @\"dragongoserver.sourceforge.net\"@ +development :: String +-- | the address of the most well-known public server, @\"www.dragongoserver.net\"@ +production :: String +development = "dragongoserver.sourceforge.net" +production = "www.dragongoserver.net" +-- }}} +-- login {{{ +data LoginResult + = WrongUsername + | WrongPassword + | LoginProblem String -- ^ it's a bug in the library if one of these ever gets built + | LoginSuccess + deriving (Eq, Ord, Show, Read) + +-- | some commands either require you to be logged in, or will give additional +-- information if you log in +login :: String -- ^ server, e.g. 'development' or 'production' + -> String -- ^ user name + -> String -- ^ password + -> DGS LoginResult +login server username password = get resultFromString loc opts where + loc = uri server "login.php" + opts = [("quick_mode", "1"), ("userid", username), ("passwd", password)] + + resultFromString s = case s of + "#Error: wrong_userid\n" -> WrongUsername + "#Error: wrong_password\n" -> WrongPassword + "\nOk" -> LoginSuccess + _ -> LoginProblem s +-- }}} +-- status {{{ +-- | (game ID, username of the opponent, current player is black?, date, time remaining) +type Game = (Integer, String, Bool, String, String) +-- | (message ID, username of the sender, subject, date) +type Message = (Integer, String, String, String) + +strip :: String -> String +strip s = read . (\s -> '"' : s ++ "\"") . take (length s - 2) . drop 1 $ s + +gameFromString :: String -> Game +messageFromString :: String -> Message +statusFromString :: String -> ([Message], [Game]) + +gameFromString s = case sepBy ", " s of + ["'G'", gid, uid, color, date, time] -> (read gid, strip uid, color == "'B'", strip date, strip time) +messageFromString s = case sepBy ", " s of + ["'M'", mid, uid, subject, date] -> (read mid, strip uid, strip subject, strip date) +statusFromString s = (messages, games) where + types c = filter (isPrefixOf ('\'' : c : "', ")) (lines s) + games = map gameFromString (types 'G') + messages = map messageFromString (types 'M') + +-- | get the inbox and games list of whoever is currently logged in; this will +-- return @([], [])@ if you are not logged in +status :: String -- ^ server + -> DGS ([Message], [Game]) +-- | get the games list of an arbitrary user; this will give the same results +-- whether or not you are logged in +statusUID :: String -- ^ server + -> Integer -- ^ user ID + -> DGS [Game] +-- | get the games list of an arbitrary user this will give the same results +-- whether or not you are logged in +statusUser :: String -- ^ server + -> String -- ^ user name + -> DGS [Game] + +status server = get statusFromString (uri server "quick_status.php") [] +statusUID server uid = get (snd . statusFromString) (uri server "quick_status.php") [("uid", show uid)] +statusUser server user = get (snd . statusFromString) (uri server "quick_status.php") [("user", user)] +-- }}} +-- play {{{ +-- | 0-indexed x/y coordinates that start at the top left +type Point = (Integer, Integer) + +data MoveResult + = NotLoggedIn + | NoGameNumber + | DatabaseCorrupted -- ^ or a bad game ID + | NotYourTurn -- ^ or you're not playing in the game, or you claimed to be the wrong color + | MoveAlreadyPlayed -- ^ or the previous move didn't match reality + | IllegalPosition -- ^ ko, playing on top of another stone, playing off the board + | MoveProblem String -- ^ it's a bug in the library if one of these ever gets built + | MoveSuccess + deriving (Eq, Ord, Show, Read) + +move :: String -- ^ server + -> Integer -- ^ game ID + -> Bool -- ^ playing as black? (can use exactly the value you got from 'status') + -> Point -- ^ the move the opponent just made + -> Point -- ^ your move + -> DGS MoveResult +move server gid black old new = get resultFromString loc opts where + loc = uri server "quick_play.php" + opts = [("gid", show gid), ("color", col), ("sgf_prev", point old), ("sgf_move", point new)] + col = if black then "B" else "W" + point (x, y) = [pos x, pos y] + pos i = toEnum (fromEnum 'a' + fromEnum i) + + resultFromString s | "#Error: " `isPrefixOf` s = case drop 8 s of + "not_logged_in\n" -> NotLoggedIn + "no_game_nr\n" -> NoGameNumber + "database_corrupted\n" -> DatabaseCorrupted + "not_your_turn\n" -> NotYourTurn + "already_played\n" -> MoveAlreadyPlayed + "illegal_position\n" -> IllegalPosition + resultFromString "\nOk" = MoveSuccess + resultFromString s = MoveProblem s +-- }}} +-- sgf {{{ +-- | you can only get private comments if you are logged in; if you are not +-- logged in, this will succeed, but a request for private comments will be +-- ignored, and you'll get an SGF with only the public comments +sgf :: String -- ^ server + -> Integer -- ^ game ID + -> Bool -- ^ request the private comments? + -> DGS String +sgf server gid comments = get id (uri server "sgf.php") opts where + opts = [("gid", show gid), ("owned_comments", show . fromEnum $ comments)] +-- }}} 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/dgs.cabal b/dgs.cabal new file mode 100644 --- /dev/null +++ b/dgs.cabal @@ -0,0 +1,34 @@ +name: dgs +version: 0.1 +author: Daniel Wagner +maintainer: daniel@wagner-home.com +homepage: http://www.dmwit.com/dgs +bug-reports: http://dmwit.fogbugz.com/ +synopsis: Haskell front-end for DGS' bot interface +description: + The Dragon Go Server exposes a convenient interface for bots. This module + provides some functions for accessing that interface to log in to the + server, retrieve your status page, retrieve the state of any games you are + playing, and make moves in games. +category: Game, Network, Web +license: BSD3 +license-file: LICENSE +cabal-version: >= 1.6 +build-type: Simple + +library + exposed-modules: Network.DGS + + build-depends: base >=3 && < 4, + HTTP, + network, + split + +source-repository head + type: git + location: http://www.dmwit.com/dgs + +source-repository this + type: git + location: http://www.dmwit.com/dgs + tag: 0.1