diff --git a/CVec.hs b/CVec.hs --- a/CVec.hs +++ b/CVec.hs @@ -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 diff --git a/CursesUI.hs b/CursesUI.hs --- a/CursesUI.hs +++ b/CursesUI.hs @@ -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 = diff --git a/CursesUIMInstance.hs b/CursesUIMInstance.hs --- a/CursesUIMInstance.hs +++ b/CursesUIMInstance.hs @@ -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 diff --git a/Database.hs b/Database.hs --- a/Database.hs +++ b/Database.hs @@ -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" diff --git a/Hex.lhs b/Hex.lhs --- a/Hex.lhs +++ b/Hex.lhs @@ -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) diff --git a/Interact.hs b/Interact.hs --- a/Interact.hs +++ b/Interact.hs @@ -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) diff --git a/InteractUtil.hs b/InteractUtil.hs --- a/InteractUtil.hs +++ b/InteractUtil.hs @@ -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 } diff --git a/MainState.hs b/MainState.hs --- a/MainState.hs +++ b/MainState.hs @@ -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 _ = [] diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -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. diff --git a/SDLGlyph.hs b/SDLGlyph.hs --- a/SDLGlyph.hs +++ b/SDLGlyph.hs @@ -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 diff --git a/SDLRender.hs b/SDLRender.hs --- a/SDLRender.hs +++ b/SDLRender.hs @@ -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 $ diff --git a/SDLUI.hs b/SDLUI.hs --- a/SDLUI.hs +++ b/SDLUI.hs @@ -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 diff --git a/SDLUIMInstance.hs b/SDLUIMInstance.hs --- a/SDLUIMInstance.hs +++ b/SDLUIMInstance.hs @@ -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 diff --git a/Server.hs b/Server.hs --- a/Server.hs +++ b/Server.hs @@ -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 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.7.1.1" +version = "0.7.2" diff --git a/intricacy.cabal b/intricacy.cabal --- a/intricacy.cabal +++ b/intricacy.cabal @@ -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