intricacy 0.7.1.1 → 0.7.2
raw patch · 16 files changed
+165/−95 lines, 16 filesdep +argon2dep +semigroupsdep +text-short
Dependencies added: argon2, semigroups, text-short
Files
- CVec.hs +4/−1
- CursesUI.hs +5/−2
- CursesUIMInstance.hs +1/−1
- Database.hs +12/−7
- Hex.lhs +4/−1
- Interact.hs +12/−11
- InteractUtil.hs +6/−5
- MainState.hs +16/−15
- NEWS +6/−2
- SDLGlyph.hs +3/−5
- SDLRender.hs +36/−26
- SDLUI.hs +13/−6
- SDLUIMInstance.hs +2/−2
- Server.hs +36/−7
- Version.hs +1/−1
- intricacy.cabal +8/−3
CVec.hs view
@@ -11,13 +11,16 @@ module CVec where import Hex+import Data.Semigroup as Sem import Data.Monoid data CVec = CVec { cy, cx :: Int } deriving (Eq, Ord, Show)+instance Sem.Semigroup CVec where+ (CVec y x) <> (CVec y' x') = CVec (y+y') (x+x') instance Monoid CVec where mempty = CVec 0 0- mappend (CVec y x) (CVec y' x') = CVec (y+y') (x+x')+ mappend = (Sem.<>) instance Grp CVec where neg (CVec y x) = CVec (-y) (-x) type CCoord = PHS CVec
CursesUI.hs view
@@ -15,6 +15,7 @@ import Control.Applicative import qualified Data.Map as Map import Data.Map (Map)+import Data.Semigroup as Sem import Data.Monoid import Data.Array import Data.Maybe@@ -87,10 +88,12 @@ GravRight -> max 0 $ w - w' _ -> max 0 . (`div` 2) $ w - w' +instance Sem.Semigroup Draw where+ (Draw w d) <> (Draw w' d') =+ Draw (w+w') $ \cpos@(CVec y x) -> d cpos >> d' (CVec y (x+w)) instance Monoid Draw where mempty = Draw 0 (const $ return ())- mappend (Draw w d) (Draw w' d') =- Draw (w+w') $ \cpos@(CVec y x) -> d cpos >> d' (CVec y (x+w))+ mappend = (Sem.<>) stringDraw :: Curses.Attr -> ColPair -> String -> Draw stringDraw attr col str =
CursesUIMInstance.hs view
@@ -289,7 +289,7 @@ drawMainState' (ReplayState {}) = do lift . drawState [] False [] =<< gets rsCurrentState lift $ drawCursorAt Nothing- drawMainState' (EditState { esGameStateStack=(st:_), selectedPiece=selPiece,+ drawMainState' (EditState { esGameState=st, selectedPiece=selPiece, selectedPos=selPos, esFrame=frame }) = lift $ do drawState (maybeToList selPiece) True [] st drawBindingsTables IMEdit frame
Database.hs view
@@ -36,9 +36,9 @@ hash :: String -> String hash = CS.unpack . digestToHexByteString . sha1 . CL.pack - data Record- = RecPassword Codename+ = RecPasswordLegacy Codename+ | RecPasswordArgon2 Codename | RecEmail Codename | RecUserInfo Codename | RecUserInfoLog Codename@@ -52,7 +52,8 @@ | RecSecretKey deriving (Eq, Ord, Show) data RecordContents- = RCPassword Password+ = RCPasswordLegacy Password+ | RCPasswordArgon2 String | RCUserInfo VersionedUInfo | RCUserInfoDeltas [UserInfoDelta] | RCLock Lock@@ -75,7 +76,8 @@ invariantRecord (RecUserInfo _) = False invariantRecord (RecUserInfoLog _) = False-invariantRecord (RecPassword _) = False+invariantRecord (RecPasswordLegacy _) = False+invariantRecord (RecPasswordArgon2 _) = False invariantRecord (RecRetiredLocks _) = False invariantRecord (RecNote _) = False invariantRecord (RecEmail _) = False@@ -102,7 +104,8 @@ liftIO $ flip catchIO (const $ return Nothing) $ do h <- openFile path ReadMode getRecordh rec h <* hClose h-getRecordh (RecPassword _) h = ((RCPassword <$>) . tryRead) <$> hGetStrict h+getRecordh (RecPasswordLegacy _) h = ((RCPasswordLegacy <$>) . tryRead) <$> hGetStrict h+getRecordh (RecPasswordArgon2 _) h = ((RCPasswordArgon2 <$>) . tryRead) <$> hGetStrict h getRecordh (RecEmail _) h = ((RCEmail <$>) . tryRead) <$> hGetStrict h getRecordh (RecUserInfo _) h = ((RCUserInfo <$>) . tryRead) <$> hGetStrict h getRecordh (RecUserInfoLog _) h = ((RCUserInfoDeltas <$>) . tryRead) <$> hGetStrict h@@ -130,7 +133,8 @@ h <- openFile path WriteMode putRecordh rc h hClose h-putRecordh (RCPassword hpw) h = hPutStr h $ show hpw+putRecordh (RCPasswordLegacy hpw) h = hPutStr h $ show hpw+putRecordh (RCPasswordArgon2 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@@ -178,7 +182,8 @@ recordPath rec = (++ ([pathSeparator] ++ recordPath' rec)) <$> ask where- recordPath' (RecPassword name) = userDir name ++ "passwd"+ recordPath' (RecPasswordLegacy name) = userDir name ++ "passwd"+ recordPath' (RecPasswordArgon2 name) = userDir name ++ "passwd_argon2" recordPath' (RecEmail name) = userDir name ++ "email" recordPath' (RecUserInfo name) = userDir name ++ "info" recordPath' (RecUserInfoLog name) = userDir name ++ "log"
Hex.lhs view
@@ -39,6 +39,7 @@ module Hex where import Data.Ix+import Data.Semigroup as Sem import Data.Monoid import Data.Ratio import Data.List (minimumBy)@@ -214,9 +215,11 @@ \begin{code} +instance Sem.Semigroup HexVec where+ (HexVec x y z) <> (HexVec x' y' z') = HexVec (x+x') (y+y') (z+z') instance Monoid HexVec where- (HexVec x y z) `mappend` (HexVec x' y' z') = HexVec (x+x') (y+y') (z+z') mempty = HexVec 0 0 0+ mappend = (Sem.<>) instance Grp HexVec where neg (HexVec x y z) = HexVec (-x) (-y) (-z)
Interact.hs view
@@ -618,7 +618,7 @@ processCommand' IMReplay CmdRedo = processCommand' IMReplay (CmdReplayForward 1) processCommand' IMEdit CmdPlay = do- st <- gets $ head.esGameStateStack+ st <- gets esGameState frame <- gets esFrame modify $ \es -> es {selectedPiece = Nothing} subPlay (frame,st)@@ -627,14 +627,15 @@ modifyEState (\st -> snd $ canonify (frame, st)) modify $ \es -> es {selectedPiece = Nothing} mpath <- gets esPath- st <- gets $ head.esGameStateStack+ st <- gets esGameState void.runMaybeT $ do soln <- solveLock (frame,st) $ Just $ "testing " ++ fromMaybe "[unnamed lock]" mpath lift $ modify $ \es -> es { esTested = Just (st, soln) } processCommand' IMEdit CmdUndo = do- st:sts <- gets esGameStateStack+ st <- gets esGameState+ sts <- gets esGameStateStack usts <- gets esUndoneStack- unless (null sts) $ modify $ \es -> es {esGameStateStack = sts, esUndoneStack = st:usts}+ unless (null sts) $ modify $ \es -> es {esGameState = head sts, esGameStateStack = tail sts, esUndoneStack = st:usts} processCommand' IMEdit CmdRedo = do usts <- gets esUndoneStack case usts of@@ -647,7 +648,7 @@ processCommand' IMEdit CmdSelect = do selPiece <- gets selectedPiece selPos <- gets selectedPos- st:_ <- gets esGameStateStack+ st <- gets esGameState let selPiece' = if isJust selPiece then Nothing@@ -663,13 +664,13 @@ processCommand' IMEdit (CmdMoveTo newPos) = setSelectedPos newPos processCommand' IMEdit (CmdDrag pos dir) = do- board <- stateBoard.head <$> gets esGameStateStack+ board <- stateBoard <$> gets esGameState void.runMaybeT $ do selIdx <- MaybeT $ gets selectedPiece idx <- liftMaybe $ fst <$> Map.lookup pos board guard $ idx == selIdx lift $ processCommand' IMEdit $ CmdDir WHSSelected $ dir- board' <- stateBoard.head <$> gets esGameStateStack+ board' <- stateBoard <$> gets esGameState msum [ do idx' <- liftMaybe $ fst <$> Map.lookup pos' board' guard $ idx' == selIdx@@ -691,7 +692,7 @@ paintTilePath frame tile (truncateToEditable frame from) (truncateToEditable frame to) processCommand' IMEdit CmdMerge = do selPos <- gets selectedPos- st:_ <- gets esGameStateStack+ st <- gets esGameState lift $ drawMessage "Merge in which direction?" let getDir = do cmd <- lift $ head <$> getSomeInput IMEdit@@ -708,14 +709,14 @@ modify $ \es -> es {selectedPiece = Nothing} lift $ drawMessage "" processCommand' IMEdit CmdWait = do- st:_ <- gets esGameStateStack+ st <- gets esGameState (st',_) <- lift $ doPhysicsTick NullPM st pushEState st' processCommand' IMEdit CmdDelete = do selPos <- gets selectedPos selPiece <- gets selectedPiece- st:_ <- gets esGameStateStack+ st <- gets esGameState case selPiece of Nothing -> drawTile selPos Nothing False Just p -> do modify $ \es -> es {selectedPiece = Nothing}@@ -728,7 +729,7 @@ liftIO (doesFileExist fullPath `catchIO` const (return True)) >>? confirmOrBail $ "Really overwrite '"++fullPath++"'?" lift $ do- st <- gets $ head.esGameStateStack+ st <- gets esGameState frame <- gets esFrame msoln <- getCurTestSoln merr <- liftIO $ ((writeAsciiLockFile fullPath msoln $ canonify (frame, st)) >> return Nothing)
InteractUtil.hs view
@@ -52,7 +52,7 @@ else drawMessage "" doForce force = do- st:_ <- gets esGameStateStack+ st <- gets esGameState let (st',alerts) = runWriter $ resolveSinglePlForce force st lift (reportAlerts st' alerts) >> pushEState st' drawTile pos tile painting = do@@ -69,8 +69,9 @@ pushEState :: UIMonad uiM => GameState -> MainStateT uiM () pushEState st = do- st':sts <- gets esGameStateStack- when (st' /= st) $ modify $ \es -> es {esGameStateStack = st:st':sts, esUndoneStack = []}+ st' <- gets esGameState+ sts <- gets esGameStateStack+ when (st' /= st) $ modify $ \es -> es {esGameState = st, esGameStateStack = st':sts, esUndoneStack = []} pushPState :: UIMonad uiM => (GameState,PlayerMove) -> MainStateT uiM () pushPState (st,pm) = do st' <- gets psCurrentState@@ -79,7 +80,7 @@ psGameStateMoveStack = (st',pm):stms, psUndoneStack = []} modifyEState :: UIMonad uiM => (GameState -> GameState) -> MainStateT uiM () modifyEState f = do- st:_ <- gets esGameStateStack+ st <- gets esGameState pushEState $ f st doPhysicsTick :: UIMonad uiM => PlayerMove -> GameState -> uiM (GameState, [Alert])@@ -157,7 +158,7 @@ setMark :: (Monad m) => Bool -> Char -> MainStateT m () setMark overwrite ch = get >>= \mst -> case mst of -- ugh... remind me why I'm not using lens?- EditState { esMarks = marks, esGameStateStack = (st:_) } ->+ EditState { esMarks = marks, esGameState = st } -> put $ mst { esMarks = insertMark ch st marks } PlayState {} -> put $ mst { psMarks = insertMark ch mst $ psMarks mst } ReplayState {} -> put $ mst { rsMarks = insertMark ch mst $ rsMarks mst }
MainState.hs view
@@ -100,7 +100,8 @@ , rsMarks::Map Char MainState } | EditState- { esGameStateStack::[GameState]+ { esGameState::GameState+ , esGameStateStack::[GameState] , esUndoneStack::[GameState] , esFrame::Frame , esPath::Maybe FilePath@@ -146,7 +147,7 @@ newPlayState (frame,st) title isTut sub saved = PlayState st frame [] False False [] [] title isTut sub saved Map.empty newReplayState st soln title = ReplayState st [] soln [] title Map.empty-newEditState (frame,st) msoln mpath = EditState [st] [] frame mpath+newEditState (frame,st) msoln mpath = EditState st [] [] frame mpath ((\s->(st,s))<$>msoln) (Just (st, isJust msoln)) Nothing (PHS zero) (PHS zero) Map.empty initMetaState = do flag <- atomically $ newTVar False@@ -227,7 +228,7 @@ editStateUnsaved :: UIMonad uiM => MainStateT uiM Bool editStateUnsaved = (isNothing <$>) $ runMaybeT $ do (sst,tested) <- MaybeT $ gets lastSavedState- st <- MaybeT $ gets $ headMay.esGameStateStack+ st <- gets $ esGameState guard $ sst == st nowTested <- isJust <$> lift getCurTestSoln guard $ tested == nowTested@@ -235,7 +236,7 @@ getCurTestSoln :: UIMonad uiM => MainStateT uiM (Maybe Solution) getCurTestSoln = runMaybeT $ do (st',soln) <- MaybeT $ gets esTested- st <- MaybeT $ gets $ headMay.esGameStateStack+ st <- gets $ esGameState guard $ st == st' return soln @@ -486,11 +487,11 @@ [ "" , "So." , ""- , "It seems your levels of manual and mental dexterity are adequate for picking locks."- , "Whether you also possess the deviousness required for their design, remains to be seen."+ , "This confirms that you have sufficient manual and mental dexterity to pick simple locks."+ , "But have you the supple cunning required to improve on their designs? That remains to be seen." , ""- , "Nonetheless, we welcome you to our number. As for what exactly it is that you are joining..."- , "perhaps you think you have worked it all out already, but let me explain."+ , "Nonetheless, we welcome you to our number. As for what it is exactly that you are joining..."+ , "probably you think you have it all worked out already. Still, allow me to explain." , "" , "But first: for reasons that will become clear," , "our members are known exclusively by pseudonyms - by tradition, a triplet of letters or symbols."@@ -507,25 +508,25 @@ , "Our task is to produce the superficially secure locks necessary for this system:" , "locks pickable with minimal tools, but with this fact obscured by their mechanical complexity." , ""- , "To push the our designs to ever new heights of intricacy, we run a ritual game."+ , "To push the designs to ever new extremes of intricacy, we run a ritual game." , "You are to be its newest player." ] initiationHelpText 3 = [ ""- , "Each player designs locks, and each player attempts to solve the locks designed by the others."+ , "We each design locks, and we each attempt to solve the locks designed by the others." , "" , "You may put forward up to three prototype locks." , "They will guard the secrets you discover: when you pick a colleague's lock,"- , "you may declare the fact by placing notes on its solution behind one of your locks."- , "As long as the owner of the lock you picked is unable to read your notes,"- , "you score a point against them."+ , "you may declare the fact by placing a note on its solution behind one of your locks."+ , "As long as the owner of the lock you picked is unable to read your note,"+ , "you score a point against them. This is now your aim in life." , ""- , "If you find a lock too difficult or trivial for you to pick yourself,"+ , "If you find a lock too difficult or trivial to pick yourself," , "you may find that reading other players' notes on it will lead you to a solution." , "" , "The finer details of the rules can wait." , "Go now; choose a codename, explore the locks we have set,"- , "and begin your own experiments in the ever-rewarding art of lock design."+ , "and begin your own experiments in the subtle art of lock design." ] initiationHelpText _ = []
NEWS view
@@ -1,8 +1,12 @@ This is an abbreviated summary; see the git log for gory details. +0.7.2:+ Support ghc-8.0+ Use Argon2 for server-side password hashing+ Tweak graphics and text 0.7.1.1:- Make server compatible with feed-1.0.0- Avoid DOS-reserved codenames+ Make server compatible with feed-1.0.0 (thanks constatinus)+ Avoid DOS-reserved codenames (thanks constatinus) 0.7.1: Rework tutorial and intro. Animate movement.
SDLGlyph.hs view
@@ -76,9 +76,7 @@ drawAtRel gl (pos -^ centre) drawAtRel :: Glyph -> HexVec -> RenderM ()-drawAtRel gl v = do- size <- asks renderSize- displaceRenderSVec (hexVec2SVec size v) $ renderGlyphCaching gl+drawAtRel gl v = recentreAt v $ renderGlyphCaching gl renderGlyphCaching :: Glyph -> RenderM () -- Glyph caching:@@ -97,7 +95,7 @@ liftIO $ setColorKey csurf [SrcColorKey,RLEAccel] $ Pixel 0 return csurf renderOnCache csurf =- let ccxt rc = rc { renderSurf = csurf, renderSCentre = SVec (w`div`2) (h`div`2) }+ let ccxt rc = rc { renderSurf = csurf, renderSCentre = SVec (w`div`2) (h`div`2), renderOffset = zero } in local ccxt $ renderGlyph gl addToCache cacheFull csurf = do CachedGlyphs cmap clist <- lift get@@ -202,7 +200,7 @@ Stretched -> 1 Relaxed -> 2 Compressed -> 4- brightness = if extn == Relaxed then dim else bright+ brightness = dim dir' = if dir == zero then hu else dir s = corner (hextant dir' - 1) +^ innerCorner endDisp off = corner (hextant dir') +^ innerCorner endDisp
SDLRender.hs view
@@ -14,6 +14,7 @@ import Graphics.UI.SDL import Graphics.UI.SDL.Primitives import qualified Graphics.UI.SDL.TTF as TTF+import Data.Semigroup as Sem import Data.Monoid import Control.Monad import Control.Monad.IO.Class@@ -33,9 +34,11 @@ -- |SVec: screen vectors, in pixels data SVec = SVec { cx, cy :: Int } deriving (Eq, Ord, Show)+instance Sem.Semigroup SVec where+ (SVec x y) <> (SVec x' y') = SVec (x+x') (y+y') instance Monoid SVec where mempty = SVec 0 0- mappend (SVec x y) (SVec x' y') = SVec (x+x') (y+y')+ mappend = (Sem.<>) instance Grp SVec where neg (SVec x y) = SVec (-x) (-y) type CCoord = PHS SVec@@ -43,9 +46,11 @@ -- |FVec: floating point screen vectors, multiplied by 'size' to get SVecs. data FVec = FVec { rcx, rcy :: Float } deriving (Eq, Ord, Show)+instance Sem.Semigroup FVec where+ (FVec x y) <> (FVec x' y') = FVec (x+x') (y+y') instance Monoid FVec where mempty = FVec 0 0- mappend (FVec x y) (FVec x' y') = FVec (x+x') (y+y')+ mappend = (Sem.<>) instance Grp FVec where neg (FVec x y) = FVec (-x) (-y) @@ -65,6 +70,11 @@ hexVec2FVec (HexVec x y z) = FVec (fi $ x-z) (-(fi y) * 3 * ylen) +fVec2SVec :: Int -> FVec -> SVec+fVec2SVec size (FVec x y) = SVec+ (round $ fi size * x)+ (round $ fi size * y)+ sVec2dHV :: Int -> SVec -> (Double,Double,Double) sVec2dHV size (SVec sx sy) = let sx',sy',size' :: Double@@ -92,6 +102,7 @@ , renderBGSurf :: Maybe Surface , renderHCentre :: HexPos , renderSCentre :: SVec+ , renderOffset :: FVec , renderSize :: Int , renderFont :: Maybe TTF.Font }@@ -99,24 +110,22 @@ runRenderT = runReaderT -displaceRender :: Monad m => FVec -> RenderT m a -> RenderT m a-displaceRender v m = do- size <- asks renderSize- let FVec x y = fi size **^ v- let sv = SVec (round x) (round y)- displaceRenderSVec sv m+applyOffset :: RenderContext -> RenderContext+applyOffset rc = rc+ { renderSCentre = renderSCentre rc +^ fVec2SVec (renderSize rc) (renderOffset rc)+ , renderOffset = zero+ } -displaceRenderSVec :: Monad m => SVec -> RenderT m a -> RenderT m a-displaceRenderSVec sv =- local $ \rc -> rc { renderSCentre = renderSCentre rc +^ sv }+displaceRender :: Monad m => FVec -> RenderT m a -> RenderT m a+displaceRender d =+ local $ \rc -> rc { renderOffset = renderOffset rc +^ d } recentreAt :: Monad m => HexVec -> RenderT m a -> RenderT m a-recentreAt v m = do- size <- asks renderSize- displaceRenderSVec (hexVec2SVec size v) m+recentreAt v m = displaceRender (hexVec2FVec v) m -rescaleRender :: Monad m => RealFrac n => n -> RenderT m a -> RenderT m a-rescaleRender r = local $ \rc -> rc { renderSize = round $ r * (fi $ renderSize rc) }+rescaleRender :: Monad m => Float -> RenderT m a -> RenderT m a+rescaleRender r = local $ (\rc -> rc+ { renderSize = round $ r * (fi $ renderSize rc) } ) . applyOffset withFont :: Monad m => Maybe TTF.Font -> RenderT m a -> RenderT m a withFont font = local $ \rc -> rc { renderFont = font }@@ -124,9 +133,10 @@ renderPos :: Monad m => Integral i => FVec -> RenderT m (i,i) renderPos v = do size <- asks renderSize- let FVec dx dy = fi size **^ v- SVec x y <- asks renderSCentre- return $ (fi x + round dx, fi y + round dy)+ c <- asks renderSCentre+ off <- asks renderOffset+ let SVec x y = c +^ fVec2SVec size (v +^ off)+ return $ (fi x, fi y) renderLen :: Monad m => Integral i => Float -> RenderT m i renderLen l = do size <- asks renderSize@@ -197,7 +207,7 @@ in rimmedPolygonR [ from +^ perp, to +^ perp , to +^ neg perp, from +^ neg perp]- (dim col) (bright col)+ col (bright col) thickLinesR verts thickness col = sequence_ [ thickLineR v v' thickness col |@@ -316,8 +326,8 @@ renderStrColAt' centred c str v = void $ runMaybeT $ do font <- MaybeT $ asks renderFont fsurf <- MaybeT $ liftIO $ TTF.tryRenderTextBlended font str $ pixelToColor c- (surf, scrCentre, size) <- lift $ asks $ liftM3 (,,) renderSurf renderSCentre renderSize- let SVec x y = scrCentre +^ (hexVec2SVec size v)+ (surf, scrCentre, off, size) <- lift $ asks $ liftM4 (,,,) renderSurf renderSCentre renderOffset renderSize+ let SVec x y = scrCentre +^ fVec2SVec size (off +^ hexVec2FVec v) +^ neg (SVec 0 ((surfaceGetHeight fsurf-1)`div`2) +^ if centred then SVec ((surfaceGetWidth fsurf)`div`2) 0@@ -344,16 +354,16 @@ mbgsurf blankRow v = do- (surf, scrCentre, size) <- asks $ liftM3 (,,) renderSurf renderSCentre renderSize- let SVec _ y = scrCentre +^ (hexVec2SVec size v)+ (surf, scrCentre, off, size) <- asks $ liftM4 (,,,) renderSurf renderSCentre renderOffset renderSize+ let SVec _ y = scrCentre +^ fVec2SVec size (off +^ hexVec2FVec v) w = surfaceGetWidth surf h = ceiling $ fi (size * 3 `div` 2) * 2 / sqrt 3 fillRectBG $ Just $ Rect 0 (y-h`div`2) w h blitAt :: (Functor m, MonadIO m) => Surface -> HexVec -> RenderT m () blitAt surface v = do- (surf, scrCentre, size) <- asks $ liftM3 (,,) renderSurf renderSCentre renderSize- let SVec x y = scrCentre +^ (hexVec2SVec size v)+ (surf, scrCentre, off, size) <- asks $ liftM4 (,,,) renderSurf renderSCentre renderOffset renderSize+ let SVec x y = scrCentre +^ fVec2SVec size (off +^ hexVec2FVec v) w = surfaceGetWidth surface h = surfaceGetHeight surface void $ liftIO $ blitSurface surface Nothing surf $ Just $
SDLUI.hs view
@@ -29,6 +29,7 @@ import Data.List import Data.Ratio import Data.Function (on)+import Data.Time.Clock (getCurrentTime) import System.FilePath --import Debug.Trace (traceShow) @@ -120,7 +121,7 @@ mfont <- gets dispFont bgsurf <- gets bgSurface cgs <- gets cachedGlyphs- (a,cgs') <- liftIO $ runRenderM m cgs $ RenderContext surf bgsurf centre scrCentre size mfont+ (a,cgs') <- liftIO $ runRenderM m cgs $ RenderContext surf bgsurf centre scrCentre zero size mfont modify $ \s -> s { cachedGlyphs = cgs' } return a @@ -723,7 +724,7 @@ draw = sequence_ [ drawAt glyph pos | (pos,glyph) <- Map.toList $ fmap (ownedTileGlyph colouring []) $ stateBoard st ] liftIO $ runRenderM draw emptyCachedGlyphs $- RenderContext surf Nothing (PHS zero) (SVec (width`div`2) (height`div`2)) minisize Nothing+ RenderContext surf Nothing (PHS zero) (SVec (width`div`2) (height`div`2)) zero minisize Nothing clearOldMiniLocks modify $ \ds -> ds { miniLocks = Map.insert lock surf $ miniLocks ds } return surf@@ -809,10 +810,11 @@ clearMiniLocks - when (isNothing font) $ lift $ do- let text = "Warning: font file not found at "++fontpath++".\n"+ when (isNothing font) $ liftIO $ do+ now <- getCurrentTime+ let text = show now ++ ": Warning: font file not found at "++fontpath++".\n" putStr text- writeFile "error.log" text+ appendFile "intricacy-warnings.log" text where getDimensions = (videoInfoWidth &&& videoInfoHeight) <$> getVideoInfo@@ -821,7 +823,12 @@ initAudio :: UIM () #ifdef SOUND initAudio = do- liftIO $ tryOpenAudio defaultFrequency AudioS16Sys 1 1024+ initialised <- liftIO $ tryOpenAudio defaultFrequency AudioS16Sys 1 1024+ unless initialised $ liftIO $ do+ now <- getCurrentTime+ let text = show now ++ ": Warning: audio failed to initialise.\n"+ putStr text+ appendFile "intricacy-warnings.log" text -- liftIO $ querySpec >>= print liftIO $ allocateChannels 16 let seqWhileJust (m:ms) = m >>= \ret -> case ret of
SDLUIMInstance.hs view
@@ -102,7 +102,7 @@ drawMainGameState [] False alerts st registerUndoButtons canUndo canRedo renderToMain $ drawCursorAt Nothing- drawMainState' (EditState { esGameStateStack=(st:sts), esUndoneStack=undostack,+ drawMainState' (EditState { esGameState=st, esGameStateStack=sts, esUndoneStack=undostack, selectedPiece=selPiece, selectedPos=selPos }) = lift $ do drawMainGameState (maybeToList selPiece) True [] st renderToMain $ drawCursorAt $ if isNothing selPiece then Just selPos else Nothing@@ -560,7 +560,7 @@ "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."]+ IMReplay -> ["Scroll wheel for undo/redo."] IMMeta -> ["Left-clicking on something does most obvious thing;" , "Right-clicking does second-most obvious thing."]] ++ case mode of
Server.hs view
@@ -36,6 +36,7 @@ import qualified Data.Binary as B import qualified Data.Text as TS import qualified Data.Text.Lazy as TL+import qualified Data.Text.Short as TSh import Data.Array import Control.Exception import System.IO.Error@@ -54,6 +55,7 @@ import Crypto.Types.PubKey.RSA (PublicKey, PrivateKey) import Codec.Crypto.RSA (decrypt, generateKeyPair, RSAError) import Crypto.Random (newGenIO, SystemRandom)+import qualified Crypto.Argon2 as A2 import qualified Text.Email.Validate import qualified Network.Mail.SMTP as SMTP@@ -137,6 +139,22 @@ putRecord RecPublicKey $ RCPublicKey publicKey putRecord RecSecretKey $ RCSecretKey secretKey +argon2 :: String -> ExceptT String IO String+argon2 s = either (throwE . show) (return) $+ TSh.unpack <$> A2.hashEncoded hashOptions (CS.pack s) (CS.pack salt)+ where+ salt = "intricacy salt"+ -- |default argon2 hash options+ hashOptions = A2.HashOptions+ { A2.hashIterations = 3+ , A2.hashMemory = 2 ^ 12 -- 4 MiB+ , A2.hashParallelism = 1+ , A2.hashVariant = A2.Argon2i+ , A2.hashVersion = A2.Argon2Version13+ , A2.hashLength = 2 ^ 5 -- 32 bytes+ }++ -- | We lock the whole database during each request, using haskell's native -- file locking, meaning that we have at any time one writer *xor* any number -- of readers.@@ -390,28 +408,36 @@ decrypt secretKey . BL.fromStrict . CS.pack $ pw) -- <=intricacy-0.6.2 sends the hashed password unencrypted `catch` \(e :: RSAError) -> return pw+ convertLegacyPW :: Codename -> IO ()+ convertLegacyPW name = void . runExceptT $ do+ RCPasswordLegacy legacyPw <- getRecordErrored (RecPasswordLegacy name)+ pwA2 <- argon2 legacyPw+ erroredDB $ putRecord (RecPasswordArgon2 name) (RCPasswordArgon2 pwA2)+ erroredDB $ delRecord (RecPasswordLegacy name) checkAuth :: Maybe Auth -> ExceptT String IO () checkAuth Nothing = throwE "Authentication required" checkAuth (Just (Auth name pw)) = do exists <- checkCodeName name unless exists $ throwE "No such user"- RCPassword correctPw <- getRecordErrored (RecPassword name)+ liftIO $ convertLegacyPW name pw' <- decryptPassword pw- when (pw' /= correctPw) $ throwE "Wrong password"+ RCPasswordArgon2 correctPwA2 <- getRecordErrored (RecPasswordArgon2 name)+ pwA2 <- argon2 pw'+ when (pwA2 /= correctPwA2) $ 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 $ throwE "Codename taken"- pw' <- decryptPassword pw- erroredDB $ putRecord (RecPassword name) (RCPassword pw')+ pw' <- decryptPassword pw >>= argon2+ erroredDB $ putRecord (RecPasswordArgon2 name) (RCPasswordArgon2 pw') erroredDB $ putRecord (RecUserInfo name) (RCUserInfo $ (1,initUserInfo name)) erroredDB $ putRecord (RecUserInfoLog name) (RCUserInfoDeltas []) resetPassword Nothing _ = throwE "Authentication required" resetPassword auth@(Just (Auth name _)) newpw = do checkAuth auth- newpw' <- decryptPassword newpw- erroredDB $ putRecord (RecPassword name) (RCPassword newpw')+ newpw' <- decryptPassword newpw >>= argon2+ erroredDB $ putRecord (RecPasswordArgon2 name) (RCPasswordArgon2 newpw') setEmail Nothing _ = throwE "Authentication required" setEmail auth@(Just (Auth name _)) addressStr = do checkAuth auth@@ -423,7 +449,10 @@ checkCodeName :: Codename -> ExceptT String IO Bool checkCodeName name = do unless (validCodeName name) $ throwE "Invalid codename"- liftIO $ withDB dbpath $ recordExists $ RecPassword name+ liftIO $ withDB dbpath $ do+ ok <- recordExists $ RecPasswordArgon2 name+ oklegacy <- recordExists $ RecPasswordLegacy name+ return $ ok || oklegacy --- | TODO: journalling so we can survive death during database writes? applyDeltasToRecords :: [(Codename, UserInfoDelta)] -> ExceptT String IO () applyDeltasToRecords nds = sequence_ $ [applyDeltasToRecord name deltas
Version.hs view
@@ -11,4 +11,4 @@ module Version where version :: String-version = "0.7.1.1"+version = "0.7.2"
intricacy.cabal view
@@ -1,5 +1,5 @@ name: intricacy-version: 0.7.1.1+version: 0.7.2 synopsis: A game of competitive puzzle-design homepage: http://mbays.freeshell.org/intricacy license: GPL-3@@ -59,13 +59,15 @@ , cryptohash >= 0.8 , safe >= 0.2 , RSA >= 2.0, crypto-pubkey-types >= 0.2, crypto-api >= 0.10+ if !impl(ghc >= 8.0)+ build-depends: semigroups == 0.18.* if flag(SDL) build-depends: SDL >=0.6.5, SDL-ttf >=0.6, SDL-gfx >=0.6 if flag(Sound) cpp-options: -DSOUND build-depends: SDL-mixer >= 0.6, random >= 1.0 if os(windows)- Extra-Lib-Dirs: winlibs+ -- Extra-Lib-Dirs: winlibs Extra-Libraries: SDL_ttf SDL SDL_gfx freetype if flag(Sound) Extra-Libraries: SDL_mixer@@ -119,7 +121,10 @@ , RSA >= 2.0, crypto-pubkey-types >= 0.2, crypto-api >= 0.10 , random >= 1.0, pipes >= 4 , feed >= 1.0.0, xml-conduit >= 1.0.0- , email-validate >= 1.0.0, text, smtp-mail >= 0.1.4.1+ , email-validate >= 1.0.0, text, text-short, smtp-mail >= 0.1.4.1+ , argon2 >= 1.3+ if !impl(ghc >= 8.0)+ build-depends: semigroups == 0.18.* else Buildable: False main-is: Server.hs