Adventure.hs

-- | This is a simple persistent multi-user adventure game, to demonstrate the
-- use of Berkeley DB/XML combined with HXT picklers.
-- The HXT library is required for this, which can be downloaded from Hackage.
--
-- To log in, you need to use a telnet client.  The command is
--
--     telnet localhost 1888
--
-- It is assumed that your telnet client will echo and buffer the text you type.
-- This is usually the case on Unix systems.

module Main where

import Database.Berkeley.Db
import Database.Berkeley.DbXml
import Text.XML.HXT.Arrow hiding (when)
import Network
import Control.Concurrent
import Control.Monad
import System.IO
import Data.List
import Data.Char
import Data.Maybe

data Player = Player {
        playerName :: String,
        playerLocation :: String
    }
    deriving (Show)

instance XmlPickler Player where
    xpickle = xpPlayer

xpPlayer :: PU Player
xpPlayer =
    xpElem "player"$
    xpWrap (
            (\(nam, loc) -> Player nam loc),
            (\(Player nam loc) -> (nam, loc))
        )$
    xpPair
        (xpAttr "name"$ xpText0)
        (xpAttr "location"$ xpText0)

data Room = Room {
        roomKey :: String,
        roomDescription :: String,
        roomExits :: [(String, String)]
    }
    deriving (Show)

instance XmlPickler Room where
    xpickle = xpRoom

xpRoom :: PU Room
xpRoom =
   xpElem "room"$
   xpWrap (
           (\(key, des, exi) -> Room key des exi),
           (\(Room key des exi) -> (key, des, exi))
       )$
   xpTriple
       (xpAttr "key"$ xpText0)
       (xpElem "descr"$ xpText0)
       (xpElem "exits"$
               xpList$
                   xpElem "exit"$
                        xpPair
                            (xpAttr "name"$ xpText0)
                            (xpAttr "room"$ xpText0)
           )

data Item = Item {
        itemKey :: String,
        itemLocation :: String,
        itemDescription :: String,
        itemNames :: [String],
        itemPortable :: Bool
    }
    deriving (Show)

instance XmlPickler Item where
    xpickle = xpItem

xpItem :: PU Item
xpItem =
    xpElem "item"$
    xpWrap (
            (\(key, loc, des, nam, por) -> Item key loc des nam (read por)),
            (\(Item key loc des nam por) -> (key, loc, des, nam, (show por)))
        )$
    xp5Tuple
        (xpAttr "key"$ xpText0)
        (xpAttr "location"$ xpText0)
        (xpElem "descr"$ xpText0)
        (xpElem "names"$ xpList$ xpElem "name"$ xpAttr "name"$ xpText0)
        (xpAttr "portable"$ xpText0)

initialRooms = [
        Room "beach"
            ("You are on a wide, white sandy beach. A bright blue ocean stretches to the horizon. "++
             "Along the beach to the north you can see some large rocks. There is thick jungle to the west.")
            [("west", "jungle"),("north", "rocks1")],
        Room "jungle"
            "You are in a dense jungle."
            [("west", "jungle"),("east", "beach"),("north", "jungle"),("south", "jungle"),("up","tree")],
        Room "tree"
            "You are up in a tree. To the south, you can see mountains."
            [("down", "jungle")],
        Room "rocks1"
            ("The beach here is strewn with large boulders. It gets more rocky to the north. "++
             "The sea is to the east.")
            [("south", "beach"),("north", "rocks2")],
        Room "rocks2"
            ("You are in a passage between huge rocks. To the west you can see the entrance to a cave. "++
             "The beach is to the south.")
            [("south", "beach"),("west", "cave")],
        Room "cave"
            ("You are in a cave, exit to the east.")
            [("east", "rocks2")]
    ]

initialItems = [
        Item "starfish" "beach" "a starfish" ["starfish","fish"] True,
        Item "tree" "jungle" "a tall, twisty tree" ["tree"] False,
        Item "nest" "tree" "an empty bird's nest" ["nest", "bird's nest", "bird nest"] True,
        Item "shell" "rocks1" "a beautiful shell" ["shell"] True,
        Item "troll" "cave" "a fierce-looking troll" ["troll"] False,
        Item "coin" "cave" "a gold coin" ["coin", "gold", "gold coin"] True
    ]

-- Get a non-empty line and strip leading and trailing whitespace
prompt :: Handle -> IO String
prompt h = do
    hPutStr h "> "
    hFlush h
    l <- hGetLine h
    let strip = dropWhile isSpace
    let l' = (reverse . strip . reverse . strip) l
    if l' == []
        then prompt h
        else return l'

