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           Codec.Crypto.RSA           (encrypt)
  39 import           Crypto.Random              (SystemRandom, newGenIO)
  40 import           Crypto.Types.PubKey.RSA    (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 (drawMessage "") >>) . 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 "++) 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 = 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 $ drawMessage ""
 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 $ 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 $ 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     modify $ \ms -> ms { listOffset = listOffset ms + 1 }
 501 processCommand' IMMeta CmdPrevPage =
 502     modify $ \ms -> ms { listOffset = max 0 $ listOffset ms - 1 }
 503 processCommand' IMMeta CmdEdit = void.runMaybeT $ do
 504     (lock, msoln) <- MaybeT (gets curLock) `mplus` do
 505         size <- msum
 506             [ do
 507                 gets curServer
 508                 RCServerInfo (ServerInfo size _) <- MaybeT $ getFreshRecBlocking RecServerInfo
 509                 return size
 510             , do
 511                 sizet <- MaybeT $ lift $ textInput
 512                     ("Lock size: [3-" ++ show maxlocksize ++ "]") 2 False False Nothing Nothing
 513                 size <- liftMaybe $ readMay sizet
 514                 guard $ 3 <= size && size <= maxlocksize
 515                 return size
 516             ]
 517         return (baseLock size, Nothing)
 518     not <$> liftIO hasLocks >>? do
 519         lift.lift $ withNoBG $ showHelp IMEdit HelpPageFirstEdit >>? do
 520             void $ textInput
 521                 "[Press a key or RMB to continue; you can review this help later with '?']"
 522                 1 False True Nothing Nothing
 523     path <- lift $ gets curLockPath
 524     newPath <- MaybeT $ (esPath <$>) $ execSubMainState $
 525         newEditState (reframe lock) msoln (if null path then Nothing else Just path)
 526     lift $ setLockPath newPath
 527 processCommand' IMMeta CmdShowRetired = void.runMaybeT $ do
 528     name <- mgetCurName
 529     newRL <- lift (gets retiredLocks) >>= \case
 530         Nothing -> do
 531             RCLockSpecs lss <- MaybeT $ getFreshRecBlocking $ RecRetiredLocks name
 532             if null lss
 533                 then do
 534                     lift.lift $ drawError "Player has no retired locks."
 535                     return Nothing
 536                 else return $ Just lss
 537         Just _ -> return Nothing
 538     lift $ modify $ \ms -> ms {retiredLocks = newRL}
 539
 540 processCommand' IMPlay CmdUndo = do
 541     st <- gets psCurrentState
 542     stack <- gets psGameStateMoveStack
 543     ustms <- gets psUndoneStack
 544     unless (null stack) $ do
 545         let (st',pm) = head stack
 546         modify $ \ps -> ps {psCurrentState=st', psGameStateMoveStack = tail stack,
 547             psLastAlerts = [], psUndoneStack = (st,pm):ustms}
 548 processCommand' IMPlay CmdRedo = do
 549     ustms <- gets psUndoneStack
 550     case ustms of
 551         [] -> return ()
 552         ustm@(_,pm):ustms' -> do
 553             st <- gets psCurrentState
 554             (st',alerts) <- lift $ doPhysicsTick pm st
 555             pushPState (st',pm)
 556             modify $ \ps -> ps {psLastAlerts = alerts, psUndoneStack = ustms'}
 557 processCommand' IMPlay (CmdManipulateToolAt pos) = do
 558     board <- gets (stateBoard . psCurrentState)
 559     wsel <- gets wrenchSelected
 560     void.runMaybeT $ msum $ (do
 561             tile <- liftMaybe $ snd <$> Map.lookup pos board
 562             guard $ case tile of {WrenchTile _ -> True; HookTile -> True; _ -> False}
 563             lift $ processCommand' IMPlay $ CmdTile tile) : [ do
 564             tile <- liftMaybe $ snd <$> Map.lookup (d+^pos) board
 565             guard $ tileType tile == if wsel then WrenchTile zero else HookTile
 566             lift $ processCommand' IMPlay $ CmdDir WHSSelected $ neg d
 567             | d <- hexDirs ]
 568 processCommand' IMPlay (CmdDrag pos dir) = do
 569     board <- gets (stateBoard . psCurrentState)
 570     wsel <- gets wrenchSelected
 571     void.runMaybeT $ do
 572         tp <- liftMaybe $ tileType . snd <$> Map.lookup pos board
 573         msum [ guard $ tp == HookTile
 574             , do
 575                 guard $ tp == WrenchTile zero
 576                 board' <- lift $ gets ((stateBoard . fst . runWriter . physicsTick (WrenchPush dir)) . psCurrentState)
 577                 msum $ [ do
 578                         tp' <- liftMaybe $ tileType . snd <$> Map.lookup pos' board'
 579                         guard $ tp' == WrenchTile zero
 580                     | d <- [0,1,2]
 581                     , let pos' = d *^ dir +^ pos ]
 582                     ++ [ (lift.lift $ warpPointer pos) >> mzero ]
 583             ]
 584         lift $ processCommand' IMPlay $ CmdDir WHSSelected dir
 585         board' <- gets (stateBoard . psCurrentState)
 586         msum [ do
 587                 tp' <- liftMaybe $ tileType . snd <$> Map.lookup pos' board'
 588                 guard $ tp' == if wsel then WrenchTile zero else HookTile
 589                 lift.lift $ warpPointer pos'
 590             | pos' <- (+^pos) <$> hexDisc 2 ]
 591
 592 processCommand' IMPlay cmd = do
 593     wsel <- gets wrenchSelected
 594     st <- gets psCurrentState
 595     let push whs dir
 596             | whs == WHSWrench || (whs == WHSSelected && wsel) =
 597                 Just $ WrenchPush dir
 598             | otherwise = Just $ HookPush dir
 599         torque whs dir
 600             {- | whs == WHSHook || (whs == WHSSelected && not wsel)=
 601                 Just $ HookTorque dir
 602             | otherwise = Nothing -}
 603             = Just $ HookTorque dir
 604         (wsel', pm) =
 605             case cmd of
 606                 CmdTile (WrenchTile _) -> (True, Nothing)
 607                 CmdTile HookTile       -> (False, Nothing)
 608                 CmdTile (ArmTile _ _)  -> (False, Nothing)
 609                 CmdToggle              -> (not wsel, Nothing)
 610                 CmdDir whs dir         -> (wsel, push whs dir)
 611                 CmdRotate whs dir      -> (wsel, torque whs dir)
 612                 CmdWait                -> (wsel, Just NullPM)
 613                 CmdSelect              -> (wsel, Just NullPM)
 614                 _                      -> (wsel, Nothing)
 615     modify $ \ps -> ps {wrenchSelected = wsel'}
 616     case pm of
 617          Nothing -> return ()
 618          Just pm' -> do
 619             (st',alerts) <- lift $ doPhysicsTick pm' st
 620             modify $ \ps -> ps {psLastAlerts = alerts}
 621             pushPState (st',pm')
 622
 623 processCommand' IMReplay (CmdReplayBack 1) = void.runMaybeT $ do
 624     (st',pm) <- MaybeT $ gets (listToMaybe . rsGameStateMoveStack)
 625     lift $ modify $ \rs -> rs {rsCurrentState=st'
 626         , rsLastAlerts = []
 627         , rsGameStateMoveStack = tail $ rsGameStateMoveStack rs
 628         , rsMoveStack = pm:rsMoveStack rs}
 629 processCommand' IMReplay (CmdReplayBack n) = replicateM_ n $
 630     processCommand' IMReplay (CmdReplayBack 1)
 631 processCommand' IMReplay (CmdReplayForward 1) = void.runMaybeT $ do
 632     pm <- MaybeT $ gets (listToMaybe . rsMoveStack)
 633     lift $ do
 634         st <- gets rsCurrentState
 635         (st',alerts) <- lift $ doPhysicsTick pm st
 636         modify $ \rs -> rs {rsCurrentState = st'
 637             , rsLastAlerts = alerts
 638             , rsGameStateMoveStack = (st,pm):rsGameStateMoveStack rs
 639             , rsMoveStack = tail $ rsMoveStack rs}
 640 processCommand' IMReplay (CmdReplayForward n) = replicateM_ n $
 641     processCommand' IMReplay (CmdReplayForward 1)
 642 processCommand' IMReplay CmdUndo = processCommand' IMReplay (CmdReplayBack 1)
 643 processCommand' IMReplay CmdRedo = processCommand' IMReplay (CmdReplayForward 1)
 644
 645 processCommand' IMEdit CmdPlay = do
 646     st <- gets esGameState
 647     frame <- gets esFrame
 648     modify $ \es -> es {selectedPiece = Nothing}
 649     subPlay (frame,st)
 650 processCommand' IMEdit CmdTest = do
 651     frame <- gets esFrame
 652     modifyEState (\st -> snd $ canonify (frame, st))
 653     modify $ \es -> es {selectedPiece = Nothing}
 654     mpath <- gets esPath
 655     st <- gets esGameState
 656     void.runMaybeT $ do
 657         soln <- solveLock (frame,st) $ Just $ "testing " ++ fromMaybe "[unnamed lock]" mpath
 658         lift $ modify $ \es -> es { esTested = Just (st, soln) }
 659 processCommand' IMEdit CmdUndo = do
 660     st <- gets esGameState
 661     sts <- gets esGameStateStack
 662     usts <- gets esUndoneStack
 663     unless (null sts) $ modify $ \es -> es {esGameState = head sts, esGameStateStack = tail sts, esUndoneStack = st:usts}
 664 processCommand' IMEdit CmdRedo = do
 665     usts <- gets esUndoneStack
 666     case usts of
 667         [] -> return ()
 668         ust:usts' -> do
 669             pushEState ust
 670             modify $ \es -> es {esUndoneStack = usts'}
 671 processCommand' IMEdit CmdUnselect =
 672     modify $ \es -> es {selectedPiece = Nothing}
 673 processCommand' IMEdit CmdSelect = do
 674     selPiece <- gets selectedPiece
 675     selPos <- gets selectedPos
 676     st <- gets esGameState
 677     let selPiece' =
 678             if isJust selPiece
 679                 then Nothing
 680                 else fmap fst . Map.lookup selPos $ stateBoard st
 681     modify $ \es -> es {selectedPiece = selPiece'}
 682 processCommand' IMEdit (CmdDir _ dir) = do
 683     selPos <- gets selectedPos
 684     selPiece <- gets selectedPiece
 685     frame <- gets esFrame
 686     case selPiece of
 687         Nothing -> modify $ \es -> es {selectedPos = checkEditable frame selPos $ dir +^ selPos}
 688         Just p -> doForce $ Push p dir
 689 processCommand' IMEdit (CmdMoveTo newPos) =
 690     setSelectedPos newPos
 691 processCommand' IMEdit (CmdDrag pos dir) = do
 692     board <- gets (stateBoard . esGameState)
 693     void.runMaybeT $ do
 694         selIdx <- MaybeT $ gets selectedPiece
 695         idx <- liftMaybe $ fst <$> Map.lookup pos board
 696         guard $ idx == selIdx
 697         lift $ processCommand' IMEdit $ CmdDir WHSSelected dir
 698         board' <- gets (stateBoard . esGameState)
 699         msum [ do
 700                 idx' <- liftMaybe $ fst <$> Map.lookup pos' board'
 701                 guard $ idx' == selIdx
 702                 lift.lift $ warpPointer pos'
 703             | pos' <- [dir+^pos, pos] ]
 704 processCommand' IMEdit (CmdRotate _ dir) = do
 705     selPiece <- gets selectedPiece
 706     case selPiece of
 707         Nothing -> return ()
 708         Just p  -> doForce $ Torque p dir
 709 processCommand' IMEdit (CmdTile tile) = do
 710     selPos <- gets selectedPos
 711     drawTile selPos (Just tile) False
 712 processCommand' IMEdit (CmdPaint tile) = do
 713     selPos <- gets selectedPos
 714     drawTile selPos tile True
 715 processCommand' IMEdit (CmdPaintFromTo tile from to) = do
 716     frame <- gets esFrame
 717     paintTilePath frame tile (truncateToEditable frame from) (truncateToEditable frame to)
 718 processCommand' IMEdit CmdMerge = do
 719     selPos <- gets selectedPos
 720     st <- gets esGameState
 721     lift $ drawMessage "Merge in which direction?"
 722     let getDir = do
 723             cmd <- lift $ head <$> getSomeInput IMEdit
 724             case cmd of
 725                 CmdDir _ mergeDir  -> return $ Just mergeDir
 726                 CmdDrag _ mergeDir -> return $ Just mergeDir
 727                 CmdMoveTo _        -> getDir
 728                 _                  -> return Nothing
 729     mergeDir <- getDir
 730     case mergeDir of
 731         Just mergeDir -> modifyEState $ mergeTiles selPos mergeDir True
 732         _             -> return ()
 733     -- XXX: merging might invalidate selectedPiece
 734     modify $ \es -> es {selectedPiece = Nothing}
 735     lift $ drawMessage ""
 736 processCommand' IMEdit CmdWait = do
 737     st <- gets esGameState
 738     (st',_) <- lift $ doPhysicsTick NullPM st
 739     pushEState st'
 740
 741 processCommand' IMEdit CmdDelete = do
 742     selPos <- gets selectedPos
 743     selPiece <- gets selectedPiece
 744     st <- gets esGameState
 745     case selPiece of
 746         Nothing -> drawTile selPos Nothing False
 747         Just p -> do modify $ \es -> es {selectedPiece = Nothing}
 748                      modifyEState $ delPiece p
 749 processCommand' IMEdit CmdWriteState = void.runMaybeT $ do
 750     path <- lift $ gets esPath
 751     newPath <- MaybeT $ lift $ textInput "Save lock as:" 1024 False False Nothing path
 752     guard $ not $ null newPath
 753     fullPath <- liftIO $ fullLockPath newPath
 754     liftIO (fileExists fullPath) >>?
 755         confirmOrBail $ "Really overwrite '"++fullPath++"'?"
 756     lift $ do
 757         st <- gets esGameState
 758         frame <- gets esFrame
 759         msoln <- getCurTestSoln
 760         merr <- liftIO $ (writeAsciiLockFile fullPath msoln (canonify (frame, st)) >> return Nothing)
 761             `catchIO` (return . Just . show)
 762         modify $ \es -> es {lastSavedState = Just (st,isJust msoln)}
 763         case merr of
 764             Nothing  -> modify $ \es -> es {esPath = Just newPath}
 765             Just err -> lift $ drawError $ "Write failed: "++err
 766 processCommand' _ _ = return ()
 767
 768 inputPassword :: UIMonad uiM => Codename -> Bool -> String -> MaybeT (MainStateT uiM) String
 769 inputPassword name confirm prompt = do
 770     pw <- MaybeT $ lift $ textInput prompt 64 True False Nothing Nothing
 771     guard $ not $ null pw
 772     when confirm $ do
 773         pw' <- MaybeT $ lift $ textInput "Confirm password:" 64 True False Nothing Nothing
 774         when (pw /= pw') $ do
 775             lift.lift $ drawError "Passwords don't match!"
 776             mzero
 777     RCPublicKey publicKey <- MaybeT $ getFreshRecBlocking RecPublicKey
 778     encryptPassword publicKey name pw
 779
 780 -- | Salt and encrypt a password, to protect users' passwords from sniffing
 781 -- and dictionary attack. We can hope that they wouldn't use valuable
 782 -- passwords, but we shouldn't assume it.
 783 -- Note that in all other respects, the protocol is entirely insecure -
 784 -- nothing else is encrypted, and anyone sniffing an encrypted password can
 785 -- replay it to authenticate as the user.
 786 encryptPassword :: UIMonad uiM =>
 787     PublicKey -> String -> String -> MaybeT (MainStateT uiM) String
 788 encryptPassword publicKey name password = msum
 789     [ MaybeT . liftIO .
 790         handle (\(e :: SomeException) -> return Nothing) $ do
 791         g <- newGenIO :: IO SystemRandom
 792         return . Just . CS.unpack . BL.toStrict . fst . encrypt g publicKey .
 793             BL.fromStrict . CS.pack $ hashed
 794     , confirmOrBail
 795         "Failed to encrypt password - send unencrypted?"
 796         >> return hashed
 797     ]
 798     where hashed = hash $ "IY" ++ name ++ password
 799
 800 setSelectedPosFromMouse :: UIMonad uiM => MainStateT uiM ()
 801 setSelectedPosFromMouse = lift getUIMousePos >>= maybe (return ()) setSelectedPos
 802
 803 setSelectedPos :: Monad m => HexPos -> MainStateT m ()
 804 setSelectedPos pos = do
 805     frame <- gets esFrame
 806     modify $ \es -> es {selectedPos = truncateToEditable frame pos}
 807
 808 subPlay :: UIMonad uiM => Lock -> MainStateT uiM ()
 809 subPlay lock =
 810     pushEState . psCurrentState =<< execSubMainState (newPlayState lock Nothing Nothing True False)
 811
 812 solveLock :: UIMonad uiM => Lock -> Maybe String -> MaybeT (MainStateT uiM) Solution
 813 solveLock = solveLock' Nothing
 814 solveLock' tutLevel lock title = do
 815     (InteractSuccess solved, ps) <- lift $ runSubMainState $ newPlayState (reframe lock) title tutLevel False False
 816     guard solved
 817     return . reverse $ snd <$> psGameStateMoveStack ps
 818
 819 solveLockSaving :: UIMonad uiM => LockSpec -> Maybe SavedPlayState -> Maybe Int -> Lock -> Maybe String -> MaybeT (MainStateT uiM) Solution
 820 solveLockSaving ls msps tutLevel lock title = do
 821     let isTut = isJust tutLevel
 822     (InteractSuccess solved, ps) <- lift $ runSubMainState $
 823         maybe newPlayState restorePlayState msps (reframe lock) title tutLevel False True
 824     if solved
 825         then do
 826             unless isTut . lift . modify $ \ms -> ms { partialSolutions = Map.delete ls $ partialSolutions ms }
 827             return . reverse $ snd <$> psGameStateMoveStack ps
 828         else do
 829             lift $ modify $ \ms -> if isTut
 830                 then ms { tutProgress = (tutProgress ms)
 831                     { tutLevel = ls, tutPartial = Just $ savePlayState ps } }
 832                 else ms { partialSolutions = Map.insert ls (savePlayState ps) $ partialSolutions ms }
 833             mzero