intricacy 0.5.7.1 → 0.5.7.2

raw patch · 11 files changed

+82/−63 lines, 11 filesdep ~mtldep ~transformers

Dependency ranges changed: mtl, transformers

Files

• CVec.hs +3/−0
• CursesUI.hs +2/−1
• CursesUIMInstance.hs +17/−3
• Interact.hs +9/−11
• InteractUtil.hs +0/−1
• MainState.hs +0/−3
• Metagame.hs +4/−2
• NEWS +3/−0
• Server.hs +38/−38
• Version.hs +1/−1
• intricacy.cabal +5/−3

@@ -26,3 +26,6 @@ hexVec2CVec (HexVec x y z) = CVec (-y) (x-z) cVec2HexVec :: CVec -> HexVec cVec2HexVec (CVec y x) = HexVec ((x+y)`div`2) (-y) ((y-x)`div`2)++truncateCVec :: CVec -> CVec+truncateCVec (CVec x y) = CVec (max 0 x) (max 0 y)

@@ -102,7 +102,8 @@ drawStrGrey = drawStr a0 0 drawStrCentred :: Curses.Attr -> ColPair -> CVec -> [Char] -> UIM () drawStrCentred attr col v str =-    drawStr attr col (v +^ CVec 0 (-length str `div` 2)) str+    drawStr attr col (truncateCVec $ (v +^ CVec 0 (-length str `div` 2))) str+  drawCursorAt :: Maybe HexPos -> UIM () drawCursorAt Nothing =

@@ -324,8 +324,22 @@     showHelp IMMeta HelpPageGame = do 	erase 	(h,w) <- liftIO Curses.scrSize-	sequence_ [drawStrCentred a0 white (CVec line $ w`div`2) str |-	    (line,str) <- zip [0..h-2] $ ["Intricacy",""] ++ metagameHelpText ]+	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 ]+	    else do+		let wrap max = wrap' max max+		    wrap' _ _ [] = []+		    wrap' max left (w:ws) = if 1+length w > left+			then if left == max+			    then take max w ++ "\n" +++				wrap' max max (drop max w : ws)+			    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 |+		    (line,str) <- zip [0..h] $+			lines (wrap w $ words $ intercalate " " metagameHelpText) ] 	return True     showHelp _ _ = return False @@ -386,5 +400,5 @@ 		    unblockBinding = (toEnum 0, CmdRefresh) -- c.f. unblockInput above 		flip (maybe $ return []) mch $ \ch -> 		    if mode == IMTextInput-		    then return [CmdInputChar ch]+		    then return $ [ CmdInputChar ch `fromMaybe` lookup ch [unblockBinding] ] 		    else (maybeToList . lookup ch . (unblockBinding:)) <$> getBindings mode

@@ -16,7 +16,7 @@ import qualified Data.Map as Map import Data.Map (Map) import Control.Monad.Writer-import Control.Monad.Trans.Error+import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Data.Maybe import Data.Char@@ -51,8 +51,6 @@ import Util  newtype InteractSuccess = InteractSuccess Bool-instance Error InteractSuccess where-    noMsg = InteractSuccess False  interactUI :: UIMonad uiM => MainStateT uiM InteractSuccess interactUI = do@@ -82,7 +80,7 @@ 		mourNameSelected >>? lift purgeInvalidUndecls 	    drawMainState 	    cmds <- lift $ getSomeInput im-	    runErrorT (mapM_ (processCommand im) cmds) >>=+	    runExceptT (mapM_ (processCommand im) cmds) >>= 		either 		    ((lift (drawMessage "") >>) . return) 		    (const interactLoop)@@ -109,25 +107,25 @@     cmds <- getInput im     if null cmds then getSomeInput im else return cmds -processCommand :: UIMonad uiM => InputMode -> Command -> ErrorT InteractSuccess (MainStateT uiM) ()+processCommand :: UIMonad uiM => InputMode -> Command -> ExceptT InteractSuccess (MainStateT uiM) () processCommand im CmdQuit = do     case im of-	IMReplay -> throwError $ InteractSuccess False+	IMReplay -> throwE $ InteractSuccess False 	IMPlay -> lift (or <$> sequence [gets psIsSub, null <$> gets psGameStateMoveStack])-	    >>? throwError $ InteractSuccess False-	IMEdit -> lift editStateUnsaved >>! throwError $ InteractSuccess True+	    >>? throwE $ InteractSuccess False+	IMEdit -> lift editStateUnsaved >>! throwE $ InteractSuccess True 	_ -> return ()     title <- lift $ getTitle     (lift . lift . confirm) ("Really quit" 	    ++ (if im == IMEdit then " without saving" else "") 	    ++ maybe "" (" from "++) title ++ "?")-	>>? throwError $ InteractSuccess False-processCommand im CmdForceQuit = throwError $ InteractSuccess False+	>>? throwE $ InteractSuccess False+processCommand im CmdForceQuit = throwE $ InteractSuccess False processCommand IMPlay CmdOpen = do     st <- gets psCurrentState     frame <- gets psFrame     if checkSolved (frame,st)-	then throwError $ InteractSuccess True+	then throwE $ InteractSuccess True 	else lift.lift $ drawError "Locked!" processCommand im cmd = lift $ processCommand' im cmd 

