Interact.hs

   1 -- This file is part of Intricacy
   2 -- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 {-# LANGUAGE LambdaCase          #-}
  12 {-# LANGUAGE ScopedTypeVariables #-}
  13
  14 module Interact (interactUI) where
  15
  16 import           Control.Applicative
  17 import           Control.Concurrent
  18 import           Control.Concurrent.STM
  19 import           Control.Monad
  20 import           Control.Monad.Catch
  21 import           Control.Monad.State
  22 import           Control.Monad.Trans.Except
  23 import           Control.Monad.Trans.Maybe
  24 import           Control.Monad.Writer
  25 import           Data.Array
  26 import qualified Data.ByteString.Char8      as CS
  27 import qualified Data.ByteString.Lazy       as BL
  28 import           Data.Char
  29 import           Data.Function              (on)
  30 import           Data.List
  31 import           Data.Map                   (Map)
  32 import qualified Data.Map                   as Map
  33 import           Data.Maybe
  34 import qualified Data.Vector                as Vector
  35 import           Safe                       (readMay)
  36 import           System.Directory
  37 import           System.FilePath
  38
  39 import           Crypto.Hash.Algorithms     (SHA256 (..))
  40 import           Crypto.PubKey.RSA.OAEP     (defaultOAEPParams, encrypt)
  41 import           Crypto.PubKey.RSA.Types    (PublicKey)
  42
  43 import           AsciiLock
  44 import           Cache
  45 import           Command
  46 import           Database
  47 import           EditGameState
  48 import           Frame
  49 import           GameState
  50 import           GameStateTypes
  51 import           Hex
  52 import           InputMode
  53 import           InteractUtil
  54 import           Lock
  55 import           MainState
  56 import           Maxlocksize
  57 import           Metagame
  58 import           Mundanities
  59 import           Physics
  60 import           Protocol
  61 import           ServerAddr
  62 import           Util
  63
  64 newtype InteractSuccess = InteractSuccess Bool
  65
  66 interactUI :: UIMonad uiM => MainStateT uiM InteractSuccess
  67 interactUI = (fromMaybe (InteractSuccess False) <$>) . runMaybeT $ do
  68     gets initiationRequired >>? lift doInitiation
  69     gets initiationRequired >>? mzero
  70     lift $ do
  71         im <- gets ms2im
  72         lift $ onNewMode im
  73         when (im == IMEdit) setSelectedPosFromMouse
  74         when (im == IMMeta) $ do
  75             spawnUnblockerThread
  76
  77             -- draw before testing auth, lest a timeout mean a blank screen
  78             drawMainState
  79
  80             testAuth
  81             refreshUInfoUI
  82         setMark False startMark
  83         interactLoop
  84
  85     where
  86         initiationRequired s = ms2im s == IMMeta && not (initiated s)
  87         interactLoop = do
  88             im <- gets ms2im
  89             when (im == IMPlay) checkWon
  90             when (im == IMMeta) $ (checkAsync >>) $ void.runMaybeT $
  91                 mourNameSelected >>? lift purgeInvalidUndecls
  92             drawMainState
  93             cmds <- lift $ getSomeInput im
  94             runExceptT (mapM_ (processCommand im) cmds) >>=
  95                 either
  96                     ((lift clearMessage >>) . return)
  97                     (const interactLoop)
  98
  99         -- | unblock input whenever the newAsync TVar is set to True
 100         spawnUnblockerThread = do
 101             flag <- gets newAsync
 102             unblock <- lift unblockInput
 103             liftIO $ forkIO $ forever $ do
 104                 atomically $ readTVar flag >>= check >> writeTVar flag False
 105                 unblock
 106
 107 runSubMainState :: UIMonad uiM => MainState -> MainStateT uiM (InteractSuccess,MainState)
 108 runSubMainState mSt = lift (runStateT interactUI mSt) <* cleanOnPop
 109     where cleanOnPop = do
 110             im <- gets ms2im
 111             lift $ onNewMode im
 112             when (im == IMEdit) setSelectedPosFromMouse
 113
 114 execSubMainState :: UIMonad uiM => MainState -> MainStateT uiM MainState
 115 execSubMainState = (snd <$>) . runSubMainState
 116
 117 doInitiation :: UIMonad uiM => MainStateT uiM ()
 118 doInitiation = do
 119     (InteractSuccess complete, s) <- runSubMainState =<< liftIO initInitState
 120     liftIO $ writeInitState s
 121     when complete $ do
 122         modify $ \s -> s {initiated = True}
 123         mauth <- gets curAuth
 124         when (isNothing mauth) $ do
 125             cbdg <- lift $ getUIBinding IMMeta $ CmdSelCodename Nothing
 126             rbdg <- lift $ getUIBinding IMMeta (CmdRegister False)
 127             let showPage p prompt = lift $ withNoBG $ showHelp IMMeta p >>? do
 128                     void $ textInput prompt 1 False True Nothing Nothing
 129             showPage (HelpPageInitiated 1) "[Initiation complete. Press a key or RMB to continue]"
 130             showPage (HelpPageInitiated 2) "[Press a key or RMB to continue]"
 131             showPage (HelpPageInitiated 3) "[Press a key or RMB to continue]"
 132             lift $ drawMessage $
 133                 "To join the game: pick a codename ('"++cbdg++
 134                 "') and register it ('"++rbdg++"')."
 135
 136 getSomeInput im = do
 137     cmds <- getInput im
 138     if null cmds then getSomeInput im else return cmds
 139
 140 processCommand :: UIMonad uiM => InputMode -> Command -> ExceptT InteractSuccess (MainStateT uiM) ()
 141 processCommand im CmdQuit = do
 142     case im of
 143         IMPlay -> lift (or <$> sequence [gets psIsSub, gets psSaved, gets (null . psGameStateMoveStack)])
 144             >>? throwE $ InteractSuccess False
 145         IMEdit -> lift editStateUnsaved >>! throwE $ InteractSuccess True
 146         _ -> throwE $ InteractSuccess False
 147     title <- lift getTitle
 148     (lift . lift . confirm) ("Really quit"
 149             ++ (if im == IMEdit then " without saving" else "")
 150             ++ maybe "" ((" from "++) . fst) title ++ "?")
 151         >>? throwE $ InteractSuccess False
 152 processCommand im CmdForceQuit = throwE $ InteractSuccess False
 153 processCommand IMPlay CmdOpen = do
 154     st <- gets psCurrentState
 155     frame <- gets psFrame
 156     if checkSolved (frame,st)
 157         then throwE $ InteractSuccess True
 158         else lift.lift $ drawError "Locked!"
 159
 160 processCommand IMInit (CmdSolveInit Nothing) = void.runMaybeT $ do
 161     tutSolved <- lift . gets $ tutSolved . tutProgress
 162     accessible <- lift . gets $ accessibleInitLocks tutSolved . initLocks
 163     v <- if Map.null accessible then return zero else do
 164         let nameMap = Map.fromList $ ("TUT",zero) :
 165                 [(initLockName l, v) | (v,l) <- Map.toList accessible]
 166             names = Map.keys nameMap
 167         name <- (map toUpper <$>) . MaybeT . lift . lift $
 168             textInput ("Solve which? ["
 169                 ++ intercalate "," (take 3 names)
 170                 ++ if length names > 3 then ",...]" else "]")
 171             3 False True (Just names) Nothing
 172         MaybeT . return $ Map.lookup name nameMap
 173     lift . processCommand IMInit . CmdSolveInit $ Just v
 174 processCommand IMInit (CmdSolveInit (Just v)) | v == zero = lift.void.runMaybeT $ do
 175     tutdir <- liftIO $ getDataPath "tutorial"
 176     tuts <- liftIO . ignoreIOErr $
 177         sort . map (takeWhile (/='.')) . filter (isSuffixOf ".lock") <$>
 178             getDirectoryContents tutdir
 179     when (null tuts) $ do
 180         lift.lift $ drawError "No tutorial levels found"
 181         mzero
 182     let dotut i msps = do
 183             let name = tuts !! (i-1)
 184             let pref = tutdir ++ [pathSeparator] ++ name
 185             (lock,_) <- MaybeT $ liftIO $ readLock (pref ++ ".lock")
 186             text <- liftIO $ fromMaybe "" . listToMaybe <$> readStrings (pref ++ ".text")
 187             solveLockSaving i msps (Just i) lock $ Just $ "Tutorial " ++ show i ++ ": " ++ text
 188             if i+1 <= length tuts
 189                 then dotut (i+1) Nothing
 190                 else lift $ do
 191                     modify $ \is -> is {tutProgress = TutProgress True 1 Nothing}
 192                     lift $ drawMessage "Tutorial complete!"
 193     TutProgress _ onLevel msps <- lift $ gets tutProgress
 194     dotut onLevel msps
 195 processCommand IMInit (CmdSolveInit (Just v)) = void.runMaybeT $ do
 196     l@InitLock { initLockDesc=desc, initLockLock=lock, initLockPartial=partial } <-
 197         MaybeT . lift $ gets (Map.lookup v . initLocks)
 198     lift $ do
 199         (InteractSuccess solved, ps) <- lift . runSubMainState $
 200             maybe newPlayState restorePlayState partial (reframe lock) [] (Just desc) Nothing False True
 201         let updateLock initLock = initLock { initLockSolved = initLockSolved initLock || solved
 202                 , initLockPartial = Just $ savePlayState ps }
 203         lift . modify $ \is -> is { initLocks = Map.adjust updateLock v $ initLocks is }
 204         when (solved && isLastInitLock l) . throwE $ InteractSuccess True
 205
 206 processCommand im cmd = lift $ processCommand' im cmd
 207
 208 processCommand' :: UIMonad uiM => InputMode -> Command -> MainStateT uiM ()
 209 processCommand' im CmdHelp = lift $ do
 210     helpPages <- case im of
 211         IMInit -> return [HelpPageGame]
 212         IMMeta -> return [HelpPageInput, HelpPageGame]
 213         IMEdit -> do
 214             first <- not <$> liftIO hasLocks
 215             return $ HelpPageInput : [HelpPageFirstEdit | first]
 216         _ -> return [HelpPageInput]
 217     let showPage p = withNoBG $ showHelp im p >>? do
 218             void $ textInput "[press a key or RMB]" 1 False True Nothing Nothing
 219     mapM_ showPage helpPages
 220 processCommand' im (CmdBind mcmd)= lift $ (>> endPrompt) $ runMaybeT $ do
 221     cmd <- liftMaybe mcmd `mplus` do
 222         lift $ drawPrompt False "Command to bind: "
 223         msum $ repeat $ do
 224             cmd <- MaybeT $ listToMaybe <$> getInput im
 225             guard $ not.null $ describeCommand cmd
 226             return cmd
 227     lift $ drawPrompt False ("key to bind to \"" ++ describeCommand cmd ++ "\" (repeat existing user binding to delete): ")
 228     ch <- MaybeT getChRaw
 229     guard $ ch /= '\ESC'
 230     lift $ setUIBinding im cmd ch
 231 processCommand' _ CmdToggleColourMode = lift toggleColourMode
 232 processCommand' _ CmdSuspend = lift suspend
 233 processCommand' _ CmdRedraw = lift redraw
 234 processCommand' im CmdClear = do
 235     lift clearMessage
 236     when (im == IMMeta) $ modify $ \ms -> ms { retiredLocks = Nothing }
 237 processCommand' im CmdMark = void.runMaybeT $ do
 238     guard $ im `elem` [IMEdit, IMPlay, IMReplay]
 239     str <- MaybeT $ lift $ textInput "Type character for mark: "
 240         1 False True Nothing Nothing
 241     ch <- liftMaybe $ listToMaybe str
 242     guard $ ch `notElem` [startMark, '\'']
 243     lift $ setMark True ch
 244 processCommand' im CmdJumpMark = void.runMaybeT $ do
 245     guard $ im `elem` [IMEdit, IMPlay, IMReplay]
 246     marks <- lift marksSet
 247     str <- MaybeT $ lift $ textInput
 248         ("Jump to mark [" ++ intersperse ',' marks ++ "]: ")
 249             1 False True (Just $ (:[]) <$> marks) Nothing
 250     ch <- liftMaybe $ listToMaybe str
 251     lift $ jumpMark ch
 252 processCommand' im CmdReset = jumpMark startMark
 253
 254 processCommand' IMMeta CmdInitiation = doInitiation
 255 processCommand' IMMeta (CmdSelCodename mname) = void.runMaybeT $ do
 256     mauth <- gets curAuth
 257     name <- msum [ liftMaybe mname
 258         , do
 259             newCodename <- (map toUpper <$>) $ MaybeT $ lift $
 260                 textInput "Select codename:"
 261                     3 False False Nothing Nothing
 262             guard $ length newCodename == 3
 263             return newCodename
 264         ]
 265     guard $ validCodeName name
 266     lift $ do
 267         modify $ \ms -> ms { codenameStack = name:codenameStack ms }
 268         invalidateUInfo name
 269         refreshUInfoUI
 270 processCommand' IMMeta CmdHome = void.runMaybeT $ do
 271     ourName <- mgetOurName
 272     lift $ do
 273         modify $ \ms -> ms { codenameStack = ourName:codenameStack ms }
 274         refreshUInfoUI
 275 processCommand' IMMeta CmdBackCodename = do
 276     stack <- gets codenameStack
 277     when (length stack > 1) $ do
 278         modify $ \ms -> ms { codenameStack = tail stack }
 279         refreshUInfoUI
 280 processCommand' IMMeta CmdSetServer = void.runMaybeT $ do
 281     saddr <- gets curServer
 282     saddrs <- liftIO knownServers
 283     newSaddr' <- MaybeT $ ((>>= strToSaddr) <$>) $
 284         lift $ textInput "Set server:" 256 False False
 285             (Just $ saddrStr <$> saddrs) (Just $ saddrStr saddr)
 286     let newSaddr = if nullSaddr newSaddr' then defaultServerAddr else newSaddr'
 287     modify $ \ms -> ms { curServer = newSaddr }
 288     msum [ void.MaybeT $ getFreshRecBlocking RecServerInfo
 289         , modify (\ms -> ms { curServer = saddr }) >> mzero ]
 290     lift $ do
 291         modify $ \ms -> ms {curAuth = Nothing}
 292         get >>= liftIO . writeServerSolns saddr
 293         (undecls,partials) <- liftIO (readServerSolns newSaddr)
 294         modify $ \ms -> ms { undeclareds=undecls, partialSolutions=partials }
 295         rnamestvar <- gets randomCodenames
 296         liftIO $ atomically $ writeTVar rnamestvar []
 297         invalidateAllUInfo
 298         refreshUInfoUI
 299 processCommand' IMMeta CmdToggleCacheOnly = do
 300     newCOnly <- gets $ not . cacheOnly
 301     modify $ \ms -> ms {cacheOnly = newCOnly}
 302     unless newCOnly $
 303         invalidateAllUInfo >> invalidateAllIndexedLocks
 304
 305 processCommand' IMMeta (CmdRegister _) = void.runMaybeT $ do
 306     regName <- mgetCurName
 307     mauth <- gets curAuth
 308     let isUs = maybe False ((==regName).authUser) mauth
 309     if isUs
 310         then msum [ do
 311                 confirmOrBail "Log out?"
 312                 modify $ \ms -> ms {curAuth = Nothing}
 313             , do
 314                 confirmOrBail "Reset password?"
 315                 void.lift.runMaybeT $ do
 316                     passwd <- inputPassword regName True "Enter new password:"
 317                     lift $ do
 318                         resp <- curServerAction $ ResetPassword passwd
 319                         case resp of
 320                             ServerAck -> do
 321                                 lift $ drawMessage "New password set."
 322                                 modify $ \ms -> ms {curAuth = Just $ Auth regName passwd}
 323                             ServerError err -> lift $ drawError err
 324                             _ -> lift $ drawMessage $ "Bad server response: " ++ show resp
 325             , do
 326                 confirmOrBail "Configure email notifications?"
 327                 setNotifications
 328             ]
 329         else msum [ do
 330                 mgetUInfo regName
 331                 lift.lift $ drawError "Sorry, this codename is already taken."
 332             , do
 333                 confirmOrBail $ "Register codename " ++ regName ++ "?"
 334                 passwd <- inputPassword regName True "Enter new password:"
 335                 lift $ do
 336                     modify $ \ms -> ms {curAuth = Just $ Auth regName passwd}
 337                     resp <- curServerAction Register
 338                     case resp of
 339                         ServerAck -> do
 340                             invalidateUInfo regName
 341                             refreshUInfoUI
 342                             conf <- lift $ confirm "Registered! Would you like to be notified by email when someone solves your lock?"
 343                             if conf then void $ runMaybeT setNotifications else lift $ drawMessage "Notifications disabled."
 344                         ServerError err -> do
 345                             lift $ drawError err
 346                             modify $ \ms -> ms {curAuth = Nothing}
 347                         _ -> lift $ drawMessage $ "Bad server response: " ++ show resp
 348             ]
 349
 350     where setNotifications = do
 351             address <- MaybeT $ lift $ textInput "Enter address, or leave blank to disable notifications:" 128 False False Nothing Nothing
 352             lift $ do
 353                 resp <- curServerAction $ SetEmail address
 354                 case resp of
 355                     ServerAck -> lift $ drawMessage $ if null address then "Notifications disabled." else "Address set."
 356                     ServerError err -> lift $ drawError err
 357                     _ -> lift $ drawMessage $ "Bad server response: " ++ show resp
 358
 359
 360 processCommand' IMMeta CmdAuth = void.runMaybeT $ do
 361     auth <- lift $ gets curAuth
 362     if isJust auth then do
 363         confirmOrBail "Log out?"
 364         modify $ \ms -> ms {curAuth = Nothing}
 365     else do
 366         name <- mgetCurName
 367         passwd <- inputPassword name False $ "Enter password for "++name++":"
 368         lift $ do
 369             modify $ \ms -> ms {curAuth = Just $ Auth name passwd}
 370             resp <- curServerAction Authenticate
 371             case resp of
 372                 ServerAck -> lift $ drawMessage "Authenticated."
 373                 ServerMessage msg -> lift $ drawMessage $ "Server: " ++ msg
 374                 ServerError err -> do
 375                     lift $ drawError err
 376                     modify $ \ms -> ms {curAuth = auth}
 377                 _ -> lift $ drawMessage $ "Bad server response: " ++ show resp
 378             refreshUInfoUI
 379 processCommand' IMMeta (CmdSolve midx) = void.runMaybeT $ do
 380     name <- mgetCurName
 381     uinfo <- mgetUInfo name
 382     idx <- msum [ liftMaybe midx
 383         , askLockIndex "Solve which lock?" "No lock to solve!" (\i -> isJust $ userLocks uinfo ! i) ]
 384     ls <- liftMaybe $ lockSpec <$> userLocks uinfo ! idx
 385     undecls <- lift (gets undeclareds)
 386     msum [ do
 387             undecl <- liftMaybe $ find (\(Undeclared _ ls' _) -> ls == ls') undecls
 388             MaybeT $ gets curAuth
 389             confirmOrBail "Declare existing solution?"
 390             void.lift.runMaybeT $ -- ignores MaybeT failures
 391                 declare undecl
 392         , do
 393             RCLock lock <- MaybeT $ getFreshRecBlocking $ RecLock ls
 394             mpartial <- gets (Map.lookup ls . partialSolutions)
 395             soln <- solveLockSaving ls mpartial Nothing lock $ Just $
 396                 "solving " ++ name ++ ":" ++ [lockIndexChar idx] ++ "  (#" ++ show ls ++")"
 397             mourName <- lift $ gets ((authUser <$>) . curAuth)
 398             guard $ mourName /= Just name
 399             let undecl = Undeclared soln ls (ActiveLock name idx)
 400             msum [ do
 401                     MaybeT $ gets curAuth
 402                     confirmOrBail "Declare solution?"
 403                     declare undecl
 404                 , unless (any (\(Undeclared _ ls' _) -> ls == ls') undecls) $
 405                     modify $ \ms -> ms { undeclareds = undecl : undeclareds ms }
 406                 ]
 407         ]
 408 processCommand' IMMeta (CmdPlayLockSpec mls) = void.runMaybeT $ do
 409     ls <- msum [ liftMaybe mls
 410         , do
 411             tls <- MaybeT . lift $ textInput "Lock number:" 16 False False Nothing Nothing
 412             liftMaybe $ readMay tls
 413         ]
 414     RCLock lock <- MaybeT $ getFreshRecBlocking $ RecLock ls
 415     solveLock lock Nothing $ Just $ "solving " ++ show ls
 416
 417 processCommand' IMMeta (CmdDeclare mundecl) = void.runMaybeT $ do
 418     guard =<< mourNameSelected
 419     name <- mgetCurName
 420     undecls <- lift $ gets undeclareds
 421     guard $ not $ null undecls
 422     declare =<< msum [ liftMaybe mundecl
 423         , if length undecls == 1
 424         then return $ head undecls
 425         else do
 426             which <- MaybeT $ lift $ textInput
 427                 "Declare which solution?"
 428                 5 False True Nothing Nothing
 429             liftMaybe $ msum
 430                 [ do
 431                     i <- readMay which
 432                     guard $ 0 < i && i <= length undecls
 433                     return $ undecls !! (i-1)
 434                 , listToMaybe $
 435                     [ undecl
 436                     | undecl@(Undeclared _ _ (ActiveLock name' i)) <- undecls
 437                     , (take (length which) (name' ++ ":" ++ [lockIndexChar i]) ==
 438                             map toUpper which) || (name'==name && [lockIndexChar i] == which)
 439                     ]
 440                 ]
 441         ]
 442 processCommand' IMMeta (CmdViewSolution mnote) = void.runMaybeT $ do
 443     note <- liftMaybe mnote `mplus` do
 444         ourName <- mgetOurName
 445         name <- mgetCurName
 446         uinfo <- mgetUInfo name
 447         noteses <- lift $ sequence
 448             [ case mlockinfo of
 449                 Nothing -> return []
 450                 Just lockinfo -> (++lockSolutions lockinfo) <$> do
 451                         ns <- getNotesReadOn lockinfo
 452                         return $ if length ns < 3 then [] else ns
 453             | mlockinfo <- elems $ userLocks uinfo ]
 454         idx <- askLockIndex "View solution to which lock?" "No solutions to view" $ not.null.(noteses!!)
 455         let notes = noteses!!idx
 456             authors = noteAuthor <$> notes
 457         author <- if length notes == 1
 458             then return $ noteAuthor $ head notes
 459             else (map toUpper <$>) $ MaybeT $ lift $
 460                 textInput ("View solution by which player? ["
 461                     ++ intercalate "," (take 3 authors)
 462                     ++ if length authors > 3 then ",...]" else "]")
 463                 3 False True (Just authors) Nothing
 464         liftMaybe $ find ((==author).noteAuthor) notes
 465     let ActiveLock name idx = noteOn note
 466     uinfo <- mgetUInfo name
 467     ls <- lockSpec <$> MaybeT (return $ userLocks uinfo ! idx)
 468     RCLock lock <- MaybeT $ getFreshRecBlocking $ RecLock ls
 469     RCSolution soln <- MaybeT $ getFreshRecBlocking $ RecNote note
 470     lift $ execSubMainState $ newReplayState (snd.reframe$lock) soln $ Just $
 471         "viewing solution by " ++ noteAuthor note ++ " to " ++ name ++ [':',lockIndexChar idx]
 472
 473 processCommand' IMMeta (CmdPlaceLock midx) = void.runMaybeT $ do
 474     guard =<< mourNameSelected
 475     ourName <- mgetOurName
 476     (lock,msoln) <- MaybeT (gets curLock) `mplus` do
 477         ebdg <- lift.lift $ getUIBinding IMMeta CmdEdit
 478         lift.lift $ drawError $ "No lock selected; '"++ebdg++"' to edit one."
 479         mzero
 480     lockpath <- lift $ gets curLockPath
 481     ourUInfo <- mgetUInfo ourName
 482     idx <- (liftMaybe midx `mplus`) $
 483         askLockIndex ("Place " ++ show lockpath ++ " in which slot?") "bug" $ const True
 484     when (isJust $ userLocks ourUInfo ! idx) $
 485         confirmOrBail "Really retire existing lock?"
 486     soln <- (liftMaybe msoln `mplus`) $ solveLock lock Nothing $ Just "testing lock"
 487     lift $ curServerActionAsyncThenInvalidate
 488         (SetLock lock idx soln)
 489         (Just (SomeCodenames [ourName]))
 490
 491 processCommand' IMMeta CmdSelectLock = void.runMaybeT $ do
 492     lockdir <- liftIO $ confFilePath "locks"
 493     paths <- liftIO $ map (drop (length lockdir + 1)) <$> getDirContentsRec lockdir
 494     path <- MaybeT $ lift $ textInput "Lock name:" 1024 False False (Just paths) Nothing
 495     lift $ setLockPath path
 496 processCommand' IMMeta CmdNextLock =
 497     gets curLockPath >>= liftIO . nextLock True >>= setLockPath
 498 processCommand' IMMeta CmdPrevLock =
 499     gets curLockPath >>= liftIO . nextLock False >>= setLockPath
 500 processCommand' IMMeta CmdNextPage =
 501     gets listOffsetMax >>!
 502         modify $ \ms -> ms { listOffset = listOffset ms + 1 }
 503 processCommand' IMMeta CmdPrevPage =
 504     modify $ \ms -> ms { listOffset = max 0 $ listOffset ms - 1 }
 505 processCommand' IMMeta CmdEdit = void.runMaybeT $ do
 506     (lock, msoln) <- MaybeT (gets curLock) `mplus` do
 507         size <- msum
 508             [ do
 509                 gets curServer
 510                 RCServerInfo (ServerInfo size _) <- MaybeT $ getFreshRecBlocking RecServerInfo
 511                 return size
 512             , do
 513                 sizet <- MaybeT $ lift $ textInput
 514                     ("Lock size: [3-" ++ show maxlocksize ++ "]") 2 False False Nothing Nothing
 515                 size <- liftMaybe $ readMay sizet
 516                 guard $ 3 <= size && size <= maxlocksize
 517                 return size
 518             ]
 519         return (baseLock size, Nothing)
 520     not <$> liftIO hasLocks >>? do
 521         lift.lift $ withNoBG $ showHelp IMEdit HelpPageFirstEdit >>? do
 522             void $ textInput
 523                 "[Press a key or RMB to continue; you can review this help later with '?']"
 524                 1 False True Nothing Nothing
 525     path <- lift $ gets curLockPath
 526     newPath <- MaybeT $ (esPath <$>) $ execSubMainState $
 527         newEditState (reframe lock) msoln (if null path then Nothing else Just path)
 528     lift $ setLockPath newPath
 529 processCommand' IMMeta CmdShowRetired = void.runMaybeT $ do
 530     name <- mgetCurName
 531     newRL <- lift (gets retiredLocks) >>= \case
 532         Nothing -> do
 533             RCLockSpecs lss <- MaybeT $ getFreshRecBlocking $ RecRetiredLocks name
 534             if null lss
 535                 then do
 536                     lift.lift $ drawError "Player has no retired locks."
 537                     return Nothing
 538                 else return $ Just lss
 539         Just _ -> return Nothing
 540     lift $ modify $ \ms -> ms {retiredLocks = newRL}
 541
 542 processCommand' IMPlay CmdUndo = do
 543     st <- gets psCurrentState
 544     stack <- gets psGameStateMoveStack
 545     ustms <- gets psUndoneStack
 546     unless (null stack) $ do
 547         let (st',pm) = head stack
 548         modify $ \ps -> ps {psCurrentState=st', psGameStateMoveStack = tail stack,
 549             psLastAlerts = [], psUndoneStack = pm:ustms}
 550 processCommand' IMPlay CmdRedo = do
 551     ustms <- gets psUndoneStack
 552     case ustms of
 553         [] -> return ()
 554         pm:ustms' -> do
 555             st <- gets psCurrentState
 556             (st',alerts) <- lift $ doPhysicsTick pm st
 557             pushPState (st',pm)
 558             modify $ \ps -> ps {psLastAlerts = alerts, psUndoneStack = ustms'}
 559 processCommand' IMPlay (CmdManipulateToolAt pos) = do
 560     board <- gets (stateBoard . psCurrentState)
 561     wsel <- gets wrenchSelected
 562     void.runMaybeT $ msum $ (do
 563             tile <- liftMaybe $ snd <$> Map.lookup pos board
 564             guard $ case tile of {WrenchTile _ -> True; HookTile -> True; _ -> False}
 565             lift $ processCommand' IMPlay $ CmdTile tile) : [ do
 566             tile <- liftMaybe $ snd <$> Map.lookup (d+^pos) board
 567             guard $ tileType tile == if wsel then WrenchTile zero else HookTile
 568             lift $ processCommand' IMPlay $ CmdDir WHSSelected $ neg d
 569             | d <- hexDirs ]
 570 processCommand' IMPlay (CmdDrag pos dir) = do
 571     board <- gets (stateBoard . psCurrentState)
 572     wsel <- gets wrenchSelected
 573     void.runMaybeT $ do
 574         tp <- liftMaybe $ tileType . snd <$> Map.lookup pos board
 575         msum [ guard $ tp == HookTile
 576             , do
 577                 guard $ tp == WrenchTile zero
 578                 board' <- lift $ gets ((stateBoard . fst . runWriter . physicsTick (WrenchPush dir)) . psCurrentState)
 579                 msum $ [ do
 580                         tp' <- liftMaybe $ tileType . snd <$> Map.lookup pos' board'
 581                         guard $ tp' == WrenchTile zero
 582                     | d <- [0,1,2]
 583                     , let pos' = d *^ dir +^ pos ]
 584                     ++ [ (lift.lift $ warpPointer pos) >> mzero ]
 585             ]
 586         lift $ processCommand' IMPlay $ CmdDir WHSSelected dir
 587         board' <- gets (stateBoard . psCurrentState)
 588         msum [ do
 589                 tp' <- liftMaybe $ tileType . snd <$> Map.lookup pos' board'
 590                 guard $ tp' == if wsel then WrenchTile zero else HookTile
 591                 lift.lift $ warpPointer pos'
 592             | pos' <- (+^pos) <$> hexDisc 2 ]
 593
 594 processCommand' IMPlay cmd = do
 595     wsel <- gets wrenchSelected
 596     st <- gets psCurrentState
 597     let push whs dir
 598             | whs == WHSWrench || (whs == WHSSelected && wsel) =
 599                 Just $ WrenchPush dir
 600             | otherwise = Just $ HookPush dir
 601         torque whs dir
 602             {- | whs == WHSHook || (whs == WHSSelected && not wsel)=
 603                 Just $ HookTorque dir
 604             | otherwise = Nothing -}
 605             = Just $ HookTorque dir
 606         (wsel', pm) =
 607             case cmd of
 608                 CmdTile (WrenchTile _) -> (True, Nothing)
 609                 CmdTile HookTile       -> (False, Nothing)
 610                 CmdTile (ArmTile _ _)  -> (False, Nothing)
 611                 CmdToggle              -> (not wsel, Nothing)
 612                 CmdDir whs dir         -> (wsel, push whs dir)
 613                 CmdRotate whs dir      -> (wsel, torque whs dir)
 614                 CmdWait                -> (wsel, Just NullPM)
 615                 CmdSelect              -> (wsel, Just NullPM)
 616                 _                      -> (wsel, Nothing)
 617     modify $ \ps -> ps {wrenchSelected = wsel'}
 618     case pm of
 619          Nothing -> return ()
 620          Just pm' -> do
 621             (st',alerts) <- lift $ doPhysicsTick pm' st
 622             modify $ \ps -> ps {psLastAlerts = alerts}
 623             pushPState (st',pm')
 624
 625 processCommand' IMReplay (CmdReplayBack 1) = void.runMaybeT $ do
 626     (st',pm) <- MaybeT $ gets (listToMaybe . rsGameStateMoveStack)
 627     lift $ modify $ \rs -> rs {rsCurrentState=st'
 628         , rsLastAlerts = []
 629         , rsGameStateMoveStack = tail $ rsGameStateMoveStack rs
 630         , rsMoveStack = pm:rsMoveStack rs}
 631 processCommand' IMReplay (CmdReplayBack n) = replicateM_ n $
 632     processCommand' IMReplay (CmdReplayBack 1)
 633 processCommand' IMReplay (CmdReplayForward 1) = void.runMaybeT $ do
 634     pm <- MaybeT $ gets (listToMaybe . rsMoveStack)
 635     lift $ do
 636         st <- gets rsCurrentState
 637         (st',alerts) <- lift $ doPhysicsTick pm st
 638         modify $ \rs -> rs {rsCurrentState = st'
 639             , rsLastAlerts = alerts
 640             , rsGameStateMoveStack = (st,pm):rsGameStateMoveStack rs
 641             , rsMoveStack = tail $ rsMoveStack rs}
 642 processCommand' IMReplay (CmdReplayForward n) = replicateM_ n $
 643     processCommand' IMReplay (CmdReplayForward 1)
 644 processCommand' IMReplay CmdUndo = processCommand' IMReplay (CmdReplayBack 1)
 645 processCommand' IMReplay CmdRedo = processCommand' IMReplay (CmdReplayForward 1)
 646
 647 processCommand' IMEdit CmdPlay = do
 648     st <- gets esGameState
 649     frame <- gets esFrame
 650     modify $ \es -> es {selectedPiece = Nothing}
 651     subPlay (frame,st)
 652 processCommand' IMEdit CmdTest = do
 653     frame <- gets esFrame
 654     modifyEState (\st -> snd $ canonify (frame, st))
 655     modify $ \es -> es {selectedPiece = Nothing}
 656     mpath <- gets esPath
 657     st <- gets esGameState
 658     curSoln <- runMaybeT $ do
 659         (st', soln) <- MaybeT $ gets esTested
 660         guard $ st' == st
 661         return soln
 662     void.runMaybeT $ do
 663         soln <- solveLock (frame,st) curSoln $ Just $ "testing " ++ fromMaybe "[unnamed lock]" mpath
 664         lift $ modify $ \es -> es { esTested = Just (st, soln) }
 665 processCommand' IMEdit CmdUndo = do
 666     st <- gets esGameState
 667     sts <- gets esGameStateStack
 668     usts <- gets esUndoneStack
 669     unless (null sts) $ modify $ \es -> es {esGameState = head sts, esGameStateStack = tail sts, esUndoneStack = st:usts}
 670 processCommand' IMEdit CmdRedo = do
 671     usts <- gets esUndoneStack
 672     case usts of
 673         [] -> return ()
 674         ust:usts' -> do
 675             pushEState ust
 676             modify $ \es -> es {esUndoneStack = usts'}
 677 processCommand' IMEdit CmdUnselect =
 678     modify $ \es -> es {selectedPiece = Nothing}
 679 processCommand' IMEdit CmdSelect = do
 680     selPiece <- gets selectedPiece
 681     selPos <- gets selectedPos
 682     st <- gets esGameState
 683     let selPiece' =
 684             if isJust selPiece
 685                 then Nothing
 686                 else fmap fst . Map.lookup selPos $ stateBoard st
 687     modify $ \es -> es {selectedPiece = selPiece'}
 688 processCommand' IMEdit (CmdDir _ dir) = do
 689     selPos <- gets selectedPos
 690     selPiece <- gets selectedPiece
 691     frame <- gets esFrame
 692     case selPiece of
 693         Nothing -> modify $ \es -> es {selectedPos = checkEditable frame selPos $ dir +^ selPos}
 694         Just p -> doForce $ Push p dir
 695 processCommand' IMEdit (CmdMoveTo newPos) =
 696     setSelectedPos newPos
 697 processCommand' IMEdit (CmdDrag pos dir) = do
 698     board <- gets (stateBoard . esGameState)
 699     void.runMaybeT $ do
 700         selIdx <- MaybeT $ gets selectedPiece
 701         idx <- liftMaybe $ fst <$> Map.lookup pos board
 702         guard $ idx == selIdx
 703         lift $ processCommand' IMEdit $ CmdDir WHSSelected dir
 704         board' <- gets (stateBoard . esGameState)
 705         msum [ do
 706                 idx' <- liftMaybe $ fst <$> Map.lookup pos' board'
 707                 guard $ idx' == selIdx
 708                 lift.lift $ warpPointer pos'
 709             | pos' <- [dir+^pos, pos] ]
 710 processCommand' IMEdit (CmdRotate _ dir) = do
 711     selPiece <- gets selectedPiece
 712     st <- gets esGameState
 713     case selPiece of
 714         Nothing -> return ()
 715         Just p  ->
 716             let PlacedPiece _ pc = getpp st p
 717                 torquable = case pc of
 718                     Hook _ _ -> True
 719                     Pivot _  -> True
 720                     _        -> False
 721             in if torquable
 722                 then doForce $ Torque p dir
 723                 else adjustSpringTension p dir
 724 processCommand' IMEdit (CmdTile tile) = do
 725     selPos <- gets selectedPos
 726     drawTile selPos (Just tile) False
 727 processCommand' IMEdit (CmdPaint tile) = do
 728     selPos <- gets selectedPos
 729     drawTile selPos tile True
 730 processCommand' IMEdit (CmdPaintFromTo tile from to) = do
 731     frame <- gets esFrame
 732     paintTilePath frame tile (truncateToEditable frame from) (truncateToEditable frame to)
 733 processCommand' IMEdit CmdMerge = do
 734     selPos <- gets selectedPos
 735     st <- gets esGameState
 736     lift $ drawMessage "Merge in which direction?"
 737     let getDir = do
 738             cmd <- lift $ head <$> getSomeInput IMEdit
 739             case cmd of
 740                 CmdDir _ mergeDir  -> return $ Just mergeDir
 741                 CmdDrag _ mergeDir -> return $ Just mergeDir
 742                 CmdMoveTo _        -> getDir
 743                 _                  -> return Nothing
 744     mergeDir <- getDir
 745     case mergeDir of
 746         Just mergeDir -> modifyEState $ mergeTiles selPos mergeDir True
 747         _             -> return ()
 748     -- XXX: merging might invalidate selectedPiece
 749     modify $ \es -> es {selectedPiece = Nothing}
 750     lift clearMessage
 751 processCommand' IMEdit CmdWait = do
 752     st <- gets esGameState
 753     (st',_) <- lift $ doPhysicsTick NullPM st
 754     pushEState st'
 755
 756 processCommand' IMEdit CmdDelete = do
 757     selPos <- gets selectedPos
 758     selPiece <- gets selectedPiece
 759     st <- gets esGameState
 760     case selPiece of
 761         Nothing -> drawTile selPos Nothing False
 762         Just p -> do modify $ \es -> es {selectedPiece = Nothing}
 763                      modifyEState $ delPiece p
 764 processCommand' IMEdit CmdWriteState = void.runMaybeT $ do
 765     path <- lift $ gets esPath
 766     newPath <- MaybeT $ lift $ textInput "Save lock as:" 1024 False False Nothing path
 767     guard $ not $ null newPath
 768     fullPath <- liftIO $ fullLockPath newPath
 769     liftIO (fileExists fullPath) >>?
 770         confirmOrBail $ "Really overwrite '"++fullPath++"'?"
 771     lift $ do
 772         st <- gets esGameState
 773         frame <- gets esFrame
 774         msoln <- getCurTestSoln
 775         merr <- liftIO $ (writeAsciiLockFile fullPath msoln (canonify (frame, st)) >> return Nothing)
 776             `catchIO` (return . Just . show)
 777         modify $ \es -> es {lastSavedState = Just (st,isJust msoln)}
 778         case merr of
 779             Nothing  -> modify $ \es -> es {esPath = Just newPath}
 780             Just err -> lift $ drawError $ "Write failed: "++err
 781 processCommand' _ _ = return ()
 782
 783 inputPassword :: UIMonad uiM => Codename -> Bool -> String -> MaybeT (MainStateT uiM) String
 784 inputPassword name confirm prompt = do
 785     pw <- MaybeT $ lift $ textInput prompt 64 True False Nothing Nothing
 786     guard $ not $ null pw
 787     when confirm $ do
 788         pw' <- MaybeT $ lift $ textInput "Confirm password:" 64 True False Nothing Nothing
 789         when (pw /= pw') $ do
 790             lift.lift $ drawError "Passwords don't match!"
 791             mzero
 792     RCPublicKey publicKey <- MaybeT $ getFreshRecBlocking RecPublicKey
 793     encryptPassword publicKey name pw
 794
 795 -- | Salt and encrypt a password, to protect users' passwords from sniffing
 796 -- and dictionary attack. We can hope that they wouldn't use valuable
 797 -- passwords, but we shouldn't assume it.
 798 -- Note that in all other respects, the protocol is entirely insecure -
 799 -- nothing else is encrypted, and anyone sniffing an encrypted password can
 800 -- replay it to authenticate as the user.
 801 encryptPassword :: UIMonad uiM =>
 802     PublicKey -> String -> String -> MaybeT (MainStateT uiM) String
 803 encryptPassword publicKey name password = MaybeT . liftIO .
 804             handle (\(e :: SomeException) -> return Nothing) $ do
 805         Right c <- encrypt (defaultOAEPParams SHA256) publicKey . CS.pack $ hashed
 806         return . Just . CS.unpack $ c
 807     where hashed = hash $ "IY" ++ name ++ password
 808
 809 setSelectedPosFromMouse :: UIMonad uiM => MainStateT uiM ()
 810 setSelectedPosFromMouse = lift getUIMousePos >>= maybe (return ()) setSelectedPos
 811
 812 setSelectedPos :: Monad m => HexPos -> MainStateT m ()
 813 setSelectedPos pos = do
 814     frame <- gets esFrame
 815     modify $ \es -> es {selectedPos = truncateToEditable frame pos}
 816
 817 subPlay :: UIMonad uiM => Lock -> MainStateT uiM ()
 818 subPlay lock =
 819     pushEState . psCurrentState =<< execSubMainState (newPlayState lock [] Nothing Nothing True False)
 820
 821 solveLock :: UIMonad uiM => Lock -> Maybe Solution -> Maybe String -> MaybeT (MainStateT uiM) Solution
 822 solveLock = solveLock' Nothing
 823 solveLock' tutLevel lock mSoln title = do
 824     (InteractSuccess solved, ps) <- lift $ runSubMainState $
 825         newPlayState (reframe lock) (fromMaybe [] mSoln) title tutLevel False False
 826     guard solved
 827     return . reverse $ snd <$> psGameStateMoveStack ps
 828
 829 solveLockSaving :: UIMonad uiM => LockSpec -> Maybe SavedPlayState -> Maybe Int -> Lock -> Maybe String -> MaybeT (MainStateT uiM) Solution
 830 solveLockSaving ls msps tutLevel lock title = do
 831     let isTut = isJust tutLevel
 832     (InteractSuccess solved, ps) <- lift $ runSubMainState $
 833         maybe newPlayState restorePlayState msps (reframe lock) [] title tutLevel False True
 834     if solved
 835         then do
 836             unless isTut . lift . modify $ \ms -> ms { partialSolutions = Map.delete ls $ partialSolutions ms }
 837             return . reverse $ snd <$> psGameStateMoveStack ps
 838         else do
 839             lift $ modify $ \ms -> if isTut
 840                 then ms { tutProgress = (tutProgress ms)
 841                     { tutLevel = ls, tutPartial = Just $ savePlayState ps } }
 842                 else ms { partialSolutions = Map.insert ls (savePlayState ps) $ partialSolutions ms }
 843             mzero