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