Initial commit

5 files changed, 378 insertions, 0 deletions

diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
index 0000000..d45088b
--- /dev/null
+++ b/ChangeLog.md
@@ -0,0 +1,6 @@
+# Revision history for dwproxy
+
+## 0.1.0.0  -- 2018-09-30
+
+* First release: Rudimentary GMCP support, basic speedwalking between
+  locations.
diff --git a/DWProxy.hs b/DWProxy.hs
new file mode 100644
index 0000000..621fdcf
--- /dev/null
+++ b/DWProxy.hs
@@ -0,0 +1,293 @@
+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import Data.Graph.Inductive.Graph (mkGraph)
+import Data.Graph.Inductive.PatriciaTree (Gr)
+import Data.Graph.Inductive.Query.SP (sp)
+import qualified Data.HashMap.Strict as HM
+import qualified Database.SQLite.Simple as SQLite
+import Data.Maybe (mapMaybe, fromJust)
+import System.Environment (getArgs)
+import System.FilePath ((</>))
+import Network.Socket.ByteString (sendAll, recv)
+import Network.Socket hiding (send, recv)
+import Control.Concurrent.Async (async, waitAny)
+import Control.Exception as E
+import Control.Monad (when, forM_, forever)
+import Data.Attoparsec.ByteString
+import Data.Attoparsec.ByteString.Char8
+import qualified Data.ByteString.Char8 as BS
+import Control.Concurrent.MVar
+import Data.Either (rights)
+import Control.Applicative
+import Data.Aeson (FromJSON, decodeStrict)
+import GHC.Generics (Generic)
+
+
+type RoomID = T.Text
+
+data RoomInfo = RoomInfo { identifier :: T.Text, name :: T.Text }
+  deriving (Show, Generic, FromJSON)
+
+data Room = Room { roomID :: RoomID
+                 , roomMapID :: Int
+                 , roomX :: Int
+                 , roomY :: Int
+                 , roomShort :: T.Text
+                 , roomType :: T.Text
+                 } deriving (Show, Eq)
+
+data Exit = Exit { exitFrom :: RoomID
+                 , exitTo :: RoomID
+                 , exitName :: T.Text }
+  deriving (Show, Eq)
+
+mapNames :: [T.Text]
+mapNames =
+  [ "Ankh-Morpork", "AM Assassins", "AM Buildings", "AM Cruets", "AM Docks"
+  , "AM Guilds", "AM Isle of Gods", "Shades Maze", "Temple of Small Gods"
+  , "AM Temples", "AM Thieves", "Unseen University", "AM Warriors"
+  , "Pseudopolis Watch House", "Magpyr's Castle", "Bois", "Bes Pelargic"
+  , "BP Buildings", "BP Estates", "BP Wizards", "Brown Islands"
+  , "Death's Domain", "Djelibeybi", "IIL - DJB Wizards", "Ephebe"
+  , "Ephebe Underdocks", "Genua", "Genua Sewers", "GRFLX Caves"
+  , "Hashishim Caves", "Klatch Region", "Mano Rossa", "Monks of Cool"
+  , "Netherworld", "Pumpkin Town", "Ramtops Regions", "Sto Lat"
+  , "Academy of Artificers", "Cabbage Warehouse", "AoA Library"
+  , "Sto Lat Sewers", "Sprite Caves", "Sto Plains Region"
+  , "Uberwald Region", "UU Library", "Klatchian Farmsteads", "CFT Arena"
+  , "PK Arena", "AM Post Office", "Ninja Guild", "The Travelling Shop"
+  , "Slippery Hollow", "House of Magic - Creel", "Special Areas"
+  , "Skund Wolf Trail"
+  ]
+
+instance SQLite.FromRow Room where
+  fromRow = Room <$> SQLite.field <*> SQLite.field <*> SQLite.field
+            <*> SQLite.field <*> SQLite.field <*> SQLite.field
+
+instance SQLite.FromRow Exit where
+  fromRow = Exit <$> SQLite.field <*> SQLite.field <*> SQLite.field
+
+data PathFinder = PF { pfGraph :: Gr RoomID Int
+                     , pfRoomToNode :: HM.HashMap RoomID Int
+                     , pfNodeToRoom :: HM.HashMap Int RoomID
+                     , pfExitMap :: HM.HashMap (RoomID, RoomID) T.Text
+                     }
+
+pathFinder :: [Room] -> [Exit] -> PathFinder
+pathFinder rooms exits =
+  let roomIDs = map roomID rooms
+      roomToNode = HM.fromList (zip roomIDs [1..])
+      nodes = zip [1..] roomIDs
+      nodeToRoom = HM.fromList nodes
+      mkEdge e = do
+        from <- HM.lookup (exitFrom e) roomToNode
+        to <- HM.lookup (exitTo e) roomToNode
+        pure (from, to, 1)
+      edges = mapMaybe mkEdge exits
+      graph = mkGraph nodes edges :: Gr RoomID Int
+      exitMap = HM.fromList $ map (\(Exit f t e) -> ((f, t), e)) exits
+  in PF graph roomToNode nodeToRoom exitMap
+
+findPath :: PathFinder -> RoomID -> RoomID -> Either T.Text T.Text
+findPath pf from to =
+  let route = sp (fromJust $ HM.lookup from $ pfRoomToNode pf)
+              (fromJust $ HM.lookup to $ pfRoomToNode pf)
+              (pfGraph pf)
+  in case route of
+    Just path@(_:_) -> Right $ T.intercalate ";" $
+      mapMaybe (flip HM.lookup (pfExitMap pf)) $
+      (\p -> zip p (tail p)) $ mapMaybe (flip HM.lookup $ pfNodeToRoom pf) path
+    Just [] -> Right "look"
+    Nothing -> Left "No route found"
+
+mkServer :: IO Socket
+mkServer = do
+  addr <- head <$> getAddrInfo
+    (Just $ defaultHints {addrFlags = [AI_PASSIVE], addrSocketType = Stream})
+    Nothing
+    (Just "2000")
+  sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+  setSocketOption sock ReuseAddr 1
+  bind sock (addrAddress addr)
+  listen sock 1
+  pure sock
+
+mkClient :: IO Socket
+mkClient = do
+  addr <- head <$> getAddrInfo
+    (Just $ defaultHints { addrSocketType = Stream })
+    (Just "discworld.starturtle.net")
+    (Just "23")
+  sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+  connect sock $ addrAddress addr
+  pure sock
+
+showRoom :: Room -> BS.ByteString
+showRoom r = TE.encodeUtf8 $ T.concat
+  [ roomShort r, " ("
+  , mapNames !! (roomMapID r - 1), ", "
+  , T.pack (show $ roomX r), "x", T.pack (show $ roomY r)
+  , ")"]
+
+c2s :: Config -> BS.ByteString -> IO ()
+c2s c leftover = do
+  cmd <- parseWith (recv (cClient c) 4096) pCommand leftover
+  case cmd of
+    Fail d _ _ -> when (d /= "") $ do
+      -- putStrLn $ "Client: " ++ show cmd
+      sendAll (cServer c) $ BS.takeWhile (/= '\255') d
+      c2s c $ BS.dropWhile (/= '\255') d
+    Partial _ -> error "Unexpected partial result"
+    Done d r -> do
+      case r of
+        TelnetSN s -> sendAll (cServer c) $ BS.concat ["\255\250", s, "\255\240"]
+        Telnet "\254\201" -> do
+          sendAll (cServer c) $ BS.concat
+            [ "\255\253\201" -- enable GMCP
+            , "\255\250\201" -- GMCP sub-negotiation
+            , "core.hello { \"client\" : \"dwproxy\", \"version\" : \"0\" }"
+            , "\255\240"
+            , "\255\250\201"
+            , "core.supports.set [ \"room.info\" ]"
+            , "\255\240"
+            ]
+        Telnet other -> sendAll (cServer c) $ BS.cons '\255' other
+        SpeedWalk f t -> do
+          cs <- readMVar (connState c)
+          case (T.pack <$> f) <|> currentRoom cs of
+            Nothing -> sendAll (cClient c)
+              "No source location is given, and none detected"
+            Just f' -> do
+              fromRooms <- SQLite.query (dbConn c)
+                "select * from rooms where room_short like ? or room_id = ?"
+                ((T.concat ["%", f', "%"]), f')
+              toRooms <- SQLite.query (dbConn c)
+                "select * from rooms where room_short like ?"
+                (SQLite.Only (concat ["%", t, "%"]))
+              let routes = rights
+                    [ (\p -> (showRoom from, showRoom to, p)) <$>
+                    findPath (cPF c) (roomID from) (roomID to)
+                    | from <- fromRooms, to <- toRooms ]
+              case routes of
+                [] -> sendAll (cClient c) "No routes found\r\n"
+                _ -> do
+                  sendAll (cClient c) "Routes found:\r\n"
+                  forM_ (zip ([0..] :: [Int]) routes) $ \(n, (from, to, _)) ->
+                    sendAll (cClient c) $
+                    BS.concat ["[", BS.pack (show n), "] ", from, " to ", to, "\r\n"]
+                  modifyMVar_ (connState c) $ \cst -> pure $
+                    cst { routeOptions = map (\(_,_,route) -> TE.encodeUtf8 route) routes }
+                  pure ()
+        RouteChoice n -> do
+          routes <- routeOptions <$> readMVar (connState c)
+          if length routes < n
+            then sendAll (cClient c) "No such route"
+            else sendAll (cServer c) $
+                 BS.concat ["alias _speedwalk ", routes !! n, "\r\n"]
+      c2s c d
+
+s2c :: Config -> BS.ByteString -> IO ()
+s2c c leftover = do
+  cmd <- parseWith (recv (cServer c) 4096) pCommon leftover
+  case cmd of
+    Fail d _ _ -> when (d /= "") $ do
+      -- putStrLn $ "Server: " ++ show cmd
+      sendAll (cClient c) $ BS.takeWhile (/= '\255') d
+      s2c c $ BS.dropWhile (/= '\255') d
+    Partial _ -> error "Unexpected partial result"
+    Done d r -> do
+      case r of
+        Telnet s -> sendAll (cClient c) $ BS.cons '\255' s
+        TelnetSN s -> do
+          case BS.stripPrefix "\201room.info " s >>= decodeStrict of
+            Nothing -> pure ()
+            jri -> do
+              print jri
+              modifyMVar_ (connState c) $ \cs -> pure cs { currentRoom = identifier <$> jri }
+              sendAll (cClient c) $ BS.concat ["\255\250", s, "\255\240"]
+        _ -> error "Parsed an unexpected server command"
+      s2c c d
+
+data Command = Telnet BS.ByteString
+             | TelnetSN BS.ByteString
+             | SpeedWalk (Maybe String) String
+             | RouteChoice Int
+  deriving (Show)
+
+data ConnState = CS { routeOptions :: [BS.ByteString]
+                    , currentRoom :: Maybe RoomID
+                    } deriving (Show)
+
+data Config = Config { cClient :: Socket
+                     , cServer :: Socket
+                     , dbConn :: SQLite.Connection
+                     , connState :: MVar ConnState
+                     , cPF :: PathFinder
+                     }
+
+pRouteChoice :: Parser Command
+pRouteChoice = do
+  _ <- "route "
+  d <- decimal
+  _ <- "\r\n"
+  pure $ RouteChoice d
+
+pSpeedWalk :: Parser Command
+pSpeedWalk = do
+  _ <- "speedwalk "
+  from <- ("from " *> (Just <$> manyTill (notChar '\255') " to "))
+    <|> ("to " *> pure Nothing)
+  to <- manyTill (notChar '\255') "\r\n"
+  pure $ SpeedWalk from to
+
+pClientCommand :: Parser Command
+pClientCommand = pSpeedWalk <|> pRouteChoice
+
+pTelnetSN :: Parser Command
+pTelnetSN = do
+  _ <- "\255\250"
+  (TelnetSN . BS.pack) <$> manyTill anyChar "\255\240"
+
+pTelnet :: Parser Command
+pTelnet = do
+  _ <- char '\255'
+  c <- notChar '\250'
+  Telnet <$> if c >= '\251' && c <= '\254'
+    then do
+      code <- anyChar
+      pure $ BS.pack [c, code]
+    else pure $ BS.pack [c]
+
+pCommon :: Parser Command
+pCommon = pTelnet <|> pTelnetSN
+
+pCommand :: Parser Command
+pCommand = pClientCommand <|> pCommon
+
+main :: IO ()
+main = do
+  args <- getArgs
+  case args of
+    [quow] ->
+      E.bracket
+      (SQLite.open $ quow </> "maps" </> "_quowmap_database.db")
+      (SQLite.close) $ \db -> do
+      rooms <- SQLite.query_ db
+        "select room_id, map_id, xpos, ypos, room_short, room_type from rooms"
+      exits <- SQLite.query_ db "select room_id, connect_id, exit from room_exits"
+      let pf = pathFinder rooms exits
+      mv <- newMVar $ CS [] Nothing
+      E.bracket mkServer close $ \serverSocket -> forever $ do
+        putStrLn "Waiting for connections"
+        E.bracket (fst <$> accept serverSocket) close $ \client ->
+          E.bracket mkClient close $ \server -> do
+          putStrLn "Connected to DW"
+          let c = Config client server db mv pf
+          c2s' <- async $ c2s c ""
+          s2c' <- async $ s2c c ""
+          waitAny [c2s', s2c']
+    _ -> putStrLn "Usage: dwroute <quow plugins>"
+  pure ()
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..710a3ab
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2018, defanor
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * 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.
+
+    * Neither the name of defanor nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT
+OWNER 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/README.md b/README.md
new file mode 100644
index 0000000..897cda9
--- /dev/null
+++ b/README.md
@@ -0,0 +1,14 @@
+# dwproxy
+
+This is a client-agnostic proxy for the Discworld MUD, which adds new
+commands:
+
+- `speedwalk [from <location>] to <location>`: find routes
+- `route <n>`: select a speedwalk route option
+
+It uses the database from [Quow's Cow Bar and
+Minimap](http://quow.co.uk/minimap.php), which should be available,
+and the path to which should be provided as the first argument on
+invocation, e.g.: `dwproxy ~/discworld/quow_cowbar/`.
+
+The default port is 2000, `telnet localhost 2000` to connect.
diff --git a/dwproxy.cabal b/dwproxy.cabal
new file mode 100644
index 0000000..940c213
--- /dev/null
+++ b/dwproxy.cabal
@@ -0,0 +1,35 @@
+-- Initial dwproxy.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                dwproxy
+version:             0.1.0.0
+-- synopsis:            
+-- description:         
+license:             BSD3
+license-file:        LICENSE
+author:              defanor
+maintainer:          defanor@uberspace.net
+-- copyright:           
+category:            Network
+build-type:          Simple
+extra-source-files:  ChangeLog.md
+cabal-version:       >=1.10
+
+executable dwproxy
+  main-is:             DWProxy.hs
+  -- other-modules:       
+  other-extensions:    DeriveGeneric, DeriveAnyClass, OverloadedStrings
+  build-depends:       base >=4.9 && <4.10
+                     , text >=1.2 && <1.3
+                     , fgl >=5.6 && <5.7
+                     , unordered-containers >=0.2 && <0.3
+                     , sqlite-simple >=0.4 && <0.5
+                     , filepath >=1.4 && <1.5
+                     , network >=2.7 && <2.8
+                     , async >=2.2 && <2.3
+                     , attoparsec >=0.13 && <0.14
+                     , bytestring >=0.10 && <0.11
+                     , aeson >=1.4 && <1.5
+  -- hs-source-dirs:      
+  default-language:    Haskell2010
+  ghc-options:       -threaded -O3 -Wall