-- Execute the specified code within a database transaction, automatically
-- re-trying if a deadlock is detected.
inTransaction :: XmlManager -> (XmlTransaction -> IO a) -> IO a
inTransaction mgr code = inTransaction_ mgr code 0
    where
        inTransaction_ mgr code retryCount = do
            trans <- xmlManager_createTransaction mgr []
            catch
                (do
                        result <- code trans
                        xmlTransaction_commit trans
                        return result
                    )
                (\err -> do
                        xmlTransaction_abort trans
                        let dbErr = getDbError err
                        if (dbErr == Just DB_LOCK_DEADLOCK) && (retryCount < 20)
                            then do
                                 hPutStrLn stderr "<<retry deadlocked thread>>"
                                 inTransaction_ mgr code (retryCount+1)
                            else ioError err
                    )

toXML :: XmlPickler p => p -> IO String
toXML p = do
    mText <- liftM listToMaybe$ runX (
            constA p >>>
            xpickleVal (xpickle) >>>
            writeDocumentToString [(a_indent, v_0)]
        )
    case mText of
        Just text -> return text
        Nothing ->   ioError (userError "pickle failed!")

collectM :: Monad m => m (Maybe a) -> m [a]
collectM valueM = do
    value <- valueM
    case value of
        Just item -> do
            rest <- collectM valueM
            return (item:rest)
        Nothing -> do
            return []

query_ :: XmlPickler p => (XmlManager, XmlContainer, XmlTransaction) -> PU p
      -> String -> [(String, XmlValue)] -> [DbXmlFlag] -> IO [(XmlDocument, p)]
query_ (mgr, cont, trans) pickler queryText params flags = do
    qctx <- xmlManager_createQueryContext mgr LiveValues Eager
    let collection = xmlContainer_getName cont
    xmlQueryContext_setDefaultCollection qctx collection
    forM params $ \(name, value) -> do
        xmlQueryContext_setVariableValue qctx name value
    res <- xmlManager_query mgr (Just trans) queryText qctx flags
    docs <- collectM (xmlResults_next res)
    records <- liftM (concat) $ forM docs $ \doc -> do
                text <- xmlDocument_getContent doc
                ps <- runX (
                    readString [ (a_validate, v_0),(a_remove_whitespace, v_1)] text
                    >>> xunpickleVal pickler)
                return$ map (\p -> (doc, p)) ps
    return records

query :: XmlPickler p => (XmlManager, XmlContainer, XmlTransaction) -> PU p
      -> String -> [(String, XmlValue)] -> IO [p]
query ctx pickler queryText params = liftM (map snd)$ query_ ctx pickler queryText params []

-- | Query with write lock. Returned document allows the document to be updated
-- without having to specify its document name.
queryUpdate :: XmlPickler p => (XmlManager, XmlContainer, XmlTransaction) -> PU p
      -> String -> [(String, XmlValue)] -> IO [(XmlDocument, p)]
queryUpdate ctx pickler queryText params = query_ ctx pickler queryText params [DB_FLAG DB_RMW]

create :: XmlPickler p => (XmlManager, XmlContainer, XmlTransaction) -> p -> IO ()
create (mgr, cont, trans) p = do
    doc <- xmlManager_createDocument mgr
    text <- toXML p
    xmlDocument_setContent doc text
    uctx <- xmlManager_createUpdateContext mgr
    xmlContainer_putDocument cont (Just trans) doc uctx [DBXML_GEN_NAME]

update :: XmlPickler p => (XmlManager, XmlContainer, XmlTransaction) -> XmlDocument -> p -> IO ()
update (mgr, cont, trans) doc p = do
    text <- toXML p
    xmlDocument_setContent doc text
    uctx <- xmlManager_createUpdateContext mgr
    xmlContainer_updateDocument cont (Just trans) doc uctx

-- | Create an item for the player so other players can see them.
putPlayer :: (XmlManager, XmlContainer, XmlTransaction) -> String -> String -> IO ()
putPlayer db name room = do
    items <- queryUpdate db xpItem "collection()/item[@key=$key]" [("key", xmlString$ "player_"++name)]
    case items of
        ((doc, p):_) -> do
            let p' = p {itemLocation = room}
            update db doc p'
        otherwise -> do
            create db$ Item ("player_"++name) room name [] False

