Server.hs

   1 -- This file is part of Intricacy
   2 -- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
   3 --
   4 -- This program is free software: you can redistribute it and/or modify
   5 -- it under the terms of version 3 of the GNU General Public License as
   6 -- published by the Free Software Foundation, or any later version.
   7 --
   8 -- You should have received a copy of the GNU General Public License
   9 -- along with this program.  If not, see http://www.gnu.org/licenses/.
  10
  11 {-# LANGUAGE CPP                 #-}
  12 {-# LANGUAGE ScopedTypeVariables #-}
  13
  14 module Main where
  15
  16 import           Network.Fancy
  17
  18 import           Control.Applicative
  19 import           Control.Concurrent         (forkIO, threadDelay)
  20 import           Control.Exception.Base     (evaluate)
  21 import           Control.Monad
  22 import           Control.Monad.Catch
  23 import           Control.Monad.IO.Class
  24 import           Control.Monad.Trans
  25 import           Control.Monad.Trans.Except
  26 import           Control.Monad.Trans.Maybe
  27 import           Control.Monad.Trans.Reader
  28 import           Control.Monad.Trans.State
  29 import           Data.Array
  30 import           Data.Bifunctor             (bimap)
  31 import qualified Data.Binary                as B
  32 import qualified Data.ByteString.Char8      as CS
  33 import qualified Data.ByteString.Lazy       as BL
  34 import           Data.Foldable              (for_)
  35 import           Data.Function              (on)
  36 import           Data.List
  37 import           Data.Maybe
  38 import qualified Data.Text                  as TS
  39 import qualified Data.Text.Lazy             as TL
  40 import qualified Data.Text.Short            as TSh
  41 import           Data.Time.Clock
  42 import           Data.Word
  43 import           Pipes
  44 import qualified Pipes.Prelude              as P
  45 import           System.Directory           (renameFile)
  46 import           System.FilePath
  47 import           System.IO
  48 import           System.IO.Error
  49 import           System.Random
  50
  51 import           Data.Time.Format
  52 import           Data.Time.LocalTime
  53 import           Text.Feed.Constructor
  54 import           Text.Feed.Export           (xmlFeed)
  55 import           Text.Feed.Import           (parseFeedFromFile)
  56 import qualified Text.XML                   as XML
  57
  58 import qualified Crypto.Argon2              as A2
  59 import           Crypto.Hash.Algorithms     (SHA256 (..))
  60 import           Crypto.PubKey.RSA          (generate, generateBlinder)
  61 import           Crypto.PubKey.RSA.OAEP     (decrypt, defaultOAEPParams)
  62 import           Crypto.PubKey.RSA.Types    (private_n)
  63
  64 #ifdef SENDMAIL
  65 import           Network.Mail.Mime          (plainPart)
  66 import qualified Network.Mail.SMTP          as SMTP
  67 import qualified Text.Email.Validate
  68 #endif
  69
  70 import           System.Console.GetOpt
  71 import           System.Environment
  72 import           System.Exit
  73
  74 import           AsciiLock
  75 import           Database
  76 import           Frame
  77 import           Lock
  78 import           Maxlocksize
  79 import           Metagame
  80 import           Mundanities
  81 import           Protocol
  82 import           Version
  83
  84 defaultPort = 27001 -- 27001 == ('i'<<8) + 'y'
  85
  86 data Opt = RequestDelay Int | Daemon | LogFile FilePath | Port Int | DBDir FilePath | ServerLockSize Int | FeedPath FilePath | Help | Version
  87     deriving (Eq, Ord, Show)
  88 options =
  89     [ Option ['p'] ["port"] (ReqArg (Port . read) "PORT") $ "TCP port to listen on (default: " ++ show defaultPort ++ ")"
  90     , Option ['P'] ["delay"] (ReqArg (RequestDelay . read) "MICROSECS") "delay before sending response (for testing) (default: 0)"
  91     -- , Option ['d'] ["daemon"] (NoArg Daemon) "Run as daemon"
  92     , Option ['l'] ["logfile"] (ReqArg LogFile "PATH") "Log to file"
  93     , Option ['d'] ["dir"] (ReqArg DBDir "PATH") "directory for server database [default: intricacydb]"
  94     , Option ['s'] ["locksize"] (ReqArg (ServerLockSize . read) "SIZE") "size of locks (only takes effect when creating a new database) [default: 8]"
  95     , Option ['f'] ["feed"] (ReqArg FeedPath "PATH") "write news feed to this path"
  96     , Option ['h'] ["help"] (NoArg Help) "show usage information"
  97     , Option ['v'] ["version"] (NoArg Version) "show version information"
  98     ]
  99
 100 usage :: String
 101 usage = usageInfo header options
 102     where header = "Usage: intricacy-server [OPTION...]"
 103
 104 parseArgs :: [String] -> IO ([Opt],[String])
 105 parseArgs argv =
 106     case getOpt Permute options argv of
 107         (o,n,[]) -> return (o,n)
 108         (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
 109     where header = "Usage: intricacy-server [OPTION...]"
 110
 111 main = do
 112     argv <- getArgs
 113     (opts,_) <- parseArgs argv
 114     {- FIXME: doesn't work
 115     if Daemon `elem` opts
 116         then void $ forkIO $ main' opts
 117         else main' opts
 118     -}
 119     when (Help `elem` opts) $ putStr usage >> exitSuccess
 120     when (Version `elem` opts) $ putStrLn version >> exitSuccess
 121     let delay = fromMaybe 0 $ listToMaybe [ d | RequestDelay d <- opts ]
 122         port = fromMaybe defaultPort $ listToMaybe [ p | Port p <- opts ]
 123         dbpath = fromMaybe "intricacydb" $ listToMaybe [ p | DBDir p <- opts ]
 124         mfeedPath = listToMaybe [ p | FeedPath p <- opts ]
 125         locksize = min maxlocksize $ fromMaybe 8 $ listToMaybe [ s | ServerLockSize s <- opts ]
 126     withDB dbpath $ setDefaultServerInfo locksize >> setKeyPair
 127     writeFile (lockFilePath dbpath) ""
 128     logh <- case listToMaybe [ f | LogFile f <- opts ] of
 129         Nothing   -> return stdout
 130         Just path -> openFile path AppendMode
 131     streamServer serverSpec{address = IPv4 "" port, threading=Threaded} $ handler dbpath delay logh mfeedPath
 132     sleepForever
 133
 134 setDefaultServerInfo locksize = do
 135     alreadySet <- recordExists RecServerInfo
 136     unless alreadySet $ putRecord RecServerInfo (RCServerInfo $ defaultServerInfo locksize)
 137
 138 setKeyPair :: DBM ()
 139 setKeyPair = do
 140     alreadySet <- recordExists RecPublicKey
 141     unless alreadySet $ do
 142         (publicKey, secretKey) <- liftIO $ generate 256 65537
 143         putRecord RecPublicKey $ RCPublicKey publicKey
 144         putRecord RecSecretKey $ RCSecretKey secretKey
 145
 146 -- Note: switching to cryptonite's argon2 implementation would not be
 147 -- straightforwardsly backwards-compatible, the output format is different.
 148 argon2 :: String -> ExceptT String IO String
 149 argon2 s = either (throwE . show) (return . TSh.unpack) $
 150     A2.hashEncoded hashOptions (CS.pack s) (CS.pack salt)
 151     where
 152         salt = "intricacy salt"
 153         -- |default argon2 hash options
 154         hashOptions = A2.HashOptions
 155                     { A2.hashIterations  = 3
 156                     , A2.hashMemory      = 2 ^ 12 -- 4 MiB
 157                     , A2.hashParallelism = 1
 158                     , A2.hashVariant     = A2.Argon2i
 159                     , A2.hashVersion     = A2.Argon2Version13
 160                     , A2.hashLength      = 2 ^ 5 -- 32 bytes
 161                     }
 162
 163
 164 -- | We lock the whole database during each request, using haskell's native
 165 -- file locking, meaning that we have at any time one writer *xor* any number
 166 -- of readers.
 167 withDBLock :: MonadIO m => [Char] -> IOMode -> m b -> m b
 168 withDBLock dbpath lockMode m = do
 169     h <- liftIO $ getDBLock lockMode
 170     ret <- m
 171     liftIO $ hClose h
 172     return ret
 173     where
 174         getDBLock lockMode =
 175             catchIO (openFile (lockFilePath dbpath) lockMode) (\_ -> threadDelay (50*10^3) >> getDBLock lockMode)
 176
 177 lockFilePath dbpath = dbpath ++ [pathSeparator] ++ "lockfile"
 178
 179 logit h s = hPutStrLn h s >> hFlush h
 180
 181 handler :: FilePath -> Int -> Handle -> Maybe FilePath -> Handle -> Address -> IO ()
 182 handler dbpath delay logh mfeedPath hdl addr = handle ((\e -> return ()) :: SomeException -> IO ()) $
 183     handler' hdl addr
 184     where handler' hdl addr = do
 185             response <- handle (\e -> return $ ServerError $ show (e::SomeException)) $ do
 186                 request <- B.decode <$> BL.hGetContents hdl
 187                 let hostname = case addr of
 188                         IP n _    -> n
 189                         IPv4 n _  -> n
 190                         IPv6 n _  -> n
 191                         Unix path -> path
 192                     hashedHostname = take 8 $ hash hostname
 193                 now <- liftIO getCurrentTime
 194                 logit logh $ show now ++ ": " ++ hashedHostname ++ " >>> " ++ showRequest request
 195                 response <- handleRequest dbpath mfeedPath request
 196                 when (delay > 0) $ threadDelay delay
 197                 now' <- liftIO getCurrentTime
 198                 logit logh $ show now' ++ ": " ++ hashedHostname ++ " <<< " ++ showResponse response
 199                 return response
 200             BL.hPut hdl $ B.encode response
 201
 202 showRequest :: ClientRequest -> String
 203 showRequest (ClientRequest ver mauth act) = show ver ++ " "
 204     ++ maybe "" (\(Auth name _) -> "Auth:" ++ name) mauth ++ " "
 205     ++ showAction act
 206 showAction :: Action -> String
 207 showAction (SetLock lock idx soln) = "SetLock " ++ show idx ++ " lock:"
 208     ++ (if not $ validLock $ reframe lock then " [INVALID LOCK] " else "\n" ++ unlines (lockToAscii lock))
 209     ++ "[SOLN]"
 210 showAction (DeclareSolution soln ls target idx) = "DeclareSolution [SOLN] "
 211     ++ unwords [show ls,show target,show idx]
 212 showAction act = show act
 213 showResponse :: ServerResponse -> String
 214 showResponse (ServedLock lock) = "ServedLock lock:\n" ++ unlines (lockToAscii lock)
 215 showResponse (ServedSolution soln) = "ServedSolution [SOLN]"
 216 showResponse resp = show resp
 217
 218 handleRequest :: FilePath -> Maybe FilePath -> ClientRequest -> IO ServerResponse
 219 handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
 220     let lockMode = case action of
 221             Authenticate     -> ReadMode
 222             GetServerInfo    -> ReadMode
 223             GetPublicKey     -> ReadMode
 224             GetLock _        -> ReadMode
 225             GetUserInfo _ _  -> ReadMode
 226             GetRetired _     -> ReadMode
 227             GetSolution _    -> ReadMode
 228             GetRandomNames _ -> ReadMode
 229             _                -> ReadWriteMode
 230
 231     -- Check solutions prior to write-locking database.
 232     -- Slightly awkward, because we have to drop the read lock before
 233     -- acquiring the write lock, so need to check preconditions again once we
 234     -- have the write lock.
 235     withDBLock dbpath ReadMode (runExceptT $ checkRequest Nothing) >>=
 236         either (return . ServerError) (\mCheckedLock ->
 237             withDBLock dbpath lockMode $
 238                 runExceptT (checkRequest mCheckedLock >> handleRequest') >>=
 239                     either (return . ServerError) return)
 240     where
 241         checkRequest mCheckedLock = do
 242             when (pv /= protocolVersion) $ throwE "Bad protocol version"
 243             case action of
 244                 DeclareSolution soln ls target idx -> do
 245                     info <- getUserInfoOfAuth auth
 246                     lock <- getLock ls
 247                     tinfo <- getALock target
 248                     when (ls /= lockSpec tinfo) $ throwE "Lock no longer in use!"
 249                     when (public tinfo) $ throwE "Lock solution already public knowledge!"
 250                     let name = codename info
 251                     let behind = ActiveLock name idx
 252                     when (name `elem` map noteAuthor (lockSolutions tinfo)) $
 253                         throwE "Note already taken on that lock!"
 254                     when (name == lockOwner target) $
 255                         throwE "That's your lock!"
 256                     behindLock <- getALock behind
 257                     when (public behindLock) $ throwE "Your lock is cracked!"
 258                     case mCheckedLock of
 259                         Nothing -> unless (checkSolution lock soln) $ throwE "Bad solution"
 260                         Just lock' -> unless (lock == lock') $ throwE "Lock changed!"
 261                     return $ Just lock
 262                 SetLock lock@(frame,_) idx soln -> do
 263                     ServerInfo serverSize _ <- getServerInfo
 264                     when (frame /= BasicFrame serverSize) $ throwE $
 265                         "Server only accepts size "++show serverSize++" locks."
 266                     unless (validLock $ reframe lock) $ throwE "Invalid lock!"
 267                     when (checkSolved $ reframe lock) $ throwE "Lock not locked!"
 268                     RCLockHashes hashes <- getRecordErrored RecLockHashes
 269                             `catchE` const (return (RCLockHashes []))
 270                     let hashed = hash $ show lock
 271                     when (hashed `elem` hashes) $ throwE "Lock has already been used"
 272                     case mCheckedLock of
 273                         Nothing -> unless (checkSolution lock soln) $ throwE "Bad solution"
 274                         Just lock' -> unless (lock == lock') $ throwE "Lock changed!"
 275                     return $ Just lock
 276                 _ -> return Nothing
 277         handleRequest' =
 278             case action of
 279                 UndefinedAction -> throwE "Request not recognised by this server"
 280                 Authenticate -> do
 281                     checkAuth auth
 282                     return $ ServerMessage $ "Welcome, " ++ authUser (fromJust auth)
 283                 Register -> do
 284                     newUser auth
 285                     doNews $ "New user " ++ authUser (fromJust auth) ++ " registered."
 286                     return ServerAck
 287                 ResetPassword passwd -> resetPassword auth passwd >> return ServerAck
 288                 SetEmail address -> setEmail auth address >> return ServerAck
 289                 GetServerInfo -> ServedServerInfo <$> getServerInfo
 290                 GetPublicKey -> ServedPublicKey <$> getPublicKey
 291                 GetLock ls -> ServedLock <$> getLock ls
 292                 GetRetired name -> ServedRetired <$> getRetired name
 293                 GetUserInfo name mversion -> (do
 294                         RCUserInfo (curV,info) <- getRecordErrored $ RecUserInfo name
 295                         (fromJust<$>)$ runMaybeT $ msum [ do
 296                             v <- MaybeT $ return mversion
 297                             msum [ guard (v >= curV) >> return ServerFresh
 298                                 , do
 299                                     guard (v >= curV - 10)
 300                                     RCUserInfoDeltas deltas <- lift $ getRecordErrored $ RecUserInfoLog name
 301                                     return $ ServedUserInfoDeltas $ take (curV-v) deltas
 302                                 ]
 303                             , return $ ServedUserInfo (curV,info)
 304                             ]
 305                     ) `catchE` \_ -> return ServerCodenameFree
 306                 GetSolution note -> do
 307                     uinfo <- getUserInfoOfAuth auth
 308                     let uname = codename uinfo
 309                     onLinfo <- getALock $ noteOn note
 310                     behindMLinfo <- maybe (return Nothing) ((Just<$>).getALock) $ noteBehind note
 311                     if uname == lockOwner (noteOn note)
 312                         || uname == noteAuthor note
 313                     then ServedSolution <$> getSolution note
 314                     else if case behindMLinfo of
 315                                 Nothing -> True
 316                                 Just behindInfo -> public behindInfo || uname `elem` accessedBy behindInfo
 317                             || note `elem` notesRead uinfo
 318                         then if public onLinfo || uname `elem` accessedBy onLinfo
 319                             then ServedSolution <$> getSolution note
 320                             else throwE "You can't wholly decipher this note - you would need more notes on the same lock."
 321                         else throwE "This note is secured behind a lock you have not opened."
 322                 DeclareSolution soln ls target idx -> do
 323                     info <- getUserInfoOfAuth auth
 324                     let name = codename info
 325                     let behind = ActiveLock name idx
 326                     let note = NoteInfo name (Just behind) target
 327                     erroredDB $ putRecord (RecNote note) (RCSolution soln)
 328                     execStateT (declareNote note behind) [] >>= applyDeltasToRecords
 329                     doNews $ name ++ " declares solution to "
 330                         ++ alockStr target ++ ", securing their note behind "
 331                         ++ alockStr behind ++ "."
 332                     mailDeclaration target behind
 333                     return ServerAck
 334                 SetLock lock@(frame,_) idx soln -> do
 335                     info <- getUserInfoOfAuth auth
 336                     let name = codename info
 337                     let al = ActiveLock name idx
 338                     RCLockHashes hashes <- getRecordErrored RecLockHashes
 339                             `catchE` const (return (RCLockHashes []))
 340                     let hashed = hash $ show lock
 341                     erroredDB $ putRecord RecLockHashes $ RCLockHashes $ hashed:hashes
 342
 343                     ls <- erroredDB $ newLockRecord lock
 344                     let oldLockInfo = userLocks info ! idx
 345                     execStateT (do
 346                             when (isJust oldLockInfo) $
 347                                 lift (getALock al) >>= retireLock
 348                             addDelta name $ PutLock ls idx
 349                         ) [] >>= applyDeltasToRecords
 350
 351                     for_ oldLockInfo $ \oldui -> do
 352                         lss <- getRetired name
 353                         erroredDB $ putRecord (RecRetiredLocks name) $ RCLockSpecs $ lockSpec oldui:lss
 354                     doNews $ "New lock " ++ alockStr al ++ "."
 355                     return ServerAck
 356                 GetRandomNames n -> do
 357                     names <- erroredDB listUsers
 358                     gen <- erroredIO getStdGen
 359                     let l = length names
 360                         namesArray = listArray (0,l-1) names
 361                         negligible name = do
 362                             uinfo <- getUserInfo name
 363                             return $ all (maybe True public . (userLocks uinfo !)) [0..2]
 364
 365                     -- huzzah for pipes!
 366                     shuffled <- P.toListM $
 367                             mapM_ Pipes.yield (nub $ randomRs (0,l-1) gen)
 368                         >-> P.take l -- give up once we've permuted all of [0..l-1]
 369                         >-> P.map (namesArray !)
 370                         >-> P.filterM ((not <$>) . negligible) -- throw away negligibles
 371                         >-> P.take n -- try to take as many as we were asked for
 372                     liftIO newStdGen
 373                     return $ ServedRandomNames shuffled
 374                 _ -> throwE "BUG: bad request"
 375         erroredIO :: IO a -> ExceptT String IO a
 376         erroredIO c = do
 377             ret <- liftIO $ catchIO (Right <$> c) (return.Left)
 378             case ret of
 379                 Left e  -> throwE $ "Server IO error: " ++ show e
 380                 Right x -> return x
 381         erroredDB :: DBM a -> ExceptT String IO a
 382         erroredDB = erroredIO . withDB dbpath
 383         getRecordErrored :: Record -> ExceptT String IO RecordContents
 384         getRecordErrored rec = do
 385             mrc <- lift $ withDB dbpath $ getRecord rec
 386             case mrc of
 387                 Just rc -> return rc
 388                 Nothing -> throwE $ "Bad record on server! Record was: " ++ show rec
 389         getLock ls = do
 390             RCLock lock <- getRecordErrored $ RecLock ls
 391             return lock
 392         getSolution note = do
 393             RCSolution soln <- getRecordErrored $ RecNote note
 394             return soln
 395         getServerInfo = do
 396             RCServerInfo sinfo <- getRecordErrored RecServerInfo
 397             return sinfo
 398         getPublicKey = do
 399             RCPublicKey publicKey <- getRecordErrored RecPublicKey
 400             return publicKey
 401         getRetired name = do
 402             RCLockSpecs lss <- fromMaybe (RCLockSpecs []) <$> erroredDB (getRecord $ RecRetiredLocks name)
 403             return lss
 404         getALock (ActiveLock name idx) = do
 405             info <- getUserInfo name
 406             checkValidLockIndex idx
 407             case ((! idx).userLocks) info of
 408                 Nothing       -> throwE "Lock not set"
 409                 Just lockinfo -> return lockinfo
 410         checkValidLockIndex idx =
 411             unless (0<=idx && idx < maxLocks) $ throwE "Bad lock index"
 412         getUserInfo name = do
 413             RCUserInfo (version,info) <- getRecordErrored $ RecUserInfo name
 414             return info
 415         getUserInfoOfAuth auth = do
 416             checkAuth auth
 417             let Just (Auth name _) = auth
 418             getUserInfo name
 419
 420         decryptPassword :: String -> ExceptT String IO String
 421         decryptPassword pw = do
 422             RCSecretKey secretKey <- getRecordErrored RecSecretKey
 423             blinder <- liftIO . generateBlinder $ private_n secretKey
 424             ExceptT . return . bimap
 425                     (\err -> show err ++ "; try deleting ~/.intricacy/cache ?")
 426                     CS.unpack .
 427                 decrypt (Just blinder) (defaultOAEPParams SHA256) secretKey . CS.pack $ pw
 428             -- XXX: <=intricacy-0.6.2 sends the hashed password unencrypted,
 429             -- but we don't support that anymore
 430         convertLegacyPW :: Codename -> IO ()
 431         convertLegacyPW name = void . runExceptT $ do
 432             RCPasswordLegacy legacyPw <- getRecordErrored (RecPasswordLegacy name)
 433             pwA2 <- argon2 legacyPw
 434             erroredDB $ putRecord (RecPasswordArgon2 name) (RCPasswordArgon2 pwA2)
 435             erroredDB $ delRecord (RecPasswordLegacy name)
 436         checkAuth :: Maybe Auth -> ExceptT String IO ()
 437         checkAuth Nothing = throwE "Authentication required"
 438         checkAuth (Just (Auth name pw)) = do
 439             exists <- checkCodeName name
 440             unless exists $ throwE "No such user"
 441             liftIO $ convertLegacyPW name
 442             pw' <- decryptPassword pw
 443             RCPasswordArgon2 correctPwA2 <- getRecordErrored (RecPasswordArgon2 name)
 444             pwA2 <- argon2 pw'
 445             when (pwA2 /= correctPwA2) $ throwE "Wrong password"
 446         newUser :: Maybe Auth -> ExceptT String IO ()
 447         newUser Nothing = throwE "Require authentication"
 448         newUser (Just (Auth name pw)) = do
 449             exists <- checkCodeName name
 450             when exists $ throwE "Codename taken"
 451             pw' <- decryptPassword pw >>= argon2
 452             erroredDB $ putRecord (RecPasswordArgon2 name) (RCPasswordArgon2 pw')
 453             erroredDB $ putRecord (RecUserInfo name) (RCUserInfo (1,initUserInfo name))
 454             erroredDB $ putRecord (RecUserInfoLog name) (RCUserInfoDeltas [])
 455         resetPassword Nothing _ = throwE "Authentication required"
 456         resetPassword auth@(Just (Auth name _)) newpw = do
 457             checkAuth auth
 458             newpw' <- decryptPassword newpw >>= argon2
 459             erroredDB $ putRecord (RecPasswordArgon2 name) (RCPasswordArgon2 newpw')
 460         setEmail Nothing _ = throwE "Authentication required"
 461         setEmail auth@(Just (Auth name _)) addressStr = do
 462             checkAuth auth
 463 #ifdef SENDMAIL
 464             serverAddr <- erroredDB $ getRecord RecServerEmail
 465             when (isNothing serverAddr) $ throwE "This server is not configured to support email notifications."
 466             let addr = CS.pack addressStr
 467             unless (CS.null addr || Text.Email.Validate.isValid addr) $ throwE "Invalid email address"
 468             erroredDB $ putRecord (RecEmail name) (RCEmail addr)
 469 #else
 470             throwE "This server is not compiled to support email notifications."
 471 #endif
 472         checkCodeName :: Codename -> ExceptT String IO Bool
 473         checkCodeName name = do
 474             unless (validCodeName name) $ throwE "Invalid codename"
 475             liftIO $ withDB dbpath $ do
 476                 ok <- recordExists $ RecPasswordArgon2 name
 477                 oklegacy <- recordExists $ RecPasswordLegacy name
 478                 return $ ok || oklegacy
 479         --- | TODO: journalling so we can survive death during database writes?
 480         applyDeltasToRecords :: [(Codename, UserInfoDelta)] -> ExceptT String IO ()
 481         applyDeltasToRecords nds = sequence_ $ [applyDeltasToRecord name deltas
 482                 | group <- groupBy ((==) `on` fst) nds
 483                 , let name = fst $ head group
 484                 , let deltas = map snd group ]
 485         applyDeltasToRecord name deltas = do
 486             erroredDB $ modifyRecord (RecUserInfoLog name) $
 487                 \(RCUserInfoDeltas deltas') -> RCUserInfoDeltas $ deltas ++ deltas'
 488             erroredDB $ modifyRecord (RecUserInfo name) $
 489                 \(RCUserInfo (v,info)) -> RCUserInfo
 490                     (v+length deltas, applyDeltas info deltas)
 491         declareNote note@(NoteInfo _ _ target) behind@(ActiveLock name idx) = do
 492             accessLock name target =<< getCurrALock target
 493             addDelta (lockOwner target) $ LockDelta (lockIndex target) $ AddSolution note
 494             addDelta name $ LockDelta idx $ AddSecured note
 495             accessed <- accessedBy <$> getCurrALock behind
 496             mapM_ (addReadNote note) (name:accessed)
 497         addReadNote note@(NoteInfo _ _ target) name = do
 498             info <- getCurrUserInfo name
 499             tlock <- getCurrALock target
 500             unless (note `elem` notesRead info) $ do
 501                 addDelta name $ AddRead note
 502                 checkSuffReadNotes target name
 503         accessLock name target@(ActiveLock tname ti) tlock = do
 504             addDelta tname $ LockDelta ti $ AddAccessed name
 505             mapM_ (`addReadNote` name) $ notesSecured tlock
 506         publiciseLock al@(ActiveLock name idx) lock = do
 507             addDelta name $ LockDelta idx SetPublic
 508             retireLock lock
 509         retireLock lock = do
 510             mapM_ scrapNote $ lockSolutions lock
 511             mapM_ publiciseNote $ notesSecured lock
 512         scrapNote note@(NoteInfo _ (Just al@(ActiveLock name idx)) _) = do
 513             addDelta name $ LockDelta idx (DelSecured note)
 514             unreadNote note
 515         scrapNote _ = return ()
 516         unreadNote note@(NoteInfo name (Just al) _) = do
 517             lock <- getCurrALock al
 518             mapM_ (\name' -> addDelta name' (DelRead note)) $ name:accessedBy lock
 519         publiciseNote note@(NoteInfo _ _ al@(ActiveLock name idx)) = do
 520             unreadNote note
 521             addDelta name $ LockDelta idx $ SetPubNote note
 522             publified <- checkSuffPubNotes al
 523             unless publified $ do
 524                 lock <- getCurrALock al
 525                 accessorsOfNotesOnLock <- (++ map noteAuthor (lockSolutions lock)).concat
 526                     <$> sequence
 527                         [ accessedBy <$> getCurrALock behind | NoteInfo _ (Just behind) _ <- lockSolutions lock ]
 528                 forM_ accessorsOfNotesOnLock $ checkSuffReadNotes al
 529         checkSuffReadNotes target name = do
 530             info <- getCurrUserInfo name
 531             tlock <- getCurrALock target
 532             unless (name `elem` accessedBy tlock || public tlock || name == lockOwner target) $ do
 533                 let countRead = fromIntegral $ length $
 534                         filter (\n -> isNothing (noteBehind n) || n `elem` notesRead info) $ lockSolutions tlock
 535                 when (countRead == notesNeeded) $
 536                     accessLock name target tlock
 537         checkSuffPubNotes al@(ActiveLock name idx) = do
 538             lock <- getCurrALock al
 539             let countPub = fromIntegral $ length $
 540                     filter (isNothing.noteBehind) $ lockSolutions lock
 541             if countPub == notesNeeded
 542                 then publiciseLock al lock >> return True
 543                 else return False
 544         -- | XXX we apply deltas right-to-left, so in the order of adding
 545         addDelta name delta = modify ((name,delta):)
 546         getCurrUserInfo name = do
 547             info <- lift $ getUserInfo name
 548             applyDeltas info . map snd . filter ((==name).fst) <$> get
 549         getCurrALock al@(ActiveLock name idx) =
 550              fromJust.(! idx).userLocks <$> getCurrUserInfo name
 551         doNews :: String -> ExceptT String IO ()
 552         doNews news = case mfeedPath of
 553             Nothing -> return ()
 554             Just feedPath -> lift $ void $ forkIO $ do
 555                 let baseFeed = withFeedTitle (TS.pack "Intricacy updates") $ newFeed $ RSSKind Nothing
 556                 feed <- fromMaybe baseFeed <$> parseFeedFromFile feedPath
 557                 time <- formatTime defaultTimeLocale rfc822DateFormat <$> getZonedTime
 558                 let newsText = TS.pack news
 559                     timeText = TS.pack time
 560                     item = withItemTitle newsText $ withItemDescription newsText $
 561                         withItemPubDate timeText $ newItem $ RSSKind Nothing
 562                 -- TODO: purge old entries
 563                 let Right element = XML.fromXMLElement $ xmlFeed $ withFeedLastUpdate timeText $ addItem item feed
 564                     document = XML.Document (XML.Prologue [] Nothing []) element []
 565                 -- | force the feed, so feedPath is closed (lazy IO)
 566                 feedString <- return $! TL.unpack $ XML.renderText XML.def document
 567                 writeFile feedPath feedString
 568 #ifdef SENDMAIL
 569         mailDeclaration target@(ActiveLock name _) behind@(ActiveLock solverName _) = runMaybeT $ do
 570             let makeAddr :: CS.ByteString -> SMTP.Address
 571                 makeAddr bs = SMTP.Address Nothing $ TS.pack $ CS.unpack bs
 572             RCEmail serverAddr <-  MaybeT $ erroredDB $ getRecord RecServerEmail
 573             RCEmail playerAddr <- MaybeT $ erroredDB $ getRecord $ RecEmail name
 574             guard $ not $ CS.null playerAddr
 575             lift.lift $ SMTP.sendMail "localhost" $ SMTP.simpleMail (makeAddr serverAddr)
 576                 [makeAddr playerAddr] [] []
 577                 (TS.pack $ "[Intricacy] " ++ alockStr target ++" solved by " ++ solverName)
 578                 [plainPart $ TL.pack $ "A solution to your lock " ++ alockStr target ++ " has been declared by " ++ solverName ++
 579                     " and secured behind " ++ alockStr behind ++ "." ++
 580                     "\n\n-----\n\nYou received this email from the game Intricacy" ++
 581                     "\n\thttp://sdf.org/~mbays/intricacy ." ++
 582                     "\nYou can disable notifications in-game by pressing 'R' on your home" ++
 583                     "\nscreen and setting an empty address." ++
 584                     "\nAlternatively, just reply to this email with the phrase \"stop bugging me\"." ]
 585 #else
 586         mailDeclaration _ _ = pure ()
 587 #endif