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