intricacy 0.5.7.2 → 0.6
raw patch · 16 files changed
+164/−106 lines, 16 filesdep +email-validatedep +smtp-maildep +text
Dependencies added: email-validate, smtp-mail, text
Files
- Command.hs +3/−2
- CursesUIMInstance.hs +6/−6
- Database.hs +9/−0
- Interact.hs +51/−30
- KeyBindings.hs +2/−1
- MainState.hs +2/−1
- NEWS +8/−28
- Protocol.hs +7/−0
- SDLUI.hs +2/−2
- SDLUIMInstance.hs +26/−24
- Server.hs +37/−7
- ServerAddr.hs +6/−1
- Version.hs +1/−1
- intricacy.cabal +2/−1
- tutorial/1-winning.text +1/−1
- tutorial/5-springs.text +1/−1
Command.hs view
@@ -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"
CursesUIMInstance.hs view
@@ -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
Database.hs view
@@ -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
Interact.hs view
@@ -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
KeyBindings.hs view
@@ -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)
MainState.hs view
@@ -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
NEWS view
@@ -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.
Protocol.hs view
@@ -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
SDLUI.hs view
@@ -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]
SDLUIMInstance.hs view
@@ -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
Server.hs view
@@ -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\"." ]
ServerAddr.hs view
@@ -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
Version.hs view
@@ -11,4 +11,4 @@ module Version where version :: String-version = "0.5.7.2"+version = "0.6"
intricacy.cabal view
@@ -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
tutorial/1-winning.text view
@@ -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'
tutorial/5-springs.text view
@@ -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