summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authormbays <>2016-03-02 20:32:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-03-02 20:32:00 (GMT)
commit0bc64b53e42dc337c65c8f8baceb3b9224f8a58b (patch)
tree8173b79860a5491a65c92d3c7f19e62baf127e41
parentc8d93511c40b9bada31a62c0c0a8e90007b81a94 (diff)
version 0.60.6
-rw-r--r--Command.hs5
-rw-r--r--CursesUIMInstance.hs12
-rw-r--r--Database.hs9
-rw-r--r--Interact.hs81
-rw-r--r--KeyBindings.hs3
-rw-r--r--MainState.hs3
-rw-r--r--NEWS36
-rw-r--r--Protocol.hs7
-rw-r--r--SDLUI.hs4
-rw-r--r--SDLUIMInstance.hs50
-rw-r--r--Server.hs44
-rw-r--r--ServerAddr.hs7
-rw-r--r--Version.hs2
-rw-r--r--intricacy.cabal3
-rw-r--r--tutorial/1-winning.text2
-rw-r--r--tutorial/5-springs.text2
16 files changed, 164 insertions, 106 deletions
diff --git a/Command.hs b/Command.hs
index bb5ea4f..bacb6e6 100644
--- a/Command.hs
+++ b/Command.hs
@@ -40,7 +40,7 @@ data Command
| CmdViewSolution (Maybe NoteInfo)
| CmdSelectLock | CmdNextLock | CmdPrevLock
| CmdEdit | CmdPlaceLock (Maybe LockIndex)
- | CmdRegister | CmdAuth
+ | CmdRegister Bool | CmdAuth
| CmdNextPage | CmdPrevPage
| CmdToggleColourMode
| CmdRedraw | CmdRefresh | CmdSuspend | CmdClear
@@ -97,7 +97,8 @@ describeCommand CmdPrevPage = "page back through lists"
describeCommand CmdEdit = "edit lock"
describeCommand (CmdPlaceLock mli) = "place lock"
++ maybe "" ((' ':).(:"").lockIndexChar) mli
-describeCommand CmdRegister = "register codename"
+describeCommand (CmdRegister False) = "register codename"
+describeCommand (CmdRegister True) = "adjust registration details"
describeCommand CmdAuth = "authenticate"
describeCommand (CmdBind _) = "bind key"
describeCommand CmdToggleColourMode = "toggle lock colour mode"
diff --git a/CursesUIMInstance.hs b/CursesUIMInstance.hs
index c6bcfb0..4423764 100644
--- a/CursesUIMInstance.hs
+++ b/CursesUIMInstance.hs
@@ -239,7 +239,7 @@ instance UIMonad (StateT UIState IO) where
when (fresh && (isNothing ourName || home || isNothing muirc)) $
drawStrGrey (CVec 2 (w`div`2+1+9)) =<<
(bindingsStr IMMeta $
- if (isNothing muirc && isNothing ourName) || home then [CmdRegister] else [CmdAuth])
+ if (isNothing muirc && isNothing ourName) || home then [CmdRegister $ isJust ourName] else [CmdAuth])
for_ muirc $ \(RCUserInfo (_,uinfo)) -> case mretired of
Just retired -> do
(h,w) <- liftIO Curses.scrSize
@@ -304,8 +304,8 @@ instance UIMonad (StateT UIState IO) where
let bdgWidth = 35
showKeys chs = intercalate "/" (map showKey chs)
maxkeyslen = maximum $ map (length.showKeys.map fst) $ groupBy ((==) `on` snd) bdgs
- drawStrCentred a0 white (CVec 0 (w`div`2)) "Bindings:"
- sequence_ [ drawStr a0 white (CVec (y+2) (x*bdgWidth) ) $
+ drawStrCentred a0 cyan (CVec 0 (w`div`2)) "Bindings:"
+ sequence_ [ drawStr a0 cyan (CVec (y+2) (x*bdgWidth) ) $
keysStr ++ replicate pad ' ' ++ ": " ++ desc |
((keysStr,pad,desc),(x,y)) <- zip [(keysStr,pad,desc)
| group <- groupBy ((==) `on` snd) $ sortBy (compare `on` snd) bdgs
@@ -325,8 +325,8 @@ instance UIMonad (StateT UIState IO) where
erase
(h,w) <- liftIO Curses.scrSize
if w >= maximum (map length metagameHelpText)
- then sequence_ [drawStrCentred a0 white (CVec line $ w`div`2) str |
- (line,str) <- zip [0..h-2] $ ["Intricacy",""] ++ metagameHelpText ]
+ then sequence_ [drawStrCentred a0 magenta (CVec line $ w`div`2) str |
+ (line,str) <- zip [0..h-2] $ ["INTRICACY",""] ++ metagameHelpText ]
else do
let wrap max = wrap' max max
wrap' _ _ [] = []
@@ -337,7 +337,7 @@ instance UIMonad (StateT UIState IO) where
else '\n' : wrap' max max (w:ws)
else let prepend = if left == max then w else ' ':w
in prepend ++ wrap' max (left - length prepend) ws
- sequence_ [drawStrCentred a0 white (CVec line $ w`div`2) str |
+ sequence_ [drawStrCentred a0 magenta (CVec line $ w`div`2) str |
(line,str) <- zip [0..h] $
lines (wrap w $ words $ intercalate " " metagameHelpText) ]
return True
diff --git a/Database.hs b/Database.hs
index 42e7d9b..36a1283 100644
--- a/Database.hs
+++ b/Database.hs
@@ -37,6 +37,7 @@ hash = CS.unpack . digestToHexByteString . sha1 . CL.pack
data Record
= RecPassword Codename
+ | RecEmail Codename
| RecUserInfo Codename
| RecUserInfoLog Codename
| RecLock LockSpec
@@ -44,6 +45,7 @@ data Record
| RecLockHashes
| RecRetiredLocks Codename
| RecServerInfo
+ | RecServerEmail
deriving (Eq, Ord, Show)
data RecordContents
= RCPassword Password
@@ -54,6 +56,7 @@ data RecordContents
| RCLockHashes [String]
| RCLockSpecs [LockSpec]
| RCServerInfo ServerInfo
+ | RCEmail CS.ByteString
deriving (Eq, Ord, Show)
rcOfServerResp (ServedServerInfo x) = RCServerInfo x
@@ -68,6 +71,7 @@ invariantRecord (RecUserInfoLog _) = False
invariantRecord (RecPassword _) = False
invariantRecord (RecRetiredLocks _) = False
invariantRecord (RecNote _) = False
+invariantRecord (RecEmail _) = False
invariantRecord _ = True
askForRecord RecServerInfo = GetServerInfo
@@ -91,6 +95,7 @@ getRecord rec = do
h <- openFile path ReadMode
getRecordh rec h <* hClose h
getRecordh (RecPassword _) h = ((RCPassword <$>) . tryRead) <$> hGetStrict h
+getRecordh (RecEmail _) h = ((RCEmail <$>) . tryRead) <$> hGetStrict h
getRecordh (RecUserInfo _) h = ((RCUserInfo <$>) . tryRead) <$> hGetStrict h
getRecordh (RecUserInfoLog _) h = ((RCUserInfoDeltas <$>) . tryRead) <$> hGetStrict h
getRecordh (RecLock _) h = ((RCLock <$>) . tryRead) <$> hGetStrict h
@@ -98,6 +103,7 @@ getRecordh (RecNote _) h = ((RCSolution <$>) . tryRead) <$> hGetStrict h
getRecordh RecLockHashes h = ((RCLockHashes <$>) . tryRead) <$> hGetStrict h
getRecordh (RecRetiredLocks name) h = ((RCLockSpecs <$>) . tryRead) <$> hGetStrict h
getRecordh RecServerInfo h = ((RCServerInfo <$>) . tryRead) <$> hGetStrict h
+getRecordh RecServerEmail h = ((RCEmail <$>) . tryRead) <$> hGetStrict h
hGetStrict h = CS.unpack <$> concatMWhileNonempty (repeat $ CS.hGet h 1024)
where concatMWhileNonempty (m:ms) = do
@@ -115,6 +121,7 @@ putRecord rec rc = do
putRecordh rc h
hClose h
putRecordh (RCPassword hpw) h = hPutStr h $ show hpw
+putRecordh (RCEmail addr) h = hPutStr h $ show addr
putRecordh (RCUserInfo info) h = hPutStr h $ show info
putRecordh (RCUserInfoDeltas deltas) h = hPutStr h $ show deltas
putRecordh (RCLock lock) h = hPutStr h $ show lock
@@ -160,6 +167,7 @@ recordPath rec =
(++ ([pathSeparator] ++ recordPath' rec)) <$> ask
where
recordPath' (RecPassword name) = userDir name ++ "passwd"
+ recordPath' (RecEmail name) = userDir name ++ "email"
recordPath' (RecUserInfo name) = userDir name ++ "info"
recordPath' (RecUserInfoLog name) = userDir name ++ "log"
recordPath' (RecLock ls) = locksDir ++ show ls
@@ -168,6 +176,7 @@ recordPath rec =
recordPath' (RecRetiredLocks name) = userDir name ++ "retired"
recordPath' RecLockHashes = "lockHashes"
recordPath' RecServerInfo = "serverInfo"
+ recordPath' RecServerEmail = "serverEmail"
userDir name = "users" ++ [pathSeparator] ++ pathifyName name ++ [pathSeparator]
alockFN (ActiveLock name idx) = pathifyName name ++":"++ show idx
diff --git a/Interact.hs b/Interact.hs
index ec02288..bc9dce9 100644
--- a/Interact.hs
+++ b/Interact.hs
@@ -192,11 +192,11 @@ processCommand' IMMeta CmdBackCodename = do
processCommand' IMMeta CmdSetServer = void.runMaybeT $ do
saddr <- gets curServer
saddrs <- liftIO $ knownServers
- newSaddr <- MaybeT $ ((>>= strToSaddr) <$>) $
+ newSaddr' <- MaybeT $ ((>>= strToSaddr) <$>) $
lift $ textInput "Set server:" 256 False False
(Just $ map saddrStr saddrs) (Just $ saddrStr saddr)
+ let newSaddr = if nullSaddr newSaddr' then defaultServerAddr else newSaddr'
modify $ \ms -> ms { curServer = newSaddr }
- guard.not $ nullSaddr newSaddr
msum [ void.MaybeT $ getFreshRecBlocking RecServerInfo
, modify (\ms -> ms { curServer = saddr }) >> mzero ]
lift $ do
@@ -211,34 +211,55 @@ processCommand' IMMeta CmdSetServer = void.runMaybeT $ do
processCommand' IMMeta CmdToggleCacheOnly =
not <$> gets cacheOnly >>= \c -> modify $ \ms -> ms {cacheOnly = c}
-processCommand' IMMeta CmdRegister = void.runMaybeT $ do
- newName <- mgetCurName
- mauth <- gets curAuth
- let isUs = maybe False ((==newName).authUser) mauth
- confirmOrBail $ if isUs then "Really reset password?" else "Register codename "++newName++"?"
- passwd <- (hashPassword newName <$>) $ MaybeT $ lift $
- textInput "Enter new password:" 64 True False Nothing Nothing
- lift $ if isUs
- then do
- resp <- curServerAction $ ResetPassword passwd
- case resp of
- ServerAck -> do
- lift $ drawMessage "New password set."
- modify $ \ms -> ms {curAuth = Just $ Auth newName passwd}
- ServerError err -> lift $ drawError err
- _ -> lift $ drawMessage $ "Bad server response: " ++ show resp
+processCommand' IMMeta (CmdRegister adjustReg) = void.runMaybeT $ do
+ regName <- mgetCurName
+ let inputPassword = (hashPassword regName <$>) $ MaybeT $ lift $
+ textInput "Enter new password:" 64 True False Nothing Nothing
+ if adjustReg
+ then msum [ do
+ confirmOrBail "Log out?"
+ modify $ \ms -> ms {curAuth = Nothing}
+ , do
+ confirmOrBail "Reset password?"
+ passwd <- inputPassword
+ lift $ do
+ resp <- curServerAction $ ResetPassword passwd
+ case resp of
+ ServerAck -> do
+ lift $ drawMessage "New password set."
+ modify $ \ms -> ms {curAuth = Just $ Auth regName passwd}
+ ServerError err -> lift $ drawError err
+ _ -> lift $ drawMessage $ "Bad server response: " ++ show resp
+ , do
+ confirmOrBail "Configure email notifications?"
+ setNotifications
+ ]
else do
- modify $ \ms -> ms {curAuth = Just $ Auth newName passwd}
- resp <- curServerAction Register
- case resp of
- ServerAck -> do
- invalidateUInfo newName
- refreshUInfoUI
- lift $ drawMessage "Registered!"
- ServerError err -> do
- lift $ drawError err
- modify $ \ms -> ms {curAuth = Nothing}
- _ -> lift $ drawMessage $ "Bad server response: " ++ show resp
+ passwd <- inputPassword
+ lift $ do
+ modify $ \ms -> ms {curAuth = Just $ Auth regName passwd}
+ resp <- curServerAction Register
+ case resp of
+ ServerAck -> do
+ invalidateUInfo regName
+ refreshUInfoUI
+ conf <- lift $ confirm "Registered! Would you like to be notified by email when someone solves your lock?"
+ if conf then void $ runMaybeT setNotifications else lift $ drawMessage "Notifications disabled."
+ ServerError err -> do
+ lift $ drawError err
+ modify $ \ms -> ms {curAuth = Nothing}
+ _ -> lift $ drawMessage $ "Bad server response: " ++ show resp
+
+ where setNotifications = do
+ address <- MaybeT $ lift $ textInput "Enter address, or leave blank to disable notifications:" 128 False False Nothing Nothing
+ lift $ do
+ resp <- curServerAction $ SetEmail address
+ case resp of
+ ServerAck -> lift $ drawMessage $ if null address then "Notifications disabled." else "Address set."
+ ServerError err -> lift $ drawError err
+ _ -> lift $ drawMessage $ "Bad server response: " ++ show resp
+
+
processCommand' IMMeta CmdAuth = void.runMaybeT $ do
auth <- lift $ gets curAuth
if isJust auth then do
@@ -430,7 +451,7 @@ processCommand' IMMeta CmdTutorials = void.runMaybeT $ do
modify $ \ms -> ms {tutProgress = (1,Nothing)}
mauth <- gets curAuth
cbdg <- lift $ getUIBinding IMMeta $ CmdSelCodename Nothing
- rbdg <- lift $ getUIBinding IMMeta CmdRegister
+ rbdg <- lift $ getUIBinding IMMeta (CmdRegister False)
if isNothing mauth
then do
let showPage p = lift $ showHelp IMMeta p >>? do
diff --git a/KeyBindings.hs b/KeyBindings.hs
index 156bf0a..2b64535 100644
--- a/KeyBindings.hs
+++ b/KeyBindings.hs
@@ -170,7 +170,8 @@ metaBindings = lowerToo
, ('S', CmdSolve Nothing)
, ('D', CmdDeclare Nothing)
, ('V', CmdViewSolution Nothing)
- , ('R', CmdRegister)
+ , ('R', CmdRegister True)
+ , ('R', CmdRegister False)
, ('P', CmdPlaceLock Nothing)
, ('E', CmdEdit)
, ('L', CmdSelectLock)
diff --git a/MainState.hs b/MainState.hs
index 023e023..84d7a0e 100644
--- a/MainState.hs
+++ b/MainState.hs
@@ -152,8 +152,9 @@ initMetaState = do
invaltvar <- atomically $ newTVar Nothing
rnamestvar <- atomically $ newTVar []
counttvar <- atomically $ newTVar 0
- (saddr, auth, path) <- confFilePath "metagame.conf" >>=
+ (saddr', auth, path) <- confFilePath "metagame.conf" >>=
liftM (fromMaybe (defaultServerAddr, Nothing, "")) . readReadFile
+ let saddr = updateDefaultSAddr saddr'
let names = maybeToList $ authUser <$> auth
(undecls,partials,tut) <- readServerSolns saddr
mlock <- fullLockPath path >>= readLock
diff --git a/NEWS b/NEWS
index da6fad2..22c360f 100644
--- a/NEWS
+++ b/NEWS
@@ -1,36 +1,16 @@
This is an abbreviated summary; see the git log for gory details.
-0.5.7.2:
- Fix ghc-7.10 compiler warnings.
- Minor fixes for curses mode.
-0.5.7.1:
- Fix missing files in source dist.
-0.5.7:
- Allow cancellation of server requests if the server doesn't respond.
- Minor UI tweaks.
-0.5.6:
- Support OS X (thanks Kevin Eaves).
- Rework setting dimensions.
-0.5.5:
- Save solutions-in-progress of locks and tutorial.
- Indicate when there's a pending request.
- Show alerts on redo in play mode.
-0.5.4:
- Fixed some UI bugs involving mode transitions and buttons.
- Hover help on tools in tutorials.
- Actually support ghc-7.10.
-0.5.3:
- Change direction of mousewheel movements for undo/redo
- (to agree with English language metaphors with time: up = future).
- Tutorial fiddling, including new level on springs.
- Support ghc-7.10 (hopefully).
-0.5.2:
- Fix cache paths on windows.
-0.5.1:
+0.6:
New scoring system - you don't get the point for a solution if the lock
owner has read your note.
+ Server optionally notifies users by email when their locks are solved.
Server produces RSS feeds.
- Improve handling of switching server.
+ Save solutions-in-progress of locks and tutorial.
+ Indicate when there's a pending network request, and allow cancellation.
+ Support ghc-7.10.
+ Support OS X (thanks Kevin Eaves).
+ Further tweaks to UI and tutorials.
+
0.5:
Adjustments to graphics, tutorial, and metagame UI, to increase clarity.
Concurrency on server; no more freezes while it checks a solution.
diff --git a/Protocol.hs b/Protocol.hs
index 571dede..e9976c5 100644
--- a/Protocol.hs
+++ b/Protocol.hs
@@ -29,6 +29,7 @@ data Action
= Authenticate
| Register
| ResetPassword Password
+ | SetEmail String
| GetServerInfo
| GetLock LockSpec
| GetRetired Codename
@@ -38,6 +39,7 @@ data Action
| DeclareSolution Solution LockSpec ActiveLock LockIndex
| SetLock Lock LockIndex Solution
| GetRandomNames Int
+ | UndefinedAction
deriving (Eq, Ord, Show, Read)
data Auth = Auth {authUser :: Codename, authPasswd :: Password}
@@ -66,6 +68,7 @@ data ServerResponse
| ServedRandomNames [Codename]
| ServerCodenameFree
| ServerFresh
+ | ServerUndefinedResponse
deriving (Eq, Ord, Show, Read)
data ServerInfo = ServerInfo {serverLockSize :: Int, serverInfoString::String}
@@ -89,6 +92,7 @@ instance Binary Action where
put (GetRandomNames n) = put (9::Word8) >> put n
put (ResetPassword pw) = put (10::Word8) >> put pw
put (GetRetired name) = put (11::Word8) >> put name
+ put (SetEmail address) = put (12::Word8) >> put address
get = do
tag <- get :: Get Word8
case tag of
@@ -104,6 +108,8 @@ instance Binary Action where
9 -> liftM GetRandomNames get
10 -> liftM ResetPassword get
11 -> liftM GetRetired get
+ 12 -> liftM SetEmail get
+ _ -> return UndefinedAction
instance Binary Auth where
put (Auth name pw) = put name >> put pw
@@ -139,6 +145,7 @@ instance Binary ServerResponse where
10 -> return ServerCodenameFree
11 -> return ServerFresh
12 -> liftM ServedRetired get
+ _ -> return ServerUndefinedResponse
instance Binary ServerInfo where
put (ServerInfo sz str) = put sz >> put str
get = liftM2 ServerInfo get get
diff --git a/SDLUI.hs b/SDLUI.hs
index 570eb44..4358c60 100644
--- a/SDLUI.hs
+++ b/SDLUI.hs
@@ -389,8 +389,8 @@ uiOB3 = UIOptButton whsButtons (\v o -> o {whsButtons=v}) [Nothing, Just WHSSele
(\v -> case v of
Nothing -> "Click to show (and rebind) keyboard control buttons."
Just whs -> "Showing buttons for controlling " ++ case whs of
- WHSSelected -> "selected piece"
- WHSWrench -> "wrench"
+ WHSSelected -> "selected piece; right-click to rebind"
+ WHSWrench -> "wrench; right-click to rebind"
WHSHook -> "hook; right-click to rebind")
[IMPlay, IMEdit] Nothing
uiOB4 = UIOptButton showButtonText (\v o -> o {showButtonText=v}) [True,False]
diff --git a/SDLUIMInstance.hs b/SDLUIMInstance.hs
index 460bf03..db1bfe6 100644
--- a/SDLUIMInstance.hs
+++ b/SDLUIMInstance.hs
@@ -122,7 +122,7 @@ instance UIMonad (StateT UIState IO) where
lift $ renderToMain $ (erase >> drawCursorAt Nothing)
lift $ do
smallFont <- gets dispFontSmall
- renderToMain $ withFont smallFont $ renderStrColAtLeft messageCol
+ renderToMain $ withFont smallFont $ renderStrColAtLeft purple
(saddrStr saddr ++ if cOnly then " (cache only)" else "")
$ serverPos +^ hu
@@ -142,9 +142,9 @@ instance UIMonad (StateT UIState IO) where
renderStrColBelow (opaquify $ dim errorCol) str $ codenamePos
maybe (return ()) (setMsgLineNoRefresh errorCol) err
when (fresh && (isNothing ourName || isNothing muirc || home)) $
- let reg = isNothing muirc && isNothing ourName
+ let reg = isNothing muirc || isJust ourName
in registerButton (codenamePos +^ 2*^hu)
- (if reg then CmdRegister else CmdAuth)
+ (if reg then CmdRegister $ isJust ourName else CmdAuth)
(if isNothing ourName then 2 else 0)
[(if reg then "reg" else "auth", 3*^hw)]
(if isJust muirc then drawName else drawNullName) name codenamePos
@@ -537,27 +537,29 @@ instance UIMonad (StateT UIState IO) where
let bdgWidth = (screenWidthHexes-6) `div` 3
showKeys chs = intercalate "/" (map showKeyFriendly chs)
maxkeyslen = maximum . (0:) $ map (length.showKeys.map fst) $ groupBy ((==) `on` snd) bdgs
- extraHelpStrs = ["Mouse commands:", "Right-click on a button to set a keybinding;"]
+ extraHelpStrs = [["Mouse commands:", "Right-click on a button to set a keybinding;"]
+ ++ case mode of
+ IMPlay -> ["Click on tool to select, drag to move;",
+ "Click by tool to move; right-click to wait;", "Scroll wheel to rotate hook;",
+ "Scroll wheel with right button held down to undo/redo."]
+ IMEdit -> ["Left-click to draw selected; scroll to change selection;",
+ "Right-click on piece to select, drag to move;",
+ "While holding right-click: left-click to advance time, middle-click to delete;",
+ "Scroll wheel to rotate selected piece; scroll wheel while held down to undo/redo."]
+ IMReplay -> ["Scroll wheel with right button held down to undo/redo."]
+ IMMeta -> ["Left-clicking on something does most obvious thing;"
+ , "Right-clicking does second-most obvious thing."]]
++ case mode of
- IMPlay -> ["Click on tool to select, drag to move;",
- "Click by tool to move; right-click to wait;", "Scroll wheel to rotate hook;",
- "Scroll wheel with right button held down to undo/redo."]
- IMEdit -> ["Left-click to draw selected; scroll to change selection;",
- "Right-click on piece to select, drag to move;",
- "While holding right-click: left-click to advance time, middle-click to delete;",
- "Scroll wheel to rotate selected piece; scroll wheel while held down to undo/redo."]
- IMReplay -> ["Scroll wheel with right button held down to undo/redo."]
- IMMeta -> ["Left-clicking on something does most obvious thing;"
- , "Right-clicking does second-most obvious thing."
- , ""
- , "Basic game instructions:"
+ IMMeta -> [[
+ "Basic game instructions:"
, "Choose [C]odename, then [R]egister it;"
, "select other players, and [S]olve their locks;"
, "go [H]ome, then [E]dit and [P]lace a lock of your own;"
, "you can then [D]eclare your solutions."
- , "Make other players green by solving their locks and not letting them solve yours."]
- renderStrColAt messageCol "Keybindings:" $ (screenHeightHexes`div`4)*^(hv+^neg hw)
- let keybindingsHeight = screenHeightHexes - (3 + length extraHelpStrs)
+ , "Make other players green by solving their locks and not letting them solve yours."]]
+ _ -> []
+ renderStrColAt cyan "Keybindings:" $ (screenHeightHexes`div`4)*^(hv+^neg hw)
+ let keybindingsHeight = screenHeightHexes - (3 + length extraHelpStrs + sum (map length extraHelpStrs))
sequence_ [ with $ renderStrColAtLeft messageCol
( keysStr ++ ": " ++ desc )
$ (x*bdgWidth-(screenWidthHexes-6)`div`2)*^hu +^ neg hv +^
@@ -576,24 +578,24 @@ instance UIMonad (StateT UIState IO) where
]
(map (`divMod` keybindingsHeight) [0..])
, (x+1)*bdgWidth < screenWidthHexes]
- sequence_ [ renderStrColAt messageCol str
+ sequence_ [ renderStrColAt (if firstLine then cyan else messageCol) str
$ (screenHeightHexes`div`4 - y`div`2)*^(hv+^neg hw)
+^ hw
+^ (y`mod`2)*^hw
- | (str,y) <- zip extraHelpStrs [keybindingsHeight..] ]
+ | ((str,firstLine),y) <- (intercalate [("",False)] $ (map (`zip` (True:repeat False)) extraHelpStrs)) `zip` [(keybindingsHeight+1)..] ]
refresh
return True
showHelp IMMeta HelpPageGame = do
renderToMain $ do
erase
let headPos = (screenHeightHexes`div`4)*^(hv+^neg hw)
- renderStrColAt messageCol "Intricacy" headPos
+ renderStrColAt red "INTRICACY" headPos
sequence_
- [ renderStrColAt messageCol str $
+ [ renderStrColAt purple str $
headPos
+^ (y`div`2)*^(hw+^neg hv)
+^ (y`mod`2)*^hw
- | (y,str) <- zip [2..]
+ | (y,str) <- zip [1..]
metagameHelpText
]
return True
diff --git a/Server.hs b/Server.hs
index 0ad94f1..b714b22 100644
--- a/Server.hs
+++ b/Server.hs
@@ -30,7 +30,10 @@ import System.IO
import System.FilePath
import System.Directory (renameFile)
import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Char8 as CS
import qualified Data.Binary as B
+import qualified Data.Text as TS
+import qualified Data.Text.Lazy as TL
import Data.Array
import Control.Exception
import System.IO.Error
@@ -46,6 +49,9 @@ import Text.XML.Light.Output (showTopElement)
import Data.Time.Format
import Data.Time.LocalTime
+import qualified Text.Email.Validate
+import qualified Network.Mail.SMTP as SMTP
+
import System.Environment
import System.Console.GetOpt
import System.Exit
@@ -181,13 +187,10 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
_ -> ReadWriteMode
-- check solutions prior to write-locking database:
- eresp <- runExceptT $ do
- withDBLock dbpath ReadMode $ checkRequest
- withDBLock dbpath lockMode $ handleRequest'
- case eresp of
- Left error -> return $ ServerError error
- Right resp -> return resp
-
+ (withDBLock dbpath ReadMode $ runExceptT checkRequest) >>=
+ either (return . ServerError) (const $
+ withDBLock dbpath lockMode $ runExceptT handleRequest' >>=
+ either (return . ServerError) return)
where
checkRequest = do
when (pv /= protocolVersion) $ throwE "Bad protocol version"
@@ -221,6 +224,7 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
_ -> return ()
handleRequest' =
case action of
+ UndefinedAction -> throwE "Request not recognised by this server"
Authenticate -> do
checkAuth auth
return $ ServerMessage $ "Welcome, " ++ authUser (fromJust auth)
@@ -229,6 +233,7 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
doNews $ "New user " ++ authUser (fromJust auth) ++ " registered."
return ServerAck
ResetPassword passwd -> resetPassword auth passwd >> return ServerAck
+ SetEmail address -> setEmail auth address >> return ServerAck
GetServerInfo -> ServedServerInfo <$> getServerInfo
GetLock ls -> ServedLock <$> getLock ls
GetRetired name -> ServedRetired <$> getRetired name
@@ -271,6 +276,7 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
doNews $ name ++ " declares solution to "
++ alockStr target ++ ", securing their note behind "
++ alockStr behind ++ "."
+ mailDeclaration target behind
return ServerAck
SetLock lock@(frame,_) idx soln -> do
info <- getUserInfoOfAuth auth
@@ -374,6 +380,14 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
resetPassword auth@(Just (Auth name _)) newpw = do
checkAuth auth
erroredDB $ putRecord (RecPassword name) (RCPassword newpw)
+ setEmail Nothing _ = throwE "Authentication required"
+ setEmail auth@(Just (Auth name _)) addressStr = do
+ checkAuth auth
+ serverAddr <- erroredDB $ getRecord RecServerEmail
+ when (isNothing serverAddr) $ throwE "This server is not configured to support email notifications."
+ let addr = CS.pack addressStr
+ when (not $ CS.null addr || Text.Email.Validate.isValid addr) $ throwE "Invalid email address"
+ erroredDB $ putRecord (RecEmail name) (RCEmail addr)
checkCodeName :: Codename -> ExceptT String IO Bool
checkCodeName name = do
unless (validCodeName name) $ throwE "Invalid codename"
@@ -461,3 +475,19 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
-- TODO: purge old entries
writeFile feedPath $ showTopElement $ xmlFeed $
withFeedLastUpdate time $ addItem item feed
+ mailDeclaration target@(ActiveLock name _) behind@(ActiveLock solverName _) = runMaybeT $ do
+ let makeAddr :: CS.ByteString -> SMTP.Address
+ makeAddr bs = SMTP.Address Nothing $ TS.pack $ CS.unpack bs
+ RCEmail serverAddr <- MaybeT $ erroredDB $ getRecord RecServerEmail
+ RCEmail playerAddr <- MaybeT $ erroredDB $ getRecord $ RecEmail name
+ guard $ not $ CS.null playerAddr
+ lift.lift $ SMTP.sendMail "localhost" $ SMTP.simpleMail (makeAddr serverAddr)
+ [makeAddr playerAddr] [] []
+ (TS.pack $ "[Intricacy] " ++ alockStr target ++" solved by " ++ solverName)
+ [SMTP.plainTextPart $ TL.pack $ "A solution to your lock " ++ alockStr target ++ " has been declared by " ++ solverName ++
+ " and secured behind " ++ alockStr behind ++ "." ++
+ "\n\n-----\n\nYou received this email from the game Intricacy" ++
+ "\n\thttp://sdf.org/~mbays/intricacy ." ++
+ "\nYou can disable notifications in-game by pressing 'R' on your home" ++
+ "\nscreen and setting an empty address." ++
+ "\nAlternatively, just reply to this email with the phrase \"stop bugging me\"." ]
diff --git a/ServerAddr.hs b/ServerAddr.hs
index 358cb9f..1840b7a 100644
--- a/ServerAddr.hs
+++ b/ServerAddr.hs
@@ -19,7 +19,12 @@ data ServerAddr = ServerAddr {hostname::String, port::Int}
nullSaddr (ServerAddr host _) = null host
defaultPort=27001 -- == ('i'<<8) + 'y'
-defaultServerAddr = ServerAddr "thegonz.net" defaultPort
+defaultServerAddr = ServerAddr "i.thegonz.net" defaultPort
+oldDefaultServerAddrs = [ServerAddr "thegonz.net" defaultPort]
+
+updateDefaultSAddr :: ServerAddr -> ServerAddr
+updateDefaultSAddr saddr | saddr `elem` oldDefaultServerAddrs = defaultServerAddr
+updateDefaultSAddr saddr = saddr
saddrStr (ServerAddr h p) = h ++ if p==defaultPort then "" else ':':show p
diff --git a/Version.hs b/Version.hs
index 5078218..2f9297e 100644
--- a/Version.hs
+++ b/Version.hs
@@ -11,4 +11,4 @@
module Version where
version :: String
-version = "0.5.7.2"
+version = "0.6"
diff --git a/intricacy.cabal b/intricacy.cabal
index 8c50cfb..49ba68b 100644
--- a/intricacy.cabal
+++ b/intricacy.cabal
@@ -1,5 +1,5 @@
name: intricacy
-version: 0.5.7.2
+version: 0.6
synopsis: A game of competitive puzzle-design
homepage: http://mbays.freeshell.org/intricacy
license: GPL-3
@@ -117,6 +117,7 @@ executable intricacy-server
, cryptohash >= 0.8
, random >= 1.0, pipes >= 4
, feed >= 0.3.1, xml >= 1.2.6
+ , email-validate >= 1.0.0, text, smtp-mail >= 0.1.4.1
else
Buildable: False
main-is: Server.hs
diff --git a/tutorial/1-winning.text b/tutorial/1-winning.text
index 7895ae6..20617c1 100644
--- a/tutorial/1-winning.text
+++ b/tutorial/1-winning.text
@@ -1 +1 @@
-drag your tools, the hook and the wrench, to pull the bolt aside; then press 'O'.
+drag your tools to pull the bolt aside, then press 'O'
diff --git a/tutorial/5-springs.text b/tutorial/5-springs.text
index 0eda550..056cd9a 100644
--- a/tutorial/5-springs.text
+++ b/tutorial/5-springs.text
@@ -1 +1 @@
-A spring's length can double when stretched, and halve when compressed.
+A spring's length can double when stretched, and halve when compressed