@@ -15,7 +15,6 @@ import qualified Data.Map as Map import Data.Map (Map) import Control.Monad.Writer-import Control.Monad.Trans.Error import Control.Monad.Trans.Maybe import Data.Maybe import Data.Char

@@ -16,7 +16,6 @@ import qualified Data.Map as Map import Data.Map (Map) import Control.Monad.Writer-import Control.Monad.Trans.Error import Control.Monad.Trans.Maybe import Data.Maybe import Data.Char@@ -236,8 +235,6 @@     st <- MaybeT $ gets $ headMay.esGameStateStack     guard $ st == st'     return soln--instance Error () where noMsg = ()  mgetOurName :: (UIMonad uiM) => MaybeT (MainStateT uiM) Codename mgetOurName = MaybeT $ (authUser <$>) <$> gets curAuth

@@ -71,8 +71,10 @@ 	mlinfos  countRead :: UserInfo -> LockInfo -> Int-countRead reader tlock = fromIntegral $ length $-	filter (\n -> isNothing (noteBehind n) || n `elem` notesRead reader) $ lockSolutions tlock+countRead reader tlock = fromIntegral $ length+	$ filter (\n -> (isNothing (noteBehind n) || n `elem` notesRead reader)+	    && noteAuthor n /= codename reader)+	$ lockSolutions tlock  data UserInfoDelta     = AddRead NoteInfo

@@ -1,5 +1,8 @@ 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:

