diff --git a/Command.hs b/Command.hs --- a/Command.hs +++ b/Command.hs @@ -40,7 +40,7 @@ | 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 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 --- a/CursesUIMInstance.hs +++ b/CursesUIMInstance.hs @@ -239,7 +239,7 @@ 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 @@ 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 @@ 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 @@ 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 --- a/Database.hs +++ b/Database.hs @@ -37,6 +37,7 @@ data Record = RecPassword Codename + | RecEmail Codename | RecUserInfo Codename | RecUserInfoLog Codename | RecLock LockSpec @@ -44,6 +45,7 @@ | RecLockHashes | RecRetiredLocks Codename | RecServerInfo + | RecServerEmail deriving (Eq, Ord, Show) data RecordContents = RCPassword Password @@ -54,6 +56,7 @@ | RCLockHashes [String] | RCLockSpecs [LockSpec] | RCServerInfo ServerInfo + | RCEmail CS.ByteString deriving (Eq, Ord, Show) rcOfServerResp (ServedServerInfo x) = RCServerInfo x @@ -68,6 +71,7 @@ invariantRecord (RecPassword _) = False invariantRecord (RecRetiredLocks _) = False invariantRecord (RecNote _) = False +invariantRecord (RecEmail _) = False invariantRecord _ = True askForRecord RecServerInfo = GetServerInfo @@ -91,6 +95,7 @@ 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 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 @@ 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 @@ (++ ([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' (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 --- a/Interact.hs +++ b/Interact.hs @@ -192,11 +192,11 @@ 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 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 @@ 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 --- a/KeyBindings.hs +++ b/KeyBindings.hs @@ -170,7 +170,8 @@ , ('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 --- a/MainState.hs +++ b/MainState.hs @@ -152,8 +152,9 @@ 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 --- 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 --- a/Protocol.hs +++ b/Protocol.hs @@ -29,6 +29,7 @@ = Authenticate | Register | ResetPassword Password + | SetEmail String | GetServerInfo | GetLock LockSpec | GetRetired Codename @@ -38,6 +39,7 @@ | 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 @@ | ServedRandomNames [Codename] | ServerCodenameFree | ServerFresh + | ServerUndefinedResponse deriving (Eq, Ord, Show, Read) data ServerInfo = ServerInfo {serverLockSize :: Int, serverInfoString::String} @@ -89,6 +92,7 @@ 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 @@ 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 @@ 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 --- a/SDLUI.hs +++ b/SDLUI.hs @@ -389,8 +389,8 @@ (\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 --- a/SDLUIMInstance.hs +++ b/SDLUIMInstance.hs @@ -122,7 +122,7 @@ 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 @@ 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 @@ 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 @@ ] (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 --- a/Server.hs +++ b/Server.hs @@ -30,7 +30,10 @@ 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 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 @@ _ -> 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 @@ _ -> 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 @@ 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 @@ 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 @@ 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 @@ -- 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 --- a/ServerAddr.hs +++ b/ServerAddr.hs @@ -19,7 +19,12 @@ 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 --- 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 --- 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 @@ , 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 --- a/tutorial/1-winning.text +++ b/tutorial/1-winning.text @@ -1,1 +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 --- a/tutorial/5-springs.text +++ b/tutorial/5-springs.text @@ -1,1 +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