summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authormbays <>2019-01-20 16:48:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-01-20 16:48:00 (GMT)
commit29329624150e34f5714d138faf3d2a24a42ef40a (patch)
tree07a8aa494ea96d61b4df143d0a0913f4224e7f3c
parent705707758ebd6564226274abfeb27d1876cc5a9b (diff)
version 0.7.2HEAD0.7.2master
-rw-r--r--CVec.hs5
-rw-r--r--CursesUI.hs7
-rw-r--r--CursesUIMInstance.hs2
-rw-r--r--Database.hs19
-rw-r--r--Hex.lhs5
-rw-r--r--Interact.hs23
-rw-r--r--InteractUtil.hs11
-rw-r--r--MainState.hs31
-rw-r--r--NEWS8
-rw-r--r--SDLGlyph.hs8
-rw-r--r--SDLRender.hs62
-rw-r--r--SDLUI.hs19
-rw-r--r--SDLUIMInstance.hs4
-rw-r--r--Server.hs43
-rw-r--r--Version.hs2
-rw-r--r--intricacy.cabal11
16 files changed, 165 insertions, 95 deletions
diff --git a/CVec.hs b/CVec.hs
index 0b6d366..456cff3 100644
--- 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
index 5984dcb..67360bf 100644
--- a/CursesUI.hs
+++ b/CursesUI.hs
@@ -15,6 +15,7 @@ import Control.Concurrent.STM
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 @@ alignDraw gravity w (Draw w' d) = Draw (max w w') $ \(CVec y x) ->
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
index 128a46b..1a60919 100644
--- a/CursesUIMInstance.hs
+++ b/CursesUIMInstance.hs
@@ -289,7 +289,7 @@ instance UIMonad (StateT UIState IO) where
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
index 7a3a858..8b3583b 100644
--- a/Database.hs
+++ b/Database.hs
@@ -36,9 +36,9 @@ sha1 = hashlazy
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 @@ data Record
| RecSecretKey
deriving (Eq, Ord, Show)
data RecordContents
- = RCPassword Password
+ = RCPasswordLegacy Password
+ | RCPasswordArgon2 String
| RCUserInfo VersionedUInfo
| RCUserInfoDeltas [UserInfoDelta]
| RCLock Lock
@@ -75,7 +76,8 @@ rcOfServerResp _ = error "no corresponding rc"
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 @@ getRecord rec = do
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 @@ putRecord rec rc = do
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 :: Record -> DBM FilePath
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
index c4eb061..3c1472d 100644
--- a/Hex.lhs
+++ b/Hex.lhs
@@ -39,6 +39,7 @@ Some hopefully elucidatory diagrams:
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 @@ HexVec difference between two points (e.g. PHS HexVec).
\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
index f1fbab7..06ca0d1 100644
--- a/Interact.hs
+++ b/Interact.hs
@@ -618,7 +618,7 @@ processCommand' IMReplay CmdUndo = processCommand' IMReplay (CmdReplayBack 1)
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 @@ processCommand' IMEdit CmdTest = do
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 CmdUnselect =
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 (CmdDir _ dir) = do
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 @@ processCommand' IMEdit (CmdPaintFromTo tile from to) = do
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 @@ processCommand' IMEdit CmdMerge = do
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 @@ processCommand' IMEdit CmdWriteState = void.runMaybeT $ do
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
index 1334000..f8ba662 100644
--- a/InteractUtil.hs
+++ b/InteractUtil.hs
@@ -52,7 +52,7 @@ checkWon = do
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 @@ paintTilePath frame tile from to = if from == to
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 @@ pushPState (st,pm) = do
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 @@ jumpMark ch = do
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
index aa18e06..3b13d07 100644
--- a/MainState.hs
+++ b/MainState.hs
@@ -100,7 +100,8 @@ data MainState
, rsMarks::Map Char MainState
}
| EditState
- { esGameStateStack::[GameState]
+ { esGameState::GameState
+ , esGameStateStack::[GameState]
, esUndoneStack::[GameState]
, esFrame::Frame
, esPath::Maybe FilePath
@@ -146,7 +147,7 @@ ms2im mainSt = case mainSt of
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 @@ getTitle = ms2im <$> get >>= \im -> case im of
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 @@ editStateUnsaved = (isNothing <$>) $ runMaybeT $ do
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 @@ initiationHelpText 1 =
[ ""
, "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 @@ initiationHelpText 2 =
, "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
index ff15ba2..a224e1f 100644
--- 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
index 01a3a53..60d9066 100644
--- a/SDLGlyph.hs
+++ b/SDLGlyph.hs
@@ -76,9 +76,7 @@ drawAt gl pos = do
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 @@ renderGlyphCaching gl = do
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 @@ renderGlyph (SpringGlyph rootDisp endDisp extn dir col) =
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
index 796fd50..d09619e 100644
--- a/SDLRender.hs
+++ b/SDLRender.hs
@@ -14,6 +14,7 @@ module SDLRender where
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 @@ import Util
-- |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 @@ type CCoord = PHS SVec
-- |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 -> FVec
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 @@ data RenderContext = RenderContext
, renderBGSurf :: Maybe Surface
, renderHCentre :: HexPos
, renderSCentre :: SVec
+ , renderOffset :: FVec
, renderSize :: Int
, renderFont :: Maybe TTF.Font
}
@@ -99,24 +110,22 @@ type RenderT = ReaderT RenderContext
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 @@ withFont font = local $ \rc -> rc { renderFont = font }
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 @@ thickLineR from to thickness col =
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' :: (Functor m, MonadIO m) => Bool -> Pixel -> String -> HexVec -
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 @@ fillRectBG mrect = do
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
index ca7c55c..8264b4e 100644
--- a/SDLUI.hs
+++ b/SDLUI.hs
@@ -29,6 +29,7 @@ import Data.Array
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 @@ renderToMainWithSurf surf m = do
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 @@ drawMiniLock lock v = do
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 @@ initVideo w h = do
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 @@ initVideo w h = do
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
index 8b45497..ca8bb6e 100644
--- a/SDLUIMInstance.hs
+++ b/SDLUIMInstance.hs
@@ -102,7 +102,7 @@ instance UIMonad (StateT UIState IO) where
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 @@ instance UIMonad (StateT UIState IO) where
"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
index af62483..d7f1bd0 100644
--- a/Server.hs
+++ b/Server.hs
@@ -36,6 +36,7 @@ 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 qualified Data.Text.Short as TSh
import Data.Array
import Control.Exception
import System.IO.Error
@@ -54,6 +55,7 @@ import Data.Time.LocalTime
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 @@ setKeyPair = do
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 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
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 @@ handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
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
index 01bf39b..7a7f90a 100644
--- 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
index 52fa513..38fbf41 100644
--- 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 @@ executable intricacy
, 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 @@ executable intricacy-server
, 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