@@ -16,7 +16,7 @@ import Control.Applicative import Control.Monad import Control.Monad.Trans.State-import Control.Monad.Trans.Error+import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Control.Monad.Trans@@ -181,7 +181,7 @@ 	    _ -> ReadWriteMode      -- check solutions prior to write-locking database:-    eresp <- runErrorT $ do+    eresp <- runExceptT $ do 	withDBLock dbpath ReadMode $ checkRequest 	withDBLock dbpath lockMode $ handleRequest'     case eresp of@@ -190,34 +190,34 @@      where 	checkRequest = do-	    when (pv /= protocolVersion) $ throwError "Bad protocol version"+	    when (pv /= protocolVersion) $ throwE "Bad protocol version" 	    case action of 		DeclareSolution soln ls target idx -> do 		    info <- getUserInfoOfAuth auth 		    lock <- getLock ls 		    tinfo <- getALock target-		    when (ls /= lockSpec tinfo) $ throwError "Lock no longer in use!"-		    when (public tinfo) $ throwError "Lock solution already public knowledge!"+		    when (ls /= lockSpec tinfo) $ throwE "Lock no longer in use!"+		    when (public tinfo) $ throwE "Lock solution already public knowledge!" 		    let name = codename info 		    let behind = ActiveLock name idx 		    when (name `elem` map noteAuthor (lockSolutions tinfo)) $-			throwError "Note already taken on that lock!"+			throwE "Note already taken on that lock!" 		    when (name == lockOwner target) $-			throwError "That's your lock!"+			throwE "That's your lock!" 		    behindLock <- getALock behind-		    when (public behindLock) $ throwError "Your lock is cracked!"-		    unless (checkSolution lock soln) $ throwError "Bad solution"+		    when (public behindLock) $ throwE "Your lock is cracked!"+		    unless (checkSolution lock soln) $ throwE "Bad solution" 		SetLock lock@(frame,_) idx soln -> do 		    ServerInfo serverSize _ <- getServerInfo-		    when (frame /= BasicFrame serverSize) $ throwError $+		    when (frame /= BasicFrame serverSize) $ throwE $ 			"Server only accepts size "++show serverSize++" locks."-		    unless (validLock $ reframe lock) $ throwError "Invalid lock!"-		    unless (not.checkSolved $ reframe lock) $ throwError "Lock not locked!"+		    unless (validLock $ reframe lock) $ throwE "Invalid lock!"+		    unless (not.checkSolved $ reframe lock) $ throwE "Lock not locked!" 		    RCLockHashes hashes <- getRecordErrored RecLockHashes-			    `catchError` const (return (RCLockHashes []))+			    `catchE` const (return (RCLockHashes [])) 		    let hashed = hash $ show lock-		    when (hashed `elem` hashes) $ throwError "Lock has already been used"-		    unless (checkSolution lock soln) $ throwError "Bad solution"+		    when (hashed `elem` hashes) $ throwE "Lock has already been used"+		    unless (checkSolution lock soln) $ throwE "Bad solution" 		_ -> return () 	handleRequest' = 	    case action of@@ -244,7 +244,7 @@ 				] 			    , return $ ServedUserInfo (curV,info) 			    ]-		    ) `catchError` \_ -> return ServerCodenameFree+		    ) `catchE` \_ -> return ServerCodenameFree 		GetSolution note -> do 		    uinfo <- getUserInfoOfAuth auth 		    let uname = codename uinfo@@ -259,8 +259,8 @@ 			    || note `elem` notesRead uinfo 			then if public onLinfo || uname `elem` accessedBy onLinfo 			    then ServedSolution <$> getSolution note-			    else throwError "You can't wholly decipher that note."-			else throwError "You don't have access to that note."+			    else throwE "You can't wholly decipher that note."+			else throwE "You don't have access to that note." 		DeclareSolution soln ls target idx -> do 		    info <- getUserInfoOfAuth auth 		    let name = codename info@@ -277,7 +277,7 @@ 		    let name = codename info 		    let al = ActiveLock name idx 		    RCLockHashes hashes <- getRecordErrored RecLockHashes-			    `catchError` const (return (RCLockHashes []))+			    `catchE` const (return (RCLockHashes [])) 		    let hashed = hash $ show lock 		    erroredDB $ putRecord RecLockHashes $ RCLockHashes $ hashed:hashes @@ -312,21 +312,21 @@ 			>-> P.take n -- try to take as many as we were asked for 		    liftIO newStdGen 		    return $ ServedRandomNames shuffled-		_ -> throwError "BUG: bad request"-	erroredIO :: IO a -> ErrorT String IO a+		_ -> throwE "BUG: bad request"+	erroredIO :: IO a -> ExceptT String IO a 	erroredIO c = do 	    ret <- liftIO $ catchIO (Right <$> c) (return.Left) 	    case ret of-		Left e -> throwError $ "Server IO error: " ++ show e+		Left e -> throwE $ "Server IO error: " ++ show e 		Right x -> return x-	erroredDB :: DBM a -> ErrorT String IO a+	erroredDB :: DBM a -> ExceptT String IO a 	erroredDB = erroredIO . withDB dbpath-	getRecordErrored :: Record -> ErrorT String IO RecordContents+	getRecordErrored :: Record -> ExceptT String IO RecordContents 	getRecordErrored rec = do 	    mrc <- lift $ withDB dbpath $ getRecord rec 	    case mrc of 		Just rc -> return rc-		Nothing -> throwError $ "Bad record on server! Record was: " ++ show rec+		Nothing -> throwE $ "Bad record on server! Record was: " ++ show rec 	getLock ls = do 	    RCLock lock <- getRecordErrored $ RecLock ls 	    return lock@@ -343,10 +343,10 @@ 	    info <- getUserInfo name 	    checkValidLockIndex idx 	    case ((!idx).userLocks) info of-		Nothing -> throwError "Lock not set"+		Nothing -> throwE "Lock not set" 		Just lockinfo -> return lockinfo 	checkValidLockIndex idx =-	    unless (0<=idx && idx < maxLocks) $ throwError "Bad lock index"+	    unless (0<=idx && idx < maxLocks) $ throwE "Bad lock index" 	getUserInfo name = do 	    RCUserInfo (version,info) <- getRecordErrored $ RecUserInfo name 	    return info@@ -355,31 +355,31 @@ 	    let Just (Auth name _) = auth 	    getUserInfo name -	checkAuth :: Maybe Auth -> ErrorT String IO ()-	checkAuth Nothing = throwError "Authentication required"+	checkAuth :: Maybe Auth -> ExceptT String IO ()+	checkAuth Nothing = throwE "Authentication required" 	checkAuth (Just (Auth name pw)) = do 	    exists <- checkCodeName name-	    unless exists $ throwError "No such user"+	    unless exists $ throwE "No such user" 	    RCPassword pw' <- getRecordErrored (RecPassword name)-	    when (pw /= pw') $ throwError "Wrong password"-	newUser :: Maybe Auth -> ErrorT String IO ()-	newUser Nothing = throwError "Require authentication"+	    when (pw /= pw') $ throwE "Wrong password"+	newUser :: Maybe Auth -> ExceptT String IO ()+	newUser Nothing = throwE "Require authentication" 	newUser (Just (Auth name pw)) = do 	    exists <- checkCodeName name-	    when exists $ throwError "Codename taken"+	    when exists $ throwE "Codename taken" 	    erroredDB $ putRecord (RecPassword name) (RCPassword pw) 	    erroredDB $ putRecord (RecUserInfo name) (RCUserInfo $ (1,initUserInfo name)) 	    erroredDB $ putRecord (RecUserInfoLog name) (RCUserInfoDeltas [])-	resetPassword Nothing pw = throwError "Authentication required"+	resetPassword Nothing pw = throwE "Authentication required" 	resetPassword auth@(Just (Auth name _)) newpw = do 	    checkAuth auth 	    erroredDB $ putRecord (RecPassword name) (RCPassword newpw)-	checkCodeName :: Codename -> ErrorT String IO Bool+	checkCodeName :: Codename -> ExceptT String IO Bool 	checkCodeName name = do-	    unless (validCodeName name) $ throwError "Invalid codename"+	    unless (validCodeName name) $ throwE "Invalid codename" 	    liftIO $ withDB dbpath $ recordExists $ RecPassword name 	--- | TODO: journalling so we can survive death during database writes?-	applyDeltasToRecords :: [(Codename, UserInfoDelta)] -> ErrorT String IO ()+	applyDeltasToRecords :: [(Codename, UserInfoDelta)] -> ExceptT String IO () 	applyDeltasToRecords nds = sequence_ $ [applyDeltasToRecord name deltas 		| group <- groupBy ((==) `on` fst) nds 		, let name = fst $ head group

@@ -11,4 +11,4 @@ module Version where  version :: String-version = "0.5.7.1"+version = "0.5.7.2"

@@ -1,5 +1,5 @@ name:                intricacy-version:             0.5.7.1+version:             0.5.7.2 synopsis:            A game of competitive puzzle-design homepage:            http://mbays.freeshell.org/intricacy license:             GPL-3@@ -52,7 +52,7 @@   if flag(Game)       extensions: DoAndIfThenElse       build-depends: base >=4.3, base < 5-        , mtl >=2.0, transformers >=0.2, stm >= 2.1+        , mtl >=2.2, transformers >=0.4, stm >= 2.1         , directory >= 1.0, filepath >= 1.0, time >= 1.2         , bytestring >=0.10         , array >=0.3, containers >=0.4, vector >=0.9@@ -97,6 +97,7 @@         -- False... but this will have to do for now:         build-depends: Unsatisfiable >= 1337 +  ghc-options: -fno-warn-tabs   other-modules: AsciiLock, BinaryInstances, BoardColouring, Cache, Command,       CursesRender, CursesUI, CursesUIMInstance, CVec, Database, Debug,       EditGameState, Frame, GameState, GameStateTypes, GraphColouring, Hex, Init,@@ -108,7 +109,7 @@   if flag(Server)       extensions: DoAndIfThenElse       build-depends: base >=4.3, base < 5-        , mtl >=2.0, transformers >=0.2, stm >= 2.1+        , mtl >=2.2, transformers >=0.4, stm >= 2.1         , directory >= 1.0, filepath >= 1.0, time >= 1.5         , bytestring >=0.10         , array >=0.3, containers >=0.4, vector >=0.9@@ -119,6 +120,7 @@   else     Buildable: False   main-is:  Server.hs+  ghc-options: -fno-warn-tabs   other-modules: AsciiLock, BinaryInstances, BoardColouring, CVec, Database,       Debug, Frame, GameState, GameStateTypes, GraphColouring, Hex, Lock,       Maxlocksize, Metagame, Mundanities, Physics, Protocol, Util, Version