dgs (empty) → 0.1
raw patch · 4 files changed
+266/−0 lines, 4 filesdep +HTTPdep +basedep +networksetup-changed
Dependencies added: HTTP, base, network, split
Files
- LICENSE +30/−0
- Network/DGS.hs +198/−0
- Setup.lhs +4/−0
- dgs.cabal +34/−0
+ LICENSE view
@@ -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.
+ Network/DGS.hs view
@@ -0,0 +1,198 @@+-- boilerplate {{{+{-|+This is a quick and dirty interface to Dragon Go Server's robot interface, as+outlined at <http://www.dragongoserver.net/faq.php?read=t&cat=215#Entry219>.+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)]+-- }}}
+ Setup.lhs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ dgs.cabal view
@@ -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