-- This file is part of Intricacy
-- Copyright (C) 2013 Martin Bays <mbays@sdf.org>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of version 3 of the GNU General Public License as
-- published by the Free Software Foundation, or any later version.
--
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see http://www.gnu.org/licenses/.
module Main where
import Network.Fancy
import Control.Concurrent (threadDelay,forkIO)
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.State
import Control.Monad.Trans.Error
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Control.Monad.Trans
import Control.Monad.IO.Class
import System.Random
import Data.Maybe
import Data.Word
import Data.Foldable (for_)
import Data.Time.Clock
import System.IO
import System.FilePath
import System.Directory (renameFile)
import qualified Data.ByteString.Lazy as L
import qualified Data.Binary as B
import Data.Array
import Control.Exception
import System.IO.Error
import Data.List
import Data.Function (on)
import Pipes
import qualified Pipes.Prelude as P
import Text.Feed.Import (parseFeedFromFile)
import Text.Feed.Export (xmlFeed)
import Text.Feed.Constructor
import Text.XML.Light.Output (showTopElement)
import Data.Time.Format
import Data.Time.LocalTime
import System.Environment
import System.Console.GetOpt
import System.Exit
import Protocol
import Metagame
import Lock
import Frame
import Database
import AsciiLock
import Mundanities
import Maxlocksize
import Version
defaultPort = 27001 -- 27001 == ('i'<<8) + 'y'
data Opt = RequestDelay Int | Daemon | LogFile FilePath | Port Int | DBDir FilePath | ServerLockSize Int | FeedPath FilePath | Help | Version
deriving (Eq, Ord, Show)
options =
[ Option ['p'] ["port"] (ReqArg (Port . read) "PORT") $ "TCP port to listen on (default: " ++ show defaultPort ++ ")"
, Option ['P'] ["delay"] (ReqArg (RequestDelay . read) "MICROSECS") "delay before sending response (for testing) (default: 0)"
-- , Option ['d'] ["daemon"] (NoArg Daemon) "Run as daemon"
, Option ['l'] ["logfile"] (ReqArg LogFile "PATH") "Log to file"
, Option ['d'] ["dir"] (ReqArg DBDir "PATH") "directory for server database [default: intricacydb]"
, Option ['s'] ["locksize"] (ReqArg (ServerLockSize . read) "SIZE") "size of locks (only takes effect when creating a new database) [default: 8]"
, Option ['f'] ["feed"] (ReqArg FeedPath "PATH") "write news feed to this path"
, Option ['h'] ["help"] (NoArg Help) "show usage information"
, Option ['v'] ["version"] (NoArg Version) "show version information"
]
usage :: String
usage = usageInfo header options
where header = "Usage: intricacy-server [OPTION...]"
parseArgs :: [String] -> IO ([Opt],[String])
parseArgs argv =
case getOpt Permute options argv of
(o,n,[]) -> return (o,n)
(_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
where header = "Usage: intricacy-server [OPTION...]"
main = do
argv <- getArgs
(opts,_) <- parseArgs argv
{- FIXME: doesn't work
if Daemon `elem` opts
then void $ forkIO $ main' opts
else main' opts
-}
when (Help `elem` opts) $ putStr usage >> exitSuccess
when (Version `elem` opts) $ putStrLn version >> exitSuccess
let delay = fromMaybe 0 $ listToMaybe [ d | RequestDelay d <- opts ]
port = fromMaybe defaultPort $ listToMaybe [ p | Port p <- opts ]
dbpath = fromMaybe "intricacydb" $ listToMaybe [ p | DBDir p <- opts ]
mfeedPath = listToMaybe [ p | FeedPath p <- opts ]
locksize = min maxlocksize $ fromMaybe 8 $ listToMaybe [ s | ServerLockSize s <- opts ]
withDB dbpath $ setDefaultServerInfo locksize
writeFile (lockFilePath dbpath) ""
logh <- case listToMaybe [ f | LogFile f <- opts ] of
Nothing -> return stdout
Just path -> openFile path AppendMode
streamServer serverSpec{address = IPv4 "" port, threading=Threaded} $ handler dbpath delay logh mfeedPath
sleepForever
setDefaultServerInfo locksize = do
alreadySet <- recordExists RecServerInfo
unless alreadySet $ putRecord RecServerInfo (RCServerInfo $ defaultServerInfo locksize)
-- | 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.
withDBLock :: MonadIO m => [Char] -> IOMode -> m b -> m b
withDBLock dbpath lockMode m = do
h <- liftIO $ getDBLock lockMode
ret <- m
liftIO $ hClose h
return ret
where
getDBLock lockMode =
catchIO (openFile (lockFilePath dbpath) lockMode) (\_ -> threadDelay (50*10^3) >> getDBLock lockMode)
lockFilePath dbpath = dbpath ++ [pathSeparator] ++ "lockfile"
logit h s = hPutStrLn h s >> hFlush h
handler :: FilePath -> Int -> Handle -> Maybe FilePath -> Handle -> Address -> IO ()
handler dbpath delay logh mfeedPath hdl addr = handle ((\e -> return ()) :: SomeException -> IO ()) $
handler' hdl addr
where handler' hdl addr = do
response <- handle (\e -> return $ ServerError $ show (e::SomeException)) $ do
request <- B.decode <$> L.hGetContents hdl
let hostname = case addr of
IP n _ -> n
IPv4 n _ -> n
IPv6 n _ -> n
Unix path -> path
hashedHostname = take 8 $ hash hostname
now <- liftIO getCurrentTime
logit logh $ show now ++ ": " ++ hashedHostname ++ " >>> " ++ showRequest request
response <- handleRequest dbpath mfeedPath request
when (delay > 0) $ threadDelay delay
now' <- liftIO getCurrentTime
logit logh $ show now' ++ ": " ++ hashedHostname ++ " <<< " ++ showResponse response
return response
L.hPut hdl $ B.encode response
showRequest :: ClientRequest -> String
showRequest (ClientRequest ver mauth act) = show ver ++ " "
++ maybe "" (\(Auth name pw) -> "Auth:" ++ name ++ ":" ++ take 4 pw) mauth ++ " "
++ showAction act
showAction :: Action -> String
showAction (SetLock lock idx soln) = "SetLock " ++ show idx ++ " lock:"
++ (if not $ validLock $ reframe lock then " [INVALID LOCK] " else "\n" ++ unlines (lockToAscii lock))
++ "[SOLN]"
showAction (DeclareSolution soln ls target idx) = "DeclareSolution [SOLN] "
++ (concat $ intersperse " " $ [show ls,show target,show idx])
showAction act = show act
showResponse :: ServerResponse -> String
showResponse (ServedLock lock) = "ServedLock lock:\n" ++ unlines (lockToAscii lock)
showResponse (ServedSolution soln) = "ServedSolution [SOLN]"
showResponse resp = show resp
handleRequest :: FilePath -> Maybe FilePath -> ClientRequest -> IO ServerResponse
handleRequest dbpath mfeedPath req@(ClientRequest pv auth action) = do
let lockMode = case action of
Authenticate -> ReadMode
GetServerInfo -> ReadMode
GetLock _ -> ReadMode
GetUserInfo _ _ -> ReadMode
GetRetired _ -> ReadMode
GetSolution _ -> ReadMode
GetRandomNames _ -> ReadMode
_ -> ReadWriteMode
-- check solutions prior to write-locking database:
eresp <- runErrorT $ do
withDBLock dbpath ReadMode $ checkRequest
withDBLock dbpath lockMode $ handleRequest'
case eresp of
Left error -> return $ ServerError error
Right resp -> return resp
where
checkRequest = do
when (pv /= protocolVersion) $ throwError "Bad protocol version"
case action of
DeclareSolution soln ls target idx -> do
info <- getUserInfoOfAuth auth
lock <- getLock ls
tinfo <- getALock target
when (ls /= lockSpec tinfo) $ throwError "Lock no longer in use!"
when (public tinfo) $ throwError "Lock solution already public knowledge!"
let name = codename info
let behind = ActiveLock name idx
when (name `elem` map noteAuthor (lockSolutions tinfo)) $
throwError "Note already taken on that lock!"
when (name == lockOwner target) $
throwError "That's your lock!"
behindLock <- getALock behind
when (public behindLock) $ throwError "Your lock is cracked!"
unless (checkSolution lock soln) $ throwError "Bad solution"
SetLock lock@(frame,_) idx soln -> do
ServerInfo serverSize _ <- getServerInfo
when (frame /= BasicFrame serverSize) $ throwError $
"Server only accepts size "++show serverSize++" locks."
unless (validLock $ reframe lock) $ throwError "Invalid lock!"
unless (not.checkSolved $ reframe lock) $ throwError "Lock not locked!"
RCLockHashes hashes <- getRecordErrored RecLockHashes
`catchError` const (return (RCLockHashes []))
let hashed = hash $ show lock
when (hashed `elem` hashes) $ throwError "Lock has already been used"
unless (checkSolution lock soln) $ throwError "Bad solution"
_ -> return ()
handleRequest' =
case action of
Authenticate -> do
checkAuth auth
return $ ServerMessage $ "Welcome, " ++ authUser (fromJust auth)
Register -> do
newUser auth
doNews $ "New user " ++ authUser (fromJust auth) ++ " registered."
return ServerAck
ResetPassword passwd -> resetPassword auth passwd >> return ServerAck
GetServerInfo -> ServedServerInfo <$> getServerInfo
GetLock ls -> ServedLock <$> getLock ls
GetRetired name -> ServedRetired <$> getRetired name
GetUserInfo name mversion -> (do
RCUserInfo (curV,info) <- getRecordErrored $ RecUserInfo name
(fromJust<$>)$ runMaybeT $ msum [ do
v <- MaybeT $ return mversion
msum [ guard (v >= curV) >> return ServerFresh
, do
guard (v >= curV - 10)
RCUserInfoDeltas deltas <- lift $ getRecordErrored $ RecUserInfoLog name
return $ ServedUserInfoDeltas $ take (curV-v) deltas
]
, return $ ServedUserInfo (curV,info)
]
) `catchError` \_ -> return ServerCodenameFree
GetSolution note -> do
uinfo <- getUserInfoOfAuth auth
let uname = codename uinfo
onLinfo <- getALock $ noteOn note
behindMLinfo <- maybe (return Nothing) ((Just<$>).getALock) $ noteBehind note
if uname == lockOwner (noteOn note)
|| uname == noteAuthor note
then ServedSolution <$> getSolution note
else if case behindMLinfo of
Nothing -> True
Just behindInfo -> public behindInfo || uname `elem` accessedBy behindInfo
|| note `elem` notesRead uinfo
then if public onLinfo || uname `elem` accessedBy onLinfo
then ServedSolution <$> getSolution note
else throwError "You can't wholly decipher that note."
else throwError "You don't have access to that note."
DeclareSolution soln ls target idx -> do
info <- getUserInfoOfAuth auth
let name = codename info
let behind = ActiveLock name idx
let note = NoteInfo name (Just behind) target
erroredDB $ putRecord (RecNote note) (RCSolution soln)
execStateT (declareNote note behind) [] >>= applyDeltasToRecords
doNews $ name ++ " declares solution to "
++ alockStr target ++ ", securing their note behind "
++ alockStr behind ++ "."
return ServerAck
SetLock lock@(frame,_) idx soln -> do
info <- getUserInfoOfAuth auth
let name = codename info
let al = ActiveLock name idx
RCLockHashes hashes <- getRecordErrored RecLockHashes
`catchError` const (return (RCLockHashes []))
let hashed = hash $ show lock
erroredDB $ putRecord RecLockHashes $ RCLockHashes $ hashed:hashes
ls <- erroredDB $ newLockRecord lock
let oldLockInfo = userLocks info ! idx
execStateT (do
when (isJust $ oldLockInfo) $
lift (getALock al) >>= retireLock
addDelta name $ PutLock ls idx
) [] >>= applyDeltasToRecords
for_ oldLockInfo $ \oldui -> do
lss <- getRetired name
erroredDB $ putRecord (RecRetiredLocks name) $ RCLockSpecs $ (lockSpec oldui):lss
doNews $ "New lock " ++ alockStr al ++ "."
return ServerAck
GetRandomNames n -> do
names <- erroredDB $ listUsers
gen <- erroredIO $ getStdGen
let l = length names
namesArray = listArray (0,l-1) names
negligible name = do
uinfo <- getUserInfo name
return $ all (maybe True public . (userLocks uinfo !)) [0..2]
-- huzzah for pipes!
shuffled <- P.toListM $
mapM_ Pipes.yield (nub $ randomRs (0,l-1) gen)
>-> P.take l -- give up once we've permuted all of [0..l-1]
>-> P.map (namesArray !)
>-> P.filterM ((not <$>) . negligible) -- throw away negligibles
>-> P.take n -- try to take as many as we were asked for
liftIO newStdGen
return $ ServedRandomNames shuffled
_ -> throwError "BUG: bad request"
erroredIO :: IO a -> ErrorT String IO a
erroredIO c = do
ret <- liftIO $ catchIO (Right <$> c) (return.Left)
case ret of
Left e -> throwError $ "Server IO error: " ++ show e
Right x -> return x
erroredDB :: DBM a -> ErrorT String IO a
erroredDB = erroredIO . withDB dbpath
getRecordErrored :: Record -> ErrorT String IO RecordContents
getRecordErrored rec = do
mrc <- lift $ withDB dbpath $ getRecord rec
case mrc of
Just rc -> return rc
Nothing -> throwError $ "Bad record on server! Record was: " ++ show rec
getLock ls = do
RCLock lock <- getRecordErrored $ RecLock ls
return lock
getSolution note = do
RCSolution soln <- getRecordErrored $ RecNote note
return soln
getServerInfo = do
RCServerInfo sinfo <- getRecordErrored $ RecServerInfo
return sinfo
getRetired name = do
RCLockSpecs lss <- fromMaybe (RCLockSpecs []) <$> (erroredDB $ getRecord $ RecRetiredLocks name)
return lss
getALock (ActiveLock name idx) = do
info <- getUserInfo name
checkValidLockIndex idx
case ((!idx).userLocks) info of
Nothing -> throwError "Lock not set"
Just lockinfo -> return lockinfo
checkValidLockIndex idx =
unless (0<=idx && idx < maxLocks) $ throwError "Bad lock index"
getUserInfo name = do
RCUserInfo (version,info) <- getRecordErrored $ RecUserInfo name
return info
getUserInfoOfAuth auth = do
checkAuth auth
let Just (Auth name _) = auth
getUserInfo name
checkAuth :: Maybe Auth -> ErrorT String IO ()
checkAuth Nothing = throwError "Authentication required"
checkAuth (Just (Auth name pw)) = do
exists <- checkCodeName name
unless exists $ throwError "No such user"
RCPassword pw' <- getRecordErrored (RecPassword name)
when (pw /= pw') $ throwError "Wrong password"
newUser :: Maybe Auth -> ErrorT String IO ()
newUser Nothing = throwError "Require authentication"
newUser (Just (Auth name pw)) = do
exists <- checkCodeName name
when exists $ throwError "Codename taken"
erroredDB $ putRecord (RecPassword name) (RCPassword pw)
erroredDB $ putRecord (RecUserInfo name) (RCUserInfo $ (1,initUserInfo name))
erroredDB $ putRecord (RecUserInfoLog name) (RCUserInfoDeltas [])
resetPassword Nothing pw = throwError "Authentication required"
resetPassword auth@(Just (Auth name _)) newpw = do
checkAuth auth
erroredDB $ putRecord (RecPassword name) (RCPassword newpw)
checkCodeName :: Codename -> ErrorT String IO Bool
checkCodeName name = do
unless (validCodeName name) $ throwError "Invalid codename"
liftIO $ withDB dbpath $ recordExists $ RecPassword name
--- | TODO: journalling so we can survive death during database writes?
applyDeltasToRecords :: [(Codename, UserInfoDelta)] -> ErrorT String IO ()
applyDeltasToRecords nds = sequence_ $ [applyDeltasToRecord name deltas
| group <- groupBy ((==) `on` fst) nds
, let name = fst $ head group
, let deltas = map snd group ]
applyDeltasToRecord name deltas = do
erroredDB $ modifyRecord (RecUserInfoLog name) $
\(RCUserInfoDeltas deltas') -> RCUserInfoDeltas $ deltas ++ deltas'
erroredDB $ modifyRecord (RecUserInfo name) $
\(RCUserInfo (v,info)) -> RCUserInfo $
(v+length deltas, applyDeltas info deltas)
declareNote note@(NoteInfo _ _ target) behind@(ActiveLock name idx) = do
accessLock name target =<< getCurrALock target
addDelta (lockOwner target) $ LockDelta (lockIndex target) $ AddSolution note
addDelta name $ LockDelta idx $ AddSecured note
accessed <- accessedBy <$> getCurrALock behind
mapM_ (addReadNote note) (name:accessed)
addReadNote note@(NoteInfo _ _ target) name = do
info <- getCurrUserInfo name
tlock <- getCurrALock target
unless (note `elem` notesRead info) $ do
addDelta name $ AddRead note
checkSuffReadNotes target name
accessLock name target@(ActiveLock tname ti) tlock = do
addDelta tname $ LockDelta ti $ AddAccessed name
mapM_ (`addReadNote` name) $ notesSecured tlock
publiciseLock al@(ActiveLock name idx) lock = do
addDelta name $ LockDelta idx SetPublic
retireLock lock
retireLock lock = do
mapM_ scrapNote $ lockSolutions lock
mapM_ publiciseNote $ notesSecured lock
scrapNote note@(NoteInfo _ (Just al@(ActiveLock name idx)) _) = do
addDelta name $ LockDelta idx (DelSecured note)
unreadNote note
scrapNote _ = return ()
unreadNote note@(NoteInfo name (Just al) _) = do
lock <- getCurrALock al
mapM_ (\name' -> addDelta name' (DelRead note)) $ name:(accessedBy lock)
publiciseNote note@(NoteInfo _ _ al@(ActiveLock name idx)) = do
unreadNote note
addDelta name $ LockDelta idx $ SetPubNote note
publified <- checkSuffPubNotes al
unless publified $ do
lock <- getCurrALock al
accessorsOfNotesOnLock <- ((++ map noteAuthor (lockSolutions lock)).concat)
<$> (sequence
[ accessedBy <$> getCurrALock behind | NoteInfo _ (Just behind) _ <- lockSolutions lock ] )
forM_ accessorsOfNotesOnLock $ checkSuffReadNotes al
checkSuffReadNotes target name = do
info <- getCurrUserInfo name
tlock <- getCurrALock target
unless (name `elem` accessedBy tlock || public tlock || name == lockOwner target) $ do
when (countRead info tlock == notesNeeded) $
accessLock name target tlock
checkSuffPubNotes al@(ActiveLock name idx) = do
info <- getCurrUserInfo name
let Just lock = userLocks info ! idx
let countPub = fromIntegral $ length $
filter (isNothing.noteBehind) $ lockSolutions lock
if (countPub == notesNeeded)
then publiciseLock al lock >> return True
else return False
-- | XXX we apply deltas right-to-left, so in the order of adding
addDelta name delta = modify ((name,delta):)
getCurrUserInfo name = do
info <- lift $ getUserInfo name
(applyDeltas info . map snd . filter ((==name).fst)) <$> get
getCurrALock al@(ActiveLock name idx) =
(fromJust.(!idx).userLocks) <$> getCurrUserInfo name
doNews news = case mfeedPath of
Nothing -> return ()
Just feedPath -> lift $ void $ forkIO $ do
let baseFeed = withFeedTitle "Intricacy updates" $ newFeed $ RSSKind Nothing
feed <- (parseFeedFromFile feedPath) `catchAll`
(const $ return baseFeed)
time <- formatTime defaultTimeLocale rfc822DateFormat <$> getZonedTime
let item = withItemTitle news $ withItemDescription news $
withItemPubDate time $ newItem $ RSSKind Nothing
-- TODO: purge old entries
writeFile feedPath $ showTopElement $ xmlFeed $
withFeedLastUpdate time $ addItem item feed