deletePlayer :: (XmlManager, XmlContainer, XmlTransaction) -> String -> IO ()
deletePlayer db@(mgr, cont, trans) name = do
    items <- queryUpdate db xpItem "collection()/item[@key=$key]" [("key", xmlString$ "player_"++name)]
    case items of
        ((doc, p):_) -> do
            uctx <- xmlManager_createUpdateContext mgr
            xmlContainer_deleteDocument cont (Just trans) doc uctx
        otherwise -> return ()

initGame :: XmlManager -> XmlContainer -> IO ()
initGame mgr cont = do
    inTransaction mgr$ \trans -> do
        let db = (mgr, cont, trans)
        beaches <- query db xpRoom "collection()/room[@key=$key]" [("key", xmlString "beach")]
        if null beaches
            then do
                hPutStrLn stderr $ "Creating the game world..."
                forM_ initialRooms$ \room -> do
                    create db room
                forM_ initialItems$ \item -> do
                    create db item
            else return ()

look :: (XmlManager, XmlContainer, XmlTransaction) -> String -> IO [String]
look db name = do
    -- Not very good error checking here.
    player <- liftM head$ query db xpPlayer "collection()/player[@name=$name]"
        [("name", xmlString name)]
    let loc = playerLocation player
    room <- liftM head$ query db xpRoom "collection()/room[@key=$loc]"
        [("loc", xmlString loc)]
    items <- query db xpItem "collection()/item[@location=$loc]"
        [("loc", xmlString loc)]
    let notMe item =   -- True if this item doesn't describe the player
            (itemKey item /= "player_"++name)
    let itemsOtherThanMe = filter notMe items
    return$
        (roomDescription room):
        (if null itemsOtherThanMe
            then []
            else "You can see":map (\i -> "  "++(itemDescription i)) itemsOtherThanMe)

go :: (XmlManager, XmlContainer, XmlTransaction) -> String -> String -> IO [String]
go db name dir = do
    (playerDoc, player) <- liftM head$ queryUpdate db xpPlayer "collection()/player[@name=$name]"
        [("name", xmlString name)]
    let loc = playerLocation player
    room <- liftM head$ query db xpRoom "collection()/room[@key=$loc]"
        [("loc", xmlString loc)]
    let mExit = dir `lookup` (roomExits room)
    case mExit of
        Just newRoom -> do
            putPlayer db name newRoom
            update db playerDoc player {
                        playerLocation = newRoom
                    }
            look db name
        Nothing -> do
            return ["You can't go that way."]

get :: (XmlManager, XmlContainer, XmlTransaction) -> String -> String -> IO [String]
get db name noun = do
    player <- liftM head$ query db xpPlayer "collection()/player[@name=$name]"
        [("name", xmlString name)]
    let loc = playerLocation player
    room <- liftM head$ query db xpRoom "collection()/room[@key=$loc]"
        [("loc", xmlString loc)]
    items <- queryUpdate db xpItem "collection()/item[@location=$loc]"
        [("loc", xmlString loc)]
    let yes = filter (\(iDoc, i) -> noun `elem` itemNames i) items
    case yes of
        [] -> return ["I can't see one of those here."]
        ((iDoc, i):_) -> do
            if itemPortable i
                then do
                    update db iDoc i {itemLocation = "player_"++name}
                    return ["You pick up "++(itemDescription i)++"."]
                else
                    return ["Hurrrrgh. No, it isn't portable."]

drop :: (XmlManager, XmlContainer, XmlTransaction) -> String -> String -> IO [String]
drop db name noun = do
    player <- liftM head$ query db xpPlayer "collection()/player[@name=$name]"
        [("name", xmlString name)]
    let loc = playerLocation player
    items <- queryUpdate db xpItem "collection()/item[@location=$loc]"
        [("loc", xmlString$ "player_"++name)]
    let yes = filter (\(iDoc, i) -> noun `elem` itemNames i) items
    case yes of
        [] -> return ["I am not carrying one of those."]
        ((iDoc, i):_) -> do
            update db iDoc i {itemLocation = loc}
            return ["You drop "++(itemDescription i)++"."]

inventory :: (XmlManager, XmlContainer, XmlTransaction) -> String -> IO [String]
inventory db name = do
    items <- query db xpItem "collection()/item[@location=$loc]"
        [("loc", xmlString$ "player_"++name)]
    return$
        (if null items
            then ["You are not carrying anything."]
            else "You are carrying":map (\i -> "  "++(itemDescription i)) items)
            
