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         IMReplay -> throwE $ InteractSuccess False
 143         IMPlay -> lift (or <$> sequence [gets psIsSub, gets psSaved, gets (null . psGameStateMoveStack)])
 144             >>? throwE $ InteractSuccess False
 145         IMEdit -> lift editStateUnsaved >>! throwE $ InteractSuccess True
 146         _ -> return ()
 147     title <- lift getTitle
 148     (lift . lift . confirm) ("Really quit"
 149             ++ (if im == IMEdit then " without saving" else "")
 150             ++ maybe "" (" from "++) 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 = 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 $ drawMessage ""
 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 $ 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 $ 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     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 = (st,pm):ustms}
 549 processCommand' IMPlay CmdRedo = do
 550     ustms <- gets psUndoneStack
 551     case ustms of
 552         [] -> return ()
 553         ustm@(_,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     void.runMaybeT $ do
 658         soln <- solveLock (frame,st) $ Just $ "testing " ++ fromMaybe "[unnamed lock]" mpath
 659         lift $ modify $ \es -> es { esTested = Just (st, soln) }
 660 processCommand' IMEdit CmdUndo = do
 661     st <- gets esGameState
 662     sts <- gets esGameStateStack
 663     usts <- gets esUndoneStack
 664     unless (null sts) $ modify $ \es -> es {esGameState = head sts, esGameStateStack = tail sts, esUndoneStack = st:usts}
 665 processCommand' IMEdit CmdRedo = do
 666     usts <- gets esUndoneStack
 667     case usts of
 668         [] -> return ()
 669         ust:usts' -> do
 670             pushEState ust
 671             modify $ \es -> es {esUndoneStack = usts'}
 672 processCommand' IMEdit CmdUnselect =
 673     modify $ \es -> es {selectedPiece = Nothing}
 674 processCommand' IMEdit CmdSelect = do
 675     selPiece <- gets selectedPiece
 676     selPos <- gets selectedPos
 677     st <- gets esGameState
 678     let selPiece' =
 679             if isJust selPiece
 680                 then Nothing
 681                 else fmap fst . Map.lookup selPos $ stateBoard st
 682     modify $ \es -> es {selectedPiece = selPiece'}
 683 processCommand' IMEdit (CmdDir _ dir) = do
 684     selPos <- gets selectedPos
 685     selPiece <- gets selectedPiece
 686     frame <- gets esFrame
 687     case selPiece of
 688         Nothing -> modify $ \es -> es {selectedPos = checkEditable frame selPos $ dir +^ selPos}
 689         Just p -> doForce $ Push p dir
 690 processCommand' IMEdit (CmdMoveTo newPos) =
 691     setSelectedPos newPos
 692 processCommand' IMEdit (CmdDrag pos dir) = do
 693     board <- gets (stateBoard . esGameState)
 694     void.runMaybeT $ do
 695         selIdx <- MaybeT $ gets selectedPiece
 696         idx <- liftMaybe $ fst <$> Map.lookup pos board
 697         guard $ idx == selIdx
 698         lift $ processCommand' IMEdit $ CmdDir WHSSelected dir
 699         board' <- gets (stateBoard . esGameState)
 700         msum [ do
 701                 idx' <- liftMaybe $ fst <$> Map.lookup pos' board'
 702                 guard $ idx' == selIdx
 703                 lift.lift $ warpPointer pos'
 704             | pos' <- [dir+^pos, pos] ]
 705 processCommand' IMEdit (CmdRotate _ dir) = do
 706     selPiece <- gets selectedPiece
 707     case selPiece of
 708         Nothing -> return ()
 709         Just p  -> doForce $ Torque p dir
 710 processCommand' IMEdit (CmdTile tile) = do
 711     selPos <- gets selectedPos
 712     drawTile selPos (Just tile) False
 713 processCommand' IMEdit (CmdPaint tile) = do
 714     selPos <- gets selectedPos
 715     drawTile selPos tile True
 716 processCommand' IMEdit (CmdPaintFromTo tile from to) = do
 717     frame <- gets esFrame
 718     paintTilePath frame tile (truncateToEditable frame from) (truncateToEditable frame to)
 719 processCommand' IMEdit CmdMerge = do
 720     selPos <- gets selectedPos
 721     st <- gets esGameState
 722     lift $ drawMessage "Merge in which direction?"
 723     let getDir = do
 724             cmd <- lift $ head <$> getSomeInput IMEdit
 725             case cmd of
 726                 CmdDir _ mergeDir  -> return $ Just mergeDir
 727                 CmdDrag _ mergeDir -> return $ Just mergeDir
 728                 CmdMoveTo _        -> getDir
 729                 _                  -> return Nothing
 730     mergeDir <- getDir
 731     case mergeDir of
 732         Just mergeDir -> modifyEState $ mergeTiles selPos mergeDir True
 733         _             -> return ()
 734     -- XXX: merging might invalidate selectedPiece
 735     modify $ \es -> es {selectedPiece = Nothing}
 736     lift $ drawMessage ""
 737 processCommand' IMEdit CmdWait = do
 738     st <- gets esGameState
 739     (st',_) <- lift $ doPhysicsTick NullPM st
 740     pushEState st'
 741
 742 processCommand' IMEdit CmdDelete = do
 743     selPos <- gets selectedPos
 744     selPiece <- gets selectedPiece
 745     st <- gets esGameState
 746     case selPiece of
 747         Nothing -> drawTile selPos Nothing False
 748         Just p -> do modify $ \es -> es {selectedPiece = Nothing}
 749                      modifyEState $ delPiece p
 750 processCommand' IMEdit CmdWriteState = void.runMaybeT $ do
 751     path <- lift $ gets esPath
 752     newPath <- MaybeT $ lift $ textInput "Save lock as:" 1024 False False Nothing path
 753     guard $ not $ null newPath
 754     fullPath <- liftIO $ fullLockPath newPath
 755     liftIO (fileExists fullPath) >>?
 756         confirmOrBail $ "Really overwrite '"++fullPath++"'?"
 757     lift $ do
 758         st <- gets esGameState
 759         frame <- gets esFrame
 760         msoln <- getCurTestSoln
 761         merr <- liftIO $ (writeAsciiLockFile fullPath msoln (canonify (frame, st)) >> return Nothing)
 762             `catchIO` (return . Just . show)
 763         modify $ \es -> es {lastSavedState = Just (st,isJust msoln)}
 764         case merr of
 765             Nothing  -> modify $ \es -> es {esPath = Just newPath}
 766             Just err -> lift $ drawError $ "Write failed: "++err
 767 processCommand' _ _ = return ()
 768
 769 inputPassword :: UIMonad uiM => Codename -> Bool -> String -> MaybeT (MainStateT uiM) String
 770 inputPassword name confirm prompt = do
 771     pw <- MaybeT $ lift $ textInput prompt 64 True False Nothing Nothing
 772     guard $ not $ null pw
 773     when confirm $ do
 774         pw' <- MaybeT $ lift $ textInput "Confirm password:" 64 True False Nothing Nothing
 775         when (pw /= pw') $ do
 776             lift.lift $ drawError "Passwords don't match!"
 777             mzero
 778     RCPublicKey publicKey <- MaybeT $ getFreshRecBlocking RecPublicKey
 779     encryptPassword publicKey name pw
 780
 781 -- | Salt and encrypt a password, to protect users' passwords from sniffing
 782 -- and dictionary attack. We can hope that they wouldn't use valuable
 783 -- passwords, but we shouldn't assume it.
 784 -- Note that in all other respects, the protocol is entirely insecure -
 785 -- nothing else is encrypted, and anyone sniffing an encrypted password can
 786 -- replay it to authenticate as the user.
 787 encryptPassword :: UIMonad uiM =>
 788     PublicKey -> String -> String -> MaybeT (MainStateT uiM) String
 789 encryptPassword publicKey name password = msum
 790     [ MaybeT . liftIO .
 791         handle (\(e :: SomeException) -> return Nothing) $ do
 792         g <- newGenIO :: IO SystemRandom
 793         return . Just . CS.unpack . BL.toStrict . fst . encrypt g publicKey .
 794             BL.fromStrict . CS.pack $ hashed
 795     , confirmOrBail
 796         "Failed to encrypt password - send unencrypted?"
 797         >> return hashed
 798     ]
 799     where hashed = hash $ "IY" ++ name ++ password
 800
 801 setSelectedPosFromMouse :: UIMonad uiM => MainStateT uiM ()
 802 setSelectedPosFromMouse = lift getUIMousePos >>= maybe (return ()) setSelectedPos
 803
 804 setSelectedPos :: Monad m => HexPos -> MainStateT m ()
 805 setSelectedPos pos = do
 806     frame <- gets esFrame
 807     modify $ \es -> es {selectedPos = truncateToEditable frame pos}
 808
 809 subPlay :: UIMonad uiM => Lock -> MainStateT uiM ()
 810 subPlay lock =
 811     pushEState . psCurrentState =<< execSubMainState (newPlayState lock Nothing Nothing True False)
 812
 813 solveLock :: UIMonad uiM => Lock -> Maybe String -> MaybeT (MainStateT uiM) Solution
 814 solveLock = solveLock' Nothing
 815 solveLock' tutLevel lock title = do
 816     (InteractSuccess solved, ps) <- lift $ runSubMainState $ newPlayState (reframe lock) title tutLevel False False
 817     guard solved
 818     return . reverse $ snd <$> psGameStateMoveStack ps
 819
 820 solveLockSaving :: UIMonad uiM => LockSpec -> Maybe SavedPlayState -> Maybe Int -> Lock -> Maybe String -> MaybeT (MainStateT uiM) Solution
 821 solveLockSaving ls msps tutLevel lock title = do
 822     let isTut = isJust tutLevel
 823     (InteractSuccess solved, ps) <- lift $ runSubMainState $
 824         maybe newPlayState restorePlayState msps (reframe lock) title tutLevel False True
 825     if solved
 826         then do
 827             unless isTut . lift . modify $ \ms -> ms { partialSolutions = Map.delete ls $ partialSolutions ms }
 828             return . reverse $ snd <$> psGameStateMoveStack ps
 829         else do
 830             lift $ modify $ \ms -> if isTut
 831                 then ms { tutProgress = (tutProgress ms)
 832                     { tutLevel = ls, tutPartial = Just $ savePlayState ps } }
 833                 else ms { partialSolutions = Map.insert ls (savePlayState ps) $ partialSolutions ms }
 834             mzero