-- This file is part of Intricacy -- Copyright (C) 2013 Martin Bays -- -- This program is free software: you can redistribute it and/or modify -- it under the terms of version 3 of the GNU General Public License as -- published by the Free Software Foundation, or any later version. -- -- You should have received a copy of the GNU General Public License -- along with this program. If not, see http://www.gnu.org/licenses/. {-# LANGUAGE ScopedTypeVariables #-} module Interact (interactUI) where import Control.Monad.State import Control.Applicative import qualified Data.Vector as Vector import qualified Data.Map as Map import Data.Map (Map) import Control.Monad.Writer import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Exception import Data.Maybe import Data.Char import Data.List import Control.Concurrent.STM import Control.Concurrent import System.Directory import System.FilePath import Data.Array import Data.Function (on) import Safe (readMay) import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as CS import Crypto.Types.PubKey.RSA (PublicKey) import Codec.Crypto.RSA (encrypt) import Crypto.Random (newGenIO, SystemRandom) import Hex import Command import Physics import Mundanities import AsciiLock import GameState import GameStateTypes import EditGameState import Frame import Lock import Cache import Database import Protocol import Metagame import ServerAddr import MainState import InputMode import Maxlocksize import InteractUtil import Util newtype InteractSuccess = InteractSuccess Bool interactUI :: UIMonad uiM => MainStateT uiM InteractSuccess interactUI = do im <- gets ms2im lift $ onNewMode im when (im == IMEdit) setSelectedPosFromMouse when (im == IMMeta) $ do spawnUnblockerThread -- draw before testing auth, lest a timeout mean a blank screen drawMainState testAuth refreshUInfoUI tbdg <- lift $ getUIBinding IMMeta CmdTutorials isNothing <$> gets curAuth >>? lift $ drawMessage $ "Welcome. To play the tutorial levels, press '"++tbdg++"'." setMark False startMark interactLoop where interactLoop = do mainSt <- get let im = ms2im mainSt when (im == IMPlay) checkWon when (im == IMMeta) $ (checkAsync >>) $ void.runMaybeT $ mourNameSelected >>? lift purgeInvalidUndecls drawMainState cmds <- lift $ getSomeInput im runExceptT (mapM_ (processCommand im) cmds) >>= either ((lift (drawMessage "") >>) . return) (const interactLoop) -- | unblock input whenever the newAsync TVar is set to True spawnUnblockerThread = do flag <- gets newAsync unblock <- lift unblockInput liftIO $ forkIO $ forever $ do atomically $ readTVar flag >>= check >> writeTVar flag False unblock runSubMainState :: UIMonad uiM => MainState -> MainStateT uiM (InteractSuccess,MainState) runSubMainState mSt = lift (runStateT interactUI mSt) <* cleanOnPop where cleanOnPop = do im <- gets ms2im lift $ onNewMode im when (im == IMEdit) setSelectedPosFromMouse execSubMainState :: UIMonad uiM => MainState -> MainStateT uiM MainState execSubMainState = (snd <$>) . runSubMainState getSomeInput im = do cmds <- getInput im if null cmds then getSomeInput im else return cmds processCommand :: UIMonad uiM => InputMode -> Command -> ExceptT InteractSuccess (MainStateT uiM) () processCommand im CmdQuit = do case im of IMReplay -> throwE $ InteractSuccess False IMPlay -> lift (or <$> sequence [gets psIsSub, gets psSaved, null <$> gets psGameStateMoveStack]) >>? throwE $ InteractSuccess False IMEdit -> lift editStateUnsaved >>! throwE $ InteractSuccess True _ -> return () title <- lift $ getTitle (lift . lift . confirm) ("Really quit" ++ (if im == IMEdit then " without saving" else "") ++ maybe "" (" from "++) title ++ "?") >>? throwE $ InteractSuccess False processCommand im CmdForceQuit = throwE $ InteractSuccess False processCommand IMPlay CmdOpen = do st <- gets psCurrentState frame <- gets psFrame if checkSolved (frame,st) then throwE $ InteractSuccess True else lift.lift $ drawError "Locked!" processCommand im cmd = lift $ processCommand' im cmd processCommand' :: UIMonad uiM => InputMode -> Command -> MainStateT uiM () processCommand' im CmdHelp = lift $ do helpPages <- case im of IMMeta -> return [HelpPageInput, HelpPageGame] IMEdit -> do first <- not <$> liftIO hasLocks return $ [HelpPageInput] ++ if first then [HelpPageFirstEdit] else [] _ -> return [HelpPageInput] let showPage p = withNoBG $ showHelp im p >>? do void $ textInput "[press a key or RMB]" 1 False True Nothing Nothing sequence_ $ map showPage helpPages processCommand' im (CmdBind mcmd)= lift $ (>> endPrompt) $ runMaybeT $ do cmd <- liftMaybe mcmd `mplus` do lift $ drawPrompt False "Command to bind: " msum $ repeat $ do cmd <- MaybeT $ listToMaybe <$> getInput im guard $ not.null $ describeCommand cmd return cmd lift $ drawPrompt False ("key to bind to \"" ++ describeCommand cmd ++ "\" (repeat existing user binding to delete): ") ch <- MaybeT getChRaw guard $ ch /= '\ESC' lift $ setUIBinding im cmd ch processCommand' _ CmdToggleColourMode = lift toggleColourMode processCommand' _ CmdSuspend = lift suspend processCommand' _ CmdRedraw = lift redraw processCommand' im CmdClear = do lift $ drawMessage "" when (im == IMMeta) $ modify $ \ms -> ms { retiredLocks = Nothing } processCommand' im CmdMark = void.runMaybeT $ do guard $ im `elem` [IMEdit, IMPlay, IMReplay] str <- MaybeT $ lift $ textInput "Type character for mark: " 1 False True Nothing Nothing ch <- liftMaybe $ listToMaybe str guard $ ch `notElem` [startMark, '\''] lift $ setMark True ch processCommand' im CmdJumpMark = void.runMaybeT $ do guard $ im `elem` [IMEdit, IMPlay, IMReplay] marks <- lift marksSet str <- MaybeT $ lift $ textInput ("Jump to mark [" ++ intersperse ',' marks ++ "]: ") 1 False True (Just $ map (:[]) marks) Nothing ch <- liftMaybe $ listToMaybe str lift $ jumpMark ch processCommand' im CmdReset = jumpMark startMark processCommand' IMMeta (CmdSelCodename mname) = void.runMaybeT $ do mauth <- gets curAuth name <- msum [ liftMaybe $ mname , do newCodename <- (map toUpper <$>) $ MaybeT $ lift $ textInput "Select codename:" 3 False False Nothing Nothing guard $ length newCodename == 3 return newCodename ] guard $ validCodeName name lift $ do modify $ \ms -> ms { codenameStack = (name:codenameStack ms) } invalidateUInfo name refreshUInfoUI processCommand' IMMeta CmdHome = void.runMaybeT $ do ourName <- mgetOurName lift $ do modify $ \ms -> ms { codenameStack = (ourName:codenameStack ms) } refreshUInfoUI processCommand' IMMeta CmdBackCodename = do stack <- gets codenameStack when (length stack > 1) $ do modify $ \ms -> ms { codenameStack = tail stack } refreshUInfoUI processCommand' IMMeta CmdSetServer = void.runMaybeT $ do saddr <- gets curServer saddrs <- liftIO $ knownServers newSaddr' <- MaybeT $ ((>>= strToSaddr) <$>) $ lift $ textInput "Set server:" 256 False False (Just $ map saddrStr saddrs) (Just $ saddrStr saddr) let newSaddr = if nullSaddr newSaddr' then defaultServerAddr else newSaddr' modify $ \ms -> ms { curServer = newSaddr } msum [ void.MaybeT $ getFreshRecBlocking RecServerInfo , modify (\ms -> ms { curServer = saddr }) >> mzero ] lift $ do modify $ \ms -> ms {curAuth = Nothing} get >>= liftIO . writeServerSolns saddr (undecls,partials,_) <- liftIO (readServerSolns newSaddr) modify $ \ms -> ms { undeclareds=undecls, partialSolutions=partials } rnamestvar <- gets randomCodenames liftIO $ atomically $ writeTVar rnamestvar [] invalidateAllUInfo refreshUInfoUI processCommand' IMMeta CmdToggleCacheOnly = do newCOnly <- gets $ not . cacheOnly modify $ \ms -> ms {cacheOnly = newCOnly} unless newCOnly $ invalidateAllUInfo >> invalidateAllIndexedLocks processCommand' IMMeta (CmdRegister _) = void.runMaybeT $ do regName <- mgetCurName mauth <- gets curAuth let isUs = maybe False ((==regName).authUser) mauth if isUs then msum [ do confirmOrBail "Log out?" modify $ \ms -> ms {curAuth = Nothing} , do confirmOrBail "Reset password?" void.lift.runMaybeT $ do passwd <- inputPassword regName True "Enter new password:" lift $ do resp <- curServerAction $ ResetPassword passwd case resp of ServerAck -> do lift $ drawMessage "New password set." modify $ \ms -> ms {curAuth = Just $ Auth regName passwd} ServerError err -> lift $ drawError err _ -> lift $ drawMessage $ "Bad server response: " ++ show resp , do confirmOrBail "Configure email notifications?" setNotifications ] else msum [ do mgetUInfo regName lift.lift $ drawError "Sorry, this codename is already taken." , do confirmOrBail $ "Register codename " ++ regName ++ "?" passwd <- inputPassword regName True "Enter new password:" lift $ do modify $ \ms -> ms {curAuth = Just $ Auth regName passwd} resp <- curServerAction Register case resp of ServerAck -> do invalidateUInfo regName refreshUInfoUI conf <- lift $ confirm "Registered! Would you like to be notified by email when someone solves your lock?" if conf then void $ runMaybeT setNotifications else lift $ drawMessage "Notifications disabled." ServerError err -> do lift $ drawError err modify $ \ms -> ms {curAuth = Nothing} _ -> lift $ drawMessage $ "Bad server response: " ++ show resp ] where setNotifications = do address <- MaybeT $ lift $ textInput "Enter address, or leave blank to disable notifications:" 128 False False Nothing Nothing lift $ do resp <- curServerAction $ SetEmail address case resp of ServerAck -> lift $ drawMessage $ if null address then "Notifications disabled." else "Address set." ServerError err -> lift $ drawError err _ -> lift $ drawMessage $ "Bad server response: " ++ show resp processCommand' IMMeta CmdAuth = void.runMaybeT $ do auth <- lift $ gets curAuth if isJust auth then do confirmOrBail "Log out?" modify $ \ms -> ms {curAuth = Nothing} else do name <- mgetCurName passwd <- inputPassword name False $ "Enter password for "++name++":" lift $ do modify $ \ms -> ms {curAuth = Just $ Auth name passwd} resp <- curServerAction $ Authenticate case resp of ServerAck -> lift $ drawMessage "Authenticated." ServerMessage msg -> lift $ drawMessage $ "Server: " ++ msg ServerError err -> do lift $ drawError err modify $ \ms -> ms {curAuth = auth} _ -> lift $ drawMessage $ "Bad server response: " ++ show resp refreshUInfoUI processCommand' IMMeta (CmdSolve midx) = void.runMaybeT $ do name <- mgetCurName uinfo <- mgetUInfo name idx <- msum [ liftMaybe midx , askLockIndex "Solve which lock?" "No lock to solve!" (\i -> isJust $ userLocks uinfo ! i) ] ls <- liftMaybe $ lockSpec <$> userLocks uinfo ! idx undecls <- lift (gets undeclareds) msum [ do undecl <- liftMaybe $ find (\(Undeclared _ ls' _) -> ls == ls') undecls MaybeT $ gets curAuth confirmOrBail "Declare existing solution?" void.lift.runMaybeT $ -- ignores MaybeT failures declare undecl , do RCLock lock <- MaybeT $ getFreshRecBlocking $ RecLock ls mpartial <- Map.lookup ls <$> gets partialSolutions soln <- solveLockSaving ls mpartial False lock $ Just $ "solving " ++ name ++ ":" ++ [lockIndexChar idx] ++ " (#" ++ show ls ++")" mourName <- lift $ (authUser <$>) <$> gets curAuth guard $ mourName /= Just name let undecl = Undeclared soln ls (ActiveLock name idx) msum [ do MaybeT $ gets curAuth confirmOrBail "Declare solution?" declare undecl , unless (any (\(Undeclared _ ls' _) -> ls == ls') undecls) $ modify $ \ms -> ms { undeclareds = (undecl : undeclareds ms) } ] ] processCommand' IMMeta (CmdPlayLockSpec mls) = void.runMaybeT $ do ls <- msum [ liftMaybe mls , do tls <- MaybeT . lift $ textInput "Lock number:" 16 False False Nothing Nothing liftMaybe $ readMay tls ] RCLock lock <- MaybeT $ getFreshRecBlocking $ RecLock ls solveLock lock $ Just $ "solving " ++ show ls processCommand' IMMeta (CmdDeclare mundecl) = void.runMaybeT $ do guard =<< mourNameSelected name <- mgetCurName undecls <- lift $ gets undeclareds guard $ not $ null undecls declare =<< msum [ liftMaybe mundecl , if length undecls == 1 then return $ head undecls else do which <- MaybeT $ lift $ textInput ("Declare which solution?") 5 False True Nothing Nothing liftMaybe $ msum [ do i <- readMay which guard $ 0 < i && i <= length undecls return $ undecls !! (i-1) , listToMaybe $ [ undecl | undecl@(Undeclared _ _ (ActiveLock name' i)) <- undecls , or [ take (length which) (name' ++ ":" ++ [lockIndexChar i]) == map toUpper which , name'==name && [lockIndexChar i] == which ] ] ] ] processCommand' IMMeta (CmdViewSolution mnote) = void.runMaybeT $ do note <- liftMaybe mnote `mplus` do ourName <- mgetOurName name <- mgetCurName uinfo <- mgetUInfo name noteses <- lift $ sequence [ case mlockinfo of Nothing -> return [] Just lockinfo -> (++lockSolutions lockinfo) <$> do ns <- getNotesReadOn lockinfo return $ if length ns < 3 then [] else ns | mlockinfo <- elems $ userLocks uinfo ] idx <- askLockIndex "View solution to which lock?" "No solutions to view" $ not.null.(noteses!!) let notes = noteses!!idx authors = map noteAuthor notes author <- if length notes == 1 then return $ noteAuthor $ head notes else (map toUpper <$>) $ MaybeT $ lift $ textInput ("View solution by which player? [" ++ intercalate "," (take 3 authors) ++ if length authors > 3 then ",...]" else "]") 3 False True (Just $ authors) Nothing liftMaybe $ find ((==author).noteAuthor) notes let ActiveLock name idx = noteOn note uinfo <- mgetUInfo name ls <- lockSpec <$> MaybeT (return $ userLocks uinfo ! idx) RCLock lock <- MaybeT $ getFreshRecBlocking $ RecLock ls RCSolution soln <- MaybeT $ getFreshRecBlocking $ RecNote note lift $ execSubMainState $ newReplayState (snd.reframe$lock) soln $ Just $ "viewing solution by " ++ noteAuthor note ++ " to " ++ name ++ [':',lockIndexChar idx] processCommand' IMMeta (CmdPlaceLock midx) = void.runMaybeT $ do guard =<< mourNameSelected ourName <- mgetOurName (lock,msoln) <- MaybeT (gets curLock) `mplus` do ebdg <- lift.lift $ getUIBinding IMMeta CmdEdit lift.lift $ drawError $ "No lock selected; '"++ebdg++"' to edit one." mzero lockpath <- lift $ gets curLockPath ourUInfo <- mgetUInfo ourName idx <- (liftMaybe midx `mplus`) $ askLockIndex ("Place " ++ show lockpath ++ " in which slot?") "bug" $ const True when (isJust $ userLocks ourUInfo ! idx) $ confirmOrBail "Really retire existing lock?" soln <- (liftMaybe msoln `mplus`) $ solveLock lock $ Just $ "testing lock" lift $ curServerActionAsyncThenInvalidate (SetLock lock idx soln) (Just (SomeCodenames [ourName])) processCommand' IMMeta CmdSelectLock = void.runMaybeT $ do lockdir <- liftIO $ confFilePath "locks" paths <- liftIO $ map (drop (length lockdir + 1)) <$> getDirContentsRec lockdir path <- MaybeT $ lift $ textInput "Lock name:" 1024 False False (Just paths) Nothing lift $ setLockPath path processCommand' IMMeta CmdNextLock = gets curLockPath >>= liftIO . nextLock True >>= setLockPath processCommand' IMMeta CmdPrevLock = gets curLockPath >>= liftIO . nextLock False >>= setLockPath processCommand' IMMeta CmdNextPage = modify $ \ms -> ms { listOffset = listOffset ms + 1 } processCommand' IMMeta CmdPrevPage = modify $ \ms -> ms { listOffset = max 0 $ listOffset ms - 1 } processCommand' IMMeta CmdEdit = void.runMaybeT $ do (lock, msoln) <- (MaybeT $ gets curLock) `mplus` do size <- msum [ do gets curServer RCServerInfo (ServerInfo size _) <- MaybeT $ getFreshRecBlocking RecServerInfo return size , do sizet <- MaybeT $ lift $ textInput ("Lock size: [3-" ++ show maxlocksize ++ "]") 2 False False Nothing Nothing size <- liftMaybe $ readMay sizet guard $ 3 <= size && size <= maxlocksize return size ] return (baseLock size, Nothing) not <$> liftIO hasLocks >>? do lift.lift $ withNoBG $ showHelp IMEdit HelpPageFirstEdit >>? do void $ textInput "[Press a key or RMB to continue; you can review this help later with '?']" 1 False True Nothing Nothing path <- lift $ gets curLockPath newPath <- MaybeT $ (esPath <$>) $ execSubMainState $ newEditState (reframe lock) msoln (if null path then Nothing else Just path) lift $ setLockPath newPath processCommand' IMMeta CmdTutorials = void.runMaybeT $ do tutdir <- liftIO $ getDataPath "tutorial" tuts <- liftIO $ (sort . map (takeWhile (/='.')) . filter (isSuffixOf ".lock")) <$> getDirectoryContents tutdir `catchIO` (const $ return []) when (null tuts) $ do lift.lift $ drawError "No tutorial levels found" mzero -- s <- MaybeT $ lift $ textInput ("Play which tutorial level? [1-"++show (length tuts)++"]") -- (length (show (length tuts))) False True Nothing Nothing -- i <- liftMaybe $ readMay s -- guard $ 1 <= i && i <= length tuts let dotut i msps = do let name = tuts !! (i-1) let pref = tutdir ++ [pathSeparator] ++ name (lock,_) <- MaybeT $ liftIO $ readLock (pref ++ ".lock") text <- liftIO $ (fromMaybe "" . listToMaybe) <$> (readStrings (pref ++ ".text") `catchIO` const (return [])) solveLockSaving i msps True lock $ Just $ "Tutorial " ++ show i ++ ": " ++ text if i+1 <= length tuts then do -- confirmOrBail $ "Tutorial level completed! Play next tutorial level (" ++ show (i+1) ++ ")?" dotut (i+1) Nothing else lift $ do modify $ \ms -> ms {tutProgress = (1,Nothing)} mauth <- gets curAuth cbdg <- lift $ getUIBinding IMMeta $ CmdSelCodename Nothing rbdg <- lift $ getUIBinding IMMeta (CmdRegister False) if isNothing mauth then do let showPage p prompt = lift $ withNoBG $ showHelp IMMeta p >>? do void $ textInput prompt 1 False True Nothing Nothing showPage (HelpPageInitiated 1) "[Tutorial complete! Press a key or RMB to continue]" showPage (HelpPageInitiated 2) "[Press a key or RMB to continue]" showPage (HelpPageInitiated 3) "[Press a key or RMB to continue]" --showPage HelpPageGame "[Press a key or RMB to continue; you can review this information later with '?']" lift $ drawMessage $ "To join the game: pick a codename ('"++cbdg++ "') and register it ('"++rbdg++"')." else lift $ drawMessage $ "Tutorial completed!" (onLevel,msps) <- lift $ gets tutProgress dotut onLevel msps processCommand' IMMeta CmdShowRetired = void.runMaybeT $ do name <- mgetCurName newRL <- lift (gets retiredLocks) >>= \rl -> case rl of Nothing -> do RCLockSpecs lss <- MaybeT $ getFreshRecBlocking $ RecRetiredLocks name if null lss then do lift.lift $ drawError "Player has no retired locks." return Nothing else return $ Just lss Just _ -> return Nothing lift $ modify $ \ms -> ms {retiredLocks = newRL} processCommand' IMPlay CmdUndo = do st <- gets psCurrentState stack <- gets psGameStateMoveStack ustms <- gets psUndoneStack unless (null stack) $ do let (st',pm) = head stack modify $ \ps -> ps {psCurrentState=st', psGameStateMoveStack = tail stack, psLastAlerts = [], psUndoneStack = (st,pm):ustms} processCommand' IMPlay CmdRedo = do ustms <- gets psUndoneStack case ustms of [] -> return () ustm@(_,pm):ustms' -> do st <- gets psCurrentState (st',alerts) <- lift $ doPhysicsTick pm st pushPState (st',pm) modify $ \ps -> ps {psLastAlerts = alerts, psUndoneStack = ustms'} processCommand' IMPlay (CmdManipulateToolAt pos) = do board <- stateBoard <$> gets psCurrentState wsel <- gets wrenchSelected void.runMaybeT $ msum $ [ do tile <- liftMaybe $ snd <$> Map.lookup pos board guard $ case tile of {WrenchTile _ -> True; HookTile -> True; _ -> False} lift $ processCommand' IMPlay $ CmdTile tile ] ++ [ do tile <- liftMaybe $ snd <$> Map.lookup (d+^pos) board guard $ tileType tile == if wsel then WrenchTile zero else HookTile lift $ processCommand' IMPlay $ CmdDir WHSSelected $ neg d | d <- hexDirs ] processCommand' IMPlay (CmdDrag pos dir) = do board <- stateBoard <$> gets psCurrentState wsel <- gets wrenchSelected void.runMaybeT $ do tp <- liftMaybe $ tileType . snd <$> Map.lookup pos board msum [ guard $ tp == HookTile , do guard $ tp == WrenchTile zero board' <- lift $ stateBoard . fst . runWriter . physicsTick (WrenchPush dir) <$> gets psCurrentState msum $ [ do tp' <- liftMaybe $ tileType . snd <$> Map.lookup pos' board' guard $ tp' == WrenchTile zero | d <- [0,1,2] , let pos' = d *^ dir +^ pos ] ++ [ (lift.lift $ warpPointer pos) >> mzero ] ] lift $ processCommand' IMPlay $ CmdDir WHSSelected $ dir board' <- stateBoard <$> gets psCurrentState msum [ do tp' <- liftMaybe $ tileType . snd <$> Map.lookup pos' board' guard $ tp' == if wsel then WrenchTile zero else HookTile lift.lift $ warpPointer pos' | pos' <- map (+^pos) $ hexDisc 2 ] processCommand' IMPlay cmd = do wsel <- gets wrenchSelected st <- gets psCurrentState let push whs dir | whs == WHSWrench || (whs == WHSSelected && wsel) = Just $ WrenchPush dir | otherwise = Just $ HookPush dir torque whs dir {- | whs == WHSHook || (whs == WHSSelected && not wsel)= Just $ HookTorque dir | otherwise = Nothing -} = Just $ HookTorque dir (wsel', pm) = case cmd of CmdTile (WrenchTile _) -> (True, Nothing) CmdTile HookTile -> (False, Nothing) CmdTile (ArmTile _ _) -> (False, Nothing) CmdToggle -> (not wsel, Nothing) CmdDir whs dir -> (wsel, push whs dir) CmdRotate whs dir -> (wsel, torque whs dir) CmdWait -> (wsel, Just NullPM) CmdSelect -> (wsel, Just NullPM) _ -> (wsel, Nothing) modify $ \ps -> ps {wrenchSelected = wsel'} case pm of Nothing -> return () Just pm' -> do (st',alerts) <- lift $ doPhysicsTick pm' st modify $ \ps -> ps {psLastAlerts = alerts} pushPState (st',pm') processCommand' IMReplay (CmdReplayBack 1) = void.runMaybeT $ do (st',pm) <- MaybeT $ listToMaybe <$> gets rsGameStateMoveStack lift $ modify $ \rs -> rs {rsCurrentState=st' , rsLastAlerts = [] , rsGameStateMoveStack = tail $ rsGameStateMoveStack rs , rsMoveStack = pm:rsMoveStack rs} processCommand' IMReplay (CmdReplayBack n) = replicateM_ n $ processCommand' IMReplay (CmdReplayBack 1) processCommand' IMReplay (CmdReplayForward 1) = void.runMaybeT $ do pm <- MaybeT $ listToMaybe <$> gets rsMoveStack lift $ do st <- gets rsCurrentState (st',alerts) <- lift $ doPhysicsTick pm st modify $ \rs -> rs {rsCurrentState = st' , rsLastAlerts = alerts , rsGameStateMoveStack = (st,pm):rsGameStateMoveStack rs , rsMoveStack = tail $ rsMoveStack rs} processCommand' IMReplay (CmdReplayForward n) = replicateM_ n $ processCommand' IMReplay (CmdReplayForward 1) processCommand' IMReplay CmdUndo = processCommand' IMReplay (CmdReplayBack 1) processCommand' IMReplay CmdRedo = processCommand' IMReplay (CmdReplayForward 1) processCommand' IMEdit CmdPlay = do st <- gets esGameState frame <- gets esFrame modify $ \es -> es {selectedPiece = Nothing} subPlay (frame,st) processCommand' IMEdit CmdTest = do frame <- gets esFrame modifyEState (\st -> snd $ canonify (frame, st)) modify $ \es -> es {selectedPiece = Nothing} mpath <- gets esPath st <- gets esGameState void.runMaybeT $ do soln <- solveLock (frame,st) $ Just $ "testing " ++ fromMaybe "[unnamed lock]" mpath lift $ modify $ \es -> es { esTested = Just (st, soln) } processCommand' IMEdit CmdUndo = do st <- gets esGameState sts <- gets esGameStateStack usts <- gets esUndoneStack unless (null sts) $ modify $ \es -> es {esGameState = head sts, esGameStateStack = tail sts, esUndoneStack = st:usts} processCommand' IMEdit CmdRedo = do usts <- gets esUndoneStack case usts of [] -> return () ust:usts' -> do pushEState ust modify $ \es -> es {esUndoneStack = usts'} processCommand' IMEdit CmdUnselect = modify $ \es -> es {selectedPiece = Nothing} processCommand' IMEdit CmdSelect = do selPiece <- gets selectedPiece selPos <- gets selectedPos st <- gets esGameState let selPiece' = if isJust selPiece then Nothing else liftM fst $ Map.lookup selPos $ stateBoard st modify $ \es -> es {selectedPiece = selPiece'} processCommand' IMEdit (CmdDir _ dir) = do selPos <- gets selectedPos selPiece <- gets selectedPiece frame <- gets esFrame case selPiece of Nothing -> modify $ \es -> es {selectedPos = checkEditable frame selPos $ dir +^ selPos} Just p -> doForce $ Push p dir processCommand' IMEdit (CmdMoveTo newPos) = setSelectedPos newPos processCommand' IMEdit (CmdDrag pos dir) = do board <- stateBoard <$> gets esGameState void.runMaybeT $ do selIdx <- MaybeT $ gets selectedPiece idx <- liftMaybe $ fst <$> Map.lookup pos board guard $ idx == selIdx lift $ processCommand' IMEdit $ CmdDir WHSSelected $ dir board' <- stateBoard <$> gets esGameState msum [ do idx' <- liftMaybe $ fst <$> Map.lookup pos' board' guard $ idx' == selIdx lift.lift $ warpPointer $ pos' | pos' <- [dir+^pos, pos] ] processCommand' IMEdit (CmdRotate _ dir) = do selPiece <- gets selectedPiece case selPiece of Nothing -> return () Just p -> doForce $ Torque p dir processCommand' IMEdit (CmdTile tile) = do selPos <- gets selectedPos drawTile selPos (Just tile) False processCommand' IMEdit (CmdPaint tile) = do selPos <- gets selectedPos drawTile selPos tile True processCommand' IMEdit (CmdPaintFromTo tile from to) = do frame <- gets esFrame paintTilePath frame tile (truncateToEditable frame from) (truncateToEditable frame to) processCommand' IMEdit CmdMerge = do selPos <- gets selectedPos st <- gets esGameState lift $ drawMessage "Merge in which direction?" let getDir = do cmd <- lift $ head <$> getSomeInput IMEdit case cmd of CmdDir _ mergeDir -> return $ Just mergeDir CmdDrag _ mergeDir -> return $ Just mergeDir CmdMoveTo _ -> getDir _ -> return $ Nothing mergeDir <- getDir case mergeDir of Just mergeDir -> modifyEState $ mergeTiles selPos mergeDir True _ -> return () -- XXX: merging might invalidate selectedPiece modify $ \es -> es {selectedPiece = Nothing} lift $ drawMessage "" processCommand' IMEdit CmdWait = do st <- gets esGameState (st',_) <- lift $ doPhysicsTick NullPM st pushEState st' processCommand' IMEdit CmdDelete = do selPos <- gets selectedPos selPiece <- gets selectedPiece st <- gets esGameState case selPiece of Nothing -> drawTile selPos Nothing False Just p -> do modify $ \es -> es {selectedPiece = Nothing} modifyEState $ delPiece p processCommand' IMEdit CmdWriteState = void.runMaybeT $ do path <- lift $ gets esPath newPath <- MaybeT $ lift $ textInput "Save lock as:" 1024 False False Nothing path guard $ not $ null newPath fullPath <- liftIO $ fullLockPath newPath liftIO (doesFileExist fullPath `catchIO` const (return True)) >>? confirmOrBail $ "Really overwrite '"++fullPath++"'?" lift $ do st <- gets esGameState frame <- gets esFrame msoln <- getCurTestSoln merr <- liftIO $ ((writeAsciiLockFile fullPath msoln $ canonify (frame, st)) >> return Nothing) `catchIO` (return . Just . show) modify $ \es -> es {lastSavedState = Just (st,isJust msoln)} case merr of Nothing -> modify $ \es -> es {esPath = Just newPath} Just err -> lift $ drawError $ "Write failed: "++err processCommand' _ _ = return () inputPassword :: UIMonad uiM => Codename -> Bool -> String -> MaybeT (MainStateT uiM) String inputPassword name confirm prompt = do pw <- MaybeT $ lift $ textInput prompt 64 True False Nothing Nothing guard $ not $ null pw when confirm $ do pw' <- MaybeT $ lift $ textInput "Confirm password:" 64 True False Nothing Nothing when (pw /= pw') $ do lift.lift $ drawError "Passwords don't match!" mzero RCPublicKey publicKey <- MaybeT $ getFreshRecBlocking RecPublicKey encryptPassword publicKey name pw -- | Salt and encrypt a password, to protect users' passwords from sniffing -- and dictionary attack. We can hope that they wouldn't use valuable -- passwords, but we shouldn't assume it. -- Note that in all other respects, the protocol is entirely insecure - -- nothing else is encrypted, and anyone sniffing an encrypted password can -- replay it to authenticate as the user. encryptPassword :: UIMonad uiM => PublicKey -> String -> String -> MaybeT (MainStateT uiM) String encryptPassword publicKey name password = msum [ MaybeT . liftIO . handle (\(e :: SomeException) -> return Nothing) $ do g <- newGenIO :: IO SystemRandom return . Just . CS.unpack . BL.toStrict . fst . encrypt g publicKey . BL.fromStrict . CS.pack $ hashed , confirmOrBail "Failed to encrypt password - send unencrypted?" >> return hashed ] where hashed = hash $ "IY" ++ name ++ password setSelectedPosFromMouse :: UIMonad uiM => MainStateT uiM () setSelectedPosFromMouse = lift getUIMousePos >>= maybe (return ()) setSelectedPos setSelectedPos :: Monad m => HexPos -> MainStateT m () setSelectedPos pos = do frame <- gets esFrame modify $ \es -> es {selectedPos = truncateToEditable frame pos} subPlay :: UIMonad uiM => Lock -> MainStateT uiM () subPlay lock = pushEState =<< psCurrentState <$> (execSubMainState $ newPlayState lock Nothing False True False) solveLock,solveLockTut :: UIMonad uiM => Lock -> Maybe String -> MaybeT (MainStateT uiM) Solution solveLock = solveLock' False solveLockTut = solveLock' True solveLock' isTut lock title = do (InteractSuccess solved, ps) <- lift $ runSubMainState $ newPlayState (reframe lock) title isTut False False guard $ solved return $ reverse $ (map snd) $ psGameStateMoveStack ps solveLockSaving :: UIMonad uiM => LockSpec -> Maybe SavedPlayState -> Bool -> Lock -> Maybe String -> MaybeT (MainStateT uiM) Solution solveLockSaving ls msps isTut lock title = do (InteractSuccess solved, ps) <- lift $ runSubMainState $ ((maybe newPlayState restorePlayState) msps) (reframe lock) title isTut False True if solved then do unless isTut $ lift $ modify $ \ms -> ms { partialSolutions = Map.delete ls $ partialSolutions ms } return $ reverse $ (map snd) $ psGameStateMoveStack ps else do lift $ modify $ \ms -> if isTut then ms { tutProgress = (ls,Just $ savePlayState ps) } else ms { partialSolutions = Map.insert ls (savePlayState ps) $ partialSolutions ms } mzero