help :: [String]
help = [
        "These are the only commands I understand:",
        "  get <item>",
        "  drop <item>",
        "  inventory",
        "  look",
        "  north, east, west, south, up, down",
        "  quit"
    ]

process :: (XmlManager, XmlContainer, XmlTransaction) -> String -> String -> IO [String]
process db name cmd = do
    case words cmd of
        [] -> return []
        (verb:nouns) -> case (verb, unwords nouns) of
            ("look", _) -> look db name
            ("quit", _) -> fail "User typed 'quit'"
            (dir, _) | dir `elem` ["north", "east", "west", "south", "up", "down"] ->
                go db name dir
            ("get", noun) -> get db name noun
            ("inventory", _) -> inventory db name
            ("drop", noun) -> Main.drop db name noun
            ("help", _) -> return help
            otherwise   -> return ["I don't understand that."]

session :: XmlManager -> XmlContainer -> Handle -> IO ()
session mgr cont h = do
    initGame mgr cont
    hPutStrLn h "Welcome to 'DB/XML Haskell binding' adventure by Stephen Blackheath"
    hPutStrLn h "Please enter your name."
    name <- prompt h
    created <- inTransaction mgr$ \trans -> do
        let db = (mgr, cont, trans)
        mPlayer <- liftM listToMaybe$ query db xpPlayer "collection()/player[@name=$name]"
            [("name", xmlString name)]
        (created, player) <- case mPlayer of
            Just player ->
                return (False, player)
            Nothing -> do
                let player = Player name "beach"
                create db player
                return (True, player)
        -- We create an item for the player to make it so other players can see them.
        putPlayer db name (playerLocation player)
        return created
    if created
        then hPutStrLn h$ "Welcome for the first time, "++name++"."
        else hPutStrLn h$ "Welcome back, "++name++"."
    hPutStrLn h$ ""
    hPutStrLn h$ "For help, please type \"help\"."
    hPutStrLn h$ ""

    mapM_ (hPutStrLn h) =<< inTransaction mgr (\trans -> do
            let db = (mgr, cont, trans)
            look db name
        )
    catch (
            forever$ do
                cmd <- prompt h
                mapM_ (hPutStrLn h) =<< inTransaction mgr (\trans -> do
                        let db = (mgr, cont, trans)
                        process db name cmd
                    )
        )
        (\err -> do
            hPutStrLn h$ "Bye!"
            inTransaction mgr$ \trans -> do
                let db = (mgr, cont, trans)
                deletePlayer db name
            ioError err)

deleteCadavers :: (XmlManager, XmlContainer, XmlTransaction) -> IO ()
deleteCadavers db@(mgr, cont, trans) = do
    cadavers <- queryUpdate db xpItem "collection()/item[substring(@key,1,7)='player_']" []
    hPutStrLn stderr$ "tidying up " ++ (show$ length cadavers) ++ " cadavers"
    forM_ cadavers$ \(doc, p) -> do
        uctx <- xmlManager_createUpdateContext mgr
        xmlContainer_deleteDocument cont (Just trans) doc uctx

main = do
    let portNo = 1888
    server <- listenOn (PortNumber portNo)

    dbenv <- dbEnv_create []

    -- Enable automatic deadlock detection.  Deadlock detection is required for
    -- multi-threaded applications.  Deadlock detection must be started on only
    -- one process in a Berkeley DB environment.
    dbEnv_set_lk_detect dbenv DB_LOCK_DEFAULT

    -- Note that we are doing DB_RECOVER here.  This should always be done before
    -- running the application but must be done with no other processes using the
    -- environment at the same time.
    dbEnv_open dbenv "." [DB_CREATE,DB_INIT_LOCK,DB_INIT_LOG,DB_INIT_MPOOL,
        DB_INIT_TXN,DB_THREAD,DB_RECOVER] 0
    mgr <- xmlManager_create dbenv []
    cont <- xmlManager_openContainer mgr "adventure.dbxml"
        [DBXML_TRANSACTIONAL,DB_FLAG DB_THREAD,DB_FLAG DB_CREATE]
        WholedocContainer 0

    putStrLn$ "Adventure server - please telnet into port "++show portNo

    inTransaction mgr$ \trans -> do
        let db = (mgr, cont, trans)
        deleteCadavers db
    
    forever$ do
        (client, host, port) <- accept server
        forkIO$ do
            catch
                (session mgr cont client >> hClose client)
                (\err -> do
                    hPutStrLn stderr (show err)
                    hClose client)